Commit 65dc594b authored by cactus's avatar cactus

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

parent 474e535b
......@@ -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,
......
......@@ -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}
......
......@@ -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
......
......@@ -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) }
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment