diff options
author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-11-06 19:01:38 +0800 |
---|---|---|
committer | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-11-08 13:49:53 +0800 |
commit | 44362225235906c5cc76a7fd10deeb16534bac58 (patch) | |
tree | d3f362424ff707d25c7bff5fdcf750e58f341cc9 | |
parent | 65f32aed54fb9a0ff2afb953eb17c9b2603ce8f9 (diff) | |
download | haskell-wip/T9783.tar.gz |
Group PatSyn req/prov arguments together so that they're not all over the placewip/T9783
-rw-r--r-- | compiler/basicTypes/PatSyn.lhs | 27 | ||||
-rw-r--r-- | compiler/iface/BuildTyCl.lhs | 23 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 3 | ||||
-rw-r--r-- | 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 9cc7c39abf..89c4374388 100644 --- a/compiler/basicTypes/PatSyn.lhs +++ b/compiler/basicTypes/PatSyn.lhs @@ -128,9 +128,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] @@ -207,19 +207,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 2a66de28ac..d90e63c972 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 4e2cfd5a76..65345ec3c8 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 7dd2e33fd4..ea2dbce9d7 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -107,9 +107,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) } |