Add super dumb lsp stub

Thanks daniël

1 files changed, 101 insertions, 0 deletions

diff --git a/lsp/Main.hs b/lsp/Main.hs
new file mode 100644
index 0000000..c3928d6
--- /dev/null
+++ b/lsp/Main.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Lens.Operators
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import qualified Data.Text as T
+import qualified Data.Text.Utf16.Rope.Mixed as Rope
+
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types
+import qualified Language.LSP.Protocol.Lens as L
+import qualified Language.LSP.VFS as L
+import Language.LSP.Server
+
+import qualified HSVIS.Parser as HV
+
+
+parseFile :: NormalizedUri -> T.Text -> [Diagnostic]
+parseFile (NormalizedUri _ fpath) source =
+  case HV.parse (T.unpack fpath) (T.unpack source) of
+    HV.This errs -> map mkDiag errs
+    HV.These errs _ -> map mkDiag errs
+    HV.That _ -> []
+  where
+    mkDiag :: HV.ErrMsg -> Diagnostic
+    mkDiag msg = Diagnostic
+      { _range =
+          let HV.Pos line col = HV.errPos msg
+              -- TODO: col needs to be UTF-16 based, which this is not
+              pos = Position (fromIntegral line) (fromIntegral col)
+          in Range pos pos
+      , _severity = Just DiagnosticSeverity_Error
+      , _code = Nothing
+      , _codeDescription = Nothing
+      , _source = Just "hs-vis"
+      , _message = T.pack $ intercalate "\n" $
+          HV.errMsg msg : ["In " ++ entry | entry <- reverse (HV.errStk msg)]
+      , _tags = Nothing
+      , _relatedInformation = Nothing
+      , _data_ = Nothing
+      }
+
+publishDiagsForUri :: Uri -> LspM () ()
+publishDiagsForUri fileUri = do
+  getVirtualFile (toNormalizedUri fileUri) >>= \case
+    Just vfile -> do
+      let diags = parseFile (toNormalizedUri fileUri)
+                            (Rope.toText (vfile ^. L.file_text))
+      liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("  -> publishing diags: " ++ show diags ++ "\n")
+      sendNotification SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams
+        { _uri = fileUri
+        , _version = Just (vfile ^. L.lsp_version)
+        , _diagnostics = diags }
+    Nothing -> pure ()
+
+handlers :: Handlers (LspM ())
+handlers =
+  mconcat
+    [ notificationHandler SMethod_Initialized $ \_notif -> do
+        sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "initialized!")
+        liftIO $ appendFile "/home/tom/hsvislsplog.txt" "initialized\n"
+        pure ()
+    , notificationHandler SMethod_TextDocumentDidOpen $ \notif -> do
+        let fileUri = notif ^. L.params . L.textDocument . L.uri
+        -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Handle (open): " ++ show fileUri ++ "\n")
+        publishDiagsForUri fileUri
+    , notificationHandler SMethod_TextDocumentDidChange $ \notif -> do
+        let fileUri = notif ^. L.params . L.textDocument . L.uri
+        -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Handle (change): " ++ show fileUri ++ "\n")
+        publishDiagsForUri fileUri
+        pure ()
+    , notificationHandler SMethod_TextDocumentDidClose $ \notif -> do
+        let fileUri = notif ^. L.params . L.textDocument . L.uri
+        -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Close: " ++ show fileUri ++ "\n")
+        publishDiagsForUri fileUri
+        pure ()
+    ]
+
+main :: IO Int
+main =
+  runServer $
+    ServerDefinition
+      { parseConfig = const $ const $ Right ()
+      , onConfigChange = const $ pure ()
+      , defaultConfig = ()
+      , configSection = "hs_vis"
+      , doInitialize = \env _req -> pure $ Right env
+      , staticHandlers = \_caps -> handlers
+      , interpretHandler = \env -> Iso (runLspT env) liftIO
+      , options = defaultOptions
+          { optTextDocumentSync = Just $ TextDocumentSyncOptions
+              { _openClose = Just True
+              , _change = Just TextDocumentSyncKind_Incremental
+              , _willSave = Nothing
+              , _willSaveWaitUntil = Nothing
+              , _save = Nothing }}
+      }
+