{- Copyright 2009-2010 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.50 2010/05/02 00:37:25 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(..), Period(..), CCSAmt(..), cmpCCSAmtName, eqCCSAmtName, AccountData, noName, todoName, joinDrop, roundP, isLeap, validDate, julianDate, gregorianDate, offsetDate, previousDate, nextDate, 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 -- 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", shIf verbose "verbose", 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 Period = PSW | PSM | PND Int | PNW Int | PNM Int | PNY Int deriving (Eq) instance Show Period where show PSW = "semiweekly" -- twice per week: N, N + 3, N + 7, ... show PSM = "semimonthly" -- twice per month: N, N +- 15 days show (PND n) | n == 1 = "daily" | n == 7 = "weekly" | n == 14 = "biweekly" | otherwise = show n ++ " days" show (PNW n) | n == 1 = "weekly" | n == 2 = "biweekly" | otherwise = show n ++ " weeks" show (PNM n) | n == 1 = "monthly" | n == 2 = "bimonthly" | n == 3 = "quarterly" | n == 6 = "semiannually" | n == 12 = "annually" | otherwise = show n ++ " months" show (PNY n) | n == 1 = "annually" | n == 2 = "biannually" | otherwise = show n ++ " years" data Record = CCSRec Name String (Maybe Amount) Name | IncomeRec Name String | ExpenseRec Name String | AccountRec Name Date String (Maybe CCSAmt) | 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 | RecurRec Period Date Date Record 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 = shIf (str /= "") (show str) shRec :: Bool -> String shRec rec = shIf rec "*" joinDrop :: [String] -> String joinDrop = intercalate " " . filter (/= "") showR :: Record -> String 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 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) = 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] 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) = shIf (c /= "") (joinDrop ["#", c]) showR (ToDoRec d r memo) = joinDrop ["todo", shRec r, show d, shDef memo "something! but what?"] showR (ErrorRec str) = joinDrop ["#err", str] showR (RecurRec p dl dr r) = joinDrop ["recurring", show p, "until", show dl, if dr == startTime then "" else "reconciled " ++ show dr, "\\\n \\", show r] 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, shIf sp " ", show a] showExp :: Record -> String showExp (XferRec d r from tos m i) = 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, shDef m "exchange"] 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 (RecurRec _ _ _ r) = getRecDate r 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)) -- This returns an integer which is the Julian day number at noon + eps, ie, -- an instant after it has incremented to a new (Julian) day. Inputs are -- 4-digit (or whatever is appropriate) year, month from 1 to 12, day from -- 1 to 28/31 as appropriate. -- -- Jan 1 2000 = 2451545 julianDate :: Date -> Int julianDate (Date y m d) = let a = quot (14 - m) 12 y1 = y + 4800 - a m1 = m + 12*a - 3 in d + quot (153*m1 + 2) 5 + 365*y1 + quot y1 4 + quot y1 400 - quot y1 100 - 32045 -- This returns astronomical years for dates before 1 AD: the year before -- that is year 0, not 1 BC, etc. For years after 1 AD, this returns -- proleptic Gregorian dates. Taken & hacked up from FORTRAN routine from US -- Naval Observatory website gregorianDate :: Int -> Date gregorianDate j = let l1 = j + 68569 n = quot (4*l1) 146097 l2 = l1 - quot (146097*n + 3) 4 i1 = quot (4000*(l2+1)) 1461001 l3 = l2 + 31 - quot (1461*i1) 4 j1 = quot (80*l3) 2447 d = l3 - quot (2447*j1) 80 l4 = quot j1 11 m = j1 + 2 - 12*l4 y = 100*(n - 49) + i1 + l4 in Date y m d -- This returns the date offset by n days from the given date offsetDate :: Date -> Int -> Date offsetDate d n = gregorianDate (n + julianDate d) -- These return the previous & next date from the given date previousDate, nextDate :: Date -> Date previousDate d = offsetDate d (-1) nextDate d = offsetDate d 1 -- 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) -- 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 (==)