Add diagnostics for Megaparsec parsing

datalog-lsp/src/Datalog/LSP.hs

@@ -0,0 +1,50 @@
+module Datalog.LSP (serverDefinition) 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)
+import Datalog.LSP.Types (DLogLspM, LSPContext (LSPContext))
+import Datalog.LSP.DocChange (docChangeHandler, docOpenHandler)
+import qualified Data.Map as M
+import Control.Concurrent.STM
+
+handlers :: Handlers DLogLspM
+handlers =
+    mconcat
+        [ initHandler
+        , docChangeHandler
+        , docOpenHandler
+        , hoverHandler
+        , tokenHandler
+        ]
+
+initHandler :: Handlers DLogLspM
+initHandler = notificationHandler SMethod_Initialized $ \_ -> pure ()
+
+serverDefinition :: IO (ServerDefinition LSPContext)
+serverDefinition = do
+        ref <- newTVarIO M.empty
+        pure $ ServerDefinition
+            { parseConfig = \c v -> Right c
+            , onConfigChange = const $ pure ()
+            , defaultConfig = LSPContext ref
+            , 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/DocChange.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Datalog.LSP.DocChange (docChangeHandler, docOpenHandler) where
+
+import Control.Concurrent.STM
+import Control.Monad.Trans
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Datalog.LSP.Types
+import Datalog.LSP.Utils (currentBufferText, currentBufferUri, currentBufferUriUnNormalized)
+import Datalog.Parser (parseProgram)
+import Language.LSP.Protocol.Lens (HasParams, HasTextDocument, HasUri)
+import Language.LSP.Protocol.Message (SMethod (SMethod_TextDocumentDidChange, SMethod_TextDocumentDidOpen, SMethod_TextDocumentPublishDiagnostics))
+import Language.LSP.Protocol.Types (Diagnostic (..), DiagnosticSeverity (DiagnosticSeverity_Error), Position (..), PublishDiagnosticsParams (..), Range (Range), Uri)
+import Language.LSP.Server (Handlers, MonadLsp, getConfig, notificationHandler, sendNotification)
+import Text.Megaparsec
+import qualified Data.List.NonEmpty as NE
+
+docOpenHandler :: Handlers DLogLspM
+docOpenHandler = notificationHandler SMethod_TextDocumentDidOpen updateState
+
+docChangeHandler :: Handlers DLogLspM
+docChangeHandler = notificationHandler SMethod_TextDocumentDidChange updateState
+
+updateState :: (HasParams s a1, MonadLsp LSPContext (t IO), HasUri a2 Uri, HasTextDocument a1 a2, MonadTrans t) => s -> t IO ()
+updateState req = do
+    let uri = currentBufferUri req
+    LSPContext parseStateRef <- getConfig
+    bufferText <- currentBufferText req
+    x <- lift . atomically $ do
+        v <- readTVar parseStateRef
+
+        let parsedBuffer = runParser parseProgram (show uri) bufferText
+
+        writeTVar parseStateRef $
+            M.insert uri parsedBuffer v
+
+        pure parsedBuffer
+
+    case x of
+        Left (ParseErrorBundle errs position) ->
+            let 
+                (a, b) = attachSourcePos errorOffset errs position
+            in
+            sendNotification
+                SMethod_TextDocumentPublishDiagnostics
+                PublishDiagnosticsParams
+                    { _uri = currentBufferUriUnNormalized req
+                    , _version = Nothing
+                    , _diagnostics =
+                        NE.toList . flip fmap a $ \(err, pos) ->
+                             Diagnostic
+                                { _range = Range (f pos) (f pos)
+                                , _severity = Just DiagnosticSeverity_Error
+                                , _code = Nothing
+                                , _codeDescription = Nothing
+                                , _source = Nothing
+                                , _message = T.pack . parseErrorTextPretty $ err
+                                , _tags = Nothing
+                                , _relatedInformation = Nothing
+                                , _data_ = Nothing
+                                }
+                            
+                    }
+        Right prog ->
+            sendNotification
+                SMethod_TextDocumentPublishDiagnostics
+                PublishDiagnosticsParams
+                    { _uri = currentBufferUriUnNormalized req
+                    , _version = Nothing
+                    , _diagnostics = []
+                    }
+
+f :: SourcePos -> Position
+f (SourcePos _ line column) = Position (unPos' line) (unPos' column)
+    where
+        unPos' = fromIntegral . (\x -> x - 1) . unPos

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

@@ -0,0 +1,60 @@
+module Datalog.LSP.Highlight where
+
+import Control.Concurrent.STM
+import Control.Monad.Trans
+import Data.Either (fromRight)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Datalog.LSP.Types (DLogLspM, LSPContext (..))
+import Datalog.LSP.Utils (currentBufferUri)
+import Datalog.Parser (SrcLoc (..))
+import Datalog.Syntax (Atom' (Atom), Program' (..), RelId (RelId), Rule' (..), Term' (..))
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types
+import Language.LSP.Server
+
+tokenHandler :: Handlers DLogLspM
+tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
+    LSPContext parseRef <- getConfig
+    p <- lift . readTVarIO $ parseRef
+    case M.lookup (currentBufferUri req) p of
+        Nothing ->
+            responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Doc not bundle" Nothing)
+        Just (Left _) ->
+            responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Failed to parse" Nothing)
+        Just (Right prog) -> do
+            responder
+                ( Right
+                    . InL
+                    . fromRight (error "")
+                    . makeSemanticTokens defaultSemanticTokensLegend
+                    $ highlightProg prog
+                )
+
+highlightProg :: Program' SrcLoc -> [SemanticTokenAbsolute]
+highlightProg (Program _ rs) = rs >>= highlightRule
+
+highlightRule :: Rule' SrcLoc -> [SemanticTokenAbsolute]
+highlightRule (Rule _ a as) = a : as >>= highlightAtom
+
+highlightAtom :: Atom' SrcLoc -> [SemanticTokenAbsolute]
+highlightAtom (Atom loc (RelId relId) ts) = highlightRel ++ (ts >>= highlightTerm)
+  where
+    highlightRel = pure $ tokenFromSrcLoc loc' SemanticTokenTypes_Interface
+    loc' = loc{endCol = startCol loc + length (T.unpack relId)}
+
+highlightTerm :: Term' SrcLoc -> [SemanticTokenAbsolute]
+highlightTerm =
+    pure <$> \case
+        Con loc _ -> tokenFromSrcLoc loc SemanticTokenTypes_Number
+        Var loc _ -> tokenFromSrcLoc loc SemanticTokenTypes_Keyword
+
+tokenFromSrcLoc :: SrcLoc -> SemanticTokenTypes -> SemanticTokenAbsolute
+tokenFromSrcLoc (SrcLoc sl sc _ ec) tokenType =
+    SemanticTokenAbsolute
+        { _line = fromIntegral $ sl - 1
+        , _startChar = fromIntegral $ sc - 1
+        , _length = fromIntegral $ ec - sc
+        , _tokenType = tokenType
+        , _tokenModifiers = []
+        }

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

@@ -0,0 +1,24 @@
+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)
+import Datalog.LSP.Types (DLogLspM)
+
+hoverHandler :: Handlers DLogLspM
+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/Datalog/LSP/Types.hs

