From dbe2c5c44ffffb9252b33ec049edb189103c49a4 Mon Sep 17 00:00:00 2001
From: "Dr. ERDI Gergo" <gergo@erdi.hu>
Date: Wed, 2 Jul 2014 19:23:47 +0800
Subject: Add parser for pattern synonym signatures

---
 compiler/parser/Parser.y.pp | 22 ++++++++++++++++++++--
 1 file changed, 20 insertions(+), 2 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 68f7e5bd58..6e4a3d5a8c 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -816,8 +816,25 @@ role : VARID             { L1 $ Just $ getVARID $1 }
 
 -- Glasgow extension: pattern synonyms
 pattern_synonym_decl :: { LHsDecl RdrName }
-        : 'pattern' con vars0 patsyn_token pat { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 }
-        | 'pattern' varid conop varid patsyn_token pat { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 }
+        : 'pattern' con vars0 patsyn_token pat
+             { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 }
+        | 'pattern' varid conop varid patsyn_token pat
+             { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 }
+
+pattern_synonym_sig :: { LSig RdrName }
+        : 'pattern' patsyn_context patsyn_stuff '::' patsyn_context type
+             { let (name, details) = unLoc $3
+               in LL $ PatSynSig name details $6 $2 $5 }
+
+patsyn_stuff :: { Located (Located RdrName, HsPatSynDetails (LHsType RdrName)) }
+        : constr_stuff
+             {% do { let { (L loc (name, con_details)) = $1 }
+                   ; ps_details <- toPatSynSigDetails loc con_details
+                   ; return $ LL (name, ps_details) } }
+
+patsyn_context :: { LHsContext RdrName }
+        : forall                      { L0 [] }
+        | forall context '=>'         { $2 }
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
@@ -1432,6 +1449,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                                 { LL $ toOL [ LL $ SigD (TypeSig ($1 : 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 '#-}'
-- 
cgit v1.2.1