UMM 0.1.5 → 0.1.6
raw patch · 6 files changed
+251/−143 lines, 6 files
Files
- UMM.cabal +1/−1
- UMM.hs +64/−38
- UMMData.hs +49/−29
- UMMEval.hs +103/−46
- UMMHelp.hs +10/−8
- UMMParser.hs +24/−21
UMM.cabal view
@@ -1,5 +1,5 @@ Name: UMM-Version: 0.1.5+Version: 0.1.6 Homepage: http://www.korgwal.com/umm/ Author: Uwe Hollerbach <uh@alumni.caltech.edu> Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>
UMM.hs view
@@ -1,4 +1,4 @@-{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+{- Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu> 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)
UMMData.hs view
@@ -1,4 +1,4 @@-{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+{- Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu> 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 (==)
UMMEval.hs view
@@ -1,4 +1,4 @@-{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+{- Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu> 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
UMMHelp.hs view
@@ -1,4 +1,4 @@-{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+{- Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu> 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 <uh@alumni.caltech.edu>\n" +++ "\n# Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu>\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" ++
UMMParser.hs view
@@ -1,4 +1,4 @@-{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+{- Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu> 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 := <to be determined> @@ -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))