patrickaldis/geolog-lsp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactor cases to move out let binding

Browse Source
This commit is contained in:
Patrick Aldis 2026-03-05 16:05:15 +00:00
parent 35b2fa4282
commit dedc72789b
1 changed files with 13 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
datalog-lsp/src/Datalog/LSP/Highlight.hs
View File

@ -1,29 +1,35 @@
module Datalog.LSP.Highlight where module Datalog.LSP.Highlight where
import Control.Concurrent.STM
import Control.Monad.Trans
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Map qualified as M
import Data.Text qualified as T import Data.Text qualified as T
import Datalog.LSP.Types (DLogLspM, LSPContext (..)) import Datalog.LSP.Types (DLogLspM, LSPContext (..))
import Datalog.LSP.Utils (currentBufferUri)
import Datalog.Parser (SrcLoc (..)) import Datalog.Parser (SrcLoc (..))
import Datalog.Syntax (Atom' (Atom), Program' (..), RelId (RelId), Rule' (..), Term' (..)) import Datalog.Syntax (Atom' (Atom), Program' (..), RelId (RelId), Rule' (..), Term' (..))
import Language.LSP.Protocol.Message import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types import Language.LSP.Protocol.Types
import Language.LSP.Server import Language.LSP.Server
import Control.Monad.Trans
import Control.Concurrent.STM
import qualified Data.Map as M
import Datalog.LSP.Utils (currentBufferUri)
tokenHandler :: Handlers DLogLspM tokenHandler :: Handlers DLogLspM
tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
LSPContext parseRef <- getConfig LSPContext parseRef <- getConfig
p <- lift . readTVarIO $ parseRef p <- lift . readTVarIO $ parseRef
case M.lookup (currentBufferUri req) p of case M.lookup (currentBufferUri req) p of
Nothing -> responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Doc not bundle" Nothing) Nothing ->
responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Doc not bundle" Nothing)
Just (Left _) -> Just (Left _) ->
responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Failed to parse" Nothing) responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Failed to parse" Nothing)
Just (Right prog) -> do Just (Right prog) -> do
let semanticTokens = fromRight (error "") $ makeSemanticTokens defaultSemanticTokensLegend $ highlightProg prog responder
responder (Right $ InL semanticTokens) ( Right
. InL
. fromRight (error "")
. makeSemanticTokens defaultSemanticTokensLegend
$ highlightProg prog
)
highlightProg :: Program' SrcLoc -> [SemanticTokenAbsolute] highlightProg :: Program' SrcLoc -> [SemanticTokenAbsolute]
highlightProg (Program _ rs) = rs >>= highlightRule highlightProg (Program _ rs) = rs >>= highlightRule