Hover displays the contents of the document

geolog-lsp.cabal

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

src/Main.hs

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