Parser for SPJ's pattern synonym signature syntax

3 files changed, 41 insertions, 8 deletions

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index db4d976101..7af05c3acb 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -272,6 +272,8 @@ data HsType name
   | HsTyLit HsTyLit      -- A promoted numeric literal.
 
   | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
+
+  | HsContextPair (LHsContext name) (LHsContext name) -- only during parsing
   deriving (Typeable)
 deriving instance (DataId name) => Data (HsType name)
 
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index ea752cf664..7d817edc44 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -880,9 +880,16 @@ where_decls :: { Located (OrdList (LHsDecl RdrName)) }
         | 'where' vocurly decls close { $3 }
 
 pattern_synonym_sig :: { LSig RdrName }
-        : 'pattern' 'type' ctype '::' ctype
-             {% do { (name, details, ty, prov, req) <- splitPatSynSig $3 $5
-                   ; return $ sLL $1 $> $ PatSynSig name details ty prov req }}
+        : 'pattern' 'type' con '::' ptype
+            { undefined }
+
+ptype :: { () }
+        : 'forall' tv_bndrs '.' ptype   {% hintExplicitForall (getLoc $1) >>
+                                            return () }
+        | pcontext '=>' type            { () }
+
+pcontext :: { (LHsContext RdrName, LHsContext RdrName) }
+        : btype {% checkContextPair $1 }
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
@@ -1207,6 +1214,7 @@ atype :: { LHsType RdrName }
         | '(' ctype ',' comma_types1 ')' { sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) }
         | '(#' '#)'                      { sLL $1 $> $ HsTupleTy HsUnboxedTuple           []      }
         | '(#' comma_types1 '#)'         { sLL $1 $> $ HsTupleTy HsUnboxedTuple           $2      }
+        | '(' comma_ltypes0 ';' comma_ltypes0 ')'     { sLL $1 $> $ HsContextPair $2 $4 }
         | '[' ctype ']'                  { sLL $1 $> $ HsListTy  $2 }
         | '[:' ctype ':]'                { sLL $1 $> $ HsPArrTy  $2 }
         | '(' ctype ')'                  { sLL $1 $> $ HsParTy   $2 }
@@ -1238,13 +1246,19 @@ inst_types1 :: { [LHsType RdrName] }
         : inst_type                     { [$1] }
         | inst_type ',' inst_types1     { $1 : $3 }
 
+comma_ltypes0 :: { Located [LHsType RdrName] }
+        : comma_ltypes1                 { $1 }
+        | {- empty -}                   { noLoc [] }
+
+comma_ltypes1   :: { Located [LHsType RdrName] }
+        : ctype                         { sL1 $1 [$1] }
+        | ctype  ',' comma_ltypes1      { sLL $1 $> $ $1 : unLoc $3 }
+
 comma_types0  :: { [LHsType RdrName] }
-        : comma_types1                  { $1 }
-        | {- empty -}                   { [] }
+        : comma_ltypes0                 { unLoc $1 }
 
-comma_types1    :: { [LHsType RdrName] }
-        : ctype                         { [$1] }
-        | ctype  ',' comma_types1       { $1 : $3 }
+comma_types1  :: { [LHsType RdrName] }
+        : comma_ltypes1                 { unLoc $1 }
 
 tv_bndrs :: { [LHsTyVarBndr RdrName] }
          : tv_bndr tv_bndrs             { $1 : $2 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 15490c304e..4b3d519334 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -41,6 +41,7 @@ module RdrHsSyn (
         -- checking and constructing values
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
+        checkContextPair,     -- HsType -> P (HsContext, HsContext)
         checkPattern,         -- HsExp -> P HsPat
         bang_RDR,
         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -673,6 +674,22 @@ checkContext (L l orig_t)
   check _
     = return (L l [L l orig_t])
 
+checkContextPair :: LHsType RdrName -> P (LHsContext RdrName, LHsContext RdrName)
+checkContextPair (L l orig_t)
+  = check orig_t
+ where
+  check (HsTupleTy _ ts)           -- Required context can be empty
+    = return (L l ts, noLoc [])
+
+  check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
+    = check (unLoc ty)
+
+  check (HsContextPair prov req)
+    = return (prov, req)
+
+  check _
+    = return (L l [L l orig_t], noLoc [])
+
 -- -------------------------------------------------------------------------
 -- Checking Patterns.