From b638fd74564458c2bab8550ec904c50de16d0427 Mon Sep 17 00:00:00 2001
From: "Dr. ERDI Gergo" <gergo@erdi.hu>
Date: Sat, 29 Nov 2014 14:51:30 +0800
Subject: Update pattern synonym type signature syntax to that used in GHC 7.10

---
 compiler/hsSyn/HsBinds.lhs        | 39 ++++++++++++++++++---------------------
 compiler/iface/IfaceSyn.lhs       | 17 +++++------------
 docs/users_guide/glasgow_exts.xml |  4 ++--
 3 files changed, 25 insertions(+), 35 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 2261a89741..769836a731 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -704,34 +704,31 @@ ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) i
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
-ppr_sig (PatSynSig name arg_tys ty prov req)
-  = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
+ppr_sig (PatSynSig name args pat_ty prov req)
+  = pprPatSynSig (unLoc name) empty
+                 (pprCtx prov) (pprCtx req)
+                 (ppr ty)
   where
-    args = fmap ppr arg_tys
+    arg_tys = case args of
+        PrefixPatSyn arg_tys -> arg_tys
+        InfixPatSyn left_ty right_ty -> [left_ty, right_ty]
+    ty = Data.List.foldr (\t1 t2 -> noLoc (HsFunTy t1 t2)) pat_ty arg_tys
 
     pprCtx lctx = case unLoc lctx of
         [] -> Nothing
         ctx -> Just (pprHsContextNoArrow ctx)
 
-pprPatSynSig :: (OutputableBndr a)
-             => a -> Bool -> HsPatSynDetails SDoc -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc
-pprPatSynSig ident is_bidir args rhs_ty prov_theta req_theta
-  = sep [ ptext (sLit "pattern")
-        , thetaOpt prov_theta, name_and_args
-        , colon
-        , thetaOpt req_theta, rhs_ty
-        ]
+pprPatSynSig :: (OutputableBndr name)
+             => name -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
+pprPatSynSig ident tvs prov req ty
+  = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
+    tvs <+> context <+> ty
   where
-    name_and_args = case args of
-        PrefixPatSyn arg_tys ->
-            pprPrefixOcc ident <+> sep arg_tys
-        InfixPatSyn left_ty right_ty ->
-            left_ty <+> pprInfixOcc ident <+> right_ty
-
-    -- TODO: support explicit foralls
-    thetaOpt = maybe empty (<+> darrow)
-
-    colon = if is_bidir then dcolon else dcolon -- TODO
+    context = case (prov, req) of
+        (Nothing, Nothing)    -> empty
+        (Nothing, Just req)   -> parens empty <+> darrow <+> req <+> darrow
+        (Just prov, Nothing)  -> prov <+> darrow
+        (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
 
 instance OutputableBndr name => Outputable (FixitySig name) where
   ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index a7f1780aac..c06aacc9a0 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -1104,22 +1104,15 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branche
   = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
        2 (vcat $ map (pprAxBranch $ Just tycon) branches)
 
-pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
+pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = _wrapper,
                             ifPatIsInfix = is_infix,
                             ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
                             ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
-                            ifPatArgs = args,
-                            ifPatTy = ty })
-  = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
+                            ifPatArgs = arg_tys,
+                            ifPatTy = pat_ty })
+  = pprPatSynSig name empty (pprCtxt prov_ctxt) (pprCtxt req_ctxt) (pprIfaceType ty)
   where
-    has_wrap = isJust wrapper
-    args' = case (is_infix, args) of
-        (True, [left_ty, right_ty]) ->
-            InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
-        (_, tys) ->
-            PrefixPatSyn (map pprParendIfaceType tys)
-
-    ty' = pprParendIfaceType ty
+    ty = foldr IfaceFunTy pat_ty arg_tys
 
     pprCtxt [] = Nothing
     pprCtxt ctxt = Just $ pprIfaceContext ctxt
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index f56bb892ae..a0957e40ef 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -1037,7 +1037,7 @@ bidirectional. The syntax for unidirectional pattern synonyms is:
   it is assigned a <emphasis>pattern type</emphasis> of the form
 </para>
 <programlisting>
-  pattern CProv => P t1 t2 ... tN :: CReq => t
+  pattern P :: CProv => CReq => t1 -> t2 -> ... -> tN -> t
 </programlisting>
 <para>
   where <replaceable>CProv</replaceable> and
@@ -1074,7 +1074,7 @@ the pattern type of <literal>ExNumPat</literal> is
 </para>
 
 <programlisting>
-pattern (Show b) => ExNumPat b :: (Num a, Eq a) => T a
+pattern ExNumPat :: (Show b) => (Num a, Eq a) => b -> T a
 </programlisting>
 
 <para>
-- 
cgit v1.2.1