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

34 files changed, 429 insertions, 98 deletions

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 57f02d9b2a..120a11438b 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -72,7 +72,7 @@ module Module
         ModuleNameEnv,
 
         -- * Sets of Modules
-        ModuleSet,
+        ModuleSet, VisibleOrphanModules,
         emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
     ) where
 
@@ -511,5 +511,10 @@ UniqFM.
 \begin{code}
 -- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
 type ModuleNameEnv elt = UniqFM elt
+
+-- | Set of visible orphan modules, according to what modules have been directly
+-- imported.  This is based off of the dep_orphs field, which records
+-- transitively reachable orphan modules (modules that define orphan instances).
+type VisibleOrphanModules = ModuleSet
 \end{code}
 
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
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index bb3fd380bc..cf3db52c94 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1971,9 +1971,13 @@ data Dependencies
                         -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively]
 
          , dep_orphs  :: [Module]
-                        -- ^ Orphan modules (whether home or external pkg),
-                        -- *not* including family instance orphans as they
-                        -- are anyway included in 'dep_finsts'
+                        -- ^ Transitive closure of orphan modules (whether
+                        -- home or external pkg).
+                        --
+                        -- (Possible optimization: don't include family
+                        -- instance orphans as they are anyway included in
+                        -- 'dep_finsts'.  But then be careful about code
+                        -- which relies on dep_orphs having the complete list!)
 
          , dep_finsts :: [Module]
                         -- ^ Modules that contain family instances (whether the
diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs
index 6fb9b3f798..e636d5b533 100644
--- a/compiler/typecheck/FunDeps.lhs
+++ b/compiler/typecheck/FunDeps.lhs
@@ -203,7 +203,7 @@ pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })
   = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs),
           nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])]
 
-improveFromInstEnv :: (InstEnv,InstEnv)
+improveFromInstEnv :: InstEnvs
                    -> PredType
                    -> [Equation SrcSpan] -- Needs to be an Equation because
                                          -- of quantified variables
@@ -522,7 +522,7 @@ if s1 matches
 
 
 \begin{code}
-checkFunDeps :: (InstEnv, InstEnv) -> ClsInst
+checkFunDeps :: InstEnvs -> ClsInst
              -> Maybe [ClsInst] -- Nothing  <=> ok
                                 -- Just dfs <=> conflict with dfs
 -- Check whether adding DFunId would break functional-dependency constraints
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index de7668db48..f3d3dff2c2 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -398,11 +398,14 @@ getOverlapFlag overlap_mode
               final_oflag = setOverlapModeMaybe default_oflag overlap_mode
         ; return final_oflag }
 
-tcGetInstEnvs :: TcM (InstEnv, InstEnv)
+tcGetInstEnvs :: TcM InstEnvs
 -- Gets both the external-package inst-env
 -- and the home-pkg inst env (includes module being compiled)
-tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
-                     return (eps_inst_env eps, tcg_inst_env env) }
+tcGetInstEnvs = do { eps <- getEps
+                   ; env <- getGblEnv
+                   ; return (InstEnvs (eps_inst_env eps)
+                                      (tcg_inst_env env)
+                                      (tcg_visible_orphan_mods env))}
 
 tcGetInsts :: TcM [ClsInst]
 -- Gets the local class instances.
@@ -482,7 +485,9 @@ addLocalInst (home_ie, my_insts) ispec
                global_ie
                     | isJust (tcg_sig_of tcg_env) = emptyInstEnv
                     | otherwise = eps_inst_env eps
-               inst_envs       = (global_ie, home_ie')
+               inst_envs       = InstEnvs global_ie
+                                          home_ie'
+                                          (tcg_visible_orphan_mods tcg_env)
                (matches, _, _) = lookupInstEnv inst_envs cls tys
                dups            = filter (identicalInstHead ispec) (map fst matches)
 
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index cb83d1b2d9..765ac4d071 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -226,9 +226,11 @@ tcLookupInstance cls tys
         extractTyVar _            = panic "TcEnv.tcLookupInstance: extractTyVar"
 
     -- NB: duplicated to prevent circular dependence on Inst
-    tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
-                       ; return (eps_inst_env eps, tcg_inst_env env) 
-                       }
+    tcGetInstEnvs = do { eps <- getEps
+                       ; env <- getGblEnv
+                       ; return (InstEnvs (eps_inst_env eps)
+                                          (tcg_inst_env env)
+                                          (tcg_visible_orphan_mods env)) }
 \end{code}
 
 \begin{code}
diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs
index a59206eb00..9ba89ccfc1 100644
--- a/compiler/typecheck/TcPluginM.hs
+++ b/compiler/typecheck/TcPluginM.hs
@@ -101,7 +101,7 @@ getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv
 getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
 getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs
 
-getInstEnvs :: TcPluginM (InstEnv, InstEnv)
+getInstEnvs :: TcPluginM InstEnvs
 getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs
 
 getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 0ca12bfbfc..6d91d267b9 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -419,6 +419,9 @@ tcRnImports hsc_env import_decls
               tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
               tcg_rn_imports   = rn_imports,
+              tcg_visible_orphan_mods = foldl extendModuleSet
+                                              (tcg_visible_orphan_mods gbl)
+                                              (imp_orphs imports),
               tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
                                                       home_fam_insts,
@@ -1404,6 +1407,14 @@ runTcInteractive hsc_env thing_inside
                       vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
                                                  , let local_gres = filter isLocalGRE gres
                                                  , not (null local_gres) ]) ]
+       ; let getOrphans m = fmap (concatMap (\iface -> mi_module iface
+                                                 : dep_orphs (mi_deps iface)))
+                                 (loadSrcInterface (text "runTcInteractive") m
+                                                   False Nothing)
+       ; ic_visible_mods <- fmap concat . forM (ic_imports icxt) $ \i ->
+            case i of
+                IIModule n -> getOrphans n
+                IIDecl i -> getOrphans (unLoc (ideclName i))
        ; gbl_env <- getGblEnv
        ; let gbl_env' = gbl_env {
                            tcg_rdr_env      = ic_rn_gbl_env icxt
@@ -1422,7 +1433,13 @@ runTcInteractive hsc_env thing_inside
                               -- setting tcg_field_env is necessary
                               -- to make RecordWildCards work (test: ghci049)
                          , tcg_fix_env      = ic_fix_env icxt
-                         , tcg_default      = ic_default icxt }
+                         , tcg_default      = ic_default icxt
+                         , tcg_visible_orphan_mods = mkModuleSet ic_visible_mods
+                              -- I guess there's a risk ic_imports will be
+                              -- desynchronized with the true RdrEnv; probably
+                              -- should insert some ASSERTs somehow.
+                              -- TODO: Cache this
+                         }
 
        ; setGblEnv gbl_env' $
          tcExtendGhciIdEnv ty_things $   -- See Note [Initialising the type environment for GHCi]
@@ -1957,7 +1974,7 @@ tcRnGetInfo hsc_env name
 
 lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
 lookupInsts (ATyCon tc)
