summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--UMM.cabal2
-rw-r--r--UMM.hs23
-rw-r--r--UMMData.hs84
-rw-r--r--UMMEval.hs105
-rw-r--r--UMMHelp.hs48
-rw-r--r--UMMParser.hs53
6 files changed, 255 insertions, 60 deletions
diff --git a/UMM.cabal b/UMM.cabal
index 4b99b95..ef97b6c 100644
--- a/UMM.cabal
+++ b/UMM.cabal
@@ -1,5 +1,5 @@
Name: UMM
-Version: 0.1.6
+Version: 0.2.0
Homepage: http://www.korgwal.com/umm/
Author: Uwe Hollerbach <uh@alumni.caltech.edu>
Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>
diff --git a/UMM.hs b/UMM.hs
index 53e8102..a2ea9e1 100644
--- a/UMM.hs
+++ b/UMM.hs
@@ -16,7 +16,7 @@ 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: UMM.hs,v 1.57 2010/01/17 00:13:47 uwe Exp $ -}
+$Id: UMM.hs,v 1.58 2010/05/02 06:53:12 uwe Exp $ -}
module Main where
import Prelude hiding (putStr,putStrLn,print,readFile,getContents)
@@ -59,8 +59,10 @@ getLines fp =
-- Merge explicit (ps) and implicit (qs) prices: the inputs are sorted
-- by date, newest first, and the output is the same, preferring
-- explicit over implicit prices in case of a date match.
+-- For transactions, the inputs are sorted the other way: oldest first
+
+mergePrices, mergeTrans :: [Record] -> [Record] -> [Record]
-mergePrices :: [Record] -> [Record] -> [Record]
mergePrices [] qs = qs
mergePrices ps [] = ps
mergePrices pa@(p:ps) qa@(q:qs) =
@@ -68,6 +70,13 @@ mergePrices pa@(p:ps) qa@(q:qs) =
then q : mergePrices pa qs
else p : mergePrices ps qa
+mergeTrans [] qs = qs
+mergeTrans ps [] = ps
+mergeTrans pa@(p:ps) qa@(q:qs) =
+ if cmpRecDate p q == LT
+ then p : mergeTrans ps qa
+ else q : mergeTrans pa qs
+
-- Get the base currency for a given CCS, which may be itself
getBaseCurrency :: Name -> Name -> [Record] -> Name
@@ -227,13 +236,15 @@ main :: IO ()
main =
do (file, action) <- processArgs
recs <- getLines file >>= mapM (return . parseURecord) >>= validateRecs
- let (dc, cb, c1, incs, exps, a1, grps, trans, p1) = classifyRecs recs
+ let (dc, cb, c1, incs, exps, a1, grps, tr1, per, pr1) = classifyRecs recs
cd <- validateCCS dc cb c1
let ccs = cb ++ cd
accts <- validateAccts dc ccs a1
- validateTransPrices ccs incs exps accts (trans ++ p1)
- let p2 = generateImplicitPrices dc trans cd
- prices = mergePrices (reverse p1) p2
+ validateTransPrices ccs incs exps accts (tr1 ++ per ++ pr1)
+ let tr2 = expandRecurringTrans per
+ trans = mergeTrans tr1 tr2
+ pr2 = generateImplicitPrices dc trans cd
+ prices = mergePrices (reverse pr1) pr2
pse r = putStrLn (showExp r) >> putStrLn ""
case action of
ChangeCmd verbose name date1 date2 ->
diff --git a/UMMData.hs b/UMMData.hs
index 0498fa5..d4cb4c4 100644
--- a/UMMData.hs
+++ b/UMMData.hs
@@ -16,16 +16,18 @@ 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.49 2010/01/02 22:33:34 uwe Exp $ -}
+$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(..),
- CCSAmt(..), cmpCCSAmtName, eqCCSAmtName, AccountData,
- noName, todoName, joinDrop, roundP, isLeap, validDate,
- trimspace, mylines, mergelines, uniqAdjBy, uniqAdj) where
+ 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
@@ -171,6 +173,28 @@ instance Show BSE where
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
@@ -183,6 +207,7 @@ data Record = CCSRec Name String (Maybe Amount) Name
| CommentRec String
| ToDoRec Date Bool String
| ErrorRec String
+ | RecurRec Period Date Date Record
instance Show Record where
show = showR
@@ -235,6 +260,11 @@ showR (ToDoRec d r memo) =
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
@@ -274,6 +304,7 @@ 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
@@ -377,6 +408,51 @@ validDate (Date y m d) =
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
diff --git a/UMMEval.hs b/UMMEval.hs
index 303ae7d..c3d3438 100644
--- a/UMMEval.hs
+++ b/UMMEval.hs
@@ -16,11 +16,11 @@ 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: UMMEval.hs,v 1.37 2010/01/03 06:02:32 uwe Exp $ -}
+$Id: UMMEval.hs,v 1.40 2010/05/02 06:53:12 uwe Exp $ -}
module UMMEval (validateRecs, validateCCS, validateAccts, classifyRecs,
validateTransPrices, generateImplicitPrices, getBalances,
- getPrices) where
+ getPrices, expandRecurringTrans) where
import Prelude hiding (putStr,putStrLn,print)
import Data.List
import Data.Maybe
@@ -109,22 +109,24 @@ validateAccts dc ccs accts =
-- separately (or just account groups, right now)
classifyRecs :: [Record] -> (Name, [Record], [Record], [Record], [Record],
- [Record], [Record], [Record], [Record])
-classifyRecs recs = cw recs [] [] [] [] [] [] []
- where cw [] c i e a g t p =
+ [Record], [Record], [Record], [Record], [Record])
+classifyRecs rs = cw rs [] [] [] [] [] [] [] []
+ where cw [] c i e a g t p r =
let dc = if null c then Name "zorkmid" else getRecName (last c)
(cb, cd) = partition isB (vsN c)
- in (dc, cb, cd, vsN i, vsN e, reverse a, vsN g, asD dc t, asD dc p)
- 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
- 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
- GroupRec _ _ -> cw rs c i e a (r:g) t p
- PriceRec _ _ _ _ -> cw rs c i e a g t (r:p)
- _ -> cw rs c i e a g (r:t) p
+ in (dc, cb, cd, vsN i, vsN e, reverse a, vsN g,
+ asD dc t, asD dc r, asD dc p)
+ cw (rec:recs) c i e a g t p r =
+ case rec of
+ CommentRec _ -> cw recs c i e a g t p r
+ CCSRec _ _ _ _ -> cw recs (rec:c) i e a g t p r
+ IncomeRec _ _ -> cw recs c (rec:i) e a g t p r
+ ExpenseRec _ _ -> cw recs c i (rec:e) a g t p r
+ AccountRec _ _ _ _ -> cw recs c i e (rec:a) g t p r
+ GroupRec _ _ -> cw recs c i e a (rec:g) t p r
+ PriceRec _ _ _ _ -> cw recs c i e a g t (rec:p) r
+ RecurRec _ _ _ _ -> cw recs c i e a g t p (rec:r)
+ _ -> cw recs c i e a g (rec:t) p r
vsN = uChk . sortBy cmpRecName
uChk vs = if uniqAdjBy (\v1 v2 -> cmpRecName v1 v2 == EQ) vs
then vs
@@ -137,6 +139,7 @@ classifyRecs recs = cw recs [] [] [] [] [] [] []
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 dc (RecurRec p dl dr r) = RecurRec p dl dr (addDC dc r)
addDC _ r = r
addDCCAt d (n,a) = (n, addDCCA d a)
isB (CCSRec _ _ ma nb) = isNothing ma && nb == noName
@@ -163,6 +166,7 @@ validateTransPrices ccs incs exps accts tps =
chk (ExchRec _ _ _ a (CCSAmt c1 _) (CCSAmt c2 _) _) =
notIn a accts || notIn c1 ccs || notIn c2 ccs
chk (ToDoRec _ _ _) = False
+ chk (RecurRec _ _ _ r) = chk r
chk _ = True
chkTo (to, CCSAmt n _) =
(notIn to exps && notIn to accts) || notIn n ccs
@@ -224,34 +228,33 @@ scaleBy qs d = map (s1 (getCN d) (getCA d)) qs
qq = getCA q
in if qn == dn then CCSAmt qn (Amount (qq * dq)) else q
-maybeRecord :: Bool -> Maybe Name -> Record -> AccountData -> (Name -> Bool) ->
+maybeRecord :: Maybe Name -> Record -> AccountData -> (Name -> Bool) ->
Ledger e (Record, [CCSAmt]) ()
-maybeRecord rt reg record newaccs tst =
+maybeRecord reg record newaccs tst =
let isJ = isJust reg
rn = fromJust reg
acc = filter (\a -> fst a == rn) newaccs
nb = if null acc
then [CCSAmt noName (Amount 0)]
else snd (head acc)
- in if rt && isJ && (tst rn || rn == noName)
+ in if isJ && (tst rn || rn == noName)
then recordInfo (record, nb)
else recordNil
-maybeDo :: Bool -> Maybe Name -> Bool -> Record -> Bool ->
+maybeDo :: Maybe Name -> Bool -> Record -> Bool ->
AccountData -> AccountData -> (Name -> Bool) ->
Ledger e (Record, [CCSAmt]) AccountData
-maybeDo rt reg dorec record isrec accs newaccs tst =
+maybeDo reg dorec record isrec accs newaccs tst =
if dorec
then if isrec
then return newaccs
- else maybeRecord rt reg record newaccs tst >> return accs
- else maybeRecord rt reg record newaccs tst >> return newaccs
+ 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 True reg dorec record isrec accs
- (doExch accs acc amtn amto) (== acc)
+ maybeDo reg dorec record isrec accs (doExch accs acc amtn amto) (== acc)
where doExch [] _ _ _ = []
doExch ((an,ab):as) n en eo =
if an == n
@@ -259,18 +262,13 @@ exchTrans reg dorec record@(ExchRec _ _ isrec acc amtn amto _) accs =
else (an,ab) : doExch as n en eo
exchTrans _ _ r _ = intErr "exchTrans" r
--- TODO: alternately, we could have '(xfer1 (not dorec))' in the
--- foldM, that would cause register displays to be shown once for each
--- sub-transaction, but reconciliation displays would show the entire
--- transaction only once
-
xferTrans :: Maybe Name -> Bool -> Record -> AccountData ->
Ledger e (Record, [CCSAmt]) AccountData
xferTrans reg dorec record@(XferRec _ isrec from tos _ _) accs =
foldM (xfer1 False) accs (init tos) >>= (\a -> xfer1 True a (last tos))
- where xfer1 rf as (to,amt) = maybeDo rf reg dorec record isrec as
- (doXfer as from to amt)
- (\rn -> rn == from || rn == to)
+ where xfer1 rf as (to,amt) =
+ maybeDo reg dorec record isrec as (doXfer as from to amt)
+ (\rn -> (rf && rn == from) || rn == to)
doXfer [] _ _ _ = []
doXfer (a@(an,ab):as) nf nt e
| an == nf = (an, subFrom ab e) : doXfer as nf nt e
@@ -287,7 +285,7 @@ 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 True reg record newaccs (const True) >> return newaccs
+ in maybeRecord reg record newaccs (const True) >> return newaccs
where doST (a1,a2) = (a1, scaleBy a2 (CCSAmt ccs (Amount (an/ao))))
splitTrans _ r _ = intErr "splitTrans" r
@@ -295,7 +293,7 @@ splitTrans _ r _ = intErr "splitTrans" r
-- new version with printing of initial values
mkInit reg as =
let iaccs = (map (\a -> (getRecName a, maybeToList (gI a))) as)
- in maybeRecord True reg (CommentRec "") iaccs (const True) >> return iaccs
+ in maybeRecord reg (CommentRec "") iaccs (const True) >> return iaccs
where gI (AccountRec _ _ _ mi) = mi
gI r = intErr "mkInit" r
-}
@@ -357,3 +355,40 @@ getPrices nm dc date prices =
else get ps
get _ = recordNil
doShow t p = putStrLn t >> mapM_ print (reverse p)
+
+-- Convert a list of RecurRec records into equivalent list
+-- of individual transactions, sorted by date
+
+expandRecurringTrans :: [Record] -> [Record]
+expandRecurringTrans rs = sortBy cmpRecDate (concatMap eRT rs)
+ where eRT (RecurRec (PND n) dl dr rec) =
+ map (mRD rec dr) (genD (getRecDate rec) n dl)
+ eRT (RecurRec (PNW n) dl dr rec) =
+ map (mRD rec dr) (genD (getRecDate rec) (7*n) dl)
+ eRT (RecurRec PSW dl dr rec) =
+ let da = getRecDate rec
+ db = offsetDate da 3
+ mf = map (mRD rec dr)
+ in mf (genD da 7 dl) ++ mf (genD db 7 dl)
+ eRT (RecurRec (PNM n) dl dr rec) =
+ map (mRD rec dr) (genM (getRecDate rec) n dl)
+ eRT (RecurRec (PNY n) dl dr rec) =
+ map (mRD rec dr) (genM (getRecDate rec) (12*n) dl)
+ eRT (RecurRec PSM dl dr rec) =
+ let da = getRecDate rec
+ db = offsetDate da 15
+ mf = map (mRD rec dr)
+ in mf (genM da 1 dl) ++ mf (genM db 1 dl)
+ eRT rec = intErr "expandRecurringTrans" rec
+ genD d1 dd d2 =
+ let j = julianDate d1
+ in map gregorianDate [j, j + dd .. julianDate d2]
+ genM d1 dm d2 = if d1 <= d2 then d1 : genM (oMo d1 dm) dm d2 else []
+ oMo (Date y m d) mstep =
+ let (dy,m1) = divMod (mstep + m - 1) 12
+ in Date (y + dy) (m1 + 1) d
+ mRD (XferRec _ _ f t m i) dr dc =
+ XferRec dc (dc <= dr) f t m i
+ mRD (ExchRec t _ _ a c1 c2 m) dr dc =
+ ExchRec t dc (dc <= dr) a c1 c2 m
+ mRD r _ _ = intErr "expandRecurringTrans" r
diff --git a/UMMHelp.hs b/UMMHelp.hs
index bff3aa9..c1cfd52 100644
--- a/UMMHelp.hs
+++ b/UMMHelp.hs
@@ -16,13 +16,13 @@ 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: UMMHelp.hs,v 1.34 2010/01/19 04:02:20 uwe Exp $ -}
+$Id: UMMHelp.hs,v 1.37 2010/05/02 21:32:50 uwe Exp $ -}
module UMMHelp (writeHdr, usageMsg) where
import Prelude
version :: String
-version = "0.1.6"
+version = "0.2.0"
writeHdr :: String
writeHdr =
@@ -130,10 +130,10 @@ usageMsg prog =
" 'price' date [amount1] name1 amount2 [name2]\n" ++
" '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" ++
+ " [period] 'xfer' [rec] date name1 name2 amount [name] [desc] [id]\n" ++
+ " [period] 'xfer' [rec] date name1 {name2 amount [name],\\\n" ++
" \\ name3 amount [name], ...} [desc] [id]\n" ++
- " 'exch' [rec] date name amount1 name1 amount2 [name2] [desc]\n" ++
+ " [period] 'exch' [rec] date name amount1 name1 amount2 [name2] [desc]\n" ++
"\n" ++
"There are also 'buy' and 'sell' records which are just\n" ++
"syntactic sugar for 'exch'; see more details below in the\n" ++
@@ -247,7 +247,7 @@ usageMsg prog =
" split 2000-5-8 GE 15/7 5/7\n" ++
"\n" ++
"\n" ++
- "* 'xfer [rec] date name1 name2 amount [name] [desc] [id]'\n" ++
+ "* '[period] xfer [rec] date name1 name2 amount [name] [desc] [id]'\n" ++
" records are used to transfer 'amount' of 'name' from account\n" ++
" 'name1' to account 'name2'; 'name1' may be either an account\n" ++
" specified by an 'account' record, or a source specified by\n" ++
@@ -275,9 +275,11 @@ usageMsg prog =
" The second form of the 'xfer' record allows specification of\n" ++
" multiple transfers as one logical transaction.\n" ++
"\n" ++
+ " For details on the optional [period] prefix, see below.\n" ++
"\n" ++
- "* 'exch [rec] date name amount1 name1 amount2 [name2] [desc]'\n" ++
- " records and their aliases 'buy and 'sell' are used to trade\n" ++
+ "\n" ++
+ "* '[period] 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" ++
" are syntactic sugar: the same could be accomplished with a\n" ++
" pair of 'xfer' records, but this is a little clearer and\n" ++
@@ -310,6 +312,8 @@ usageMsg prog =
" exch 2009/10/2 brokerage 3.959 VTSMX 100 US$\n" ++
" exch 2009/10/2 brokerage 100 US$ 3.959 VTSMX\n" ++
"\n" ++
+ " Again, for details on the optional [period] prefix, see below.\n" ++
+ "\n" ++
"\n" ++
"* 'todo [rec] date text' is basically a sticky note in the\n" ++
" ledger. If the record is not marked as reconciled, and the\n" ++
@@ -372,4 +376,30 @@ usageMsg prog =
"\n" ++
"\n" ++
"* 'id' (in an 'xfer' record) is a sequence of digits: a\n" ++
- " check number or other identifying number.\n"
+ " check number or other identifying number.\n" ++
+ "\n" ++
+ "\n" ++
+ "* 'period' is an optional prefix of 'xfer' and 'exch' records:\n" ++
+ " it specifies that this is a periodic transaction. It has the\n" ++
+ " format\n" ++
+ "\n" ++
+ " recurring interval until end-date [reconciled rec-date]\n" ++
+ "\n" ++
+ " where 'recurring', 'until', and 'reconciled' are literal keywords,\n" ++
+ " end-date and rec-date are dates in the usual format described above,\n" ++
+ " and interval specifies how far apart the repetitions are: interval\n" ++
+ " may be any one of the literal keywords 'daily', 'weekly', 'monthly',\n" ++
+ " 'quarterly', 'annually', 'biweekly', 'bimonthly', 'biannually',\n" ++
+ " 'semiweekly', 'semimonthly', or 'semiannually', or an integer\n" ++
+ " followed by one of the literal keywords 'days', 'weeks', 'months',\n" ++
+ " or 'years'. For example\n" ++
+ "\n" ++
+ " recurring monthly until 2010-12-31 \\\n" ++
+ " \\ xfer 2009-2-27 interest abc:savings 0.01\n" ++
+ "\n" ++
+ " is a monthly interest payment into abc:savings, occurring on\n" ++
+ " the 27th of each month from February 2009 until December 2010.\n" ++
+ "\n" ++
+ " The reconciled keyword and rec-date are themselves optional.\n" ++
+ " If present, they indicate that instances of this record before\n" ++
+ " the rec-date are reconciled.\n"
diff --git a/UMMParser.hs b/UMMParser.hs
index a51a965..ad9af43 100644
--- a/UMMParser.hs
+++ b/UMMParser.hs
@@ -16,7 +16,7 @@ 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: UMMParser.hs,v 1.42 2010/01/02 22:33:34 uwe Exp $ -}
+$Id: UMMParser.hs,v 1.43 2010/05/02 00:37:26 uwe Exp $ -}
-- TODO: template := <to be determined>
@@ -28,6 +28,9 @@ import Text.ParserCombinators.Parsec as TPCP hiding (spaces)
import UMMData
+intErr :: String -> o
+intErr loc = error ("internal error at " ++ loc ++ ", please report this")
+
readInt :: String -> Integer
readInt s = foldl ma 0 s
where ma v1 v2 = 10*v1 + toInteger (digitToInt v2)
@@ -212,13 +215,39 @@ parseReconcile :: Parser Bool
parseReconcile =
option False (TPCP.try (many space >> oneOf "*!" >> return True))
-intErr :: String -> o
-intErr loc = error ("internal error at " ++ loc ++ ", please report this")
+parsePeriod :: Parser Period
+parsePeriod =
+ spaces >> (pPG <|>
+ pPS "daily" (PND 1) <|>
+ pPS "weekly" (PNW 1) <|>
+ pPS "monthly" (PNM 1) <|>
+ pPS "quarterly" (PNM 3) <|>
+ pPS "annually" (PNY 1) <|>
+ TPCP.try (pPS "biweekly" (PNW 2)) <|>
+ TPCP.try (pPS "bimonthly" (PNM 2)) <|>
+ pPS "biannually" (PNY 2) <|>
+ TPCP.try (pPS "semiweekly" PSW) <|>
+ TPCP.try (pPS "semimonthly" PSM) <|>
+ pPS "semiannually" (PNM 6))
+ where pPS s p = string s >> return p
+ pPG = do n <- parseInt
+ spaces
+ p <- parsePrefixOf 1 "days" <|>
+ parsePrefixOf 1 "weeks" <|>
+ parsePrefixOf 1 "months" <|>
+ parsePrefixOf 1 "years"
+ let ni = fromInteger n
+ return (case p of
+ "days" -> PND ni
+ "weeks" -> PNW ni
+ "months" -> PNM ni
+ "years" -> PNY ni
+ _ -> intErr "parsePeriod")
-- The top-level record parsers
-parseCCS, parseIE, parseAccount, parseGroup, parsePrice, parseXfer,
- parseEBS, parseSplit, parseTodo, parseComment, parseBlank, parseRecord ::
+parseCCS, parseIE, parseAccount, parseGroup, parsePrice, parseXfer, parseEBS,
+ parseSplit, parseTodo, parseRecur, parseComment, parseBlank, parseRecord ::
Parser Record
parseCCS =
@@ -314,6 +343,19 @@ parseComment =
comment <- many anyChar
return (CommentRec (trimspace comment))
+parseRecur =
+ do string "recurring"
+ period <- parsePeriod
+ spaces -- TODO: keep this syntactic sugar?
+ string "until" -- it kinda reads better...?
+ dl <- parseDate
+ spaces
+ dr <- option startTime
+ (TPCP.try (parsePrefixOf 3 "reconciled" >> parseDate))
+ many space
+ record <- parseEBS <|> parseXfer
+ return (RecurRec period dl dr record)
+
parseBlank = many space >> return (CommentRec "")
parseRecord =
@@ -327,6 +369,7 @@ parseRecord =
<|> parseTodo
<|> parseAccount
<|> parseGroup
+ <|> parseRecur
<|> parseComment
<|> parseBlank -- this must be last, as it can match nothing
many space