diff --git a/UMM.cabal b/UMM.cabal --- a/UMM.cabal +++ b/UMM.cabal @@ -1,5 +1,5 @@ Name: UMM -Version: 0.1.5 +Version: 0.1.6 Homepage: http://www.korgwal.com/umm/ Author: Uwe Hollerbach Maintainer: Uwe Hollerbach diff --git a/UMM.hs b/UMM.hs --- a/UMM.hs +++ b/UMM.hs @@ -1,4 +1,4 @@ -{- Copyright 2009 Uwe Hollerbach +{- Copyright 2009-2010 Uwe Hollerbach This file is part of umm, Uwe's Money Manager. @@ -16,7 +16,7 @@ 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.53 2009/12/15 06:05:44 uwe Exp $ -} +$Id: UMM.hs,v 1.57 2010/01/17 00:13:47 uwe Exp $ -} module Main where import Prelude hiding (putStr,putStrLn,print,readFile,getContents) @@ -42,7 +42,7 @@ fname = head args nd = genDate now cmd = if argc < 2 - then BalanceCmd (Name "") nd + then BalanceCmd noName nd else parseUCommand nd (intercalate " " (tail args)) putStrLn writeHdr when (argc < 1 || fname == "-h" || fname == "-help" || fname == "--help") @@ -68,25 +68,42 @@ then q : mergePrices pa qs else p : mergePrices ps qa --- Find an equivalent price in the default units for a given CCS, +-- Get the base currency for a given CCS, which may be itself + +getBaseCurrency :: Name -> Name -> [Record] -> Name + +-- old behavior: translate everything into one default currency +-- getBaseCurrency _ dc _ = dc + +-- new behavior: for each CCS, translate it into that CCS' base CCS if +-- the current CCS is a derived CCS + +getBaseCurrency cn _ [] = cn +getBaseCurrency cn ign ((CCSRec n _ _ nb):cs) = + if n == cn then nb else getBaseCurrency cn ign cs +getBaseCurrency _ _ r = + error ("internal error at getBaseCurrency! got " ++ show r) + +-- Find an equivalent price in the base 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 +equivPrice (CCSAmt n (Amount a)) bc date p1s = + if n == bc then Nothing else xlat p1s where xlat [] = Nothing xlat ((PriceRec dr _ (CCSAmt nr1 (Amount ar1)) (CCSAmt nr2 (Amount ar2))):ps) = - if date >= dr && n == nr1 && nr2 == dc - then Just ((CCSAmt dc (Amount (a*ar2/ar1))), dr) + if date >= dr && n == nr1 && nr2 == bc + then Just ((CCSAmt bc (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 = maybe ccs fst (equivPrice ccs dc date prices) +reprice :: CCSAmt -> Name -> [Record] -> Date -> [Record] -> CCSAmt +reprice c@(CCSAmt cn _) bc ccs date prices = + maybe c fst (equivPrice c (getBaseCurrency cn bc ccs) date prices) -- Pretty-print accounts @@ -99,12 +116,13 @@ 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 +showPos :: Name -> [Record] -> Date -> [Record] -> + AccountData -> [(Name, [String])] +showPos dc ccs da ps as = map f1 as where f1 (n1,es) = (n1, if null es then ["[empty]"] else map f2 es) - f2 c2 = + f2 c2@(CCSAmt c2n _) = let sv = show c2 - ep = equivPrice c2 dc da ps + ep = equivPrice c2 (getBaseCurrency c2n dc ccs) da ps jep = fromJust ep CCSAmt n (Amount a) = fst jep jer = CCSAmt n (Amount (roundP 2 a)) @@ -153,17 +171,17 @@ sh = mapM_ print doBalance :: Bool -> Date -> [Name] -> Name -> [Record] -> - [Record] -> [Record] -> IO () -doBalance ke date names dc accts trans prices = + [Record] -> [Record] -> [Record] -> IO () +doBalance ke date names dc ccs accts trans prices = do final <- getBalances startTime date Nothing False accts trans let fsel = selAccts ke names final - fp = map (\e -> reprice e dc date prices) (concatMap snd fsel) + fp = map (\e -> reprice e dc ccs date prices) (concatMap 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) >> + mapM_ putStrLn (ppAccts (showPos dc ccs date prices fsel) 8) >> putStrLn ("Grand total: ~" ++ show sp) where sumCCS cs = CCSAmt (ccsN (head cs)) (Amount (roundP 2 (sum (map ccsA cs)))) @@ -171,19 +189,19 @@ ccsA (CCSAmt _ (Amount a)) = a doRegister :: Date -> Date -> Name -> Name -> [Record] -> - [Record] -> [Record] -> Bool -> IO () -doRegister d1 d2 name dc accts trans prices dorec = + [Record] -> [Record] -> [Record] -> Bool -> IO () +doRegister d1 d2 name dc ccs 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 + mapM_ putStrLn (ppAccts (showPos dc ccs d2 prices (selAccts True [name] final)) 8) doChange :: Bool -> Date -> Date -> Name -> Name -> - [Record] -> [Record] -> IO () -doChange verbose d1 d2 name dc accts trans = + [Record] -> [Record] -> [Record] -> IO () +doChange verbose d1 d2 name dc ccs accts trans = do let aux = if notElem name (map getRecName accts) - then [AccountRec name d1 ""] + then [AccountRec name d1 "" Nothing] else [] trs = dropWhile (\t -> getRecDate t <= d1) trans mn = if verbose then Just name else Nothing @@ -191,7 +209,8 @@ putStr "Change" when (d1 /= startTime) (putStr (" from " ++ show d1)) putStrLn (" to " ++ show d2) - mapM_ putStrLn (ppAccts (showPos dc d2 [] (selAccts True [name] final)) 8) + mapM_ putStrLn (ppAccts (showPos dc ccs d2 [] + (selAccts True [name] final)) 8) -- Filter predicate for computing basis: want to only consider transactions -- which involve ccs "n0" @@ -208,31 +227,38 @@ main = do (file, action) <- processArgs recs <- getLines file >>= mapM (return . parseURecord) >>= validateRecs - let (dc, ccs, incs, exps, accts, grps, trans, p1) = classifyRecs recs + let (dc, cb, c1, incs, exps, a1, grps, trans, p1) = classifyRecs recs + cd <- validateCCS dc cb c1 + let ccs = cb ++ cd + accts <- validateAccts dc ccs a1 validateTransPrices ccs incs exps accts (trans ++ p1) - let p2 = generateImplicitPrices dc trans ccs + let p2 = generateImplicitPrices dc trans cd prices = mergePrices (reverse p1) p2 pse r = putStrLn (showExp r) >> putStrLn "" case action of ChangeCmd verbose name date1 date2 -> - doChange verbose date1 date2 name dc accts trans + doChange verbose date1 date2 name dc ccs accts trans BalanceCmd name date -> doBalance True date (expandGroup accts grps name) - dc accts trans prices + dc ccs accts trans prices BasisCmd name date -> - doBalance False date [noName] dc accts (filter (hasCur name) trans) [] + doBalance False date [noName] dc ccs accts + (filter (hasCur name) trans) [] ExportCmd -> mapM_ pse trans >> mapM_ pse (reverse prices) ListDataCmd w -> doList w dc ccs accts grps incs exps 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 + if elem name (map getRecName cb) + then putStrLn (show name ++ " is a base CCS!") + else let crec = find (\r -> getRecName r == name) cd + in if isNothing crec + then putStrLn ("Error! unknown CCS " ++ show name) + else getPrices name (getNB (fromJust crec)) date prices RegisterCmd name date1 date2 -> - doRegister date1 date2 name dc accts trans prices False + doRegister date1 date2 name dc ccs accts trans prices False ReconcileCmd name date -> - doRegister startTime date name dc accts trans prices True + doRegister startTime date name dc ccs accts trans prices True ToDoCmd date -> - doBalance True date [todoName] dc accts trans prices + doBalance True date [todoName] dc ccs accts trans prices + where getNB (CCSRec _ _ _ nb) = nb + getNB r = error ("internal error at main! got " ++ show r) diff --git a/UMMData.hs b/UMMData.hs --- a/UMMData.hs +++ b/UMMData.hs @@ -1,4 +1,4 @@ -{- Copyright 2009 Uwe Hollerbach +{- Copyright 2009-2010 Uwe Hollerbach This file is part of umm, Uwe's Money Manager. @@ -16,7 +16,7 @@ along with umm; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: UMMData.hs,v 1.45 2009/12/14 04:58:06 uwe Exp $ -} +$Id: UMMData.hs,v 1.49 2010/01/02 22:33:34 uwe Exp $ -} module UMMData (Name(..), Date(..), Amount(..), startTime, Command(..), CmdOpt(..), Record(..), genDate, @@ -25,10 +25,11 @@ recordInfo, recordErr, recordNil, showExp, BSE(..), CCSAmt(..), cmpCCSAmtName, eqCCSAmtName, AccountData, noName, todoName, joinDrop, roundP, isLeap, validDate, - trimspace, mylines, mergelines) where + trimspace, mylines, mergelines, uniqAdjBy, uniqAdj) where import Prelude import Data.Char import Data.List +import Data.Maybe import Data.Ord import Data.Ratio import System.Time @@ -154,7 +155,7 @@ joinDrop ["register", show name, show date1, show date2] show (ReconcileCmd name date) = joinDrop ["reconcile", show name, show date] show (ChangeCmd verbose name date1 date2) = - joinDrop ["change", (if verbose then "verbose" else ""), + joinDrop ["change", shIf verbose "verbose", show name, show date1, show date2] show ExportCmd = "export" @@ -170,10 +171,10 @@ show S = "sell" show E = "exch" -data Record = CCSRec Name String (Maybe CCSAmt) +data Record = CCSRec Name String (Maybe Amount) Name | IncomeRec Name String | ExpenseRec Name String - | AccountRec Name Date String + | AccountRec Name Date String (Maybe CCSAmt) | GroupRec Name [Name] | PriceRec Date Bool CCSAmt CCSAmt | XferRec Date Bool Name [(Name, CCSAmt)] String String @@ -186,31 +187,36 @@ instance Show Record where show = showR +shIf :: Bool -> String -> String +shIf fl val = if fl then val else "" + +shM :: Show a => Maybe a -> String +shM val = if isJust val then show (fromJust val) else "" + +shDef :: String -> String -> String +shDef s d = if s == "" then d else s + -- We use "show str" here to add quotes and escape any escapables optStr :: String -> String -optStr str = if str == "" then "" else show str +optStr str = shIf (str /= "") (show str) shRec :: Bool -> String -shRec rec = if rec then "*" else "" - -mAmt :: Maybe CCSAmt -> String -mAmt Nothing = "" -mAmt (Just a) = show a +shRec rec = shIf rec "*" joinDrop :: [String] -> String joinDrop = intercalate " " . filter (/= "") showR :: Record -> String -showR (CCSRec n d a) = joinDrop ["ccs", show n, optStr d, mAmt a] +showR (CCSRec n d ma nb) = + joinDrop ["ccs", show n, optStr d, shM ma, show nb] showR (IncomeRec n d) = joinDrop ["income", show n, optStr d] showR (ExpenseRec n d) = joinDrop ["expense", show n, optStr d] -showR (AccountRec n da de) = joinDrop ["account", show n, show da, optStr de] +showR (AccountRec n da de mi) = + joinDrop ["account", show n, show da, optStr de, shM mi] showR (GroupRec n as) = joinDrop (["group", show n] ++ map show as) showR (PriceRec d imp c1 c2) = - (if imp then "[" else "") ++ - joinDrop ["price", show d, show c1, show c2] ++ - (if imp then "]" else "") + joinDrop [shIf imp "[", "price", show d, show c1, show c2, shIf imp "]"] showR (XferRec d r from tos m i) = joinDrop ["xfer", shRec r, show d, show from, showTos tos, optStr m, i] @@ -222,11 +228,10 @@ showR (SplitRec d n a1 a2) = joinDrop ["split", show d, show n, show a1, show a2] -showR (CommentRec c) = if c == "" then "" else joinDrop ["#", c] +showR (CommentRec c) = shIf (c /= "") (joinDrop ["#", c]) showR (ToDoRec d r memo) = - joinDrop ["todo", shRec r, show d, - (if memo == "" then "something! but what?" else memo)] + joinDrop ["todo", shRec r, show d, shDef memo "something! but what?"] showR (ErrorRec str) = joinDrop ["#err", str] @@ -236,17 +241,17 @@ showTos ts = "{" ++ intercalate ", " (map (showTo1 False) ts) ++ "}" showTo1 :: Bool -> (Name, CCSAmt) -> String -showTo1 sp (n,a) = joinDrop [show n, if sp then " " else "", show a] +showTo1 sp (n,a) = joinDrop [show n, shIf sp " ", show a] showExp :: Record -> String showExp (XferRec d r from tos m i) = - let l1 = joinDrop [show d, shRec r, i, if m == "" then "transfer" else m] + let l1 = joinDrop [show d, shRec r, i, shDef m "transfer"] l2 = map (showTo1 True) tos l3 = joinDrop [show from] in intercalate "\n " ([l1] ++ l2 ++ [l3]) showExp (ExchRec _ d r a c1 (CCSAmt n2 (Amount a2)) m) = - let l1 = joinDrop [show d, shRec r, if m == "" then "exchange" else m] + let l1 = joinDrop [show d, shRec r, shDef m "exchange"] l2 = joinDrop [show a, ' ' : show c1] l3 = joinDrop [show a, ' ' : show (CCSAmt n2 (Amount (-a2)))] l4 = "the:world" @@ -263,7 +268,7 @@ -- Get the date (or at any rate /some/ date) from a Record getRecDate :: Record -> Date -getRecDate (AccountRec _ d _) = d +getRecDate (AccountRec _ d _ _) = d getRecDate (PriceRec d _ _ _) = d getRecDate (XferRec d _ _ _ _ _) = d getRecDate (ExchRec _ d _ _ _ _ _) = d @@ -274,11 +279,11 @@ -- Get the name (or at any rate /some/ name) from a Record getRecName :: Record -> Name -getRecName (CCSRec n _ _) = n -getRecName (IncomeRec n _) = n -getRecName (ExpenseRec n _) = n -getRecName (AccountRec n _ _) = n -getRecName (GroupRec n _) = n +getRecName (CCSRec n _ _ _) = n +getRecName (IncomeRec n _) = n +getRecName (ExpenseRec n _) = n +getRecName (AccountRec n _ _ _) = n +getRecName (GroupRec n _) = n getRecName _ = nilName -- so it works for every Record -- Compare two Records @@ -408,3 +413,18 @@ | isL h && isF t = mergelines ((init h ++ tail t):ts) | isL h || isF h = error ("mergelines: partial line " ++ h) | otherwise = h : mergelines (t:ts) + +-- Examine a list of items: with a comparison function which returns +-- True if two items are equal, False otherwise, determine if there are +-- duplicate adjacent entries in the list. Return True if all items are +-- unique, False if there are adjacent duplicates. The restriction to +-- adjacent elements makes it faster than 'nub' or 'elem' or the like. + +uniqAdjBy :: (a -> a -> Bool) -> [a] -> Bool +uniqAdjBy _ [] = True +uniqAdjBy _ [_] = True +uniqAdjBy f (v1:v2:[]) = not (f v1 v2) +uniqAdjBy f (v1:v2:vs) = if f v1 v2 then False else uniqAdjBy f (v2:vs) + +uniqAdj :: (Eq a) => [a] -> Bool +uniqAdj = uniqAdjBy (==) diff --git a/UMMEval.hs b/UMMEval.hs --- a/UMMEval.hs +++ b/UMMEval.hs @@ -1,4 +1,4 @@ -{- Copyright 2009 Uwe Hollerbach +{- Copyright 2009-2010 Uwe Hollerbach This file is part of umm, Uwe's Money Manager. @@ -16,10 +16,11 @@ along with umm; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: UMMEval.hs,v 1.33 2009/12/15 06:05:44 uwe Exp $ -} +$Id: UMMEval.hs,v 1.37 2010/01/03 06:02:32 uwe Exp $ -} -module UMMEval (validateRecs, classifyRecs, validateTransPrices, - generateImplicitPrices, getBalances, getPrices) where +module UMMEval (validateRecs, validateCCS, validateAccts, classifyRecs, + validateTransPrices, generateImplicitPrices, getBalances, + getPrices) where import Prelude hiding (putStr,putStrLn,print) import Data.List import Data.Maybe @@ -51,9 +52,8 @@ validateRecs :: [Record] -> IO [Record] validateRecs records = do let (_,i,e) = runLedger (chk records) - if null e - then return i - else showErrs "parse or date errors" e + unless (null e) (showErrs "parse or date errors" e) + return i where chk [] = return () chk (r@(ErrorRec _):rs) = recordErr r >> chk rs chk ((CommentRec _):rs) = chk rs @@ -61,6 +61,46 @@ (if validDate (getRecDate r) then recordInfo else recordErr) r >> chk rs +-- Check that the default ccs is basic and that all derived ccs refer +-- to basic ccs; return the derived ccs with noName refers-to replaced +-- with explicit default ccs. + +validateCCS :: Name -> [Record] -> [Record] -> IO [Record] +validateCCS dc cb cd = + do let bn = map getRecName cb + dn = map getRecName cd + when (elem dc dn) (error (show dc ++ " is not a basic CCS!")) + let (_,i,e) = runLedger (chk bn dn cd) + unless (null e) (showErrs "problems with non-basic ccs" e) + return i + where chk _ _ [] = return () + chk bn dn (r@(CCSRec n d a nb):rs) + | nb == noName = recordInfo (CCSRec n d a dc) >> chk bn dn rs + | elem nb bn = recordInfo r >> chk bn dn rs + | elem nb dn = rE "non-basic" nb >> recordErr r >> chk bn dn rs + | otherwise = rE "unknown" nb >> recordErr r >> chk bn dn rs + chk _ _ (r:_) = intErr "validateCCS" r + rE t n = recordErr (CommentRec (t ++ " ccs: " ++ show n)) + +-- Check that accounts with initial values refer to known ccs; replace +-- blank ccs-name with explicit default ccs + +validateAccts :: Name -> [Record] -> [Record] -> IO [Record] +validateAccts dc ccs accts = + do let cn = map getRecName ccs + let (_,i,e) = runLedger (chk cn accts) + unless (null e) (showErrs "problems with initial values in accounts" e) + return i + where chk _ [] = return () + chk cn (r@(AccountRec _ _ _ Nothing):rs) = recordInfo r >> chk cn rs + chk cn (r@(AccountRec n da de (Just (CCSAmt nb ia))):rs) + | nb == noName = + recordInfo (AccountRec n da de (Just (CCSAmt dc ia))) >> chk cn rs + | elem nb cn = recordInfo r >> chk cn rs + | otherwise = rE "unknown" nb >> recordErr r >> chk cn rs + chk _ (r:_) = intErr "validateCCS" r + rE t n = recordErr (CommentRec (t ++ " ccs: " ++ show n)) + -- Classify records by type and sort accounts and -- transaction-type records by date or name as needed @@ -68,30 +108,28 @@ -- account names and account group names together, rather than -- separately (or just account groups, right now) -classifyRecs :: [Record] -> (Name, [Record], [Record], [Record], +classifyRecs :: [Record] -> (Name, [Record], [Record], [Record], [Record], [Record], [Record], [Record], [Record]) classifyRecs recs = cw recs [] [] [] [] [] [] [] where cw [] c i e a g t p = let dc = if null c then Name "zorkmid" else getRecName (last c) - in (dc, vsN c, vsN i, vsN e, reverse a, vsN g, asD dc t, asD dc p) + (cb, cd) = partition isB (vsN c) + in (dc, cb, cd, vsN i, vsN e, reverse a, vsN g, asD dc t, asD dc p) cw (r:rs) c i e a g t p = case r of - CommentRec _ -> cw rs c i e a g t p - CCSRec _ _ _ -> cw rs (r:c) i e a g t p - IncomeRec _ _ -> cw rs c (r:i) e a g t p - ExpenseRec _ _ -> cw rs c i (r:e) a g t p - AccountRec _ _ _ -> cw rs c i e (r:a) g t p - GroupRec _ _ -> cw rs c i e a (r:g) t p - PriceRec _ _ _ _ -> cw rs c i e a g t (r:p) - _ -> cw rs c i e a g (r:t) p + CommentRec _ -> cw rs c i e a g t p + CCSRec _ _ _ _ -> cw rs (r:c) i e a g t p + IncomeRec _ _ -> cw rs c (r:i) e a g t p + ExpenseRec _ _ -> cw rs c i (r:e) a g t p + AccountRec _ _ _ _ -> cw rs c i e (r:a) g t p + GroupRec _ _ -> cw rs c i e a (r:g) t p + PriceRec _ _ _ _ -> cw rs c i e a g t (r:p) + _ -> cw rs c i e a g (r:t) p vsN = uChk . sortBy cmpRecName - uChk [] = [] - uChk s@(_:[]) = s - uChk v@(v1:v2:[]) = uc1 v1 v2 v - uChk v@(v1:v2:_) = uc1 v1 v2 (v1 : uChk (tail v)) - uc1 v1 v2 r = if getRecName v1 == getRecName v2 then uErr v1 v2 else r - uErr v1 v2 = - error ("duplicate records\n " ++ show v1 ++ "\n " ++ show v2) + uChk vs = if uniqAdjBy (\v1 v2 -> cmpRecName v1 v2 == EQ) vs + then vs + else error ("duplicate records\n " ++ + intercalate "\n " (map show vs)) asD dc = sortBy cmpRecDate . reverse . map (addDC dc) addDC dc (PriceRec d imp ccsa1 ccsa2) = PriceRec d imp ccsa1 (addDCCA dc ccsa2) @@ -101,13 +139,15 @@ ExchRec t d f acc (addDCCA dc ccsa1) (addDCCA dc ccsa2) m addDC _ r = r addDCCAt d (n,a) = (n, addDCCA d a) + isB (CCSRec _ _ ma nb) = isNothing ma && nb == noName + isB r = intErr "classifyCCS" r -- Second validation of transactions: check that all from & to accounts -- are valid, that splits aren't 1/0 or 0/1, etc -- TODO: if we want to give a reason for each failure, run this -- through runLedger as above? then we could generate multiple output --- records for (some of) each input record +-- records for (some of) each input record... see validateCCS validateTransPrices :: [Record] -> [Record] -> [Record] -> [Record] -> [Record] -> IO () @@ -135,13 +175,13 @@ -- other stuff is too hard to untangle at least for now. generateImplicitPrices :: Name -> [Record] -> [Record] -> [Record] -generateImplicitPrices dc trs ccs = gip (geni ccs) trs - where geni = map gii . filter iJ . filter nD - nD r = getRecName r /= dc - iJ (CCSRec _ _ ma) = isJust ma - iJ r = intErr "generateImplicitPrices:1" r - gii (CCSRec n _ (Just a)) = - PriceRec startTime True (CCSAmt n (Amount 1)) (addDCCA dc a) +generateImplicitPrices dc trs cd = gip (geni cd) trs + where geni = map gii . filter iG + iG (CCSRec _ _ ma _) = isJust ma + iG r = intErr "generateImplicitPrices:1" r + gii (CCSRec n _ (Just a) nb) = + PriceRec startTime True (CCSAmt n (Amount 1)) + (addDCCA dc (CCSAmt nb a)) gii r = intErr "generateImplicitPrices:2" r gip acc [] = filter pr acc gip acc (t@(ExchRec _ _ _ _ _ _ _):ts) = gip (genp t : acc) ts @@ -184,33 +224,33 @@ qq = getCA q in if qn == dn then CCSAmt qn (Amount (qq * dq)) else q -maybeRecord :: Maybe Name -> Record -> AccountData -> (Name -> Bool) -> +maybeRecord :: Bool -> Maybe Name -> Record -> AccountData -> (Name -> Bool) -> Ledger e (Record, [CCSAmt]) () -maybeRecord reg record newaccs tst = +maybeRecord rt reg record newaccs tst = let isJ = isJust reg rn = fromJust reg acc = filter (\a -> fst a == rn) newaccs nb = if null acc then [CCSAmt noName (Amount 0)] else snd (head acc) - in if isJ && (tst rn || rn == noName) + in if rt && isJ && (tst rn || rn == noName) then recordInfo (record, nb) else recordNil -maybeDo :: Maybe Name -> Bool -> Record -> Bool -> +maybeDo :: Bool -> Maybe Name -> Bool -> Record -> Bool -> AccountData -> AccountData -> (Name -> Bool) -> Ledger e (Record, [CCSAmt]) AccountData -maybeDo reg dorec record isrec accs newaccs tst = +maybeDo rt reg dorec record isrec accs newaccs tst = if dorec then if isrec then return newaccs - else maybeRecord reg record newaccs tst >> return accs - else maybeRecord reg record newaccs tst >> return newaccs + else maybeRecord rt reg record newaccs tst >> return accs + else maybeRecord rt reg record newaccs tst >> return newaccs exchTrans :: Maybe Name -> Bool -> Record -> AccountData -> Ledger e (Record, [CCSAmt]) AccountData exchTrans reg dorec record@(ExchRec _ _ isrec acc amtn amto _) accs = - maybeDo reg dorec record isrec accs + maybeDo True reg dorec record isrec accs (doExch accs acc amtn amto) (== acc) where doExch [] _ _ _ = [] doExch ((an,ab):as) n en eo = @@ -219,12 +259,18 @@ else (an,ab) : doExch as n en eo exchTrans _ _ r _ = intErr "exchTrans" r +-- TODO: alternately, we could have '(xfer1 (not dorec))' in the +-- foldM, that would cause register displays to be shown once for each +-- sub-transaction, but reconciliation displays would show the entire +-- transaction only once + xferTrans :: Maybe Name -> Bool -> Record -> AccountData -> Ledger e (Record, [CCSAmt]) AccountData -xferTrans reg dorec record@(XferRec _ isrec from tos _ _) accs = foldM xfer1 accs tos - where xfer1 as (to,amt) = maybeDo reg dorec record isrec as - (doXfer as from to amt) - (\rn -> rn == from || rn == to) +xferTrans reg dorec record@(XferRec _ isrec from tos _ _) accs = + foldM (xfer1 False) accs (init tos) >>= (\a -> xfer1 True a (last tos)) + where xfer1 rf as (to,amt) = maybeDo rf reg dorec record isrec as + (doXfer as from to amt) + (\rn -> rn == from || rn == to) doXfer [] _ _ _ = [] doXfer (a@(an,ab):as) nf nt e | an == nf = (an, subFrom ab e) : doXfer as nf nt e @@ -241,12 +287,23 @@ Ledger e (Record, [CCSAmt]) AccountData splitTrans reg record@(SplitRec _ ccs (Amount an) (Amount ao)) acc = let newaccs = map doST acc - in maybeRecord reg record newaccs (const True) >> return newaccs + in maybeRecord True reg record newaccs (const True) >> return newaccs where doST (a1,a2) = (a1, scaleBy a2 (CCSAmt ccs (Amount (an/ao)))) splitTrans _ r _ = intErr "splitTrans" r +{- +-- new version with printing of initial values +mkInit reg as = + let iaccs = (map (\a -> (getRecName a, maybeToList (gI a))) as) + in maybeRecord True reg (CommentRec "") iaccs (const True) >> return iaccs + where gI (AccountRec _ _ _ mi) = mi + gI r = intErr "mkInit" r +-} + mkInit :: Monad m => [Record] -> m AccountData -mkInit as = return (map (\a -> (getRecName a, [])) as) +mkInit as = return (map (\a -> (getRecName a, maybeToList (gI a))) as) + where gI (AccountRec _ _ _ mi) = mi + gI r = intErr "mkInit" r appTr :: Date -> Maybe Name -> Bool -> [Record] -> AccountData -> Ledger Record (Record, [CCSAmt]) AccountData diff --git a/UMMHelp.hs b/UMMHelp.hs --- a/UMMHelp.hs +++ b/UMMHelp.hs @@ -1,4 +1,4 @@ -{- Copyright 2009 Uwe Hollerbach +{- Copyright 2009-2010 Uwe Hollerbach This file is part of umm, Uwe's Money Manager. @@ -16,18 +16,18 @@ along with umm; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: UMMHelp.hs,v 1.28 2009/12/19 21:39:21 uwe Exp $ -} +$Id: UMMHelp.hs,v 1.34 2010/01/19 04:02:20 uwe Exp $ -} module UMMHelp (writeHdr, usageMsg) where import Prelude version :: String -version = "0.1.5" +version = "0.1.6" writeHdr :: String writeHdr = "# Uwe's Money Manager -- umm " ++ version ++ - "\n# Copyright 2009 Uwe Hollerbach \n" ++ + "\n# Copyright 2009-2010 Uwe Hollerbach \n" ++ "# Available under GPL V3 or later. Share and enjoy!\n" ++ "# http://www.korgwal.com/umm/\n" @@ -122,7 +122,7 @@ "\n" ++ "There are several kinds of records in a ledger file:\n" ++ "\n" ++ - " 'ccs' name [desc] [amount]\n" ++ + " 'ccs' name [desc] [amount] [name]\n" ++ " 'income' name [desc]\n" ++ " 'expense' name [desc]\n" ++ " 'account' name [date] [desc]\n" ++ @@ -163,8 +163,8 @@ "\n" ++ "The meaning of each record type is as follows:\n" ++ "\n" ++ - "* 'ccs name [desc] [amount]' describes a currency or commodity or\n" ++ - " security: the things you want to keep track of. The first\n" ++ + "* 'ccs name [desc] [amount] [name]' describes a currency or commodity\n" ++ + " or security: the things you want to keep track of. The first\n" ++ " ccs record in the ledger file is the default unit; my ledger\n" ++ " file has 'ccs US$' very near the top. However, you don't\n" ++ " need one, in which case the program computes in Zorkmid\n" ++ @@ -176,7 +176,9 @@ " another. The 'desc' field in a ccs record is currently just\n" ++ " for documentation, it's not used by the program. The optional\n" ++ " 'amount' field is for specifying the initial price of this ccs\n" ++ - " in units of the default ccs.\n" ++ + " in units of the second 'name' ccs, or the default ccs if no second\n" ++ + " 'name' is specified. If present, the second 'name' is also the ccs\n" ++ + " into which this ccs is translated.\n" ++ "\n" ++ "\n" ++ "* 'account name [date] [desc]' records specify accounts where you\n" ++ diff --git a/UMMParser.hs b/UMMParser.hs --- a/UMMParser.hs +++ b/UMMParser.hs @@ -1,4 +1,4 @@ -{- Copyright 2009 Uwe Hollerbach +{- Copyright 2009-2010 Uwe Hollerbach This file is part of umm, Uwe's Money Manager. @@ -16,7 +16,7 @@ along with umm; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: UMMParser.hs,v 1.39 2009/12/13 04:48:42 uwe Exp $ -} +$Id: UMMParser.hs,v 1.42 2010/01/02 22:33:34 uwe Exp $ -} -- TODO: template := @@ -137,7 +137,7 @@ return (Name (first:rest)) parseOptionalName :: Parser Name -parseOptionalName = option (Name "") (TPCP.try parseName) +parseOptionalName = option noName (TPCP.try parseName) parseInt :: Parser Integer parseInt = many1 digit >>= return . readInt @@ -173,13 +173,18 @@ parseOptionalAmount = option (Amount 1) (TPCP.try parseAmount) +parseCCSAmt :: Parser CCSAmt +parseCCSAmt = + do amt <- parseAmount + ccs <- parseOptionalName + return (CCSAmt ccs amt) + parseOneTo, parseManyTo :: Parser [(Name, CCSAmt)] parseOneTo = do to <- parseName - amt <- parseAmount - ccs <- parseOptionalName - return [(to, CCSAmt ccs amt)] + ca <- parseCCSAmt + return [(to, ca)] parseManyTo = do spaces @@ -205,7 +210,7 @@ parseReconcile :: Parser Bool parseReconcile = - option False (TPCP.try (many space >> char '*' >> return True)) + option False (TPCP.try (many space >> oneOf "*!" >> return True)) intErr :: String -> o intErr loc = error ("internal error at " ++ loc ++ ", please report this") @@ -220,9 +225,9 @@ do string "ccs" name <- parseName desc <- parseOptionalString - ma <- option Nothing (TPCP.try (parseAmount >>= - return . Just . CCSAmt noName)) - return (CCSRec name desc ma) + ma <- option Nothing (TPCP.try (parseAmount >>= return . Just)) + bname <- parseOptionalName + return (CCSRec name desc ma bname) parseIE = do rtype <- string "income" <|> string "expense" @@ -238,7 +243,8 @@ name <- parseName date <- option startTime (TPCP.try parseDate) desc <- parseOptionalString - return (AccountRec name date desc) + ival <- option Nothing (TPCP.try (parseCCSAmt >>= return . Just)) + return (AccountRec name date desc ival) parseGroup = do string "group" @@ -250,9 +256,8 @@ date <- parseDate amt1 <- parseOptionalAmount name1 <- parseName - amt2 <- parseAmount - name2 <- parseOptionalName - return (PriceRec date False (CCSAmt name1 amt1) (CCSAmt name2 amt2)) + ca2 <- parseCCSAmt + return (PriceRec date False (CCSAmt name1 amt1) ca2) parseXfer = do string "xfer" @@ -275,19 +280,17 @@ acct <- parseName amt1 <- parseAmount name1 <- parseName - amt2 <- parseAmount - name2 <- parseOptionalName + ca2 <- parseCCSAmt memo <- parseOptionalString let et = case rtype of "buy" -> B "sell" -> S "exch" -> E _ -> intErr "parseEBS" - ccsa1 = CCSAmt name1 amt1 - ccsa2 = CCSAmt name2 amt2 + ca1 = CCSAmt name1 amt1 if et == S - then return (ExchRec et date rec acct ccsa2 ccsa1 memo) - else return (ExchRec et date rec acct ccsa1 ccsa2 memo) + then return (ExchRec et date rec acct ca2 ca1 memo) + else return (ExchRec et date rec acct ca1 ca2 memo) parseSplit = do string "split" @@ -306,7 +309,7 @@ return (ToDoRec date rec (trimspace memo)) parseComment = - do many1 (char '#') + do many1 (oneOf "#;") many space comment <- many anyChar return (CommentRec (trimspace comment))