6 changed files with 100 additions and 129 deletions
--- a/datalog-lsp/src/Datalog/LSP.hs
+++ b/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)))
-                                }
-                    }
-            }
--- a/datalog-lsp/src/Datalog/LSP/Highlight.hs
+++ b/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
--- a/datalog-lsp/src/Datalog/LSP/Hover.hs
+++ b/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
--- a/datalog-lsp/src/Main.hs
+++ b/datalog-lsp/src/Main.hs
@ -1,7 +1,65 @@
 {-# LANGUAGE OverloadedStrings #-}

-import Datalog.LSP (serverDefinition)
-import Language.LSP.Server (runServer)
+import Control.Lens ((^.))
+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)))
+                                }
+                    }
+            }
--- a/datalog/src/Datalog/Parser.hs
+++ b/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 (Atom' (..), Program' (..), Rule' (..), Term' (..))
+import Datalog.Syntax
 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 = parseThingWithSub Con $ ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
+parseCon :: (MonadParsec e Text m) => m Term
+parseCon = Con () . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))

-parseVar :: Parser Term
-parseVar = parseThingWithSub Var $ VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
+parseVar :: (MonadParsec e Text m) => m Term
+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

-parseRule :: Parser Rule
-parseRule = parseThingWithSub (\loc (a, as) -> Rule loc a as) $
-        try rule1 <|> rule2
-  where
-    rule1 = do
+parseFact :: Parser Rule
+parseFact = do
    headAtom <- parseAtom
    period
-        return (headAtom, [])
-    rule2 = do
+    return (Rule () headAtom [])
+
+parseRule :: Parser Rule
+parseRule =
+    try parseFact <|> do
        headAtom <- parseAtom <* symbol ":-"
        bodyAtoms <- parseQuery
        period
-        return (headAtom, bodyAtoms)
+        return (Rule () headAtom bodyAtoms)
+parseRule' :: Parser (Rule' SrcLoc)
+parseRule' = _

-parseProgram :: Parser Program
-parseProgram = parseThingWithSub Program (many parseRule)
-
-parseThingWithSub :: (SrcLoc -> c -> f SrcLoc) -> Parser c -> Parser (f SrcLoc)
-parseThingWithSub f parseSub = do
+-- parseProgram :: Parser Program
+parseProgram :: Parser (Program' SrcLoc)
+parseProgram = do
+    -- annotateSrcLoc $
    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)
--- a/geolog-lsp.cabal
+++ b/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