UMM-0.1.3: UMM.hs
{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>
This file is part of umm, Uwe's Money Manager.
umm is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3 of the License, or (at your
option) any later version.
umm is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
License for more details.
You should have received a copy of the GNU General Public License
along with umm; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
$Id: UMM.hs,v 1.43 2009/11/29 23:10:11 uwe Exp $ -}
module Main where
import Prelude hiding (putStr,putStrLn,readFile,getContents)
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ratio
import System
import System.Exit
import System.IO.UTF8
import System.Time
import UMMHelp
import UMMData
import UMMParser
import UMMEval
processArgs :: IO (String, Command)
processArgs =
do prog <- getProgName
args <- getArgs
now <- getClockTime >>= toCalendarTime
let argc = length args
fname = head args
nd = genDate now
cmd = if argc < 2
then BalanceCmd (Name "") nd
else parseUCommand nd (intercalate " " (tail args))
writeHdr
if argc < 1 || fname == "-h" || fname == "-help" || fname == "--help"
then putStr (usageMsg prog) >> exitWith ExitSuccess
else return (fname, cmd)
-- A version of 'lines' which deals with all combinations of '\r' and '\n'.
-- It drops blank lines, which is perfectly fine here, but which might be
-- a problem elsewhere.
mylines :: String -> [String]
mylines str = filter (/= "") (ml str)
where ml [] = []
ml s = let (p, s1) = break (\c -> c == '\n' || c == '\r') s
in p : (if null s1 then [] else ml (tail s1))
getLines :: String -> IO [String]
getLines fp =
(if fp == "-" then getContents else readFile fp) >>= (return . mylines)
-- Merge explicit (ps) and implicit (qs) prices: the inputs are sorted
-- by date, newest first, and the output is the same, preferring
-- explicit over implicit prices in case of a date match.
mergePrices :: [Record] -> [Record] -> [Record]
mergePrices [] qs = qs
mergePrices ps [] = ps
mergePrices pa@(p:ps) qa@(q:qs) =
if cmpRecDate p q == LT
then q : mergePrices pa qs
else p : mergePrices ps qa
-- Find an equivalent price in the default units for a given CCS,
-- if a suitable one can be found. If none can be found, or if the
-- ccs is already in the default units, return Nothing.
equivPrice :: CCSAmt -> Name -> Date -> [Record] -> Maybe (CCSAmt, Date)
equivPrice (CCSAmt n (Amount a)) dc date p1s =
if n == dc then Nothing else xlat p1s
where xlat [] = Nothing
xlat ((PriceRec dr _ (CCSAmt nr1 (Amount ar1))
(CCSAmt nr2 (Amount ar2))):ps) =
if compare date dr /= LT && n == nr1 && nr2 == dc
then Just ((CCSAmt dc (Amount (a*ar2/ar1))), dr)
else xlat ps
xlat (_:ps) = xlat ps -- for non-PriceRec records
-- Translate price if possible
reprice :: CCSAmt -> Name -> Date -> [Record] -> CCSAmt
reprice ccs dc date prices =
let ep = equivPrice ccs dc date prices
in if isJust ep then fst (fromJust ep) else ccs
-- Pretty-print accounts
ppAccts :: [(Name, [String])] -> Int -> [String]
ppAccts es sp =
concat (map (ppe (sp + maximum (map (length . getN . fst) es))) es)
where getN (Name n) = n
ppe l (m,as) =
let isp = concat (repeat " ")
in zipWith gl ((take l (show m ++ isp)) : repeat (take l isp)) as
gl a b = concat [a, b]
showPos :: Name -> Date -> [Record] -> AccountData -> [(Name, [String])]
showPos dc da ps as = map f1 as
where f1 (n1,es) = (n1, if null es then ["[empty]"] else map f2 es)
f2 c2 =
let sv = show c2
ep = equivPrice c2 dc da ps
jep = fromJust ep
CCSAmt n (Amount a) = fst jep
jer = CCSAmt n (Amount (roundP 2 a))
sd d = if d == start_time then "" else " (" ++ show d ++ ")"
sp = "\t~" ++ show jer ++ sd (snd jep)
pad = " " ++ concat (take (18 - length sv) (repeat " "))
in if isJust ep then sv ++ pad ++ sp else sv
selAccts :: [Name] -> AccountData -> AccountData
selAccts names accs =
(if length names == 1 && head names == noName
then id
else filter (\a -> elem (fst a) names)) accs
-- Round a rational number val to np decimal places
-- This might not be ultimately exact, but it's for converted prices
-- which might be a couple of days out of date anyway, so no big deal
roundP :: Int -> Rational -> Rational
roundP np val =
if val < 0 then negate (rp (negate val)) else rp val
where rp v1 =
let e1 = 10^(max 0 np)
e2 = 10*e1
vs = (fromInteger e2)*v1
n = numerator vs
d = denominator vs
q1 = quot n d
q2 = quot (q1 + 4) 10
in q2 % e1
-- Turn an account-group into a list of accounts. An account-group can
-- contain (names of) other account-groups, including recursively, and
-- loops aren't prohibited either... need to handle all those cases.
expandGroup :: [Record] -> [Record] -> Name -> [Name]
expandGroup aas ggs ag =
if ag == noName || ag == todoName
then [ag]
else ff [ag] (map getRecName aas) (map ggt ggs) [] []
where ff [] _ _ am _ = am
ff (q:qs) as gs am ab
| elem q am || elem q ab = ff qs as gs am ab
| elem q as = ff qs as gs (q:am) ab
| isJust (lookup q gs) = ff (qs ++ fromJust(lookup q gs))
as gs am (q:ab)
| otherwise = error ("unknown account or group! "
++ show q)
ggt (GroupRec n as) = (n,as)
ggt r = error ("internal error at expandGroup! got " ++ show r)
doList :: CmdOpt -> Name -> [Record] -> [Record] ->
[Record] -> [Record] -> [Record] -> IO ()
doList w dc ccs accts grps incs exps =
do when (chk w COLCCS)
(putStrLn "# Currencies, Commodities, Securities\n" >>
putStrLn ("# default ccs " ++ (show dc) ++ "\n") >> sh ccs)
when (chk w COLAccs) (putStrLn "\n# Accounts\n" >> sh accts)
when (chk w COLGrps) (putStrLn "\n# Groups\n" >> sh grps)
when (chk w COLIncs) (putStrLn "\n# Incomes\n" >> sh incs)
when (chk w COLExps) (putStrLn "\n# Expenses\n" >> sh exps)
where chk w1 w2 = w1 == w2 || w1 == COLAll
sh = mapM_ (putStrLn . show)
doBalance :: Date -> [Name] -> Name -> [Record] ->
[Record] -> [Record] -> IO ()
doBalance date names dc accts trans prices =
do final <- getBalances start_time date Nothing False accts trans
let fsel = selAccts names final
fp = map (\e -> reprice e dc date prices) (concat (map snd fsel))
gp = groupBy eqCCSAmtName (sortBy cmpCCSAmtName fp)
sp = filter (\e -> ccsA e /= 0) (map sumCCS gp)
if length names == 1 && head names == todoName
then putStr ""
else putStrLn ("Account balances as of " ++ show date) >>
mapM_ putStrLn (ppAccts (showPos dc date prices fsel) 8) >>
putStrLn ("Grand total: ~" ++ show sp)
where sumCCS cs =
CCSAmt (ccsN (head cs)) (Amount (roundP 2 (sum (map ccsA cs))))
ccsN (CCSAmt n _) = n
ccsA (CCSAmt _ (Amount a)) = a
doRegister :: Date -> Date -> Name -> Name -> [Record] ->
[Record] -> [Record] -> Bool -> IO ()
doRegister d1 d2 name dc accts trans prices dorec =
do final <- getBalances d1 d2 (Just name) dorec accts trans
putStrLn ((if dorec then "Reconciled" else "Account")
++ " balance as of " ++ show d2)
mapM_ putStrLn (ppAccts (showPos dc d2 prices (selAccts [name] final)) 8)
doChange :: Bool -> Date -> Date -> Name -> Name ->
[Record] -> [Record] -> IO ()
doChange verbose d1 d2 name dc accts trans =
do let aux = if notElem name (map getRecName accts)
then [AccountRec name d1 ""]
else []
trs = dropWhile (\t -> compare (getRecDate t) d1 /= GT) trans
mn = if verbose then Just name else Nothing
final <- getBalances d1 d2 mn False (aux ++ accts) trs
putStr "Change"
when (d1 /= start_time) (putStr (" from " ++ show d1))
putStrLn (" to " ++ show d2)
mapM_ putStrLn (ppAccts (showPos dc d2 [] (selAccts [name] final)) 8)
main :: IO ()
main =
do (file, action) <- processArgs
recs <- getLines file >>= mapM (return . parseURecord) >>= validateRecs
let (dc, ccs, incs, exps, accts, grps, trans, p1) = classifyRecs recs
validateTransPrices ccs incs exps accts (trans ++ p1)
let p2 = generateImplicitPrices dc trans ccs
prices = mergePrices (reverse p1) p2
case action of
ListDataCmd w ->
doList w dc ccs accts grps incs exps
BalanceCmd name date ->
doBalance date (expandGroup accts grps name) dc accts trans prices
BasisCmd _ _ ->
putStrLn "Sorry, basis command is not implemented yet!"
ToDoCmd date ->
doBalance date [todoName] dc accts trans prices
RegisterCmd name date1 date2 ->
doRegister date1 date2 name dc accts trans prices False
ReconcileCmd name date ->
doRegister start_time date name dc accts trans prices True
ChangeCmd verbose name date1 date2 ->
doChange verbose date1 date2 name dc accts trans
PriceCmd name date ->
if name == dc
then putStrLn ("Price of " ++ show name ++ " is always 1!")
else if notElem name (map getRecName ccs)
then putStrLn ("Error! unknown CCS " ++ show name)
else getPrices name dc date prices