Improve error message when importing an unusable package

If a module cannot be found because it is ignored or from an unusable
package, report this to the user and the reason it is unusable.

Currently, GHC displays the standard "Cannot find module error". For
example:

```
<no location info>: error:
    Could not find module ‘Control.Monad.Random’
    Perhaps you meant
      Control.Monad.Reader (from mtl-2.2.2)
      Control.Monad.Cont (from mtl-2.2.2)
      Control.Monad.Error (from mtl-2.2.2)
```

GHC does, however, indicate unusable/ignored packages with the -v flag:

```
package MonadRandom-0.5.1-1421RgpXdhC8e8UI7D3emA is unusable due to
missing dependencies:
  fail-4.9.0.0-BAHmj60kS5K7NVhhKpm9J5
```

With this change, I took that message and added it to the output of the
"Cannot find module" message.

Reviewers: bgamari, dfeuer

Reviewed By: bgamari

Subscribers: Phyx, dfeuer, rwbarton, thomie, carter

GHC Trac Issues: #4806

Differential Revision: https://phabricator.haskell.org/D4783

1 files changed, 76 insertions, 20 deletions

diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 008e9b5da0..d9c198a432 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -35,6 +35,8 @@ module Packages (
         LookupResult(..),
         ModuleSuggestion(..),
         ModuleOrigin(..),
+        UnusablePackageReason(..),
+        pprReason,
 
         -- * Inspecting the set of packages in scope
         getPackageIncludePath,
@@ -157,6 +159,8 @@ data ModuleOrigin =
     -- (But maybe the user didn't realize), so we'll still keep track
     -- of these modules.)
     ModHidden
+    -- | Module is unavailable because the package is unusable.
+  | ModUnusable UnusablePackageReason
     -- | Module is public, and could have come from some places.
   | ModOrigin {
         -- | @Just False@ means that this module is in
@@ -176,6 +180,7 @@ data ModuleOrigin =
 
 instance Outputable ModuleOrigin where
     ppr ModHidden = text "hidden module"
+    ppr (ModUnusable _) = text "unusable module"
     ppr (ModOrigin e res rhs f) = sep (punctuate comma (
         (case e of
             Nothing -> []
@@ -226,6 +231,7 @@ instance Monoid ModuleOrigin where
 -- ambiguity, or is it only relevant when we're making suggestions?)
 originVisible :: ModuleOrigin -> Bool
 originVisible ModHidden = False
+originVisible (ModUnusable _) = False
 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
 
 -- | Are there actually no providers for this module?  This will never occur
@@ -1136,7 +1142,8 @@ pprReason pref reason = case reason of
       pref <+> text "unusable due to cyclic dependencies:" $$
         nest 2 (hsep (map ppr deps))
   IgnoredDependencies deps ->
-      pref <+> text "unusable due to ignored dependencies:" $$
+      pref <+> text ("unusable because the -ignore-package flag was used to " ++
+                     "ignore at least one of its dependencies:") $$
         nest 2 (hsep (map ppr deps))
   ShadowedDependencies deps ->
       pref <+> text "unusable due to shadowed dependencies:" $$
@@ -1548,7 +1555,10 @@ mkPackageState dflags dbs preload0 = do
   dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
-  let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map
+  let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map
+      mod_map2 = mkUnusableModuleToPkgConfAll unusable
+      mod_map = Map.union mod_map1 mod_map2
+
   when (dopt Opt_D_dump_mod_map dflags) $
       printInfoForUser (dflags { pprCols = 200 })
                        alwaysQualify (pprModuleMap mod_map)
@@ -1617,9 +1627,6 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
                   ]
 
   emptyMap = Map.empty
-  sing pk m _ = Map.singleton (mkModule pk m)
-  addListTo = foldl' merge
-  merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
   setOrigins m os = fmap (const os) m
   extend_modmap modmap uid
     UnitVisibility { uv_expose_all = b, uv_renamings = rns }
@@ -1647,19 +1654,19 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
     es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
     es e = do
      (m, exposedReexport) <- exposed_mods
-     let (pk', m', pkg', origin') =
+     let (pk', m', origin') =
           case exposedReexport of
-           Nothing -> (pk, m, pkg, fromExposedModules e)
+           Nothing -> (pk, m, fromExposedModules e)
            Just (Module pk' m') ->
             let pkg' = pkg_lookup pk'
-            in (pk', m', pkg', fromReexportedModules e pkg')
-     return (m, sing pk' m' pkg' origin')
+            in (pk', m', fromReexportedModules e pkg')
+     return (m, mkModMap pk' m' origin')
 
     esmap :: UniqFM (Map Module ModuleOrigin)
     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
                                  -- be overwritten
 
-    hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
+    hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
 
     pk = packageConfigId pkg
     pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid
@@ -1668,6 +1675,43 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
     exposed_mods = exposedModules pkg
     hidden_mods = hiddenModules pkg
 
+-- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages.
+mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll
+mkUnusableModuleToPkgConfAll unusables =
+    Map.foldl' extend_modmap Map.empty unusables
+ where
+    extend_modmap modmap (pkg, reason) = addListTo modmap bindings
+      where bindings :: [(ModuleName, Map Module ModuleOrigin)]
+            bindings = exposed ++ hidden
+
+            origin = ModUnusable reason
+            pkg_id = packageConfigId pkg
+
+            exposed = map get_exposed exposed_mods
+            hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]
+
+            get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin)
+            get_exposed (mod, _)         = (mod, mkModMap pkg_id mod origin)
+
+            exposed_mods = exposedModules pkg
+            hidden_mods = hiddenModules pkg
+
+-- | Add a list of key/value pairs to a nested map.
+--
+-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
+-- when reloading modules in GHCi (see Trac #4029). This ensures that each
+-- value is forced before installing into the map.
+addListTo :: (Monoid a, Ord k1, Ord k2)
+          => Map k1 (Map k2 a)
+          -> [(k1, Map k2 a)]
+          -> Map k1 (Map k2 a)
+addListTo = foldl' merge
+  where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
+
+-- | Create a singleton module mapping
+mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
+mkModMap pkg mod = Map.singleton (mkModule pkg mod)
+
 -- -----------------------------------------------------------------------------
 -- Extracting information from the packages in scope
 
@@ -1815,6 +1859,9 @@ data LookupResult =
     -- an exact name match.  First is due to package hidden, second
     -- is due to module being hidden
   | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
+    -- | No modules found, but there were some unusable ones with
+    -- an exact name match
+  | LookupUnusable [(Module, ModuleOrigin)]
     -- | Nothing found, here are some suggested different names
   | LookupNotFound [ModuleSuggestion] -- suggestions
 
@@ -1846,20 +1893,28 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn
   = case Map.lookup m mod_map of
         Nothing -> LookupNotFound suggestions
         Just xs ->
-          case foldl' classify ([],[],[]) (Map.toList xs) of
-            ([], [], []) -> LookupNotFound suggestions
-            (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)
-            (_, _, exposed@(_:_))        -> LookupMultiple exposed
-            (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
+          case foldl' classify ([],[],[], []) (Map.toList xs) of
+            ([], [], [], []) -> LookupNotFound suggestions
+            (_, _, _, [(m, _)])             -> LookupFound m (mod_pkg m)
+            (_, _, _, exposed@(_:_))        -> LookupMultiple exposed
+            ([], [], unusable@(_:_), [])    -> LookupUnusable unusable
+            (hidden_pkg, hidden_mod, _, []) ->
+              LookupHidden hidden_pkg hidden_mod
   where
-    classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
+    classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) =
       let origin = filterOrigin mb_pn (mod_pkg m) origin0
           x = (m, origin)
       in case origin of
-          ModHidden                  -> (hidden_pkg,   x:hidden_mod, exposed)
-          _ | originEmpty origin     -> (hidden_pkg,   hidden_mod,   exposed)
-            | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)
-            | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)
+          ModHidden
+            -> (hidden_pkg, x:hidden_mod, unusable, exposed)
+          ModUnusable _
+            -> (hidden_pkg, hidden_mod, x:unusable, exposed)
+          _ | originEmpty origin
+            -> (hidden_pkg,   hidden_mod, unusable, exposed)
+            | originVisible origin
+            -> (hidden_pkg, hidden_mod, unusable, x:exposed)
+            | otherwise
+            -> (x:hidden_pkg, hidden_mod, unusable, exposed)
 
     pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
     mod_pkg = pkg_lookup . moduleUnitId
@@ -1875,6 +1930,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn
     filterOrigin (Just pn) pkg o =
       case o of
           ModHidden -> if go pkg then ModHidden else mempty
+          (ModUnusable _) -> if go pkg then o else mempty
           ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
                       fromHiddenReexport = rhs }
             -> ModOrigin {