{-# 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)
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