datalog-lsp/src/Datalog/LSP.hs

@@ -1,43 +0,0 @@
-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

@@ -1,28 +0,0 @@
-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

@@ -1,23 +0,0 @@
-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,7 +1,65 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-import Datalog.LSP (serverDefinition)
+import Control.Lens ((^.))
-import Language.LSP.Server (runServer)
+import Control.Monad.IO.Class
+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 = runServer serverDefinition
+main =
+    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,9 +1,11 @@
-{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE BlockArguments #-}
 
 module Datalog.Parser (
     parseTerm,
+    parseAtom,
     parseRule,
+    parseQuery,
     parseProgram,
 )
 where
@@ -11,8 +13,7 @@ where
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Void (Void)
-import Datalog.Syntax hiding (Atom, Program, Rule, Term)
+import Datalog.Syntax
-import Datalog.Syntax (Atom' (..), Program' (..), Rule' (..), Term' (..))
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
@@ -20,11 +21,6 @@ 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
 
@@ -45,46 +41,61 @@ comma, period :: (MonadParsec e Text m) => m ()
 comma = () <$ symbol ","
 period = () <$ symbol "."
 
-parseCon :: Parser Term
+parseCon :: (MonadParsec e Text m) => m Term
-parseCon = parseThingWithSub Con $ ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
+parseCon = Con () . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
 
-parseVar :: Parser Term
+parseVar :: (MonadParsec e Text m) => m Term
-parseVar = parseThingWithSub Var $ VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
+parseVar = Var () . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
 
 parseTerm :: Parser Term
 parseTerm = parseVar <|> parseCon
 
 parseAtom :: Parser Atom
-parseAtom = parseThingWithSub (\loc (rel, args) -> Atom loc rel args) do
+parseAtom = do
     rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
     args <- parens (parseTerm `sepBy` comma)
-    return (rel, args)
+    return (Atom () rel args)
 
 parseQuery :: Parser [Atom]
 parseQuery = parseAtom `sepBy` comma
 
+parseFact :: Parser Rule
+parseFact = do
+    headAtom <- parseAtom
+    period
+    return (Rule () headAtom [])
+
 parseRule :: Parser Rule
-parseRule = parseThingWithSub (\loc (a, as) -> Rule loc a as) $
+parseRule =
-        try rule1 <|> rule2
+    try parseFact <|> do
-  where
-    rule1 = do
-        headAtom <- parseAtom
-        period
-        return (headAtom, [])
-    rule2 = do
         headAtom <- parseAtom <* symbol ":-"
         bodyAtoms <- parseQuery
         period
-        return (headAtom, bodyAtoms)
+        return (Rule () headAtom bodyAtoms)
+parseRule' :: Parser (Rule' SrcLoc)
+parseRule' = _
 
-parseProgram :: Parser Program
+-- parseProgram :: Parser Program
-parseProgram = parseThingWithSub Program (many parseRule)
+parseProgram :: Parser (Program' SrcLoc)
-
+parseProgram = do
-parseThingWithSub :: (SrcLoc -> c -> f SrcLoc) -> Parser c -> Parser (f SrcLoc)
+    -- annotateSrcLoc $
-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,9 +43,5 @@ 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