{- Copyright 2009 Uwe Hollerbach This file is part of umm, Uwe's Money Manager. umm is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. umm is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License 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 $ -} module UMMData (Name(..), Date(..), Amount(..), startTime, Command(..), CmdOpt(..), Record(..), genDate, getRecDate, cmpRecDate, getRecName, cmpRecName, Ledger(..), runLedger, getResult, getInfo, getErrs, recordInfo, recordErr, recordNil, showExp, BSE(..), CCSAmt(..), cmpCCSAmtName, eqCCSAmtName, AccountData, 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 -- UMM values: names, dates, amounts, records newtype Name = Name String deriving (Eq, Ord) 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) instance Show Date where show (Date y m d) = show y ++ "-" ++ show2 m ++ "-" ++ show2 d where show2 n = reverse (take 2 (reverse (show n) ++ "00")) instance Ord Date where compare (Date y1 m1 d1) (Date y2 m2 d2) = let dy = compare y1 y2 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 February -> 2 March -> 3 April -> 4 May -> 5 June -> 6 July -> 7 August -> 8 September -> 9 October -> 10 November -> 11 December -> 12 in Date y m2 d startTime :: Date startTime = 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 (p2,r2) = divout d 2 (p5,r5) = divout r2 5 e10 = max p2 p5 vs1 = show (numerator (val * 10^e10)) l1 = max (length vs1) (1 + e10) vs2 = take l1 (reverse vs1 ++ cycle "0") vsf = reverse (take e10 vs2) vsi = reverse (drop e10 vs2) in if r5 == 1 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 = CCSAmt Name Amount instance Show CCSAmt where show (CCSAmt name amount) = joinDrop [show amount, show name] -- Compare two CCSAmts by name 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 | COLAccs | COLGrps | COLIncs | COLExps deriving (Eq) instance Show CmdOpt where show COLAll = "all" show COLCCS = "ccs" show COLAccs = "accounts" show COLGrps = "groups" show COLIncs = "incomes" show COLExps = "expenses" data Command = ListDataCmd CmdOpt | ToDoCmd Date | BalanceCmd Name Date | BasisCmd Name Date | RegisterCmd Name Date Date | ReconcileCmd Name Date | PriceCmd Name Date | ChangeCmd Bool Name Date Date | ExportCmd instance Show Command where show (ListDataCmd opt) = joinDrop ["list", show opt] show (ToDoCmd date) = joinDrop ["todo", show date] show (PriceCmd name date) = joinDrop ["price", show name, show date] show (BalanceCmd name date) = joinDrop ["balance", show name, show date] show (BasisCmd name date) = joinDrop ["basis", show name, show date] show (RegisterCmd name date1 date2) = 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 ""), show name, show date1, show date2] show ExportCmd = "export" -- No, not bovine spongiform encephalitis! Disambiguate buy, sell, and -- exch records: internally, they are all treated as exch, because -- that makes the code simple, but the user can enter "buy" or "sell", -- and it seems only polite to echo that back on output. data BSE = B | S | E deriving (Eq) instance Show BSE where show B = "buy" show S = "sell" show E = "exch" 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 String | ExchRec BSE Date Bool Name CCSAmt CCSAmt String | SplitRec Date Name Amount Amount | CommentRec String | ToDoRec Date Bool String | ErrorRec String instance Show Record where show = showR -- 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 = intercalate " " . filter (/= "") 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) = (if imp then "[" else "") ++ joinDrop ["price", show d, show c1, show c2] ++ (if imp then "]" else "") 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] in joinDrop ([show t, shRec r, show d, show a] ++ hs ++ [optStr memo]) 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 (ToDoRec d r memo) = joinDrop ["todo", shRec r, show d, (if memo == "" then "something! but what?" else memo)] 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 from tos m i) = let l1 = joinDrop [show d, shRec r, i, if m == "" then "transfer" else m] 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)))] 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 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 getRecDate :: Record -> Date getRecDate (AccountRec _ d _) = d getRecDate (PriceRec d _ _ _) = d getRecDate (XferRec d _ _ _ _ _) = d getRecDate (ExchRec _ d _ _ _ _ _) = d getRecDate (SplitRec d _ _ _) = d getRecDate (ToDoRec d _ _) = d getRecDate _ = startTime -- so it works for every Record -- 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 _ = nilName -- so it works for every Record -- Compare two Records cmpRecDate, cmpRecName :: Record -> Record -> Ordering -- by date cmpRecDate = comparing getRecDate -- by name 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", -- whatever that may be, the second component is a list of ordinary bits -- of information, and the third component is a list of extraordinary bits -- of information, aka errors. 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 -- low-performance: it's entirely ok for this application, where we -- toss around a few to a few thousand list entries, but for longer -- lists it might not be suitable. instance Monad (Ledger e i) where return a = Ledger (a, [], []) (>>=) m k = let (a,li1,le1) = runLedger m n = k a (b,li2,le2) = runLedger n in Ledger (b, li1 ++ li2, le1 ++ le2) (>>) a f = a >>= const f -- 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)