[commit: ghc] wip/pattern-synonyms: Fold mkPatSyn{Matcher, Wrapper}Id into TcPatSyn (fac9054)
git at git.haskell.org
git at git.haskell.org
Sun May 25 07:22:50 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/pattern-synonyms
Link : http://ghc.haskell.org/trac/ghc/changeset/fac9054210a2ce4a51f987d667d8744d130fd8a7/ghc
>---------------------------------------------------------------
commit fac9054210a2ce4a51f987d667d8744d130fd8a7
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Fri Apr 18 19:50:04 2014 +0800
Fold mkPatSyn{Matcher,Wrapper}Id into TcPatSyn
>---------------------------------------------------------------
fac9054210a2ce4a51f987d667d8744d130fd8a7
compiler/iface/BuildTyCl.lhs | 56 ++++-------------------------------------
compiler/iface/TcIface.lhs | 7 +++---
compiler/typecheck/TcPatSyn.lhs | 30 ++++++++++++----------
3 files changed, 25 insertions(+), 68 deletions(-)
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index d0e3232..0d6fb43 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -16,7 +16,7 @@ module BuildTyCl (
buildSynTyCon,
buildAlgTyCon,
buildDataCon,
- buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId,
+ buildPatSyn,
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs,
@@ -37,8 +37,6 @@ import MkId
import Class
import TyCon
import Type
-import TypeRep
-import TcType
import Id
import Coercion
@@ -185,24 +183,15 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
-buildPatSyn :: Name -> Bool -> Bool
+buildPatSyn :: Name -> Bool
+ -> Id -> Maybe Id
-> [Var]
-> [TyVar] -> [TyVar] -- Univ and ext
-> ThetaType -> ThetaType -- Prov and req
-> Type -- Result type
- -> TyVar
-> TcRnIf m n PatSyn
-buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
- = do { (matcher, _, _) <- mkPatSynMatcherId src_name args
- univ_tvs ex_tvs
- prov_theta req_theta
- pat_ty tv
- ; wrapper <- case has_wrapper of
- False -> return Nothing
- True -> fmap Just $
- mkPatSynWrapperId src_name args
- (univ_tvs ++ ex_tvs) (prov_theta ++ req_theta)
- pat_ty
+buildPatSyn src_name declared_infix matcher wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty
+ = do { pprTrace "buildPatSyn: matcher:" (ppr (idType matcher)) $ return ()
; return $ mkPatSyn src_name declared_infix
args
univ_tvs ex_tvs
@@ -211,41 +200,6 @@ buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta
matcher
wrapper }
-mkPatSynMatcherId :: Name
- -> [Var]
- -> [TyVar]
- -> [TyVar]
- -> ThetaType -> ThetaType
- -> Type
- -> TyVar
- -> TcRnIf n m (Id, Type, Type)
-mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv
- = do { matcher_name <- newImplicitBinder name mkMatcherOcc
-
- ; let res_ty = TyVarTy res_tv
- cont_ty = mkSigmaTy ex_tvs prov_theta $
- mkFunTys (map varType args) res_ty
-
- ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
- matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
- matcher_id = mkVanillaGlobal matcher_name matcher_sigma
- ; return (matcher_id, res_ty, cont_ty) }
-
-mkPatSynWrapperId :: Name
- -> [Var]
- -> [TyVar]
- -> ThetaType
- -> Type
- -> TcRnIf n m Id
-mkPatSynWrapperId name args qtvs theta pat_ty
- = do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-
- ; let wrapper_tau = mkFunTys (map varType args) pat_ty
- wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau
-
- ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
- ; return wrapper_id }
-
\end{code}
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 85a2c7d..06f402d 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -595,7 +595,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
, ifPatTy = pat_ty })
= do { name <- lookupIfaceTop occ_name
; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
- ; _matcher <- tcExt "Matcher" matcher_name
+ ; matcher <- tcExt "Matcher" matcher_name
; wrapper <- maybe (return Nothing) (fmap Just . tcExt "Wrapper") wrapper_name
; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
{ bindIfaceTyVars ex_tvs $ \ex_tvs -> do
@@ -605,9 +605,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; return (prov_theta, req_theta, pat_ty) }
- ; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do
- { patsyn <- buildPatSyn name is_infix (isJust wrapper) args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
- ; return (AConLike (PatSynCon patsyn)) }}}}}
+ ; patsyn <- buildPatSyn name is_infix matcher wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty
+ ; return (AConLike (PatSynCon patsyn)) }}}}
where
mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 7c9f876..30b18c7 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -33,6 +33,7 @@ import Data.Monoid
import Bag
import TcEvidence
import BuildTyCl
+import TypeRep
#include "HsVersions.h"
\end{code}
@@ -176,10 +177,15 @@ tcPatSynMatcher :: Located Name
-> TcM (Id, LHsBinds Id)
tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
= do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
- ; (matcher_id, res_ty, cont_ty) <- mkPatSynMatcherId name args
- univ_tvs ex_tvs
- prov_theta req_theta
- pat_ty res_tv
+ ; matcher_name <- newImplicitBinder name mkMatcherOcc
+ ; let res_ty = TyVarTy res_tv
+ cont_ty = mkSigmaTy ex_tvs prov_theta $
+ mkFunTys (map varType args) res_ty
+
+ ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
+ matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
+ matcher_id = mkVanillaGlobal matcher_name matcher_sigma
+
; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
; let matcher_lid = L loc matcher_id
@@ -262,18 +268,16 @@ tc_pat_syn_wrapper_from_expr :: Located Name
-> TcM (Id, LHsBinds Id)
tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty
= do { let qtvs = univ_tvs ++ ex_tvs
- ; (subst, qtvs') <- tcInstSkolTyVars qtvs
- ; let theta' = substTheta subst theta
+ ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs
+ ; let wrapper_theta = substTheta subst theta
pat_ty' = substTy subst pat_ty
args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args
-
- ; wrapper_id <- mkPatSynWrapperId name args qtvs theta pat_ty
- ; let wrapper_name = getName wrapper_id
- wrapper_lname = L loc wrapper_name
- -- (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id)
- wrapper_tvs = qtvs'
- wrapper_theta = theta'
wrapper_tau = mkFunTys (map varType args') pat_ty'
+ wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
+
+ ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
+ ; let wrapper_lname = L loc wrapper_name
+ wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
More information about the ghc-commits
mailing list