From fb1f3d1f4d53f4db9c43645e647720b77750f58d Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 25 Feb 2024 21:04:23 +0100
Subject: Add super dumb lsp stub
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Thanks daniël
---
 lsp/Main.hs | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 101 insertions(+)
 create mode 100644 lsp/Main.hs

(limited to 'lsp')

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 }}
+      }
+
-- 
cgit v1.2.3-70-g09d2