Merge branch 'master' into eval-ghc901

Author: berberman

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

@@ -30,8 +30,10 @@ import           Development.IDE.GHC.Compat           hiding (TargetFile,
                                                        writeHieFile)
 import           Development.IDE.Graph
 import qualified Development.IDE.Spans.AtPoint        as AtPoint
+import           Development.IDE.Types.HscEnvEq       (hscEnv)
 import           Development.IDE.Types.Location
 import qualified HieDb
+import           HscTypes                             (hsc_dflags)
 import           Language.LSP.Types                   (DocumentHighlight (..),
                                                        SymbolInformation (..))
 
@@ -62,10 +64,11 @@ getAtPoint file pos = runMaybeT $ do
   opts <- liftIO $ getIdeOptionsIO ide
 
   (hf, mapping) <- useE GetHieAst file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file)
+  df <- hsc_dflags . hscEnv . fst <$> useE GhcSession file
+  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-  MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos'
+  MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df pos'
 
 toCurrentLocations :: PositionMapping -> [Location] -> [Location]
 toCurrentLocations mapping = mapMaybe go

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

@@ -151,6 +151,7 @@ import           Ide.Plugin.Properties                        (HasProperty,
 import           Ide.PluginUtils                              (configForPlugin)
 import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
                                                                PluginId)
+import qualified Data.HashSet as HS
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -311,6 +312,7 @@ getLocatedImportsRule =
     define $ \GetLocatedImports file -> do
         ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file
         targets <- useNoFile_ GetKnownTargets
+        let targetsMap = HM.mapWithKey const targets
         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
         env_eq <- use_ GhcSession file
         let env = hscEnvWithImportPaths env_eq
@@ -321,14 +323,24 @@ getLocatedImportsRule =
                     then addRelativeImport file (moduleName $ ms_mod ms) dflags
                     else dflags
         opt <- getIdeOptions
-        let getTargetExists modName nfp
-                | isImplicitCradle = getFileExists nfp
-                | HM.member (TargetModule modName) targets
-                || HM.member (TargetFile nfp) targets
-                = getFileExists nfp
-                | otherwise = return False
+        let getTargetFor modName nfp
+                | isImplicitCradle = do
+                    itExists <- getFileExists nfp
+                    return $ if itExists then Just nfp else Nothing
+                | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do
+                    -- reuse the existing NormalizedFilePath in order to maximize sharing
+                    itExists <- getFileExists nfp'
+                    return $ if itExists then Just nfp' else Nothing
+                | Just tt <- HM.lookup (TargetModule modName) targets = do
+                    -- reuse the existing NormalizedFilePath in order to maximize sharing
+                    let ttmap = HM.mapWithKey const (HS.toMap tt)
+                        nfp' = HM.lookupDefault nfp nfp ttmap
+                    itExists <- getFileExists nfp'
+                    return $ if itExists then Just nfp' else Nothing
+                | otherwise
+                = return Nothing
         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
-            diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource
+            diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource
             case diagOrImp of
                 Left diags              -> pure (diags, Just (modName, Nothing))
                 Right (FileImport path) -> pure ([], Just (modName, Just path))

ghcide/src/Development/IDE/Import/FindImports.hs

@@ -69,15 +69,15 @@ modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms
 locateModuleFile :: MonadIO m
              => [[FilePath]]
              -> [String]
-             -> (ModuleName -> NormalizedFilePath -> m Bool)
+             -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
              -> Bool
              -> ModuleName
              -> m (Maybe NormalizedFilePath)
-locateModuleFile import_dirss exts doesExist isSource modName = do
+locateModuleFile import_dirss exts targetFor isSource modName = do
   let candidates import_dirs =
         [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
            | prefix <- import_dirs , ext <- exts]
-  findM (doesExist modName) (concatMap candidates import_dirss)
+  firstJustM (targetFor modName) (concatMap candidates import_dirss)
   where
     maybeBoot ext
       | isSource = ext ++ "-boot"
@@ -97,12 +97,12 @@ locateModule
     => DynFlags
     -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories
     -> [String]                        -- ^ File extensions
-    -> (ModuleName -> NormalizedFilePath -> m Bool)  -- ^ does file exist predicate
+    -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate
     -> Located ModuleName              -- ^ Module name
     -> Maybe FastString                -- ^ Package name
     -> Bool                            -- ^ Is boot module
     -> m (Either [FileDiagnostic] Import)
-locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
+locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do
   case mbPkgName of
     -- "this" means that we should only look in the current package
     Just "this" -> do
@@ -118,7 +118,7 @@ locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
       -- Here the importPaths for the current modules are added to the front of the import paths from the other components.
       -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in
       -- each component will end up being found in the wrong place and cause a multi-cradle match failure.
-      mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName
+      mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName
       case mbFile of
         Nothing   -> lookupInPackageDB dflags
         Just file -> toModLocation file
@@ -129,7 +129,7 @@ locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
         return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)
 
     lookupLocal dirs = do
-      mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName
+      mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName
       case mbFile of
         Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
         Just file -> toModLocation file

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -56,6 +56,7 @@ import           Data.Either
 import           Data.List                            (isSuffixOf)
 import           Data.List.Extra                      (dropEnd1, nubOrd)
 
+import           Data.Version                         (showVersion)
 import           HieDb                                hiding (pointCommand)
 import           System.Directory                     (doesFileExist)
 
@@ -196,9 +197,10 @@ atPoint
   :: IdeOptions
   -> HieAstResult
   -> DocAndKindMap
+  -> DynFlags
   -> Position
   -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo
+atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo
   where
     -- Hover info for values/data
     hoverInfo ast = (Just range, prettyNames ++ pTypes)
@@ -219,11 +221,20 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ point
         prettyName (Right n, dets) = T.unlines $
           wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))
           : definedAt n
+          ++ maybeToList (prettyPackageName n)
           ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
                        ]
           where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n
         prettyName (Left m,_) = showGhc m
 
+        prettyPackageName n = do
+          m <- nameModule_maybe n
+          let pid = moduleUnitId m
+          conf <- lookupPackage df pid
+          let pkgName = T.pack $ packageNameString conf
+              version = T.pack $ showVersion (packageVersion conf)
+          pure $ " *(" <> pkgName <> "-" <> version <> ")*"
+
         prettyTypes = map (("_ :: "<>) . prettyType) types
         prettyType t = case kind of
           HieFresh -> showGhc t

ghcide/test/exe/Main.hs

@@ -3591,17 +3591,17 @@ findDefinitionAndHoverTests = let
   aaaL14 = Position 18 20  ;  aaa    = [mkR  11  0   11  3]
   dcL7   = Position 11 11  ;  tcDC   = [mkR   7 23    9 16]
   dcL12  = Position 16 11  ;
-  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types"]]
+  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]
   tcL6   = Position 10 11  ;  tcData = [mkR   7  0    9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
   vvL16  = Position 20 12  ;  vv     = [mkR  20  4   20  6]
   opL16  = Position 20 15  ;  op     = [mkR  21  2   21  4]
   opL18  = Position 22 22  ;  opp    = [mkR  22 13   22 17]
   aL18   = Position 22 20  ;  apmp   = [mkR  22 10   22 11]
   b'L19  = Position 23 13  ;  bp     = [mkR  23  6   23  7]
-  xvL20  = Position 24  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]]
+  xvL20  = Position 24  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]]
   clL23  = Position 27 11  ;  cls    = [mkR  25  0   26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
   clL25  = Position 29  9
-  eclL15 = Position 19  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num"]]
+  eclL15 = Position 19  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]]
   dnbL29 = Position 33 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  33 12   33 21]
   dnbL30 = Position 34 23
   lcbL33 = Position 37 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  37 26   37 27]