Commit 614ba3c5 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Kill off sizePred

It really isn't needed, and life is simpler without
parent 7c07cf16
...@@ -318,8 +318,14 @@ newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS () ...@@ -318,8 +318,14 @@ newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS ()
-- Returns superclasses, see Note [Adding superclasses] -- Returns superclasses, see Note [Adding superclasses]
newSCWorkFromFlavored flavor cls xis newSCWorkFromFlavored flavor cls xis
| CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor | CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor
= do { let size = sizePred (mkClassPred cls xis) = do { let size = sizeTypes xis
loc' = case ctLocOrigin loc of loc' | isCTupleClass cls
= loc -- For tuple predicates, just take them apart, without
-- adding their (large) size into the chain. When we
-- get down to a base predicate, we'll include its size.
-- Trac #10335
| otherwise
= case ctLocOrigin loc of
GivenOrigin InstSkol GivenOrigin InstSkol
-> loc { ctl_origin = GivenOrigin (InstSC size) } -> loc { ctl_origin = GivenOrigin (InstSC size) }
GivenOrigin (InstSC n) GivenOrigin (InstSC n)
......
...@@ -999,7 +999,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t ...@@ -999,7 +999,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t
; return (ids, listToBag binds, listToBag implics) } ; return (ids, listToBag binds, listToBag implics) }
where where
loc = getSrcSpan dfun_id loc = getSrcSpan dfun_id
size = sizePred (mkClassPred cls inst_tys) size = sizeTypes inst_tys
tc_super (sc_pred, n) tc_super (sc_pred, n)
= do { (sc_implic, sc_ev_id) <- checkInstConstraints $ \_ -> = do { (sc_implic, sc_ev_id) <- checkInstConstraints $ \_ ->
emitWanted (ScOrigin size) sc_pred emitWanted (ScOrigin size) sc_pred
...@@ -1096,7 +1096,7 @@ generate a guaranteed-non-bottom superclass witness from: ...@@ -1096,7 +1096,7 @@ generate a guaranteed-non-bottom superclass witness from:
(sc3) a call of a dfun (always returns a dictionary constructor) (sc3) a call of a dfun (always returns a dictionary constructor)
The tricky case is (sc2). We proceed by induction on the size of The tricky case is (sc2). We proceed by induction on the size of
the (type of) the dictionary, defined by TcValidity.sizePred. the (type of) the dictionary, defined by TcValidity.sizeTypes.
Let's suppose we are building a dictionary of size 3, and Let's suppose we are building a dictionary of size 3, and
suppose the Superclass Invariant holds of smaller dictionaries. suppose the Superclass Invariant holds of smaller dictionaries.
Then if we have a smaller dictionary, its immediate superclasses Then if we have a smaller dictionary, its immediate superclasses
......
...@@ -2067,9 +2067,10 @@ data SkolemInfo ...@@ -2067,9 +2067,10 @@ data SkolemInfo
| ClsSkol Class -- Bound at a class decl | ClsSkol Class -- Bound at a class decl
| InstSkol -- Bound at an instance decl | InstSkol -- Bound at an instance decl
| InstSC TypeSize -- A "given" constraint obtained by superclass selection | InstSC TypeSize -- A "given" constraint obtained by superclass selection.
-- from an InstSkol, giving the largest class from -- If (C ty1 .. tyn) is the largest class from
-- which we made a superclass selection in the chain -- which we made a superclass selection in the chain,
-- then TypeSize = sizeTypes [ty1, .., tyn]
-- See Note [Solving superclass constraints] in TcInstDcls -- See Note [Solving superclass constraints] in TcInstDcls
| DataSkol -- Bound at a data type declaration | DataSkol -- Bound at a data type declaration
...@@ -2193,7 +2194,8 @@ data CtOrigin ...@@ -2193,7 +2194,8 @@ data CtOrigin
| ViewPatOrigin | ViewPatOrigin
| ScOrigin TypeSize -- Typechecking superclasses of an instance declaration | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration
-- whose head has the given size -- If the instance head is C ty1 .. tyn
-- then TypeSize = sizeTypes [ty1, .., tyn]
-- See Note [Solving superclass constraints] in TcInstDcls -- See Note [Solving superclass constraints] in TcInstDcls
| DerivOrigin -- Typechecking deriving | DerivOrigin -- Typechecking deriving
......
...@@ -149,7 +149,7 @@ module TcType ( ...@@ -149,7 +149,7 @@ module TcType (
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprType, pprParendType, pprTypeApp, pprTyThingCategory,
pprTheta, pprThetaArrowTy, pprClassPred, pprTheta, pprThetaArrowTy, pprClassPred,
TypeSize, sizePred, sizeType, sizeTypes TypeSize, sizeType, sizeTypes
) where ) where
...@@ -1872,40 +1872,23 @@ is irreducible. See Trac #5581. ...@@ -1872,40 +1872,23 @@ is irreducible. See Trac #5581.
type TypeSize = IntWithInf type TypeSize = IntWithInf
sizeType :: Type -> TypeSize sizeType, size_type :: Type -> TypeSize
-- Size of a type: the number of variables and constructors -- Size of a type: the number of variables and constructors
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -- Ignore kinds altogether
sizeType (TyVarTy {}) = 1 sizeType ty | isKind ty = 0
sizeType (TyConApp tc tys) | otherwise = size_type ty
size_type ty | Just exp_ty <- tcView ty = size_type exp_ty
size_type (TyVarTy {}) = 1
size_type (TyConApp tc tys)
| isTypeFamilyTyCon tc = infinity -- Type-family applications can | isTypeFamilyTyCon tc = infinity -- Type-family applications can
-- expand to any arbitrary size -- expand to any arbitrary size
| otherwise = sizeTypes tys + 1 | otherwise = sizeTypes tys + 1
sizeType (LitTy {}) = 1 size_type (LitTy {}) = 1
sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 size_type (FunTy arg res) = size_type arg + size_type res + 1
sizeType (AppTy fun arg) = sizeType fun + sizeType arg size_type (AppTy fun arg) = size_type fun + size_type arg
sizeType (ForAllTy _ ty) = sizeType ty size_type (ForAllTy _ ty) = size_type ty
sizeTypes :: [Type] -> TypeSize sizeTypes :: [Type] -> TypeSize
-- IA0_NOTE: Avoid kinds. sizeTypes tys = sum (map sizeType tys)
sizeTypes xs = sum (map sizeType tys)
where tys = filter (not . isKind) xs
-- Note [Size of a predicate]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We are considering whether class constraints terminate.
-- Equality constraints and constraints for the implicit
-- parameter class always termiante so it is safe to say "size 0".
-- (Implicit parameter constraints always terminate because
-- there are no instances for them---they are only solved by
-- "local instances" in expressions).
-- See Trac #4200.
sizePred :: PredType -> TypeSize
sizePred p
= case classifyPredType p of
ClassPred cls tys
| isIPClass cls -> 0 -- See Note [Size of a predicate]
| isCTupleClass cls -> maximum (0 : map sizePred tys)
| otherwise -> sizeTypes tys
EqPred {} -> 0 -- See Note [Size of a predicate]
IrredPred ty -> sizeType ty
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment