[commit: ghc] wip/T8584: PatSynSig: Add type variable binders (3defd32)
git at git.haskell.org
git at git.haskell.org
Sun Aug 31 11:05:59 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8584
Link : http://ghc.haskell.org/trac/ghc/changeset/3defd32e5f56eebf6b9637f438b2d30cfca64201/ghc
>---------------------------------------------------------------
commit 3defd32e5f56eebf6b9637f438b2d30cfca64201
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Mon Jul 21 19:40:34 2014 +0800
PatSynSig: Add type variable binders
>---------------------------------------------------------------
3defd32e5f56eebf6b9637f438b2d30cfca64201
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 14837f6..9777e0d 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
@@ -485,15 +485,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 0d72cb1..2abcb08 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