Enhancements to hover

ghcide.cabal

@@ -134,6 +134,7 @@ library
         Development.IDE.LSP.Outline
         Development.IDE.Spans.AtPoint
         Development.IDE.Spans.Calculate
+        Development.IDE.Spans.Common
         Development.IDE.Spans.Documentation
         Development.IDE.Spans.Type
     ghc-options: -Wall -Wno-name-shadowing

src/Development/IDE/Core/Completions.hs

@@ -24,8 +24,6 @@ import Type
 import Var
 import Packages
 import DynFlags
-import ConLike
-import DataCon
 import SrcLoc as GHC
 
 import Language.Haskell.LSP.Types
@@ -36,19 +34,7 @@ import Development.IDE.Spans.Documentation
 import Development.IDE.GHC.Util
 import Development.IDE.GHC.Error
 import Development.IDE.Types.Options
-
--- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
-
-safeTyThingId :: TyThing -> Maybe Id
-safeTyThingId (AnId i)                    = Just i
-safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
-safeTyThingId _                           = Nothing
-
-safeTyThingType :: TyThing -> Maybe Type
-safeTyThingType thing
-  | Just i <- safeTyThingId thing = Just (varType i)
-safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)
-safeTyThingType _                 = Nothing
+import Development.IDE.Spans.Common
 
 -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
 

src/Development/IDE/Core/CompletionsTypes.hs

@@ -5,15 +5,11 @@ module Development.IDE.Core.CompletionsTypes (
 import           Control.DeepSeq
 import qualified Data.Map  as Map
 import qualified Data.Text as T
-
 import           GHC
-import           Outputable
-import           DynFlags
 
--- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
+import Development.IDE.Spans.Common
 
-showGhc :: Outputable a => a -> String
-showGhc = showPpr unsafeGlobalDynFlags
+-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
 
 data Backtick = Surrounded | LeftSide deriving Show
 data CompItem = CI

src/Development/IDE/Core/Rules.hs

@@ -262,9 +262,11 @@ getSpanInfoRule :: Rules ()
 getSpanInfoRule =
     define $ \GetSpanInfo file -> do
         tc <- use_ TypeCheck file
+        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
+        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
         (fileImports, _) <- use_ GetLocatedImports file
         packageState <- hscEnv <$> use_ GhcSession file
-        x <- liftIO $ getSrcSpanInfos packageState fileImports tc
+        x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms
         return ([], Just x)
 
 -- Typechecks a module.

src/Development/IDE/Spans/AtPoint.hs

@@ -8,7 +8,6 @@ module Development.IDE.Spans.AtPoint (
   , gotoDefinition
   ) where
 
-import           Development.IDE.Spans.Documentation
 import           Development.IDE.GHC.Error
 import Development.IDE.GHC.Orphans()
 import Development.IDE.Types.Location
@@ -18,7 +17,7 @@ import Development.Shake
 import Development.IDE.GHC.Util
 import Development.IDE.GHC.Compat
 import Development.IDE.Types.Options
-import           Development.IDE.Spans.Type as SpanInfo
+import Development.IDE.Spans.Type as SpanInfo
 
 -- GHC API imports
 import Avail
@@ -54,36 +53,39 @@ atPoint
   -> [SpanInfo]
   -> Position
   -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{..} tcs srcSpans pos = do
+atPoint IdeOptions{..} _ srcSpans pos = do
     firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
     return (Just (range firstSpan), hoverInfo firstSpan)
   where
     -- Hover info for types, classes, type variables
-    hoverInfo SpanInfo{spaninfoType = Nothing , ..} =
-       documentation <> (wrapLanguageSyntax <$> name <> kind) <> location
+    hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs ,  ..} =
+       (wrapLanguageSyntax <$> name) <> location <> docs
      where
-       documentation = findDocumentation mbName
        name     = [maybe shouldNotHappen showName  mbName]
        location = [maybe shouldNotHappen definedAt mbName]
-       kind     = [] -- TODO
        shouldNotHappen = "ghcide: did not expect a type level component without a name"
        mbName = getNameM spaninfoSource
 
     -- Hover info for values/data
-    hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =
-       documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location
+    hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} =
+       (wrapLanguageSyntax <$> nameOrSource) <> location <> docs
      where
        mbName = getNameM spaninfoSource
-       documentation  = findDocumentation mbName
-       typeAnnotation = [colon <> showName typ]
-       nameOrSource   = [maybe literalSource qualifyNameIfPossible mbName]
-       literalSource = "" -- TODO: literals: display (length-limited) source
+       typeAnnotation = colon <> showName typ
+       expr = case spaninfoSource of
+                Named n -> qualifyNameIfPossible n
+                Lit _ l -> crop $ T.pack l
+                _       -> ""
+       nameOrSource   = [expr <> "\n" <> typeAnnotation]
        qualifyNameIfPossible name' = modulePrefix <> showName name'
          where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
        location = [maybe "" definedAt mbName]
 
