Reimplement Hover/GotoDefn in terms of HIE Files.

Implement Document Hightlight LSP request
Add GetDocMap, GetHieFile rules.

ghcide.cabal

@@ -172,9 +172,7 @@ library
         Development.IDE.Import.FindImports
         Development.IDE.LSP.Notifications
         Development.IDE.Spans.AtPoint
-        Development.IDE.Spans.Calculate
         Development.IDE.Spans.Documentation
-        Development.IDE.Spans.Type
         Development.IDE.Plugin.CodeAction.PositionIndexed
         Development.IDE.Plugin.CodeAction.Rules
         Development.IDE.Plugin.CodeAction.RuleTypes

src/Development/IDE/Core/Compile.hs

@@ -269,7 +269,7 @@ mkTcModuleResult tcm upgradedError = do
     (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
 #endif
     let mod_info = HomeModInfo iface details Nothing
-    return $ TcModuleResult tcm mod_info upgradedError
+    return $ TcModuleResult tcm mod_info upgradedError Nothing
   where
     (tcGblEnv, details) = tm_internals_ tcm
 
@@ -280,7 +280,7 @@ atomicFileWrite targetPath write = do
   (tempFilePath, cleanUp) <- newTempFileWithin dir
   (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
 
-generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]
+generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO ([FileDiagnostic],Maybe Compat.HieFile)
 generateAndWriteHieFile hscEnv tcm =
   handleGenerationErrors dflags "extended interface generation" $ do
     case tm_renamed_source tcm of
@@ -288,8 +288,9 @@ generateAndWriteHieFile hscEnv tcm =
         hf <- runHsc hscEnv $
           GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""
         atomicFileWrite targetPath $ flip GHC.writeHieFile hf
+        pure (Just hf)
       _ ->
-        return ()
+        return Nothing
   where
     dflags       = hsc_dflags hscEnv
     mod_summary  = pm_mod_summary $ tm_parsed_module tcm
@@ -298,19 +299,20 @@ generateAndWriteHieFile hscEnv tcm =
 
 writeHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
 writeHiFile hscEnv tc =
-  handleGenerationErrors dflags "interface generation" $ do
+  fst <$> (handleGenerationErrors dflags "interface generation" $ do
     atomicFileWrite targetPath $ \fp ->
       writeIfaceFile dflags fp modIface
+    pure Nothing)
   where
     modIface = hm_iface $ tmrModInfo tc
     targetPath = ml_hi_file $ ms_location $ tmrModSummary tc
     dflags = hsc_dflags hscEnv
 
-handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
+handleGenerationErrors :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic],Maybe a)
 handleGenerationErrors dflags source action =