@@ -0,0 +1,20 @@
+module Datalog.LSP.Types (DLogLspM, LSPContext(..)) where
+
+import Control.Monad.Reader (ReaderT)
+import Language.LSP.Server (LspM)
+import Control.Concurrent.STM (TVar)
+import Text.Megaparsec
+import Data.Text (Text)
+import Data.Void (Void)
+import Data.Map (Map)
+import Language.LSP.Protocol.Types qualified as J
+import Datalog.Syntax (Program')
+import Datalog.Parser (SrcLoc)
+
+type DLogLspM = LspM LSPContext
+
+type UriBundle a = Map J.NormalizedUri a
+
+data LSPContext = LSPContext
+    { parseState :: TVar (UriBundle (Either (ParseErrorBundle Text Void) (Program' SrcLoc)))
+    }

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

@@ -0,0 +1,19 @@
+module Datalog.LSP.Utils where
+
+import Control.Lens
+import Data.Maybe
+import Data.Text qualified as T
+import Language.LSP.Protocol.Lens
+import Language.LSP.Protocol.Types
+import Language.LSP.Server
+import Language.LSP.VFS
+
+currentBufferText :: (MonadLsp config f, HasParams s a1, HasTextDocument a1 a2,  HasUri a2 Uri) => s -> f T.Text
+currentBufferText req = virtualFileText . fromJust <$> getVirtualFile (currentBufferUri req)
+
+currentBufferUri :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 Uri) => s -> NormalizedUri
+currentBufferUri = toNormalizedUri . currentBufferUriUnNormalized
+
+currentBufferUriUnNormalized :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 a3) => s -> a3
+currentBufferUriUnNormalized req = req ^. (params . textDocument . uri)
+

datalog-lsp/src/Main.hs

@@ -1,65 +1,5 @@
-{-# 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 =
+main = serverDefinition >>= runServer 
-    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

@@ -5,14 +5,15 @@ module Datalog.Parser (
     parseTerm,
     parseRule,
     parseProgram,
+    SrcLoc (..),
 )
 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 hiding (Atom, Program, Rule, Term)
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
@@ -20,6 +21,14 @@ import Text.Pretty.Simple
 
 type Parser = Parsec Void Text
 
+data SrcLoc = SrcLoc
+    { startLine :: Int
+    , startCol :: Int
+    , endLine :: Int
+    , endCol :: Int
+    }
+    deriving (Show)
+
 type Atom = Atom' SrcLoc
 type Term = Term' SrcLoc
 type Rule = Rule' SrcLoc
@@ -64,7 +73,8 @@ parseQuery :: Parser [Atom]
 parseQuery = parseAtom `sepBy` comma
 
 parseRule :: Parser Rule
-parseRule = parseThingWithSub (\loc (a, as) -> Rule loc a as) $
+parseRule =
+    parseThingWithSub (\loc (a, as) -> Rule loc a as) $
         try rule1 <|> rule2
   where
     rule1 = do
@@ -82,23 +92,10 @@ parseProgram = parseThingWithSub Program (many parseRule)
 
 parseThingWithSub :: (SrcLoc -> c -> f SrcLoc) -> Parser c -> Parser (f SrcLoc)
 parseThingWithSub f parseSub = do
-    s <- getSourcePos
+    SourcePos _ sl sc <- getSourcePos
     c <- parseSub
-    e <- getSourcePos
+    SourcePos _ el ec <- getSourcePos
-    pure $ f (SrcLoc s e) c
+    pure $ f (SrcLoc (unPos sl) (unPos sc) (unPos el) (unPos ec)) c
-
-annotateSrcLoc :: (Functor f) => Parser (f a) -> Parser (f SrcLoc)
-annotateSrcLoc p = do
-    s <- getSourcePos
-    res <- p
-    f <- getSourcePos
-    pure (SrcLoc s f <$ res)
-
-data SrcLoc = SrcLoc
-    { start :: SourcePos
-    , end :: SourcePos
-    }
-    deriving (Show)
 
 test = do
     let r = runParser parseProgram "???" prog

flake.nix

@@ -43,7 +43,7 @@
             ghcid
           ];
         };
-        packages.default = haskell.packages."geolog-lsp:exe:geolog-lsp";
+        packages.default = haskell.packages."geolog-lsp:exe:datalog-lsp";
       }
     );
 }

