Add diagnostics for Megaparsec parsing
This commit is contained in:
Patrick Aldis
parent
dedc72789b
commit
7ac8aef519
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
)
|
||||
|
||||
@ -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
|
||||
}
|
||||
)
|
||||
|
||||
@ -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)))
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
}
|
||||
)
|
||||
|
||||
@ -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')
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user