Language Server Protocol

.gitignore

@@ -20,3 +20,5 @@ file_volume/
 ./file-volume/
 ./git/
 .DS_Store
+
+lsp-log.txt

Makefile

@@ -57,6 +57,22 @@ watch:
 		--command "cabal repl wasm-calc$(version)-tests" \
 		--test-ghci 'main'
 
+# run with `make watch version=9` to run tests / ghci for wasm-calc9
+.PHONY: watch-app
+version = 11
+watch-app:
+	ghciwatch --watch wasm-calc$(version) \
+		--command "cabal repl exe:wasm-calc$(version)" \
+		--test-shell 'cabal install wasm-calc11 --overwrite-policy=always'
+
+# run with `make watch version=9` to run tests / ghci for wasm-calc9
+.PHONY: lsp
+version = 11
+lsp:
+	ghciwatch --watch wasm-calc$(version) \
+		--command "cabal repl calc-language-server$(version)" \
+		--test-ghci 'main'
+
 # run with `make run version=8` to run wasm-calc8
 .PHONY: run
 version = 11
@@ -69,12 +85,13 @@ version = 11
 test:
 	cabal run wasm-calc$(version):tests
 
-# run with `make format-all-files version=7` to format all static `.calc` files for wasm-calc7
+# run with `make format-all-files version=7` to format all `.calc` files for wasm-calc7
 .PHONY: format-all-files
 version = 11
-STATIC_FILES = "./wasm-calc$(version)/test/static/"
+STATIC_FILES = "./wasm-calc$(version)/**/*.calc"
 format-all-files:
-	find $(STATIC_FILES) -maxdepth 1 -type f -exec cabal run wasm-calc$(version) -- format {} \;
+	find $(STATIC_FILES) -maxdepth 1 -type f -exec \
+		nix run .#wasm-calc$(version) format {} \;
 
 # run with `make build-malloc version=9` to build and diff malloc.calc for
 # wasm-calc9

wasm-calc11/app/Main.hs

@@ -2,6 +2,7 @@ module Main where
 
 import qualified Calc
 import Control.Applicative
+import Control.Monad (void)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Options.Applicative as Opt
@@ -11,6 +12,7 @@ data AppAction
   = Repl
   | Build Text -- given an input path, turn it into a Wasm module or explode with an error
   | Format Text -- given an input path, format and write new file
+  | Lsp -- run the language server
 
 parseAppAction :: Opt.Parser AppAction
 parseAppAction =
@@ -21,6 +23,12 @@ parseAppAction =
             (pure Repl)
             (Opt.progDesc "Start new calc repl")
         )
+        <> Opt.command
+          "lsp"
+          ( Opt.info
+              (pure Lsp)
+              (Opt.progDesc "Start calc lsp")
+          )
         <> Opt.command
           "build"
           ( Opt.info
@@ -63,3 +71,4 @@ main = do
     Repl -> Calc.repl
     Build filePath -> Calc.build (T.unpack filePath)
     Format filePath -> Calc.prettyPrint (T.unpack filePath)
+    Lsp -> void Calc.lsp

wasm-calc11/demo/calc-project.json

@@ -0,0 +1,3 @@
+{
+  "file": "to help lsp"
+}

wasm-calc11/demo/draw.calc

@@ -4,7 +4,7 @@ import imports.draw as draw(
   x: Int64, y: Int64, r: Int64, g: Int64, b: Int64
 ) -> Void
 
-function min(floor: Int64, value: Int64) -> Int64 { 
+function min(floor: Int64, value: Int64) -> Int64 {
   if value > floor then value else floor
 }
 
@@ -54,4 +54,5 @@ export function test() -> Void {
     set(index, index + 1)
   else
     set(index, 0)
-}
+}
+

wasm-calc11/src/Calc.hs

@@ -6,11 +6,13 @@ module Calc
     module Calc.Repl,
     module Calc.Wasm,
     module Calc.PrettyPrint,
+    module Calc.Lsp,
   )
 where
 
 import Calc.Build
 import Calc.ExprUtils
+import Calc.Lsp
 import Calc.Parser
 import Calc.PrettyPrint
 import Calc.Repl

