├── .gitignore ├── .vscode └── settings.json ├── Setup.hs ├── ChangeLog.md ├── test └── Spec.hs ├── .gitmodules ├── stack.yaml ├── .circleci └── config.yml ├── LICENSE ├── package.yaml ├── README.md ├── src └── Language │ ├── Elm │ └── LSP │ │ └── Diagnostics.hs │ └── Elm.hs └── app └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | /elm-language-server.cabal 3 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "editor.tabSize": 4, 3 | } -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for elm-language-server 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "elm-compiler-library"] 2 | path = elm-compiler-library 3 | url = https://github.com/matheus23/elm-compiler-library 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file contains EXACT dependencies to produce a reproducible build 2 | 3 | # LTS 11.22 is the latest one working for elm/compiler 4 | # which means ghc-8.2.2 5 | resolver: lts-11.22 6 | 7 | packages: 8 | - '.' 9 | - './elm-compiler-library' 10 | 11 | extra-deps: 12 | # Change these to use later versions (they are not part of the lts) 13 | - haskell-lsp-0.8.0.0 14 | - haskell-lsp-types-0.8.0.0 15 | - sorted-list-0.2.1.0 16 | - git: https://github.com/avh4/elm-format.git 17 | commit: 0.8.0 18 | - indents-0.3.3 19 | - concatenative-1.0.1 20 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: fpco/stack-build:lts-11.22 6 | steps: 7 | - checkout 8 | - run: 9 | name: Pull Git Submodules 10 | command: git submodule sync --recursive && git submodule update --recursive --init 11 | 12 | - restore_cache: 13 | keys: 14 | - stack-work-v1-{{ checksum "package.yaml" }} 15 | - stack-work-v1 16 | - stack-work-elm-library-v1-{{ checksum "elm-compiler-library/elm.cabal" }} 17 | - stack-work-elm-library-v1 18 | - stack-home 19 | 20 | - run: 21 | name: Configuration 22 | # system-ghc: the lts-11.22 image has ghc 8.2.2 pre-installed 23 | command: stack config set system-ghc --global true 24 | 25 | - run: 26 | name: Install 27 | command: stack install 28 | 29 | - save_cache: 30 | key: stack-work-v1-{{ checksum "package.yaml" }} 31 | paths: 32 | - .stack-work/ 33 | - save_cache: 34 | key: stack-work-elm-library-v1-{{ checksum "elm-compiler-library/elm.cabal" }} 35 | paths: 36 | - elm-compiler-library/.stack-work/ 37 | - save_cache: 38 | key: stack-home 39 | paths: 40 | - ~/.stack/ 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Martin Norbäck Olivers (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: elm-language-server 2 | version: 0.1.0.0 3 | github: "elm-tooling/elm-language-server" 4 | license: BSD3 5 | author: "Martin Norbäck Olivers" 6 | maintainer: "martin@norpan.org" 7 | copyright: "2018 Martin Norbäck Olivers" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - Glob 24 | - aeson 25 | - base >= 4.7 && < 5 26 | - bytestring 27 | - containers 28 | - data-default 29 | - directory 30 | - elm 31 | - elm-format 32 | - filepath 33 | - haskell-lsp 34 | - haskell-lsp-types 35 | - hslogger 36 | - lens >= 4.15.2 37 | - mtl 38 | - network-uri 39 | - parsec 40 | - stm 41 | - text 42 | - time 43 | - transformers 44 | - unordered-containers 45 | - vector 46 | - yi-rope 47 | - optparse-applicative # for parsing commandline arguments 48 | 49 | library: 50 | source-dirs: 51 | - src 52 | 53 | executables: 54 | elm-language-server: 55 | main: Main.hs 56 | source-dirs: app 57 | ghc-options: 58 | - -threaded 59 | - -rtsopts 60 | - -with-rtsopts=-N 61 | dependencies: 62 | - elm-language-server 63 | 64 | tests: 65 | elm-language-server-test: 66 | main: Spec.hs 67 | source-dirs: test 68 | ghc-options: 69 | - -threaded 70 | - -rtsopts 71 | - -with-rtsopts=-N 72 | dependencies: 73 | - elm-language-server 74 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # elm-language-server-haskell (archived) 2 | 3 | **NOTE**: The repository [elm-language-server](https://github.com/elm-tooling/elm-language-server) is actively maintained. This repository is currently *not maintained*. 4 | 5 | --- 6 | 7 | First attempt to write a language server for Elm. 8 | 9 | See https://microsoft.github.io/language-server-protocol/specification for 10 | a description of the protocol. 11 | 12 | ## Features 13 | * Diagnostics 14 | 15 | If you want to work on more, please reach out and create an issue, before you start working on it. 16 | 17 | ## Conceptual workings of the language server 18 | The editor should start one language server for each Elm project (there may be multiple). `rootPath` should be set to the location of the `elm.json` file. 19 | * On the initialize notification, the language server will copy all files in the project to a temporary directory. This is so that we can handle open files by saving them there. It will then compile all files in the project, to get diagnostics. It will then send diagnostics for all files to the editor. 20 | * When a file is changed in the editor, we change it in our copy, and recompile everything to get new diagnostics. 21 | 22 | ## Libraries used 23 | * haskell-lsp 24 | * json-rpc-server 25 | * elm-compiler-library (which is a version of elm-compiler) 26 | 27 | ## Notes 28 | * Code formatted using `hlint` 29 | 30 | ## Building 31 | Clone the repository and its subrepositories: 32 | * `git clone https://github.com/elm-tooling/elm-language-server` 33 | * `git submodule update --init --recursive` 34 | Install ghc and dependencies. You need to have [stack](https://www.haskellstack.org) installed 35 | * `stack setup` 36 | * `stack install` 37 | 38 | ## Contributing 39 | * [Elm Language Server - Requirements](https://docs.google.com/document/d/1ETeZeN17hqM4yui4iqBv1jwO8HryDZyel2kdcxTCGGA/edit) 40 | * Get information about contributing on the [\#elm-language-server channel](https://elmlang.slack.com/messages/elm-language-server) in the elm slack. 41 | -------------------------------------------------------------------------------- /src/Language/Elm/LSP/Diagnostics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PackageImports #-} 4 | 5 | module Language.Elm.LSP.Diagnostics where 6 | 7 | import Control.Lens 8 | import Control.Monad 9 | import Control.Monad.IO.Class 10 | import Control.Monad.Reader 11 | import Control.Monad.STM 12 | import qualified Data.Aeson as Json 13 | import qualified Data.HashMap.Strict as HashMap 14 | import qualified Data.Map as Map 15 | import System.FilePath (()) 16 | import qualified Data.Text as T 17 | import qualified Data.Text.IO as T 18 | import qualified Data.Text.Encoding as T 19 | import Data.Maybe 20 | 21 | import qualified Language.Haskell.LSP.Control as LSP.Control 22 | import qualified Language.Haskell.LSP.Core as LSP.Core 23 | import Language.Haskell.LSP.Diagnostics 24 | import Language.Haskell.LSP.Messages 25 | import qualified Language.Haskell.LSP.Types as LSP 26 | import qualified Language.Haskell.LSP.Types.MessageFuncs as LSP 27 | import qualified Language.Haskell.LSP.Types.Lens as LSP 28 | import qualified Language.Haskell.LSP.Utility as LSP 29 | import Language.Haskell.LSP.VFS 30 | 31 | -- ELM COMPILER MODULES 32 | import qualified Elm.Compiler 33 | import qualified Elm.Compiler.Module 34 | import qualified Elm.Interface 35 | import qualified Elm.Package 36 | import qualified Elm.Project.Json 37 | import qualified Elm.Name 38 | import qualified AST.Optimized 39 | import qualified File.Args 40 | import qualified File.Compile 41 | import qualified File.Crawl 42 | import qualified File.Plan 43 | import qualified Reporting.Progress.Json 44 | import qualified Reporting.Progress.Terminal 45 | import qualified Reporting.Error 46 | import qualified Reporting.Render.Code 47 | import qualified Reporting.Report 48 | import qualified Reporting.Progress 49 | import qualified Reporting.Task 50 | import qualified Reporting.Warning 51 | import qualified Reporting.Result 52 | import qualified Reporting.Render.Type.Localizer 53 | import qualified Reporting.Doc 54 | import qualified Reporting.Exit 55 | import qualified "elm" Reporting.Region -- would conflict with elm-format's Reporting.Region 56 | import qualified Stuff.Verify 57 | 58 | import qualified Language.Elm as Elm 59 | 60 | -- | The monad used in the reactor 61 | type R c a = ReaderT (LSP.Core.LspFuncs c) IO a 62 | 63 | publishDiagnostics :: Int -> LSP.Uri -> LSP.TextDocumentVersion -> DiagnosticsBySource -> R () () 64 | publishDiagnostics maxToPublish uri v diags = do 65 | lf <- ask 66 | liftIO $ (LSP.Core.publishDiagnosticsFunc lf) maxToPublish uri v diags 67 | 68 | showMessageNotification :: LSP.MessageType -> T.Text -> R () () 69 | showMessageNotification messageType text = do 70 | lf <- ask 71 | liftIO $ (LSP.Core.sendFunc lf) (NotShowMessage (LSP.fmServerShowMessageNotification messageType text)) 72 | 73 | typeCheckAndReportDiagnostics :: R () () 74 | typeCheckAndReportDiagnostics = do 75 | lf <- ask 76 | case LSP.Core.rootPath lf of 77 | Nothing -> 78 | liftIO $ LSP.logm "NO ROOTPATH" 79 | 80 | Just root -> do 81 | result <- liftIO $ Elm.typeCheckFiles root 82 | case result of 83 | Right answers -> 84 | reportAnswers root answers 85 | 86 | Left exit -> 87 | showMessageNotification LSP.MtError (T.pack (Reporting.Exit.toString exit)) 88 | 89 | sendReportAsDiagnostics :: FilePath -> Reporting.Report.Report -> R () () 90 | sendReportAsDiagnostics filePath report = do 91 | let diags = [reportToDiagnostic report] 92 | let fileUri = LSP.filePathToUri filePath 93 | publishDiagnostics 100 fileUri (Just 0) (partitionBySource diags) 94 | 95 | reportToDiagnostic :: Reporting.Report.Report -> LSP.Diagnostic 96 | reportToDiagnostic (Reporting.Report.Report title region suggestions messageDoc) = 97 | let 98 | translatePosition (Reporting.Region.Position line column) = LSP.Position (line - 1) (column - 1) -- elm uses 1-based indices (for being human friendly) 99 | (Reporting.Region.Region start end) = region 100 | in 101 | LSP.Diagnostic 102 | (LSP.Range (translatePosition start) (translatePosition end)) 103 | (Just LSP.DsError) -- severity 104 | Nothing -- code 105 | (Just "ElmLS") -- source 106 | (T.pack (Reporting.Doc.toString messageDoc)) -- TODO: The messageDoc also shows the source code, which is not necessary for diagnostics 107 | (Just (LSP.List [])) 108 | 109 | reportAnswers :: FilePath -> Elm.CheckingAnswers -> R () () 110 | reportAnswers rootPath checkingAnswers = do 111 | Map.traverseWithKey reportModule checkingAnswers 112 | return () 113 | where 114 | reportModule moduleName result = 115 | case result of 116 | Left (Elm.TypeCheckFailure path errors) -> 117 | let 118 | fileUri = LSP.filePathToUri (rootPath path) 119 | diagnostics = map reportToDiagnostic errors 120 | in 121 | publishDiagnostics 200 fileUri Nothing (partitionBySource diagnostics) 122 | 123 | Right _ -> return () 124 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE PackageImports #-} 6 | 7 | module Main 8 | ( main 9 | ) where 10 | 11 | import Control.Concurrent 12 | import Control.Concurrent.STM.TChan 13 | import qualified Control.Exception as Exception 14 | import Control.Lens 15 | import Control.Monad 16 | import Control.Monad.IO.Class 17 | import Control.Monad.Reader 18 | import Control.Monad.STM 19 | import qualified Data.Aeson as Json 20 | import Data.Default 21 | import qualified Data.HashMap.Strict as HashMap 22 | import qualified Data.Map as Map 23 | import System.FilePath (()) 24 | import qualified System.FilePath.Glob as Glob 25 | import System.Posix.Types 26 | import qualified Data.Text as T 27 | import qualified Data.Text.IO as T 28 | import Data.Maybe 29 | import Data.Semigroup 30 | import qualified Language.Haskell.LSP.Control as LSP.Control 31 | import qualified Language.Haskell.LSP.Core as LSP.Core 32 | import Language.Haskell.LSP.Diagnostics 33 | import Language.Haskell.LSP.Messages 34 | import qualified Language.Haskell.LSP.Types as LSP 35 | import qualified Language.Haskell.LSP.Types.Lens as LSP 36 | import qualified Language.Haskell.LSP.Utility as LSP 37 | import Language.Haskell.LSP.VFS 38 | import System.Exit 39 | import qualified System.Log.Logger as L 40 | import qualified Yi.Rope as Yi 41 | import Options.Applicative 42 | import qualified Data.Time.LocalTime as Time 43 | import qualified Data.Time.Format as Time 44 | 45 | 46 | -- ELM COMPILER MODULES 47 | import qualified Elm.Compiler 48 | import qualified Elm.Compiler.Module 49 | import qualified Elm.Package 50 | import qualified Elm.Project.Json 51 | import qualified File.Args 52 | import qualified File.Compile 53 | import qualified File.Crawl 54 | import qualified File.Plan 55 | import qualified Reporting.Progress.Json 56 | import qualified Reporting.Task 57 | import qualified Reporting.Doc 58 | import qualified Reporting.Error 59 | import qualified Reporting.Render.Code 60 | import qualified Reporting.Report 61 | import qualified "elm" Reporting.Region -- would conflict with elm-format's Reporting.Region 62 | import qualified Stuff.Verify 63 | 64 | import qualified Language.Elm.LSP.Diagnostics as Diagnostics 65 | 66 | data CommandLineOptions 67 | = CommandLineOptions 68 | { serverLogFile :: Maybe FilePath 69 | , sessionLogFile :: Maybe FilePath 70 | } 71 | 72 | commandLineOptionsParser :: String -> Parser CommandLineOptions 73 | commandLineOptionsParser logSuffix = CommandLineOptions 74 | <$> optional (strOption 75 | ( long "server-log-file" 76 | <> short 'l' 77 | <> metavar "LOGFILE" 78 | <> help "Log file used for general server logging, defaults to stdout" 79 | )) 80 | 81 | <*> optional (strOption 82 | ( long "session-log-file" 83 | <> metavar "SESSIONLOGFILE" 84 | <> help "Log file used for session server logging, defaults to stdout" 85 | )) 86 | 87 | commandLineOptions :: String -> ParserInfo CommandLineOptions 88 | commandLineOptions logSuffix = info (commandLineOptionsParser logSuffix <**> helper) 89 | ( fullDesc 90 | <> header "elm-language-server" 91 | <> progDesc "A Language Server Protocol Implementation for the Elm Language (see https://elm-lang.org)" 92 | ) 93 | 94 | main :: IO () 95 | main = do 96 | zonedTime <- Time.getZonedTime 97 | let isoFormat = Time.iso8601DateFormat (Just "%H:%M:%S") 98 | 99 | opts <- execParser (commandLineOptions (Time.formatTime Time.defaultTimeLocale isoFormat zonedTime)) 100 | run opts (return ()) >>= \case 101 | 0 -> exitSuccess 102 | c -> exitWith . ExitFailure $ c 103 | 104 | run :: CommandLineOptions -> IO () -> IO Int 105 | run opts dispatcherProc = flip Exception.catches handlers $ do 106 | rin <- atomically newTChan :: IO (TChan ReactorInput) 107 | let dp lf = do 108 | _rpid <- forkIO $ reactor lf rin 109 | dispatcherProc 110 | return Nothing 111 | flip Exception.finally finalProc $ do 112 | LSP.Core.setupLogger (serverLogFile opts) [] L.DEBUG 113 | LSP.Control.run 114 | (return (Right ()), dp) 115 | (lspHandlers rin) 116 | lspOptions 117 | (sessionLogFile opts) 118 | where 119 | handlers = [Exception.Handler ioExcept, Exception.Handler someExcept] 120 | finalProc = L.removeAllHandlers 121 | ioExcept (e :: Exception.IOException) = print e >> return 1 122 | someExcept (e :: Exception.SomeException) = print e >> return 1 123 | 124 | -- The reactor is a process that serialises and buffers all requests from the 125 | -- LSP client, so they can be sent to the backend compiler one at a time, and a 126 | -- reply sent. 127 | data ReactorInput = 128 | HandlerRequest FromClientMessage -- ^ injected into the reactor input by each of the individual callback handlers 129 | 130 | -- | The monad used in the reactor 131 | type R c a = ReaderT (LSP.Core.LspFuncs c) IO a 132 | 133 | -- | The single point that all events flow through, allowing management of state 134 | -- to stitch replies and requests together from the two asynchronous sides: lsp 135 | -- server and backend compiler 136 | reactor :: LSP.Core.LspFuncs () -> TChan ReactorInput -> IO () 137 | reactor lf inp = 138 | flip runReaderT lf $ forever $ do 139 | inval <- liftIO $ atomically $ readTChan inp 140 | case inval of 141 | HandlerRequest (RspFromClient rm) -> 142 | liftIO $ LSP.logs $ "reactor:got RspFromClient:" ++ show rm 143 | 144 | HandlerRequest (NotInitialized _notification) -> 145 | Diagnostics.typeCheckAndReportDiagnostics 146 | 147 | HandlerRequest (NotDidSaveTextDocument notification ) -> do 148 | let fileUri = notification ^. LSP.params . LSP.textDocument . LSP.uri 149 | let filePath = LSP.uriToFilePath fileUri 150 | lf <- ask 151 | liftIO $ LSP.Core.flushDiagnosticsBySourceFunc lf 200 (Just "ElmLS") 152 | Diagnostics.typeCheckAndReportDiagnostics 153 | 154 | syncOptions :: LSP.TextDocumentSyncOptions 155 | syncOptions = LSP.TextDocumentSyncOptions 156 | { LSP._openClose = Just False 157 | , LSP._change = Just LSP.TdSyncNone 158 | , LSP._willSave = Just False 159 | , LSP._willSaveWaitUntil = Just False 160 | , LSP._save = Just $ LSP.SaveOptions $ Just False 161 | } 162 | 163 | lspOptions :: LSP.Core.Options 164 | lspOptions = def 165 | { LSP.Core.textDocumentSync = Just syncOptions } 166 | 167 | lspHandlers :: TChan ReactorInput -> LSP.Core.Handlers 168 | lspHandlers rin = def 169 | { LSP.Core.initializedHandler = Just $ passHandler rin NotInitialized 170 | , LSP.Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument 171 | } 172 | 173 | passHandler :: TChan ReactorInput -> (a -> FromClientMessage) -> LSP.Core.Handler a 174 | passHandler rin c notification = 175 | atomically $ writeTChan rin (HandlerRequest (c notification)) 176 | -------------------------------------------------------------------------------- /src/Language/Elm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE PackageImports #-} 3 | module Language.Elm where 4 | 5 | import Control.Concurrent (forkIO) 6 | import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar) 7 | import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan, getChanContents) 8 | import Control.Monad.IO.Class 9 | import Control.Monad 10 | import System.FilePath (()) 11 | import qualified System.FilePath.Glob as Glob 12 | import qualified Data.Map as Map 13 | import qualified Data.ByteString as BS 14 | import qualified Data.Text as T 15 | import qualified Data.Text.IO as T 16 | import qualified Data.Text.Encoding as T 17 | import Data.Maybe 18 | 19 | -- ELM COMPILER MODULES 20 | import qualified Compile 21 | import qualified Parse.Parse 22 | import qualified Canonicalize.Module 23 | import qualified Elm.Compiler 24 | import qualified Elm.Compiler.Module 25 | import qualified Elm.Interface 26 | import qualified Elm.Package 27 | import qualified Elm.Project.Json 28 | import qualified Elm.Name 29 | import qualified AST.Optimized 30 | import qualified File.Args 31 | import qualified File.Compile 32 | import qualified File.Crawl 33 | import qualified File.Plan 34 | import qualified Reporting.Progress.Json 35 | import qualified Reporting.Progress.Terminal 36 | import qualified Reporting.Task 37 | import qualified Reporting.Doc 38 | import qualified Reporting.Error 39 | import qualified Reporting.Render.Code 40 | import qualified Reporting.Report 41 | import qualified Reporting.Progress 42 | import qualified Reporting.Task 43 | import qualified Reporting.Warning 44 | import qualified Reporting.Result 45 | import qualified Reporting.Exit.Crawl 46 | import qualified Reporting.Exit 47 | import qualified Reporting.Render.Type.Localizer 48 | import qualified "elm" Reporting.Region -- would conflict with elm-format's Reporting.Region 49 | import qualified Stuff.Verify 50 | 51 | instance Show Elm.Name.Name where 52 | show = Elm.Name.toString 53 | 54 | instance Show Elm.Compiler.Module.Canonical where 55 | show (Elm.Compiler.Module.Canonical pkgName moduleName) = show pkgName ++ ":" ++ show moduleName 56 | 57 | instance Show Elm.Package.Name where 58 | show (Elm.Package.Name author name) = T.unpack author ++ "/" ++ T.unpack name 59 | 60 | data TypeCheckSuccess = TypeCheckSuccess 61 | { interface :: Elm.Interface.Interface 62 | } 63 | 64 | data TypeCheckFailure = TypeCheckFailure 65 | { sourcePath :: FilePath 66 | , errors :: [Reporting.Report.Report] 67 | } 68 | 69 | type CheckingAnswer = Either TypeCheckFailure TypeCheckSuccess 70 | type CheckingAnswers = Map.Map Elm.Compiler.Module.Raw CheckingAnswer 71 | 72 | -- Use Elm Compiler to typecheck files 73 | -- Arguments are root (where elm.json lives) and filenames (or []) 74 | typeCheckFiles :: MonadIO m => String -> m (Either Reporting.Exit.Exit CheckingAnswers) 75 | typeCheckFiles root = 76 | liftIO $ Reporting.Task.tryWithError Reporting.Progress.silentReporter $ do 77 | project <- Elm.Project.Json.read (root "elm.json") 78 | Elm.Project.Json.check project 79 | summary <- Stuff.Verify.verify root project 80 | -- get files from the project 81 | files <- liftIO $ getElmFiles project 82 | 83 | args <- File.Args.fromPaths summary files 84 | graph <- File.Crawl.crawl summary args 85 | (dirtyModules, interfaces) <- File.Plan.plan Nothing summary graph 86 | 87 | answers <- liftIO $ do 88 | mvar <- newEmptyMVar 89 | iMVar <- newMVar interfaces 90 | answerMVars <- Map.traverseWithKey (compileModule project mvar iMVar) dirtyModules 91 | putMVar mvar answerMVars 92 | traverse readMVar answerMVars 93 | 94 | return (fmap computeInterfaceOrErrors answers) 95 | 96 | computeInterfaceOrErrors :: File.Compile.Answer -> CheckingAnswer 97 | computeInterfaceOrErrors answer = 98 | case answer of 99 | File.Compile.Blocked -> 100 | Left (TypeCheckFailure "" []) 101 | 102 | File.Compile.Bad path timeStamp source errors -> 103 | Left (TypeCheckFailure path (compilerErrorsToReports source errors)) 104 | 105 | File.Compile.Good (Elm.Compiler.Artifacts interface output documentation) -> 106 | Right (TypeCheckSuccess interface) 107 | 108 | compilerErrorsToReports :: BS.ByteString -> [Elm.Compiler.Error] -> [Reporting.Report.Report] 109 | compilerErrorsToReports sourceRaw errors = 110 | let 111 | source = Reporting.Render.Code.toSource (T.decodeUtf8 sourceRaw) 112 | in 113 | concatMap (Reporting.Error.toReports source) errors 114 | 115 | compileModule 116 | :: Elm.Project.Json.Project 117 | -> MVar (Map.Map Elm.Compiler.Module.Raw (MVar File.Compile.Answer)) 118 | -> MVar Elm.Interface.Interfaces 119 | -> Elm.Compiler.Module.Raw 120 | -> File.Plan.Info 121 | -> IO (MVar File.Compile.Answer) 122 | compileModule project answersMVar ifacesMVar name info = do 123 | mvar <- newEmptyMVar 124 | void $ forkIO $ 125 | do answers <- readMVar answersMVar 126 | blocked <- File.Compile.isBlocked answers info 127 | if blocked 128 | then putMVar mvar File.Compile.Blocked 129 | else 130 | do let pkg = Elm.Project.Json.getName project 131 | let imports = File.Compile.makeImports project info 132 | ifaces <- readMVar ifacesMVar 133 | let source = File.Plan._src info 134 | case customCompile pkg imports ifaces source of 135 | (_warnings, Left errors) -> do 136 | let time = File.Plan._time info 137 | let path = File.Plan._path info 138 | putMVar mvar (File.Compile.Bad path time source errors) 139 | 140 | (_warnings, Right result@(Compile.Artifacts elmi _ _)) -> do 141 | let canonicalName = Elm.Compiler.Module.Canonical pkg name 142 | lock <- takeMVar ifacesMVar 143 | putMVar ifacesMVar (Map.insert canonicalName elmi lock) 144 | putMVar mvar (File.Compile.Good result) 145 | 146 | return mvar 147 | 148 | customCompile 149 | :: Elm.Package.Name 150 | -> Map.Map Elm.Compiler.Module.Raw Elm.Compiler.Module.Canonical 151 | -> Map.Map Elm.Compiler.Module.Canonical Elm.Compiler.Module.Interface 152 | -> BS.ByteString 153 | -> ([Reporting.Warning.Warning], Either [Reporting.Error.Error] Elm.Compiler.Artifacts) 154 | customCompile pkg importDict interfaces source = 155 | Reporting.Result.run $ do 156 | valid <- Reporting.Result.mapError Reporting.Error.Syntax $ 157 | Parse.Parse.program pkg source 158 | 159 | canonical <- Reporting.Result.mapError Reporting.Error.Canonicalize $ 160 | Canonicalize.Module.canonicalize pkg importDict interfaces valid 161 | 162 | let localizer = Reporting.Render.Type.Localizer.fromModule valid 163 | 164 | annotations <- 165 | Compile.runTypeInference localizer canonical 166 | 167 | () <- 168 | Compile.exhaustivenessCheck canonical 169 | 170 | -- we don't actually run any code generation 171 | 172 | Reporting.Result.ok $ 173 | Compile.Artifacts 174 | { Compile._elmi = Elm.Interface.fromModule annotations canonical 175 | -- we have to fake this, so compileModule can store artifacts in File.Compile.Good 176 | , Compile._elmo = AST.Optimized.Graph Map.empty Map.empty Map.empty 177 | , Compile._docs = Nothing 178 | } 179 | 180 | 181 | -- Get all elm files given in an elm.json ([] for a package, all elm files for an application) 182 | getElmFiles :: Elm.Project.Json.Project -> IO [FilePath] 183 | getElmFiles summary = case summary of 184 | Elm.Project.Json.App app -> do 185 | let dirs = Elm.Project.Json._app_source_dirs app 186 | elmFiles <- mapM (Glob.globDir1 (Glob.compile "**/*.elm")) dirs 187 | return (concat elmFiles) 188 | Elm.Project.Json.Pkg package -> return [] 189 | --------------------------------------------------------------------------------