geolog-lsp.cabal

@@ -28,6 +28,7 @@ library datalog-parser
         containers,
         megaparsec,
         pretty-simple,
+        lens
     exposed-modules:
         Datalog.Parser,
         Datalog.Syntax
@@ -42,6 +43,17 @@ executable datalog-lsp
                       lsp,
                       text,
                       containers,
-                      lens
+                      lens,
+                      megaparsec,
+                      datalog-parser,
+                      mtl,
+                      stm
+    other-modules:
+        Datalog.LSP
+        Datalog.LSP.DocChange
+        Datalog.LSP.Types
+        Datalog.LSP.Highlight
+        Datalog.LSP.Hover
+        Datalog.LSP.Utils
     hs-source-dirs:   datalog-lsp/src
     default-language: GHC2024

nvim-setup.lua

@@ -1,10 +1,11 @@
 vim.filetype.add({
     extension = {
-        lsptest = "lsptest"
+        mydatalog = "dl"
     }
 })
-vim.lsp.config['geolog'] = {
+vim.lsp.config['mydatalog'] = {
-    cmd = { './result/bin/geolog-lsp' },
+    cmd = { './result/bin/datalog-lsp' },
-    filetypes = { 'lsptest'}
+    filetypes = { 'mydatalog' }
 }
-vim.lsp.enable('geolog')
+vim.lsp.enable('mydatalog')
+

test.dl

@@ -0,0 +1,11 @@
+odd(X,Y) :- r(X,Y).
+odd(X,Y) :- even(X,Z), r(Z,Y).
+even(X,Y) :- odd(X,Z), r(Z,Y).
+
+r(0,1).
+r(1,2).
+r(2,3).
+r(3,4).
+r(4,5).
+
+r(X,Y) :- r(Y,X).