[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

@@ -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.initializedHandler = Just $ passHandler rin NotInitialized
-      Core.definitionHandler = Just $ passHandler rin ReqDefinition,
+    , Core.definitionHandler = Just $ passHandler rin ReqDefinition
-      Core.referencesHandler = Just $ passHandler rin ReqFindReferences,
+    , Core.referencesHandler = Just $ passHandler rin ReqFindReferences
-      Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument,
+    , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
-      Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument,
+    , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
-      Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument,
+    , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
-      Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument,
+    , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
-      Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient,
+    , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
-      Core.responseHandler = Just $ responseHandlerCb rin,
+    , 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

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
+      ]