Filter instance visibility based on set of visible orphans, fixes #2182.ghc-instvis

Summary:
Amazingly, the fix for this very old bug is quite simple: when type-checking,
maintain a set of "visible orphan modules" based on the orphans list of
modules which we explicitly imported.  When we import an instance and it
is an orphan, we check if it is in the visible modules set, and if not,
ignore it.  A little bit of refactoring for when orphan-hood is calculated
happens so that we always know if an instance is an orphan or not.

For GHCi, we preinitialize the visible modules set based on the list of
interactive imports which are active.

Future work: Cache the visible orphan modules set for GHCi, rather than
recomputing it every type-checking round.  (But it's tricky what to do when you
/remove/ a module: you need a data structure a little more complicated than
just a set of modules.)

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: new tests and validate

Reviewers: simonpj, austin

Subscribers: thomie, carter

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

GHC Trac Issues: #2182

3 files changed, 24 insertions, 43 deletions

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 3d602dd5a7..98bfae9f81 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -56,6 +56,7 @@ import HsBinds
 import TyCon (Role (..))
 import StaticFlags (opt_PprStyle_Debug)
 import Util( filterOut )
+import InstEnv
 
 import Control.Monad
 import System.IO.Unsafe
@@ -213,7 +214,7 @@ data IfaceClsInst
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
                    ifDFun     :: IfExtName,                -- The dfun
                    ifOFlag    :: OverlapFlag,              -- Overlap flag
-                   ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
+                   ifInstOrph :: IsOrphan }                -- See Note [Orphans]
         -- There's always a separate IfaceDecl for the DFun, which gives
         -- its IdInfo with its full type and version number.
         -- The instance declarations taken together have a version number,
@@ -227,7 +228,7 @@ data IfaceFamInst
   = IfaceFamInst { ifFamInstFam      :: IfExtName            -- Family name
                  , ifFamInstTys      :: [Maybe IfaceTyCon]   -- See above
                  , ifFamInstAxiom    :: IfExtName            -- The axiom
-                 , ifFamInstOrph     :: Maybe OccName        -- Just like IfaceClsInst
+                 , ifFamInstOrph     :: IsOrphan       -- Just like IfaceClsInst
                  }
 
 data IfaceRule
@@ -239,7 +240,7 @@ data IfaceRule
         ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
         ifRuleRhs    :: IfaceExpr,
         ifRuleAuto   :: Bool,
-        ifRuleOrph   :: Maybe OccName   -- Just like IfaceClsInst
+        ifRuleOrph   :: IsOrphan   -- Just like IfaceClsInst
     }
 
 data IfaceAnnotation
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 85bd396cd8..8b5dac58e7 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -339,10 +339,10 @@ mkIface_ hsc_env maybe_old_fingerprint
         unqual = mkPrintUnqualified dflags rdr_env
         inst_warns = listToBag [ instOrphWarn dflags unqual d
                                | (d,i) <- insts `zip` iface_insts
-                               , isNothing (ifInstOrph i) ]
+                               , isOrphan (ifInstOrph i) ]
         rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
                                | r <- iface_rules
-                               , isNothing (ifRuleOrph r)
+                               , isOrphan (ifRuleOrph r)
                                , if ifRuleAuto r then warn_auto_orphs
                                                  else warn_orphs ]
 
@@ -934,17 +934,16 @@ ruleOrphWarn dflags unqual mod rule
 --      (a) an OccEnv for ones that are not orphans,
 --          mapping the local OccName to a list of its decls
 --      (b) a list of orphan decls
-mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
-                                        -- Nothing for an orphan decl
-          -> [decl]                     -- Sorted into canonical order
-          -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
-                                        --      each sublist in canonical order
-              [decl])                   -- Orphan decls; in canonical order
+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
+          -> [decl]             -- Sorted into canonical order
+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;
+                                --      each sublist in canonical order
+              [decl])           -- Orphan decls; in canonical order
 mkOrphMap get_key decls
   = foldl go (emptyOccEnv, []) decls
   where
     go (non_orphs, orphs) d
-        | Just occ <- get_key d
+        | NotOrphan occ <- get_key d
         = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
         | otherwise = (non_orphs, d:orphs)
 \end{code}
@@ -1797,7 +1796,8 @@ getFS x = occNameFS (getOccName x)
 instanceToIfaceInst :: ClsInst -> IfaceClsInst
 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
                              , is_cls_nm = cls_name, is_cls = cls
-                             , is_tys = tys, is_tcs = mb_tcs })
+                             , is_tcs = mb_tcs
+                             , is_orphan = orph })
   = ASSERT( cls_name == className cls )
     IfaceClsInst { ifDFun    = dfun_name,
                 ifOFlag   = oflag,
@@ -1809,29 +1809,7 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
     do_rough (Just n) = Just (toIfaceTyCon_name n)
 
     dfun_name = idName dfun_id
-    mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
-    is_local name = nameIsLocalOrFrom mod name
 
-        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
-    (tvs, fds) = classTvsFds cls
-    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
-
-    -- See Note [When exactly is an instance decl an orphan?] in IfaceSyn
-    orph | is_local cls_name = Just (nameOccName cls_name)
-         | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
-         | otherwise         = Nothing
-
-    mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
-                                -- that is not in the "determined" arguments
-    mb_ns | null fds   = [choose_one arg_names]
-          | otherwise  = map do_one fds
-    do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
-                                          , not (tv `elem` rtvs)]
-
-    choose_one :: [NameSet] -> Maybe OccName
-    choose_one nss = case nameSetElems (unionNameSets nss) of
-                        []      -> Nothing
-                        (n : _) -> Just (nameOccName n)
 
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
@@ -1854,14 +1832,14 @@ famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
     lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
 
     orph | is_local fam_decl
-         = Just (nameOccName fam_decl)
+         = NotOrphan (nameOccName fam_decl)
 
          | not (isEmptyNameSet lhs_names)
-         = Just (nameOccName (head (nameSetElems lhs_names)))
+         = NotOrphan (nameOccName (head (nameSetElems lhs_names)))
 
 
          | otherwise
-         = Nothing
+         = IsOrphan
 
 --------------------------
 toIfaceLetBndr :: Id -> IfaceLetBndr
@@ -1976,14 +1954,15 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
     lhs_names = nameSetElems (ruleLhsOrphNames rule)
 
     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
-                        (n : _) -> Just (nameOccName n)
-                        []      -> Nothing
+                        (n : _) -> NotOrphan (nameOccName n)
+                        []      -> IsOrphan
 
 bogusIfaceRule :: Name -> IfaceRule
 bogusIfaceRule id_name
   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
-        ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
+        ifRuleAuto = True }
 
 ---------------------
 toIfaceExpr :: CoreExpr -> IfaceExpr
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index adc6725284..10984ece24 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -735,11 +735,12 @@ look at it.
 \begin{code}
 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
 tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
-                          , ifInstCls = cls, ifInstTys = mb_tcs })
+                          , ifInstCls = cls, ifInstTys = mb_tcs
+                          , ifInstOrph = orph })
   = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
                  tcIfaceExtId dfun_occ
        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
-       ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
+       ; return (mkImportedInstance cls mb_tcs' dfun oflag orph) }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs