Draft: Implement a language server

.gitignore

@@ -2,6 +2,7 @@
 .trash/
 .idea/
 .vs/
+.vscode/
 node_modules/
 out/
 dist/

koka.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.33.0.
+-- This file has been generated from package.yaml by hpack version 0.31.2.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 5566036dac3bd0ad45754486154ddd84027b16d81b584e00838c079caf6268eb
+-- hash: 05735bf23830ba3e79a733b1af1ce1de608c17203e466c1377e589caac3a0a3d
 
 name:           koka
 version:        2.0.15
@@ -88,6 +88,16 @@ executable koka
       Kind.Pretty
       Kind.Synonym
       Kind.Unify
+      LanguageServer.Conversions
+      LanguageServer.Handler.Completion
+      LanguageServer.Handler.Definition
+      LanguageServer.Handler.DocumentSymbol
+      LanguageServer.Handler.Hover
+      LanguageServer.Handler.Initialized
+      LanguageServer.Handler.TextDocument
+      LanguageServer.Handlers
+      LanguageServer.Monad
+      LanguageServer.Run
       Lib.JSON
       Lib.PPrint
       Lib.Printer
@@ -142,6 +152,8 @@ executable koka
     , containers
     , directory
     , haskeline
+    , lens
+    , lsp
     , mtl
     , parsec
     , process
@@ -173,6 +185,8 @@ test-suite koka-test
     , haskeline
     , hspec
     , hspec-core
+    , lens
+    , lsp
     , mtl
     , parsec
     , process

package.yaml

@@ -20,6 +20,8 @@ dependencies:
   - cond
   - containers
   - directory
+  - lens
+  - lsp
   - mtl
   - parsec
   - process

src/Backend/C/FromCore.hs

@@ -2026,6 +2026,9 @@ instance Monad Asm where
                                     (x,st1) -> case f x of
                                                  Asm b -> b env st1)
 
+instance MonadFail Asm where
+  fail = failure
+
 runAsm :: Int -> Env -> Asm a -> (a,Doc,Doc)
 runAsm uniq initEnv (Asm asm)
   = case asm initEnv (initSt uniq) of

src/Common/Range.hs

