{-# LANGUAGE ViewPatterns #-}
-- | Functions for computing retainers
module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainers, addLocationToStack, displayRetainerStack, addLocationToStack', displayRetainerStack') where

import GHC.Debug.Client
import Control.Monad.State
import GHC.Debug.Trace
import GHC.Debug.Types.Graph

import qualified Data.Set as Set
import Control.Monad.RWS

addOne :: [ClosurePtr] -> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne :: [ClosurePtr]
-> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne [ClosurePtr]
_ (Just Int
0, [[ClosurePtr]]
cp) = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0, [[ClosurePtr]]
cp)
addOne [ClosurePtr]
cp (Maybe Int
n, [[ClosurePtr]]
cps)    = (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
n, [ClosurePtr]
cp[ClosurePtr] -> [[ClosurePtr]] -> [[ClosurePtr]]
forall a. a -> [a] -> [a]
:[[ClosurePtr]]
cps)

findRetainersOf :: Maybe Int
                -> [ClosurePtr]
                -> [ClosurePtr]
                -> DebugM [[ClosurePtr]]
findRetainersOf :: Maybe Int -> [ClosurePtr] -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainersOf Maybe Int
limit [ClosurePtr]
cps [ClosurePtr]
bads = Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
cps (\ClosurePtr
cp SizedClosure
_ -> Bool -> DebugM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr
cp ClosurePtr -> Set ClosurePtr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ClosurePtr
bad_set))
  where
    bad_set :: Set ClosurePtr
bad_set = [ClosurePtr] -> Set ClosurePtr
forall a. Ord a => [a] -> Set a
Set.fromList [ClosurePtr]
bads

findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructor Maybe Int
limit [ClosurePtr]
rroots String
con_name =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
forall {p} {pap} {s} {b}.
p -> DebugClosureWithSize pap ConstrDescCont s b -> DebugM Bool
go
  where
    go :: p -> DebugClosureWithSize pap ConstrDescCont s b -> DebugM Bool
go p
_ DebugClosureWithSize pap ConstrDescCont s b
sc =
      case DebugClosureWithSize pap ConstrDescCont s b
-> DebugClosure pap ConstrDescCont s b
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize pap ConstrDescCont s b
sc of
        ConstrClosure StgInfoTableWithPtr
_ [b]
_ [Word]
_ ConstrDescCont
cd -> do
          ConstrDesc String
_ String
_  String
cname <- ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc ConstrDescCont
cd
          Bool -> DebugM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ String
cname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
con_name
        DebugClosure pap ConstrDescCont s b
_ -> Bool -> DebugM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ Bool
False

findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructorExact Maybe Int
limit [ClosurePtr]
rroots String
clos_name =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
forall {p} {pap} {string} {s} {b}.
p -> DebugClosureWithSize pap string s b -> DebugM Bool
go
  where
    go :: p -> DebugClosureWithSize pap string s b -> DebugM Bool
go p
_ DebugClosureWithSize pap string s b
sc = do
      Maybe SourceInformation
loc <- ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure pap string s b -> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize pap string s b -> DebugClosure pap string s b
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize pap string s b
sc)))
      case Maybe SourceInformation
loc of
        Maybe SourceInformation
Nothing -> Bool -> DebugM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SourceInformation
cur_loc ->

          Bool -> DebugM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ (SourceInformation -> String
infoName SourceInformation
cur_loc) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
clos_name

