[commit: ghc] master: Split out inferConstraintsDataConArgs from inferConstraints (a4f347c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a4f347c23ed926c24d178fec54c27d94f1fae0e4/ghc

>---------------------------------------------------------------

commit a4f347c23ed926c24d178fec54c27d94f1fae0e4
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sat Aug 12 15:46:22 2017 -0400

    Split out inferConstraintsDataConArgs from inferConstraints
    
    Summary:
    Addresses point (1) of https://phabricator.haskell.org/D3337#107865.
    
    Before, `inferConstraints` awkwardly combined all of the logic needed to handle
    stock, newtype, and anyclass deriving. Really, though, the stock/newtype logic
    is quite different from the anyclass logic, so this splits off
    `inferConstraintsDataConArgs` (so named because it infers constraints by
    inspecting the types of the arguments to data constructors) from
    `inferConstraints` to handle the stock/newtype-specific bits.
    
    Aside from making the code somewhat clearer, this allows us to factor out
    superclass constraint inference, which is done regardless of deriving strategy.
    
    Test Plan: If it builds, ship it
    
    Reviewers: bgamari, austin
    
    Subscribers: rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3827


>---------------------------------------------------------------

a4f347c23ed926c24d178fec54c27d94f1fae0e4
 compiler/typecheck/TcDerivInfer.hs | 62 +++++++++++++++++++++++++-------------
 1 file changed, 41 insertions(+), 21 deletions(-)

diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index 515ae52..7d39c31 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -67,10 +67,43 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
 inferConstraints tvs main_cls cls_tys inst_ty
                  rep_tc rep_tc_args
                  mechanism
-  | is_generic && not is_anyclass          -- Generic constraints are easy
+  = do { (inferred_constraints, tvs', inst_tys') <- infer_constraints
+       ; traceTc "inferConstraints" $ vcat
+              [ ppr main_cls <+> ppr inst_tys'
+              , ppr inferred_constraints
+              ]
+       ; return ( sc_constraints ++ inferred_constraints
+                , tvs', inst_tys' ) }
+  where
+    is_anyclass = isDerivSpecAnyClass mechanism
+    infer_constraints
+      | is_anyclass = inferConstraintsDAC tvs main_cls inst_tys
+      | otherwise   = inferConstraintsDataConArgs tvs main_cls cls_tys inst_ty
+                                                  rep_tc rep_tc_args
+
+    inst_tys = cls_tys ++ [inst_ty]
+
+        -- Constraints arising from superclasses
+        -- See Note [Superclasses of derived instance]
+    cls_tvs  = classTyVars main_cls
+    sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
+                            , ppr main_cls <+> ppr inst_tys )
+                     [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
+                       substTheta cls_subst (classSCTheta main_cls) ]
+    cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+                zipTvSubst cls_tvs inst_tys
+
+-- | Like 'inferConstraints', but used only in the case of deriving strategies
+-- where the constraints are inferred by inspecting the fields of each data
+-- constructor (i.e., stock- and newtype-deriving).
+inferConstraintsDataConArgs
+  :: [TyVar] -> Class -> [TcType] -> TcType -> TyCon -> [TcType]
+  -> TcM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDataConArgs tvs main_cls cls_tys inst_ty rep_tc rep_tc_args
+  | is_generic                             -- Generic constraints are easy
   = return ([], tvs, inst_tys)
 
-  | is_generic1 && not is_anyclass         -- Generic1 needs Functor
+  | is_generic1                            -- Generic1 needs Functor
   = ASSERT( rep_tc_tvs `lengthExceeds` 0 ) -- See Note [Getting base classes]
     ASSERT( cls_tys `lengthIs` 1 )         -- Generic1 has a single kind variable
     do { functorClass <- tcLookupClass functorClassName
@@ -82,20 +115,15 @@ 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 )
-      do { (arg_constraints, tvs', inst_tys') <- infer_constraints
-         ; traceTc "inferConstraints" $ vcat
+      do { (arg_constraints, tvs', inst_tys')
+             <- con_arg_constraints get_std_constrained_tys
+         ; traceTc "inferConstraintsDataConArgs" $ vcat
                 [ ppr main_cls <+> ppr inst_tys'
                 , ppr arg_constraints
                 ]
-         ; return (stupid_constraints ++ extra_constraints
-                    ++ sc_constraints ++ arg_constraints
+         ; return ( stupid_constraints ++ extra_constraints ++ arg_constraints
                   , tvs', inst_tys') }
   where
-    is_anyclass = isDerivSpecAnyClass mechanism
-    infer_constraints
-      | is_anyclass = inferConstraintsDAC main_cls tvs inst_tys
-      | otherwise   = con_arg_constraints get_std_constrained_tys
-
     tc_binders = tyConBinders rep_tc
     choose_level bndr
       | isNamedTyConBinder bndr = KindLevel
@@ -187,15 +215,7 @@ inferConstraints tvs main_cls cls_tys inst_ty
     all_rep_tc_args = rep_tc_args ++ map mkTyVarTy
                                      (drop (length rep_tc_args) rep_tc_tvs)
 
-        -- Constraints arising from superclasses
-        -- See Note [Superclasses of derived instance]
-    cls_tvs  = classTyVars main_cls
     inst_tys = cls_tys ++ [inst_ty]
-    sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)
-                     [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
-                       substTheta cls_subst (classSCTheta main_cls) ]
-    cls_subst = ASSERT( equalLength cls_tvs inst_tys )
-                zipTvSubst cls_tvs inst_tys
 
         -- Stupid constraints
     stupid_constraints = [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
@@ -240,9 +260,9 @@ typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
 -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
 -- for an explanation of how these constraints are used to determine the
 -- derived instance context.
-inferConstraintsDAC :: Class -> [TyVar] -> [TcType]
+inferConstraintsDAC :: [TyVar] -> Class -> [TcType]
                     -> TcM ([ThetaOrigin], [TyVar], [TcType])
-inferConstraintsDAC cls tvs inst_tys
+inferConstraintsDAC tvs cls inst_tys
   = do { let gen_dms = [ (sel_id, dm_ty)
                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]