[commit: ghc] wip/T8584: Add parser for pattern synonym type signatures. Syntax is of the form (b6fe946)
git at git.haskell.org
git at git.haskell.org
Sat Nov 8 03:53:29 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8584
Link : http://ghc.haskell.org/trac/ghc/changeset/b6fe9464fce8923d21cfb899694f18bee60632a0/ghc
>---------------------------------------------------------------
commit b6fe9464fce8923d21cfb899694f18bee60632a0
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.
>---------------------------------------------------------------
b6fe9464fce8923d21cfb899694f18bee60632a0
compiler/hsSyn/HsBinds.lhs | 1 +
compiler/hsSyn/HsTypes.lhs | 19 +++++++++++++------
compiler/parser/Parser.y.pp | 9 +++++++--
compiler/parser/RdrHsSyn.lhs | 31 ++++++++++++++++++++++++++++++-
4 files changed, 51 insertions(+), 9 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.pp b/compiler/parser/Parser.y.pp
index e0eaf4d..41ad6f0 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -856,8 +856,7 @@ role : VARID { L1 $ Just $ getVARID $1 }
pattern_synonym_decl :: { LHsDecl RdrName }
: 'pattern' pat '=' pat
{% do { (name, args) <- splitPatSyn $2
- ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional
- }}
+ ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional }}
| 'pattern' pat '<-' pat
{% do { (name, args) <- splitPatSyn $2
; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional
@@ -873,6 +872,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 . LL $ PatSynSig name details ty prov req }}
+
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
| varid vars0 { $1 : $2 }
@@ -1484,6 +1488,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
{ LL $ toOL [ LL $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
+ | pattern_synonym_sig { LL . unitOL $ LL . SigD . unLoc $ $1 }
| '{-# INLINE' activation qvar '#-}'
{ LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e6969e7..3152642 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -18,7 +18,7 @@ module RdrHsSyn (
mkTyFamInst,
mkFamDecl,
splitCon, mkInlinePragma,
- splitPatSyn, toPatSynMatchGroup,
+ splitPatSyn, splitPatSynSig, toPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkTyClD, mkInstD,
@@ -471,6 +471,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