[commit: ghc] wip/T8584: Add parser for pattern synonym type signatures. Syntax is of the form (b99afa8)

[git at git.haskell.org]

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

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

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

commit b99afa87a790532259e949ed987da50573742daa
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Tue Nov 11 18:54:14 2014 +0800

    Add parser for pattern synonym type signatures.
    Syntax is of the form
    
        pattern P :: (Prov b) => (Req a) => a -> b -> Int -> T a
    
    which declares a pattern synonym called `P`, with argument types `a`, `b`,
    and `Int`, and result type `T a`, with provided context `(Prov b)` and required
    context `(Req a)`.


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

b99afa87a790532259e949ed987da50573742daa
 compiler/parser/Parser.y    | 51 +++++++++++++++++++++++++++++++--------------
 compiler/parser/RdrHsSyn.hs | 27 +++++-------------------
 2 files changed, 40 insertions(+), 38 deletions(-)

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 1123375..0cceb09 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -860,29 +860,47 @@ 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
-                  ; mg <- toPatSynMatchGroup name $5
+        : '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 <- mkPatSynMatchGroup name $5
                   ; return $ sLL $1 $> . ValD $
-                    mkPatSynBind name args $4 (ExplicitBidirectional mg)
-                  }}
+                    mkPatSynBind name args $4 (ExplicitBidirectional mg) }}
 
-where_decls :: { Located (OrdList (LHsDecl RdrName)) }
-        : 'where' '{' decls '}'       { $3 }
-        | 'where' vocurly decls close { $3 }
+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' 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
+            {% do { hintExplicitForall (getLoc $1)
+                  ; let (_, qtvs', prov, req, ty) = unLoc $4
+                  ; return $ sLL $1 $> (Explicit, $2 ++ qtvs', prov, req ,ty) }}
+        | context '=>' context '=>' type
+            { sLL $1 $> (Implicit, [], $1, $3, $5) }
+        | context '=>' type
+            { sLL $1 $> (Implicit, [], $1, noLoc [], $3) }
+        | type
+            { sL1 $1 (Implicit, [], noLoc [], noLoc [], $1) }
+
 -----------------------------------------------------------------------------
 -- Nested declarations
 
@@ -1490,6 +1508,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                                 { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
         | infix prec ops        { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                              | n <- unLoc $3 ] }
+        | pattern_synonym_sig   { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
         | '{-# INLINE' activation qvar '#-}'
                 { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 625c4dc..e945e43 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -18,7 +18,7 @@ module RdrHsSyn (
         mkTyFamInst,
         mkFamDecl,
         splitCon, mkInlinePragma,
-        splitPatSyn, toPatSynMatchGroup,
+        mkPatSynMatchGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyClD, mkInstD,
 
@@ -414,33 +414,16 @@ 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{}           -> recordPatSynErr loc 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 (L loc pat)          = 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
-
 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
 recordPatSynErr loc pat =
     parseErrorSDoc loc $
     text "record syntax not supported for pattern synonym declarations:" $$
     ppr pat
 
-toPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName))
-toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
+mkPatSynMatchGroup :: Located RdrName
+                   -> Located (OrdList (LHsDecl RdrName))
+                   -> P (MatchGroup RdrName (LHsExpr RdrName))
+mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
     do { matches <- mapM fromDecl (fromOL decls)
        ; return $ mkMatchGroup FromSource matches }
   where