-    findDocumentation = maybe [] (getDocumentation tcs)
-    definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"
+    definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
+
+    crop txt
+      | T.length txt > 50 = T.take 46 txt <> " ..."
+      | otherwise         = txt
 
     range SpanInfo{..} = Range
       (Position spaninfoStartLine spaninfoStartCol)
@@ -112,6 +114,7 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
   where getSpan :: SpanSource -> m (Maybe SrcSpan)
         getSpan NoSource = pure Nothing
         getSpan (SpanS sp) = pure $ Just sp
+        getSpan (Lit _ _) = pure Nothing
         getSpan (Named name) = case nameSrcSpan name of
             sp@(RealSrcSpan _) -> pure $ Just sp
             sp@(UnhelpfulSpan _) -> runMaybeT $ do

src/Development/IDE/Spans/Calculate.hs

@@ -9,15 +9,14 @@
 
 -- | Get information on modules, identifiers, etc.
 
-module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where
+module Development.IDE.Spans.Calculate(getSrcSpanInfos) where
 
 import           ConLike
 import           Control.Monad
 import qualified CoreUtils
-import           Data.Data
-import qualified Data.Generics
 import           Data.List
 import           Data.Maybe
+import qualified Data.Text as T
 import           DataCon
 import           Desugar
 import           GHC
@@ -26,14 +25,15 @@ import           FastString (mkFastString)
 import           OccName
 import           Development.IDE.Types.Location
 import           Development.IDE.Spans.Type
-import           Development.IDE.GHC.Error (zeroSpan)
+import           Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
 import           Prelude hiding (mod)
 import           TcHsSyn
 import           Var
 import Development.IDE.Core.Compile
 import qualified Development.IDE.GHC.Compat as Compat
 import Development.IDE.GHC.Util
-
+import Development.IDE.Spans.Common
+import Development.IDE.Spans.Documentation
 
 -- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
 -- this U ignores that arg in 8.6, but is hidden in 8.4
@@ -48,33 +48,35 @@ getSrcSpanInfos
     :: HscEnv
     -> [(Located ModuleName, Maybe NormalizedFilePath)]
     -> TcModuleResult
+    -> [TcModuleResult]
     -> IO [SpanInfo]
-getSrcSpanInfos env imports tc =
-    runGhcEnv env
-        . getSpanInfo imports
-        $ tmrModule tc
+getSrcSpanInfos env imports tc tms =
+    runGhcEnv env $
+        getSpanInfo imports (tmrModule tc) (map tmrModule tms)
 
 -- | Get ALL source spans in the module.
 getSpanInfo :: GhcMonad m
             => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
             -> TypecheckedModule
+            -> [TypecheckedModule]
             -> m [SpanInfo]
-getSpanInfo mods tcm =
+getSpanInfo mods tcm tcms =
   do let tcs = tm_typechecked_source tcm
          bs  = listifyAllSpans  tcs :: [LHsBind GhcTc]
          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]
          ps  = listifyAllSpans' tcs :: [Pat GhcTc]
          ts  = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
-     let funBinds = funBindMap $ tm_parsed_module tcm
-     bts <- mapM (getTypeLHsBind funBinds) bs -- binds
-     ets <- mapM (getTypeLHsExpr tcm) es -- expressions
-     pts <- mapM (getTypeLPat tcm)    ps -- patterns
-     tts <- mapM (getLHsType tcm)     ts -- types
+         allModules = tcm:tcms
+         funBinds = funBindMap $ tm_parsed_module tcm
+     bts <- mapM (getTypeLHsBind allModules funBinds) bs   -- binds
+     ets <- mapM (getTypeLHsExpr allModules) es -- expressions
+     pts <- mapM (getTypeLPat allModules)    ps -- patterns
+     tts <- mapM (getLHsType allModules)     ts -- types
      let imports = importInfo mods
      let exports = getExports tcm
      let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
      return (mapMaybe toSpanInfo (sortBy cmp exprs))
-  where cmp (_,a,_) (_,b,_)
+  where cmp (_,a,_,_) (_,b,_,_)
           | a `isSubspanOf` b = LT
           | b `isSubspanOf` a = GT
           | otherwise         = compare (srcSpanStart a) (srcSpanStart b)
@@ -88,10 +90,10 @@ getSpanInfo mods tcm =
 funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)
 funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]
 
-getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]
+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type, [T.Text])]
 getExports m
     | Just (_, _, Just exports, _) <- renamedSource m =
-    [ (Named $ unLoc n, getLoc n, Nothing)
+    [ (Named $ unLoc n, getLoc n, Nothing, [])
     | (e, _) <- exports
     , n <- ieLNames $ unLoc e
     ]
@@ -107,31 +109,44 @@ ieLNames _ = []
 
 -- | Get the name and type of a binding.
 getTypeLHsBind :: (GhcMonad m)
-               => OccEnv (HsBind GhcPs)
+               => [TypecheckedModule]
+               -> OccEnv (HsBind GhcPs)
                -> LHsBind GhcTc
-               -> m [(SpanSource, SrcSpan, Maybe Type)]
-getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})
-  | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) =
-  return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
+               -> m [(SpanSource, SrcSpan, Maybe Type, [T.Text])]
+getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})
+  | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
+  let name = getName (unLoc pid)
+  docs <- getDocumentationTryGhc' tms name
+  return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
 -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
-getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
-  return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
-getTypeLHsBind _ _ = return []
+getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
+  let name = getName (unLoc pid)
+  docs <- getDocumentationTryGhc' tms name
+  return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
+getTypeLHsBind _ _ _ = return []
 
 -- | Get the name and type of an expression.
 getTypeLHsExpr :: (GhcMonad m)
-               => TypecheckedModule
+               => [TypecheckedModule]
                -> LHsExpr GhcTc
-               -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
-getTypeLHsExpr _ e = do
+               -> m (Maybe (SpanSource, SrcSpan, Maybe Type, [T.Text]))
+getTypeLHsExpr tms e = do
   hs_env <- getSession
   (_, mbe) <- liftIO (deSugarExpr hs_env e)
-  return $
-    case mbe of
-      Just expr ->
-        Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))
-      Nothing -> Nothing
+  case mbe of
+    Just expr -> do
+      let ss = getSpanSource' e
+      docs <- case ss of
+                Named n -> getDocumentationTryGhc' tms n
+                _       -> return []
+      return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
+    Nothing -> return Nothing
   where
+    getSpanSource' :: LHsExpr GhcTc -> SpanSource
+    getSpanSource' (L s xpr)
+      | HsLit U lit <- xpr = Lit s (showGhc lit)
+      | HsOverLit U lit <- xpr = Lit s (showGhc lit)
+    getSpanSource' xpr = getSpanSource (unLoc xpr)
     getSpanSource :: HsExpr GhcTc -> SpanSource
     getSpanSource (HsVar U (L _ i)) = Named (getName i)
     getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
@@ -142,12 +157,15 @@ getTypeLHsExpr _ e = do
 
 -- | Get the name and type of a pattern.
 getTypeLPat :: (GhcMonad m)
-            => TypecheckedModule
+            => [TypecheckedModule]
             -> Pat GhcTc
-            -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
-getTypeLPat _ pat =
-  let (src, spn) = getSpanSource pat in
-  return $ Just (src, spn, Just (hsPatType pat))
+            -> m (Maybe (SpanSource, SrcSpan, Maybe Type, [T.Text]))
+getTypeLPat tms pat = do
+  let (src, spn) = getSpanSource pat
+  docs <- case src of
+            Named n -> getDocumentationTryGhc' tms n
+            _       -> return []
+  return $ Just (src, spn, Just (hsPatType pat), docs)
   where
     getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
     getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
@@ -157,40 +175,36 @@ getTypeLPat _ pat =
 
 getLHsType
     :: GhcMonad m
-    => TypecheckedModule
+    => [TypecheckedModule]
     -> LHsType GhcRn
-    -> m [(SpanSource, SrcSpan, Maybe Type)]
-getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
+    -> m [(SpanSource, SrcSpan, Maybe Type, [T.Text])]
+getLHsType tms (L spn (HsTyVar U _ v)) = do
+  let n = unLoc v
+  docs <- getDocumentationTryGhc' tms n
+  ty <- catchSrcErrors "completion" $ do
+          name' <- lookupName n
+          return $ name' >>= safeTyThingType
+  let ty' = case ty of
+              Right (Just x) -> Just x
+              _ -> Nothing
+  pure [(Named n, spn, ty', docs)]
 getLHsType _ _ = pure []
 
 importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
-           -> [(SpanSource, SrcSpan, Maybe Type)]
+           -> [(SpanSource, SrcSpan, Maybe Type, [T.Text])]
 importInfo = mapMaybe (uncurry wrk) where
-  wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
+  wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type, [T.Text])
   wrk modName = \case
     Nothing -> Nothing
-    Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)
+    Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing, [])
 
   -- TODO make this point to the module name
   fpToSpanSource :: FilePath -> SpanSource
   fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
 
--- | Get ALL source spans in the source.
-listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
-listifyAllSpans tcs =
-  Data.Generics.listify p tcs
-  where p (L spn _) = isGoodSrcSpan spn
--- This is a version of `listifyAllSpans` specialized on picking out
--- patterns.  It comes about since GHC now defines `type LPat p = Pat
--- p` (no top-level locations).
-listifyAllSpans' :: Typeable a
-                   => TypecheckedSource -> [Pat a]
-listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
-
-
 -- | Pretty print the types into a 'SpanInfo'.
-toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo
-toSpanInfo (name,mspan,typ) =
+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, [T.Text]) -> Maybe SpanInfo
+toSpanInfo (name,mspan,typ,docs) =
   case mspan of
     RealSrcSpan spn ->
       -- GHC’s line and column numbers are 1-based while LSP’s line and column
@@ -200,5 +214,6 @@ toSpanInfo (name,mspan,typ) =
                      (srcSpanEndLine spn - 1)
                      (srcSpanEndCol spn - 1)
                      typ
-                     name)
+                     name
+                     docs)
     _ -> Nothing