--------------------------------
-- MetaDetails
UserTypeCtxt(..), pprUserTypeCtxt,
- TcTyVarDetails(..), pprTcTyVarDetails,
+ TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
MetaDetails(Flexi, Indirect), MetaInfo(..),
- SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy,
isSigTyVar, isOverlappableTyVar, isTyConableTyVar,
metaTvRef,
- isFlexi, isIndirect, isUnkSkol, isRuntimeUnkSkol,
+ isFlexi, isIndirect, isRuntimeUnkSkol,
--------------------------------
-- Builders
-- 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,
---------------------------------
-- Misc type manipulators
deNoteType,
- tyClsNamesOfType, tyClsNamesOfDFunHead,
+ orphNamesOfType, orphNamesOfDFunHead,
getDFunTyKey,
---------------------------------
isPredTy, isDictTy, isDictLikeTy,
tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
isIPPred,
- isRefineableTy, isRefineablePred,
+ mkMinimalBySCs, transSuperClasses, immSuperClasses,
-- * Tidying type related things up for printing
tidyType, tidyTypes,
tidyTyVarBndr, tidyFreeTyVars,
tidyOpenTyVar, tidyOpenTyVars,
tidyTopType, tidyPred,
- tidyKind, tidySkolemTyVar,
+ tidyKind,
---------------------------------
-- Foreign import and export
-- friends:
import TypeRep
-import DataCon
import Class
import Var
import ForeignCall
import Type
import Coercion
import TyCon
-import HsExpr( HsMatchContext )
-- others:
import DynFlags
\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
| 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)
-
- | 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
| 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 = []
--
\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)
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))]]
-
-instance Outputable SkolemInfo where
- ppr = pprSkolInfo
-
-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 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}
-- 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
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}
-- 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
--- isOverlappableTyVar has a unique purpose.
--- See Note [Binding when looking up instances] in InstEnv.
isOverlappableTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- SkolemTv (PatSkol {}) -> True
- SkolemTv (InstSkol {}) -> True
- _ -> False
+ SkolemTv overlappable -> overlappable
+ _ -> False
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> True
- _ -> False
+ MetaTv SigTv _ -> True
+ _ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
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}
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
| 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
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
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.
= 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 / blobdiff