diff --git a/README b/README --- a/README +++ b/README @@ -1,4 +1,4 @@ -$Id: README,v 1.3 2009/11/21 06:05:50 uwe Exp $ +$Id: README,v 1.6 2009/11/28 16:30:16 uwe Exp $ Umm is an extremely minimal command-line program to read a plain-text ledger file and report balance and other information. Although @@ -6,11 +6,14 @@ commodities, and securities. It doesn't abolutely force you to use double-entry bookkeeping, although it tries to make it easy to do so. -Umm should have no dependencies other than a haskell compiler and -standard libraries, although I've not tested it with anything except -ghc. I've built it with ghc 6.8.3 on an iMac G3 running OSX 10.3.9, -ghc 6.10.3 on an x86 running Ubuntu, and ghc 6.10.x(1?) on an x86 -running Windows XP. You should be able to build umm simply by running +Umm has only one dependency outside of a haskell compiler and standard +libraries: in order to support Unicode, it requires the utf8-string +library. I don't know of anything in either umm itself or the +utf8-string library that's specific to ghc, but I have so far only +built it with ghc. I've built it with ghc 6.8.3 on an iMac G3 running +OSX 10.3.9, ghc 6.10.3 on an x86 running Ubuntu, and ghc 6.10.x(1?) on +an x86 running Windows XP. You should be able to build umm simply by +running cabal configure && cabal build @@ -19,10 +22,5 @@ Then look at the two files sample1.dat and sample2.dat; they are very simple examples of ledgers. -If you want to use Unicode currency symbols... umm can't do that yet. -However, please have a look at the shell script ummw in this -distribution. You'll have to do a tiny bit of editing to customize -that shell script, but you should be able to make it turn your -favorite currency symbol(s) into stuff that umm can understand, -then reverse that transformation on the output of umm. Then just -use ummw as a wrapper around umm, and you should be all set! +In the contrib/ subdirectory there is a vim syntax highlighter, contributed +by Nicolas Pouillard -- many thanks! diff --git a/UMM.cabal b/UMM.cabal --- a/UMM.cabal +++ b/UMM.cabal @@ -1,10 +1,9 @@ Name: UMM -Version: 0.1.1 +Version: 0.1.3 Homepage: http://www.korgwal.com/umm/ Author: Uwe Hollerbach Maintainer: Uwe Hollerbach -Synopsis: A small command-line accounting tool: - hledger + bugs - features? maybe... +Synopsis: A small command-line accounting tool: hledger + bugs - features? maybe... Description: This is a very minimal command-line program to read a plain-text ledger file and display balance information and other reports. I could have used hledger or ledger diff --git a/UMM.hs b/UMM.hs --- a/UMM.hs +++ b/UMM.hs @@ -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.39 2009/11/22 22:09:08 uwe Exp $ -} +$Id: UMM.hs,v 1.43 2009/11/29 23:10:11 uwe Exp $ -} module Main where import Prelude hiding (putStr,putStrLn,readFile,getContents) @@ -34,6 +34,7 @@ import UMMParser import UMMEval +processArgs :: IO (String, Command) processArgs = do prog <- getProgName args <- getArgs @@ -53,11 +54,13 @@ -- 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) @@ -65,6 +68,7 @@ -- 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) = @@ -76,24 +80,27 @@ -- 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 (CCSAmount n (Amount a)) dc date ps = - if n == dc then Nothing else xlat ps +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 _ (CCSAmount nr1 (Amount ar1)) - (CCSAmount nr2 (Amount ar2))):ps) = + xlat ((PriceRec dr _ (CCSAmt nr1 (Amount ar1)) + (CCSAmt nr2 (Amount ar2))):ps) = if compare date dr /= LT && n == nr1 && nr2 == dc - then Just ((CCSAmount dc (Amount (a*ar2/ar1))), dr) + 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 @@ -102,18 +109,21 @@ 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 - CCSAmount n (Amount a) = fst jep - jer = CCSAmount n (Amount (roundP 2 a)) - sp = "\t~" ++ show jer ++ " (" ++ show (snd jep) ++ ")" + 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 @@ -123,12 +133,13 @@ -- 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 np (negate val)) else rp np val - where rp 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)*val + vs = (fromInteger e2)*v1 n = numerator vs d = denominator vs q1 = quot n d @@ -139,10 +150,11 @@ -- contain (names of) other account-groups, including recursively, and -- loops aren't prohibited either... need to handle all those cases. -expandGroup as gs ag = +expandGroup :: [Record] -> [Record] -> Name -> [Name] +expandGroup aas ggs ag = if ag == noName || ag == todoName then [ag] - else ff [ag] (map getRecName as) (map ggt gs) [] [] + 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 @@ -152,23 +164,28 @@ | 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 COLAccts) (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) + 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 eqCCSAmountName (sortBy cmpCCSAmountName fp) + gp = groupBy eqCCSAmtName (sortBy cmpCCSAmtName fp) sp = filter (\e -> ccsA e /= 0) (map sumCCS gp) if length names == 1 && head names == todoName then putStr "" @@ -176,16 +193,20 @@ mapM_ putStrLn (ppAccts (showPos dc date prices fsel) 8) >> putStrLn ("Grand total: ~" ++ show sp) where sumCCS cs = - CCSAmount (ccsN (head cs)) (Amount (roundP 2 (sum (map ccsA cs)))) - ccsN (CCSAmount n _) = n - ccsA (CCSAmount _ (Amount a)) = a + 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 ""] @@ -198,19 +219,20 @@ 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 + 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 name date -> + BasisCmd _ _ -> putStrLn "Sorry, basis command is not implemented yet!" ToDoCmd date -> doBalance date [todoName] dc accts trans prices diff --git a/UMMData.hs b/UMMData.hs --- a/UMMData.hs +++ b/UMMData.hs @@ -16,14 +16,14 @@ 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.30 2009/11/22 22:43:06 uwe Exp $ -} +$Id: UMMData.hs,v 1.36 2009/11/29 23:10:11 uwe Exp $ -} module UMMData (Name(..), Date(..), Amount(..), start_time, Command(..), CmdOpt(..), Record(..), genDate, getRecDate, cmpRecDate, getRecName, cmpRecName, Ledger(..), runLedger, getResult, getInfo, getErrs, recordInfo, recordErr, recordNil, BSE(..), - CCSAmt(..), cmpCCSAmountName, eqCCSAmountName, + CCSAmt(..), cmpCCSAmtName, eqCCSAmtName, AccountData, noName, todoName, joinDrop, isLeap, validDate) where import Prelude import Data.Char @@ -37,8 +37,11 @@ instance Show Name where show (Name name) = name +noName, todoName, nilName :: Name + noName = Name "" todoName = Name " todo " +nilName = Name " nil " data Date = Date Int Int Int deriving (Eq) @@ -52,6 +55,7 @@ dm = compare m1 m2 in if dy /= EQ then dy else if dm /= EQ then dm else compare d1 d2 +genDate :: CalendarTime -> Date genDate (CalendarTime {ctYear = y, ctMonth = m, ctDay = d}) = let m2 = case m of January -> 1 @@ -68,12 +72,14 @@ December -> 12 in Date y m2 d +start_time :: Date start_time = Date (-4003) 10 23 -- 9 AM (GMT) newtype Amount = Amount Rational deriving (Eq, Ord) instance Show Amount where show (Amount amt) = if amt < 0 then "-" ++ shRat (-amt) else shRat amt +shRat :: Rational -> String shRat val = let n = numerator val d = denominator val @@ -89,21 +95,30 @@ then if e10 == 0 then show n else vsi ++ "." ++ vsf else show n ++ "/" ++ show d +divout :: Integer -> Integer -> (Int, Integer) divout n q = doit 0 n where doit e v = if rem v q == 0 then doit (e + 1) (quot v q) else (e,v) -data CCSAmt = CCSAmount Name Amount +data CCSAmt = CCSAmt Name Amount instance Show CCSAmt where - show (CCSAmount name amount) = joinDrop [show amount, show name] + show (CCSAmt name amount) = joinDrop [show amount, show name] --- Compare two CCSAmounts by name +-- Compare two CCSAmts by name -cmpCCSAmountName (CCSAmount n1 _) (CCSAmount n2 _) = compare n1 n2 -eqCCSAmountName (CCSAmount n1 _) (CCSAmount n2 _) = n1 == n2 +cmpCCSAmtName :: CCSAmt -> CCSAmt -> Ordering +cmpCCSAmtName (CCSAmt n1 _) (CCSAmt n2 _) = compare n1 n2 +eqCCSAmtName :: CCSAmt -> CCSAmt -> Bool +eqCCSAmtName (CCSAmt n1 _) (CCSAmt n2 _) = n1 == n2 + +-- All accounts: an array of tuples of names and amounts +-- TODO: make this a newtype? + +type AccountData = [(Name, [CCSAmt])] + data CmdOpt = COLAll | COLCCS - | COLAccts + | COLAccs | COLGrps | COLIncs | COLExps @@ -112,7 +127,7 @@ instance Show CmdOpt where show COLAll = "all" show COLCCS = "ccs" - show COLAccts = "accounts" + show COLAccs = "accounts" show COLGrps = "groups" show COLIncs = "incomes" show COLExps = "expenses" @@ -151,13 +166,13 @@ show S = "sell" show E = "exch" -data Record = CCSRec Name String +data Record = CCSRec Name String (Maybe CCSAmt) | IncomeRec Name String | ExpenseRec Name String | AccountRec Name Date String | GroupRec Name [Name] | PriceRec Date Bool CCSAmt CCSAmt - | XferRec Date Bool Name Name CCSAmt String Int + | XferRec Date Bool Name Name CCSAmt String String | ExchRec BSE Date Bool Name CCSAmt CCSAmt String | SplitRec Date Name Amount Amount | CommentRec String @@ -169,23 +184,32 @@ -- We use "show str" here to add quotes and escape any escapables +optStr :: String -> String optStr str = if str == "" then "" else show str +shRec :: Bool -> String shRec rec = if rec then "*" else "" +mAmt :: Maybe CCSAmt -> String +mAmt Nothing = "" +mAmt (Just a) = show a + +joinDrop :: [String] -> String joinDrop ss = intercalate " " (filter (\s -> s /= "") ss) -showR (CCSRec n d) = joinDrop ["ccs", show n, optStr d] +showR :: Record -> String +showR (CCSRec n d a) = joinDrop ["ccs", show n, optStr d, mAmt a] 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 (GroupRec n as) = joinDrop (["group", show n] ++ map show as) showR (PriceRec d imp c1 c2) = - joinDrop ["price", shRec imp, show d, show c1, show c2] + (if imp then "[" else "") ++ + joinDrop ["price", show d, show c1, show c2] ++ + (if imp then "]" else "") -showR (XferRec d r a1 a2 c memo chknum) = - joinDrop ["xfer", shRec r, show d, show a1, show a2, - show c, optStr memo, (if chknum == 0 then "" else show chknum)] +showR (XferRec d r a1 a2 c m i) = + joinDrop ["xfer", shRec r, show d, show a1, show a2, show c, optStr m, i] showR (ExchRec t d r a c1 c2 memo) = let hs = if t == S then [show c2, show c1] else [show c1, show c2] @@ -204,6 +228,7 @@ -- Get the date (or at any rate /some/ date) from a Record +getRecDate :: Record -> Date getRecDate (AccountRec _ d _) = d getRecDate (PriceRec d _ _ _) = d getRecDate (XferRec d _ _ _ _ _ _) = d @@ -214,19 +239,21 @@ -- Get the name (or at any rate /some/ name) from a Record -getRecName (CCSRec n _) = n +getRecName :: Record -> Name +getRecName (CCSRec n _ _) = n getRecName (IncomeRec n _) = n getRecName (ExpenseRec n _) = n getRecName (AccountRec n _ _) = n getRecName (GroupRec n _) = n -getRecName _ = Name " nil " -- so it works for every Record +getRecName _ = nilName -- so it works for every Record --- Compare two Records by date +-- Compare two Records +cmpRecDate, cmpRecName :: Record -> Record -> Ordering +-- by date cmpRecDate v1 v2 = compare (getRecDate v1) (getRecDate v2) --- Compare two Records by name - +-- by name cmpRecName v1 v2 = compare (getRecName v1) (getRecName v2) -- Ledger monad: essentially a parametrized bi-level version of the Logger @@ -237,22 +264,32 @@ newtype Ledger e i r = Ledger (r, [i], [e]) deriving (Show) +runLedger :: Ledger e i r -> (r,[i],[e]) runLedger (Ledger a) = a + +getResult :: Ledger e i r -> r getResult (Ledger (r,_,_)) = r + +getInfo :: Ledger e i r -> [i] getInfo (Ledger (_,i,_)) = i + +getErrs :: Ledger e i r -> [e] getErrs (Ledger (_,_,e)) = e -- Record a message +recordInfo :: i -> Ledger e i () recordInfo i = Ledger ((), [i], []) -- Record an error +recordErr :: e -> Ledger e i () recordErr e = Ledger ((), [], [e]) -- Record nothing: a placeholder for conditionals: -- if someCond then recordErr "someErr" else recordNil +recordNil :: Ledger e i () recordNil = Ledger ((), [], []) -- Note that because we use append (++) for lists here, this is fairly @@ -272,8 +309,11 @@ -- Some miscellany -- divisible by 4 except if divisible by 100 except if divisible by 400 + +isLeap :: Int -> Bool isLeap y = rem y 4 == 0 && (rem y 100 /= 0 || rem y 400 == 0) +validDate :: Date -> Bool validDate (Date y m d) = let lim = [ 0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ] !! m in (m >= 1 && m <= 12 && d >= 1 && diff --git a/UMMEval.hs b/UMMEval.hs --- a/UMMEval.hs +++ b/UMMEval.hs @@ -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: UMMEval.hs,v 1.24 2009/11/22 22:09:08 uwe Exp $ -} +$Id: UMMEval.hs,v 1.28 2009/11/29 23:10:12 uwe Exp $ -} module UMMEval (validateRecs, classifyRecs, validateTransPrices, generateImplicitPrices, getBalances, getPrices) where @@ -28,10 +28,22 @@ import UMMData +-- Internal error: complain loudly! + +intErr :: (Show i) => String -> i -> o +intErr loc w = + error ("internal error at " ++ loc ++ "\ngot unexpected " ++ show w) + +-- Add the default ccs to a CCSAmt that has a blank ccs + +addDCCA :: Name -> CCSAmt -> CCSAmt +addDCCA dc c@(CCSAmt n a) = if n == noName then CCSAmt dc a else c + -- Initial validation of records: filter out comments, highlight parse -- errors, and check that dates are valid. This is kind of a trivial -- use of runLedger, it could almost be accomplished by partition. +validateRecs :: [Record] -> IO [Record] validateRecs records = do let (_,i,e) = runLedger (chk records) if length e == 0 @@ -49,20 +61,12 @@ -- Classify records by type and sort accounts and -- transaction-type records by date or name as needed -uErr v1 v2 = - error ("duplicate records\n " ++ show v1 ++ "\n " ++ show v2) - -uChk [] = [] -uChk s@(_:[]) = s -uChk v@(v1:v2:[]) = - if getRecName v1 == getRecName v2 then uErr v1 v2 else v -uChk (v1:v2:vs) = - if getRecName v1 == getRecName v2 then uErr v1 v2 else v1 : uChk (v2:vs) - -- TODO: should really check that there are no duplications among -- account names and account group names together, rather than -- separately (or just account groups, right now) +classifyRecs :: [Record] -> (Name, [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) @@ -70,7 +74,7 @@ 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 + 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 @@ -78,6 +82,13 @@ PriceRec _ _ _ _ -> cw rs c i e a g t (r:p) _ -> cw rs c i e a g (r:t) p vsN rs = uChk (sortBy cmpRecName rs) + 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) asD dc rs = sortBy cmpRecDate (reverse (map (addDC dc) rs)) addDC dc (PriceRec d imp ccsa1 ccsa2) = PriceRec d imp ccsa1 (addDCCA dc ccsa2) @@ -86,8 +97,6 @@ addDC dc (ExchRec t d f acc ccsa1 ccsa2 m) = ExchRec t d f acc (addDCCA dc ccsa1) (addDCCA dc ccsa2) m addDC _ r = r - addDCCA dc c@(CCSAmount n a) = - if n == noName then CCSAmount dc a else c -- Second validation of transactions: check that all from & to accounts -- are valid, that splits aren't 1/0 or 0/1, etc @@ -96,6 +105,8 @@ -- through runLedger as above? then we could generate multiple output -- records for (some of) each input record +validateTransPrices :: [Record] -> [Record] -> [Record] -> + [Record] -> [Record] -> IO () validateTransPrices ccs incs exps accts tps = do let bads = filter chk tps when (length bads > 0) @@ -103,13 +114,13 @@ >> mapM_ (putStrLn . show) bads >> error "quitting now") where chk (SplitRec _ c (Amount amt1) (Amount amt2)) = amt1 == 0 || amt2 == 0 || notIn c ccs - chk (PriceRec _ _ (CCSAmount c1 amt1) (CCSAmount c2 _)) = + chk (PriceRec _ _ (CCSAmt c1 amt1) (CCSAmt c2 _)) = amt1 == Amount 0 || notIn c1 ccs || notIn c2 ccs - chk (XferRec _ _ af at (CCSAmount n _) _ _) = + chk (XferRec _ _ af at (CCSAmt n _) _ _) = (notIn af incs && notIn af accts) || (notIn at exps && notIn at accts) || notIn n ccs - chk (ExchRec _ _ _ a (CCSAmount c1 _) (CCSAmount c2 _) _) = + chk (ExchRec _ _ _ a (CCSAmt c1 _) (CCSAmt c2 _) _) = notIn a accts || notIn c1 ccs || notIn c2 ccs chk (ToDoRec _ _ _) = False chk _ = True @@ -121,22 +132,35 @@ -- want. Only generate info for transactions involving the default currency, -- other stuff is too hard to untangle at least for now. -generateImplicitPrices dc trs = gip [] trs - where gip acc [] = filter pr acc +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 start_time True (CCSAmt n (Amount 1)) (addDCCA dc a) + gii r = intErr "generateImplicitPrices:2" r + gip acc [] = filter pr acc gip acc (t@(ExchRec _ _ _ _ _ _ _):ts) = gip ((genp t) : acc) ts gip acc (_:ts) = gip acc ts - genp (ExchRec _ date _ _ (CCSAmount n1 a1) (CCSAmount n2 a2) _) + genp (ExchRec _ date _ _ (CCSAmt n1 a1) (CCSAmt n2 a2) _) | n1 == dc = PriceRec date True (nC n2 a2 a2) (nC n1 a1 a2) | n2 == dc = PriceRec date True (nC n1 a1 a1) (nC n2 a2 a1) | otherwise = CommentRec "general exchange, no price generated" + genp r = intErr "generateImplicitPrices:3" r pr (PriceRec _ _ _ _) = True pr _ = False nC n (Amount a1) (Amount a2) = - CCSAmount n (Amount (if a2 == 0 then a1 else a1/a2)) + CCSAmt n (Amount (if a2 == 0 then a1 else a1/a2)) -getCN (CCSAmount n _) = n -getCA (CCSAmount _ (Amount a)) = a +getCN :: CCSAmt -> Name +getCN (CCSAmt n _) = n +getCA :: CCSAmt -> Rational +getCA (CCSAmt _ (Amount a)) = a + +addTo :: [CCSAmt] -> CCSAmt -> [CCSAmt] addTo [] n = [n] addTo (q:qs) d = let qn = getCN q @@ -145,30 +169,35 @@ dq = getCA d nq = qq + dq in if qn == dn - then if nq == 0 - then qs - else (CCSAmount qn (Amount nq)) : qs + then if nq == 0 then qs else (CCSAmt qn (Amount nq)) : qs else q : addTo qs d -subFrom acc d = addTo acc (CCSAmount (getCN d) (Amount (-(getCA d)))) +subFrom :: [CCSAmt] -> CCSAmt -> [CCSAmt] +subFrom acc d = addTo acc (CCSAmt (getCN d) (Amount (-(getCA d)))) +scaleBy :: [CCSAmt] -> CCSAmt -> [CCSAmt] scaleBy qs d = map (s1 (getCN d) (getCA d)) qs where s1 dn dq q = let qn = getCN q qq = getCA q - in if qn == dn then (CCSAmount qn (Amount (qq * dq))) else q + in if qn == dn then (CCSAmt qn (Amount (qq * dq))) else q +maybeRecord :: Maybe Name -> Record -> AccountData -> (Name -> Bool) -> + Ledger e (Record, [CCSAmt]) () maybeRecord reg record newaccs tst = let isJ = isJust reg rn = fromJust reg acc = filter (\a -> fst a == rn) newaccs nb = if length acc > 0 then snd (head acc) - else [CCSAmount noName (Amount 0)] + else [CCSAmt noName (Amount 0)] in if isJ && (tst rn || rn == noName) then recordInfo (record, nb) else recordNil +maybeDo :: Maybe Name -> Bool -> Record -> Bool -> + AccountData -> AccountData -> (Name -> Bool) -> + Ledger e (Record, [CCSAmt]) AccountData maybeDo reg dorec record isrec accs newaccs tst = if dorec then if isrec @@ -176,6 +205,8 @@ else maybeRecord reg record newaccs tst >> return accs else maybeRecord 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 (doExch accs acc amtn amto) (\rn -> rn == acc) @@ -184,7 +215,10 @@ if an == n then (an, subFrom (addTo ab en) eo) : as else (an,ab) : doExch as n en eo +exchTrans _ _ r _ = intErr "exchTrans" r +xferTrans :: Maybe Name -> Bool -> Record -> AccountData -> + Ledger e (Record, [CCSAmt]) AccountData xferTrans reg dorec record@(XferRec _ isrec from to amt _ _) accs = maybeDo reg dorec record isrec accs (doXfer accs from to amt) (\rn -> rn == from || rn == to) @@ -193,19 +227,26 @@ | an == nf = (an, subFrom ab e) : doXfer as nf nt e | an == nt = (an, addTo ab e) : doXfer as nf nt e | otherwise = a : doXfer as nf nt e +xferTrans _ _ r _ = intErr "xferTrans" r -- TODO: look into account and see if split is applicable? yeah... cleaner -- Also: does maybeDo apply here, too? I think probably it should... -- but is this a reconcilable transaction? It reaches across accounts, -- so maybe not +splitTrans :: Maybe Name -> Record -> AccountData -> + 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 (\_ -> True) >> return newaccs - where doST (a1,a2) = (a1, scaleBy a2 (CCSAmount ccs (Amount (an/ao)))) + where doST (a1,a2) = (a1, scaleBy a2 (CCSAmt ccs (Amount (an/ao)))) +splitTrans _ r _ = intErr "splitTrans" r +mkInit :: Monad m => [Record] -> m AccountData mkInit as = return (map (\a -> (getRecName a, [])) as) +appTr :: Date -> Maybe Name -> Bool -> [Record] -> AccountData -> + Ledger Record (Record, [CCSAmt]) AccountData appTr _ _ _ [] as = return as appTr d r f (t:ts) as = if getRecDate t > d @@ -219,11 +260,15 @@ >> appTr d r f ts as _ -> recordErr t >> appTr d r f ts as +showT :: (Record, [CCSAmt]) -> IO () showT (t,_) = putStrLn (show t) +showTB :: (Record, [CCSAmt]) -> IO () showTB e@(_,b) = showT e >> mapM_ sB b where sB ccsa = putStrLn ("\t" ++ show ccsa) +getBalances :: Date -> Date -> Maybe Name -> Bool -> + [Record] -> [Record] -> IO AccountData getBalances date1 date2 reg dorec accts trans = do let (r,i1,e) = runLedger (mkInit accts >>= appTr date2 reg dorec trans) i = dropWhile (\t -> compare (getRecDate (fst t)) date1 == LT) i1 @@ -237,6 +282,7 @@ -- For now, we don't generate "swap prices" internally, so unless the user -- enters some, we won't see any; see also generateImplicitPrices above. +getPrices :: Name -> Name -> Date -> [Record] -> IO () getPrices nm dc date prices = do let p1 = dropWhile (\t -> compare date (getRecDate t) == LT) prices (_,i,e) = runLedger (get p1) @@ -245,7 +291,7 @@ when (length e == 0 && length i == 0) (putStrLn ("No prices known for " ++ show nm)) where get [] = return () - get (p@(PriceRec _ _ (CCSAmount nr1 _) (CCSAmount nr2 _)):ps) = + get (p@(PriceRec _ _ (CCSAmt nr1 _) (CCSAmt nr2 _)):ps) = if (nr1 == nm && nr2 == dc) || (nr1 == dc && nr2 == nm) then recordInfo p >> get ps else if (nr1 == nm || nr2 == nm) diff --git a/UMMHelp.hs b/UMMHelp.hs --- a/UMMHelp.hs +++ b/UMMHelp.hs @@ -16,14 +16,16 @@ 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.16 2009/11/22 22:09:09 uwe Exp $ -} +$Id: UMMHelp.hs,v 1.19 2009/11/29 23:10:13 uwe Exp $ -} module UMMHelp (writeHdr, usageMsg) where import Prelude hiding (putStr,putStrLn) import System.IO.UTF8 -version = "0.1.1" +version :: String +version = "0.1.3" +writeHdr :: IO () writeHdr = putStrLn ("Uwe's Money Manager -- umm " ++ version ++ @@ -34,6 +36,7 @@ -- TODO: store these unadorned in some separate text files, and use -- a program (Template Haskell?) to turn them into proper source code +usageMsg :: String -> String usageMsg prog = "usage is '" ++ prog ++ " '\n" ++ "where and can be any of the following:\n" ++ @@ -116,7 +119,7 @@ "\n" ++ "There are several kinds of records in a ledger file:\n" ++ "\n" ++ - " 'ccs' name [desc]\n" ++ + " 'ccs' name [desc] [amount]\n" ++ " 'income' name [desc]\n" ++ " 'expense' name [desc]\n" ++ " 'account' name [date] [desc]\n" ++ @@ -149,7 +152,7 @@ "\n" ++ "The meaning of each record type is as follows:\n" ++ "\n" ++ - "* 'ccs name [desc]' describes a currency or commodity or\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 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" ++ @@ -160,7 +163,9 @@ " and 'sell') records, but they probably won't be very useful,\n" ++ " since all you can do is to trade one amount of Zorkmids for\n" ++ " another. The 'desc' field in a ccs record is currently just\n" ++ - " for documentation, it's not used by the program.\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" ++ "\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 @@ -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.29 2009/11/22 22:09:09 uwe Exp $ -} +$Id: UMMParser.hs,v 1.34 2009/11/29 23:10:14 uwe Exp $ -} -- TODO: template := @@ -28,9 +28,11 @@ import UMMData +readInt :: String -> Integer readInt s = foldl ma 0 s where ma v1 v2 = 10*v1 + (toInteger (digitToInt v2)) +readAmt :: String -> String -> Rational readAmt ip fp = let l = length fp e = 10^l @@ -38,12 +40,16 @@ fv = readInt fp in (e*iv + fv) % e +trimspace :: String -> String trimspace str = f (f str) where f = dropWhile isSpace . reverse -- Hide parsec's spaces and substitute this one: -- want "spaces" to mean an actual something there +spaces, parseString, parseOptionalString, parseXferID :: Parser String +escChar, currency_symbol, other_symbol :: Parser Char + spaces = many1 space escChar = @@ -75,70 +81,76 @@ -- Currency symbols: do allow these as the first char of a name -- gathered from various places on the web, mainly unicode.org -currency_symbol = oneOf $ - map chr [0x24, -- dollar - 0xa2, -- cent - 0xa3, -- pound - 0xa4, -- generic currency symbol - 0xa5, -- yen - 0x192, -- florin - 0x9f2, -- Bengali rupee 1 - 0x9f3, -- Bengali rupee 2 - 0xaf1, -- gujarati rupee - 0xbf9, -- Tamil rupee - 0xe2f, -- Thai baht - 0x17db, -- Khmer currency symbol - 0x20a0, -- euro-currency (not euro) - 0x20a1, -- colon - 0x20a2, -- Brazilian cruzeiro - 0x20a3, -- French franc - 0x20a4, -- Italian lira - 0x20a5, -- mill - 0x20a6, -- Nigerian naira - 0x20a7, -- Spanish peseta - 0x20a8, -- Indian rupee - 0x20a9, -- Korean won - 0x20aa, -- Israeli new sheqel - 0x20ab, -- Vietnamese dong - 0x20ac, -- European euro - 0x20ad, -- Laotian kip - 0x20ae, -- Mongolian tugrik - 0x20af, -- Greek drachma - 0x20b0, -- German pfennig - 0x20b1, -- Phillipine peso - 0x20b2, -- Paraguayan guarani ??? - 0x20b3, -- austral ??? - 0x20b4, -- Ukrainian hryvnia ??? - 0x20b5, -- Ghanaian cedi ??? - 0x20b6, -- livre tournois ??? - 0x20b7, -- spesmilo ??? - 0x20b8, -- tenge ??? - 0x3350, -- yuan 1 - 0x5143, -- Chinese yuan - 0x5186, -- yen 2 - 0x5706, -- yen/yuan variant - 0x570e, -- yen/yuan variant - 0x5713, -- yuan variant - 0x571c, -- yuan variant - 0xa838, -- North Indic rupee ??? - 0xfdfc] -- Iranian rial +currency_symbol = + oneOf ['\x24', -- dollar + '\xa2', -- cent + '\xa3', -- pound + '\xa4', -- generic currency symbol + '\xa5', -- yen + '\x192', -- florin + '\x9f2', -- Bengali rupee 1 + '\x9f3', -- Bengali rupee 2 + '\xaf1', -- gujarati rupee + '\xbf9', -- Tamil rupee + '\xe2f', -- Thai baht + '\x17db', -- Khmer currency symbol + '\x20a0', -- euro-currency (not euro) + '\x20a1', -- colon + '\x20a2', -- Brazilian cruzeiro + '\x20a3', -- French franc + '\x20a4', -- Italian lira + '\x20a5', -- mill + '\x20a6', -- Nigerian naira + '\x20a7', -- Spanish peseta + '\x20a8', -- Indian rupee + '\x20a9', -- Korean won + '\x20aa', -- Israeli new sheqel + '\x20ab', -- Vietnamese dong + '\x20ac', -- European euro + '\x20ad', -- Laotian kip + '\x20ae', -- Mongolian tugrik + '\x20af', -- Greek drachma + '\x20b0', -- German pfennig + '\x20b1', -- Phillipine peso + '\x20b2', -- Paraguayan guarani ??? + '\x20b3', -- austral ??? + '\x20b4', -- Ukrainian hryvnia ??? + '\x20b5', -- Ghanaian cedi ??? + '\x20b6', -- livre tournois ??? + '\x20b7', -- spesmilo ??? + '\x20b8', -- tenge ??? + '\x3350', -- yuan 1 + '\x5143', -- Chinese yuan + '\x5186', -- yen 2 + '\x5706', -- yen/yuan variant + '\x570e', -- yen/yuan variant + '\x5713', -- yuan variant + '\x571c', -- yuan variant + '\xa838', -- North Indic rupee ??? + '\xfdfc'] -- Iranian rial -- Non-currency symbols: don't allow these as the first character of a name other_symbol = oneOf "!%&*+-/:<=>?@^_~" +parseName :: Parser Name parseName = do spaces first <- letter <|> currency_symbol rest <- many (letter <|> currency_symbol <|> digit <|> other_symbol) return (Name (first:rest)) +parseOptionalName :: Parser Name parseOptionalName = option (Name "") (TPCP.try parseName) +parseInt :: Parser Integer parseInt = many1 digit >>= return . readInt +parseXferID = spaces >> many1 (digit <|> letter <|> oneOf "-/_@") + -- Parse first alternative for amounts: \d+(\.\d*)? +parseAmt1, parseAmt2, parseAmt3 :: Parser Rational parseAmt1 = do ip <- many1 digit fp <- option "" (char '.' >> many digit) @@ -146,23 +158,18 @@ -- Parse second alternative for amounts: \.\d+ -parseAmt2 = - do char '.' - fp <- many1 digit - return (readAmt "0" fp) +parseAmt2 = char '.' >> many1 digit >>= (\fp -> return (readAmt "0" fp)) -- Parse third alternative for amounts: \d+/\d+: this is how rationals -- get displayed if they're not integers scaled by a power of 10, so -- we'd better be able to handle them... -parseAmt3 = - do n <- parseInt - char '/' - d <- parseInt - return (n%d) +parseAmt3 = parseInt >>= (\n -> char '/' >> parseInt >>= (\d -> return (n%d))) -- Parse a floating-point-formatted number as either \d+(\.\d*)? or \.\d+ +parseAmount, parseOptionalAmount :: Parser Amount + parseAmount = do many space s <- option '+' (oneOf "+-") @@ -179,31 +186,44 @@ -- whether days come first or months, and also no implicit 19xx or 20xx -- or whatever. +parseDate :: Parser Date parseDate = do spaces y <- parseInt m <- pMS '/' <|> pMS '-' d <- parseInt return (Date (fromInteger y) (fromInteger m) (fromInteger d)) - where pMS s = - do char s - m <- parseInt - char s - return m + where pMS s = char s >> parseInt >>= (\m -> char s >> return m) +parseReconcile :: Parser Bool parseReconcile = option False (TPCP.try (many space >> char '*' >> return True)) +intErr :: String -> o +intErr loc = error ("internal error at " ++ loc ++ ", please report this") + -- The top-level record parsers -parseCIE = - do rtype <- string "ccs" <|> string "income" <|> string "expense" +parseCCS, parseIE, parseAccount, parseGroup, parsePrice, parseXfer, + parseEBS, parseSplit, parseTodo, parseComment, parseBlank, parseRecord :: + Parser Record + +parseCCS = + do string "ccs" name <- parseName desc <- parseOptionalString + ma <- option Nothing (TPCP.try (parseAmount >>= + return . Just . (CCSAmt noName))) + return (CCSRec name desc ma) + +parseIE = + do rtype <- string "income" <|> string "expense" + name <- parseName + desc <- parseOptionalString return (case rtype of - "ccs" -> CCSRec name desc "income" -> IncomeRec name desc - "expense" -> ExpenseRec name desc) + "expense" -> ExpenseRec name desc + _ -> intErr "parseIE") parseAccount = do string "account" @@ -224,7 +244,7 @@ name1 <- parseName amt2 <- parseAmount name2 <- parseOptionalName - return (PriceRec date False (CCSAmount name1 amt1) (CCSAmount name2 amt2)) + return (PriceRec date False (CCSAmt name1 amt1) (CCSAmt name2 amt2)) parseXfer = do string "xfer" @@ -235,9 +255,8 @@ amt <- parseAmount ccs <- parseOptionalName memo <- parseOptionalString - chknum <- option 0 (TPCP.try (spaces >> parseInt)) - return (XferRec date rec acc1 acc2 (CCSAmount ccs amt) - memo (fromInteger chknum)) + ident <- option "" (TPCP.try parseXferID) + return (XferRec date rec acc1 acc2 (CCSAmt ccs amt) memo ident) -- 'buy' and 'sell' are purely syntactic sugar for 'exch': 'buy' is -- exactly the same, and 'sell' is the same as if {amt1,ccs1} and @@ -257,8 +276,9 @@ "buy" -> B "sell" -> S "exch" -> E - ccsa1 = CCSAmount name1 amt1 - ccsa2 = CCSAmount name2 amt2 + _ -> intErr "parseEBS" + ccsa1 = CCSAmt name1 amt1 + ccsa2 = CCSAmt name2 amt2 if et == S then return (ExchRec et date rec acct ccsa2 ccsa1 memo) else return (ExchRec et date rec acct ccsa1 ccsa2 memo) @@ -291,11 +311,12 @@ do many space record <- parsePrice <|> parseXfer - <|> (TPCP.try parseCIE) + <|> parseCCS + <|> (TPCP.try parseIE) <|> (TPCP.try parseEBS) <|> parseSplit <|> parseTodo - <|> (TPCP.try parseAccount) + <|> parseAccount <|> parseGroup <|> parseComment <|> parseBlank -- this must be last, as it can match nothing @@ -303,18 +324,26 @@ eof return record +parseURecord :: String -> Record parseURecord input = case parse parseRecord "umm record" input of Left _ -> ErrorRec input Right val -> val +parseUDate :: String -> Either ParseError Date parseUDate input = parse parseDate "umm date" (" " ++ input) +parsePrefixOf :: Int -> String -> Parser String parsePrefixOf n str = string (take n str) >> opts (drop n str) >> return str where opts [] = return () opts (c:cs) = optional (char c >> opts cs) +parseCmdBalance, parseCmdBasis, parseCmdChange, parseCmdPrice, + parseCmdReconcile, parseCmdRegister, parseCmdToDo, parseCommand :: + Date -> Parser Command +parseCmdList :: Parser Command + parseCmdBalance now = do parsePrefixOf 3 "balance" name <- parseOptionalName @@ -351,10 +380,11 @@ return (ListDataCmd (case w of "all" -> COLAll "ccs" -> COLCCS - "accounts" -> COLAccts + "accounts" -> COLAccs "groups" -> COLGrps "incomes" -> COLIncs - "expenses" -> COLExps)) + "expenses" -> COLExps + _ -> intErr "parseListCmd")) parseCmdPrice now = do parsePrefixOf 1 "price" @@ -394,6 +424,7 @@ eof return cmd +parseUCommand :: Date -> String -> Command parseUCommand now input = case parse (parseCommand now) "umm command" input of Left err -> error (show err) diff --git a/contrib/umm.vim b/contrib/umm.vim new file mode 100644 --- /dev/null +++ b/contrib/umm.vim @@ -0,0 +1,25 @@ +" Filename: umm.vim +" Purpose: Vim syntax file +" Language: UMM +" Maintainer: Nicolas Pouillard +" URL: + +" For version 6.x: Quit when a syntax file was already loaded +if exists("b:current_syntax") + finish +endif + +syn match ummDate /\d\{4\}-\d\{1,2\}-\d\{1,2\}/ +syn match String /"\([^"\\]\|\\.\)*"/ +syn match Comment /#.*$/ +syn match ummAmount /\<\d\+\(\.\d*\)\?\>/ +syn match Keyword /xfer\|account\|income\|expense\|price\|ccs\|exch\|sell\|buy\|group\|todo\|split/ +syn match ummRec /\*/ + +hi link ummDate Structure +hi link ummAmount Number +hi link ummRec Identifier + +let b:current_syntax = "umm" + +" vim: ts=8