[commit: ghc] wip/pattern-synonyms: New parser for pattern synonym declarations: (007c39f)

[git at git.haskell.org]

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

On branch  : wip/pattern-synonyms
Link       : http://ghc.haskell.org/trac/ghc/changeset/007c39f7b2749409af45b649a2906297a3be9c93/ghc

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

commit 007c39f7b2749409af45b649a2906297a3be9c93
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sun Jul 6 17:33:00 2014 +0800

    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


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

007c39f7b2749409af45b649a2906297a3be9c93
 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 a3c68c3..073afd8 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -821,17 +821,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 af351b7..0536286 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,
@@ -412,6 +412,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]