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
---
 hie.yaml          |   5 +++
 hs-visinter.cabal |  15 ++++++++
 lsp/Main.hs       | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 121 insertions(+)
 create mode 100644 lsp/Main.hs

diff --git a/hie.yaml b/hie.yaml
index ae8c4c0..9e52c3f 100644
--- a/hie.yaml
+++ b/hie.yaml
@@ -10,6 +10,11 @@ cradle:
         cradle:
           cabal:
             component: "exe:hs-visinter"
+    - path: "./lsp"
+      config:
+        cradle:
+          cabal:
+            component: "exe:hs-vis-lsp"
     - path: "./examples"
       config:
         cradle:
diff --git a/hs-visinter.cabal b/hs-visinter.cabal
index 748355d..0a179fb 100644
--- a/hs-visinter.cabal
+++ b/hs-visinter.cabal
@@ -32,3 +32,18 @@ executable hs-visinter
   hs-source-dirs: app
   default-language: Haskell2010
   ghc-options: -Wall -threaded
+
+executable hs-vis-lsp
+  main-is: Main.hs
+  other-modules:
+  build-depends:
+    base,
+    hs-visinter,
+    lsp ^>= 2.4.0.0,
+    text,
+
+    -- dependencies of lsp
+    lens, text-rope
+  hs-source-dirs: lsp
+  default-language: Haskell2010
+  ghc-options: -Wall -threaded
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