-  action >> return [] `catches`
+  (([],) <$> action) `catches`
-    [ Handler $ return . diagFromGhcException source dflags
+    [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-    , Handler $ return . diagFromString source DsError (noSpan "<internal>")
+    , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")
     . (("Error during " ++ T.unpack source) ++) . show @SomeException
     ]
 

src/Development/IDE/Core/FileStore.hs

@@ -218,7 +218,7 @@ setFileModified state prop nfp = do
     let da = mkDelayedAction "FileStoreTC" L.Info $ do
           ShakeExtras{progressUpdate} <- getShakeExtras
           liftIO $ progressUpdate KickStarted
-          void $ use GetSpanInfo nfp
+          void $ use GetHieFile nfp
           liftIO $ progressUpdate KickCompleted
     shakeRestart state [da]
     when prop $

src/Development/IDE/Core/RuleTypes.hs

@@ -14,19 +14,20 @@ module Development.IDE.Core.RuleTypes(
 import           Control.DeepSeq
 import Data.Binary
 import           Development.IDE.Import.DependencyInformation
-import Development.IDE.GHC.Compat
+import Development.IDE.GHC.Compat hiding (HieFileResult)
 import Development.IDE.GHC.Util
 import           Data.Hashable
 import           Data.Typeable
 import qualified Data.Set as S
 import qualified Data.HashSet                             as HS
+import qualified Data.Map as M
 import           Development.Shake
 import           GHC.Generics                             (Generic)
 
 import Module (InstalledUnitId)
 import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
 
-import           Development.IDE.Spans.Type
+import           Development.IDE.Spans.Common
 import           Development.IDE.Import.FindImports (ArtifactsLocation)
 import Data.ByteString (ByteString)
 import Language.Haskell.LSP.Types (NormalizedFilePath)
@@ -66,6 +67,7 @@ data TcModuleResult = TcModuleResult
     -- HomeModInfo instead
     , tmrModInfo    :: HomeModInfo
     , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
+    , tmrHieFile    :: Maybe HieFile
     }
 instance Show TcModuleResult where
     show = show . pm_mod_summary . tm_parsed_module . tmrModule
@@ -101,8 +103,25 @@ instance Show HiFileResult where
 -- | The type checked version of this file, requires TypeCheck+
 type instance RuleResult TypeCheck = TcModuleResult
 
+data HieFileResult = HFR { hieFile :: !HieFile, refmap :: !RefMap }
+
+instance NFData HieFileResult where
+    rnf (HFR hf rm) = rnf hf `seq` rnf rm
+
+instance Show HieFileResult where
+    show = show . hie_module . hieFile
+
 -- | Information about what spans occur where, requires TypeCheck
-type instance RuleResult GetSpanInfo = SpansInfo
+type instance RuleResult GetHieFile = HieFileResult
+
+newtype PDocMap = PDocMap {getDocMap :: DocMap}
+instance NFData PDocMap where
+    rnf = rwhnf
+
+instance Show PDocMap where
+    show = const "docmap"
+
+type instance RuleResult GetDocMap = PDocMap
 
 -- | Convert to Core, requires TypeCheck*
 type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
@@ -184,11 +203,18 @@ instance Hashable TypeCheck
 instance NFData   TypeCheck
 instance Binary   TypeCheck
 
-data GetSpanInfo = GetSpanInfo
+data GetHieFile = GetHieFile
     deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetSpanInfo
+instance Hashable GetHieFile
-instance NFData   GetSpanInfo
+instance NFData   GetHieFile
-instance Binary   GetSpanInfo
+instance Binary   GetHieFile
+
+data GetDocMap = GetDocMap
+    deriving (Eq, Show, Typeable, Generic)
+
+instance Hashable GetDocMap
+instance NFData   GetDocMap
+instance Binary   GetDocMap
 
 data GenerateCore = GenerateCore
     deriving (Eq, Show, Typeable, Generic)

src/Development/IDE/Core/Rules.hs

@@ -24,6 +24,7 @@ module Development.IDE.Core.Rules(
     getAtPoint,
     getDefinition,
     getTypeDefinition,
+    highlightAtPoint,
     getDependencies,
     getParsedModule,
     generateCore,
@@ -39,7 +40,7 @@ import Control.Monad.Trans.Maybe
 import Development.IDE.Core.Compile
 import Development.IDE.Core.OfInterest
 import Development.IDE.Types.Options
-import Development.IDE.Spans.Calculate
+import Development.IDE.Spans.Documentation
 import Development.IDE.Import.DependencyInformation
 import Development.IDE.Import.FindImports
 import           Development.IDE.Core.FileExists
@@ -61,9 +62,9 @@ import qualified Data.Text                                as T
 import           Development.IDE.GHC.Error
 import           Development.Shake                        hiding (Diagnostic)
 import Development.IDE.Core.RuleTypes
-import Development.IDE.Spans.Type
 import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Core.PositionMapping
+import           Language.Haskell.LSP.Types (DocumentHighlight (..))
 
 import qualified GHC.LanguageExtensions as LangExt
 import HscTypes
@@ -131,26 +132,35 @@ getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [
 getAtPoint file pos = fmap join $ runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
-  (spans, mapping) <- useE  GetSpanInfo file
+
+  (HFR hf _, mapping) <- useE GetHieFile file
+  PDocMap dm <- lift $ maybe (PDocMap mempty) fst <$> (runMaybeT $ useE GetDocMap file)
+
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-  return $ AtPoint.atPoint opts spans pos'
+  return $ AtPoint.atPoint opts hf dm pos'
 
 -- | Goto Definition.
 getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
 getDefinition file pos = runMaybeT $ do
     ide <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (spans,mapping) <- useE GetSpanInfo file
+    (HFR hf _, mapping) <- useE GetHieFile file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos'
+    AtPoint.gotoDefinition (getHieFile ide file) opts hf pos'
 
 getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getTypeDefinition file pos = runMaybeT $ do
     ide <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (spans,mapping) <- useE GetSpanInfo file
+    (HFR hf _, mapping) <- useE GetHieFile file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    AtPoint.gotoTypeDefinition (getHieFile ide file) opts (spansExprs spans) pos'
+    AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos'
+
+highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
+highlightAtPoint file pos = runMaybeT $ do
+    (HFR hf rf,mapping) <- useE GetHieFile file
+    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+    AtPoint.documentHighlight hf rf pos'
 
 getHieFile
   :: ShakeExtras
@@ -193,7 +203,6 @@ getHomeHieFile f = do
       ncu <- mkUpdater
       liftIO $ loadHieFile ncu hie_f
 
-
 getPackageHieFile :: ShakeExtras
                   -> Module             -- ^ Package Module to load .hie file for
                   -> NormalizedFilePath -- ^ Path of home module importing the package module
@@ -490,27 +499,41 @@ getDependenciesRule =
         let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
         return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))
 
--- Source SpanInfo is used by AtPoint and Goto Definition.
+getHieFileRule :: Rules ()
-getSpanInfoRule :: Rules ()
+getHieFileRule =
-getSpanInfoRule =
+    define $ \GetHieFile f -> do
-    define $ \GetSpanInfo file -> do
+      tcm <- use_ TypeCheck f
-        tc <- use_ TypeCheck file
+      hf <- case tmrHieFile tcm of
-        packageState <- hscEnv <$> use_ GhcSessionDeps file
+        Just hf -> pure ([],Just hf)
+        Nothing -> do
+          hsc  <- hscEnv <$> use_ GhcSession f
+          liftIO $ generateAndWriteHieFile hsc (tmrModule tcm)
+      let refmap = generateReferencesMap . getAsts . hie_asts
+      pure $ fmap (\x -> HFR x $ refmap x) <$> hf
+
+
+getDocMapRule :: Rules ()
+getDocMapRule =
+    define $ \GetDocMap file -> do
+      hmi <- hirModIface <$> use_ GetModIface file
+      hsc <- hscEnv <$> use_ GhcSessionDeps file
+      HFR _ rf <- use_ GetHieFile file
+
+      deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
+      let tdeps = transitiveModuleDeps deps
 
 -- When possible, rely on the haddocks embedded in our interface files
 -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
 #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
-        let parsedDeps = []
+      let parsedDeps = []
 #else
-        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
+      parsedDeps <- uses_ GetParsedModule tdeps
-        let tdeps = transitiveModuleDeps deps
-        parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps
 #endif
 
-        (fileImports, _) <- use_ GetLocatedImports file
+      ifaces <- uses_ GetModIface tdeps
-        let imports = second (fmap artifactFilePath) <$> fileImports
+
-        x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps
+      docMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf hmi (map hirModIface ifaces)
-        return ([], Just x)
+      return ([],Just $ PDocMap docMap)
 
 -- Typechecks a module.
 typeCheckRule :: Rules ()
@@ -560,9 +583,9 @@ typeCheckRuleDefinition hsc pm generateArtifacts = do
         -- type errors, as we won't get proper diagnostics if we load these from
         -- disk
         , not $ tmrDeferedError tcm -> do
-        diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)
+        (diagsHie,hf) <- generateAndWriteHieFile hsc (tmrModule tcm)
         diagsHi  <- writeHiFile hsc tcm
