diff options
| -rw-r--r-- | compiler/parser/Parser.y | 39 |
1 files changed, 20 insertions, 19 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index bf62286705..80bc48daa8 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -860,29 +860,34 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl RdrName } - : 'pattern' pat '=' pat - {% do { (name, args) <- splitPatSyn $2 - ; return $ sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional - }} - | 'pattern' pat '<-' pat - {% do { (name, args) <- splitPatSyn $2 - ; return $ sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional - }} - | 'pattern' pat '<-' pat where_decls - {% do { (name, args) <- splitPatSyn $2 + : 'pattern' pattern_synonym_lhs '=' pat + { let (name, args) = $2 + in sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional } + | 'pattern' pattern_synonym_lhs '<-' pat + { let (name, args) = $2 + in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional } + | 'pattern' pattern_synonym_lhs '<-' pat where_decls + {% do { let (name, args) = $2 ; mg <- toPatSynMatchGroup name $5 ; return $ sLL $1 $> . ValD $ - mkPatSynBind name args $4 (ExplicitBidirectional mg) - }} + mkPatSynBind name args $4 (ExplicitBidirectional mg) }} + +pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) } + : con vars0 { ($1, PrefixPatSyn $2) } + | varid consym varid { ($2, InfixPatSyn $1 $3) } + +vars0 :: { [Located RdrName] } + : {- empty -} { [] } + | varid vars0 { $1 : $2 } where_decls :: { Located (OrdList (LHsDecl RdrName)) } : 'where' '{' decls '}' { $3 } | 'where' vocurly decls close { $3 } pattern_synonym_sig :: { LSig RdrName } - : 'pattern' 'type' con '::' ptype - { let (flag, qtvs, prov, req, ty) = unLoc $5 - in sLL $1 $> $ PatSynSig $3 (flag, mkHsQTvs qtvs) prov req ty } + : 'pattern' con '::' ptype + { let (flag, qtvs, prov, req, ty) = unLoc $4 + in sLL $1 $> $ PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty } ptype :: { Located (HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName, LHsContext RdrName, LHsType RdrName) } : 'forall' tv_bndrs '.' ptype @@ -895,10 +900,6 @@ ptype :: { Located (HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName, pcontext :: { Located (LHsContext RdrName, LHsContext RdrName) } : btype {% fmap (sL1 $1) $ checkContextPair $1 } -vars0 :: { [Located RdrName] } - : {- empty -} { [] } - | varid vars0 { $1 : $2 } - ----------------------------------------------------------------------------- -- Nested declarations |