From 95cbb55cf7dfeaae466f0512af28a92914faacb5 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 21 Feb 2017 14:27:30 +0000
Subject: 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.
---
 compiler/typecheck/TcDerivInfer.hs | 33 +++++++++++++++------------------
 1 file changed, 15 insertions(+), 18 deletions(-)

(limited to 'compiler/typecheck/TcDerivInfer.hs')

diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index 02e9f1f3b8..22c05033bf 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))
-- 
cgit v1.2.1