-        return (diags <> diagsHi <> diagsHie, Just tcm)
+        return (diags <> diagsHi <> diagsHie, Just tcm{tmrHieFile=hf})
       (diags, res) ->
         return (diags, snd <$> res)
  where
@@ -829,7 +852,8 @@ mainRule = do
     reportImportCyclesRule
     getDependenciesRule
     typeCheckRule
-    getSpanInfoRule
+    getHieFileRule
+    getDocMapRule
     generateCoreRule
     generateByteCodeRule
     loadGhcSession

src/Development/IDE/GHC/Compat.hs

@@ -14,6 +14,7 @@ module Development.IDE.GHC.Compat(
     HieFileResult(..),
     HieFile(..),
     NameCacheUpdater(..),
+    RefMap,
     hieExportNames,
     mkHieFile,
     writeHieFile,
@@ -112,6 +113,7 @@ import FastString (FastString)
 #if MIN_GHC_API_VERSION(8,6,0)
 import Development.IDE.GHC.HieAst (mkHieFile)
 import Development.IDE.GHC.HieBin
+import Data.Map (Map)
 
 #if MIN_GHC_API_VERSION(8,8,0)
 import HieUtils
@@ -455,6 +457,8 @@ getConArgs = GHC.getConArgs
 getConArgs = GHC.getConDetails
 #endif
 
+type RefMap = Map Identifier [(Span, IdentifierDetails TypeIndex)]
+
 getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
 getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))
 

src/Development/IDE/GHC/Orphans.hs

@@ -75,3 +75,9 @@ deriving instance Eq SourceModified
 deriving instance Show SourceModified
 instance NFData SourceModified where
     rnf = rwhnf
+
+instance NFData a => NFData (IdentifierDetails a) where
+    rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b)
+
+instance NFData RealSrcSpan where
+    rnf = rwhnf

src/Development/IDE/LSP/HoverDefinition.hs

@@ -7,6 +7,7 @@ module Development.IDE.LSP.HoverDefinition
     ( setHandlersHover
     , setHandlersDefinition
     , setHandlersTypeDefinition
+    , setHandlersDocHighlight
     -- * For haskell-language-server
     , hover
     , gotoDefinition
@@ -27,21 +28,25 @@ import qualified Data.Text as T
 gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
 hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
 gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
+documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight))
 gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
 gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc
 hover          = request "Hover"      getAtPoint     Nothing      foundHover
+documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List
 
 foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
 foundHover (mbRange, contents) =
   Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
 
-setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition :: PartialHandlers c
+setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c
 setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
   return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
 setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->
   return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}
 setHandlersHover      = PartialHandlers $ \WithMessage{..} x ->
   return x{LSP.hoverHandler      = withResponse RspHover      $ const hover}
+setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->
+  return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}
 
 -- | Respond to and log a hover or go-to-definition request
 request

src/Development/IDE/LSP/LanguageServer.hs

@@ -104,6 +104,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
             initializeRequestHandler <>
             setHandlersIgnore <> -- least important
             setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <>
+            setHandlersDocHighlight <>
             setHandlersOutline <>
             userHandlers <>
             setHandlersNotifications <> -- absolutely critical, join them with user notifications

src/Development/IDE/Spans/AtPoint.hs

@@ -7,25 +7,24 @@ module Development.IDE.Spans.AtPoint (
     atPoint
   , gotoDefinition
   , gotoTypeDefinition
+  , documentHighlight
   ) where
 
 import           Development.IDE.GHC.Error
 import Development.IDE.GHC.Orphans()
 import Development.IDE.Types.Location
+import           Language.Haskell.LSP.Types
 
 -- DAML compiler and infrastructure
 import Development.IDE.GHC.Compat
 import Development.IDE.Types.Options