@@ -14,7 +14,7 @@ module Common.Range
           ( Pos, makePos, minPos, maxPos, posColumn, posLine
           , posMove8, posMoves8, posNull
           , Range, showFullRange
-          , makeRange, rangeNull, combineRange, rangeEnd, rangeStart
+          , makeRange, rangeNull, combineRange, rangeEnd, rangeStart, rangeLength
           , Ranged( getRange ), combineRanged
           , combineRangeds, combineRanges, extendRange
           , Source(Source,sourceName, sourceBString), sourceText, sourceFromRange
@@ -271,6 +271,10 @@ rangeStart (Range p1 p2)  = p1
 rangeEnd :: Range -> Pos
 rangeEnd   (Range p1 p2)  = p2
 
+-- | Return the length of a range
+rangeLength :: Range -> Int
+rangeLength (Range p1 p2) = posOfs p2 - posOfs p1
+
 -- | Return the source of a range
 rangeSource :: Range -> Source
 rangeSource = posSource . rangeStart

src/Compiler/Compile.hs

@@ -151,7 +151,6 @@ instance Monad IOErr where
 instance MonadFail IOErr where
   fail = liftError . fail
 
-
 bindIO :: IO (Error a) -> (a -> IO (Error b)) -> IO (Error b)
 bindIO io f
   = do err <- io
@@ -808,7 +807,7 @@ inferCheck loaded flags line coreImports program1
               (isValueFromFlags flags)
               (colorSchemeFromFlags flags)
               (platform flags)
-              (if (outHtml flags > 0) then Just rangeMapNew else Nothing)
+              (if genRangeMap flags then Just rangeMapNew else Nothing)
               (loadedImportMap loaded)
               (loadedKGamma loaded)
               (loadedSynonyms loaded)

src/Compiler/Options.hs

@@ -75,11 +75,13 @@ prettyIncludePath flags
 data Mode
   = ModeHelp
   | ModeVersion
-  | ModeCompiler    { files :: [FilePath] }
-  | ModeInteractive { files :: [FilePath] }
+  | ModeCompiler       { files :: [FilePath] }
+  | ModeInteractive    { files :: [FilePath] }
+  | ModeLanguageServer { files :: [FilePath] }
 
 data Option
   = Interactive
+  | LanguageServer
   | Version
   | Help
   | Flag (Flags -> Flags)
@@ -133,6 +135,7 @@ data Flags
          , coreCheck        :: Bool
          , enableMon        :: Bool
          , semiInsert       :: Bool
+         , genRangeMap      :: Bool
          , localBinDir      :: FilePath  -- directory of koka executable
          , localDir         :: FilePath  -- install prefix: /usr/local
          , localLibDir      :: FilePath  -- precompiled object files: <prefix>/lib/koka/v2.x.x  /<cc>-<config>/libkklib.a, /<cc>-<config>/std_core.kki, ...
@@ -198,6 +201,7 @@ flagsNull
           False -- coreCheck
           True  -- enableMonadic
           True  -- semi colon insertion
+          False -- generate range map
           ""    -- koka executable dir
           ""    -- prefix dir (default: <program-dir>/..)
           ""    -- localLib dir
@@ -223,6 +227,9 @@ isVersion _      = False
 isInteractive Interactive = True
 isInteractive _ = False
 
+isLanguageServer LanguageServer = True
+isLanguageServer _ = False
+
 isValueFromFlags flags
  = dataInfoIsValue
 
@@ -239,6 +246,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip
  [ option ['?','h'] ["help"]            (NoArg Help)                "show this information"
  , option []    ["version"]         (NoArg Version)                 "show the compiler version"
  , option ['p'] ["prompt"]          (NoArg Interactive)             "interactive mode"
+ , option []    ["language-server"] (NoArg LanguageServer)          "language server mode"
  , flag   ['e'] ["execute"]         (\b f -> f{evaluate= b})        "compile and execute (default)"
  , flag   ['c'] ["compile"]         (\b f -> f{evaluate= not b})    "only compile, do not execute"
  , option ['i'] ["include"]         (OptArg includePathFlag "dirs") "add <dirs> to search path (empty resets)"
@@ -464,6 +472,7 @@ processOptions flags0 opts
                  mode = if (any isHelp options) then ModeHelp
                         else if (any isVersion options) then ModeVersion
                         else if (any isInteractive options) then ModeInteractive files
+                        else if (any isLanguageServer options) then ModeLanguageServer files
                         else if (null files) then ModeInteractive files
                                              else ModeCompiler files
              in do ed   <- if (null (editor flags))
@@ -483,7 +492,8 @@ processOptions flags0 opts
                                   ccompPath   = ccmd,
                                   ccomp       = cc,
                                   editor      = ed,
-                                  includePath = (localShareDir ++ "/lib") : includePath flags }
+                                  includePath = (localShareDir ++ "/lib") : includePath flags,
+                                  genRangeMap = outHtml flags > 0 || any isLanguageServer options }
                           ,mode)
         else invokeError errs
 

src/Kind/Constructors.hs

