datalog-lsp sensible file structure

datalog-lsp/src/Datalog/LSP.hs

@@ -0,0 +1,43 @@
+module Datalog.LSP where
+
+import Control.Monad.IO.Class
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types
+import Language.LSP.Server
+import Datalog.LSP.Hover (hoverHandler)
+import Datalog.LSP.Highlight (tokenHandler)
+
+handlers :: Handlers (LspM ())
+handlers =
+    mconcat
+        [ initHandler
+        , hoverHandler
+        , tokenHandler
+        ]
+
+initHandler :: Handlers (LspM ())
+initHandler = notificationHandler SMethod_Initialized $ \_ -> pure ()
+
+serverDefinition :: ServerDefinition ()
+serverDefinition = 
+        ServerDefinition
+            { parseConfig = const $ const $ Right ()
+            , onConfigChange = const $ pure ()
+            , defaultConfig = ()
+            , configSection = "demo"
+            , doInitialize = \env _req -> pure $ Right env
+            , staticHandlers = const handlers
+            , interpretHandler = \env -> Iso (runLspT env) liftIO
+            , options =
+                defaultOptions
+                    { optTextDocumentSync =
+                        Just $
+                            TextDocumentSyncOptions
+                                { _openClose = Just True
+                                , _change = Just TextDocumentSyncKind_Full
+                                , _willSave = Just False
+                                , _willSaveWaitUntil = Just False
+                                , _save = Just (InR (SaveOptions (Just False)))
+                                }
+                    }
+            }

datalog-lsp/src/Datalog/LSP/Highlight.hs

@@ -0,0 +1,28 @@
+module Datalog.LSP.Highlight where
+
+import Control.Lens ((^.), Lens')
+import Data.Either (fromRight)
+import Data.Maybe (fromJust)
+import Language.LSP.Protocol.Lens (params, textDocument, uri, HasTextDocument, HasParams, HasUri)
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types
+import Language.LSP.Server
+
+tokenHandler :: Handlers (LspM ())
+tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
+    let 
+        openUri = toNormalizedUri $ req ^. docUri
+        token =
+            SemanticTokenAbsolute
+                { _line = 0
+                , _startChar = 0
+                , _length = 5
+                , _tokenType = SemanticTokenTypes_Keyword
+                , _tokenModifiers = []
+                }
+        tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
+    c <- fromJust <$> getVirtualFile openUri
+    responder (Right $ InL tokens)
+
+docUri :: (HasParams s s1,  HasTextDocument s1 s2, HasUri s2 a) => Lens' s a 
+docUri = params . textDocument . uri

datalog-lsp/src/Datalog/LSP/Hover.hs

@@ -0,0 +1,23 @@
+module Datalog.LSP.Hover where
+
+import Control.Lens ((^.), Lens')
+import Data.Maybe (fromJust)
+import Language.LSP.Protocol.Lens (params, textDocument, uri, HasTextDocument, HasParams, HasUri)
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types
+import Language.LSP.Server
+import Language.LSP.VFS (virtualFileText)
+
+hoverHandler :: Handlers (LspM ())
+hoverHandler = requestHandler SMethod_TextDocumentHover $ \req responder -> do
+    let
+        openUri = toNormalizedUri $ req ^. docUri
+        TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
+        Position _l _c' = pos
+        rsp txt = Hover (InL . mkMarkdown $ txt) (Just range)
+        range = Range pos pos
+    c <- fromJust <$> getVirtualFile openUri
+    responder (Right . InL . rsp . virtualFileText $ c)
+
+docUri :: (HasParams s s1,  HasTextDocument s1 s2, HasUri s2 a) => Lens' s a 
+docUri = params . textDocument . uri

datalog-lsp/src/Main.hs

@@ -1,65 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-import Control.Lens ((^.))
+import Datalog.LSP (serverDefinition)
-import Control.Monad.IO.Class
+import Language.LSP.Server (runServer)
-import Data.Either (fromRight)
-import Data.Maybe (fromJust)
-import Language.LSP.Protocol.Lens (params, textDocument, uri)
-import Language.LSP.Protocol.Message
-import Language.LSP.Protocol.Types
-import Language.LSP.Server
-import Language.LSP.VFS (virtualFileText)
-
-handlers :: Handlers (LspM ())
-handlers =
-    mconcat
-        [ notificationHandler SMethod_Initialized $ \_ -> pure ()
-        , requestHandler SMethod_TextDocumentHover $ \req responder -> do
-            let
-                docUri = toNormalizedUri $ req ^. (params . textDocument . uri)
-                TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
-                Position _l _c' = pos
-                rsp txt = Hover (InL . mkMarkdown $ txt) (Just range)
-                range = Range pos pos
-            c <- fromJust <$> getVirtualFile docUri
-            responder (Right . InL . rsp . virtualFileText $ c)
-        , requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
-            let TRequestMessage _ _ _ (SemanticTokensParams _doc _workDone _partial) = req
-                docUri = toNormalizedUri $ req ^. (params . textDocument . uri)
-                token =
-                    SemanticTokenAbsolute
-                        { _line = 0
-                        , _startChar = 0
-                        , _length = 5
-                        , _tokenType = SemanticTokenTypes_Keyword
-                        , _tokenModifiers = []
-                        }
-                tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
-            c <- fromJust <$> getVirtualFile docUri
-            responder (Right $ InL tokens)
-        ]
 
 main :: IO Int
-main =
+main = runServer serverDefinition
-    runServer $
-        ServerDefinition
-            { parseConfig = const $ const $ Right ()
-            , onConfigChange = const $ pure ()
-            , defaultConfig = ()
-            , configSection = "demo"
-            , doInitialize = \env _req -> pure $ Right env
-            , staticHandlers = const handlers
-            , interpretHandler = \env -> Iso (runLspT env) liftIO
-            , options =
-                defaultOptions
-                    { optTextDocumentSync =
-                        Just $
-                            TextDocumentSyncOptions
-                                { _openClose = Just True
-                                , _change = Just TextDocumentSyncKind_Full
-                                , _willSave = Just False
-                                , _willSaveWaitUntil = Just False
-                                , _save = Just (InR (SaveOptions (Just False)))
-                                }
-                    }
-            }

geolog-lsp.cabal

@@ -42,6 +42,12 @@ executable datalog-lsp
                       lsp,
                       text,
                       containers,
-                      lens
+                      lens,
+                      megaparsec,
+                      datalog-parser
+    other-modules:
+        Datalog.LSP
+        Datalog.LSP.Highlight
+        Datalog.LSP.Hover
     hs-source-dirs:   datalog-lsp/src
     default-language: GHC2024