Add diagnostics for Megaparsec parsing

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

@@ -5,14 +5,16 @@ 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)
+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
+import qualified Data.List.NonEmpty as NE
 
 docOpenHandler :: Handlers DLogLspM
 docOpenHandler = notificationHandler SMethod_TextDocumentDidOpen updateState
@@ -24,8 +26,52 @@ updateState :: (HasParams s a1, MonadLsp LSPContext (t IO), HasUri a2 Uri, HasTe
 updateState req = do
     let uri = currentBufferUri req
     LSPContext parseStateRef <- getConfig
-    text <- currentBufferText req
-    lift . atomically $ do
+    bufferText <- currentBufferText req
+    x <- lift . atomically $ do
         v <- readTVar parseStateRef
+
+        let parsedBuffer = runParser parseProgram (show uri) bufferText
+
         writeTVar parseStateRef $
-            M.insert uri (runParser parseProgram (show uri) text) v
+            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/Utils.hs

@@ -12,5 +12,8 @@ currentBufferText :: (MonadLsp config f, HasParams s a1, HasTextDocument a1 a2,
 currentBufferText req = virtualFileText . fromJust <$> getVirtualFile (currentBufferUri req)
 
 currentBufferUri :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 Uri) => s -> NormalizedUri
-currentBufferUri req = toNormalizedUri $ req ^. (params . textDocument . uri)
+currentBufferUri = toNormalizedUri . currentBufferUriUnNormalized
+
+currentBufferUriUnNormalized :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 a3) => s -> a3
+currentBufferUriUnNormalized req = req ^. (params . textDocument . uri)
 

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')
+