summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Core/TyCo/Ppr.hs40
-rw-r--r--testsuite/tests/ghc-api/T18522-dbg-ppr.hs50
-rw-r--r--testsuite/tests/ghc-api/T18522-dbg-ppr.stdout2
-rw-r--r--testsuite/tests/ghc-api/all.T4
4 files changed, 84 insertions, 12 deletions
diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs
index ea9417e360..d48cf84c4e 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs
+++ b/compiler/GHC/Core/TyCo/Ppr.hs
@@ -36,7 +36,8 @@ import {-# SOURCE #-} GHC.CoreToIface
import {-# SOURCE #-} GHC.Core.DataCon
( dataConFullSig , dataConUserTyVarBinders, DataCon )
-import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many )
+import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many,
+ splitForAllTysReq, splitForAllTysInvis )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
@@ -268,19 +269,34 @@ debug_ppr_ty prec (CastTy ty co)
debug_ppr_ty _ (CoercionTy co)
= parens (text "CO" <+> ppr co)
-debug_ppr_ty prec ty@(ForAllTy {})
- | (tvs, body) <- split ty
+-- Invisible forall: forall {k} (a :: k). t
+debug_ppr_ty prec t
+ | (bndrs, body) <- splitForAllTysInvis t
+ , not (null bndrs)
= maybeParen prec funPrec $
- hang (text "forall" <+> fsep (map ppr tvs) <> dot)
- -- The (map ppr tvs) will print kind-annotated
- -- tvs, because we are (usually) in debug-style
- 2 (ppr body)
+ sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot,
+ ppr body ]
where
- split ty | ForAllTy tv ty' <- ty
- , (tvs, body) <- split ty'
- = (tv:tvs, body)
- | otherwise
- = ([], ty)
+ -- (ppr tv) will print the binder kind-annotated
+ -- when in debug-style
+ ppr_bndr (Bndr tv InferredSpec) = braces (ppr tv)
+ ppr_bndr (Bndr tv SpecifiedSpec) = ppr tv
+
+-- Visible forall: forall x y -> t
+debug_ppr_ty prec t
+ | (bndrs, body) <- splitForAllTysReq t
+ , not (null bndrs)
+ = maybeParen prec funPrec $
+ sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow,
+ ppr body ]
+ where
+ -- (ppr tv) will print the binder kind-annotated
+ -- when in debug-style
+ ppr_bndr (Bndr tv ()) = ppr tv
+
+-- Impossible case: neither visible nor invisible forall.
+debug_ppr_ty _ ForAllTy{}
+ = panic "debug_ppr_ty: neither splitForAllTysInvis nor splitForAllTysReq returned any binders"
{-
Note [Infix type variables]
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
new file mode 100644
index 0000000000..3b14cc1d8a
--- /dev/null
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds #-}
+
+module Main where
+
+import Language.Haskell.TH (runQ)
+import GHC.Types.Basic
+import GHC.ThToHs
+import GHC.Driver.Session
+import GHC.Core.TyCo.Ppr
+import GHC.Utils.Outputable
+import GHC.Tc.Module
+import GHC.Tc.Utils.Zonk
+import GHC.Utils.Error
+import GHC.Driver.Types
+import GHC
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Either (fromRight)
+import Control.Monad.IO.Class (liftIO)
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ do
+ initial_dflags <- getSessionDynFlags
+ setSessionDynFlags $ initial_dflags
+ `dopt_set` Opt_D_ppr_debug
+ `gopt_set` Opt_SuppressUniques
+ `gopt_set` Opt_SuppressModulePrefixes
+ `gopt_set` Opt_SuppressVarKinds
+ `xopt_set` LangExt.KindSignatures
+ `xopt_set` LangExt.PolyKinds
+ `xopt_set` LangExt.RankNTypes
+ hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+ liftIO $ do
+ th_t <- runQ [t| forall k {j}.
+ forall (a :: k) (b :: j) ->
+ () |]
+ let hs_t = fromRight (error "convertToHsType") $
+ convertToHsType Generated noSrcSpan th_t
+ ((warnings, errors), mres) <-
+ tcRnType hsc_env SkolemiseFlexi True hs_t
+ case mres of
+ Nothing -> do
+ printBagOfErrors dflags warnings
+ printBagOfErrors dflags errors
+ Just (t, _) -> do
+ putStrLn $ showSDoc dflags (debugPprType t)
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.stdout b/testsuite/tests/ghc-api/T18522-dbg-ppr.stdout
new file mode 100644
index 0000000000..c6e1d209e7
--- /dev/null
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.stdout
@@ -0,0 +1,2 @@
+forall k{tv}[tv] {j{tv}[tv]}.
+forall a{tv}[tv] b{tv}[tv] -> (){(w) tc}
diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T
index fa7f7a9348..4135ca7a13 100644
--- a/testsuite/tests/ghc-api/all.T
+++ b/testsuite/tests/ghc-api/all.T
@@ -20,3 +20,7 @@ test('T9015', extra_run_opts('"' + config.libdir + '"'),
test('T11579', extra_run_opts('"' + config.libdir + '"'), compile_and_run,
['-package ghc'])
test('T12099', normal, compile_and_run, ['-package ghc'])
+test('T18522-dbg-ppr',
+ extra_run_opts('"' + config.libdir + '"'),
+ compile_and_run,
+ ['-package ghc'])