-- * Selective free variables of expressions
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
- exprFreeNames, exprsFreeNames,
-- * Free variables of Rules, Vars and Ids
varTypeTyVars, varTypeTcTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, rulesFreeVars,
- ruleLhsFreeNames, ruleLhsFreeIds,
+ ruleLhsOrphNames, ruleLhsFreeIds,
-- * Core syntax tree annotation with free variables
CoreExprWithFVs, -- = AnnExpr Id VarSet
%************************************************************************
\begin{code}
--- | Similar to 'exprFreeNames'. However, this is used when deciding whether
+-- | ruleLhsOrphNames is used when deciding whether
-- a rule is an orphan. In particular, suppose that T is defined in this
-- module; we want to avoid declaring that a rule like:
--
--
-- is an orphan. Of course it isn't, and declaring it an orphan would
-- make the whole module an orphan module, which is bad.
-ruleLhsFreeNames :: CoreRule -> NameSet
-ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
-ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args })
- = addOneToNameSet (exprsFreeNames tpl_args) fn
+ruleLhsOrphNames :: CoreRule -> NameSet
+ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
+ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args })
+ = addOneToNameSet (exprsOrphNames tpl_args) fn
+ -- No need to delete bndrs, because
+ -- exprsOrphNames finds only External names
-- | Finds the free /external/ names of an expression, notably
-- including the names of type constructors (which of course do not show
-- up in 'exprFreeVars').
-exprFreeNames :: CoreExpr -> NameSet
+exprOrphNames :: CoreExpr -> NameSet
-- There's no need to delete local binders, because they will all
-- be /internal/ names.
-exprFreeNames e
+exprOrphNames e
= go e
where
go (Var v)
| otherwise = emptyNameSet
where n = idName v
go (Lit _) = emptyNameSet
- go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
+ go (Type ty) = orphNamesOfType ty -- Don't need free tyvars
go (App e1 e2) = go e1 `unionNameSets` go e2
go (Lam v e) = go e `delFromNameSet` idName v
go (Note _ e) = go e
- go (Cast e co) = go e `unionNameSets` tyClsNamesOfType co
+ go (Cast e co) = go e `unionNameSets` orphNamesOfType co
go (Let (NonRec _ r) e) = go e `unionNameSets` go r
- go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
- go (Case e _ ty as) = go e `unionNameSets` tyClsNamesOfType ty
+ go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e
+ go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty
`unionNameSets` unionManyNameSets (map go_alt as)
go_alt (_,_,r) = go r
--- | Finds the free /external/ names of several expressions: see 'exprFreeNames' for details
-exprsFreeNames :: [CoreExpr] -> NameSet
-exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
+-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
+exprsOrphNames :: [CoreExpr] -> NameSet
+exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
\end{code}
%************************************************************************
(_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
-- Slightly awkward: we need the Class to get the fundeps
(tvs, fds) = classTvsFds cls
- arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
+ arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
orph | is_local cls_name = Just (nameOccName cls_name)
| all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns
| otherwise = Nothing
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
-coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
- ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs,
- ru_auto = auto })
+coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
+ ru_act = act, ru_bndrs = bndrs,
+ ru_args = args, ru_rhs = rhs,
+ ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
-- A rule is an orphan only if none of the variables
-- mentioned on its left-hand side are locally defined
- lhs_names = fn : nameSetToList (exprsFreeNames args)
- -- No need to delete bndrs, because
- -- exprsFreeNames finds only External names
+ lhs_names = nameSetToList (ruleLhsOrphNames rule)
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n : _) -> Just (nameOccName n)
return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
where
plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
- = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
+ = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec
where -- A name is ok if it's in the rdr_env,
-- whether qualified or not
ok n | n == name = True -- The one we looked for in the first place!
import DataCon
import Type
import Class
-import TcType ( tyClsNamesOfDFunHead )
+import TcType ( orphNamesOfDFunHead )
import Inst ( tcGetInstEnvs )
import Data.List ( sortBy )
, let dfun = instanceDFunId ispec
, relevant dfun ] }
where
- relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
tc_name = tyConName tc
lookupInsts _ = return []
---------------------------------
-- Misc type manipulators
deNoteType,
- tyClsNamesOfType, tyClsNamesOfDFunHead,
+ orphNamesOfType, orphNamesOfDFunHead,
getDFunTyKey,
---------------------------------
= go ty
where
go ty | Just ty' <- tcView ty = go ty' -- This is the key line
- go (TyVarTy tv) = unitVarSet tv
- go (TyConApp _ tys) = exactTyVarsOfTypes tys
- go (PredTy ty) = go_pred ty
- go (FunTy arg res) = go arg `unionVarSet` go res
- go (AppTy fun arg) = go fun `unionVarSet` go arg
- go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
- `unionVarSet` go_tv tyvar
+ go (TyVarTy tv) = unitVarSet tv
+ go (TyConApp _ tys) = exactTyVarsOfTypes tys
+ go (PredTy ty) = go_pred ty
+ go (FunTy arg res) = go arg `unionVarSet` go res
+ go (AppTy fun arg) = go fun `unionVarSet` go arg
+ go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
+ `unionVarSet` go_tv tyvar
go_pred (IParam _ ty) = go ty
go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
end of the compiler.
\begin{code}
-tyClsNamesOfType :: Type -> NameSet
-tyClsNamesOfType (TyVarTy _) = emptyNameSet
-tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (PredTy (IParam _ ty)) = tyClsNamesOfType ty
-tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
-tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
-tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
-tyClsNamesOfType (ForAllTy _ ty) = tyClsNamesOfType ty
-
-tyClsNamesOfTypes :: [Type] -> NameSet
-tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
-
-tyClsNamesOfDFunHead :: Type -> NameSet
+orphNamesOfType :: Type -> NameSet
+orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
+ -- Look through type synonyms (Trac #4912)
+orphNamesOfType (TyVarTy _) = emptyNameSet
+orphNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon)
+ `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (IParam _ ty)) = orphNamesOfType ty
+orphNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl)
+ `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1
+ `unionNameSets` orphNamesOfType ty2
+orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res
+orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
+orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty
+
+orphNamesOfTypes :: [Type] -> NameSet
+orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
+
+orphNamesOfDFunHead :: Type -> NameSet
-- Find the free type constructors and classes
-- of the head of the dfun instance type
-- The 'dfun_head_type' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
-tyClsNamesOfDFunHead dfun_ty
+orphNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
- (_, _, head_ty) -> tyClsNamesOfType head_ty
+ (_, _, head_ty) -> orphNamesOfType head_ty
\end{code}
projects / ghc-hetmet.git / commitdiff