ghcide: type of selected expression via haskell/hoverRange custom method (#709)

docs/features.md

@@ -7,6 +7,7 @@ Many of these are standard LSP features, but a lot of special features are provi
 | --------------------------------------------------- | ------------------------------------------------------------------------------------------------- |
 | [Diagnostics](#diagnostics)                         | `textDocument/publishDiagnostics`                                                                 |
 | [Hovers](#hovers)                                   | `textDocument/hover`                                                                              |
+| [Hover over a selection](#hover-over-a-selection)   | `haskell/hoverRange` (custom method)                                                              |
 | [Signature help](#signature-help)                   | `textDocument/signatureHelp`                                                                      |
 | [Jump to definition](#jump-to-definition)           | `textDocument/definition`                                                                         |
 | [Jump to type definition](#jump-to-type-definition) | `textDocument/typeDefinition`                                                                     |
@@ -64,6 +65,26 @@ Provided by: `hls-explicit-fixity-plugin`
 
 Provides fixity information.
 
+## Hover over a selection
+
+Provided by: `ghcide`
+
+Shows the type of the smallest expression that encloses an arbitrary selection of code, so you can inspect the type of any sub-expression, not just identifiers.
+
+This is an LSP extension modelled after [rust-analyzer's "Hover Range" extension](https://rust-analyzer.github.io/book/contributing/lsp-extensions.html#hover-range), exposed as the custom request method `haskell/hoverRange`, since standard LSP hover only carries a single position ([microsoft/language-server-protocol#377](https://github.com/microsoft/language-server-protocol/issues/377)).
+
+Clients can send the following request whenever the user hovers over (or invokes a "show type of selection" command on) a non-empty selection:
+
+```typescript
+method: "haskell/hoverRange"
+params: {
+    textDocument: TextDocumentIdentifier,
+    range: Range, // the current selection
+}
+```
+
+The response is a standard LSP `Hover | null` value describing the smallest expression that fully contains the given range. An empty range behaves exactly like `textDocument/hover`.
+
 ## Signature help
 
 Provided by: `hls-signature-help-plugin`

ghcide-test/exe/HoverRangeTests.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE DataKinds #-}
+
+-- | Tests for the @haskell/hoverRange@ custom request, which provides
+-- hover information for the smallest expression enclosing a given range.
+module HoverRangeTests (tests) where
+
+import           Config
+import           Control.Monad                 (void)
+import           Control.Monad.IO.Class        (liftIO)
+import qualified Data.Aeson                    as A
+import           Data.Foldable                 (for_, traverse_)
+import           Data.Proxy                    (Proxy (..))
+import qualified Data.Text                     as T
+import           Hover                         (assertFoundIn)
+import           Language.LSP.Protocol.Message
+import           Language.LSP.Protocol.Types   hiding
+                                               (SemanticTokenAbsolute (..),
+                                                SemanticTokenRelative (..),
+                                                SemanticTokensEdit (..),
+                                                mkRange)
+import           Language.LSP.Test
+import           Test.Hls                      (waitForTypecheck)
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "hover range"
+  [ testGroup "basic"
+    [ hoverRangeTest basicSource "type of selected sub-expression"
+        (R 2 11 2 19) (Just $ R 2 11 2 19) ["_ :: Int"]
+    , hoverRangeTest basicSource "misaligned selection snaps to the enclosing expression"
+        (R 2 13 2 21) (Just $ R 2 11 2 23) ["_ :: Int"]
+    , hoverRangeTest basicSource "literal"
+        (R 2 22 2 23) (Just $ R 2 22 2 23) ["_ :: Int"]
+    , hoverRangeTest basicSource "selection exactly covering an identifier gives the rich hover"
+        (R 2 11 2 17) Nothing ["negate ::", "Int -> Int"]
+    , hoverRangeTest basicSource "operator"
+        (R 2 20 2 21) Nothing ["Int -> Int -> Int"]
+    , hoverRangeTest basicSource "multi-line selection"
+        (R 4 6 6 18) (Just $ R 4 6 6 18) ["_ :: Int"]
+    , hoverRangeTest basicSource "branch of an if expression"
+        (R 5 13 5 18) (Just $ R 5 13 5 18) ["_ :: Int"]
+    , hoverRangeTest basicSource "string literal"
+        (R 8 11 8 19) Nothing ["_ :: String"]
+    , hoverRangeTest basicSource "empty range behaves like hover at a position"
+        (R 2 12 2 12) Nothing ["negate"]
+    , hoverRangeNullTest basicSource "null for a selection spanning multiple declarations"
+        (R 1 0 4 14)
+    , hoverRangeNullTest basicSource "null for a range outside any expression"
+        (R 100 0 100 5)
+    ]
+  , testGroup "GADTs and DataKinds"
+    [ hoverRangeTest gadtSource "partially applied constructor is instantiated"
+        (R 8 8 8 15) Nothing ["_ ::", "-> Vec ('Succ ('Succ ('Succ 'Zero))) Int"]
+    , hoverRangeTest gadtSource "nested constructor application"
+        (R 8 26 8 38) Nothing ["_ :: Vec ('Succ 'Zero) Int"]
+    , hoverRangeTest gadtSource "existential hides the type-level index"
+        (R 10 9 10 22) Nothing ["_ :: SomeVec Int"]
+    ]
+  ]
+
+basicSource :: T.Text
+basicSource = T.unlines
+  [ "module A where"                       -- 0
+  , "combined :: Int"                      -- 1
+  , "combined = negate 3 + 7"              -- 2
+  , "g :: Int -> Int"                      -- 3
+  , "g x = if x > 0"                       -- 4
+  , "        then x + 1"                   -- 5
+  , "        else x - 1"                   -- 6
+  , "greeting :: String"                   -- 7
+  , "greeting = \"hello \" ++ \"world\""   -- 8
+  ]
+
+gadtSource :: T.Text
+gadtSource = T.unlines
+  [ "{-# LANGUAGE DataKinds, GADTs #-}"                     -- 0
+  , "module A where"                                        -- 1
+  , "data Nat = Zero | Succ Nat"                            -- 2
+  , "data Vec (n :: Nat) a where"                           -- 3
+  , "  VNil  :: Vec 'Zero a"                                -- 4
+  , "  VCons :: a -> Vec n a -> Vec ('Succ n) a"            -- 5
+  , "data SomeVec a where SomeVec :: Vec n a -> SomeVec a"  -- 6
+  , "three :: Vec ('Succ ('Succ ('Succ 'Zero))) Int"        -- 7
+  , "three = VCons 1 (VCons 2 (VCons 3 VNil))"              -- 8
+  , "hidden :: SomeVec Int"                                 -- 9
+  , "hidden = SomeVec three"                                -- 10
+  ]
+
+-- | Run @haskell/hoverRange@ over the given selection and check that the
+-- hover text contains the given snippets and (optionally) that the reported
+-- range is the enclosing expression's span.
+hoverRangeTest :: T.Text -> TestName -> Range -> Maybe Range -> [T.Text] -> TestTree
+hoverRangeTest src name sel expectedRange snippets =
+  testWithDummyPluginEmpty name $ do
+    doc <- createDoc "A.hs" "haskell" src
+    void $ waitForTypecheck doc
+    hover <- getHoverRange doc sel
+    (msg, mbRange) <- extractHover hover
+    liftIO $ do
+      traverse_ (`assertFoundIn` msg) snippets
+      for_ expectedRange $ \r -> mbRange @?= Just r
+
+hoverRangeNullTest :: T.Text -> TestName -> Range -> TestTree
+hoverRangeNullTest src name sel =
+  testWithDummyPluginEmpty name $ do
+    doc <- createDoc "A.hs" "haskell" src
+    void $ waitForTypecheck doc
+    hover <- getHoverRange doc sel
+    liftIO $ hover @?= InR Null
+
+getHoverRange :: TextDocumentIdentifier -> Range -> Session (Hover |? Null)
+getHoverRange doc range = do
+  resp <- request (SMethod_CustomMethod (Proxy @"haskell/hoverRange")) $
+    A.object ["textDocument" A..= doc, "range" A..= range]
+  case resp of
+    TResponseMessage{_result = Left err} ->
+      liftIO $ assertFailure $ "hoverRange request failed: " <> show err
+    TResponseMessage{_result = Right value} -> case A.fromJSON value of
+      A.Error err     -> liftIO $ assertFailure $ "hoverRange response decode failed: " <> err
+      A.Success hover -> pure hover
+
+extractHover :: Hover |? Null -> Session (T.Text, Maybe Range)
+extractHover hover = case hover of
+  InL (Hover (InL (MarkupContent _ msg)) mbRange) -> pure (msg, mbRange)
+  other -> liftIO $ assertFailure $ "Unexpected hoverRange response: " <> show other

ghcide-test/exe/Main.hs

@@ -31,9 +31,9 @@
 module Main (main) where
 
 import qualified HieDbRetry
+import           Test.Hls                        (defaultTestRunner)
 import           Test.Tasty
 import           Test.Tasty.Ingredients.Rerun
-import           Test.Hls (defaultTestRunner)
 
 import           AsyncTests
 import           BootTests
@@ -51,6 +51,7 @@ import           FindImplementationAndHoverTests
 import           GarbageCollectionTests
 import           HaddockTests
 import           HighlightTests
+import           HoverRangeTests
 import           IfaceTests
 import           InitializeResponseTests
 import           LogType                         ()
@@ -81,6 +82,7 @@ main = do
     , CodeLensTests.tests
     , OutlineTests.tests
     , HighlightTests.tests
+    , HoverRangeTests.tests
     , ConstructorHoverTests.tests
     , FindDefinitionAndHoverTests.tests
     , FindImplementationAndHoverTests.tests

ghcide/src/Development/IDE.hs

@@ -7,6 +7,7 @@ module Development.IDE
 ) where
 
 import           Development.IDE.Core.Actions          as X (getAtPoint,
+                                                             getAtPointRange,
                                                              getDefinition,
                                                              getTypeDefinition)
 import           Development.IDE.Core.FileExists       as X (getFileExists)

ghcide/src/Development/IDE/Core/Actions.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeFamilies #-}
 module Development.IDE.Core.Actions
 ( getAtPoint
+, getAtPointRange
 , getDefinition
 , getTypeDefinition
 , getImplementationDefinition
@@ -10,6 +11,7 @@ module Development.IDE.Core.Actions
 , lookupMod
 ) where
 
+import           Control.Applicative                  ((<|>))
 import           Control.Monad.Extra                  (mapMaybeM)
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Maybe
@@ -26,6 +28,9 @@ import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat           (DynFlags (..),
                                                        ms_hspp_opts)
+import           Development.IDE.GHC.Error            (rangeToRealSrcSpan,
+                                                       realSrcSpanToRange)
+import           Development.IDE.GHC.Util             (printOutputableOneLine)
 import           Development.IDE.Graph
 import qualified Development.IDE.Spans.AtPoint        as AtPoint
 import           Development.IDE.Types.HscEnvEq       (hscEnv)
@@ -46,7 +51,12 @@ import           Language.LSP.Protocol.Types          (DocumentHighlight (..),
 
 -- | Try to get hover text for the name under point.
 getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
-getAtPoint file pos = runMaybeT $ do
+getAtPoint file pos = getAtPointRange file (Range pos pos)
+
+-- | Try to get hover text for the smallest expression enclosing the given
+-- range, e.g. the current selection.
+getAtPointRange :: NormalizedFilePath -> Range -> IdeAction (Maybe (Maybe Range, [T.Text]))
+getAtPointRange file (Range start end) = runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
 
@@ -58,10 +68,32 @@ getAtPoint file pos = runMaybeT $ do
   dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
   let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary))
 
-  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+  !start' <- MaybeT (return $ fromCurrentPosition mapping start)
+  !end' <- MaybeT (return $ fromCurrentPosition mapping end)
+
+  mResult <- liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>
+    AtPoint.atPoint opts shakeExtras hf dkMap env (Range start' end') enabledExtensions
+
+  -- The HieAST does not record the types of many intermediate expression
+  -- nodes (e.g. applications), so a non-empty selection often lands on a
+  -- node without any hover information. In that case, recover the type of
+  -- the enclosing expression from the typechecked source.
+  let emptyHover = maybe True (all T.null . snd) mResult
+  if start == end || not emptyHover
+    then hoistMaybe mResult
+    else exprTypeAtRange file (Range start end) <|> hoistMaybe mResult
 
-  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>
-    AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions
+-- | Hover information with the type of the smallest expression enclosing the
+-- given range, computed from the typechecked source.
+exprTypeAtRange :: NormalizedFilePath -> Range -> MaybeT IdeAction (Maybe Range, [T.Text])
+exprTypeAtRange file (Range start end) = do
+  (tmr, mapping) <- useWithStaleFastMT TypeCheck file
+  !start' <- MaybeT (return $ fromCurrentPosition mapping start)
+  !end' <- MaybeT (return $ fromCurrentPosition mapping end)
+  let sp = rangeToRealSrcSpan file (Range start' end')
+  (exprSpan, exprTy) <- hoistMaybe $ AtPoint.exprTypeAtSpan sp (tmrTypechecked tmr)
+  let typeSig = "\n```haskell\n_ :: " <> printOutputableOneLine exprTy <> "\n```\n"
+  pure (toCurrentRange mapping (realSrcSpanToRange exprSpan), [typeSig])
 
 -- | Converts locations in the source code to their current positions,
 -- taking into account changes that may have occurred due to edits.

ghcide/src/Development/IDE/LSP/HoverDefinition.hs

@@ -7,6 +7,7 @@ module Development.IDE.LSP.HoverDefinition
     ( Log(..)
     -- * For haskell-language-server
     , hover
+    , hoverRange
     , foundHover
     , gotoDefinition
     , gotoTypeDefinition
@@ -16,8 +17,9 @@ module Development.IDE.LSP.HoverDefinition
     , wsSymbols
     ) where
 
-import           Control.Monad.Except           (ExceptT)
+import           Control.Monad.Except           (ExceptT, throwError)
 import           Control.Monad.IO.Class
+import qualified Data.Aeson                     as A
 import           Data.Maybe                     (fromMaybe)
 import           Development.IDE.Core.Actions
 import qualified Development.IDE.Core.Rules     as Shake
@@ -36,6 +38,7 @@ import qualified Data.Text                      as T
 data Log
   = LogWorkspaceSymbolRequest !T.Text
   | LogRequest !T.Text !Position !NormalizedFilePath
+  | LogRequestRange !T.Text !Range !NormalizedFilePath
   deriving (Show)
 
 instance Pretty Log where
@@ -44,6 +47,10 @@ instance Pretty Log where
     LogRequest label pos nfp ->
       pretty label <+> "request at position" <+> pretty (showPosition pos) <+>
         "in file:" <+> pretty (fromNormalizedFilePath nfp)
+    LogRequestRange label (Range start end) nfp ->
+      pretty label <+> "request for range" <+>
+        pretty (showPosition start) <> "-" <> pretty (showPosition end) <+>
+        "in file:" <+> pretty (fromNormalizedFilePath nfp)
 
 gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition)
 hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)
@@ -71,6 +78,38 @@ foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null
 foundHover (mbRange, contents) =
   InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange
 
+-- | Parameters of the @haskell/hoverRange@ request: a text document and the
+-- range to hover, typically the current selection.
+data HoverRangeParams = HoverRangeParams !TextDocumentIdentifier !Range
+
+instance A.FromJSON HoverRangeParams where
+  parseJSON = A.withObject "HoverRangeParams" $ \o ->
+    HoverRangeParams <$> o A..: "textDocument" <*> o A..: "range"
+
+-- | Handler for the @haskell/hoverRange@ custom request, an LSP extension
+-- modelled after rust-analyzer's \"Hover Range\" extension. It behaves like
+-- @textDocument/hover@, but hovers the smallest expression that covers the
+-- whole given range (typically the current selection), so clients can show
+-- the type of an arbitrary selected expression.
+--
+-- The response is a standard @Hover | null@ value.
+hoverRange :: Recorder (WithPriority Log) -> IdeState -> A.Value -> ExceptT PluginError (HandlerM c) A.Value
+hoverRange recorder ide params = case A.fromJSON params of
+  A.Error err ->
+    throwError $ PluginInvalidParams $ T.pack $ "Invalid hoverRange request parameters: " <> err
+  A.Success (HoverRangeParams (TextDocumentIdentifier uri) range) -> do
+    nfp <- getNormalizedFilePathE uri
+    liftIO $ do
+      logWith recorder Debug $ LogRequestRange "HoverRange" range nfp
+      mbResult <- runIdeAction "HoverRange" (shakeExtras ide) (getAtPointRange nfp range)
+      -- A node with neither identifiers nor types (e.g. a selection spanning
+      -- multiple declarations lands on the module root) produces an empty
+      -- hover; report null instead so clients don't render an empty popup.
+      let mbNonEmpty = case mbResult of
+            Just (_, texts) | any (not . T.null) texts -> mbResult
+            _                                          -> Nothing
+      pure $ A.toJSON $ maybe (InR Null) foundHover mbNonEmpty
+
 -- | Respond to and log a hover or go-to-definition request
 request
   :: T.Text

ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs

@@ -8,6 +8,7 @@ module Development.IDE.Plugin.HLS.GhcIde
   , Log(..)
   ) where
 
+import           Data.Proxy                          (Proxy (..))
 import           Development.IDE
 import qualified Development.IDE.LSP.HoverDefinition as Hover
 import qualified Development.IDE.LSP.Notifications   as Notifications
@@ -46,6 +47,8 @@ descriptors recorder =
 descriptor :: Recorder (WithPriority Hover.Log) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId desc)
   { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover (hover' recorder)
+                  <> mkPluginHandler (SMethod_CustomMethod (Proxy @"haskell/hoverRange")) (\ide _ params ->
+                      Hover.hoverRange recorder ide params)
                   <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline
                   <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} ->
                       Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})