68 lines
2.9 KiB
Haskell
68 lines
2.9 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
|
|
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, 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
|
|
|
|
docOpenHandler :: Handlers DLogLspM
|
|
docOpenHandler = notificationHandler SMethod_TextDocumentDidOpen updateState
|
|
|
|
docChangeHandler :: Handlers DLogLspM
|
|
docChangeHandler = notificationHandler SMethod_TextDocumentDidChange updateState
|
|
|
|
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
|
|
|
|
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
|