Add parser support for explicitly bidirectional pattern synonyms

4 files changed, 60 insertions, 13 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 2261a89741..54d574640a 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -441,15 +441,18 @@ ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details,
                           patsyn_def = pat, patsyn_dir = dir })
   = ppr_lhs <+> ppr_rhs
       where
-        ppr_lhs = ptext (sLit "pattern") <+> ppr_details details
+        ppr_lhs = ptext (sLit "pattern") <+> ppr_details
         ppr_simple syntax = syntax <+> ppr pat
 
-        ppr_details (InfixPatSyn v1 v2) = hsep [ppr v1, pprInfixOcc psyn, ppr v2]
-        ppr_details (PrefixPatSyn vs)   = hsep (pprPrefixOcc psyn : map ppr vs)
+        (is_infix, ppr_details) = case details of
+            InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
+            PrefixPatSyn vs   -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
 
         ppr_rhs = case dir of
-            Unidirectional         -> ppr_simple (ptext (sLit "<-"))
-            ImplicitBidirectional  -> ppr_simple equals
+            Unidirectional           -> ppr_simple (ptext (sLit "<-"))
+            ImplicitBidirectional    -> ppr_simple equals
+            ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
+                                          (nest 2 $ pprFunBind psyn is_infix mg)
 
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                        , abs_exports = exports, abs_binds = val_binds
@@ -785,10 +788,9 @@ instance Traversable HsPatSynDetails where
     traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
     traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
 
-data HsPatSynDirLR idL idR
+data HsPatSynDir id
   = Unidirectional
   | ImplicitBidirectional
+  | ExplicitBidirectional (MatchGroup id (LHsExpr id))
   deriving (Data, Typeable)
-
-type HsPatSynDir id = HsPatSynDirLR id id
 \end{code}
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 9321e03d87..72dfc88fa6 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -856,6 +856,16 @@ pattern_synonym_decl :: { LHsDecl RdrName }
             {% do { (name, args) <- splitPatSyn $2
                   ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional
                   }}
+        | 'pattern' pat '<-' pat where_decls
+            {% do { (name, args) <- splitPatSyn $2
+                  ; mg <- toPatSynMatchGroup name $5
+                  ; return $ LL . ValD $
+                    mkPatSynBind name args $4 (ExplicitBidirectional mg)
+                  }}
+
+where_decls :: { Located (OrdList (LHsDecl RdrName)) }
+        : 'where' '{' decls '}'       { $3 }
+        | 'where' vocurly decls close { $3 }
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ed29fe0e6f..84a284f0ab 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -16,7 +16,8 @@ module RdrHsSyn (
         mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst, 
         mkFamDecl, 
-        splitCon, splitPatSyn, mkInlinePragma,
+        splitCon, mkInlinePragma,
+        splitPatSyn, toPatSynMatchGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyLit,
         mkTyClD, mkInstD,
@@ -435,18 +436,49 @@ 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
+        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 pat@(L loc _)        = parseErrorSDoc loc $
-                                  text "Pattern synonym arguments must be variable names:" $$ ppr 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) =
+    do { matches <- mapM fromDecl (fromOL decls)
+       ; return $ mkMatchGroup FromSource matches }
+  where
+    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) =
+        do { unless (name == patsyn_name) $
+               wrongNameBindingErr loc decl
+           ; match <- case details of
+               PrefixCon pats -> return $ Match pats Nothing rhs
+               InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs
+               RecCon{} -> recordPatSynErr loc pat
+           ; return $ L loc match }
+    fromDecl (L loc decl) = extraDeclErr loc decl
+
+    extraDeclErr loc decl =
+        parseErrorSDoc loc $
+        text "pattern synonym 'where' clause must contain a single binding:" $$
+        ppr decl
+
+    wrongNameBindingErr loc decl =
+        parseErrorSDoc loc $
+        text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
+        quotes (ppr patsyn_name) $$ ppr decl
+
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
                            -> [ConDeclField RdrName]
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index f90cfca317..1a48fe8260 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -489,6 +489,9 @@ zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)
 zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id)
 zonkPatSynDir env Unidirectional = return (env, Unidirectional)
 zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
+zonkPatSynDir env (ExplicitBidirectional mg) = do
+    mg' <- zonkMatchGroup env zonkLExpr mg
+    return (env, ExplicitBidirectional mg')
 
 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
 zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod