[commit: ghc] wip/T8584: PatSynSig: Add type variable binders (941c6d4)

git at git.haskell.org git at git.haskell.org
Wed Jul 30 08:14:32 UTC 2014


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

On branch  : wip/T8584
Link       : http://ghc.haskell.org/trac/ghc/changeset/941c6d48fed69e93c46dbefa892ca23eb99a99d5/ghc

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

commit 941c6d48fed69e93c46dbefa892ca23eb99a99d5
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Mon Jul 21 19:40:34 2014 +0800

    PatSynSig: Add type variable binders


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

941c6d48fed69e93c46dbefa892ca23eb99a99d5
 compiler/hsSyn/HsBinds.lhs   |  8 ++++----
 compiler/hsSyn/HsTypes.lhs   | 19 +++++++++++++------
 compiler/parser/RdrHsSyn.lhs | 10 ++++++----
 compiler/rename/RnBinds.lhs  | 17 +++++++++--------
 4 files changed, 32 insertions(+), 22 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index a90ea66..673a269 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -549,12 +549,12 @@ data Sig name
     TypeSig [Located name] (LHsType name)
 
       -- | A pattern synonym type signature
-      -- @pattern (Eq b) => P a b :: (Num a) => T a
+      -- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
   | PatSynSig (Located name)
               (HsPatSynDetails (LHsType name))
               (LHsType name)    -- Type
-              (LHsContext name) -- Provided context
-              (LHsContext name) -- Required contex
+              (HsExplicitFlag, LHsTyVarBndrs name, LHsContext name) -- Provided context
+              (HsExplicitFlag, LHsTyVarBndrs name, LHsContext name) -- Required contex
 
         -- | A type signature for a default method inside a class
         --
