[commit: ghc] wip/T8584: Show foralls (when requested) in pattern synonym types (54a3cc6)

[git at git.haskell.org]

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

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

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

commit 54a3cc6735be0bd47db2c86befc0d1cb267a58d5
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sun Aug 3 15:26:13 2014 +0200

    Show foralls (when requested) in pattern synonym types


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

54a3cc6735be0bd47db2c86befc0d1cb267a58d5
 compiler/hsSyn/HsBinds.lhs  | 21 ++++++---------------
 compiler/iface/IfaceSyn.lhs |  9 +++++----
 2 files changed, 11 insertions(+), 19 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index f75fa2e..5a45956 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -730,24 +730,18 @@ 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))
+ppr_sig (PatSynSig name arg_tys ty prov req)
   = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
   where
     args = fmap ppr arg_tys
 
-    pprCtx lctx = case unLoc lctx of
-        [] -> Nothing
-        ctx -> Just (pprHsContextNoArrow ctx)
+    pprCtx (flag, tvs, lctx) = pprHsForAll flag tvs lctx
 
 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")
-        , ptext (sLit "type")
-        , thetaOpt prov_theta, name_and_args
-        , colon
-        , thetaOpt req_theta, rhs_ty
-        ]
+             => a -> Bool -> HsPatSynDetails SDoc -> SDoc -> SDoc -> SDoc -> SDoc
+pprPatSynSig ident is_bidir args rhs_ty prov req
+  = ptext (sLit "pattern type") <+>
+    prov <+> name_and_args <+> colon <+> req <+> rhs_ty
   where
     name_and_args = case args of
         PrefixPatSyn arg_tys ->
@@ -755,9 +749,6 @@ pprPatSynSig ident is_bidir args rhs_ty prov_theta req_theta
         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
 
 instance OutputableBndr name => Outputable (FixitySig name) where
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 5cfe773..d228510 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -761,11 +761,13 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
 
 pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
                               ifPatIsInfix = is_infix,
-                              ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
+                              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)
+  = pprPatSynSig name has_wrap args' ty'
+                 (pprCtxt ex_tvs prov_ctxt)
+                 (pprCtxt univ_tvs req_ctxt)
   where
     has_wrap = isJust wrapper
     args' = case (is_infix, args) of
@@ -776,8 +778,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
 
     ty' = pprParendIfaceType ty
 
-    pprCtxt [] = Nothing
-    pprCtxt ctxt = Just $ pprIfaceContext ctxt
+    pprCtxt tvs ctxt = pprIfaceForAllPart tvs ctxt empty
 
 pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
                               ifIdDetails = details, ifIdInfo = info })