--------------------------------------------------------------------------------
{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CostCentre] -> ShowS
$cshowList :: [CostCentre] -> ShowS
show :: CostCentre -> String
$cshow :: CostCentre -> String
showsPrec :: Int -> CostCentre -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show)


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

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

        let allChildren :: [Node]
allChildren = forall a. Maybe a -> [a]
maybeToList Maybe Node
indiv forall a. [a] -> [a] -> [a]
++ [Node]
children forall a. [a] -> [a] -> [a]
++ 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 = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Node -> Id
nId forall a b. (a -> b) -> a -> b
$
                    forall a. Maybe a -> [a]
maybeToList Maybe Node
indiv forall a. [a] -> [a] -> [a]
++ [Node]
children
                }

        forall (m :: * -> *) a. Monad m => a -> m a
return (Node
self, [Node]
allChildren)
  where
    indiv :: Maybe Node
indiv = do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ CostCentre -> Double
ccIndividualTime CostCentre
cc forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
|| CostCentre -> Double
ccIndividualAlloc CostCentre
cc forall a. Ord a => a -> a -> Bool
> Double
0
        forall (m :: * -> *) a. Monad m => a -> m a
return Node
            { nId :: Id
nId       = CostCentre -> Id
ccId CostCentre
cc forall a. Semigroup a => a -> a -> a
<> Id
".indiv"
            , nName :: Id
nName     = CostCentre -> Id
ccName CostCentre
cc 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 = forall a. Vector a
V.empty
            }


--------------------------------------------------------------------------------
instance A.ToJSON Node where
    toJSON :: Node -> Value
toJSON Node {Double
Int
Id
Vector Id
nChildren :: Vector Id
nAlloc :: Double
nTime :: Double
nEntries :: Int
nSrc :: Id
nModule :: Id
nName :: Id
nId :: Id
nChildren :: Node -> Vector Id
nAlloc :: Node -> Double
nTime :: Node -> Double
nEntries :: Node -> Int
nSrc :: Node -> Id
nModule :: Node -> Id
nName :: Node -> Id
nId :: Node -> Id
..} = forall a. ToJSON a => a -> Value
A.toJSON
        [ forall a. ToJSON a => a -> Value
A.toJSON Id
nName
        , forall a. ToJSON a => a -> Value
A.toJSON Id
nModule
        , forall a. ToJSON a => a -> Value
A.toJSON Id
nSrc
        , forall a. ToJSON a => a -> Value
A.toJSON Int
nEntries
        , forall a. ToJSON a => a -> Value
A.toJSON Double
nTime
        , forall a. ToJSON a => a -> Value
A.toJSON Double
nAlloc
        , 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeMap] -> ShowS
$cshowList :: [NodeMap] -> ShowS
show :: NodeMap -> String
$cshow :: NodeMap -> String
showsPrec :: Int -> NodeMap -> ShowS
$cshowsPrec :: Int -> NodeMap -> ShowS
Show)


--------------------------------------------------------------------------------
instance A.ToJSON NodeMap where
    toJSON :: NodeMap -> Value
toJSON NodeMap {Id
HashMap Id Node
nmRoot :: Id
nmNodes :: HashMap Id Node
nmRoot :: NodeMap -> Id
nmNodes :: NodeMap -> HashMap Id Node
..} = forall a. ToJSON a => a -> Value
A.toJSON
        [ forall a. ToJSON a => a -> Value
A.toJSON HashMap Id Node
nmNodes
        , 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HashMap Id Node
acc Node
n -> forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMS.insert (Node -> Id
nId Node
n) Node
n HashMap Id Node
acc) 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 forall a. a -> [a] -> [a]
: [Node]
ns