[commit: ghc] wip/pattern-synonym-sig-backport: Update pattern synonym type signature syntax to that used in GHC 7.10 (abc0160)

[git at git.haskell.org]

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

On branch  : wip/pattern-synonym-sig-backport
Link       : http://ghc.haskell.org/trac/ghc/changeset/abc0160d3d423c0ea5645a3ac469066459387ef8/ghc

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

commit abc0160d3d423c0ea5645a3ac469066459387ef8
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sat Nov 29 14:46:53 2014 +0800

    Update pattern synonym type signature syntax to that used in GHC 7.10


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

abc0160d3d423c0ea5645a3ac469066459387ef8
 compiler/hsSyn/HsBinds.lhs  | 39 ++++++++++++++++++---------------------
 compiler/iface/IfaceSyn.lhs | 17 +++++------------
 2 files changed, 23 insertions(+), 33 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 2261a89..769836a 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 a7f1780..c06aacc 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