Commit 4c834fdd authored by Edward Z. Yang's avatar Edward Z. Yang

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

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: default avatarEdward 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
parent 46c53d5c
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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}
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
module T2182 where
instance Read (IO a) where
readsPrec = undefined
x = read "" :: IO Bool
y = show (\x -> x)
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)
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)
module T2182_A where
import Text.Show.Functions
instance Eq (a -> b) where
_ == _ = True
......@@ -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):
......
......@@ -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’