UMM 0.1.4 → 0.1.5
raw patch · 6 files changed
+148/−84 lines, 6 files
Files
- UMM.cabal +1/−1
- UMM.hs +9/−37
- UMMData.hs +85/−15
- UMMEval.hs +15/−13
- UMMHelp.hs +18/−7
- UMMParser.hs +20/−11
UMM.cabal view
@@ -1,5 +1,5 @@ Name: UMM-Version: 0.1.4+Version: 0.1.5 Homepage: http://www.korgwal.com/umm/ Author: Uwe Hollerbach <uh@alumni.caltech.edu> Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>
UMM.hs view
@@ -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 ->
UMMData.hs view
@@ -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)
UMMEval.hs view
@@ -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 _ ->
UMMHelp.hs view
@@ -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 <uh@alumni.caltech.edu>\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 <uh@alumni.caltech.edu>\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"
UMMParser.hs view
@@ -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 := <to be determined> @@ -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