78 lines
3.2 KiB
Haskell
78 lines
3.2 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
|
|
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, 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
|
|
import qualified Data.List.NonEmpty as NE
|
|
|
|
docOpenHandler :: Handlers DLogLspM
|
|
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 req = do
|
|
let uri = currentBufferUri req
|
|
LSPContext parseStateRef <- getConfig
|
|
bufferText <- currentBufferText req
|
|
x <- lift . atomically $ do
|
|
v <- readTVar parseStateRef
|
|
|
|
let parsedBuffer = runParser parseProgram (show uri) bufferText
|
|
|
|
writeTVar parseStateRef $
|
|
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
|