summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/IfaceSyn.lhs7
-rw-r--r--compiler/iface/MkIface.lhs55
-rw-r--r--compiler/iface/TcIface.lhs5
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
View Lorry Controller Status