From 0532fd040346e9d05867c542b3c5c2e6d0cca8bd Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 4 May 2020 20:19:46 +0100 Subject: [PATCH] Reimplement Hover/GotoDefn in terms of HIE Files. Implement Document Hightlight LSP request Add GetDocMap, GetHieFile rules. --- ghcide.cabal | 2 - src/Development/IDE/Core/Compile.hs | 18 +- src/Development/IDE/Core/FileStore.hs | 2 +- src/Development/IDE/Core/RuleTypes.hs | 40 ++- src/Development/IDE/Core/Rules.hs | 76 ++++-- src/Development/IDE/GHC/Compat.hs | 4 + src/Development/IDE/GHC/Orphans.hs | 6 + src/Development/IDE/LSP/HoverDefinition.hs | 7 +- src/Development/IDE/LSP/LanguageServer.hs | 1 + src/Development/IDE/Spans/AtPoint.hs | 210 +++++++--------- src/Development/IDE/Spans/Calculate.hs | 268 --------------------- src/Development/IDE/Spans/Common.hs | 18 +- src/Development/IDE/Spans/Documentation.hs | 23 ++ src/Development/IDE/Spans/Type.hs | 77 ------ test/exe/Main.hs | 5 +- 15 files changed, 230 insertions(+), 527 deletions(-) delete mode 100644 src/Development/IDE/Spans/Calculate.hs delete mode 100644 src/Development/IDE/Spans/Type.hs diff --git a/ghcide.cabal b/ghcide.cabal index a6ca4656..725f231d 100644 --- a/ghcide.cabal +++ b/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 diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index f1a51e72..a32d767b 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/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` - [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DsError (noSpan "") + (([],) <$> action) `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs index dce3c8ce..74a8acca 100644 --- a/src/Development/IDE/Core/FileStore.hs +++ b/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 $ diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs index b822d03f..34eef4f1 100644 --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/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 NFData GetSpanInfo -instance Binary GetSpanInfo +instance Hashable GetHieFile +instance NFData GetHieFile +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) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 3ab94bb4..7d733e8d 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/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. -getSpanInfoRule :: Rules () -getSpanInfoRule = - define $ \GetSpanInfo file -> do - tc <- use_ TypeCheck file - packageState <- hscEnv <$> use_ GhcSessionDeps file +getHieFileRule :: Rules () +getHieFileRule = + define $ \GetHieFile f -> do + tcm <- use_ TypeCheck f + hf <- case tmrHieFile tcm of + 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 - let tdeps = transitiveModuleDeps deps - parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps + parsedDeps <- uses_ GetParsedModule tdeps #endif - (fileImports, _) <- use_ GetLocatedImports file - let imports = second (fmap artifactFilePath) <$> fileImports - x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps - return ([], Just x) + ifaces <- uses_ GetModIface tdeps + + docMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf hmi (map hirModIface ifaces) + 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 diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs index 8814252a..cc442944 100644 --- a/src/Development/IDE/GHC/Compat.hs +++ b/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)) diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs index 10813e80..4f88c25b 100644 --- a/src/Development/IDE/GHC/Orphans.hs +++ b/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 diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs index 5c4711bd..6aa73574 100644 --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/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 diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index ec124c22..4a638395 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/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 diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs index 6240f5b8..070a48d0 100644 --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/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 (showName, spanDocToMarkdown) +import Development.IDE.Spans.Common -- 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 = - MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans +gotoDefinition getHieFile ideOpts srcSpans pos + = 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 - 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) +atPoint IdeOptions{} hf dm pos = listToMaybe $ pointCommand hf pos hoverInfo 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 = - (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs - where - mbName = getNameM spaninfoSource - 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] + hoverInfo ast = + (Just range, prettyNames ++ pTypes) + where + pTypes + | length names == 1 = dropEnd 1 $ map wrapHaskell prettyTypes + | otherwise = map wrapHaskell prettyTypes - thisFVs = tyCoVarsOfType typ - constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts - constraintsT = T.intercalate ", " (map showName constraintsOverFVs) + range = realSrcSpanToRange $ nodeSpan ast - typeAnnotation = case constraintsOverFVs of - [] -> colon <> showName typ - [_] -> colon <> constraintsT <> "\n=> " <> showName typ - _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ + wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + info = nodeInfo ast + names = M.assocs $ nodeIdentifiers info + 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 - | T.length txt > 50 = T.take 46 txt <> " ..." - | 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 + prettyTypes = map (("_ :: "<>) . prettyType) types + prettyType t = showName $ hieTypeToIface $ recoverFullType t arr + 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] - -> MaybeT m [Location] -typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan - where getTypeSpan :: SpanInfo -> m (Maybe SrcSpan) - getTypeSpan SpanInfo { spaninfoType = Just t } = - case splitTyConApp_maybe t of - Nothing -> return Nothing - Just (getName -> name, _) -> - nameToLocation getHieFile name - getTypeSpan _ = return Nothing + -> HieFile + -> m [Location] +typeLocationsAtPoint getHieFile _ideOptions pos ast = + let ts = concat $ pointCommand ast pos (nodeType . nodeInfo) + arr = hie_types ast + its = map (arr A.!) ts + ns = flip mapMaybe its $ \case + HTyConApp tc _ -> Just $ ifaceTyConName tc + HTyVarTy n -> Just n + _ -> Nothing + in mapMaybeM (nameToLocation getHieFile) ns locationsAtPoint :: forall m @@ -154,33 +145,20 @@ locationsAtPoint => (Module -> MaybeT m (HieFile, FilePath)) -> IdeOptions -> Position - -> [SpanInfo] - -> MaybeT m [Location] -locationsAtPoint getHieFile = querySpanInfoAt (getSpan . spaninfoSource) - where getSpan :: SpanSource -> m (Maybe SrcSpan) - getSpan NoSource = pure Nothing - 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 + -> HieFile + -> m [Location] +locationsAtPoint getHieFile _ideOptions pos ast = + let ns = concat $ pointCommand ast pos (rights . M.keys . nodeIdentifiers . nodeInfo) + in mapMaybeM (nameToLocation getHieFile) ns -- | 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 getHieFile name = +nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location) +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 -spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo] -spansAtPoint pos = filter atp where - line = _line pos - cha = _character pos - atp SpanInfo{..} = - startsBeforePosition && endsAfterPosition - where - startLineCmp = compare spaninfoStartLine line - endLineCmp = compare spaninfoEndLine line - - 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) +pointCommand :: HieFile -> Position -> (HieAST TypeIndex -> a) -> [a] +pointCommand hf pos k = + catMaybes $ M.elems $ flip M.mapWithKey (getAsts $ hie_asts hf) $ \fs ast -> + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just $ k ast' + where + sloc fs = mkRealSrcLoc fs (line+1) (cha+1) + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + line = _line pos + cha = _character pos -getModuleNameAsText :: Name -> Maybe T.Text -getModuleNameAsText n = do - m <- nameModule_maybe n - return . T.pack . moduleNameString $ moduleName m diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs deleted file mode 100644 index 0797d413..00000000 --- a/src/Development/IDE/Spans/Calculate.hs +++ /dev/null @@ -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 diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs index 3ae06c7d..edc57fb8 100644 --- a/src/Development/IDE/Spans/Common.hs +++ b/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 diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs index 0d3fb5c0..af5f1b6e 100644 --- a/src/Development/IDE/Spans/Documentation.hs +++ b/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] diff --git a/src/Development/IDE/Spans/Type.hs b/src/Development/IDE/Spans/Type.hs deleted file mode 100644 index 635cd1fd..00000000 --- a/src/Development/IDE/Spans/Type.hs +++ /dev/null @@ -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 \ No newline at end of file diff --git a/test/exe/Main.hs b/test/exe/Main.hs index da5e7001..05e36cec 100644 --- a/test/exe/Main.hs +++ b/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"