[commit: ghc] wip/pattern-synonym-backport: Group PatSyn req/prov arguments together so that they're not all over the place (125d4a5)

[git at git.haskell.org]

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

On branch  : wip/pattern-synonym-backport
Link       : http://ghc.haskell.org/trac/ghc/changeset/125d4a5300ec1fa049fab296bc364ff51cbff106/ghc

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

commit 125d4a5300ec1fa049fab296bc364ff51cbff106
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
    
    (cherry picked from commit 65dc594b156c9cc5c2e9bc640f0762beaf3ca6ca)


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

125d4a5300ec1fa049fab296bc364ff51cbff106
 compiler/basicTypes/PatSyn.lhs  | 27 ++++++++++++++-------------
 compiler/iface/BuildTyCl.lhs    | 38 ++++++++++++++++++++------------------
 compiler/iface/TcIface.lhs      |  3 ++-
 compiler/typecheck/TcPatSyn.lhs |  4 ++--
 4 files changed, 38 insertions(+), 34 deletions(-)

diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index e679fdd..528b95a 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -127,9 +127,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]
@@ -206,19 +206,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 fa46a73..31be15b 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -185,27 +185,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
-  = 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
+  = 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'
+                , arg_tys `eqTypes` arg_tys'
+                ]))
+    mkPatSyn src_name declared_infix
+             (univ_tvs, req_theta) (ex_tvs, prov_theta)
+             arg_tys pat_ty
+             matcher wrapper
   where
-    -- TODO: assert that these match the ones in the parameters
-    ((_:_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
-
+    ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher
+    ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
+    (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
+    (arg_tys', _) = tcSplitFunTys cont_tau
 \end{code}
 
 
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 398ae4e..873fdc1 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -608,7 +608,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 17fe40b..55ec6b7 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -98,9 +98,9 @@ tcPatSynDecl lname@(L _ name) details lpat dir
 
        ; 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 (fmap fst m_wrapper)
        ; return (patSyn, binds) }