Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #!/usr/bin/env stack
- {- stack
- script
- --nix --no-nix-pure
- --resolver lts-14.7
- --package boxes,containers,Decimal,hledger-lib,text,time
- -}
- {-# OPTIONS_GHC -Weverything -Wno-implicit-prelude -Wno-missing-export-lists -Wno-unsafe #-}
- {-# LANGUAGE OverloadedStrings #-}
- import Data.Decimal (Decimal)
- import Data.List (inits)
- import qualified Data.Map as M
- import Data.Maybe (fromMaybe, maybeToList)
- import qualified Data.Text as T
- import Data.Time.Calendar (Day, diffDays)
- import Data.Time.Clock (UTCTime(utctDay), getCurrentTime)
- import qualified Hledger.Data.Types as H
- import qualified Hledger.Read as H
- import qualified Text.PrettyPrint.Boxes as B
- import Text.Printf (printf)
- main :: IO ()
- main = do
- journal <- H.defaultJournal
- today <- utctDay <$> getCurrentTime
- printAccountStats (calcAccountStats journal today)
- -------------------------------------------------------------------------------
- data AccountStats = AccountStats
- { aAgeOfOldestGBP :: Integer
- , aAgeOfAverageGBP :: Decimal
- , aAverageLifespanOfSpentGBP :: Maybe Decimal
- }
- calcAccountStats :: H.Journal -> Day -> M.Map H.AccountName AccountStats
- calcAccountStats journal today =
- doAccountStats today <$>
- M.filter (not . null . snd) (foldl doTransaction M.empty (H.jtxns journal))
- printAccountStats :: M.Map H.AccountName AccountStats -> IO ()
- printAccountStats stats = B.printBox $ B.hsep 1 B.top
- [ col B.left "account" T.unpack (M.keys stats)
- , col B.right "age of oldest £" (show . aAgeOfOldestGBP) vals
- , col B.right "age of average £" (roundDecimal . aAgeOfAverageGBP) vals
- , col B.right "average livespan of spent £" (maybe "-" roundDecimal . aAverageLifespanOfSpentGBP) vals
- ]
- where
- vals = M.elems stats
- col :: B.Alignment -> String -> (a -> String) -> [a] -> B.Box
- col a hdr f bs = B.vcat a (map B.text (hdr:"---":map f bs))
- -------------------------------------------------------------------------------
- type Pots = ([(Integer, Decimal)], M.Map Day Decimal)
- doTransaction :: M.Map H.AccountName Pots -> H.Transaction -> M.Map H.AccountName Pots
- doTransaction ages0 txn = foldl (doPosting day) ages0 expandedPostings where
- day = H.tdate txn
- expandedPostings =
- [ (H.paccount posting, amount)
- | posting <- concatMap explode (H.tpostings txn)
- , check (H.paccount posting)
- , amount <- maybeToList (toGBP (H.pamount posting))
- ]
- check account =
- ("assets:cash:" `T.isPrefixOf` account) && not ("assets:cash:petty" `T.isPrefixOf` account)
- doPosting :: Day -> M.Map H.AccountName Pots -> (H.AccountName, Decimal) -> M.Map H.AccountName Pots
- doPosting day ages (account, amount)
- | amount > 0 = M.alter (Just . addMoneyToPot) account ages
- | amount < 0 = M.alter (Just . delMoneyFromPot) account ages
- | otherwise = ages
- where
- addMoneyToPot :: Maybe Pots -> Pots
- addMoneyToPot (Just (ls, pots)) = (ls, M.alter (\a -> Just (amount + fromMaybe 0 a)) day pots)
- addMoneyToPot Nothing = ([], M.fromList [(day, amount)])
- delMoneyFromPot :: Maybe Pots -> Pots
- delMoneyFromPot (Just (ls, pots)) = delMoneyFromPot' (abs amount) ls (M.toList pots)
- delMoneyFromPot Nothing = debt amount
- delMoneyFromPot' :: Decimal -> [(Integer, Decimal)] -> [(Day, Decimal)] -> Pots
- delMoneyFromPot' q ls ((d,p):ps)
- | q > p = delMoneyFromPot' (q - p) ((diffDays day d, p):ls) ps
- | q < p = ((diffDays day d, p - q):ls, M.fromList ((d,p - q):ps))
- | otherwise = ((diffDays day d, p):ls, M.fromList ps)
- delMoneyFromPot' q _ [] = debt q
- debt :: Decimal -> a
- debt q = error ("[" ++ T.unpack account ++ ", " ++ show day ++ "] tried to go into debt by " ++ show (abs q))
- doAccountStats :: Day -> Pots -> AccountStats
- doAccountStats today (ls, pots) = AccountStats
- { aAgeOfOldestGBP = diffDays today (fst (head ds))
- , aAgeOfAverageGBP = weightedAvg [(fromIntegral (diffDays today d), w) | (d, w) <- ds]
- , aAverageLifespanOfSpentGBP =
- let ls' = filter ((/=0) . fst) ls
- in if null ls'
- then Nothing
- else Just (weightedAvg [(fromInteger d, w) | (d, w) <- ls'])
- }
- where
- ds = M.toList pots -- ideally 'pots' would be some non-empty map type
- -------------------------------------------------------------------------------
- weightedAvg :: Fractional a => [(a,a)] -> a
- weightedAvg xws = sum [x * w | (x, w) <- xws] / sum [w | (_, w) <- xws]
- roundDecimal :: Decimal -> String
- roundDecimal = printf "%0.3f" . (realToFrac :: Decimal -> Double)
- explode :: H.Posting -> [H.Posting]
- explode p =
- [ p { H.paccount = a }
- | a <- tail . map (T.intercalate ":") . inits . T.splitOn ":" $ H.paccount p
- ]
- toGBP :: H.MixedAmount -> Maybe Decimal
- toGBP (H.Mixed [H.Amount "£" q _ _ _]) = Just q
- toGBP _ = Nothing
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement