[commit: ghc] wip/pattern-synonyms: Store IfExtNames for PatSyn matchers and wrappers in interface file (bea2018)

git at git.haskell.org git at git.haskell.org
Fri Apr 18 14:24:23 UTC 2014


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/pattern-synonyms
Link       : http://ghc.haskell.org/trac/ghc/changeset/bea20186c67bacc794ef4b25d28874103365ca2f/ghc

>---------------------------------------------------------------

commit bea20186c67bacc794ef4b25d28874103365ca2f
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


>---------------------------------------------------------------

bea20186c67bacc794ef4b25d28874103365ca2f
 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 1283b09..2fd2eb2 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)
@@ -1392,6 +1397,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 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