-  = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
+  = do  { InstEnvs pkg_ie home_ie vis_mods <- tcGetInstEnvs
         ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
                 -- Load all instances for all classes that are
                 -- in the type environment (which are all the ones
@@ -1968,6 +1985,7 @@ lookupInsts (ATyCon tc)
         ; let cls_insts =
                  [ ispec        -- Search all
                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
+                 , instIsVisible vis_mods ispec
                  , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
         ; let fam_insts =
                  [ fispec
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index a4e1e11c13..15a6ba7262 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -132,6 +132,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_inst_env       = emptyInstEnv,
                 tcg_fam_inst_env   = emptyFamInstEnv,
                 tcg_ann_env        = emptyAnnEnv,
+                tcg_visible_orphan_mods = mkModuleSet [mod],
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
                 tcg_exports        = [],
@@ -1307,7 +1308,9 @@ mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
 initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
-        ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
+        ; let { if_env = IfGblEnv {
+                            if_rec_types = Just (tcg_mod tcg_env, get_type_env)
+                         }
               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
         ; setEnvs (if_env, ()) thing_inside }
 
@@ -1327,7 +1330,9 @@ initIfaceTc :: ModIface
 -- No type envt from the current module, but we do know the module dependencies
 initIfaceTc iface do_this
  = do   { tc_env_var <- newTcRef emptyTypeEnv
-        ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ;
+        ; let { gbl_env = IfGblEnv {
+                            if_rec_types = Just (mod, readTcRef tc_env_var)
+                          } ;
               ; if_lenv = mkIfLclEnv mod doc
            }
         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index cc9a7699e2..cf8b56cd04 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -269,6 +269,11 @@ data TcGblEnv
         tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances
         tcg_ann_env      :: AnnEnv,     -- ^ And for annotations
 
+        tcg_visible_orphan_mods :: ModuleSet,
+          -- ^ The set of orphan modules which transitively reachable from
+          -- direct imports.  We use this to figure out if an orphan instance
+          -- in the global InstEnv should be considered visible.
+
                 -- Now a bunch of things about this module that are simply
                 -- accumulated, but never consulted until the end.
                 -- Nevertheless, it's convenient to accumulate them along
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 9355e3b498..0699122f5c 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1350,7 +1350,7 @@ getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
 -- Just get some environments needed for instance looking up and matching
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-getInstEnvs :: TcS (InstEnv, InstEnv)
+getInstEnvs :: TcS InstEnvs
 getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
 
 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 411b006059..cf7110981e 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -17,15 +17,19 @@ module InstEnv (
         instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
         fuzzyClsInstCmp,
 
-        InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead, 
+        IsOrphan(..), isOrphan, notOrphan,
+
+        InstEnvs(..), InstEnv,
+        emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead,
         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
-        memberInstEnv,
+        memberInstEnv, instIsVisible,
         classInstances, orphNamesOfClsInst, instanceBindFun,
         instanceCantMatch, roughMatchTcs
     ) where
 
 #include "HsVersions.h"
 
+import Module
 import Class
 import Var
 import VarSet
@@ -40,6 +44,7 @@ import BasicTypes
 import UniqFM
 import Util
 import Id
+import Binary
 import FastString
 import Data.Data        ( Data, Typeable )
 import Data.Maybe       ( isJust, isNothing )
@@ -56,6 +61,35 @@ import Data.Monoid
 %************************************************************************
 
 \begin{code}
+
+-- | Is this instance an orphan?  If it is not an orphan, contains an 'OccName'
+-- witnessing the instance's non-orphanhood.
+data IsOrphan = IsOrphan | NotOrphan OccName
+    deriving (Data, Typeable)
+
+-- | Returns true if 'IsOrphan' is orphan.
+isOrphan :: IsOrphan -> Bool
+isOrphan IsOrphan = True
+isOrphan _ = False
+
+-- | Returns true if 'IsOrphan' is not an orphan.
+notOrphan :: IsOrphan -> Bool
+notOrphan NotOrphan{} = True
+notOrphan _ = False
+
+instance Binary IsOrphan where
+    put_ bh IsOrphan = putByte bh 0
+    put_ bh (NotOrphan n) = do
+        putByte bh 1
+        put_ bh n
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> return IsOrphan
+            _ -> do
+                n <- get bh
+                return $ NotOrphan n
+
 data ClsInst 
   = ClsInst {   -- Used for "rough matching"; see Note [Rough-match field]
                 -- INVARIANT: is_tcs = roughMatchTcs is_tys
@@ -78,6 +112,7 @@ data ClsInst
 
              , is_flag :: OverlapFlag   -- See detailed comments with
                                         -- the decl of BasicTypes.OverlapFlag
+             , is_orphan :: IsOrphan
     }
   deriving (Data, Typeable)
 
@@ -211,22 +246,59 @@ mkLocalInstance :: DFunId -> OverlapFlag
                 -> [TyVar] -> Class -> [Type]
                 -> ClsInst
 -- Used for local instances, where we can safely pull on the DFunId
-mkLocalInstance dfun oflag tvs cls tys
+-- TODO: what is the difference between source_tvs and tvs?
+mkLocalInstance dfun oflag source_tvs cls tys
   = ClsInst { is_flag = oflag, is_dfun = dfun
-            , is_tvs = tvs
-            , is_cls = cls, is_cls_nm = className cls
-            , is_tys = tys, is_tcs = roughMatchTcs tys }
-
-mkImportedInstance :: Name -> [Maybe Name]
-                   -> DFunId -> OverlapFlag -> ClsInst
+            , is_tvs = source_tvs
+            , is_cls = cls, is_cls_nm = cls_name
+            , is_tys = tys, is_tcs = roughMatchTcs tys
+            , is_orphan = orph
+            }
+  where
+    cls_name = className cls
+    dfun_name = idName dfun
+    this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
+    is_local name = nameIsLocalOrFrom this_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 = NotOrphan (nameOccName cls_name)
+         | all notOrphan mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
+         | otherwise         = IsOrphan
+
+    notOrphan NotOrphan{} = True
+    notOrphan _ = False
+
+    mb_ns :: [IsOrphan]    -- 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] -> IsOrphan
+    choose_one nss = case nameSetElems (unionNameSets nss) of
+                        []      -> IsOrphan
+                        (n : _) -> NotOrphan (nameOccName n)
+
+mkImportedInstance :: Name
+                   -> [Maybe Name]
+                   -> DFunId
+                   -> OverlapFlag
+                   -> IsOrphan
+                   -> ClsInst
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
 -- The bound tyvars of the dfun are guaranteed fresh, because
 -- the dfun has been typechecked out of the same interface file
-mkImportedInstance cls_nm mb_tcs dfun oflag
+mkImportedInstance cls_nm mb_tcs dfun oflag orphan
   = ClsInst { is_flag = oflag, is_dfun = dfun
             , is_tvs = tvs, is_tys = tys
-            , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs }
+            , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs
+            , is_orphan = orphan }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
@@ -390,6 +462,16 @@ or, to put it another way, we have
 ---------------------------------------------------
 type InstEnv = UniqFM ClsInstEnv        -- Maps Class to instances for that class
 
+-- | 'InstEnvs' represents the combination of the global type class instance
+-- environment, the local type class instance environment, and the set of
+-- transitively reachable orphan modules (according to what modules have been
+-- directly imported) used to test orphan instance visibility.
+data InstEnvs = InstEnvs {
+        ie_global  :: InstEnv,
+        ie_local   :: InstEnv,
+        ie_visible :: VisibleOrphanModules
+    }
+
 newtype ClsInstEnv 
   = ClsIE [ClsInst]    -- The instances for a particular class, in any order
 
@@ -411,9 +493,21 @@ emptyInstEnv = emptyUFM
 instEnvElts :: InstEnv -> [ClsInst]
 instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts]
 
-classInstances :: (InstEnv,InstEnv) -> Class -> [ClsInst]
-classInstances (pkg_ie, home_ie) cls 
-  = get home_ie ++ get pkg_ie
+-- | Test if an instance is visible, by checking that its origin module
+-- is in 'VisibleOrphanModules'.
+instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool
+instIsVisible vis_mods ispec
+  -- NB: Instances from the interactive package always are visible. We can't
+  -- add interactive modules to the set since we keep creating new ones
+  -- as a GHCi session progresses.
+  | isInteractiveModule mod = True
+  | IsOrphan <- is_orphan ispec = mod `elemModuleSet` vis_mods
+  | otherwise = True
+  where mod = nameModule (idName (is_dfun ispec))
+
+classInstances :: InstEnvs -> Class -> [ClsInst]
+classInstances (InstEnvs pkg_ie home_ie vis_mods) cls
+  = filter (instIsVisible vis_mods) (get home_ie ++ get pkg_ie)
   where
     get env = case lookupUFM env cls of
                 Just (ClsIE insts) -> insts
@@ -555,7 +649,7 @@ where the 'Nothing' indicates that 'b' can be freely instantiated.
 -- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,
 -- yield 'Left errorMessage'.
 --
-lookupUniqueInstEnv :: (InstEnv, InstEnv) 
+lookupUniqueInstEnv :: InstEnvs
                     -> Class -> [Type]
                     -> Either MsgDoc (ClsInst, [Type])
 lookupUniqueInstEnv instEnv cls tys
@@ -570,6 +664,7 @@ lookupUniqueInstEnv instEnv cls tys
       _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys)
 
 lookupInstEnv' :: InstEnv          -- InstEnv to look in
