[commit: ghc] wip/T8584: Cosmetics (f424727)
git at git.haskell.org
git at git.haskell.org
Wed Nov 5 13:48:42 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8584
Link : http://ghc.haskell.org/trac/ghc/changeset/f4247275cd9d192e23a0af6f8272eba8bdf87c49/ghc
>---------------------------------------------------------------
commit f4247275cd9d192e23a0af6f8272eba8bdf87c49
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Wed Nov 5 21:47:08 2014 +0800
Cosmetics
>---------------------------------------------------------------
f4247275cd9d192e23a0af6f8272eba8bdf87c49
compiler/basicTypes/PatSyn.lhs | 27 ++++++++++++++-------------
compiler/iface/BuildTyCl.lhs | 23 ++++++++++-------------
compiler/iface/TcIface.lhs | 3 ++-
compiler/typecheck/TcPatSyn.lhs | 15 ++++++++-------
4 files changed, 34 insertions(+), 34 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 905a66e..3704265 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -49,9 +49,9 @@ tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id)
tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
psb_def = lpat, psb_dir = dir }
- = do { traceTc "tcPatSynDecl {" $ ppr name
+ = do { tcCheckPatSynPat lpat
+ ; traceTc "tcPatSynDecl {" $ ppr name
; pat_ty <- newFlexiTyVarTy openTypeKind
- ; tcCheckPatSynPat lpat
; let (arg_names, is_infix) = case details of
PrefixPatSyn names -> (map unLoc names, False)
@@ -91,9 +91,9 @@ tcInferPatSynDecl 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) }
@@ -109,7 +109,8 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
= setSrcSpan loc $
do { tcCheckPatSynPat lpat
- ; traceTc "tcCheckPatSynDecl" $
+ ; traceTc "tcCheckPatSynDecl {" $
+ ppr name $$
ppr (ex_tvs, prov_theta) $$
ppr (univ_tvs, req_theta) $$
ppr tau
@@ -160,9 +161,9 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
; traceTc "tcPatSynDecl }" $ ppr name
; let patSyn = mkPatSyn name is_infix
+ (univ_tvs, req_theta)
+ (ex_tvs, prov_theta)
arg_tys
- univ_tvs ex_tvs
- prov_theta req_theta
pat_ty
matcher_id wrapper_id
; return (patSyn, matcher_bind) }
More information about the ghc-commits
mailing list