[Git][ghc/ghc][wip/t18522] Fix debug_ppr_ty ForAllTy (#18522)

[Vladislav Zavialov]

Vladislav Zavialov pushed to branch wip/t18522 at Glasgow Haskell Compiler / GHC


Commits:
b61598c7 by Vladislav Zavialov at 2020-08-04T21:26:20+03:00
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.

- - - - -


4 changed files:

- compiler/GHC/Core/TyCo/Ppr.hs
- + testsuite/tests/ghc-api/T18522-dbg-ppr.hs
- + testsuite/tests/ghc-api/T18522-dbg-ppr.stdout
- testsuite/tests/ghc-api/all.T


Changes:

=====================================
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,32 @@ 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 kind-annotated 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 kind-annotated 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]


=====================================
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)


=====================================
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}


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b61598c750b9ab5d719dd6df5119c9007cb8e5bd

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b61598c750b9ab5d719dd6df5119c9007cb8e5bd
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200804/3fef6d2b/attachment-0001.html>