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

datalog-lsp sensible file structure

Browse Source
This commit is contained in:
Patrick Aldis 2026-03-03 14:26:56 +00:00
parent a967a8e532
commit 6e726dfe54
5 changed files with 104 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
datalog-lsp/src/Datalog/LSP.hs Normal file
View File

@ -0,0 +1,43 @@
module Datalog.LSP where
import Control.Monad.IO.Class
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Datalog.LSP.Hover (hoverHandler)
import Datalog.LSP.Highlight (tokenHandler)
handlers :: Handlers (LspM ())
handlers =
mconcat
[ initHandler
, hoverHandler
, tokenHandler
]
initHandler :: Handlers (LspM ())
initHandler = notificationHandler SMethod_Initialized $ \_ -> pure ()
serverDefinition :: ServerDefinition ()
serverDefinition =
ServerDefinition
{ parseConfig = const $ const $ Right ()
, onConfigChange = const $ pure ()
, defaultConfig = ()
, configSection = "demo"
, doInitialize = \env _req -> pure $ Right env
, staticHandlers = const handlers
, interpretHandler = \env -> Iso (runLspT env) liftIO
, options =
defaultOptions
{ optTextDocumentSync =
Just $
TextDocumentSyncOptions
{ _openClose = Just True
, _change = Just TextDocumentSyncKind_Full
, _willSave = Just False
, _willSaveWaitUntil = Just False
, _save = Just (InR (SaveOptions (Just False)))
}
}
}

28
datalog-lsp/src/Datalog/LSP/Highlight.hs Normal file
View File

@ -0,0 +1,28 @@
module Datalog.LSP.Highlight where
import Control.Lens ((^.), Lens')
import Data.Either (fromRight)
import Data.Maybe (fromJust)
import Language.LSP.Protocol.Lens (params, textDocument, uri, HasTextDocument, HasParams, HasUri)
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
tokenHandler :: Handlers (LspM ())
tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
let
openUri = toNormalizedUri $ req ^. docUri
token =
SemanticTokenAbsolute
{ _line = 0
, _startChar = 0
, _length = 5
, _tokenType = SemanticTokenTypes_Keyword
, _tokenModifiers = []
}
tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
c <- fromJust <$> getVirtualFile openUri
responder (Right $ InL tokens)
docUri :: (HasParams s s1, HasTextDocument s1 s2, HasUri s2 a) => Lens' s a
docUri = params . textDocument . uri

23
datalog-lsp/src/Datalog/LSP/Hover.hs Normal file
View File

@ -0,0 +1,23 @@
module Datalog.LSP.Hover where
import Control.Lens ((^.), Lens')
import Data.Maybe (fromJust)
import Language.LSP.Protocol.Lens (params, textDocument, uri, HasTextDocument, HasParams, HasUri)
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.VFS (virtualFileText)
hoverHandler :: Handlers (LspM ())
hoverHandler = requestHandler SMethod_TextDocumentHover $ \req responder -> do
let
openUri = toNormalizedUri $ req ^. docUri
TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
Position _l _c' = pos
rsp txt = Hover (InL . mkMarkdown $ txt) (Just range)
range = Range pos pos
c <- fromJust <$> getVirtualFile openUri
responder (Right . InL . rsp . virtualFileText $ c)
docUri :: (HasParams s s1, HasTextDocument s1 s2, HasUri s2 a) => Lens' s a
docUri = params . textDocument . uri

64
datalog-lsp/src/Main.hs
View File

@ -1,65 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
import Control.Lens ((^.))
import Control.Monad.IO.Class
import Data.Either (fromRight)
import Data.Maybe (fromJust)
import Language.LSP.Protocol.Lens (params, textDocument, uri)
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.VFS (virtualFileText)
handlers :: Handlers (LspM ())
handlers =
mconcat
[ notificationHandler SMethod_Initialized $ \_ -> pure ()
, requestHandler SMethod_TextDocumentHover $ \req responder -> do
let
docUri = toNormalizedUri $ req ^. (params . textDocument . uri)
TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
Position _l _c' = pos
rsp txt = Hover (InL . mkMarkdown $ txt) (Just range)
range = Range pos pos
c <- fromJust <$> getVirtualFile docUri
responder (Right . InL . rsp . virtualFileText $ c)
, requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
let TRequestMessage _ _ _ (SemanticTokensParams _doc _workDone _partial) = req
docUri = toNormalizedUri $ req ^. (params . textDocument . uri)
token =
SemanticTokenAbsolute
{ _line = 0
, _startChar = 0
, _length = 5
, _tokenType = SemanticTokenTypes_Keyword
, _tokenModifiers = []
}
tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
c <- fromJust <$> getVirtualFile docUri
responder (Right $ InL tokens)
]
import Datalog.LSP (serverDefinition)
import Language.LSP.Server (runServer)
main :: IO Int
main =
runServer $
ServerDefinition
{ parseConfig = const $ const $ Right ()
, onConfigChange = const $ pure ()
, defaultConfig = ()
, configSection = "demo"
, doInitialize = \env _req -> pure $ Right env
, staticHandlers = const handlers
, interpretHandler = \env -> Iso (runLspT env) liftIO
, options =
defaultOptions
{ optTextDocumentSync =
Just $
TextDocumentSyncOptions
{ _openClose = Just True
, _change = Just TextDocumentSyncKind_Full
, _willSave = Just False
, _willSaveWaitUntil = Just False
, _save = Just (InR (SaveOptions (Just False)))
}
}
}
main = runServer serverDefinition

8
geolog-lsp.cabal
View File

@ -42,6 +42,12 @@ executable datalog-lsp
lsp,
text,
containers,
lens
lens,
megaparsec,
datalog-parser
other-modules:
Datalog.LSP
Datalog.LSP.Highlight
Datalog.LSP.Hover
hs-source-dirs: datalog-lsp/src
default-language: GHC2024