[commit: ghc] wip/T9732: Group PatSyn req/prov arguments together so that they're not all over the place (f2c683c)

[git at git.haskell.org]

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

On branch  : wip/T9732
Link       : http://ghc.haskell.org/trac/ghc/changeset/f2c683c8719d24ba16846245978ef1e980e27bca/ghc

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

commit f2c683c8719d24ba16846245978ef1e980e27bca
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Thu Nov 6 19:01:38 2014 +0800

    Group PatSyn req/prov arguments together so that they're not all over the place


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

f2c683c8719d24ba16846245978ef1e980e27bca
 compiler/basicTypes/PatSyn.lhs  | 27 ++++++++++++++-------------
 compiler/iface/BuildTyCl.lhs    | 23 ++++++++++-------------
 compiler/iface/TcIface.lhs      |  3 ++-
 compiler/typecheck/TcPatSyn.lhs |  4 ++--
 4 files changed, 28 insertions(+), 29 deletions(-)

diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 2081b5a..9efd69d 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -123,9 +123,9 @@ data PatSyn
         psInfix       :: Bool,        -- True <=> declared infix
 
         psUnivTyVars  :: [TyVar],     -- Universially-quantified type variables
+        psReqTheta    :: ThetaType,   -- Required dictionaries
         psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
         psProvTheta   :: ThetaType,   -- Provided dictionaries
-        psReqTheta    :: ThetaType,   -- Required dictionaries
         psOrigResTy   :: Type,        -- Mentions only psUnivTyVars
 
         -- See Note [Matchers and wrappers for pattern synonyms]
@@ -194,19 +194,20 @@ instance Data.Data PatSyn where
 \begin{code}
 -- | Build a new pattern synonym
 mkPatSyn :: Name
-         -> Bool       -- ^ Is the pattern synonym declared infix?
-         -> [Type]     -- ^ Original arguments
-         -> [TyVar]    -- ^ Universially-quantified type variables
-         -> [TyVar]    -- ^ Existentially-quantified type variables
-         -> ThetaType  -- ^ Wanted dicts
-         -> ThetaType  -- ^ Given dicts
-         -> Type       -- ^ Original result type
-         -> Id         -- ^ Name of matcher
-         -> Maybe Id   -- ^ Name of wrapper
+         -> Bool                 -- ^ Is the pattern synonym declared infix?
+         -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
+                                --   and required dicts
+         -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
+                                --   and provided dicts
+         -> [Type]               -- ^ Original arguments
+         -> Type                 -- ^ Original result type
+         -> Id                   -- ^ Name of matcher
+         -> Maybe Id             -- ^ Name of wrapper
          -> PatSyn
-mkPatSyn name declared_infix orig_args
-         univ_tvs ex_tvs
-         prov_theta req_theta
+mkPatSyn name declared_infix
+         (univ_tvs, req_theta)
+         (ex_tvs, prov_theta)
+         orig_args
          orig_res_ty
          matcher wrapper
     = MkPatSyn {psName = name, psUnique = getUnique name,
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 2a66de2..d90e63c 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -180,32 +180,29 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
             -> Id -> Maybe Id
-            -> [Type]
-            -> [TyVar] -> [TyVar]     -- Univ and ext
-            -> ThetaType -> ThetaType -- Prov and req
-            -> Type                  -- Result type
+            -> ([TyVar], ThetaType) -- ^ Univ and req
+            -> ([TyVar], ThetaType) -- ^ Ex and prov
+            -> [Type]               -- ^ Argument types
+            -> Type                 -- ^ Result type
             -> PatSyn
 buildPatSyn src_name declared_infix matcher wrapper
-            args univ_tvs ex_tvs prov_theta req_theta pat_ty
+            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty
   = ASSERT((and [ univ_tvs == univ_tvs'
                 , ex_tvs == ex_tvs'
                 , pat_ty `eqType` pat_ty'
                 , prov_theta `eqTypes` prov_theta'
                 , req_theta `eqTypes` req_theta'
-                , args `eqTypes` args'
+                , arg_tys `eqTypes` arg_tys'
                 ]))
     mkPatSyn src_name declared_infix
-             args
-             univ_tvs ex_tvs
-             prov_theta req_theta
-             pat_ty
-             matcher
-             wrapper
+             (univ_tvs, req_theta) (ex_tvs, prov_theta)
+             arg_tys pat_ty
+             matcher wrapper
   where
     ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher
     ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
     (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
-    (args', _) = tcSplitFunTys cont_tau
+    (arg_tys', _) = tcSplitFunTys cont_tau
 \end{code}
 
 
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 424a46c..9dd5864 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -605,7 +605,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
                 ; return $ buildPatSyn name is_infix matcher wrapper
-                                       arg_tys univ_tvs ex_tvs prov_theta req_theta pat_ty }
+                                       (univ_tvs, req_theta) (ex_tvs, prov_theta)
+                                       arg_tys pat_ty }
        ; return $ AConLike . PatSynCon $ patsyn }}}
   where
      mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index e2334d0..398acca 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -103,9 +103,9 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
 
        ; traceTc "tcPatSynDecl }" $ ppr name
        ; let patSyn = mkPatSyn name is_infix
+                        (univ_tvs, req_theta)
+                        (ex_tvs, prov_theta)
                         (map varType args)
-                        univ_tvs ex_tvs
-                        prov_theta req_theta
                         pat_ty
                         matcher_id wrapper_id
        ; return (patSyn, matcher_bind) }