[commit: ghc] wip/T8584: Add parser for pattern synonym type signatures. Syntax is of the form (893f1b0)
git at git.haskell.org
git at git.haskell.org
Sat Nov 8 08:53:47 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8584
Link : http://ghc.haskell.org/trac/ghc/changeset/893f1b0565439837069a0fe9055b1c3aadd805f5/ghc
>---------------------------------------------------------------
commit 893f1b0565439837069a0fe9055b1c3aadd805f5
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Mon Jul 14 18:18:44 2014 +0800
Add parser for pattern synonym type signatures.
Syntax is of the form
pattern type Eq a => P a T b :: Num b => R a b
which declares a pattern synonym called P, with argument types a, T, and b.
>---------------------------------------------------------------
893f1b0565439837069a0fe9055b1c3aadd805f5
compiler/hsSyn/HsBinds.lhs | 1 +
compiler/hsSyn/HsTypes.lhs | 19 +++++++++++++------
compiler/parser/Parser.y | 6 ++++++
compiler/parser/RdrHsSyn.hs | 31 ++++++++++++++++++++++++++++++-
4 files changed, 50 insertions(+), 7 deletions(-)
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 23534cf..f75fa2e 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -743,6 +743,7 @@ pprPatSynSig :: (OutputableBndr a)
=> a -> Bool -> HsPatSynDetails SDoc -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc
pprPatSynSig ident is_bidir args rhs_ty prov_theta req_theta
= sep [ ptext (sLit "pattern")
+ , ptext (sLit "type")
, thetaOpt prov_theta, name_and_args
, colon
, thetaOpt req_theta, rhs_ty
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 9bd5845..db4d976 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -39,7 +39,7 @@ module HsTypes (
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitLHsInstDeclTy_maybe,
splitHsClassTy_maybe, splitLHsClassTy_maybe,
- splitHsFunType,
+ splitHsFunType, splitLHsForAllTyFlag, splitLHsForAllTy,
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-- Printing
@@ -510,15 +510,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/Parser.y b/compiler/parser/Parser.y
index 1123375..ea752cf 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -879,6 +879,11 @@ where_decls :: { Located (OrdList (LHsDecl RdrName)) }
: 'where' '{' decls '}' { $3 }
| 'where' vocurly decls close { $3 }
+pattern_synonym_sig :: { LSig RdrName }
+ : 'pattern' 'type' ctype '::' ctype
+ {% do { (name, details, ty, prov, req) <- splitPatSynSig $3 $5
+ ; return $ sLL $1 $> $ PatSynSig name details ty prov req }}
+
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
| varid vars0 { $1 : $2 }
@@ -1490,6 +1495,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
{ sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
| infix prec ops { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
+ | pattern_synonym_sig { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
| '{-# INLINE' activation qvar '#-}'
{ sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 625c4dc..15490c3 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -18,7 +18,7 @@ module RdrHsSyn (
mkTyFamInst,
mkFamDecl,
splitCon, mkInlinePragma,
- splitPatSyn, toPatSynMatchGroup,
+ splitPatSyn, splitPatSynSig, toPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkTyClD, mkInstD,
@@ -464,6 +464,35 @@ toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
quotes (ppr patsyn_name) $$ ppr decl
+-- Given two types like
+-- Eq a => P a T b
+-- and
+-- Num b => R a b
+--
+-- This returns
+-- P as the name,
+-- PrefixPatSyn [a, T, b] as the details,
+-- R a b as the result type,
+-- 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,
+ (HsExplicitFlag, LHsTyVarBndrs RdrName, LHsContext RdrName),
+ (HsExplicitFlag, LHsTyVarBndrs RdrName, LHsContext RdrName))
+splitPatSynSig lty1 lty2 = do
+ (name, details) <- splitCon pat_ty
+ details' <- case details of
+ PrefixCon tys -> return $ PrefixPatSyn tys
+ 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, (ex_flag, ex_tvs, prov'), (univ_flag, univ_tvs, req'))
+ where
+ (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
+
mkDeprecatedGadtRecordDecl :: SrcSpan
-> Located RdrName
-> [ConDeclField RdrName]
More information about the ghc-commits
mailing list