--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternGuards              #-}
{-# LANGUAGE RecordWildCards            #-}
module Profiteur.Core
    ( CostCentre (..)
    , Node (..)
    , nodesFromCostCentre
    , NodeMap (..)
    , nodeMapFromNodes
    , nodeMapFromCostCentre
    ) where


--------------------------------------------------------------------------------
import           Control.Monad       (guard)
import qualified Data.Aeson          as A
import qualified Data.HashMap.Strict as HMS
import           Data.List           (foldl')
import           Data.Maybe          (mapMaybe, maybeToList)
import qualified Data.Text           as T
import qualified Data.Vector         as V


--------------------------------------------------------------------------------
type Id = T.Text


--------------------------------------------------------------------------------
data CostCentre = CostCentre
    { CostCentre -> Id
ccName            :: !T.Text
    , CostCentre -> Id
ccModule          :: !T.Text
    , CostCentre -> Id
ccSrc             :: !T.Text
    , CostCentre -> Id
ccId              :: !Id
    , CostCentre -> Int
ccEntries         :: !Int
    , CostCentre -> Double
ccIndividualTime  :: !Double
    , CostCentre -> Double
ccIndividualAlloc :: !Double
    , CostCentre -> Double
ccInheritedTime   :: !Double
    , CostCentre -> Double
ccInheritedAlloc  :: !Double
    , CostCentre -> Vector CostCentre
ccChildren        :: !(V.Vector CostCentre)
    } deriving (Int -> CostCentre -> ShowS
[CostCentre] -> ShowS
CostCentre -> String
(Int -> CostCentre -> ShowS)
-> (CostCentre -> String)
-> ([CostCentre] -> ShowS)
-> Show CostCentre
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CostCentre -> ShowS
showsPrec :: Int -> CostCentre -> ShowS
$cshow :: CostCentre -> String
show :: CostCentre -> String
$cshowList :: [CostCentre] -> ShowS
showList :: [CostCentre] -> ShowS
Show)


--------------------------------------------------------------------------------
data Node = Node
    { Node -> Id
nId       :: !Id
    , Node -> Id
nName     :: !T.Text
    , Node -> Id
nModule   :: !T.Text
    , Node -> Id
nSrc      :: !T.Text
    , Node -> Int
nEntries  :: !Int
    , Node -> Double
nTime     :: !Double
    , Node -> Double
nAlloc    :: !Double
    , Node -> Vector Id
nChildren :: !(V.Vector Id)
    } deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Returns the node and its (transitive) children.
nodesFromCostCentre :: CostCentre -> Maybe (Node, [Node])
nodesFromCostCentre :: CostCentre -> Maybe (Node, [Node])
nodesFromCostCentre CostCentre
cc
    | Vector CostCentre -> Bool
forall a. Vector a -> Bool
V.null (CostCentre -> Vector CostCentre
ccChildren CostCentre
cc), Just Node
indiv' <- Maybe Node
indiv =
        (Node, [Node]) -> Maybe (Node, [Node])
forall a. a -> Maybe a
Just (Node
indiv' {nId = ccId cc, nName = ccName cc}, [])
    | Bool
otherwise = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ CostCentre -> Double
ccInheritedTime CostCentre
cc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
|| CostCentre -> Double
ccInheritedAlloc CostCentre
cc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0

        let ([Node]
children, [[Node]]
grandChildren) = [(Node, [Node])] -> ([Node], [[Node]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Node, [Node])] -> ([Node], [[Node]]))
-> [(Node, [Node])] -> ([Node], [[Node]])
forall a b. (a -> b) -> a -> b
$
                (CostCentre -> Maybe (Node, [Node]))
-> [CostCentre] -> [(Node, [Node])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CostCentre -> Maybe (Node, [Node])
nodesFromCostCentre (Vector CostCentre -> [CostCentre]
forall a. Vector a -> [a]
V.toList (Vector CostCentre -> [CostCentre])
-> Vector CostCentre -> [CostCentre]
forall a b. (a -> b) -> a -> b
$ CostCentre -> Vector CostCentre
ccChildren CostCentre
cc)

        let allChildren :: [Node]
allChildren = Maybe Node -> [Node]
forall a. Maybe a -> [a]
maybeToList Maybe Node
indiv [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node]
children [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [[Node]] -> [Node]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Node]]
grandChildren

        let self :: Node
self = Node
                { nId :: Id
nId       = CostCentre -> Id
ccId CostCentre
cc
                , nName :: Id
nName     = CostCentre -> Id
ccName CostCentre
cc
                , nModule :: Id
nModule   = CostCentre -> Id
ccModule CostCentre
cc
                , nSrc :: Id
nSrc      = CostCentre -> Id
ccSrc CostCentre
cc
                , nEntries :: Int
nEntries  = CostCentre -> Int
ccEntries CostCentre
cc
                , nTime :: Double
nTime     = CostCentre -> Double
ccInheritedTime CostCentre
cc
                , nAlloc :: Double
nAlloc    = CostCentre -> Double
ccInheritedAlloc CostCentre
cc
                , nChildren :: Vector Id
nChildren = [Id] -> Vector Id
forall a. [a] -> Vector a
V.fromList ([Id] -> Vector Id) -> [Id] -> Vector Id
forall a b. (a -> b) -> a -> b
$ (Node -> Id) -> [Node] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Id
nId ([Node] -> [Id]) -> [Node] -> [Id]
forall a b. (a -> b) -> a -> b
$
                    Maybe Node -> [Node]
forall a. Maybe a -> [a]
maybeToList Maybe Node
indiv [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node]
children
                }

        (Node, [Node]) -> Maybe (Node, [Node])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Node
self, [Node]
allChildren)
  where
    indiv :: Maybe Node
indiv = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ CostCentre -> Double
ccIndividualTime CostCentre
cc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
|| CostCentre -> Double
ccIndividualAlloc CostCentre
cc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
        Node -> Maybe Node
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
            { nId :: Id
nId       = CostCentre -> Id
ccId CostCentre
cc Id -> Id -> Id
forall a. Semigroup a => a -> a -> a
<> Id
".indiv"
            , nName :: Id
nName     = CostCentre -> Id
ccName CostCentre
cc Id -> Id -> Id
forall a. Semigroup a => a -> a -> a
<> Id
" (indiv)"
            , nModule :: Id
nModule   = CostCentre -> Id
ccModule CostCentre
cc
            , nSrc :: Id
nSrc      = CostCentre -> Id
ccSrc CostCentre
cc
            , nEntries :: Int
nEntries  = CostCentre -> Int
ccEntries CostCentre
cc
            , nTime :: Double
nTime     = CostCentre -> Double
ccIndividualTime CostCentre
cc
            , nAlloc :: Double
nAlloc    = CostCentre -> Double
ccIndividualAlloc CostCentre
cc
            , nChildren :: Vector Id
nChildren = Vector Id
forall a. Vector a
V.empty
            }


--------------------------------------------------------------------------------
instance A.ToJSON Node where
    toJSON :: Node -> Value
toJSON Node {Double
Int
Id
Vector Id
nId :: Node -> Id
nName :: Node -> Id
nModule :: Node -> Id
nSrc :: Node -> Id
nEntries :: Node -> Int
nTime :: Node -> Double
nAlloc :: Node -> Double
nChildren :: Node -> Vector Id
nId :: Id
nName :: Id
nModule :: Id
nSrc :: Id
nEntries :: Int
nTime :: Double
nAlloc :: Double
nChildren :: Vector Id
..} = [Value] -> Value
forall a. ToJSON a => a -> Value
A.toJSON
        [ Id -> Value
forall a. ToJSON a => a -> Value
A.toJSON Id
nName
        , Id -> Value
forall a. ToJSON a => a -> Value
A.toJSON Id
nModule
        , Id -> Value
forall a. ToJSON a => a -> Value
A.toJSON Id
nSrc
        , Int -> Value
forall a. ToJSON a => a -> Value
A.toJSON Int
nEntries
        , Double -> Value
forall a. ToJSON a => a -> Value
A.toJSON Double
nTime
        , Double -> Value
forall a. ToJSON a => a -> Value
A.toJSON Double
nAlloc
        , Vector Id -> Value
forall a. ToJSON a => a -> Value
A.toJSON Vector Id
nChildren
        ]


--------------------------------------------------------------------------------
data NodeMap = NodeMap
    { NodeMap -> HashMap Id Node
nmNodes :: !(HMS.HashMap Id Node)
    , NodeMap -> Id
nmRoot  :: !Id
    } deriving (Int -> NodeMap -> ShowS
[NodeMap] -> ShowS
NodeMap -> String
(Int -> NodeMap -> ShowS)
-> (NodeMap -> String) -> ([NodeMap] -> ShowS) -> Show NodeMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeMap -> ShowS
showsPrec :: Int -> NodeMap -> ShowS
$cshow :: NodeMap -> String
show :: NodeMap -> String
$cshowList :: [NodeMap] -> ShowS
showList :: [NodeMap] -> ShowS
Show)


--------------------------------------------------------------------------------
instance A.ToJSON NodeMap where
    toJSON :: NodeMap -> Value
toJSON NodeMap {Id
HashMap Id Node
nmNodes :: NodeMap -> HashMap Id Node
nmRoot :: NodeMap -> Id
nmNodes :: HashMap Id Node
nmRoot :: Id
..} = [Value] -> Value
forall a. ToJSON a => a -> Value
A.toJSON
        [ HashMap Id Node -> Value
forall a. ToJSON a => a -> Value
A.toJSON HashMap Id Node
nmNodes
        , Id -> Value
forall a. ToJSON a => a -> Value
A.toJSON Id
nmRoot
        ]


--------------------------------------------------------------------------------
nodeMapFromNodes :: Id -> [Node] -> NodeMap
nodeMapFromNodes :: Id -> [Node] -> NodeMap
nodeMapFromNodes Id
root [Node]
nodes = NodeMap
    { nmNodes :: HashMap Id Node
nmNodes = (HashMap Id Node -> Node -> HashMap Id Node)
-> HashMap Id Node -> [Node] -> HashMap Id Node
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HashMap Id Node
acc Node
n -> Id -> Node -> HashMap Id Node -> HashMap Id Node
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HMS.insert (Node -> Id
nId Node
n) Node
n HashMap Id Node
acc) HashMap Id Node
forall k v. HashMap k v
HMS.empty [Node]
nodes
    , nmRoot :: Id
nmRoot  = Id
root
    }


--------------------------------------------------------------------------------
nodeMapFromCostCentre :: CostCentre -> NodeMap
nodeMapFromCostCentre :: CostCentre -> NodeMap
nodeMapFromCostCentre CostCentre
root =
    Id -> [Node] -> NodeMap
nodeMapFromNodes (CostCentre -> Id
ccId CostCentre
root) [Node]
nodes
  where
    nodes :: [Node]
nodes = case CostCentre -> Maybe (Node, [Node])
nodesFromCostCentre CostCentre
root of
        Maybe (Node, [Node])
Nothing      -> []
        Just (Node
n, [Node]
ns) -> Node
n Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
ns