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)))
-                                }
-                    }
-            }

datalog/src/Datalog/Parser.hs

@@ -1,11 +1,9 @@
-{-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE MultilineStrings #-}
 
 module Datalog.Parser (
     parseTerm,
-    parseAtom,
     parseRule,
-    parseQuery,
     parseProgram,
 )
 where
@@ -13,7 +11,8 @@ where
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Void (Void)
-import Datalog.Syntax
+import Datalog.Syntax hiding (Atom, Program, Rule, Term)
+import Datalog.Syntax (Atom' (..), Program' (..), Rule' (..), Term' (..))
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
@@ -21,6 +20,11 @@ import Text.Pretty.Simple
 
 type Parser = Parsec Void Text
 
+type Atom = Atom' SrcLoc
+type Term = Term' SrcLoc
+type Rule = Rule' SrcLoc
+type Program = Program' SrcLoc
+
 lexeme :: (MonadParsec e Text m) => m a -> m a
 lexeme = L.lexeme whitespace
 
@@ -41,61 +45,46 @@ comma, period :: (MonadParsec e Text m) => m ()
 comma = () <$ symbol ","
 period = () <$ symbol "."
 
-parseCon :: (MonadParsec e Text m) => m Term
+parseCon :: Parser Term
-parseCon = Con () . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
+parseCon = parseThingWithSub Con $ ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
 
-parseVar :: (MonadParsec e Text m) => m Term
+parseVar :: Parser Term
-parseVar = Var () . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
+parseVar = parseThingWithSub Var $ VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
 
 parseTerm :: Parser Term
 parseTerm = parseVar <|> parseCon
 
 parseAtom :: Parser Atom
-parseAtom = do
+parseAtom = parseThingWithSub (\loc (rel, args) -> Atom loc rel args) do
     rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
     args <- parens (parseTerm `sepBy` comma)
-    return (Atom () rel args)
+    return (rel, args)
 
 parseQuery :: Parser [Atom]
 parseQuery = parseAtom `sepBy` comma
 
-parseFact :: Parser Rule
-parseFact = do
-    headAtom <- parseAtom
-    period
-    return (Rule () headAtom [])
-
 parseRule :: Parser Rule
-parseRule =
+parseRule = parseThingWithSub (\loc (a, as) -> Rule loc a as) $
-    try parseFact <|> do
+        try rule1 <|> rule2
+  where
+    rule1 = do
+        headAtom <- parseAtom
+        period
+        return (headAtom, [])
+    rule2 = do
         headAtom <- parseAtom <* symbol ":-"
         bodyAtoms <- parseQuery
         period
-        return (Rule () headAtom bodyAtoms)
+        return (headAtom, bodyAtoms)
-parseRule' :: Parser (Rule' SrcLoc)
-parseRule' = _
 
--- parseProgram :: Parser Program
+parseProgram :: Parser Program
-parseProgram :: Parser (Program' SrcLoc)
+parseProgram = parseThingWithSub Program (many parseRule)
-parseProgram = do
+
-    -- annotateSrcLoc $
+parseThingWithSub :: (SrcLoc -> c -> f SrcLoc) -> Parser c -> Parser (f SrcLoc)
+parseThingWithSub f parseSub = do
     s <- getSourcePos
-    c <- many parseRule'
-    e <- getSourcePos
-    -- Program _ <$> many parseRule
-    pure $ Program (SrcLoc s e) c
-
-parseProgram' :: Parser (Program' SrcLoc)
-parseProgram' = parseThingWithSub (many parseRule') Program
-
-parseThingWithSub :: (Parser c) -> (SrcLoc -> c -> f SrcLoc) -> Parser (f SrcLoc)
-parseThingWithSub parseSub f = do
-    -- annotateSrcLoc $
-    s <- getSourcePos
-    -- c <- many parseRule'
     c <- parseSub
     e <- getSourcePos
-    -- Program _ <$> many parseRule
     pure $ f (SrcLoc s e) c
 
 annotateSrcLoc :: (Functor f) => Parser (f a) -> Parser (f SrcLoc)

geolog-lsp.cabal

@@ -43,5 +43,9 @@ executable datalog-lsp
                       text,
                       containers,
                       lens
+    other-modules:
+        Datalog.LSP
+        Datalog.LSP.Highlight
+        Datalog.LSP.Hover
     hs-source-dirs:   datalog-lsp/src
     default-language: GHC2024