-import Development.IDE.Spans.Type as SpanInfo
+import Development.IDE.Spans.Common
-import Development.IDE.Spans.Common (showName, spanDocToMarkdown)
 
 -- GHC API imports
 import FastString
 import Name
 import Outputable hiding ((<>))
 import SrcLoc
-import Type
-import VarSet
 
 import Control.Monad.Extra
 import Control.Monad.Trans.Maybe
@@ -34,102 +33,93 @@ import Control.Monad.IO.Class
 import           Data.Maybe
 import           Data.List
 import qualified Data.Text as T
+import qualified Data.Map as M
+import qualified Data.Array as A
+
+
+import IfaceType
+import Data.Either
+import Data.List.Extra (dropEnd)
+
+documentHighlight
+  :: Monad m
+  => HieFile
+  -> RefMap
+  -> Position
+  -> MaybeT m [DocumentHighlight]
+documentHighlight hf rf pos = MaybeT $ pure (Just highlights)
+  where
+    ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo)
+    highlights = do
+      n <- ns
+      ref <- maybe [] id (M.lookup (Right n) rf)
+      pure $ makeHighlight ref
+    makeHighlight (sp,dets) =
+      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
+    highlightType s =
+      if any (isJust . getScopeFromContext) s
+        then HkWrite
+        else HkRead
 
 gotoTypeDefinition
   :: MonadIO m
   => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
-  -> [SpanInfo]
+  -> HieFile
   -> Position
   -> MaybeT m [Location]
 gotoTypeDefinition getHieFile ideOpts srcSpans pos
-  = typeLocationsAtPoint getHieFile ideOpts pos srcSpans
+  = lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans
 
 -- | Locate the definition of the name at a given position.
 gotoDefinition
   :: MonadIO m
   => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
-  -> [SpanInfo]
+  -> HieFile
   -> Position
   -> MaybeT m Location
-gotoDefinition getHieFile ideOpts srcSpans pos =
+gotoDefinition getHieFile ideOpts srcSpans pos
-  MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans
+  = MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts pos srcSpans
 
 -- | Synopsis for the name at a given position.
 atPoint
   :: IdeOptions
-  -> SpansInfo
+  -> HieFile
+  -> DocMap
   -> Position
   -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
+atPoint IdeOptions{} hf dm pos = listToMaybe $ pointCommand hf pos hoverInfo
-    firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
-    let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
-        -- Filter out the empty lines so we don't end up with a bunch of
-        -- horizontal separators with nothing inside of them
-        text = filter (not . T.null) $ hoverInfo firstSpan constraintsAtPoint
-    return (Just (range firstSpan), text)
   where
-    -- Hover info for types, classes, type variables
-    hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs ,  ..} _ =
-       (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs
-     where
-       name     = [maybe shouldNotHappen showName  mbName]
-       location = [maybe shouldNotHappen definedAt mbName]
-       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), spaninfoDocs = docs , ..} cnts =
+    hoverInfo ast =
-       (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs
+      (Just range, prettyNames ++ pTypes)
-     where
+      where
-       mbName = getNameM spaninfoSource
+        pTypes
-       expr = case spaninfoSource of
+          | length names == 1 = dropEnd 1 $ map wrapHaskell prettyTypes
-                Named n -> qualifyNameIfPossible n
+          | otherwise = map wrapHaskell prettyTypes
-                Lit   l -> crop $ T.pack l
-                _       -> ""
-       nameOrSource   = [expr <> "\n" <> typeAnnotation]
-       qualifyNameIfPossible name' = modulePrefix <> showName name'
-         where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
-       location = [maybe "" definedAt mbName]
 
-       thisFVs = tyCoVarsOfType typ
+        range = realSrcSpanToRange $ nodeSpan ast
-       constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
-       constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
 
-       typeAnnotation = case constraintsOverFVs of
+        wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
-                          []  -> colon <> showName typ
+        info = nodeInfo ast
-                          [_] -> colon <> constraintsT <> "\n=> " <> showName typ
+        names = M.assocs $ nodeIdentifiers info
-                          _   -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
+        types = nodeType info
 
-    definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
+        prettyNames :: [T.Text]
+        prettyNames = map prettyName names
+        prettyName (Right n, dets) = T.unlines $
+          wrapHaskell (showName n <> maybe "" (" :: " <> ) (prettyType <$> identType dets))
+          : definedAt n
+          : concat (maybeToList (spanDocToMarkdown <$> M.lookup n dm))
+        prettyName (Left m,_) = showName m
 
-    crop txt
+        prettyTypes = map (("_ :: "<>) . prettyType) types
-      | T.length txt > 50 = T.take 46 txt <> " ..."
+        prettyType t = showName $ hieTypeToIface $ recoverFullType t arr
-      | otherwise         = txt
-
-    range SpanInfo{..} = Range
-      (Position spaninfoStartLine spaninfoStartCol)
-      (Position spaninfoEndLine spaninfoEndCol)
-
-    colon = if optNewColonConvention then ": " else ":: "
-    wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
-
-    -- NOTE(RJR): This is a bit hacky.
-    -- We don't want to show the user type signatures generated from Eq and Show
-    -- instances, as they do not appear in the source program.
-    -- However the user could have written an `==` or `show` function directly,
-    -- in which case we still want to show information for that.
-    -- Hence we just move such information later in the list of spans.
-    deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
-    deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)
-    isTypeclassDeclSpan :: SpanInfo -> Bool
-    isTypeclassDeclSpan spanInfo =
-      case getNameM (spaninfoSource spanInfo) of
-        Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
-        Nothing -> False
 
+        definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"
 
+        arr = hie_types hf
 
 typeLocationsAtPoint
   :: forall m
@@ -137,16 +127,17 @@ typeLocationsAtPoint
   => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
   -> Position
-  -> [SpanInfo]
+  -> HieFile
-  -> MaybeT m [Location]
+  -> m [Location]
-typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan
+typeLocationsAtPoint getHieFile _ideOptions pos ast =
-  where getTypeSpan :: SpanInfo -> m (Maybe SrcSpan)
+  let ts = concat $ pointCommand ast pos (nodeType . nodeInfo)
-        getTypeSpan SpanInfo { spaninfoType = Just t } =
+      arr = hie_types ast
-          case splitTyConApp_maybe t of
+      its = map (arr A.!) ts
-            Nothing -> return Nothing
+      ns = flip mapMaybe its $ \case
-            Just (getName -> name, _) ->
+        HTyConApp tc _ -> Just $ ifaceTyConName tc
-              nameToLocation getHieFile name
+        HTyVarTy n -> Just n
-        getTypeSpan _ = return Nothing
+        _ -> Nothing
+    in mapMaybeM (nameToLocation getHieFile) ns
 
 locationsAtPoint
   :: forall m
@@ -154,33 +145,20 @@ locationsAtPoint
   => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
   -> Position
-  -> [SpanInfo]
+  -> HieFile
-  -> MaybeT m [Location]
+  -> m [Location]
-locationsAtPoint getHieFile = querySpanInfoAt (getSpan . spaninfoSource)
+locationsAtPoint getHieFile _ideOptions pos ast =
-  where getSpan :: SpanSource -> m (Maybe SrcSpan)
+  let ns = concat $ pointCommand ast pos (rights . M.keys . nodeIdentifiers . nodeInfo)
-        getSpan NoSource = pure Nothing
+    in mapMaybeM (nameToLocation getHieFile) ns
-        getSpan (SpanS sp) = pure $ Just sp
-        getSpan (Lit _) = pure Nothing
-        getSpan (Named name) = nameToLocation getHieFile name
-
-querySpanInfoAt :: forall m
-   . MonadIO m
-  => (SpanInfo -> m (Maybe SrcSpan))
-  -> IdeOptions
-  -> Position
-  -> [SpanInfo]
-  -> MaybeT m [Location]
-querySpanInfoAt getSpan _ideOptions pos =
-    lift . fmap (mapMaybe srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos
 
 -- | Given a 'Name' attempt to find the location where it is defined.
-nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe SrcSpan)
+nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location)
-nameToLocation getHieFile name =
+nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $
   case nameSrcSpan name of
     sp@(RealSrcSpan _) -> pure $ Just sp
     sp@(UnhelpfulSpan _) -> runMaybeT $ do
       guard (sp /= wiredInSrcSpan)
-      -- This case usually arises when the definition is in an external package (DAML only).
+      -- This case usually arises when the definition is in an external package.
       -- In this case the interface files contain garbage source spans
       -- so we instead read the .hie files to get useful source spans.
       mod <- MaybeT $ return $ nameModule_maybe name
@@ -198,24 +176,16 @@ nameToLocation getHieFile name =
     setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
     setFileName _ span@(UnhelpfulSpan _) = span
 
--- | Filter out spans which do not enclose a given point
+pointCommand :: HieFile -> Position -> (HieAST TypeIndex -> a) -> [a]
-spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
+pointCommand hf pos k =
-spansAtPoint pos = filter atp where
+    catMaybes $ M.elems $ flip M.mapWithKey (getAsts $ hie_asts hf) $ \fs ast ->
-  line = _line pos
+      case selectSmallestContaining (sp fs) ast of
-  cha = _character pos
+        Nothing -> Nothing
-  atp SpanInfo{..} =
+        Just ast' -> Just $ k ast'
-      startsBeforePosition && endsAfterPosition
+ where
-    where
+   sloc fs = mkRealSrcLoc fs (line+1) (cha+1)
-      startLineCmp = compare spaninfoStartLine line
+   sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
-      endLineCmp   = compare spaninfoEndLine   line
+   line = _line pos
-
+   cha = _character pos
-      startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)
-                                              -- The end col points to the column after the
-                                              -- last character so we use > instead of >=
-      endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)
 
 
-getModuleNameAsText :: Name -> Maybe T.Text
-getModuleNameAsText n = do
-  m <- nameModule_maybe n
-  return . T.pack . moduleNameString $ moduleName m

src/Development/IDE/Spans/Calculate.hs

