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