-- | This module exports functionality for generating a call graph of
-- an Futhark program.
module Futhark.Analysis.CallGraph
  ( CallGraph,
    buildCallGraph,
    isFunInCallGraph,
    calls,
    calledByConsts,
    allCalledBy,
    numOccurences,
  )
where

import Control.Monad.Writer.Strict
import Data.Map.Strict qualified as M
import Data.Maybe (isJust)
import Data.Set qualified as S
import Futhark.IR
import Futhark.Util.Pretty

type FunctionTable rep = M.Map Name (FunDef rep)

buildFunctionTable :: Prog rep -> FunctionTable rep
buildFunctionTable :: forall rep. Prog rep -> FunctionTable rep
buildFunctionTable = (FunctionTable rep -> FunDef rep -> FunctionTable rep)
-> FunctionTable rep -> [FunDef rep] -> FunctionTable rep
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FunctionTable rep -> FunDef rep -> FunctionTable rep
forall {rep}.
Map Name (FunDef rep) -> FunDef rep -> Map Name (FunDef rep)
expand FunctionTable rep
forall k a. Map k a
M.empty ([FunDef rep] -> FunctionTable rep)
-> (Prog rep -> [FunDef rep]) -> Prog rep -> FunctionTable rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog rep -> [FunDef rep]
forall rep. Prog rep -> [FunDef rep]
progFuns
  where
    expand :: Map Name (FunDef rep) -> FunDef rep -> Map Name (FunDef rep)
expand Map Name (FunDef rep)
ftab FunDef rep
f = Name
-> FunDef rep -> Map Name (FunDef rep) -> Map Name (FunDef rep)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FunDef rep -> Name
forall rep. FunDef rep -> Name
funDefName FunDef rep
f) FunDef rep
f Map Name (FunDef rep)
ftab

-- | A unique (at least within a function) name identifying a function
-- call.  In practice the first element of the corresponding pattern.
type CallId = VName

data FunCalls = FunCalls
  { FunCalls -> Map CallId (Attrs, Name)
fcMap :: M.Map CallId (Attrs, Name),
    FunCalls -> Set Name
fcAllCalled :: S.Set Name
  }
  deriving (FunCalls -> FunCalls -> Bool
(FunCalls -> FunCalls -> Bool)
-> (FunCalls -> FunCalls -> Bool) -> Eq FunCalls
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunCalls -> FunCalls -> Bool
== :: FunCalls -> FunCalls -> Bool
$c/= :: FunCalls -> FunCalls -> Bool
/= :: FunCalls -> FunCalls -> Bool
Eq, Eq FunCalls
Eq FunCalls =>
(FunCalls -> FunCalls -> Ordering)
-> (FunCalls -> FunCalls -> Bool)
-> (FunCalls -> FunCalls -> Bool)
-> (FunCalls -> FunCalls -> Bool)
-> (FunCalls -> FunCalls -> Bool)
-> (FunCalls -> FunCalls -> FunCalls)
-> (FunCalls -> FunCalls -> FunCalls)
-> Ord FunCalls
FunCalls -> FunCalls -> Bool
FunCalls -> FunCalls -> Ordering
FunCalls -> FunCalls -> FunCalls
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FunCalls -> FunCalls -> Ordering
compare :: FunCalls -> FunCalls -> Ordering
$c< :: FunCalls -> FunCalls -> Bool
< :: FunCalls -> FunCalls -> Bool
$c<= :: FunCalls -> FunCalls -> Bool
<= :: FunCalls -> FunCalls -> Bool
$c> :: FunCalls -> FunCalls -> Bool
> :: FunCalls -> FunCalls -> Bool
$c>= :: FunCalls -> FunCalls -> Bool
>= :: FunCalls -> FunCalls -> Bool
$cmax :: FunCalls -> FunCalls -> FunCalls
max :: FunCalls -> FunCalls -> FunCalls
$cmin :: FunCalls -> FunCalls -> FunCalls
min :: FunCalls -> FunCalls -> FunCalls
Ord, Int -> FunCalls -> ShowS
[FunCalls] -> ShowS
FunCalls -> String
(Int -> FunCalls -> ShowS)
-> (FunCalls -> String) -> ([FunCalls] -> ShowS) -> Show FunCalls
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunCalls -> ShowS
showsPrec :: Int -> FunCalls -> ShowS
$cshow :: FunCalls -> String
show :: FunCalls -> String
$cshowList :: [FunCalls] -> ShowS
showList :: [FunCalls] -> ShowS
Show)