@@ -710,7 +710,7 @@ ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) i
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
-ppr_sig (PatSynSig name arg_tys ty prov req)
+ppr_sig (PatSynSig name arg_tys ty (_, _, prov) (_, _, req))
   = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
   where
     args = fmap ppr arg_tys
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 52b919e..bb5694c 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -31,7 +31,7 @@ module HsTypes (
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
         splitLHsInstDeclTy_maybe,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
-        splitHsFunType, splitLHsForAllTy,
+        splitHsFunType, splitLHsForAllTyFlag, splitLHsForAllTy,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
 
         -- Printing
@@ -476,15 +476,22 @@ splitLHsInstDeclTy_maybe inst_ty = do
     (cls, tys) <- splitLHsClassTy_maybe ty
     return (tvs, cxt, cls, tys)
 
+splitLHsForAllTyFlag
+    :: LHsType name
+    -> (HsExplicitFlag, LHsTyVarBndrs name, HsContext name, LHsType name)
+splitLHsForAllTyFlag poly_ty
+  = case unLoc poly_ty of
+        HsParTy ty                 -> splitLHsForAllTyFlag ty
+        HsForAllTy flag tvs cxt ty -> (flag, tvs, unLoc cxt, ty)
+        _                          -> (Implicit, emptyHsQTvs, [], poly_ty)
+        -- The type vars should have been computed by now, even if they were implicit
+
 splitLHsForAllTy
     :: LHsType name 
     -> (LHsTyVarBndrs name, HsContext name, LHsType name)
 splitLHsForAllTy poly_ty
-  = case unLoc poly_ty of
-        HsParTy ty              -> splitLHsForAllTy ty
-        HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                       -> (emptyHsQTvs, [], poly_ty)
-        -- The type vars should have been computed by now, even if they were implicit
+  = let (_, tvs, cxt, ty) = splitLHsForAllTyFlag poly_ty
+    in (tvs, cxt, ty)
 
 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
 splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index c6ddc7d..fdf6c23 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -491,7 +491,9 @@ toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
 -- and (Eq a) and (Num b) as the provided and required thetas (respectively)
 splitPatSynSig :: LHsType RdrName
       -> LHsType RdrName
-      -> P (Located RdrName, HsPatSynDetails (LHsType RdrName), LHsType RdrName, LHsContext RdrName, LHsContext RdrName)
+      -> P (Located RdrName, HsPatSynDetails (LHsType RdrName), LHsType RdrName,
+            (HsExplicitFlag, LHsTyVarBndrs RdrName, LHsContext RdrName),
+            (HsExplicitFlag, LHsTyVarBndrs RdrName, LHsContext RdrName))
 splitPatSynSig lty1 lty2 = do
     (name, details) <- splitCon pat_ty
     details' <- case details of
@@ -499,10 +501,10 @@ splitPatSynSig lty1 lty2 = do
         InfixCon ty1 ty2 -> return $ InfixPatSyn ty1 ty2
         RecCon{}         -> parseErrorSDoc (getLoc lty1) $
                               text "record syntax not supported for pattern synonym declarations:" $$ ppr lty1
-    return (name, details', res_ty, prov', req')
+    return (name, details', res_ty, (ex_flag, ex_tvs, prov'), (univ_flag, univ_tvs, req'))
   where
-    (_, prov, pat_ty) = splitLHsForAllTy lty1
-    (_, req, res_ty) = splitLHsForAllTy lty2
+    (ex_flag, ex_tvs, prov, pat_ty) = splitLHsForAllTyFlag lty1
+    (univ_flag, univ_tvs, req, res_ty) = splitLHsForAllTyFlag lty2
     prov' = L (getLoc lty1) prov
     req' = L (getLoc lty2) req
 
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 807a05c..f649e27 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -831,15 +831,15 @@ renameSig ctxt sig@(MinimalSig bf)
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
        return (MinimalSig new_bf, emptyFVs)
 
-renameSig ctxt sig@(PatSynSig v args ty prov req)
+renameSig ctxt sig@(PatSynSig v args ty (ex_flag, _ex_tvs, prov) (univ_flag, _univ_tvs, req))
   = do	{ v' <- lookupSigOccRn ctxt sig v
         ; let doc = TypeSigCtx $ quotes (ppr v)
         ; loc <- getSrcSpanM
 
-        ; let (ty_kvs, ty_tvs) = extractHsTysRdrTyVars (ty:unLoc req)
-        ; let ty_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ ty_tvs
+        ; let (univ_kvs, univ_tvs) = extractHsTysRdrTyVars (ty:unLoc req)
+        ; let univ_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ univ_tvs
 
-        ; bindHsTyVars doc Nothing ty_kvs ty_tv_bndrs $ \ _new_tyvars -> do
+        ; bindHsTyVars doc Nothing univ_kvs univ_tv_bndrs $ \ univ_tyvars -> do
         { (req', fvs1) <- rnContext doc req
         ; (ty', fvs2) <- rnLHsType doc ty
 
@@ -855,14 +855,15 @@ renameSig ctxt sig@(PatSynSig v args ty prov req)
                               (ty2', fvs2) <- rnLHsType doc ty2
                               return (InfixPatSyn ty1' ty2', fvs1 `plusFV` fvs2)
                       in ([ty1, ty2], rnArgs)
-        ; let (arg_kvs, arg_tvs) = extractHsTysRdrTyVars (arg_tys ++ unLoc prov)
-        ; let arg_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ arg_tvs
+        ; let (ex_kvs, ex_tvs) = extractHsTysRdrTyVars (arg_tys ++ unLoc prov)
+        ; let ex_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ ex_tvs
 
-        ; bindHsTyVars doc Nothing arg_kvs arg_tv_bndrs $ \ _new_tyvars -> do
+        ; bindHsTyVars doc Nothing ex_kvs ex_tv_bndrs $ \ ex_tyvars -> do
         { (prov', fvs3) <- rnContext doc prov
         ; (args', fvs4) <- rnArgs
 
-        ; return (PatSynSig v' args' ty' prov' req', plusFVs [fvs1, fvs2, fvs3, fvs4]) }}}
+        ; return (PatSynSig v' args' ty' (ex_flag, ex_tyvars, prov') (univ_flag, univ_tyvars, req'),
+                  plusFVs [fvs1, fvs2, fvs3, fvs4]) }}}
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)



More information about the ghc-commits mailing list