X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=d9166d1c58c68c2c588f90d72b681f36d218942e;hp=47bb554e867d4760659079f8bd8bfbe3c6f89813;hb=35a1ec430a5e44a9bc79d385b997422c20cb427b;hpb=0dc2b9de4dd4681aa11dfa5419c931a51b274fa6 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 47bb554..d9166d1 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -24,13 +24,12 @@ module TcType ( -------------------------------- -- MetaDetails UserTypeCtxt(..), pprUserTypeCtxt, - TcTyVarDetails(..), pprTcTyVarDetails, + TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), - SkolemInfo(..), pprSkolTvBinding, pprSkolInfo, isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, - isSigTyVar, isExistentialTyVar, isTyConableTyVar, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, metaTvRef, - isFlexi, isIndirect, isUnkSkol, isRuntimeUnkSkol, + isFlexi, isIndirect, isRuntimeUnkSkol, -------------------------------- -- Builders @@ -53,7 +52,7 @@ module TcType ( -- Again, newtypes are opaque tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, eqKind, - isSigmaTy, isOverloadedTy, isRigidTy, + isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, @@ -62,7 +61,7 @@ module TcType ( --------------------------------- -- Misc type manipulators deNoteType, - tyClsNamesOfType, tyClsNamesOfDFunHead, + orphNamesOfType, orphNamesOfDFunHead, getDFunTyKey, --------------------------------- @@ -74,7 +73,7 @@ module TcType ( isPredTy, isDictTy, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, isIPPred, - isRefineableTy, isRefineablePred, + mkMinimalBySCs, transSuperClasses, immSuperClasses, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -82,7 +81,7 @@ module TcType ( tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTopType, tidyPred, - tidyKind, tidySkolemTyVar, + tidyKind, --------------------------------- -- Foreign import and export @@ -147,7 +146,6 @@ module TcType ( -- friends: import TypeRep -import DataCon import Class import Var import ForeignCall @@ -155,7 +153,6 @@ import VarSet import Type import Coercion import TyCon -import HsExpr( HsMatchContext ) -- others: import DynFlags @@ -273,9 +270,15 @@ TcBinds.tcInstSig, and its use_skols parameter. \begin{code} -- A TyVarDetails is inside a TyVar data TcTyVarDetails - = SkolemTv SkolemInfo -- A skolem constant + = SkolemTv -- A skolem + Bool -- True <=> this skolem type variable can be overlapped + -- when looking up instances + -- See Note [Binding when looking up instances] in InstEnv - | FlatSkol TcType + | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi + -- interactive context + + | FlatSkol TcType -- The "skolem" obtained by flattening during -- constraint simplification @@ -285,70 +288,41 @@ data TcTyVarDetails | MetaTv MetaInfo (IORef MetaDetails) +vanillaSkolemTv, superSkolemTv :: TcTyVarDetails +-- See Note [Binding when looking up instances] in InstEnv +vanillaSkolemTv = SkolemTv False -- Might be instantiated +superSkolemTv = SkolemTv True -- Treat this as a completely distinct type + data MetaDetails = Flexi -- Flexi type variables unify to become Indirects | Indirect TcType -data MetaInfo +instance Outputable MetaDetails where + ppr Flexi = ptext (sLit "Flexi") + ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty + +data MetaInfo = TauTv -- This MetaTv is an ordinary unification variable -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls - | SigTv Name -- A variant of TauTv, except that it should not be + | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- SigTvs are only distinguished to improve error messages -- see Note [Signature skolems] -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv - -- The Name is the name of the function from whose - -- type signature we got this skolem | TcsTv -- A MetaTv allocated by the constraint solver -- Its particular property is that it is always "touchable" -- Nevertheless, the constraint solver has to try to guess -- what type to instantiate it to ----------------------------------- --- SkolemInfo describes a site where --- a) type variables are skolemised --- b) an implication constraint is generated -data SkolemInfo - = SigSkol UserTypeCtxt -- A skolem that is created by instantiating - -- a programmer-supplied type signature - -- Location of the binding site is on the TyVar - - -- The rest are for non-scoped skolems - | ClsSkol Class -- Bound at a class decl - | InstSkol -- Bound at an instance decl - | FamInstSkol -- Bound at a family instance decl - | PatSkol -- An existential type variable bound by a pattern for - DataCon -- a data constructor with an existential type. - (HsMatchContext Name) - -- e.g. data T = forall a. Eq a => MkT a - -- f (MkT x) = ... - -- The pattern MkT x will allocate an existential type - -- variable for 'a'. - - | ArrowSkol -- An arrow form (see TcArrows) - - | IPSkol [IPName Name] -- Binding site of an implicit parameter - - | RuleSkol RuleName -- The LHS of a RULE - | GenSkol TcType -- Bound when doing a subsumption check for ty - - | RuntimeUnkSkol -- a type variable used to represent an unknown - -- runtime type (used in the GHCi debugger) - - | NoScSkol -- Used for the "self" superclass when solving - -- superclasses; don't generate superclasses of me - - | UnkSkol -- Unhelpful info (until I improve it) - ------------------------------------- --- UserTypeCtxt describes the places where a --- programmer-written type signature can occur --- Like SkolemInfo, no location info -data UserTypeCtxt +-- UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need to an expression has that type + +data UserTypeCtxt = FunSigCtxt Name -- Function type signature -- Also used for types in SPECIALISE pragmas | ExprSigCtxt -- Expression type signature @@ -367,6 +341,10 @@ data UserTypeCtxt | SpecInstCtxt -- SPECIALISE instance pragma | ThBrackCtxt -- Template Haskell type brackets [t| ... |] + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] -- @@ -412,11 +390,12 @@ kind_var_occ = mkOccName tvName "k" \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk") -pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") -pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") -pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") -pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") +pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") +pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") +pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") +pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) @@ -431,51 +410,7 @@ pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") - -pprSkolTvBinding :: TcTyVar -> SDoc --- Print info about the binding of a skolem tyvar, --- or nothing if we don't have anything useful to say -pprSkolTvBinding tv - = ASSERT ( isTcTyVar tv ) - quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) - where - ppr_details (SkolemTv info) = ppr_skol info - ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable") - ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") - <+> quotes (ppr n) - ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable") - - ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") - ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"), - sep [pprSkolInfo info, - nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]] - -pprSkolInfo :: SkolemInfo -> SDoc --- Complete the sentence "is a rigid type variable bound by..." -pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt -pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter bindings for") - <+> pprWithCommas ppr ips -pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) -pprSkolInfo InstSkol = ptext (sLit "the instance declaration") -pprSkolInfo NoScSkol = ptext (sLit "the instance declaration (self)") -pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration") -pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name) -pprSkolInfo ArrowSkol = ptext (sLit "the arrow form") -pprSkolInfo (PatSkol dc _) = sep [ ptext (sLit "a pattern with constructor") - , ppr dc <+> dcolon <+> ppr (dataConUserType dc) ] -pprSkolInfo (GenSkol ty) = sep [ ptext (sLit "the polymorphic type") - , quotes (ppr ty) ] - --- UnkSkol --- For type variables the others are dealt with by pprSkolTvBinding. --- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") -pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol") - -instance Outputable MetaDetails where - ppr Flexi = ptext (sLit "Flexi") - ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty +pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") \end{code} @@ -492,18 +427,27 @@ instance Outputable MetaDetails where -- It doesn't change the uniques at all, just the print names. tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) tidyTyVarBndr env@(tidy_env, subst) tyvar - = case tidyOccName tidy_env (getOccName name) of + = case tidyOccName tidy_env occ1 of (tidy', occ') -> ((tidy', subst'), tyvar'') where - subst' = extendVarEnv subst tyvar tyvar'' - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' - -- Don't forget to tidy the kind for coercions! + subst' = extendVarEnv subst tyvar tyvar'' + tyvar' = setTyVarName tyvar name' + + name' = tidyNameOcc name occ' + + -- Don't forget to tidy the kind for coercions! tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind' | otherwise = tyvar' kind' = tidyType env (tyVarKind tyvar) where name = tyVarName tyvar + occ = getOccName name + -- System Names are for unification variables; + -- when we tidy them we give them a trailing "0" (or 1 etc) + -- so that they don't take precedence for the un-modified name + occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0") + | otherwise = occ + --------------- tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv @@ -579,24 +523,6 @@ tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty --------------- -tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar) --- Tidy the type inside a GenSkol, preparatory to printing it -tidySkolemTyVar env tv - = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) ) - (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1) - where - (env1, info1) = case tcTyVarDetails tv of - SkolemTv info -> (env1, SkolemTv info') - where - (env1, info') = tidy_skol_info env info - info -> (env, info) - - tidy_skol_info env (GenSkol ty) = (env1, GenSkol ty1) - where - (env1, ty1) = tidyOpenType env ty - tidy_skol_info env info = (env, info) - ---------------- tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) tidyKind env k = tidyOpenType env k \end{code} @@ -615,7 +541,7 @@ isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True -isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar tv @@ -624,21 +550,22 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> False - _ -> True + MetaTv SigTv _ -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - SkolemTv {} -> True - FlatSkol {} -> True - MetaTv {} -> False + SkolemTv {} -> True + FlatSkol {} -> True + RuntimeUnk {} -> True + MetaTv {} -> False -isExistentialTyVar tv -- Existential type variable, bound by a pattern +isOverlappableTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - SkolemTv (PatSkol {}) -> True - _ -> False + SkolemTv overlappable -> overlappable + _ -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -654,8 +581,8 @@ isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> True - _ -> False + MetaTv SigTv _ -> True + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv @@ -673,15 +600,9 @@ isIndirect _ = False isRuntimeUnkSkol :: TyVar -> Bool -- Called only in TcErrors; see Note [Runtime skolems] there -isRuntimeUnkSkol x | isTcTyVar x - , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x - = True - | otherwise = False - -isUnkSkol :: TyVar -> Bool -isUnkSkol x | isTcTyVar x - , SkolemTv UnkSkol <- tcTyVarDetails x = True - | otherwise = False +isRuntimeUnkSkol x + | isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True + | otherwise = False \end{code} @@ -711,7 +632,6 @@ isTauTy (FunTy a b) = isTauTy a && isTauTy b isTauTy (PredTy _) = True -- Don't look through source types isTauTy _ = False - isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype isTauTyCon tc @@ -719,24 +639,7 @@ isTauTyCon tc | otherwise = True --------------- -isRigidTy :: TcType -> Bool --- A type is rigid if it has no meta type variables in it -isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty)) - -isRefineableTy :: TcType -> (Bool,Bool) --- A type should have type refinements applied to it if it has --- free type variables, and they are all rigid -isRefineableTy ty = (null tc_tvs, all isImmutableTyVar tc_tvs) - where - tc_tvs = varSetElems (tcTyVarsOfType ty) - -isRefineablePred :: TcPredType -> Bool -isRefineablePred pred = not (null tc_tvs) && all isImmutableTyVar tc_tvs - where - tc_tvs = varSetElems (tcTyVarsOfPred pred) - ---------------- -getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv @@ -917,23 +820,24 @@ tcIsTyVarTy :: Type -> Bool tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type]) -- Split the type of a dictionary function -- We don't use tcSplitSigmaTy, because a DFun may (with NDP) -- have non-Pred arguments, such as -- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> - (tvs, clas, tys) }} + = case tcSplitForAllTys ty of { (tvs, rho) -> + case split_dfun_args 0 rho of { (n_theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> + (tvs, n_theta, clas, tys) }}} where - -- Discard the context of the dfun. This can be a mix of + -- Count the context of the dfun. This can be a mix of -- coercion and class constraints; or (in the general NDP case) -- some other function argument - drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' - drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty - drop_pred_tys (FunTy _ ty) = drop_pred_tys ty - drop_pred_tys ty = ty + split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty' + split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty + split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty + split_dfun_args n ty = (n, ty) tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau @@ -954,6 +858,9 @@ tcInstHeadTyAppAllTyVars :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head -- These must be a constructor applied to type variable arguments tcInstHeadTyAppAllTyVars ty + | Just ty' <- tcView ty -- Look through synonyms + = tcInstHeadTyAppAllTyVars ty' + | otherwise = case ty of TyConApp _ tys -> ok tys FunTy arg res -> ok [arg, res] @@ -1022,8 +929,6 @@ getClassPredTys _ = panic "getClassPredTys" mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) - - isDictLikeTy :: Type -> Bool -- Note [Dictionary-like types] isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' @@ -1033,6 +938,35 @@ isDictLikeTy (TyConApp tc tys) isDictLikeTy _ = False \end{code} +Superclasses + +\begin{code} +mkMinimalBySCs :: [PredType] -> [PredType] +-- Remove predicates that can be deduced from others by superclasses +mkMinimalBySCs ptys = [ ploc | ploc <- ptys + , ploc `not_in_preds` rec_scs ] + where + rec_scs = concatMap trans_super_classes ptys + not_in_preds p ps = null (filter (tcEqPred p) ps) + trans_super_classes (ClassP cls tys) = transSuperClasses cls tys + trans_super_classes _other_pty = [] + +transSuperClasses :: Class -> [Type] -> [PredType] +transSuperClasses cls tys + = foldl (\pts p -> trans_sc p ++ pts) [] $ + immSuperClasses cls tys + where trans_sc :: PredType -> [PredType] + trans_sc this_pty@(ClassP cls tys) + = foldl (\pts p -> trans_sc p ++ pts) [this_pty] $ + immSuperClasses cls tys + trans_sc pty = [pty] + +immSuperClasses :: Class -> [Type] -> [PredType] +immSuperClasses cls tys + = substTheta (zipTopTvSubst tyvars tys) sc_theta + where (tyvars,sc_theta,_,_) = classBigSig cls +\end{code} + Note [Dictionary-like types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Being "dictionary-like" means either a dictionary type or a tuple thereof. @@ -1226,13 +1160,13 @@ exactTyVarsOfType ty = 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 @@ -1249,29 +1183,34 @@ Find the free tycons and classes of a type. This is used in the front 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}