From 7ac8aef519995090167496f67b7fa0e106198e6a Mon Sep 17 00:00:00 2001 From: Patrick Aldis Date: Fri, 6 Mar 2026 12:11:24 +0000 Subject: [PATCH] Add diagnostics for Megaparsec parsing --- datalog-lsp/src/Datalog/LSP.hs | 13 ++---- datalog-lsp/src/Datalog/LSP/DocChange.hs | 58 +++++++++++++++++++----- datalog-lsp/src/Datalog/LSP/Highlight.hs | 6 +-- datalog-lsp/src/Datalog/LSP/Hover.hs | 27 +++++------ datalog-lsp/src/Datalog/LSP/Types.hs | 7 ++- datalog-lsp/src/Datalog/LSP/Utils.hs | 9 ++-- datalog-lsp/src/Main.hs | 11 ++++- nvim-setup.lua | 11 +++-- 8 files changed, 91 insertions(+), 51 deletions(-) diff --git a/datalog-lsp/src/Datalog/LSP.hs b/datalog-lsp/src/Datalog/LSP.hs index c512ac1..d484a2d 100644 --- a/datalog-lsp/src/Datalog/LSP.hs +++ b/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 diff --git a/datalog-lsp/src/Datalog/LSP/DocChange.hs b/datalog-lsp/src/Datalog/LSP/DocChange.hs index 67fdd31..dcf9f3e 100644 --- a/datalog-lsp/src/Datalog/LSP/DocChange.hs +++ b/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 diff --git a/datalog-lsp/src/Datalog/LSP/Highlight.hs b/datalog-lsp/src/Datalog/LSP/Highlight.hs index bba76db..dbe71a6 100644 --- a/datalog-lsp/src/Datalog/LSP/Highlight.hs +++ b/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 ) diff --git a/datalog-lsp/src/Datalog/LSP/Hover.hs b/datalog-lsp/src/Datalog/LSP/Hover.hs index 98a3b3f..9a0ede7 100644 --- a/datalog-lsp/src/Datalog/LSP/Hover.hs +++ b/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 + } + ) diff --git a/datalog-lsp/src/Datalog/LSP/Types.hs b/datalog-lsp/src/Datalog/LSP/Types.hs index e35e50e..e0649e5 100644 --- a/datalog-lsp/src/Datalog/LSP/Types.hs +++ b/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))) } diff --git a/datalog-lsp/src/Datalog/LSP/Utils.hs b/datalog-lsp/src/Datalog/LSP/Utils.hs index 143ebec..f9806c5 100644 --- a/datalog-lsp/src/Datalog/LSP/Utils.hs +++ b/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 diff --git a/datalog-lsp/src/Main.hs b/datalog-lsp/src/Main.hs index a165817..85e1fba 100644 --- a/datalog-lsp/src/Main.hs +++ b/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 + } + ) diff --git a/nvim-setup.lua b/nvim-setup.lua index d62d40e..d829b30 100644 --- a/nvim-setup.lua +++ b/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') +