@@ -15,7 +15,7 @@ module Kind.Constructors( -- * Constructors
                           , constructorsExtend, constructorsLookup, constructorsFind
                           , constructorsIsEmpty
                           , constructorsFindScheme
-                          , constructorsSet
+                          , constructorsSet, constructorsList
                           , constructorsCompose, constructorsFromList
                           , extractConstructors
                             -- * Pretty
@@ -78,6 +78,10 @@ constructorsSet :: Constructors -> S.NameSet
 constructorsSet (Constructors m)
   = S.fromList (M.keys m)
 
+constructorsList :: Constructors -> [(Name, ConInfo)]
+constructorsList (Constructors m)
+  = M.toList m
+
 {--------------------------------------------------------------------------
   Pretty printing
 --------------------------------------------------------------------------}

src/LanguageServer/Conversions.hs

@@ -0,0 +1,73 @@
+-----------------------------------------------------------------------------
+-- Conversions between LSP types and internal types, e.g. positions/ranges
+-----------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module LanguageServer.Conversions( -- * Conversions to LSP types
+                                   toLspPos, toLspRange, toLspLocation
+                                 , toLspDiagnostics, toLspErrorDiagnostics, toLspWarningDiagnostic
+                                   -- * Conversions from LSP types
+                                 , fromLspPos, fromLspRange, fromLspLocation ) where
+
+import qualified Common.Error            as E
+import qualified Common.Range            as R
+import qualified Data.Text               as T
+import qualified Language.LSP.Types      as J
+import Lib.PPrint                        ( Doc )
+
+toLspPos :: R.Pos -> J.Position
+toLspPos p = J.Position (R.posLine p - 1) (R.posColumn p - 1) -- LSP positions are zero-based
+
+toLspRange :: R.Range -> J.Range
+toLspRange r = J.Range (J.Position l1 c1) (J.Position l2 $ c2 + 1) -- LSP range ends are exclusive
+  where
+    J.Position l1 c1 = toLspPos $ R.rangeStart r
+    J.Position l2 c2 = toLspPos $ R.rangeEnd r
+
+toLspLocation :: R.Range -> J.Location
+toLspLocation r = J.Location uri (toLspRange r)
+  where
+    uri = J.filePathToUri $ R.sourceName $ R.rangeSource r
+
+toLspDiagnostics :: J.DiagnosticSource -> E.Error a -> [J.Diagnostic]
+toLspDiagnostics src err = case E.checkError err of
+  Right (_, ws) -> map (uncurry $ toLspWarningDiagnostic src) ws
+  Left  e ->       toLspErrorDiagnostics src e
+
+toLspErrorDiagnostics :: J.DiagnosticSource -> E.ErrorMessage -> [J.Diagnostic]
+toLspErrorDiagnostics src e = case e of
+  E.ErrorGeneral r doc  -> [makeDiagnostic J.DsError src r doc]
+  E.ErrorParse   r doc  -> [makeDiagnostic J.DsError src r doc]
+  E.ErrorStatic  rds    -> map (uncurry $ makeDiagnostic J.DsError src) rds
+  E.ErrorKind    rds    -> map (uncurry $ makeDiagnostic J.DsError src) rds
+  E.ErrorType    rds    -> map (uncurry $ makeDiagnostic J.DsError src) rds
+  E.ErrorWarning rds e' -> map (uncurry $ makeDiagnostic J.DsError src) rds ++ toLspErrorDiagnostics src e'
+  E.ErrorIO      doc    -> [makeDiagnostic J.DsError src R.rangeNull doc]
+  E.ErrorZero           -> []
+
+toLspWarningDiagnostic :: J.DiagnosticSource -> R.Range -> Doc -> J.Diagnostic
+toLspWarningDiagnostic = makeDiagnostic J.DsWarning
+
+makeDiagnostic :: J.DiagnosticSeverity -> J.DiagnosticSource -> R.Range -> Doc -> J.Diagnostic
+makeDiagnostic s src r doc = J.Diagnostic range severity code source message tags related
+  where
+    range = toLspRange r
+    severity = Just s
+    code = Nothing
+    source = Just src
+    message = T.pack $ show doc
+    tags | "is unused" `T.isInfixOf` message = Just $ J.List [J.DtUnnecessary]
+         | otherwise                         = Nothing
+    related = Nothing
+
+fromLspPos :: J.Uri -> J.Position -> R.Pos
+fromLspPos uri (J.Position l c) = R.makePos src (-1) (l + 1) (c + 1)
+  where
+    src = case J.uriToFilePath uri of
+      Just filePath -> R.Source filePath R.bstringEmpty -- TODO: Read file here (and compute the offset correctly)
+      Nothing       -> R.sourceNull
+
+fromLspRange :: J.Uri -> J.Range -> R.Range
+fromLspRange uri (J.Range s e) = R.makeRange (fromLspPos uri s) (fromLspPos uri e)
+
+fromLspLocation :: J.Location -> R.Range
+fromLspLocation (J.Location uri rng) = fromLspRange uri rng