instance Monoid FunCalls where
  mempty :: FunCalls
mempty = Map CallId (Attrs, Name) -> Set Name -> FunCalls
FunCalls Map CallId (Attrs, Name)
forall a. Monoid a => a
mempty Set Name
forall a. Monoid a => a
mempty

instance Semigroup FunCalls where
  FunCalls Map CallId (Attrs, Name)
x1 Set Name
y1 <> :: FunCalls -> FunCalls -> FunCalls
<> FunCalls Map CallId (Attrs, Name)
x2 Set Name
y2 = Map CallId (Attrs, Name) -> Set Name -> FunCalls
FunCalls (Map CallId (Attrs, Name)
x1 Map CallId (Attrs, Name)
-> Map CallId (Attrs, Name) -> Map CallId (Attrs, Name)
forall a. Semigroup a => a -> a -> a
<> Map CallId (Attrs, Name)
x2) (Set Name
y1 Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Set Name
y2)

fcCalled :: Name -> FunCalls -> Bool
fcCalled :: Name -> FunCalls -> Bool
fcCalled Name
f FunCalls
fcs = Name
f Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` FunCalls -> Set Name
fcAllCalled FunCalls
fcs

type FunGraph = M.Map Name FunCalls

-- | The call graph is a mapping from a function name, i.e., the
-- caller, to a record of the names of functions called *directly* (not
-- transitively!) by the function.
--
-- We keep track separately of the functions called by constants.
data CallGraph = CallGraph
  { CallGraph -> FunGraph
cgCalledByFuns :: FunGraph,
    CallGraph -> FunCalls
cgCalledByConsts :: FunCalls
  }
  deriving (CallGraph -> CallGraph -> Bool
(CallGraph -> CallGraph -> Bool)
-> (CallGraph -> CallGraph -> Bool) -> Eq CallGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallGraph -> CallGraph -> Bool
== :: CallGraph -> CallGraph -> Bool
$c/= :: CallGraph -> CallGraph -> Bool
/= :: CallGraph -> CallGraph -> Bool
Eq, Eq CallGraph
Eq CallGraph =>
(CallGraph -> CallGraph -> Ordering)
-> (CallGraph -> CallGraph -> Bool)
-> (CallGraph -> CallGraph -> Bool)
-> (CallGraph -> CallGraph -> Bool)
-> (CallGraph -> CallGraph -> Bool)
-> (CallGraph -> CallGraph -> CallGraph)
-> (CallGraph -> CallGraph -> CallGraph)
-> Ord CallGraph
CallGraph -> CallGraph -> Bool
CallGraph -> CallGraph -> Ordering
CallGraph -> CallGraph -> CallGraph
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CallGraph -> CallGraph -> Ordering
compare :: CallGraph -> CallGraph -> Ordering
$c< :: CallGraph -> CallGraph -> Bool
< :: CallGraph -> CallGraph -> Bool
$c<= :: CallGraph -> CallGraph -> Bool
<= :: CallGraph -> CallGraph -> Bool
$c> :: CallGraph -> CallGraph -> Bool
> :: CallGraph -> CallGraph -> Bool
$c>= :: CallGraph -> CallGraph -> Bool
>= :: CallGraph -> CallGraph -> Bool
$cmax :: CallGraph -> CallGraph -> CallGraph
max :: CallGraph -> CallGraph -> CallGraph
$cmin :: CallGraph -> CallGraph -> CallGraph
min :: CallGraph -> CallGraph -> CallGraph
Ord, Int -> CallGraph -> ShowS
[CallGraph] -> ShowS
CallGraph -> String
(Int -> CallGraph -> ShowS)
-> (CallGraph -> String)
-> ([CallGraph] -> ShowS)
-> Show CallGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallGraph -> ShowS
showsPrec :: Int -> CallGraph -> ShowS
$cshow :: CallGraph -> String
show :: CallGraph -> String
$cshowList :: [CallGraph] -> ShowS
showList :: [CallGraph] -> ShowS
Show)

-- | Is the given function known to the call graph?
isFunInCallGraph :: Name -> CallGraph -> Bool
isFunInCallGraph :: Name -> CallGraph -> Bool
isFunInCallGraph Name
f = Name -> FunGraph -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Name
f (FunGraph -> Bool) -> (CallGraph -> FunGraph) -> CallGraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallGraph -> FunGraph
cgCalledByFuns

-- | Does the first function call the second?
calls :: Name -> Name -> CallGraph -> Bool
calls :: Name -> Name -> CallGraph -> Bool
calls Name
caller Name
callee =
  Bool -> (FunCalls -> Bool) -> Maybe FunCalls -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Name -> FunCalls -> Bool
fcCalled Name
callee) (Maybe FunCalls -> Bool)
-> (CallGraph -> Maybe FunCalls) -> CallGraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> FunGraph -> Maybe FunCalls
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
caller (FunGraph -> Maybe FunCalls)
-> (CallGraph -> FunGraph) -> CallGraph -> Maybe FunCalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallGraph -> FunGraph
cgCalledByFuns

-- | Is the function called in any of the constants?
calledByConsts :: Name -> CallGraph -> Bool
calledByConsts :: Name -> CallGraph -> Bool
calledByConsts Name
callee = Name -> FunCalls -> Bool
fcCalled Name
callee (FunCalls -> Bool) -> (CallGraph -> FunCalls) -> CallGraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallGraph -> FunCalls
cgCalledByConsts

-- | All functions called by this function.
allCalledBy :: Name -> CallGraph -> S.Set Name
allCalledBy :: Name -> CallGraph -> Set Name
allCalledBy Name
f = Set Name -> (FunCalls -> Set Name) -> Maybe FunCalls -> Set Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Name
forall a. Monoid a => a
mempty FunCalls -> Set Name
fcAllCalled (Maybe FunCalls -> Set Name)
-> (CallGraph -> Maybe FunCalls) -> CallGraph -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> FunGraph -> Maybe FunCalls
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
f (FunGraph -> Maybe FunCalls)
-> (CallGraph -> FunGraph) -> CallGraph -> Maybe FunCalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallGraph -> FunGraph
cgCalledByFuns

-- | Build the program's call graph.
buildCallGraph :: (TraverseOpStms rep) => Prog rep -> CallGraph
buildCallGraph :: forall rep. TraverseOpStms rep => Prog rep -> CallGraph
buildCallGraph Prog rep
prog =
  FunGraph -> FunCalls -> CallGraph
CallGraph FunGraph
fg FunCalls
cg
  where
    fg :: FunGraph
fg = (FunGraph -> Name -> FunGraph) -> FunGraph -> Set Name -> FunGraph
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (FunctionTable rep -> FunGraph -> Name -> FunGraph
forall rep.
TraverseOpStms rep =>
FunctionTable rep -> FunGraph -> Name -> FunGraph
buildFGfun FunctionTable rep
ftable) FunGraph
forall k a. Map k a
M.empty Set Name
entry_points
    cg :: FunCalls
cg = Stms rep -> FunCalls
forall rep. TraverseOpStms rep => Stms rep -> FunCalls
buildFGStms (Stms rep -> FunCalls) -> Stms rep -> FunCalls
forall a b. (a -> b) -> a -> b
$ Prog rep -> Stms rep
forall rep. Prog rep -> Stms rep
progConsts Prog rep
prog

    entry_points :: Set Name
entry_points =
      [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ((FunDef rep -> Name) -> [FunDef rep] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FunDef rep -> Name
forall rep. FunDef rep -> Name
funDefName ((FunDef rep -> Bool) -> [FunDef rep] -> [FunDef rep]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe EntryPoint -> Bool
forall a. Maybe a -> Bool
isJust (Maybe EntryPoint -> Bool)
-> (FunDef rep -> Maybe EntryPoint) -> FunDef rep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunDef rep -> Maybe EntryPoint
forall rep. FunDef rep -> Maybe EntryPoint
funDefEntryPoint) ([FunDef rep] -> [FunDef rep]) -> [FunDef rep] -> [FunDef rep]
forall a b. (a -> b) -> a -> b
$ Prog rep -> [FunDef rep]
forall rep. Prog rep -> [FunDef rep]
progFuns Prog rep
prog))
        Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> FunCalls -> Set Name
fcAllCalled FunCalls
cg
    ftable :: FunctionTable rep
ftable = Prog rep -> FunctionTable rep
forall rep. Prog rep -> FunctionTable rep
buildFunctionTable Prog rep
prog

count :: (Ord k) => [k] -> M.Map k Int
count :: forall k. Ord k => [k] -> Map k Int
count [k]
ks = (Int -> Int -> Int) -> [(k, Int)] -> Map k Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(k, Int)] -> Map k Int) -> [(k, Int)] -> Map k Int
forall a b. (a -> b) -> a -> b
$ (k -> (k, Int)) -> [k] -> [(k, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,Int
1) [k]
ks

-- | Produce a mapping of the number of occurences in the call graph
-- of each function.  Only counts functions that are called at least
-- once.
numOccurences :: CallGraph -> M.Map Name Int
numOccurences :: CallGraph -> Map Name Int
numOccurences (CallGraph FunGraph
funs FunCalls
consts) =
  [Name] -> Map Name Int
forall k. Ord k => [k] -> Map k Int
count ([Name] -> Map Name Int) -> [Name] -> Map Name Int
forall a b. (a -> b) -> a -> b
$ ((Attrs, Name) -> Name) -> [(Attrs, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Attrs, Name) -> Name
forall a b. (a, b) -> b
snd ([(Attrs, Name)] -> [Name]) -> [(Attrs, Name)] -> [Name]
forall a b. (a -> b) -> a -> b
$ Map CallId (Attrs, Name) -> [(Attrs, Name)]
forall k a. Map k a -> [a]
M.elems (FunCalls -> Map CallId (Attrs, Name)
fcMap FunCalls
consts Map CallId (Attrs, Name)
-> Map CallId (Attrs, Name) -> Map CallId (Attrs, Name)
forall a. Semigroup a => a -> a -> a
<> (FunCalls -> Map CallId (Attrs, Name))
-> [FunCalls] -> Map CallId (Attrs, Name)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap FunCalls -> Map CallId (Attrs, Name)
fcMap (FunGraph -> [FunCalls]
forall k a. Map k a -> [a]
M.elems FunGraph
funs))

-- | @buildCallGraph ftable fg fname@ updates @fg@ with the
-- contributions of function @fname@.
buildFGfun :: (TraverseOpStms rep) => FunctionTable rep -> FunGraph -> Name -> FunGraph
buildFGfun :: forall rep.
TraverseOpStms rep =>
FunctionTable rep -> FunGraph -> Name -> FunGraph
buildFGfun FunctionTable rep
ftable FunGraph
fg Name
fname =
  -- Check if function is a non-builtin that we have not already
  -- processed.
  case Name -> FunctionTable rep -> Maybe (FunDef rep)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname FunctionTable rep
ftable of
    Just FunDef rep
f | Maybe FunCalls
Nothing <- Name -> FunGraph -> Maybe FunCalls
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname FunGraph
fg -> do
      let callees :: FunCalls
callees = Body rep -> FunCalls
forall rep. TraverseOpStms rep => Body rep -> FunCalls
buildFGBody (Body rep -> FunCalls) -> Body rep -> FunCalls
forall a b. (a -> b) -> a -> b
$ FunDef rep -> Body rep
forall rep. FunDef rep -> Body rep
funDefBody FunDef rep
f
          fg' :: FunGraph
fg' = Name -> FunCalls -> FunGraph -> FunGraph
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
fname FunCalls
callees FunGraph
fg
      -- recursively build the callees
      (FunGraph -> Name -> FunGraph) -> FunGraph -> Set Name -> FunGraph
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (FunctionTable rep -> FunGraph -> Name -> FunGraph
forall rep.
TraverseOpStms rep =>
FunctionTable rep -> FunGraph -> Name -> FunGraph
buildFGfun FunctionTable rep
ftable) FunGraph
fg' (Set Name -> FunGraph) -> Set Name -> FunGraph
forall a b. (a -> b) -> a -> b
$ FunCalls -> Set Name
fcAllCalled FunCalls
callees
    Maybe (FunDef rep)
_ -> FunGraph
fg

buildFGStms :: (TraverseOpStms rep) => Stms rep -> FunCalls
buildFGStms :: forall rep. TraverseOpStms rep => Stms rep -> FunCalls
buildFGStms = [FunCalls] -> FunCalls
forall a. Monoid a => [a] -> a
mconcat ([FunCalls] -> FunCalls)
-> (Stms rep -> [FunCalls]) -> Stms rep -> FunCalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stm rep -> FunCalls) -> [Stm rep] -> [FunCalls]
forall a b. (a -> b) -> [a] -> [b]
map Stm rep -> FunCalls
forall rep. TraverseOpStms rep => Stm rep -> FunCalls
buildFGstm ([Stm rep] -> [FunCalls])
-> (Stms rep -> [Stm rep]) -> Stms rep -> [FunCalls]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stms rep -> [Stm rep]
forall rep. Stms rep -> [Stm rep]
stmsToList

buildFGBody :: (TraverseOpStms rep) => Body rep -> FunCalls
buildFGBody :: forall rep. TraverseOpStms rep => Body rep -> FunCalls
buildFGBody = Stms rep -> FunCalls
forall rep. TraverseOpStms rep => Stms rep -> FunCalls
buildFGStms (Stms rep -> FunCalls)
-> (Body rep -> Stms rep) -> Body rep -> FunCalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body rep -> Stms rep
forall rep res. GBody rep res -> Stms rep
bodyStms

buildFGstm :: (TraverseOpStms rep) => Stm rep -> FunCalls
buildFGstm :: forall rep. TraverseOpStms rep => Stm rep -> FunCalls
buildFGstm (Let (Pat (PatElem (LetDec rep)
p : [PatElem (LetDec rep)]
_)) StmAux (ExpDec rep)
aux (Apply Name
fname [(SubExp, Diet)]
_ [(RetType rep, RetAls)]
_ Safety
_)) =
  Map CallId (Attrs, Name) -> Set Name -> FunCalls
FunCalls (CallId -> (Attrs, Name) -> Map CallId (Attrs, Name)
forall k a. k -> a -> Map k a
M.singleton (PatElem (LetDec rep) -> CallId
forall dec. PatElem dec -> CallId
patElemName PatElem (LetDec rep)
p) (StmAux (ExpDec rep) -> Attrs
forall dec. StmAux dec -> Attrs
stmAuxAttrs StmAux (ExpDec rep)
aux, Name
fname)) (Name -> Set Name
forall a. a -> Set a
S.singleton Name
fname)
buildFGstm (Let Pat (LetDec rep)
_ StmAux (ExpDec rep)
_ (Op Op rep
op)) = Writer FunCalls (Op rep) -> FunCalls
forall w a. Writer w a -> w
execWriter (Writer FunCalls (Op rep) -> FunCalls)
-> Writer FunCalls (Op rep) -> FunCalls
forall a b. (a -> b) -> a -> b
$ OpStmsTraverser (WriterT FunCalls Identity) (Op rep) rep
forall rep (m :: * -> *).
(TraverseOpStms rep, Monad m) =>
OpStmsTraverser m (Op rep) rep
forall (m :: * -> *). Monad m => OpStmsTraverser m (Op rep) rep
traverseOpStms Scope rep -> Stms rep -> WriterT FunCalls Identity (Stms rep)
forall {m :: * -> *} {rep} {p}.
(MonadWriter FunCalls m, TraverseOpStms rep) =>
p -> Stms rep -> m (Stms rep)
onStms Op rep
op
  where
    onStms :: p -> Stms rep -> m (Stms rep)
onStms p
_ Stms rep
stms = do
      FunCalls -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (FunCalls -> m ()) -> FunCalls -> m ()
forall a b. (a -> b) -> a -> b
$ Stms rep -> FunCalls
forall rep. TraverseOpStms rep => Stms rep -> FunCalls
buildFGStms Stms rep
stms
      Stms rep -> m (Stms rep)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stms rep
stms
buildFGstm (Let Pat (LetDec rep)
_ StmAux (ExpDec rep)
_ Exp rep
e) = Writer FunCalls (Exp rep) -> FunCalls
forall w a. Writer w a -> w
execWriter (Writer FunCalls (Exp rep) -> FunCalls)
-> Writer FunCalls (Exp rep) -> FunCalls
forall a b. (a -> b) -> a -> b
$ Mapper rep rep (WriterT FunCalls Identity)
-> Exp rep -> Writer FunCalls (Exp rep)
forall (m :: * -> *) frep trep.
Monad m =>
Mapper frep trep m -> Exp frep -> m (Exp trep)
mapExpM Mapper rep rep (WriterT FunCalls Identity)
folder Exp rep
e
  where
    folder :: Mapper rep rep (WriterT FunCalls Identity)
folder =
      Mapper rep rep (WriterT FunCalls Identity)
forall rep (m :: * -> *). Monad m => Mapper rep rep m
identityMapper
        { mapOnBody = \Scope rep
_ Body rep
body -> do
            FunCalls -> WriterT FunCalls Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (FunCalls -> WriterT FunCalls Identity ())
-> FunCalls -> WriterT FunCalls Identity ()
forall a b. (a -> b) -> a -> b
$ Body rep -> FunCalls
forall rep. TraverseOpStms rep => Body rep -> FunCalls
buildFGBody Body rep
body
            Body rep -> WriterT FunCalls Identity (Body rep)
forall a. a -> WriterT FunCalls Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Body rep
body
        }

instance Pretty FunCalls where
  pretty :: forall ann. FunCalls -> Doc ann
pretty = [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
stack ([Doc ann] -> Doc ann)
-> (FunCalls -> [Doc ann]) -> FunCalls -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CallId, (Attrs, Name)) -> Doc ann)
-> [(CallId, (Attrs, Name))] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (CallId, (Attrs, Name)) -> Doc ann
forall {a} {a} {a} {ann}.
(Pretty a, Pretty a, Pretty a) =>
(a, (a, a)) -> Doc ann
f ([(CallId, (Attrs, Name))] -> [Doc ann])
-> (FunCalls -> [(CallId, (Attrs, Name))]) -> FunCalls -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CallId (Attrs, Name) -> [(CallId, (Attrs, Name))]
forall k a. Map k a -> [(k, a)]
M.toList (Map CallId (Attrs, Name) -> [(CallId, (Attrs, Name))])
-> (FunCalls -> Map CallId (Attrs, Name))
-> FunCalls
-> [(CallId, (Attrs, Name))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunCalls -> Map CallId (Attrs, Name)
fcMap
    where
      f :: (a, (a, a)) -> Doc ann
f (a
x, (a
attrs, a
y)) = Doc ann
"=>" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
y Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"at" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
attrs)

instance Pretty CallGraph where
  pretty :: forall ann. CallGraph -> Doc ann
pretty (CallGraph FunGraph
fg FunCalls
cg) =
    [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
stack ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
      Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
line ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
        (Name, FunCalls) -> Doc ann
forall {a} {a}. Pretty a => (Name, a) -> Doc a
ppFunCalls (Name
"called at top level", FunCalls
cg) Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((Name, FunCalls) -> Doc ann) -> [(Name, FunCalls)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Name, FunCalls) -> Doc ann
forall {a} {a}. Pretty a => (Name, a) -> Doc a
ppFunCalls (FunGraph -> [(Name, FunCalls)]
forall k a. Map k a -> [(k, a)]
M.toList FunGraph
fg)
    where
      ppFunCalls :: (Name, a) -> Doc a
ppFunCalls (Name
f, a
fcalls) =
        Name -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty Name
f
          Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
</> String -> Doc a
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'=') (Name -> String
nameToString Name
f))
          Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
</> Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (a -> Doc a
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
fcalls)