Add diagnostics for Megaparsec parsing

datalog-lsp/src/Datalog/LSP.hs

@@ -6,10 +6,8 @@ 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.Types (DLogLspM, LSPState)
 import Datalog.LSP.DocChange (docChangeHandler, docOpenHandler)
-import qualified Data.Map as M
-import Control.Concurrent.STM
 
 handlers :: Handlers DLogLspM
 handlers =
@@ -24,13 +22,12 @@ handlers =
 initHandler :: Handlers DLogLspM
 initHandler = notificationHandler SMethod_Initialized $ \_ -> pure ()
 
-serverDefinition :: IO (ServerDefinition LSPContext)
-serverDefinition = do
-        ref <- newTVarIO M.empty
-        pure $ ServerDefinition
+serverDefinition :: LSPState -> ServerDefinition LSPState
+serverDefinition context = 
+        ServerDefinition
             { parseConfig = \c v -> Right c
             , onConfigChange = const $ pure ()
-            , defaultConfig = LSPContext ref
+            , defaultConfig = context
             , configSection = "demo"
             , doInitialize = \env _req -> pure $ Right env
             , staticHandlers = const handlers

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

@@ -3,15 +3,18 @@
 module Datalog.LSP.DocChange (docChangeHandler, docOpenHandler) where
 
 import Control.Concurrent.STM
+import Control.Lens ((^.))
 import Control.Monad.Trans
+import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
+import Data.Text qualified as T
 import Datalog.LSP.Types
-import Datalog.LSP.Utils (currentBufferText, currentBufferUri)
+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))
-import Language.LSP.Protocol.Types (Uri)
-import Language.LSP.Server (Handlers, MonadLsp, getConfig, notificationHandler)
+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
 
 docOpenHandler :: Handlers DLogLspM
@@ -20,12 +23,45 @@ 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 :: (HasParams s a1, MonadLsp LSPState (t IO), HasUri a2 Uri, HasTextDocument a1 a2, MonadTrans t) => s -> t IO ()
 updateState req = do
     let uri = currentBufferUri req
-    LSPContext parseStateRef <- getConfig
-    text <- currentBufferText req
-    lift . atomically $ do
-        v <- readTVar parseStateRef
-        writeTVar parseStateRef $
-            M.insert uri (runParser parseProgram (show uri) text) v
+
+    parseRef <- parseState <$> getConfig
+    bufferText <- currentBufferText req
+    parseResult <- lift . atomically $ do
+        v <- readTVar parseRef
+
+        let parsedBuffer = runParser parseProgram (show uri) bufferText
+
+        writeTVar parseRef $
+            M.insert uri parsedBuffer v
+
+        pure parsedBuffer
+
+    sendNotification
+        SMethod_TextDocumentPublishDiagnostics
+        PublishDiagnosticsParams
+            { _uri = req ^. currentBufferUriUnNormalized
+            , _version = Nothing
+            , _diagnostics = case parseResult of
+                Right _ -> []
+                Left (ParseErrorBundle errs position) ->
+                    NE.toList . flip fmap (fst $ attachSourcePos errorOffset errs position) $ \(err, pos) ->
+                        Diagnostic
+                            { _range = let p = sourcePosToPosition pos in Range p p
+                            , _severity = Just DiagnosticSeverity_Error
+                            , _code = Nothing
+                            , _codeDescription = Nothing
+                            , _source = Nothing
+                            , _message = T.pack . parseErrorTextPretty $ err
+                            , _tags = Nothing
+                            , _relatedInformation = Nothing
+                            , _data_ = Nothing
+                            }
+            }
+
+sourcePosToPosition :: SourcePos -> Position
+sourcePosToPosition (SourcePos _ line column) = Position (unPos' line) (unPos' column)
+  where
+    unPos' = fromIntegral . (\x -> x - 1) . unPos

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

@@ -5,7 +5,7 @@ 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.Types (DLogLspM, LSPState (..))
 import Datalog.LSP.Utils (currentBufferUri)
 import Datalog.Parser (SrcLoc (..))
 import Datalog.Syntax (Atom' (Atom), Program' (..), RelId (RelId), Rule' (..), Term' (..))
@@ -15,7 +15,7 @@ import Language.LSP.Server
 
 tokenHandler :: Handlers DLogLspM
 tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
-    LSPContext parseRef <- getConfig
+    LSPState parseRef <- getConfig
     p <- lift . readTVarIO $ parseRef
     case M.lookup (currentBufferUri req) p of
         Nothing ->
@@ -26,7 +26,7 @@ tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req resp
             responder
                 ( Right
                     . InL
-                    . fromRight (error "")
+                    . fromRight (SemanticTokens Nothing [])
                     . makeSemanticTokens defaultSemanticTokensLegend
                     $ highlightProg prog
                 )

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

@@ -1,24 +1,19 @@
 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 Datalog.LSP.Types (DLogLspM)
+import Datalog.LSP.Utils (currentBufferText)
 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
+    text <- currentBufferText req
+    responder
+        ( Right
+            . InL
+            $ Hover
+                { _contents = InL . mkMarkdown $ text
+                , _range = Nothing
+                }
+        )

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

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

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

@@ -8,9 +8,12 @@ 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)
+currentBufferText :: (MonadLsp config m, HasParams s a1, HasTextDocument a1 a2,  HasUri a2 Uri) => s -> m T.Text
+currentBufferText = fmap (virtualFileText . fromJust) . (getVirtualFile . currentBufferUri)
 
 currentBufferUri :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 Uri) => s -> NormalizedUri
-currentBufferUri req = toNormalizedUri $ req ^. (params . textDocument . uri)
+currentBufferUri = toNormalizedUri . view currentBufferUriUnNormalized
+
+currentBufferUriUnNormalized :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 a3) => Lens' s a3
+currentBufferUriUnNormalized = params . textDocument . uri
 

datalog-lsp/src/Main.hs

@@ -1,5 +1,14 @@
+import Control.Concurrent.STM (newTVarIO)
 import Datalog.LSP (serverDefinition)
+import Datalog.LSP.Types (LSPState (..))
 import Language.LSP.Server (runServer)
 
 main :: IO Int
-main = serverDefinition >>= runServer 
+main = do
+    ref <- newTVarIO mempty
+    runServer $
+        serverDefinition
+            ( LSPState
+                { parseState = ref
+                }
+            )

nvim-setup.lua

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