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

{-# 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