diff --git a/UMM.cabal b/UMM.cabal --- a/UMM.cabal +++ b/UMM.cabal @@ -1,5 +1,5 @@ Name: UMM -Version: 0.1.4 +Version: 0.1.5 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 @@ -16,17 +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: UMM.hs,v 1.47 2009/12/05 22:31:37 uwe Exp $ -} +$Id: UMM.hs,v 1.53 2009/12/15 06:05:44 uwe Exp $ -} module Main where import Prelude hiding (putStr,putStrLn,print,readFile,getContents) import Control.Monad import Data.List import Data.Maybe -import Data.Ratio -import System import System.Exit import System.IO.UTF8 +import System.Environment.UTF8 import System.Time import UMMHelp @@ -52,19 +51,10 @@ (exitWith ExitSuccess) return (fname, cmd) --- A version of 'lines' which deals with all combinations of '\r' and '\n'. --- It drops blank lines, which is perfectly fine here, but which might be --- a problem elsewhere. - -mylines :: String -> [String] -mylines str = filter (/= "") (ml str) - where ml [] = [] - ml s = let (p, s1) = break (\c -> c == '\n' || c == '\r') s - in p : (if null s1 then [] else ml (tail s1)) - getLines :: String -> IO [String] getLines fp = - (if fp == "-" then getContents else readFile fp) >>= (return . mylines) + (if fp == "-" then getContents else readFile fp) >>= + (return . mergelines . mylines) -- Merge explicit (ps) and implicit (qs) prices: the inputs are sorted -- by date, newest first, and the output is the same, preferring @@ -96,9 +86,7 @@ -- 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 +reprice ccs dc date prices = maybe ccs fst (equivPrice ccs dc date prices) -- Pretty-print accounts @@ -129,24 +117,7 @@ selAccts keep names accs = f2 (f1 accs) where f0 = filter (\a -> elem (fst a) names) f1 = if length names == 1 && head names == noName then id else f0 - f2 = if keep then id else filter (\a -> not (null (snd a))) - --- Round a rational number val to np decimal places --- This might not be ultimately exact, but it's for converted prices --- which might be a couple of days out of date anyway, so no big deal - -roundP :: Int -> Rational -> Rational -roundP np val = - if val < 0 then negate (rp (negate val)) else rp val - where rp v1 = - let e1 = 10 ^ max 0 np - e2 = 10*e1 - vs = v1 * fromInteger e2 - n = numerator vs - d = denominator vs - q1 = quot n d - q2 = quot (q1 + 4) 10 - in q2 % e1 + f2 = if keep then id else filter (not . null . snd) -- Turn an account-group into a list of accounts. An account-group can -- contain (names of) other account-groups, including recursively, and @@ -226,7 +197,8 @@ -- which involve ccs "n0" hasCur :: Name -> Record -> Bool -hasCur c (XferRec _ _ _ _ (CCSAmt n1 _) _ _) = c == n1 +hasCur c (XferRec _ _ _ tos _ _) = any hC tos + where hC (_, CCSAmt n _) = c == n hasCur c (ExchRec _ _ _ _ (CCSAmt n1 _) (CCSAmt n2 _) _) = c == n1 || c == n2 hasCur c (SplitRec _ n1 _ _) = c == n1 hasCur _ (ToDoRec _ _ _) = False @@ -249,7 +221,7 @@ dc accts trans prices BasisCmd name date -> doBalance False date [noName] dc accts (filter (hasCur name) trans) [] - ExportCmd -> mapM_ pse trans + ExportCmd -> mapM_ pse trans >> mapM_ pse (reverse prices) ListDataCmd w -> doList w dc ccs accts grps incs exps PriceCmd name date -> diff --git a/UMMData.hs b/UMMData.hs --- a/UMMData.hs +++ b/UMMData.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: UMMData.hs,v 1.39 2009/12/05 20:30:42 uwe Exp $ -} +$Id: UMMData.hs,v 1.45 2009/12/14 04:58:06 uwe Exp $ -} module UMMData (Name(..), Date(..), Amount(..), startTime, Command(..), CmdOpt(..), Record(..), genDate, @@ -24,10 +24,12 @@ Ledger(..), runLedger, getResult, getInfo, getErrs, recordInfo, recordErr, recordNil, showExp, BSE(..), CCSAmt(..), cmpCCSAmtName, eqCCSAmtName, AccountData, - noName, todoName, joinDrop, isLeap, validDate) where + noName, todoName, joinDrop, roundP, isLeap, validDate, + trimspace, mylines, mergelines) where import Prelude import Data.Char import Data.List +import Data.Ord import Data.Ratio import System.Time @@ -174,7 +176,7 @@ | AccountRec Name Date String | GroupRec Name [Name] | PriceRec Date Bool CCSAmt CCSAmt - | XferRec Date Bool Name Name CCSAmt String String + | XferRec Date Bool Name [(Name, CCSAmt)] String String | ExchRec BSE Date Bool Name CCSAmt CCSAmt String | SplitRec Date Name Amount Amount | CommentRec String @@ -210,8 +212,8 @@ joinDrop ["price", show d, show c1, show c2] ++ (if imp then "]" else "") -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 (XferRec d r from tos m i) = + joinDrop ["xfer", shRec r, show d, show from, showTos tos, 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] @@ -228,22 +230,34 @@ showR (ErrorRec str) = joinDrop ["#err", str] +showTos :: [(Name, CCSAmt)] -> String +showTos [] = "{}" +showTos (t:[]) = showTo1 False t +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] + showExp :: Record -> String -showExp (XferRec d r a1 a2 c m i) = +showExp (XferRec d r from tos m i) = let l1 = joinDrop [show d, shRec r, i, if m == "" then "transfer" else m] - l2 = joinDrop [show a2, show c] - l3 = joinDrop [show a1] - in intercalate "\n " [l1, l2, l3] + 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] - l2 = joinDrop [show a, show c1] - l3 = joinDrop [show a, show (CCSAmt n2 (Amount (-a2)))] + l2 = joinDrop [show a, ' ' : show c1] + l3 = joinDrop [show a, ' ' : show (CCSAmt n2 (Amount (-a2)))] l4 = "the:world" in intercalate "\n " [l1, l2, l3, l4] +showExp (PriceRec d _ (CCSAmt n1 (Amount a1)) (CCSAmt n2 (Amount a2))) = + joinDrop ["P", show d, show n1, + ' ' : show (CCSAmt n2 (Amount (roundP 4 (a2/a1))))] + showExp (SplitRec _ _ _ _) = "# Split to be implemented" -showExp (PriceRec _ _ _ _) = "# Price to be implemented" +showExp r@(ToDoRec _ _ _) = "# " ++ showR r showExp r = error ("internal error at showExp! got " ++ show r) -- Get the date (or at any rate /some/ date) from a Record @@ -251,7 +265,7 @@ getRecDate :: Record -> Date getRecDate (AccountRec _ d _) = d getRecDate (PriceRec d _ _ _) = d -getRecDate (XferRec d _ _ _ _ _ _) = d +getRecDate (XferRec d _ _ _ _ _) = d getRecDate (ExchRec _ d _ _ _ _ _) = d getRecDate (SplitRec d _ _ _) = d getRecDate (ToDoRec d _ _) = d @@ -271,10 +285,10 @@ cmpRecDate, cmpRecName :: Record -> Record -> Ordering -- by date -cmpRecDate v1 v2 = compare (getRecDate v1) (getRecDate v2) +cmpRecDate = comparing getRecDate -- by name -cmpRecName v1 v2 = compare (getRecName v1) (getRecName v2) +cmpRecName = comparing getRecName -- Ledger monad: essentially a parametrized bi-level version of the Logger -- monad from RWH. The first component of the tuple is "the final result", @@ -328,13 +342,69 @@ -- Some miscellany +-- Round a rational number val to np decimal places +-- This might not be ultimately exact, but it's for converted prices +-- which might be a couple of days out of date anyway, so no big deal + +roundP :: Int -> Rational -> Rational +roundP np val = + if val < 0 then negate (rp (negate val)) else rp val + where rp v1 = + let e1 = 10 ^ max 0 np + e2 = 10*e1 + vs = v1 * fromInteger e2 + n = numerator vs + d = denominator vs + q1 = quot n d + q2 = quot (q1 + 4) 10 + in q2 % e1 + -- 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) +-- Check the validity of a date: see that the day and month are in bounds + 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 && (d <= lim || m == 2 && isLeap y && d <= 29)) + +-- Remove leading and trailing whitespace from a string. + +trimspace :: String -> String +trimspace str = f (f str) + where f = dropWhile isSpace . reverse + +-- A version of 'lines' which deals with all combinations of '\r' and '\n'. +-- It drops blank lines and trims leading and trailing whitespace from +-- lines, which is all 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 trimspace p : (if null s1 then [] else ml (tail s1)) + +-- Re-join continuation lines approximately following haskell convention: a +-- trailing '\' as the last character on a line, followed by a line with a +-- leading '\' as the first character, means that the two '\' are dropped +-- and the two lines joined. In conjunction with the trimspace aspect of +-- mylines, above, this pretty much replicates the haskell way. + +isL, isF :: String -> Bool +isL s = not (null s) && last s == '\\' +isF s = not (null s) && head s == '\\' + +mergelines :: [String] -> [String] +mergelines [] = [] +mergelines (h:[]) + | isL h || isF h = error ("mergelines: partial line " ++ h) + | otherwise = [h] +mergelines (h:t:ts) + | isL h && isF t = mergelines ((init h ++ tail t):ts) + | isL h || isF h = error ("mergelines: partial line " ++ h) + | otherwise = h : mergelines (t:ts) 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.30 2009/12/03 15:17:14 uwe Exp $ -} +$Id: UMMEval.hs,v 1.33 2009/12/15 06:05:44 uwe Exp $ -} module UMMEval (validateRecs, classifyRecs, validateTransPrices, generateImplicitPrices, getBalances, getPrices) where @@ -95,11 +95,12 @@ asD dc = sortBy cmpRecDate . reverse . map (addDC dc) addDC dc (PriceRec d imp ccsa1 ccsa2) = PriceRec d imp ccsa1 (addDCCA dc ccsa2) - addDC dc (XferRec d f a1 a2 ccsa m c) = - XferRec d f a1 a2 (addDCCA dc ccsa) m c + addDC dc (XferRec d f from tos m c) = + XferRec d f from (map (addDCCAt dc) tos) m c 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 + addDCCAt d (n,a) = (n, addDCCA d a) -- Second validation of transactions: check that all from & to accounts -- are valid, that splits aren't 1/0 or 0/1, etc @@ -117,14 +118,14 @@ amt1 == 0 || amt2 == 0 || notIn c ccs chk (PriceRec _ _ (CCSAmt c1 amt1) (CCSAmt c2 _)) = amt1 == Amount 0 || notIn c1 ccs || notIn c2 ccs - chk (XferRec _ _ af at (CCSAmt n _) _ _) = - (notIn af incs && notIn af accts) || - (notIn at exps && notIn at accts) || - notIn n ccs + chk (XferRec _ _ from tos _ _) = + (notIn from incs && notIn from accts) || any chkTo tos chk (ExchRec _ _ _ a (CCSAmt c1 _) (CCSAmt c2 _) _) = notIn a accts || notIn c1 ccs || notIn c2 ccs chk (ToDoRec _ _ _) = False chk _ = True + chkTo (to, CCSAmt n _) = + (notIn to exps && notIn to accts) || notIn n ccs notIn _ [] = True notIn s (r:rs) = s /= getRecName r && notIn s rs @@ -153,7 +154,7 @@ pr (PriceRec _ _ _ _) = True pr _ = False nC n (Amount a1) (Amount a2) = - CCSAmt n (Amount (if a2 == 0 then a1 else a1/a2)) + CCSAmt n (Amount (if a2 == 0 then a1 else roundP 4 (a1/a2))) getCN :: CCSAmt -> Name getCN (CCSAmt n _) = n @@ -220,10 +221,11 @@ 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) - where doXfer [] _ _ _ = [] +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) + doXfer [] _ _ _ = [] doXfer (a@(an,ab):as) nf nt e | an == nf = (an, subFrom ab e) : doXfer as nf nt e | an == nt = (an, addTo ab e) : doXfer as nf nt e @@ -253,7 +255,7 @@ if getRecDate t > d then return as else case t of - XferRec _ _ _ _ _ _ _ -> xferTrans r f t as >>= appTr d r f ts + XferRec _ _ _ _ _ _ -> xferTrans r f t as >>= appTr d r f ts ExchRec _ _ _ _ _ _ _ -> exchTrans r f t as >>= appTr d r f ts SplitRec _ _ _ _ -> splitTrans r t as >>= appTr d r f ts ToDoRec _ isrec _ -> diff --git a/UMMHelp.hs b/UMMHelp.hs --- a/UMMHelp.hs +++ b/UMMHelp.hs @@ -16,20 +16,20 @@ 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.21 2009/12/05 22:45:21 uwe Exp $ -} +$Id: UMMHelp.hs,v 1.28 2009/12/19 21:39:21 uwe Exp $ -} module UMMHelp (writeHdr, usageMsg) where import Prelude version :: String -version = "0.1.4" +version = "0.1.5" writeHdr :: String writeHdr = - "Uwe's Money Manager -- umm " ++ version ++ - "\nCopyright 2009 Uwe Hollerbach \n" ++ - "Available under GPL V3 or later. Share and enjoy!\n" ++ - "http://www.korgwal.com/umm/\n" + "# Uwe's Money Manager -- umm " ++ version ++ + "\n# Copyright 2009 Uwe Hollerbach \n" ++ + "# Available under GPL V3 or later. Share and enjoy!\n" ++ + "# http://www.korgwal.com/umm/\n" -- TODO: store these unadorned in some separate text files, and use -- a program (Template Haskell?) to turn them into proper source code @@ -131,6 +131,8 @@ " 'split' date name amount1 amount2\n" ++ " 'todo' [rec] date text\n" ++ " 'xfer' [rec] date name1 name2 amount [name] [desc] [id]\n" ++ + " 'xfer' [rec] date name1 {name2 amount [name],\\\n" ++ + " \\ name3 amount [name], ...} [desc] [id]\n" ++ " 'exch' [rec] date name amount1 name1 amount2 [name2] [desc]\n" ++ "\n" ++ "There are also 'buy' and 'sell' records which are just\n" ++ @@ -152,7 +154,13 @@ "the program orders them by type and date, and applies\n" ++ "transactions in order by date.\n" ++ "\n" ++ + "The second form of the 'xfer' record above shows splitting\n" ++ + "of records across multiple physical lines. All whitespace\n" ++ + "between the trailing '\\' on the first line and the leading '\\'\n" ++ + "on the second line, plus the two '\\', is annihilated and the\n" ++ + "remainders are joined.\n" ++ "\n" ++ + "\n" ++ "The meaning of each record type is as follows:\n" ++ "\n" ++ "* 'ccs name [desc] [amount]' describes a currency or commodity or\n" ++ @@ -262,7 +270,10 @@ " not printed, whereas not-reconciled transactions are printed\n" ++ " but not included in the reconciled balance.\n" ++ "\n" ++ + " The second form of the 'xfer' record allows specification of\n" ++ + " multiple transfers as one logical transaction.\n" ++ "\n" ++ + "\n" ++ "* 'exch [rec] date name amount1 name1 amount2 [name2] [desc]'\n" ++ " records and their aliases 'buy and 'sell' are used to trade\n" ++ " some amount of one ccs for another. To some extent, these\n" ++ @@ -359,4 +370,4 @@ "\n" ++ "\n" ++ "* 'id' (in an 'xfer' record) is a sequence of digits: a\n" ++ - " check number or other identifying number." + " check number or other identifying number.\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.36 2009/12/03 15:17:14 uwe Exp $ -} +$Id: UMMParser.hs,v 1.39 2009/12/13 04:48:42 uwe Exp $ -} -- TODO: template := @@ -40,10 +40,6 @@ 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 @@ -135,7 +131,7 @@ parseName :: Parser Name parseName = - do spaces + do many space first <- letter <|> currencySymbol rest <- many (letter <|> currencySymbol <|> digit <|> otherSymbol) return (Name (first:rest)) @@ -177,6 +173,21 @@ parseOptionalAmount = option (Amount 1) (TPCP.try parseAmount) +parseOneTo, parseManyTo :: Parser [(Name, CCSAmt)] + +parseOneTo = + do to <- parseName + amt <- parseAmount + ccs <- parseOptionalName + return [(to, CCSAmt ccs amt)] + +parseManyTo = + do spaces + char '{' + tos <- sepBy1 (parseOneTo >>= (\t -> many space >> return t)) (char ',') + char '}' + return (concat tos) + -- A date: three groups of digits separated by '/' or '-' (but not mixed) -- where the first group of digits is the year, the second the month, and -- the third the day: YYYY/MM/DD or YYYY-MM-DD: no messing around with @@ -247,13 +258,11 @@ do string "xfer" rec <- parseReconcile date <- parseDate - acc1 <- parseName - acc2 <- parseName - amt <- parseAmount - ccs <- parseOptionalName + from <- parseName + to <- TPCP.try parseOneTo <|> parseManyTo memo <- parseOptionalString ident <- option "" (TPCP.try parseXferID) - return (XferRec date rec acc1 acc2 (CCSAmt ccs amt) memo ident) + return (XferRec date rec from to 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