+               -> VisibleOrphanModules   -- But filter against this
                -> Class -> [Type]  -- What we are looking for
                -> ([InstMatch],    -- Successful matches
                    [ClsInst])     -- These don't match but do unify
@@ -583,7 +678,7 @@ lookupInstEnv' :: InstEnv          -- InstEnv to look in
 -- but Foo [Int] is a unifier.  This gives the caller a better chance of
 -- giving a suitable error message
 
-lookupInstEnv' ie cls tys
+lookupInstEnv' ie vis_mods cls tys
   = lookup ie
   where
     rough_tcs  = roughMatchTcs tys
@@ -597,6 +692,8 @@ lookupInstEnv' ie cls tys
     find ms us [] = (ms, us)
     find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs
                               , is_tys = tpl_tys, is_flag = oflag }) : rest)
+      | not (instIsVisible vis_mods item)
+      = find ms us rest
         -- Fast check for no match, uses the "rough match" fields
       | instanceCantMatch rough_tcs mb_tcs
       = find ms us rest
@@ -632,15 +729,15 @@ lookupInstEnv' ie cls tys
 
 ---------------
 -- This is the common way to call this function.
-lookupInstEnv :: (InstEnv, InstEnv)     -- External and home package inst-env
+lookupInstEnv :: InstEnvs     -- External and home package inst-env
               -> Class -> [Type]   -- What we are looking for
               -> ClsInstLookupResult
 -- ^ See Note [Rules for instance lookup]
