module Penny.Cabin.Balance.Util
( tieredForest
, tieredPostings
, filterForest
, balances
, flatten
, treeWithParents
, forestWithParents
, sumForest
, sumTree
, boxesBalance
, labelLevels
, sortForest
, sortTree
, lastMode
) where
import Control.Arrow (second, first)
import qualified Penny.Cabin.Options as CO
import qualified Penny.Lincoln as L
import Data.Tuple (swap)
import Data.Either (partitionEithers)
import qualified Data.Map as M
import Data.Ord (comparing)
import Data.List (sortBy, maximumBy, groupBy)
import Data.Monoid (mconcat, Monoid, mempty, mappend)
import Data.Maybe (mapMaybe)
import qualified Data.Tree as T
import qualified Penny.Lincoln.Queries as Q
tieredPostings
:: [(a, L.Posting)]
-> ([(a, L.Posting)], T.Forest (L.SubAccount, [(a, L.Posting)]))
tieredPostings = second (map (fmap swap)) . tieredForest e
where
e = L.unAccount . Q.account . snd
filterForest :: (a -> Bool) -> T.Forest a -> T.Forest a
filterForest f = mapMaybe pruneTree
where
pruneTree (T.Node a fs) =
case filterForest f fs of
[] -> if not (f a) then Nothing else Just (T.Node a [])
cs -> Just (T.Node a cs)
balances
:: CO.ShowZeroBalances
-> [(a, L.Posting)]
-> (L.Balance, T.Forest (L.SubAccount, L.Balance))
balances (CO.ShowZeroBalances szb)
= first boxesBalance
. second remover
. second (map (fmap (second boxesBalance)))
. tieredPostings
where
remover =
if szb
then id
else filterForest (not . M.null . L.unBalance . snd)
. map (fmap (second L.removeZeroCommodities))
flatten
:: (L.Balance, T.Forest (L.SubAccount, L.Balance))
-> [(L.Account, L.Balance)]
flatten (top, frst) = (L.Account [], top) : rest
where
rest
= concatMap T.flatten
. map (fmap toPair)
. forestWithParents
$ frst
toPair ((s, b), ls) =
case reverse . map fst $ ls of
[] -> (L.Account [s], b)
s1:sr -> (L.Account (s1 : (sr ++ [s])), b)
treeWithParents :: T.Tree a -> T.Tree (a, [a])
treeWithParents = treeWithParentsR []
treeWithParentsR :: [a] -> T.Tree a -> T.Tree (a, [a])
treeWithParentsR ls (T.Node n cs) = T.Node (n, ls) cs'
where
cs' = map (treeWithParentsR (n:ls)) cs
forestWithParents :: T.Forest a -> T.Forest (a, [a])
forestWithParents = map (treeWithParentsR [])
sumForest
:: Monoid s
=> T.Forest (a, s)
-> (T.Forest (a, s), s)
sumForest ts = (ts', s)
where
ts' = map sumTree ts
s = foldr mappend mempty . map (snd . T.rootLabel) $ ts'
sumTree
:: Monoid s
=> T.Tree (a, s)
-> T.Tree (a, s)
sumTree (T.Node (a, s) cs) = T.Node (a, mappend s cSum) cs'
where
(cs', cSum) = sumForest cs
boxesBalance :: [(a, L.Posting)] -> L.Balance
boxesBalance
= mconcat
. map (either L.entryToBalance L.entryToBalance)
. map Q.entry
. map snd
labelLevels :: T.Tree a -> T.Tree (Int, a)
labelLevels = go 0
where
go l (T.Node x xs) = T.Node (l, x) (map (go (l + 1)) xs)
sortForest ::
(a -> a -> Ordering)
-> T.Forest a
-> T.Forest a
sortForest o f = sortBy o' (map (sortTree o) f)
where
o' x y = o (T.rootLabel x) (T.rootLabel y)
sortTree ::
(a -> a -> Ordering)
-> T.Tree a
-> T.Tree a
sortTree o (T.Node l f) = T.Node l (sortForest o f)
lastMode :: Ord a => [a] -> Maybe a
lastMode = lastModeBy compare
lastModeBy ::
(a -> a -> Ordering)
-> [a]
-> Maybe a
lastModeBy o ls =
case modesBy o' ls' of
[] -> Nothing
ms -> Just . fst . maximumBy fx $ ms
where
fx = comparing snd
ls' = zip ls ([0..] :: [Int])
o' x y = o (fst x) (fst y)
modesBy :: (a -> a -> Ordering) -> [a] -> [a]
modesBy o =
concat
. longestLists
. groupBy (\x y -> o x y == EQ)
. sortBy o
longestLists :: [[a]] -> [[a]]
longestLists as =
let lengths = map (\ls -> (ls, length ls)) as
maxLen = maximum . map snd $ lengths
in map fst . filter (\(_, len) -> len == maxLen) $ lengths
tieredForest
:: Ord b
=> (a -> [b])
-> [a]
-> ([a], T.Forest ([a], b))
tieredForest f
= second forest
. groupByHead
. sortBy (comparing snd)
. map (\a -> (a, f a))
tree
:: Eq b
=> b
-> ([a], [(b, [(a, [b])])])
-> T.Tree ([a], b)
tree lbl (as, rest) = T.Node (as, lbl) (forest rest)
forest
:: Eq b
=> [(b, [(a, [b])])]
-> T.Forest ([a], b)
forest = map (uncurry tree . second groupByHead)
groupByHead
:: Eq b
=> [(a, [b])]
-> ([a], [(b, [(a, [b])])])
groupByHead
= second groupPairs
. partitionEithers
. map pluckHead
pluckHead
:: (a, [b])
-> Either a (b, (a, [b]))
pluckHead (a, []) = Left a
pluckHead (a, b:bs) = Right (b, (a, bs))
groupPairs
:: Eq a
=> [(a, b)]
-> [(a, [b])]
groupPairs
= map (\ls -> (fst . head $ ls, map snd ls))
. groupBy (\x y -> fst x == fst y)