Improve printing of pattern synonym types

Add the function `pprPatSynType :: PatSyn -> SDoc` for printing pattern
synonym types, and remove the ambiguous `patSynType` function. Also,
the types in a `PatSyn` are now tidy.

Haddock submodule updated to reflect the removal of `patSynType` by
mpickering.

Fixes: #11213.

Reviewers: goldfire, simonpj, austin, mpickering, bgamari

Reviewed By: simonpj, mpickering

Subscribers: bollmann, simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1896

GHC Trac Issues: #11213

8 files changed, 138 insertions, 44 deletions

diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index 3eea30018f..e7228795a8 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -13,13 +13,13 @@ module PatSyn (
 
         -- ** Type deconstruction
         patSynName, patSynArity, patSynIsInfix,
-        patSynArgs, patSynType,
+        patSynArgs,
         patSynMatcher, patSynBuilder,
         patSynUnivTyBinders, patSynExTyVars, patSynExTyBinders, patSynSig,
         patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
         patSynFieldType,
 
-        tidyPatSynIds
+        tidyPatSynIds, pprPatSynType
     ) where
 
 #include "HsVersions.h"
@@ -348,16 +348,6 @@ mkPatSyn name declared_infix
 patSynName :: PatSyn -> Name
 patSynName = psName
 
-patSynType :: PatSyn -> Type
--- The full pattern type, used only in error messages
--- See Note [Pattern synonym signatures]
-patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
-                     , psExTyVars   = ex_tvs,   psProvTheta = prov_theta
-                     , psArgs = orig_args, psOrigResTy = orig_res_ty })
-  = mkSpecSigmaTy univ_tvs req_theta $  -- use mkSpecSigmaTy because it
-    mkSpecSigmaTy ex_tvs prov_theta $   -- prints better
-    mkFunTys orig_args orig_res_ty
-
 -- | Should the 'PatSyn' be presented infix?
 patSynIsInfix :: PatSyn -> Bool
 patSynIsInfix = psInfix
@@ -435,3 +425,16 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
   = ASSERT2( length univ_tvs == length inst_tys
            , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
     substTyWith univ_tvs inst_tys res_ty
+
+-- | Print the type of a pattern synonym. The foralls are printed explicitly
+pprPatSynType :: PatSyn -> SDoc
+pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta
+                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta
+                        , psArgs       = orig_args, psOrigResTy = orig_res_ty })
+  = sep [ pprForAllImplicit univ_tvs
+        , pprThetaArrowTy req_theta
+        , ppWhen insert_empty_ctxt $ parens empty <+> darrow
+        , pprType sigma_ty ]
+  where
+    sigma_ty = mkSpecSigmaTy ex_tvs prov_theta $ mkFunTys orig_args orig_res_ty
+    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index c9f916a95a..16591916db 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -1567,9 +1567,10 @@ warnUnusedImportDecls gbl_env
 warnMissingSignatures :: TcGblEnv -> RnM ()
 warnMissingSignatures gbl_env
   = do { let exports = availsToNameSet (tcg_exports gbl_env)
-             sig_ns = tcg_sigs gbl_env
-             all_binds = collectHsBindsBinders $ tcg_binds gbl_env
-             all_ps    = tcg_patsyns gbl_env
+             sig_ns  = tcg_sigs gbl_env
+               -- We use sig_ns to exclude top-level bindings that are generated by GHC
+             binds    = collectHsBindsBinders $ tcg_binds gbl_env
+             pat_syns = tcg_patsyns gbl_env
 
          -- Warn about missing signatures
          -- Do this only when we we have a type to offer
@@ -1584,27 +1585,32 @@ warnMissingSignatures gbl_env
                | otherwise          = return ()
 
              add_warns flag
-               = forM_ binders
-                 (\(name, ty) ->
-                    do { env <- tcInitTidyEnv
-                       ; let (_, tidy_ty) = tidyOpenType env ty
-                       ; addWarnAt (Reason flag) (getSrcSpan name)
-                                                 (get_msg name tidy_ty) })
-
-             binds   = if warn_missing_sigs || warn_only_exported then all_binds else []
-             ps      = if warn_pat_syns                           then all_ps    else []
-             binders = filter pred $
-                         [(patSynName p, patSynType p) | p <- ps   ] ++
-                         [(idName b, idType b)         | b <- binds]
-
-             pred (name, _) = name `elemNameSet` sig_ns
-                              && (not warn_only_exported || name `elemNameSet` exports)
-               -- We use sig_ns to exclude top-level bindings that are
-               -- generated by GHC and that don't have signatures
-
-             get_msg name ty
-               = sep [ text "Top-level binding with no type signature:",
-                       nest 2 $ pprPrefixName name <+> dcolon <+> ppr ty ]
+                = when warn_pat_syns
+                       (mapM_ add_pat_syn_warn pat_syns) >>
+                  when (warn_missing_sigs || warn_only_exported)
+                       (mapM_ add_bind_warn binds)
+                where
+                  add_pat_syn_warn p
+                    = add_warn (patSynName p) (pprPatSynType p)
+
+                  add_bind_warn id
+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?
+                         ; let name    = idName id
+                               (_, ty) = tidyOpenType env (idType id)
+                               ty_msg  = ppr ty
+                         ; add_warn name ty_msg }
+
+                  add_warn name ty_msg
+                    = when (name `elemNameSet` sig_ns && export_check name)
+                           (addWarnAt (Reason flag) (getSrcSpan name)
+                                                    (get_msg name ty_msg))
+
+                  export_check name
+                    = not warn_only_exported || name `elemNameSet` exports
+
+                  get_msg name ty_msg
+                    = sep [ text "Top-level binding with no type signature:",
+                            nest 2 $ pprPrefixName name <+> dcolon <+> ty_msg ]
 
        ; add_sig_warns }
 
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 025101a8e3..2accd24c56 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -28,6 +28,8 @@ import Panic
 import Outputable
 import FastString
 import Var
+import VarEnv( emptyTidyEnv )
+import Type( tidyTyCoVarBndrs, tidyTypes, tidyType )
 import Id
 import IdInfo( RecSelParent(..))
 import TcBinds
@@ -411,12 +413,19 @@ tc_patsyn_finish lname dir is_infix lpat'
                  pat_ty field_labels
   = do { -- Zonk everything.  We are about to build a final PatSyn
          -- so there had better be no unification variables in there
-         univ_tvs     <- mapMaybeM zonkQuantifiedTyVar univ_tvs
-       ; ex_tvs       <- mapMaybeM zonkQuantifiedTyVar ex_tvs
-       ; prov_theta   <- zonkTcTypes prov_theta
-       ; req_theta    <- zonkTcTypes req_theta
-       ; pat_ty       <- zonkTcType pat_ty
-       ; arg_tys      <- zonkTcTypes arg_tys
+         univ_tvs'    <- mapMaybeM zonkQuantifiedTyVar univ_tvs
+       ; ex_tvs'      <- mapMaybeM zonkQuantifiedTyVar ex_tvs
+       ; prov_theta'  <- zonkTcTypes prov_theta
+       ; req_theta'   <- zonkTcTypes req_theta
+       ; pat_ty'      <- zonkTcType pat_ty
+       ; arg_tys'     <- zonkTcTypes arg_tys
+
+       ; let (env1, univ_tvs) = tidyTyCoVarBndrs emptyTidyEnv univ_tvs'
+             (env2, ex_tvs)   = tidyTyCoVarBndrs env1 ex_tvs'
+             req_theta  = tidyTypes env2 req_theta'
+             prov_theta = tidyTypes env2 prov_theta'
+             arg_tys    = tidyTypes env2 arg_tys'
+             pat_ty     = tidyType  env2 pat_ty'
 
           -- We need to update the univ and ex binders after zonking.
           -- But zonking may have defaulted some erstwhile binders,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 3f3bff3e15..b218ec0ec2 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -139,7 +139,7 @@ import TyCon    ( TyCon )
 import Coercion ( Coercion, mkHoleCo )
 import ConLike  ( ConLike(..) )
 import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
-import PatSyn   ( PatSyn, patSynType )
+import PatSyn   ( PatSyn, pprPatSynType )
 import Id       ( idName )
 import PrelNames ( callStackTyConKey, ipClassKey )
 import Unique ( hasKey )
@@ -2669,7 +2669,7 @@ pprPatSkolInfo (RealDataCon dc)
 pprPatSkolInfo (PatSynCon ps)
   = sep [ text "a pattern with pattern synonym:"
         , nest 2 $ ppr ps <+> dcolon
-                   <+> pprType (patSynType ps) <> comma ]
+                   <+> pprPatSynType ps <> comma ]
 
 {- Note [Skolem info for pattern synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/patsyn/should_compile/T11213.hs b/testsuite/tests/patsyn/should_compile/T11213.hs
new file mode 100644
index 0000000000..fff1c1e6d5
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T11213.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE PatternSynonyms, GADTs #-}
+{-# OPTIONS_GHC -fwarn-missing-pattern-synonym-signatures #-}
+
+{-
+Test the printing of pattern synonym types (pprPatSynType)
+We test all valid combinations of:
+    universal type variables      yes/no
+    "required" context            yes/no
+    existential type variables    yes/no
+    "provided" context            yes/no
+-}
+
+module T11213 where
+
+data Ex         where MkEx       :: a -> Ex
+data ExProv     where MkExProv   :: (Show a) => a -> ExProv
+data UnivProv a where MkUnivProv :: (Show a) => a -> UnivProv a
+
+pattern P         <-  True
+pattern Pe    x   <-  MkEx x
+pattern Pu    x   <-  x
+pattern Pue   x y <- (x, MkEx y)
+pattern Pur   x   <-  [x, 1]
+pattern Purp  x y <- ([x, 1], MkUnivProv y)
+pattern Pure  x y <- ([x, 1], MkEx y)
+pattern Purep x y <- ([x, 1], MkExProv y)
+pattern Pep   x   <-  MkExProv x
+pattern Pup   x   <-  MkUnivProv x
+pattern Puep  x y <- (MkExProv x, y)
diff --git a/testsuite/tests/patsyn/should_compile/T11213.stderr b/testsuite/tests/patsyn/should_compile/T11213.stderr
new file mode 100644
index 0000000000..88d8f84a53
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T11213.stderr
@@ -0,0 +1,46 @@
+
+T11213.hs:19:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature: P :: Bool
+
+T11213.hs:20:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Pe :: () => forall a. a -> Ex
+
+T11213.hs:21:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature: Pu :: forall t. t -> t
+
+T11213.hs:22:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Pue :: forall t. () => forall a. t -> a -> (t, Ex)
+
+T11213.hs:23:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Pur :: forall a. (Num a, Eq a) => a -> [a]
+
+T11213.hs:24:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Purp :: forall a t.
+              (Num a, Eq a) =>
+              Show t => a -> t -> ([a], UnivProv t)
+
+T11213.hs:25:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Pure :: forall a. (Num a, Eq a) => forall a1. a -> a1 -> ([a], Ex)
+
+T11213.hs:26:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Purep :: forall a.
+               (Num a, Eq a) =>
+               forall a1. Show a1 => a -> a1 -> ([a], ExProv)
+
+T11213.hs:27:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Pep :: () => forall a. Show a => a -> ExProv
+
+T11213.hs:28:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Pup :: forall t. () => Show t => t -> UnivProv t
+
+T11213.hs:29:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      Puep :: forall t. () => forall a. Show a => a -> t -> (ExProv, t)
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 0fc26cba23..3032096629 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -44,6 +44,7 @@ test('export-record-selector', normal, compile, [''])
 test('T10897', normal, multi_compile, ['T10897', [
                                        ('T10897a.hs','-c')
                                       ], '-v0'])
+test('T11213', normal, compile, [''])
 test('T11224b', normal, compile, [''])
 test('MoreEx', normal, compile, [''])
 test('T11283', normal, compile, [''])
diff --git a/utils/haddock b/utils/haddock
-Subproject bb994de1ab0c76d1aaf1e39c54158db2526d31f
+Subproject 3ddcbd6b8e6884bd95028381176eb33bee6896f