@@ -1,268 +0,0 @@
--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RankNTypes #-}
-#include "ghc-api-version.h"
-
--- | Get information on modules, identifiers, etc.
-
-module Development.IDE.Spans.Calculate(getSrcSpanInfos) where
-
-import           ConLike
-import           Control.Monad
-import qualified CoreUtils
-import           Data.List
-import           Data.Maybe
-import           DataCon
-import           Desugar
-import           GhcMonad
-import           HscTypes
-import           FastString (mkFastString)
-import           OccName
-import           Development.IDE.Types.Location
-import           Development.IDE.Spans.Type
-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.Compat
-import Development.IDE.GHC.Util
-import Development.IDE.Spans.Common
-import Development.IDE.Spans.Documentation
-import Data.List.Extra (nubOrd)
-import qualified Data.Map.Strict as Map
-
--- 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
-#if MIN_GHC_API_VERSION(8,6,0)
-#define U _
-#else
-#define U
-#endif
-
--- | Get source span info, used for e.g. AtPoint and Goto Definition.
-getSrcSpanInfos
-    :: HscEnv
-    -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
-    -> TcModuleResult
-    -> [ParsedModule]   -- ^ Dependencies parsed, optional if the 'HscEnv' already contains docs
-    -> IO SpansInfo
-getSrcSpanInfos env imports tc parsedDeps =
-    evalGhcEnv env $
-        getSpanInfo imports tc parsedDeps
-
--- | Get ALL source spans in the module.
-getSpanInfo :: GhcMonad m
-            => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
-            -> TcModuleResult
-            -> [ParsedModule]
-            -> m SpansInfo
-getSpanInfo mods TcModuleResult{tmrModInfo, tmrModule = tcm@TypecheckedModule{..}} parsedDeps =
-  do let tcs = tm_typechecked_source
-         bs  = listifyAllSpans  tcs :: [LHsBind GhcTc]
-         es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]
-         ps  = listifyAllSpans' tcs :: [Pat GhcTc]
-         ts  = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
-         allModules = tm_parsed_module : parsedDeps
-         funBinds = funBindMap tm_parsed_module
-         thisMod = ms_mod $ pm_mod_summary tm_parsed_module
-         modIface = hm_iface tmrModInfo
-
-     -- Load this module in HPT to make its interface documentation available
-     modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
-
-     bts <- mapM (getTypeLHsBind funBinds) bs   -- binds
-     ets <- mapM getTypeLHsExpr es -- expressions
-     pts <- mapM getTypeLPat  ps -- patterns
-     tts <- concat <$> mapM getLHsType ts -- types
-
-     -- Batch extraction of kinds
-     let typeNames = nubOrd [ n | (Named n, _) <- tts]
-     kinds <- Map.fromList . zip typeNames  <$> mapM (lookupKind thisMod) typeNames
-     let withKind (Named n, x) =
-            (Named n, x, join $ Map.lookup n kinds)
-         withKind (other, x) =
-            (other, x, Nothing)
-     tts <- pure $ map withKind tts
-
-     let imports = importInfo mods
-     let exports = getExports tcm
-     let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ tts ++ catMaybes (ets ++ pts)
-     let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
-         sortedExprs = sortBy cmp exprs
-         sortedConstraints = sortBy cmp constraints
-
-    -- Batch extraction of Haddocks
-     let names = nubOrd [ s | (Named s,_,_) <- sortedExprs ++ sortedConstraints]
-     docs <- Map.fromList . zip names <$> getDocumentationsTryGhc thisMod allModules names
-     let withDocs (Named n, x, y) = (Named n, x, y, Map.findWithDefault emptySpanDoc n docs)
-         withDocs (other, x, y) = (other, x, y, emptySpanDoc)
-
-     return $ SpansInfo (mapMaybe (toSpanInfo . withDocs) sortedExprs)
-                        (mapMaybe (toSpanInfo . withDocs) sortedConstraints)
-  where cmp (_,a,_) (_,b,_)
-          | a `isSubspanOf` b = LT
-          | b `isSubspanOf` a = GT
-          | otherwise         = compare (srcSpanStart a) (srcSpanStart b)
-
-        addEmptyInfo = map (\(a,b) -> (a,b,Nothing))
-        constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty)
-
-lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type)
-lookupKind mod =
-    fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod
--- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
--- points to the first match) whereas the parsed module has the correct locations.
--- Therefore we build up a map from OccName to the corresponding definition in the parsed module
--- to lookup precise locations for things like multi-clause function definitions.
---
--- For now this only contains FunBinds.
-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)]
-getExports m
-    | Just (_, _, Just exports, _) <- renamedSource m =
-    [ (Named $ unLoc n, getLoc n)
-    | (e, _) <- exports
-    , n <- ieLNames $ unLoc e
-    ]
-getExports _ = []
-
--- | Variant of GHC's ieNames that produces LIdP instead of IdP
-ieLNames :: IE pass -> [Located (IdP pass)]
-ieLNames (IEVar       U n   )     = [ieLWrappedName n]
-ieLNames (IEThingAbs  U n   )     = [ieLWrappedName n]
-ieLNames (IEThingAll    n   )     = [ieLWrappedName n]
-ieLNames (IEThingWith   n _ ns _) = ieLWrappedName n : map ieLWrappedName ns
-ieLNames _ = []
-
--- | Get the name and type of a binding.
-getTypeLHsBind :: (Monad m)
-               => 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) = do
-  let name = getName (unLoc pid)
-  return [(Named name, getLoc mc_fun, Just (varType (unLoc pid))) | 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{}}) = do
-  let name = getName (unLoc pid)
-  return [(Named name, getLoc pid, Just (varType (unLoc pid)))]
-getTypeLHsBind _ _ = return []
-
--- | Get information about constraints
-getConstraintsLHsBind :: LHsBind GhcTc
-                      -> [(SrcSpan, Type)]
-getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })
-  = map (\v -> (spn, varType v)) vars
-getConstraintsLHsBind _ = []
-
--- | Get the name and type of an expression.
-getTypeLHsExpr :: (GhcMonad m)
-               => LHsExpr GhcTc
-               -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
-getTypeLHsExpr e = do
-  hs_env <- getSession
-  (_, mbe) <- liftIO (deSugarExpr hs_env e)
-  case mbe of
-    Just expr -> do
-      let ss = getSpanSource (unLoc e)
-      return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr))
-    Nothing -> return Nothing
-  where
-    getSpanSource :: HsExpr GhcTc -> SpanSource
-    getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
-    getSpanSource (HsVar U (L _ i)) = Named (getName i)
-    getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
-    getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
-    getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
-    getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
-    getSpanSource _ = NoSource
-
-    isLit :: HsExpr GhcTc -> Bool
-    isLit (HsLit U _) = True
-    isLit (HsOverLit U _) = True
-    isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args
-#if MIN_GHC_API_VERSION(8,6,0)
-    isLit (ExplicitSum  U _ _ xpr) = isLitChild (unLoc xpr)
-    isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs
-#else
-    isLit (ExplicitSum  _ _ xpr _) = isLitChild (unLoc xpr)
-    isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs
-#endif
-    isLit _ = False
-
-    isTupLit (Present U xpr) = isLitChild (unLoc xpr)
-    isTupLit _               = False
-
-    -- We need special treatment for children so things like [(1)] are still treated
-    -- as a list literal while not treating (1) as a literal.
-    isLitChild (HsWrap U _ xpr) = isLitChild xpr
-    isLitChild (HsPar U xpr)    = isLitChild (unLoc xpr)
-#if MIN_GHC_API_VERSION(8,8,0)
-    isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)
-#elif MIN_GHC_API_VERSION(8,6,0)
-    isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)
-#else
-    isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)
-    isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)
-#endif
-    isLitChild e = isLit e
-
--- | Get the name and type of a pattern.
-getTypeLPat :: (Monad m)
-            => Pat GhcTc
-            -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
-getTypeLPat pat = do
-  let (src, spn) = getSpanSource pat
-  return $ Just (src, spn, Just (hsPatType pat))
-  where
-    getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
-    getSpanSource (VarPat (L spn vid)) = (Named (getName vid), spn)
-    getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) =
-      (Named (dataConName dc), spn)
-    getSpanSource _ = (NoSource, noSrcSpan)
-
-getLHsType
-    :: Monad m
-    => LHsType GhcRn
-    -> m [(SpanSource, SrcSpan)]
-getLHsType (L spn (HsTyVar U _ v)) = do
-  let n = unLoc v
-  pure [(Named n, spn)]
-getLHsType _ = pure []
-
-importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
-           -> [(SpanSource, SrcSpan)]
-importInfo = mapMaybe (uncurry wrk) where
-  wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)
-  wrk modName = \case
-    Nothing -> Nothing
-    Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)
-
-  -- TODO make this point to the module name
-  fpToSpanSource :: FilePath -> SpanSource
-  fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
-
--- | Pretty print the types into a 'SpanInfo'.
-toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> 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
-      -- numbers are 0-based.
-      Just (SpanInfo (srcSpanStartLine spn - 1)
-                     (srcSpanStartCol spn - 1)
-                     (srcSpanEndLine spn - 1)
-                     (srcSpanEndCol spn - 1)
-                     typ
-                     name
-                     docs)
-    _ -> Nothing

