[commit: ghc] wip/T8584.spj: Look ma, no 'pattern type'! (b0a25b9)

[git at git.haskell.org]

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

On branch  : wip/T8584.spj
Link       : http://ghc.haskell.org/trac/ghc/changeset/b0a25b9e30c9c2d9635a4dc9786f5ba00e3e060a/ghc

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

commit b0a25b9e30c9c2d9635a4dc9786f5ba00e3e060a
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Mon Nov 10 21:52:12 2014 +0800

    Look ma, no 'pattern type'!


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

b0a25b9e30c9c2d9635a4dc9786f5ba00e3e060a
 compiler/parser/Parser.y | 39 ++++++++++++++++++++-------------------
 1 file changed, 20 insertions(+), 19 deletions(-)

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index bf62286..80bc48d 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