-- | From the given roots, find any path to one of the given pointers.
-- Note: This function can be quite slow! The first argument is a limit to
-- how many paths to find. You should normally set this to a small number
-- such as 10.
findRetainers :: Maybe Int -> [ClosurePtr] -> (ClosurePtr -> SizedClosure -> DebugM Bool) -> DebugM [[ClosurePtr]]
findRetainers :: Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
p = (\(()
_, (Maybe Int, [[ClosurePtr]])
r, ()
_) -> (Maybe Int, [[ClosurePtr]]) -> [[ClosurePtr]]
forall a b. (a, b) -> b
snd (Maybe Int, [[ClosurePtr]])
r) (((), (Maybe Int, [[ClosurePtr]]), ()) -> [[ClosurePtr]])
-> DebugM ((), (Maybe Int, [[ClosurePtr]]), ())
-> DebugM [[ClosurePtr]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> [ClosurePtr]
-> (Maybe Int, [[ClosurePtr]])
-> DebugM ((), (Maybe Int, [[ClosurePtr]]), ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (TraceFunctions (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
-> [ClosurePtr]
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
funcs [ClosurePtr]
rroots) [] (Maybe Int
limit, [])
  where
    funcs :: TraceFunctions (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
papTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> GenPapPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
stackTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> GenStackFrames ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closAccum
              , visitedVal :: ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
visitedVal = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
conDescTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> ConstrDesc
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add clos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
    closAccum :: ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closAccum ClosurePtr
_ (SizedClosure
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize -> WeakClosure {}) RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
_ = () -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    closAccum ClosurePtr
cp SizedClosure
sc RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k = do
      Bool
b <- DebugM Bool
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM Bool
 -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool)
-> DebugM Bool
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> SizedClosure -> DebugM Bool
p ClosurePtr
cp SizedClosure
sc
      if Bool
b
        then do
          [ClosurePtr]
ctx <- RWST
  [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM [ClosurePtr]
forall r (m :: * -> *). MonadReader r m => m r
ask
          ((Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]]))
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ([ClosurePtr]
-> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne (ClosurePtr
cpClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
: [ClosurePtr]
ctx))
          ([ClosurePtr] -> [ClosurePtr])
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ClosurePtr
cpClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
:) RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k
          -- Don't call k, there might be more paths to the pointer but we
          -- probably just care about this first one.
        else do
          (Maybe Int
lim, [[ClosurePtr]]
_) <- RWST
  [ClosurePtr]
  ()
  (Maybe Int, [[ClosurePtr]])
  DebugM
  (Maybe Int, [[ClosurePtr]])
forall s (m :: * -> *). MonadState s m => m s
get
          case Maybe Int
lim of
            Just Int
0 -> () -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe Int
_ -> ([ClosurePtr] -> [ClosurePtr])
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ClosurePtr
cpClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
:) RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k

addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)]
addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)]
addLocationToStack [ClosurePtr]
r = do
  [SizedClosure]
