diff options
| -rw-r--r-- | compiler/GHC/Core/TyCo/Ppr.hs | 40 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/T18522-dbg-ppr.hs | 50 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/T18522-dbg-ppr.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/all.T | 4 |
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']) |