From 283f41738d709fe3ed861db4f805638cf97f5de5 Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Tue, 25 Aug 2020 19:10:36 +0300 Subject: [PATCH] [LIGO-40] Support for code hovering Problem: We want to be able to show modal on hovering curson on some specific declaration. Solution: Add `hoverDecl` and integrate it with haskell-lsp client. --- tools/lsp/squirrel/app/Main.hs | 39 +++++++++------ .../squirrel/src/AST/Capabilities/Hover.hs | 48 +++++++++++++++++++ 2 files changed, 73 insertions(+), 14 deletions(-) create mode 100644 tools/lsp/squirrel/src/AST/Capabilities/Hover.hs diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 708050cca..bb8536b6e 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -30,7 +30,6 @@ import Duplo.Pretty import Duplo.Tree (collect) import AST hiding (def) -import qualified AST.Find as Find import Data.Maybe (fromMaybe) import Extension import Parser @@ -90,20 +89,21 @@ lspOptions = def lspHandlers :: TChan FromClientMessage -> Core.Handlers lspHandlers rin = def - { Core.initializedHandler = Just $ passHandler rin NotInitialized, - Core.definitionHandler = Just $ passHandler rin ReqDefinition, - Core.referencesHandler = Just $ passHandler rin ReqFindReferences, - Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument, - Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument, - Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument, - Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument, - Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient, - Core.responseHandler = Just $ responseHandlerCb rin, + { Core.initializedHandler = Just $ passHandler rin NotInitialized + , Core.definitionHandler = Just $ passHandler rin ReqDefinition + , Core.referencesHandler = Just $ passHandler rin ReqFindReferences + , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument + , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument + , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument + , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument + , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient + , Core.responseHandler = Just $ responseHandlerCb rin -- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction -- , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand - Core.completionHandler = Just $ passHandler rin ReqCompletion, + , Core.completionHandler = Just $ passHandler rin ReqCompletion -- , Core.completionResolveHandler = Just $ passHandler rin ReqCompletionItemResolve - Core.foldingRangeHandler = Just $ passHandler rin ReqFoldingRange + , Core.foldingRangeHandler = Just $ passHandler rin ReqFoldingRange + , Core.hoverHandler = Just $ passHandler rin ReqHover } passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a @@ -177,7 +177,7 @@ eventLoop funs chan = do let uri = req^.J.params.J.textDocument.J.uri let pos = posToRange $ req^.J.params.J.position tree <- loadFromVFS funs uri - case Find.definitionOf pos tree of + case definitionOf pos tree of Just defPos -> do respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos] Nothing -> do @@ -188,12 +188,13 @@ eventLoop funs chan = do let uri = req^.J.params.J.textDocument.J.uri let pos = posToRange $ req^.J.params.J.position tree <- loadFromVFS funs uri - case Find.referencesOf pos tree of + case referencesOf pos tree of Just refs -> do let locations = J.Location uri . rangeToLoc <$> refs respondWith funs req RspFindReferences $ J.List locations Nothing -> do respondWith funs req RspFindReferences $ J.List [] + ReqCompletion req -> do stopDyingAlready funs req $ do U.logs $ "got completion request: " <> show req @@ -222,6 +223,16 @@ eventLoop funs chan = do . fmap toFoldingRange actions <- foldingAST tree handler actions + + ReqHover req -> do + stopDyingAlready funs req do + let uri = req ^. J.params . J.textDocument . J.uri + let pos = posToRange $ req ^. J.params . J.position + tree <- loadFromVFS funs uri + let response = + RspHover $ Core.makeResponseMessage req (hoverDecl pos tree) + Core.sendFunc funs response + _ -> U.logs "unknown msg" respondWith diff --git a/tools/lsp/squirrel/src/AST/Capabilities/Hover.hs b/tools/lsp/squirrel/src/AST/Capabilities/Hover.hs new file mode 100644 index 000000000..c5560d3f3 --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Capabilities/Hover.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Hover code capability + +module AST.Capabilities.Hover where + +import qualified Language.Haskell.LSP.Types as LSP + +import AST.Capabilities.Find +import AST.Scope +import AST.Skeleton + +import Duplo.Pretty +import Product +import Range +import Data.Text (intercalate) + +hoverDecl + :: CanSearch xs + => Range + -> LIGO (Product xs) + -> Maybe LSP.Hover +hoverDecl at tree = do + decl <- findScopedDecl at tree + Just $ LSP.Hover + { _contents = mkContents decl + , _range = Just $ toLSPRange at + } + +mkContents :: ScopedDecl -> LSP.HoverContents +mkContents ScopedDecl + { _sdType = ppToText -> _sdType + , _sdName = ppToText -> _sdName + , _sdDoc = ppToText -> _sdDoc + , _sdOrigin = ppToText -> _sdOrigin + -- TODO: more documentation + } = LSP.HoverContents $ LSP.MarkupContent + { _kind = LSP.MkMarkdown + , _value = contentDoc + } where + contentDoc = intercalate "\n" + [ _sdName <> " :: " <> _sdType + , "\n" + , "*defined at*" + , _sdOrigin + , "\n" + , _sdDoc + ]