[commit: ghc] wip/pattern-synonyms: Store IfExtNames for PatSyn matchers and wrappers in interface file (e0f47fe)
git at git.haskell.org
git at git.haskell.org
Sat Apr 12 10:52:01 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/pattern-synonyms
Link : http://ghc.haskell.org/trac/ghc/changeset/e0f47fe6346e7093cdba0b883bb3729dea93ca91/ghc
>---------------------------------------------------------------
commit e0f47fe6346e7093cdba0b883bb3729dea93ca91
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Sat Apr 12 18:46:35 2014 +0800
Store IfExtNames for PatSyn matchers and wrappers in interface file
>---------------------------------------------------------------
e0f47fe6346e7093cdba0b883bb3729dea93ca91
compiler/iface/IfaceSyn.lhs | 19 ++++++++++++-------
compiler/iface/MkIface.lhs | 6 +++++-
compiler/iface/TcIface.lhs | 9 ++++++---
3 files changed, 23 insertions(+), 11 deletions(-)
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 1283b09..534bb80 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -59,6 +59,7 @@ import HsBinds
import Control.Monad
import System.IO.Unsafe
+import Data.Maybe ( isJust )
infixl 3 &&&
\end{code}
@@ -120,8 +121,9 @@ data IfaceDecl
ifExtName :: Maybe FastString }
| IfacePatSyn { ifName :: OccName, -- Name of the pattern synonym
- ifPatHasWrapper :: Bool,
ifPatIsInfix :: Bool,
+ ifPatMatcher :: IfExtName,
+ ifPatWrapper :: Maybe IfExtName,
ifPatUnivTvs :: [IfaceTvBndr],
ifPatExTvs :: [IfaceTvBndr],
ifPatProvCtxt :: IfaceContext,
@@ -186,7 +188,7 @@ instance Binary IfaceDecl where
put_ bh a3
put_ bh a4
- put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do
+ put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
putByte bh 6
put_ bh (occNameFS name)
put_ bh a2
@@ -197,6 +199,7 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
get bh = do
h <- getByte bh
@@ -253,8 +256,9 @@ instance Binary IfaceDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
+ a10 <- get bh
occ <- return $! mkOccNameFS dataName a1
- return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9)
+ return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
data IfaceSynTyConRhs
@@ -1015,10 +1019,10 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
dc_occ = mkClassDataConOcc cls_tc_occ
is_newtype = n_sigs + n_ctxt == 1 -- Sigh
-ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper })
- = [wrap_occ | has_wrapper]
+ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatWrapper = wrapper_name })
+ = [wrap_occ | isJust wrapper_name]
where
- wrap_occ = mkDataConWrapperOcc ps_occ -- Id namespace
+ wrap_occ = mkDataConWrapperOcc ps_occ
ifaceDeclImplicitBndrs _ = []
@@ -1103,7 +1107,7 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branche
= hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
2 (vcat $ map (pprAxBranch $ Just tycon) branches)
-pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,
+pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
ifPatIsInfix = is_infix,
ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
@@ -1111,6 +1115,7 @@ pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,
ifPatTy = ty })
= pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
where
+ has_wrap = isJust wrapper
args' = case (is_infix, map snd args) of
(True, [left_ty, right_ty]) ->
InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index bb51cda..d504386 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1488,7 +1488,8 @@ dataConToIfaceDecl dataCon
patSynToIfaceDecl :: PatSyn -> IfaceDecl
patSynToIfaceDecl ps
= IfacePatSyn { ifName = getOccName . getName $ ps
- , ifPatHasWrapper = isJust $ patSynWrapper ps
+ , ifPatMatcher = matcher
+ , ifPatWrapper = wrapper
, ifPatIsInfix = patSynIsInfix ps
, ifPatUnivTvs = toIfaceTvBndrs univ_tvs'
, ifPatExTvs = toIfaceTvBndrs ex_tvs'
@@ -1507,6 +1508,9 @@ patSynToIfaceDecl ps
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
+ matcher = idName (patSynMatcher ps)
+ wrapper = fmap idName (patSynWrapper ps)
+
--------------------------
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index cc45648..31c2bf7 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -583,7 +583,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
- , ifPatHasWrapper = has_wrapper
+ , ifPatMatcher = matcher_name
+ , ifPatWrapper = wrapper_name
, ifPatIsInfix = is_infix
, ifPatUnivTvs = univ_tvs
, ifPatExTvs = ex_tvs
@@ -593,6 +594,8 @@ 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
+ ; wrapper <- maybe (return Nothing) (fmap Just . tcExt "Wrapper") wrapper_name
; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
{ bindIfaceTyVars ex_tvs $ \ex_tvs -> do
{ bindIfaceIdVars args $ \args -> do
@@ -602,11 +605,11 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
; pat_ty <- tcIfaceType pat_ty
; return (prov_theta, req_theta, pat_ty) }
; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do
- { patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
+ { patsyn <- buildPatSyn name is_infix (isJust wrapper) args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
; 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
tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
More information about the ghc-commits
mailing list