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

Hover displays the contents of the document

Browse Source
This commit is contained in:
Patrick Aldis 2026-02-27 12:07:52 +00:00
parent fbb0fb27fb
commit a42a546586
2 changed files with 30 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
geolog-lsp.cabal
View File

@ -15,13 +15,20 @@ extra-doc-files: CHANGELOG.md
common warnings common warnings
ghc-options: -Wall ghc-options: -Wall
common extensions
default-extensions:
OverloadedRecordDot
executable geolog-lsp executable geolog-lsp
import: warnings import: warnings, extensions
main-is: Main.hs main-is: Main.hs
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: base, build-depends:
base,
lsp, lsp,
text text,
containers,
lens
hs-source-dirs: src hs-source-dirs: src
default-language: GHC2024 default-language: GHC2024

38
src/Main.hs
View File

@ -1,37 +1,39 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
import Control.Lens ((^.))
import Control.Monad.IO.Class 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.Message
import Language.LSP.Protocol.Types import Language.LSP.Protocol.Types
import Language.LSP.Server import Language.LSP.Server
import Data.Either (fromRight) import Language.LSP.VFS (virtualFileText)
handlers :: Handlers (LspM ()) handlers :: Handlers (LspM ())
handlers = handlers =
mconcat mconcat
[ notificationHandler SMethod_Initialized $ \_ -> pure () [ notificationHandler SMethod_Initialized $ \_ -> pure ()
, requestHandler SMethod_TextDocumentHover $ \req responder -> do , requestHandler SMethod_TextDocumentHover $ \req responder -> do
let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req let
docUri = toNormalizedUri $ req ^. (params . textDocument . uri)
TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
Position _l _c' = pos Position _l _c' = pos
rsp = Hover (InL ms) (Just range) rsp txt = Hover (InL . mkMarkdown $ txt) (Just range)
ms = mkMarkdown "Hello world"
range = Range pos pos range = Range pos pos
responder (Right $ InL rsp) c <- fromJust <$> getVirtualFile docUri
responder (Right . InL . rsp . virtualFileText $ c)
, requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do , requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
let TRequestMessage _ _ _ (SemanticTokensParams _doc _workDone _partial) = req let TRequestMessage _ _ _ (SemanticTokensParams _doc _workDone _partial) = req
docUri = toNormalizedUri $ req ^. (params . textDocument . uri)
-- Each token is encoded as 5 uints: token =
-- [deltaLine, deltaStartChar, length, tokenTypeIndex, tokenModifiersBitset] SemanticTokenAbsolute
-- This example returns a single token at (0,0) of length 5. { _line = 0
let -- tokenTypeIndex=0 is "whatever the legend's 0 is" , _startChar = 0
token = SemanticTokenAbsolute { , _length = 5
_line = 0, , _tokenType = SemanticTokenTypes_Keyword
_startChar = 0, , _tokenModifiers = []
_length = 5, }
_tokenType = SemanticTokenTypes_Keyword,
_tokenModifiers = []
}
tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token] tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
responder (Right $ InL tokens) responder (Right $ InL tokens)