[commit: ghc] wip/T8584: Add TcPatSynInfo as a separate type (same pattern as PatSynBind being a separate type) (4288b32)
git at git.haskell.org
git at git.haskell.org
Thu Oct 16 14:24:15 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8584
Link : http://ghc.haskell.org/trac/ghc/changeset/4288b327f66cb8d8764e26f81101645a331efe8a/ghc
>---------------------------------------------------------------
commit 4288b327f66cb8d8764e26f81101645a331efe8a
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Sun Aug 31 19:04:17 2014 +0800
Add TcPatSynInfo as a separate type (same pattern as PatSynBind being a separate type)
>---------------------------------------------------------------
4288b327f66cb8d8764e26f81101645a331efe8a
compiler/typecheck/TcBinds.lhs | 19 ++++++++++---------
compiler/typecheck/TcPat.lhs | 22 ++++++++++++++++------
compiler/typecheck/TcPatSyn.lhs | 11 ++++++-----
compiler/typecheck/TcPatSyn.lhs-boot | 6 ++----
4 files changed, 34 insertions(+), 24 deletions(-)
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index e92c1ec..5e5e17b 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -431,11 +431,9 @@ tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb at PSB{ psb_id = L _ name }
}
where
tc_pat_syn_decl = case sig_fn name of
- Nothing ->
- tcInferPatSynDecl psb
- Just TcPatSynInfo{ patsig_tau = tau, patsig_prov = prov, patsig_req = req } ->
- tcCheckPatSynDecl psb tau prov req
- Just _ -> panic "tc_single"
+ Nothing -> tcInferPatSynDecl psb
+ Just (TcPatSynInfo tpsi) -> tcCheckPatSynDecl psb tpsi
+ Just _ -> panic "tc_single"
tc_single top_lvl sig_fn prag_fn lbind thing_inside
= do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
@@ -1319,10 +1317,13 @@ tcTySig (L loc (PatSynSig (L _ name) args ty (_, ex_tvs, prov) (_, univ_tvs, req
InfixPatSyn ty1 ty2 -> [ty1, ty2]
; prov' <- tcHsContext prov
; traceTc "tcTySig" $ ppr ty' $$ ppr args' $$ ppr (ex_tvs', prov') $$ ppr (univ_tvs', req')
- ; return [TcPatSynInfo{ patsig_name = name,
- patsig_tau = mkFunTys args' ty',
- patsig_prov = (ex_tvs', prov'),
- patsig_req = (univ_tvs', req') }]}}}
+ ; let tpsi = TPSI{ patsig_name = name,
+ patsig_tau = mkFunTys args' ty',
+ patsig_ex = ex_tvs',
+ patsig_prov = prov',
+ patsig_univ = univ_tvs',
+ patsig_req = req' }
+ ; return [TcPatSynInfo tpsi]}}}
tcTySig _ = return []
instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index c044e31..7ca4fdb 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -15,7 +15,8 @@ TcPat: Typechecking patterns
-- for details
module TcPat ( tcLetPat, TcSigFun, TcPragFun
- , TcSigInfo(..), findScopedTyVars
+ , TcSigInfo(..), TcPatSynInfo(..)
+ , findScopedTyVars
, LetBndrSpec(..), addInlinePrags, warnPrags
, tcPat, tcPats, newNoSigLetBndr
, addDataConStupidTheta, badFieldCon, polyPatSig ) where
@@ -158,11 +159,16 @@ data TcSigInfo
sig_loc :: SrcSpan -- The location of the signature
}
- | TcPatSynInfo {
+ | TcPatSynInfo TcPatSynInfo
+
+data TcPatSynInfo
+ = TPSI {
patsig_name :: Name,
patsig_tau :: TcSigmaType,
- patsig_prov :: ([TcTyVar], TcThetaType),
- patsig_req :: ([TcTyVar], TcThetaType)
+ patsig_ex :: [TcTyVar],
+ patsig_prov :: TcThetaType,
+ patsig_univ :: [TcTyVar],
+ patsig_req :: TcThetaType
}
findScopedTyVars -- See Note [Binding scoped type variables]
@@ -185,13 +191,17 @@ findScopedTyVars hs_ty sig_ty inst_tvs
instance NamedThing TcSigInfo where
getName TcSigInfo{ sig_id = id } = idName id
- getName TcPatSynInfo { patsig_name = name } = name
+ getName (TcPatSynInfo tpsi) = patsig_name tpsi
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
= ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
, ppr (map fst tyvars) ]
- ppr (TcPatSynInfo { patsig_name = name}) = text "TcPatSynInfo" <+> ppr name
+ ppr (TcPatSynInfo tpsi) = text "TcPatSynInfo" <+> ppr tpsi
+
+instance Outputable TcPatSynInfo where
+ ppr (TPSI{ patsig_name = name}) = ppr name
+
\end{code}
Note [Binding scoped type variables]
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 3ae6303..e60cfb6 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -92,14 +92,15 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
; return (patSyn, matcher_bind) }
tcCheckPatSynDecl :: PatSynBind Name Name
- -> TcType
- -> ([TyVar], ThetaType) -> ([TyVar], ThetaType)
+ -> TcPatSynInfo
-> TcM (PatSyn, LHsBinds Id)
tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
psb_def = lpat, psb_dir = dir }
- tau (ex_tvs, prov_theta) (univ_tvs, req_theta)
- = do { tcCheckPatSynPat lpat
-
+ TPSI{ patsig_tau = tau,
+ patsig_ex = ex_tvs, patsig_univ = univ_tvs,
+ patsig_prov = prov_theta, patsig_req = req_theta }
+ = setSrcSpan loc $
+ do { tcCheckPatSynPat lpat
; prov_dicts <- newEvVars prov_theta
; req_dicts <- newEvVars req_theta
diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot
index 2129c33..1b2356a 100644
--- a/compiler/typecheck/TcPatSyn.lhs-boot
+++ b/compiler/typecheck/TcPatSyn.lhs-boot
@@ -6,15 +6,13 @@ import Id ( Id )
import HsSyn ( PatSynBind, LHsBinds )
import TcRnTypes ( TcM )
import PatSyn ( PatSyn )
-import TcType ( TcType, ThetaType )
-import Var ( TyVar )
+import TcPat ( TcPatSynInfo )
tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id)
tcCheckPatSynDecl :: PatSynBind Name Name
- -> TcType
- -> ([TyVar], ThetaType) -> ([TyVar], ThetaType)
+ -> TcPatSynInfo
-> TcM (PatSyn, LHsBinds Id)
tcPatSynWrapper :: PatSynBind Name Name
More information about the ghc-commits
mailing list