From 12644c3c0216edfcff33266f4f250e0c52004352 Mon Sep 17 00:00:00 2001
From: "Dr. ERDI Gergo" <gergo@erdi.hu>
Date: Sun, 6 Jul 2014 17:33:00 +0800
Subject: New parser for pattern synonym declarations:

Like splitCon for constructor definitions, the left-hand side of a
pattern declaration is parsed as a single pattern which is then split
into a ConName and argument variable names
---
 compiler/parser/Parser.y.pp  | 14 ++++++++------
 compiler/parser/RdrHsSyn.lhs | 21 ++++++++++++++++++++-
 2 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 3fff097d25..9321e03d87 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -848,17 +848,19 @@ 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' pat '=' pat
+            {% do { (name, args) <- splitPatSyn $2
+                  ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional
+                  }}
+        | 'pattern' pat '<-' pat
+            {% do { (name, args) <- splitPatSyn $2
+                  ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional
+                  }}
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
         | varid vars0                 { $1 : $2 }
 
-patsyn_token :: { HsPatSynDir RdrName }
-        : '<-' { Unidirectional }
-        | '='  { ImplicitBidirectional }
-
 -----------------------------------------------------------------------------
 -- Nested declarations
 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 93a98d068e..ed29fe0e6f 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -16,7 +16,7 @@ module RdrHsSyn (
         mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst, 
         mkFamDecl, 
-        splitCon, mkInlinePragma,
+        splitCon, splitPatSyn, mkInlinePragma,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyLit,
         mkTyClD, mkInstD,
@@ -428,6 +428,25 @@ splitCon ty
    mk_rest [L _ (HsRecTy flds)] = RecCon flds
    mk_rest ts                   = PrefixCon ts
 
+splitPatSyn :: LPat RdrName
+      -> P (Located RdrName, HsPatSynDetails (Located RdrName))
+splitPatSyn (L _ (ParPat pat)) = splitPatSyn pat
+splitPatSyn pat@(L loc (ConPatIn con details)) = do
+    details' <- case details of
+        PrefixCon pats     -> liftM PrefixPatSyn (mapM patVar pats)
+        InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2)
+        RecCon{}           -> parseErrorSDoc loc $
+                              text "record syntax not supported for pattern synonym declarations:" $$ ppr pat
+    return (con, details')
+  where
+    patVar :: LPat RdrName -> P (Located RdrName)
+    patVar (L loc (VarPat v))   = return $ L loc v
+    patVar (L _   (ParPat pat)) = patVar pat
+    patVar pat@(L loc _)        = parseErrorSDoc loc $
+                                  text "Pattern synonym arguments must be variable names:" $$ ppr pat
+splitPatSyn pat@(L loc _) = parseErrorSDoc loc $
+                            text "invalid pattern synonym declaration:" $$ ppr pat
+
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
                            -> [ConDeclField RdrName]
-- 
cgit v1.2.1