[commit: ghc] wip/pattern-synonyms: Fold mkPatSyn{Matcher, Wrapper}Id into TcPatSyn (d316f45)

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


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

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

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

commit d316f454a6a81753469301ea9523eddd16904877
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Fri Apr 18 19:50:04 2014 +0800

    Fold mkPatSyn{Matcher,Wrapper}Id into TcPatSyn


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

d316f454a6a81753469301ea9523eddd16904877
 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 e412d7e..ba59939 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -15,7 +15,7 @@ module BuildTyCl (
         buildSynTyCon,
         buildAlgTyCon, 
         buildDataCon,
-        buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId,
+        buildPatSyn,
         TcMethInfo, buildClass,
         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
         mkNewTyConRhs, mkDataTyConRhs, 
@@ -36,8 +36,6 @@ import MkId
 import Class
 import TyCon
 import Type
-import TypeRep
-import TcType
 import Id
 import Coercion
 
@@ -184,24 +182,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
@@ -210,41 +199,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 31c2bf7..4d3f4af 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -594,7 +594,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
@@ -604,9 +604,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 0b3b4e4..2337ccf 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -31,6 +31,7 @@ import Data.Monoid
 import Bag
 import TcEvidence
 import BuildTyCl
+import TypeRep
 
 #include "HsVersions.h"
 \end{code}
@@ -174,10 +175,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
 
@@ -260,18 +266,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