[commit: ghc] wip/pattern-synonyms: Store IfExtNames for PatSyn matchers and wrappers in interface file (005b078)
git at git.haskell.org
git at git.haskell.org
Sun May 25 07:22:45 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/pattern-synonyms
Link : http://ghc.haskell.org/trac/ghc/changeset/005b0788f6f5e37b364481fc61b7e93c9fa4670e/ghc
>---------------------------------------------------------------
commit 005b0788f6f5e37b364481fc61b7e93c9fa4670e
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Fri Apr 18 19:21:37 2014 +0800
Store IfExtNames for PatSyn matchers and wrappers in interface file
>---------------------------------------------------------------
005b0788f6f5e37b364481fc61b7e93c9fa4670e
compiler/iface/IfaceSyn.lhs | 21 ++++++++++++++-------
compiler/iface/MkIface.lhs | 6 +++++-
compiler/iface/TcIface.lhs | 9 ++++++---
3 files changed, 25 insertions(+), 11 deletions(-)
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index fb194e0..ec4fbea 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -60,6 +60,7 @@ import HsBinds
import Control.Monad
import System.IO.Unsafe
+import Data.Maybe ( isJust )
infixl 3 &&&
\end{code}
@@ -121,8 +122,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,
@@ -187,7 +189,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
@@ -198,6 +200,7 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
get bh = do
h <- getByte bh
@@ -254,8 +257,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
@@ -1016,10 +1020,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 _ = []
@@ -1104,7 +1108,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,
@@ -1112,6 +1116,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)
@@ -1393,6 +1398,8 @@ freeNamesIfDecl d at IfaceAxiom{} =
freeNamesIfTc (ifTyCon d) &&&
fnList freeNamesIfAxBranch (ifAxBranches d)
freeNamesIfDecl d at IfacePatSyn{} =
+ unitNameSet (ifPatMatcher d) &&&
+ maybe emptyNameSet unitNameSet (ifPatWrapper d) &&&
freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
freeNamesIfTvBndrs (ifPatExTvs d) &&&
freeNamesIfContext (ifPatProvCtxt d) &&&
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 6c87961..4a26906 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1490,7 +1490,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'
@@ -1509,6 +1510,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 980796a..85a2c7d 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -584,7 +584,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
@@ -594,6 +595,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
@@ -603,11 +606,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