src/Development/IDE/Spans/Common.hs

@@ -4,8 +4,6 @@
 module Development.IDE.Spans.Common (
   showGhc
 , showName
-, listifyAllSpans
-, listifyAllSpans'
 , safeTyThingId
 , safeTyThingType
 , SpanDoc(..)
@@ -13,6 +11,7 @@ module Development.IDE.Spans.Common (
 , emptySpanDoc
 , spanDocToMarkdown
 , spanDocToMarkdownForTest
+, DocMap
 ) where
 
 import Data.Data
@@ -20,6 +19,7 @@ import qualified Data.Generics
 import Data.Maybe
 import qualified Data.Text as T
 import Data.List.Extra
+import Data.Map (Map)
 
 import GHC
 import Outputable hiding ((<>))
@@ -31,6 +31,8 @@ import Var
 import qualified Documentation.Haddock.Parser as H
 import qualified Documentation.Haddock.Types as H
 
+type DocMap = Map Name SpanDoc
+
 showGhc :: Outputable a => a -> String
 showGhc = showPpr unsafeGlobalDynFlags
 
@@ -40,18 +42,6 @@ showName = T.pack . prettyprint
     prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
     style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
 
--- | 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
-
 -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
 safeTyThingType :: TyThing -> Maybe Type
 safeTyThingType thing

src/Development/IDE/Spans/Documentation.hs

@@ -9,12 +9,15 @@ module Development.IDE.Spans.Documentation (
     getDocumentation
   , getDocumentationTryGhc
   , getDocumentationsTryGhc
+  , DocMap
+  , mkDocMap
   ) where
 
 import           Control.Monad
 import           Data.Foldable
 import           Data.List.Extra
 import qualified Data.Map as M
+import qualified Data.Set as S
 import           Data.Maybe
 import qualified Data.Text as T
 #if MIN_GHC_API_VERSION(8,6,0)
@@ -32,6 +35,26 @@ import           GhcMonad
 import           Packages
 import           Name
 import           Language.Haskell.LSP.Types (getUri, filePathToUri)
+import Data.Either
+
+mkDocMap
+  :: GhcMonad m
+  => [ParsedModule]
+  -> RefMap
+  -> ModIface
+  -> [ModIface]
+  -> m DocMap
+mkDocMap sources rm hmi deps =
+  do mapM_ (`loadDepModule` Nothing) (reverse deps)
+     loadDepModule hmi Nothing
+     foldrM go M.empty names
+  where
+    go n map = do
+      doc <- getDocumentationTryGhc mod sources n
+      pure $ M.insert n doc map
+    names = rights $ S.toList idents
+    idents = M.keysSet rm
+    mod = mi_module hmi
 
 getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
 getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]

