diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 965ebf21f0..41b068cc0c 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -65,7 +65,7 @@ getAtPoint file pos = runMaybeT $ do dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' + MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' -- | For each Loacation, determine if we have the PositionMapping -- for the correct file. If not, get the correct position mapping diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 4bf7454ab5..5b1b5e0c58 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -50,50 +50,54 @@ module Development.IDE.GHC.Compat.Units ( filterInplaceUnits, FinderCache, showSDocForUser', + findImportedModule, ) where import Control.Monad -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map #if MIN_VERSION_ghc(9,3,0) import GHC.Unit.Home.ModInfo #endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Data.ShortText as ST +import qualified GHC.Data.ShortText as ST #if !MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (hsc_unit_dbs) +import GHC.Driver.Env (hsc_unit_dbs) #endif import GHC.Driver.Ppr import GHC.Unit.Env import GHC.Unit.External -import GHC.Unit.Finder +import GHC.Unit.Finder hiding + (findImportedModule) #else import GHC.Driver.Types #endif import GHC.Data.FastString -import qualified GHC.Driver.Session as DynFlags +import qualified GHC.Driver.Session as DynFlags import GHC.Types.Unique.Set -import qualified GHC.Unit.Info as UnitInfo -import GHC.Unit.State (LookupResult, UnitInfo, - UnitState (unitInfoMap)) -import qualified GHC.Unit.State as State -import GHC.Unit.Types hiding (moduleUnit, toUnitId) -import qualified GHC.Unit.Types as Unit +import qualified GHC.Unit.Info as UnitInfo +import GHC.Unit.State (LookupResult, UnitInfo, + UnitState (unitInfoMap)) +import qualified GHC.Unit.State as State +import GHC.Unit.Types hiding (moduleUnit, + toUnitId) +import qualified GHC.Unit.Types as Unit import GHC.Utils.Outputable #else import qualified DynFlags import FastString -import GhcPlugins (SDoc, showSDocForUser) +import GhcPlugins (SDoc, showSDocForUser) import HscTypes -import Module hiding (moduleUnitId) +import Module hiding (moduleUnitId) import qualified Module -import Packages (InstalledPackageInfo (haddockInterfaces, packageName), - LookupResult, PackageConfig, - PackageConfigMap, - PackageState, - getPackageConfigMap, - lookupPackage') +import Packages (InstalledPackageInfo (haddockInterfaces, packageName), + LookupResult, + PackageConfig, + PackageConfigMap, + PackageState, + getPackageConfigMap, + lookupPackage') import qualified Packages #endif @@ -101,12 +105,23 @@ import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Outputable #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) -import Data.Map (Map) +import Data.Map (Map) #endif import Data.Either import Data.Version import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) +#endif +#if MIN_VERSION_ghc(9,1,0) +import qualified GHC.Unit.Finder as GHC +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Finder as GHC +#else +import qualified Finder as GHC +#endif + #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId #if MIN_VERSION_ghc(9,2,0) @@ -407,3 +422,14 @@ showSDocForUser' env = showSDocForUser (hsc_dflags env) (unitState env) #else showSDocForUser' env = showSDocForUser (hsc_dflags env) #endif + +findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module) +findImportedModule env mn = do +#if MIN_VERSION_ghc(9,3,0) + res <- GHC.findImportedModule env mn NoPkgQual +#else + res <- GHC.findImportedModule env mn Nothing +#endif + case res of + Found _ mod -> pure . pure $ mod + _ -> pure Nothing diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 37b0fbcc17..54b1015cfd 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -1,9 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly. @@ -213,21 +214,33 @@ atPoint -> DocAndKindMap -> HscEnv -> Position - -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo + -> IO (Maybe (Maybe Range, [T.Text])) +atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos = + listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data - hoverInfo ast = (Just range, prettyNames ++ pTypes) + hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text]) + hoverInfo ast = do + prettyNames <- mapM prettyName filteredNames + pure (Just range, prettyNames ++ pTypes) where + pTypes :: [T.Text] pTypes | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes | otherwise = map wrapHaskell prettyTypes + range :: Range range = realSrcSpanToRange $ nodeSpan ast + wrapHaskell :: T.Text -> T.Text wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + + info :: NodeInfo hietype info = nodeInfoH kind ast + + names :: [(Identifier, IdentifierDetails hietype)] names = M.assocs $ nodeIdentifiers info + -- Check for evidence bindings isInternal :: (Identifier, IdentifierDetails a) -> Bool isInternal (Right _, dets) = @@ -237,11 +250,12 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p False #endif isInternal (Left _, _) = False + + filteredNames :: [(Identifier, IdentifierDetails hietype)] filteredNames = filter (not . isInternal) names - types = nodeType info - prettyNames :: [T.Text] - prettyNames = map prettyName filteredNames - prettyName (Right n, dets) = T.unlines $ + + prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text + prettyName (Right n, dets) = pure $ T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : maybeToList (pretty (definedAt n) (prettyPackageName n)) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n @@ -251,21 +265,48 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p pretty (Just define) Nothing = Just $ define <> "\n" pretty Nothing (Just pkgName) = Just $ pkgName <> "\n" pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n" - prettyName (Left m,_) = printOutputable m + prettyName (Left m,_) = packageNameForImportStatement m + prettyPackageName :: Name -> Maybe T.Text prettyPackageName n = do m <- nameModule_maybe n + pkgTxt <- packageNameWithVersion m env + pure $ "*(" <> pkgTxt <> ")*" + + -- Return the module text itself and + -- the package(with version) this `ModuleName` belongs to. + packageNameForImportStatement :: ModuleName -> IO T.Text + packageNameForImportStatement mod = do + mpkg <- findImportedModule env mod :: IO (Maybe Module) + let moduleName = printOutputable mod + case mpkg >>= flip packageNameWithVersion env of + Nothing -> pure moduleName + Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion + + -- Return the package name and version of a module. + -- For example, given module `Data.List`, it should return something like `base-4.x`. + packageNameWithVersion :: Module -> HscEnv -> Maybe T.Text + packageNameWithVersion m env = do let pid = moduleUnit m conf <- lookupUnit env pid let pkgName = T.pack $ unitPackageNameString conf version = T.pack $ showVersion (unitPackageVersion conf) - pure $ "*(" <> pkgName <> "-" <> version <> ")*" + pure $ pkgName <> "-" <> version + + -- Type info for the current node, it may contains several symbols + -- for one range, like wildcard + types :: [hietype] + types = nodeType info + prettyTypes :: [T.Text] prettyTypes = map (("_ :: "<>) . prettyType) types + + prettyType :: hietype -> T.Text prettyType t = case kind of HieFresh -> printOutputable t HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + definedAt :: Name -> Maybe T.Text definedAt name = -- do not show "at " and similar messages -- see the code of 'pprNameDefnLoc' for more information diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index ceba6e3971..b0fe95891b 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -173,6 +173,7 @@ tests = let reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] + import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]] in mkFindTests -- def hover look expect @@ -236,6 +237,7 @@ tests = let test no broken thLocL57 thLoc "TH Splice Hover" | otherwise -> test no yes thLocL57 thLoc "TH Splice Hover" + , test yes yes import310 pkgTxt "show package name and its version" ] where yes, broken :: (TestTree -> Maybe TestTree) yes = Just -- test should run and pass diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9292e3ccc9..18296dce16 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -124,4 +124,4 @@ main = do , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests recorder logger - ] \ No newline at end of file + ]