cs <- [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
r
  [SizedClosureC]
cs' <- (SizedClosure -> DebugM SizedClosureC)
-> [SizedClosure] -> DebugM [SizedClosureC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((PayloadCont -> DebugM PayloadCont)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM SizedClosureC
forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse PayloadCont -> DebugM PayloadCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- (SizedClosureC -> DebugM (Maybe SourceInformation))
-> [SizedClosureC] -> DebugM [Maybe SourceInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SizedClosureC -> DebugM (Maybe SourceInformation)
forall {pap} {string} {s} {b}.
DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureC]
cs'
  return $ ([SizedClosureC]
-> [Maybe SourceInformation]
-> [(SizedClosureC, Maybe SourceInformation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SizedClosureC]
cs' [Maybe SourceInformation]
locs)
  where
    getSourceLoc :: DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize pap string s b
c = ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure pap string s b -> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize pap string s b -> DebugClosure pap string s b
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize pap string s b
c)))

addLocationToStack' :: [ClosurePtr] -> DebugM [(ClosurePtr, SizedClosureC, Maybe SourceInformation)]
addLocationToStack' :: [ClosurePtr]
-> DebugM [(ClosurePtr, SizedClosureC, Maybe SourceInformation)]
addLocationToStack' [ClosurePtr]
r = do
  [SizedClosure]
cs <- [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
r
  [SizedClosureC]
cs' <- (SizedClosure -> DebugM SizedClosureC)
-> [SizedClosure] -> DebugM [SizedClosureC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((PayloadCont -> DebugM PayloadCont)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM SizedClosureC
forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse PayloadCont -> DebugM PayloadCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- (SizedClosureC -> DebugM (Maybe SourceInformation))
-> [SizedClosureC] -> DebugM [Maybe SourceInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SizedClosureC -> DebugM (Maybe SourceInformation)
forall {pap} {string} {s} {b}.
DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureC]
cs'
  return $ ([ClosurePtr]
-> [SizedClosureC]
-> [Maybe SourceInformation]
-> [(ClosurePtr, SizedClosureC, Maybe SourceInformation)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ClosurePtr]
r [SizedClosureC]
cs' [Maybe SourceInformation]
locs)
  where
    getSourceLoc :: DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize pap string s b
c = ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure pap string s b -> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize pap string s b -> DebugClosure pap string s b
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize pap string s b
c)))

displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO ()
displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO ()
displayRetainerStack [(String, [(SizedClosureC, Maybe SourceInformation)])]
rs = do
      let disp :: (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
disp (DebugClosureWithSize p ConstrDesc s c
d, Maybe SourceInformation
l) =
            (String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
forall c p s.
String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
ppClosure String
""  (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure p ConstrDesc s c -> String)
-> (DebugClosureWithSize p ConstrDesc s c
    -> DebugClosure p ConstrDesc s c)
-> DebugClosureWithSize p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize p ConstrDesc s c
-> DebugClosure p ConstrDesc s c
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize (DebugClosureWithSize p ConstrDesc s c -> String)
-> DebugClosureWithSize p ConstrDesc s c -> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize p ConstrDesc s c
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (SourceInformation -> String)
-> Maybe SourceInformation
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"nl" SourceInformation -> String
tdisplay Maybe SourceInformation
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoPosition SourceInformation
sl
          do_one :: a
-> (a,
    t (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
stack) = do
            String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            a -> IO ()
forall a. Show a => a -> IO ()
print a
l
            ((DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
 -> IO ())
-> t (DebugClosureWithSize p ConstrDesc s c,
      Maybe SourceInformation)
-> IO (t ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
putStrLn (String -> IO ())
-> ((DebugClosureWithSize p ConstrDesc s c,
     Maybe SourceInformation)
    -> String)
-> (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
forall {c} {p} {s}.
Show c =>
(DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
disp) t (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
stack
      (Int
 -> (String, [(SizedClosureC, Maybe SourceInformation)]) -> IO [()])
-> [Int]
-> [(String, [(SizedClosureC, Maybe SourceInformation)])]
-> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> (String, [(SizedClosureC, Maybe SourceInformation)]) -> IO [()]
forall {t :: * -> *} {a} {a} {c} {p} {s}.
(Traversable t, Show a, Show a, Show c) =>
a
-> (a,
    t (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(SizedClosureC, Maybe SourceInformation)])]
rs

displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])] -> IO ()
displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])]
-> IO ()
displayRetainerStack' [(String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])]
rs = do
      let disp :: (a, DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
disp (a
p, DebugClosureWithSize p ConstrDesc s c
d, Maybe SourceInformation
l) =
            a -> String
forall a. Show a => a -> String
show a
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
forall c p s.
String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
ppClosure String
""  (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure p ConstrDesc s c -> String)
-> (DebugClosureWithSize p ConstrDesc s c
    -> DebugClosure p ConstrDesc s c)
-> DebugClosureWithSize p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize p ConstrDesc s c
-> DebugClosure p ConstrDesc s c
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize (DebugClosureWithSize p ConstrDesc s c -> String)
-> DebugClosureWithSize p ConstrDesc s c -> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize p ConstrDesc s c
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (SourceInformation -> String)
-> Maybe SourceInformation
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"nl" SourceInformation -> String
tdisplay Maybe SourceInformation
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoPosition SourceInformation
sl
          do_one :: a
-> (a,
    t (a, DebugClosureWithSize p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (a, DebugClosureWithSize p ConstrDesc s c,
   Maybe SourceInformation)
stack) = do
            String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            a -> IO ()
forall a. Show a => a -> IO ()
print a
l
            ((a, DebugClosureWithSize p ConstrDesc s c,
  Maybe SourceInformation)
 -> IO ())
-> t (a, DebugClosureWithSize p ConstrDesc s c,
      Maybe SourceInformation)
-> IO (t ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
putStrLn (String -> IO ())
-> ((a, DebugClosureWithSize p ConstrDesc s c,
     Maybe SourceInformation)
    -> String)
-> (a, DebugClosureWithSize p ConstrDesc s c,
    Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
forall {a} {c} {p} {s}.
(Show a, Show c) =>
(a, DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
disp) t (a, DebugClosureWithSize p ConstrDesc s c,
   Maybe SourceInformation)
stack
      (Int
 -> (String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])
 -> IO [()])
-> [Int]
-> [(String,
     [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])]
-> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> (String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])
-> IO [()]
forall {t :: * -> *} {a} {a} {a} {c} {p} {s}.
(Traversable t, Show a, Show a, Show a, Show c) =>
a
-> (a,
    t (a, DebugClosureWithSize p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])]
rs