-lookupInstEnv (pkg_ie, home_ie) cls tys
+lookupInstEnv (InstEnvs pkg_ie home_ie vis_mods) cls tys
   = (final_matches, final_unifs, safe_fail)
   where
-    (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys
-    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  cls tys
+    (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys
+    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys
     all_matches = home_matches ++ pkg_matches
     all_unifs   = home_unifs   ++ pkg_unifs
     pruned_matches = foldr insert_overlapping [] all_matches
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index 3358ceafab..098e9c8227 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -123,7 +123,7 @@ data GlobalEnv
         , global_pr_funs              :: NameEnv Var
           -- ^Mapping from TyCons to their PR dfuns.
 
-        , global_inst_env             :: (InstEnv, InstEnv)
+        , global_inst_env             :: InstEnvs
           -- ^External package inst-env & home-package inst-env for class instances.
 
         , global_fam_inst_env         :: FamInstEnvs
@@ -139,7 +139,12 @@ data GlobalEnv
 -- to the global table, so that we can query scalarness during vectorisation, and especially, when
 -- vectorising the scalar entities' definitions themselves.
 --
-initGlobalEnv :: Bool -> VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv :: Bool
+              -> VectInfo
+              -> [CoreVect]
+              -> InstEnvs
+              -> FamInstEnvs
+              -> GlobalEnv
 initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs
   = GlobalEnv 
   { global_vect_avoid           = vectAvoid
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index b530b3c6a6..3e6c33ac7d 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -42,6 +42,7 @@ import Id
 import Name
 import ErrUtils
 import Outputable
+import Module
 
 
 -- |Run a vectorisation computation.
@@ -85,7 +86,9 @@ initV hsc_env guts info thing_inside
                -- set up class and type family envrionments
            ; eps <- liftIO $ hscEPS hsc_env
            ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
-                 instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
+                 instEnvs    = InstEnvs (eps_inst_env     eps)
+                                        (mg_inst_env     guts)
+                                        (mkModuleSet (dep_orphs (mg_deps guts)))
                  builtin_pas = initClassDicts instEnvs (paClass builtins)  -- grab all 'PA' and..
                  builtin_prs = initClassDicts instEnvs (prClass builtins)  -- ..'PR' class instances
 
@@ -114,7 +117,7 @@ initV hsc_env guts info thing_inside
     -- instance dfun for that type constructor and class.  (DPH class instances cannot overlap in
     -- head constructors.)
     --
-    initClassDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
+    initClassDicts :: InstEnvs -> Class -> [(Name, Var)]
     initClassDicts insts cls = map find $ classInstances insts cls
       where
         find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile
index edc78d8845..4670958c91 100644
--- a/testsuite/tests/driver/Makefile
+++ b/testsuite/tests/driver/Makefile
@@ -569,6 +569,11 @@ T703:
 	"$(TEST_HC)" $(TEST_HC_OPTS) --make T703.hs -v0
 	! readelf -W -l T703 2>/dev/null | grep 'GNU_STACK' | grep -q 'RWE'
 
+.PHONY: T2182
+T2182:
+	! "$(TEST_HC)" $(TEST_HC_OPTS) --make T2182_A.hs T2182.hs -v0
+	! "$(TEST_HC)" $(TEST_HC_OPTS) --make T2182.hs T2182_A.hs -v0
+
 .PHONY: write_interface_oneshot
 write_interface_oneshot:
 	$(RM) -rf write_interface_oneshot/A011.hi
diff --git a/testsuite/tests/driver/T2182.hs b/testsuite/tests/driver/T2182.hs
new file mode 100644
index 0000000000..367f6bad84
--- /dev/null
+++ b/testsuite/tests/driver/T2182.hs
@@ -0,0 +1,6 @@
+module T2182 where
+instance Read (IO a) where
+ readsPrec = undefined
+x = read "" :: IO Bool
+y = show (\x -> x)
+z = (\x -> x) == (\y -> y)
diff --git a/testsuite/tests/driver/T2182.stderr b/testsuite/tests/driver/T2182.stderr
new file mode 100644
index 0000000000..b8d9e8b437
--- /dev/null
+++ b/testsuite/tests/driver/T2182.stderr
@@ -0,0 +1,28 @@
+
+T2182.hs:5:5:
+    No instance for (Show (t1 -> t1))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘show’
+    In the expression: show (\ x -> x)
+    In an equation for ‘y’: y = show (\ x -> x)
+
+T2182.hs:6:15:
+    No instance for (Eq (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘==’
+    In the expression: (\ x -> x) == (\ y -> y)
+    In an equation for ‘z’: z = (\ x -> x) == (\ y -> y)
+
+T2182.hs:5:5:
+    No instance for (Show (t1 -> t1))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘show’
+    In the expression: show (\ x -> x)
+    In an equation for ‘y’: y = show (\ x -> x)
+
+T2182.hs:6:15:
+    No instance for (Eq (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘==’
+    In the expression: (\ x -> x) == (\ y -> y)
+    In an equation for ‘z’: z = (\ x -> x) == (\ y -> y)
diff --git a/testsuite/tests/driver/T2182_A.hs b/testsuite/tests/driver/T2182_A.hs
new file mode 100644
index 0000000000..52ecca712e
--- /dev/null
+++ b/testsuite/tests/driver/T2182_A.hs
@@ -0,0 +1,4 @@
+module T2182_A where
+import Text.Show.Functions
+instance Eq (a -> b) where
+    _ == _ = True
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index f2c58d1150..ed4d924843 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -398,6 +398,7 @@ test('T8959a',
      ['$MAKE -s --no-print-directory T8959a'])
 
 test('T703', normal, run_command, ['$MAKE -s --no-print-directory T703'])
+test('T2182', normal, run_command, ['$MAKE -s --no-print-directory T2182'])
 test('T8101', normal, compile, ['-Wall -fno-code'])
 
 def build_T9050(name, way):
diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr
index 035a38f4c4..5084150660 100644
--- a/testsuite/tests/ghci.debugger/scripts/break006.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr
@@ -5,10 +5,13 @@
     Use :print or :force to determine these types
     Relevant bindings include it :: t1 (bound at <interactive>:6:1)
     Note: there are several potential instances:
-      instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
-      instance Show Ordering -- Defined in ‘GHC.Show’
-      instance Show Integer -- Defined in ‘GHC.Show’
-      ...plus 22 others
+      instance (Show a, Show b) => Show (Either a b)
+        -- Defined in ‘Data.Either’
+      instance forall (k :: BOX) (s :: k). Show (Data.Proxy.Proxy s)
+        -- Defined in ‘Data.Proxy’
+      instance (GHC.Arr.Ix a, Show a, Show b) => Show (GHC.Arr.Array a b)
+        -- Defined in ‘GHC.Arr’
+      ...plus 25 others
     In a stmt of an interactive GHCi command: print it
 
 <interactive>:8:1:
@@ -17,8 +20,11 @@
     Use :print or :force to determine these types
     Relevant bindings include it :: t1 (bound at <interactive>:8:1)
     Note: there are several potential instances:
-      instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
-      instance Show Ordering -- Defined in ‘GHC.Show’
-      instance Show Integer -- Defined in ‘GHC.Show’
-      ...plus 22 others
+      instance (Show a, Show b) => Show (Either a b)
+        -- Defined in ‘Data.Either’
+      instance forall (k :: BOX) (s :: k). Show (Data.Proxy.Proxy s)
+        -- Defined in ‘Data.Proxy’
+      instance (GHC.Arr.Ix a, Show a, Show b) => Show (GHC.Arr.Array a b)
+        -- Defined in ‘GHC.Arr’
+      ...plus 25 others
     In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr
index 0c92dba4e4..139ce8d111 100644
--- a/testsuite/tests/ghci.debugger/scripts/print019.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr
@@ -5,8 +5,12 @@
     Use :print or :force to determine these types
     Relevant bindings include it :: a1 (bound at <interactive>:11:1)
     Note: there are several potential instances:
-      instance Show TyCon -- Defined in ‘Data.Typeable.Internal’
-      instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’
-      instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
-      ...plus 30 others
+      instance forall (k :: BOX) (s :: k). Show (Proxy s)
+        -- Defined in ‘Data.Proxy’
+      instance forall (k :: BOX) (a :: k) (b :: k).
+               Show (Data.Type.Coercion.Coercion a b)
+        -- Defined in ‘Data.Type.Coercion’
+      instance forall (k :: BOX) (a :: k) (b :: k). Show (a :~: b)
+        -- Defined in ‘Data.Type.Equality’
+      ...plus 47 others
     In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci/scripts/T2182ghci.script b/testsuite/tests/ghci/scripts/T2182ghci.script
new file mode 100644
index 0000000000..9c9f78781b
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci.script
@@ -0,0 +1,49 @@
+"NO"
+(\x -> x)
+
+:m +Text.Show.Functions
+"YES"
+(\x -> x)
+
+:m -Text.Show.Functions
+"NO"
+(\x -> x)
+
+:load T2182ghci_A
+"YES"
+(\x -> x)
+T
+
+:m -T2182ghci_A
+"NO"
+(\x -> x)
+
+:load T2182ghci_B
+"YES"
+(\x -> x)
+T
+
+:m -T2182ghci_B
+"NO"
+(\x -> x)
+
+:load T2182ghci_C
+"YES"
+(\x -> x)
+T
+
+:m -T2182ghci_C
+:load T2182ghci_A
+:load T2182ghci_B
+"YES"
+(\x -> x)
+T
+
+:m -T2182ghci_A
+"YES"
+(\x -> x)
+T
+
+:m -T2182ghci_B
+"NO"
+(\x -> x)
diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stderr b/testsuite/tests/ghci/scripts/T2182ghci.stderr
new file mode 100644
index 0000000000..82fbb3188c
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci.stderr
@@ -0,0 +1,30 @@
+
+<interactive>:3:1:
+    No instance for (Show (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘print’
+    In a stmt of an interactive GHCi command: print it
+
+<interactive>:11:1:
+    No instance for (Show (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘print’
+    In a stmt of an interactive GHCi command: print it
+
+<interactive>:20:1:
+    No instance for (Show (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘print’
+    In a stmt of an interactive GHCi command: print it
+
+<interactive>:29:1:
+    No instance for (Show (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘print’
+    In a stmt of an interactive GHCi command: print it
+
+<interactive>:50:1:
+    No instance for (Show (t0 -> t0))
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a use of ‘print’
+    In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stdout b/testsuite/tests/ghci/scripts/T2182ghci.stdout
new file mode 100644
index 0000000000..6d0ce38983
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci.stdout
@@ -0,0 +1,22 @@
+"NO"
+"YES"
+<function>
+"NO"
+"YES"
+MyFunction
+T
+"NO"
+"YES"
+MyFunction
+T
+"NO"
+"YES"
+MyFunction
+T
+"YES"
+MyFunction
+T
+"YES"
+MyFunction
+T
+"NO"
diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.script b/testsuite/tests/ghci/scripts/T2182ghci2.script
new file mode 100644
index 0000000000..7bb4791140
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci2.script
@@ -0,0 +1,15 @@
+-- Warning: this test will stop working when we eliminate orphans from
+-- GHC.Float.  The idea of this test is to import an external package
+-- module which transitively depends on the module defining the orphan
+-- instance.
+:m +GHC.Types
+"NO"
+0.2 :: Float
+
+:m +Prelude
+"YES"
+0.2 :: Float
+
+:m -Prelude
+"NO"
+0.2 :: Float
diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.stderr b/testsuite/tests/ghci/scripts/T2182ghci2.stderr
new file mode 100644
index 0000000000..0a7f61959d
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci2.stderr
@@ -0,0 +1,10 @@
+
+<interactive>:8:1:
+    No instance for (GHC.Show.Show Float)
+      arising from a use of ‘System.IO.print’
+    In a stmt of an interactive GHCi command: System.IO.print it
+
+<interactive>:16:1:
+    No instance for (GHC.Show.Show Float)
+      arising from a use of ‘System.IO.print’
+    In a stmt of an interactive GHCi command: System.IO.print it
diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.stdout b/testsuite/tests/ghci/scripts/T2182ghci2.stdout
new file mode 100644
index 0000000000..0c7b219fbb
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci2.stdout
@@ -0,0 +1,4 @@
+"NO"
+"YES"
+0.2
+"NO"
diff --git a/testsuite/tests/ghci/scripts/T2182ghci_A.hs b/testsuite/tests/ghci/scripts/T2182ghci_A.hs
new file mode 100644
index 0000000000..a271f8b654
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci_A.hs
@@ -0,0 +1,4 @@
+module T2182ghci_A where
+data T = T deriving (Show)
+instance Show (a -> b) where
+    show _ = "MyFunction"
diff --git a/testsuite/tests/ghci/scripts/T2182ghci_B.hs b/testsuite/tests/ghci/scripts/T2182ghci_B.hs
new file mode 100644
index 0000000000..623d2468de
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci_B.hs
@@ -0,0 +1,2 @@
+module T2182ghci_B(T(..)) where
+import T2182ghci_A
diff --git a/testsuite/tests/ghci/scripts/T2182ghci_C.hs b/testsuite/tests/ghci/scripts/T2182ghci_C.hs
new file mode 100644
index 0000000000..d54894b700
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T2182ghci_C.hs
@@ -0,0 +1,2 @@
+module T2182ghci_C(T(..)) where
+import T2182ghci_B
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 12bfebf814..a802027569 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -99,6 +99,8 @@ test('T1914',
      ghci_script,
      ['T1914.script'])
 
+test('T2182ghci', normal, ghci_script, ['T2182ghci.script'])
+test('T2182ghci2', [extra_hc_opts("-XNoImplicitPrelude")], ghci_script, ['T2182ghci2.script'])
 test('T2976', normal, ghci_script, ['T2976.script'])
 test('T2816', normal, ghci_script, ['T2816.script'])
 test('T789', normal, ghci_script, ['T789.script'])
diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr
index 701bd761d3..af420d2382 100644
--- a/testsuite/tests/typecheck/should_fail/T5095.stderr
+++ b/testsuite/tests/typecheck/should_fail/T5095.stderr
@@ -60,6 +60,13 @@ T5095.hs:9:11:
         -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’
       instance Eq Integer
         -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’
+      instance forall (k :: BOX) (s :: k). Eq (Data.Proxy.Proxy s)
+        -- Defined in ‘Data.Proxy’
+      instance (Eq a, Eq b) => Eq (Either a b)
+        -- Defined in ‘Data.Either’
+      instance (GHC.Arr.Ix i, Eq e) => Eq (GHC.Arr.Array i e)
+        -- Defined in ‘GHC.Arr’
+      instance Eq (GHC.Arr.STArray s i e) -- Defined in ‘GHC.Arr’
     (The choice depends on the instantiation of ‘a’
      To pick the first instance above, use IncoherentInstances
      when compiling the other instance declarations)