wasm-calc11/src/Calc/Lsp.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Calc.Lsp (lsp) where
+
+import Calc.Build.Steps
+import Calc.Test
+import Calc.TypeUtils
+import Calc.Types
+import Control.Lens hiding (Iso)
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Data.Maybe
+import Data.Text qualified as T
+import Data.Text.Utf16.Rope.Mixed as TextRope
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types qualified as LSP
+import Language.LSP.Server qualified as LSP
+import Language.LSP.VFS qualified as LSP
+
+doLog :: (MonadIO m) => String -> m ()
+doLog =
+  liftIO . appendFile "/Users/daniel/git/wasm-calc/lsp-log.txt" . (<>) "\n"
+
+handlers :: LSP.Handlers (LSP.LspM ())
+handlers =
+  mconcat
+    [ LSP.notificationHandler SMethod_Initialized $ \notification -> do
+        doLog (show notification)
+
+        workspaceFolders <- fromMaybe [] <$> LSP.getWorkspaceFolders
+        doLog ("workspaceFolders " <> show workspaceFolders)
+        pure (),
+      LSP.notificationHandler SMethod_TextDocumentDidOpen $ \notification -> do
+        doLog "textDocumentDidOpen"
+        doLog (show notification)
+        pure (),
+      LSP.notificationHandler SMethod_TextDocumentDidChange $ \notification -> do
+        -- doLog "textDocumentDidChange"
+        -- doLog (show notification)
+        let doc =
+              notification
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to LSP.toNormalizedUri
+        doLog ("Processing DidChangeTextDocument for: " <> show doc)
+        let TNotificationMessage
+              _
+              _
+              ( LSP.DidChangeTextDocumentParams
+                  (LSP.VersionedTextDocumentIdentifier textDocumentIdentifier _)
+                  _
+                ) = notification
+        file <- findFile textDocumentIdentifier
+        doLog (show file)
+        pure (),
+      LSP.notificationHandler SMethod_TextDocumentDidSave $ \notification -> do
+        doLog "textDocumentDidSave"
+        doLog (show notification)
+        pure (),
+      LSP.requestHandler SMethod_TextDocumentHover $ \req responder -> do
+        doLog "textDocumentDidHover"
+        doLog (show req)
+        let TRequestMessage _ _ _ (LSP.HoverParams (LSP.TextDocumentIdentifier doc) pos _workDone) = req
+        file <- findFile doc
+
+        doLog (T.unpack file)
+
+        res <- runExceptT (lspBuildSteps file)
+        case res of
+          Right (_tests, typedModule) -> do
+            doLog (show typedModule)
+            let annotations = extractModuleAnnotations typedModule
+            doLog (show annotations)
+          Left _e -> doLog ("error")
+
+        let LSP.Position _l _c' = pos
+            rsp = LSP.Hover (LSP.InL ms) (Just range)
+            ms = LSP.mkMarkdown "Poo poo"
+            range = LSP.Range pos pos
+        responder (Right $ LSP.InL rsp)
+    ]
+
+extractModuleAnnotations :: Module (Type ann) -> [(ann, Type ann)]
+extractModuleAnnotations (Module {mdFunctions}) =
+  concatMap extractFunctionAnnotations mdFunctions
+
+extractFunctionAnnotations :: Function (Type ann) -> [(ann, Type ann)]
+extractFunctionAnnotations (Function {fnBody}) =
+  foldMap (\ty -> [(getOuterTypeAnnotation ty, ty)]) fnBody
+
+findFile :: LSP.Uri -> LSP.LspM config T.Text
+findFile doc = do
+  let uri = LSP.toNormalizedUri doc
+  mdoc <- LSP.getVirtualFile uri
+  case mdoc of
+    Just (LSP.VirtualFile _ _ str) -> do
+      pure (TextRope.toText str)
+    Nothing -> do
+      error ("Didn't find anything in the VFS for: " <> show doc)
+
+lsp :: IO Int
+lsp =
+  LSP.runServer $
+    LSP.ServerDefinition
+      { parseConfig = const $ const $ Right (),
+        onConfigChange = const $ pure (),
+        defaultConfig = (),
+        configSection = "demo",
+        doInitialize = \env _req -> pure $ Right env,
+        staticHandlers = \_caps -> handlers,
+        interpretHandler = \env -> LSP.Iso (LSP.runLspT env) liftIO,
+        options =
+          LSP.defaultOptions
+            { LSP.optTextDocumentSync = Just syncOptions,
+              LSP.optServerInfo = Just $ LSP.ServerInfo "Calc Language Server" Nothing
+            }
+      }
+  where
+    syncOptions =
+      LSP.TextDocumentSyncOptions
+        (Just True) -- open/close notifications
+        (Just LSP.TextDocumentSyncKind_Full) -- changes
+        Nothing -- will save
+        Nothing -- will save (wait until requests are sent to server)
+        (Just $ LSP.InR $ LSP.SaveOptions $ Just False) -- save
+
+lspBuildSteps ::
+  (MonadIO m, MonadError BuildError m) =>
+  T.Text ->
+  m
+    ( [(T.Text, Bool)],
+      Module (Type Annotation)
+    )
+lspBuildSteps input = do
+  parsedModuleItems <- liftEither (parseModuleStep input)
+
+  parsedModule <- liftEither (resolveModuleStep parsedModuleItems)
+
+  typedModule <- liftEither (typecheckModuleStep input parsedModule)
+
+  liftEither (linearityCheckStep input typedModule)
+
+  _ <- liftEither (abilityCheckStep input parsedModule)
+
+  testResults <- liftIO (testModule typedModule)
+
+  pure (testResults, typedModule)

wasm-calc11/wasm-calc11.cabal

@@ -40,6 +40,8 @@ common shared
     , file-embed
     , hashable
     , haskeline
+    , lens
+    , lsp
     , megaparsec
     , mtl
     , parser-combinators
@@ -48,6 +50,7 @@ common shared
     , process
     , string-conversions
     , text
+    , text-rope
     , unix
     , unordered-containers
     , wasm
@@ -67,6 +70,7 @@ common shared
     Calc.Linearity.Error
     Calc.Linearity.Types
     Calc.Linearity.Validate
+    Calc.Lsp
     Calc.Module
     Calc.Parser
     Calc.Parser.Data
@@ -192,6 +196,7 @@ executable wasm-calc11
     , file-embed
     , hashable
     , haskeline
+    , lsp
     , megaparsec
     , mtl
     , optparse-applicative