[Git][ghc/ghc][wip/ozkutuk/sprint-fun] Disambiguate closures' printing from thunks (#23507)

[Berk Ozkutuk (@ozkutuk)]

Berk Ozkutuk pushed to branch wip/ozkutuk/sprint-fun at Glasgow Haskell Compiler / GHC


Commits:
d3a173ba by Berk Ozkutuk at 2023-06-15T11:22:57+02:00
Disambiguate closures' printing from thunks (#23507)

- - - - -


7 changed files:

- compiler/GHC/Runtime/Heap/Inspect.hs
- testsuite/tests/ghci/scripts/T14828.stdout
- + testsuite/tests/ghci/scripts/T23507.script
- + testsuite/tests/ghci/scripts/T23507.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/scripts/ghci055.stdout
- testsuite/tests/ghci/scripts/shadow-bindings.stdout


Changes:

=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -37,6 +38,7 @@ import GHC.Types.RepType
 import GHC.Core.Multiplicity
 import qualified GHC.Core.Unify as U
 import GHC.Core.TyCon
+import GHC.Core.TyCo.Rep (Type(..))
 
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.TcType
@@ -331,6 +333,7 @@ cPprTermBase y =
   , ifTerm' (isTyCon doubleTyCon  . ty) ppr_double
   , ifTerm' (isTyCon integerTyCon . ty) ppr_integer
   , ifTerm' (isTyCon naturalTyCon . ty) ppr_natural
+  , ifSuspension         (isFunTy . ty) ppr_fun
   ]
  where
    ifTerm :: (Term -> Bool)
@@ -345,6 +348,18 @@ cPprTermBase y =
        | pred t    = f prec t
    ifTerm' _ _ _ _  = return Nothing
 
+   ifSuspension :: (Term -> Bool)
+          -> (Precedence -> Term -> m (Maybe SDoc))
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifSuspension pred f prec t at Suspension{}
+       | pred t    = f prec t
+   ifSuspension _ _ _ _  = return Nothing
+
+   isFunTy :: Type -> Bool
+   isFunTy (FunTy {}) = True
+   isFunTy (ForAllTy {}) = True
+   isFunTy _ = False
+
    isTupleTy ty    = fromMaybe False $ do
      (tc,_) <- tcSplitTyConApp_maybe ty
      return (isBoxedTupleTyCon tc)
@@ -459,6 +474,10 @@ cPprTermBase y =
               getListTerms t = pprPanic "getListTerms" (ppr t)
    ppr_list _ _ = panic "doList"
 
+   ppr_fun :: Precedence -> Term -> m (Maybe SDoc)
+   ppr_fun _ (ty -> fun_ty) = return $ Just $
+     angleBrackets (underscore <+> dcolon <+> pprType fun_ty)
+
 
 repPrim :: TyCon -> [Word] -> SDoc
 repPrim t = rep where


=====================================
testsuite/tests/ghci/scripts/T14828.stdout
=====================================
@@ -1,12 +1,18 @@
 foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b
-foldl = (_t1::Foldable t => (b -> a -> b) -> b -> t a -> b)
+foldl = <_ :: forall (t :: * -> *) b a.
+              Foldable t =>
+              (b -> a -> b) -> b -> t a -> b>
 fmap :: Functor f => (a -> b) -> f a -> f b
-fmap = (_t2::Functor f => (a -> b) -> f a -> f b)
+fmap = <_ :: forall (f :: * -> *) a b.
+             Functor f =>
+             (a -> b) -> f a -> f b>
 return :: Monad m => a -> m a
-return = (_t3::Monad m => a -> m a)
+return = <_ :: forall (m :: * -> *) a. Monad m => a -> m a>
 pure :: Applicative f => a -> f a
-pure = (_t4::Applicative f => a -> f a)
-mempty = (_t5::Monoid a => a)
-mappend = (_t6::Monoid a => a -> a -> a)
-foldl' = (_t7::Foldable t => (b -> a -> b) -> b -> t a -> b)
-f = (_t8::(forall a. a -> a) -> b -> b)
+pure = <_ :: forall (f :: * -> *) a. Applicative f => a -> f a>
+mempty = <_ :: forall a. Monoid a => a>
+mappend = <_ :: forall a. Monoid a => a -> a -> a>
+foldl' = <_ :: forall (t :: * -> *) b a.
+               Foldable t =>
+               (b -> a -> b) -> b -> t a -> b>
+f = <_ :: forall b. (forall a. a -> a) -> b -> b>


=====================================
testsuite/tests/ghci/scripts/T23507.script
=====================================
@@ -0,0 +1,4 @@
+let f () = ()
+:sprint f
+let x = 3
+:sprint x


=====================================
testsuite/tests/ghci/scripts/T23507.stdout
=====================================
@@ -0,0 +1,2 @@
+f = <_ :: () -> ()>
+x = <_ :: forall {a}. Num a => a>


=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -375,3 +375,4 @@ test('T22695', normal, ghci_script, ['T22695.script'])
 test('T22817', normal, ghci_script, ['T22817.script'])
 test('T22908', normal, ghci_script, ['T22908.script'])
 test('T23062', normal, ghci_script, ['T23062.script'])
+test('T23507', normal, ghci_script, ['T23507.script'])


=====================================
testsuite/tests/ghci/scripts/ghci055.stdout
=====================================
@@ -1,5 +1,5 @@
 *** Exception: Prelude.undefined
 CallStack (from HasCallStack):
   undefined, called at <interactive>:1:7 in interactive:Ghci1
-x :: a = _
+x :: a = <_ :: forall {a}. a>
 y :: Int = 3


=====================================
testsuite/tests/ghci/scripts/shadow-bindings.stdout
=====================================
@@ -27,7 +27,7 @@ it :: () = ()
 Expecting T and foo with function type
 type T :: *
 data T = ...
-foo :: T -> Bool = _
+foo :: T -> Bool = <_ :: T -> Bool>
 it :: () = ()
 Expecting T and foo :: Bool
 type T :: *



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3a173baa56ccb439cce673214cbf1a84d1fa163
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/20230615/cfbbcf3c/attachment-0001.html>