src/Development/IDE/Spans/Type.hs

@@ -1,77 +0,0 @@
--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
-
--- | Types used separate to GHCi vanilla.
-
-module Development.IDE.Spans.Type(
-    SpansInfo(..)
-  , SpanInfo(..)
-  , SpanSource(..)
-  , getNameM
-  ) where
-
-import GHC
-import Control.DeepSeq
-import OccName
-import Development.IDE.GHC.Util
-import Development.IDE.Spans.Common
-
-data SpansInfo =
-  SpansInfo { spansExprs       :: [SpanInfo]
-            , spansConstraints :: [SpanInfo] }
-  deriving Show
-
-instance NFData SpansInfo where
-  rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c
-
--- | Type of some span of source code. Most of these fields are
--- unboxed but Haddock doesn't show that.
-data SpanInfo =
-  SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int
-            -- ^ Start line of the span, zero-based.
-           ,spaninfoStartCol :: {-# UNPACK #-} !Int
-            -- ^ Start column of the span, zero-based.
-           ,spaninfoEndLine :: {-# UNPACK #-} !Int
-            -- ^ End line of the span (absolute), zero-based.
-           ,spaninfoEndCol :: {-# UNPACK #-} !Int
-            -- ^ End column of the span (absolute), zero-based.
-           ,spaninfoType :: !(Maybe Type)
-            -- ^ A pretty-printed representation for the type.
-           ,spaninfoSource :: !SpanSource
-           -- ^ The actutal 'Name' associated with the span, if
-            -- any. This can be useful for accessing a variety of
-            -- information about the identifier such as module,
-            -- locality, definition location, etc.
-           ,spaninfoDocs :: !SpanDoc
-           -- ^ Documentation for the element
-           }
-instance Show SpanInfo where
-  show (SpanInfo sl sc el ec t n docs) =
-    unwords ["(SpanInfo", show sl, show sc, show el, show ec
-            , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"
-            , "docs(" <> show docs <> ")"]
-
-instance NFData SpanInfo where
-    rnf = rwhnf
-
-
--- we don't always get a name out so sometimes manually annotating source is more appropriate
-data SpanSource = Named Name
-                | SpanS SrcSpan
-                | Lit String
-                | NoSource
-  deriving (Eq)
-
-instance Show SpanSource where
-  show = \case
-    Named n -> "Named " ++ occNameString (occName n)
-    SpanS sp -> "Span " ++ show sp
-    Lit lit -> "Lit " ++ lit
-    NoSource -> "NoSource"
-
-getNameM :: SpanSource -> Maybe Name
-getNameM = \case
-  Named name -> Just name
-  _ -> Nothing

test/exe/Main.hs

@@ -113,7 +113,7 @@ initializeResponseTests = withResource acquire release tests where
     -- for now
     , chk "NO goto implementation"  _implementationProvider (Just $ GotoOptionsStatic True)
     , chk "NO find references"          _referencesProvider  Nothing
-    , chk "NO doc highlight"     _documentHighlightProvider  Nothing
+    , chk "   doc highlight"     _documentHighlightProvider  (Just True)
     , chk "   doc symbol"           _documentSymbolProvider  (Just True)
     , chk "NO workspace symbol"    _workspaceSymbolProvider  Nothing
     , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True
@@ -194,8 +194,7 @@ diagnosticTests = testGroup "diagnostics"
             , "foo :: Int -> Int -> Int"
             , "foo a b = a + ab"
             , "bar :: Int -> Int -> Int"
-            , "bar a b = cd + b"
+            , "bar a b = cd + b" ]
-            ]
       _ <- createDoc "Testing.hs" "haskell" content
       expectDiagnostics
         [ ( "Testing.hs"