[commit: ghc] master: Refactor inferConstraints not to use CPS (95cbb55)
git at git.haskell.org
git at git.haskell.org
Tue Feb 21 14:29:17 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/95cbb55cf7dfeaae466f0512af28a92914faacb5/ghc
>---------------------------------------------------------------
commit 95cbb55cf7dfeaae466f0512af28a92914faacb5
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Feb 21 14:27:30 2017 +0000
Refactor inferConstraints not to use CPS
For some odd reason inferConstraints was using a CPS style,
which is entirely unnecessary. This patch straightens it out.
No change in what it does.
>---------------------------------------------------------------
95cbb55cf7dfeaae466f0512af28a92914faacb5
compiler/typecheck/TcDeriv.hs | 10 ++++++----
compiler/typecheck/TcDerivInfer.hs | 33 +++++++++++++++------------------
2 files changed, 21 insertions(+), 22 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 55b7d6d..86f0409 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1010,16 +1010,18 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
dfun_name <- newDFunName' cls tycon
case mtheta of
Nothing -> -- Infer context
- inferConstraints tvs cls cls_tys inst_ty rep_tc rep_tc_args mechanism
- $ \inferred_constraints tvs' inst_tys' ->
- return $ InferTheta $ DS
+ do { (inferred_constraints, tvs', inst_tys')
+ <- inferConstraints tvs cls cls_tys inst_ty
+ rep_tc rep_tc_args mechanism
+ ; return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs'
, ds_cls = cls, ds_tys = inst_tys'
, ds_tc = rep_tc
, ds_theta = inferred_constraints
, ds_overlap = overlap_mode
- , ds_mechanism = mechanism }
+ , ds_mechanism = mechanism } }
+
Just theta -> do -- Specified context
return $ GivenTheta $ DS
{ ds_loc = loc
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index 02e9f1f..22c0503 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -48,8 +48,7 @@ import Data.Maybe
inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
-> TyCon -> [TcType] -> DerivSpecMechanism
- -> ([ThetaOrigin] -> [TyVar] -> [TcType] -> TcM a)
- -> TcM a
+ -> TcM ([ThetaOrigin], [TyVar], [TcType])
-- inferConstraints figures out the constraints needed for the
-- instance declaration generated by a 'deriving' clause on a
-- data type declaration. It also returns the new in-scope type
@@ -67,15 +66,15 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
-- before being used in the instance declaration
inferConstraints tvs main_cls cls_tys inst_ty
rep_tc rep_tc_args
- mechanism thing
+ mechanism
| is_generic && not is_anyclass -- Generic constraints are easy
- = thing [mkThetaOriginFromPreds []] tvs inst_tys
+ = return ([], tvs, inst_tys)
| is_generic1 && not is_anyclass -- Generic1 needs Functor
= ASSERT( length rep_tc_tvs > 0 ) -- See Note [Getting base classes]
ASSERT( length cls_tys == 1 ) -- Generic1 has a single kind variable
do { functorClass <- tcLookupClass functorClassName
- ; con_arg_constraints (get_gen1_constraints functorClass) thing }
+ ; con_arg_constraints (get_gen1_constraints functorClass) }
| otherwise -- The others are a bit more complicated
= -- See the comment with all_rep_tc_args for an explanation of
@@ -83,14 +82,14 @@ inferConstraints tvs main_cls cls_tys inst_ty
ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
, ppr main_cls <+> ppr rep_tc
$$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
- infer_constraints $ \arg_constraints tvs' inst_tys' ->
- do { traceTc "inferConstraints" $ vcat
+ do { (arg_constraints, tvs', inst_tys') <- infer_constraints
+ ; traceTc "inferConstraints" $ vcat
[ ppr main_cls <+> ppr inst_tys'
, ppr arg_constraints
]
- ; thing (stupid_constraints ++ extra_constraints
- ++ sc_constraints ++ arg_constraints)
- tvs' inst_tys' }
+ ; return (stupid_constraints ++ extra_constraints
+ ++ sc_constraints ++ arg_constraints
+ , tvs', inst_tys') }
where
is_anyclass = isDerivSpecAnyClass mechanism
infer_constraints
@@ -108,9 +107,8 @@ inferConstraints tvs main_cls cls_tys inst_ty
con_arg_constraints :: (CtOrigin -> TypeOrKind
-> Type
-> [([PredOrigin], Maybe TCvSubst)])
- -> ([ThetaOrigin] -> [TyVar] -> [TcType] -> TcM a)
- -> TcM a
- con_arg_constraints get_arg_constraints thing
+ -> TcM ([ThetaOrigin], [TyVar], [TcType])
+ con_arg_constraints get_arg_constraints
= let (predss, mbSubsts) = unzip
[ preds_and_mbSubst
| data_con <- tyConDataCons rep_tc
@@ -136,7 +134,7 @@ inferConstraints tvs main_cls cls_tys inst_ty
preds' = map (substPredOrigin subst') preds
inst_tys' = substTys subst' inst_tys
tvs' = tyCoVarsOfTypesWellScoped inst_tys'
- in thing [mkThetaOriginFromPreds preds'] tvs' inst_tys'
+ in return ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
is_generic = main_cls `hasKey` genClassKey
is_generic1 = main_cls `hasKey` gen1ClassKey
@@ -243,9 +241,8 @@ typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
-- for an explanation of how these constraints are used to determine the
-- derived instance context.
inferConstraintsDAC :: Class -> [TyVar] -> [TcType]
- -> ([ThetaOrigin] -> [TyVar] -> [TcType] -> TcM a)
- -> TcM a
-inferConstraintsDAC cls tvs inst_tys thing
+ -> TcM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDAC cls tvs inst_tys
= do { let gen_dms = [ (sel_id, dm_ty)
| (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
@@ -254,7 +251,7 @@ inferConstraintsDAC cls tvs inst_tys thing
-- to mk_wanteds in simplifyDeriv. If we omit this, the
-- unification variables will wrongly be untouchable.
- ; thing theta_origins tvs inst_tys }
+ ; return (theta_origins, tvs, inst_tys) }
where
cls_tvs = classTyVars cls
empty_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tvs))
More information about the ghc-commits
mailing list