Commit 826d07db authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot
Browse files

Fix debug_ppr_ty ForAllTy (#18522)

Before this change, GHC would
pretty-print   forall k. forall a -> ()
          as   forall @k a. ()
which isn't even valid Haskell.
parent 6770e199
......@@ -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]
......
{-# 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)
forall k{tv}[tv] {j{tv}[tv]}.
forall a{tv}[tv] b{tv}[tv] -> (){(w) tc}
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment