slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

parse posting dates, better comment/tag handling, begin using HTF for unit testing

Browse Source
This commit is contained in:
Simon Michael 2012-12-06 00:28:23 +00:00
parent d0bd0663b6
commit e75abc4625
11 changed files with 338 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
MANUAL.md
View File

@ -408,6 +408,16 @@ Filtering reports by tag is work in progress. For the moment, you can
match transactions' or postings' tag values by adding `tag match transactions' or postings' tag values by adding `tag
NAME=EXACTVALUE` on the command line. NAME=EXACTVALUE` on the command line.
### Posting dates
You can give individual postings a different date (or dates) from their parent transaction,
by adding posting tags `date:ACTUALDATE` and/or `date2:EFFECTIVEDATE`.
For compatibility, ledger's posting date syntax is also supported
(`[ACTUALDATE]`, `[=EFFECTIVEDATE]` or `[ACTUALDATE=EFFECTIVEDATE]` in a
posting comment), and treated as an alterate spelling of the date and
date2 tags.
### Including other files ### Including other files
You can pull in the content of additional journal files, by writing lines like this: You can pull in the content of additional journal files, by writing lines like this:
@ -1312,7 +1322,7 @@ entries, and the following c++ ledger options and commands:
and "not:" prefixes, unlike ledger 3's free-form parser and "not:" prefixes, unlike ledger 3's free-form parser
- hledger doesn't require a space before command-line option - hledger doesn't require a space before command-line option
values, eg either `-f-` or `-f -` is fine values, eg `-fFILE` or `-f FILE` works
- hledger's weekly reporting intervals always start on mondays - hledger's weekly reporting intervals always start on mondays

1
hledger-lib/Hledger/Data/Dates.hs
View File

@ -28,6 +28,7 @@ module Hledger.Data.Dates (
getCurrentYear, getCurrentYear,
nulldate, nulldate,
spanContainsDate, spanContainsDate,
parsedateM,
parsedate, parsedate,
showDate, showDate,
elapsedSeconds, elapsedSeconds,

12
hledger-lib/Hledger/Data/Posting.hs
View File

@ -64,7 +64,8 @@ instance Show Posting where show = showPosting
nullposting, posting :: Posting nullposting, posting :: Posting
nullposting = Posting nullposting = Posting
{pstatus=False {pdate=Nothing
,pstatus=False
,paccount="" ,paccount=""
,pamount=nullmixedamt ,pamount=nullmixedamt
,pcomment="" ,pcomment=""
@ -98,7 +99,7 @@ tagsAsLines :: [(String, String)] -> [String]
tagsAsLines mds = map (\(k,v) -> " ; " ++ k++": "++v) mds tagsAsLines mds = map (\(k,v) -> " ; " ++ k++": "++v) mds
showComment :: String -> String showComment :: String -> String
showComment s = if null s then "" else " ; " ++ s showComment s = if null s then "" else " ;" ++ s
-- XXX refactor -- XXX refactor
showPostingForRegister :: Posting -> String showPostingForRegister :: Posting -> String
@ -132,8 +133,13 @@ accountNamesFromPostings = nub . map paccount
sumPostings :: [Posting] -> MixedAmount sumPostings :: [Posting] -> MixedAmount
sumPostings = sum . map pamount sumPostings = sum . map pamount
-- | Get a posting's (primary) date - it's own date if specified,
-- otherwise the parent transaction's primary date (otherwise the null
-- date).
postingDate :: Posting -> Day postingDate :: Posting -> Day
postingDate p = maybe nulldate tdate $ ptransaction p postingDate p = fromMaybe txndate $ pdate p
where
txndate = maybe nulldate tdate $ ptransaction p
-- |Is this posting cleared? If this posting was individually marked -- |Is this posting cleared? If this posting was individually marked
-- as cleared, returns True. Otherwise, return the parent -- as cleared, returns True. Otherwise, return the parent

53
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -115,14 +115,13 @@ tests_showTransactionUnelided = [
] ]
} }
`gives` unlines [ `gives` unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1", "2012/05/14=2012/05/15 (code) desc",
" ; tcomment2", " ;tcomment1",
" ; ttag1: val1", " ;tcomment2",
" $1.00", " $1.00",
" * a 2.0h ; pcomment1", " * a 2.0h",
" ; pcomment2", " ;pcomment1",
" ; ptag1: val1", " ;pcomment2",
" ; ptag2: val2",
"" ""
] ]
] ]
@ -131,26 +130,30 @@ tests_showTransactionUnelided = [
showTransaction' :: Bool -> Transaction -> String showTransaction' :: Bool -> Transaction -> String
showTransaction' elide t = showTransaction' elide t =
unlines $ [descriptionline] unlines $ [descriptionline]
++ commentlines ++ multilinecomment
++ (tagsAsLines $ ttags t) -- ++ (tagsAsLines $ ttags t)
++ (postingsAsLines elide t (tpostings t)) ++ (postingsAsLines elide t (tpostings t))
++ [""] ++ [""]
where where
descriptionline = rstrip $ concat [date, status, code, desc, firstcomment] descriptionline = rstrip $ concat [date, status, code, desc, inlinecomment]
date = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) date = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)
showdate = printf "%-10s" . showDate showdate = printf "%-10s" . showDate
showedate = printf "=%s" . showdate showedate = printf "=%s" . showdate
status = if tstatus t then " *" else "" status = if tstatus t then " *" else ""
code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""
desc = if null d then "" else " " ++ d where d = tdescription t desc = if null d then "" else " " ++ d where d = tdescription t
(firstcomment, commentlines) = commentLines $ tcomment t (inlinecomment, multilinecomment) = commentLines $ tcomment t
-- Render a transaction or posting's comment as indented & prefixed comment lines. -- Render a transaction or posting's comment as indented, semicolon-prefixed comment lines -
-- an inline comment (when it's a single line) or multiple lines.
commentLines :: String -> (String, [String]) commentLines :: String -> (String, [String])
commentLines s commentLines s
| null s = ("", []) | null s = ("", [])
| otherwise = (" ; " ++ first, map (indent . ("; "++)) rest) | length ls == 1 = (prefix $ head ls, [])
where (first:rest) = lines s | otherwise = ("", (prefix $ head ls):(map prefix $ tail ls))
where
ls = lines s
prefix = indent . (";"++)
postingsAsLines :: Bool -> Transaction -> [Posting] -> [String] postingsAsLines :: Bool -> Transaction -> [Posting] -> [String]
postingsAsLines elide t ps postingsAsLines elide t ps
@ -161,12 +164,12 @@ postingsAsLines elide t ps
postingAsLines :: Bool -> [Posting] -> Posting -> [String] postingAsLines :: Bool -> [Posting] -> Posting -> [String]
postingAsLines elideamount ps p = postingAsLines elideamount ps p =
postinglines postinglines
++ commentlines ++ multilinecomment
++ tagsAsLines (ptags p) -- ++ tagsAsLines (ptags p)
where where
postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, firstcomment] postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, inlinecomment]
amount = if elideamount then "" else showamt (pamount p) amount = if elideamount then "" else showamt (pamount p)
(firstcomment, commentlines) = commentLines $ pcomment p (inlinecomment, multilinecomment) = commentLines $ pcomment p
showacct p = showacct p =
indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))
where where
@ -178,21 +181,21 @@ postingAsLines elideamount ps p =
tests_postingAsLines = [ tests_postingAsLines = [
"postingAsLines" ~: do "postingAsLines" ~: do
let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p) let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p)
nullposting `gives` [" 0"] posting `gives` [" 0"]
nullposting{ posting{
pstatus=True, pstatus=True,
paccount="a", paccount="a",
pamount=Mixed [usd 1, hrs 2], pamount=Mixed [usd 1, hrs 2],
pcomment="pcomment1\npcomment2\n", pcomment="pcomment1\npcomment2\n tag3: val3 \n",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")] ptags=[("ptag1","val1"),("ptag2","val2")]
} }
`gives` [ `gives` [
" $1.00", " $1.00",
" * a 2.0h ; pcomment1", " * a 2.0h",
" ; pcomment2", " ;pcomment1",
" ; ptag1: val1", " ;pcomment2",
" ; ptag2: val2" " ; tag3: val3 "
] ]
] ]

5
hledger-lib/Hledger/Data/Types.hs
View File

@ -76,6 +76,7 @@ data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
type Tag = (String, String) type Tag = (String, String)
data Posting = Posting { data Posting = Posting {
pdate :: Maybe Day, -- ^ this posting's clearing date, if different from the transaction's
pstatus :: Bool, pstatus :: Bool,
paccount :: AccountName, paccount :: AccountName,
pamount :: MixedAmount, pamount :: MixedAmount,
@ -89,7 +90,7 @@ data Posting = Posting {
-- The equality test for postings ignores the parent transaction's -- The equality test for postings ignores the parent transaction's
-- identity, to avoid infinite loops. -- identity, to avoid infinite loops.
instance Eq Posting where instance Eq Posting where
(==) (Posting a1 b1 c1 d1 e1 f1 _) (Posting a2 b2 c2 d2 e2 f2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 (==) (Posting a1 b1 c1 d1 e1 f1 g1 _) (Posting a2 b2 c2 d2 e2 f2 g2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2
data Transaction = Transaction { data Transaction = Transaction {
tdate :: Day, tdate :: Day,
@ -247,6 +248,8 @@ data Account = Account {
aboring :: Bool -- ^ used in the accounts report to label elidable parents aboring :: Bool -- ^ used in the accounts report to label elidable parents
} }
-- | A Ledger has the journal it derives from, and the accounts -- | A Ledger has the journal it derives from, and the accounts
-- derived from that. Accounts are accessible both list-wise and -- derived from that. Accounts are accessible both list-wise and
-- tree-wise, since each one knows its parent and subs; the first -- tree-wise, since each one knows its parent and subs; the first

2
hledger-lib/Hledger/Read.hs
View File

@ -216,7 +216,7 @@ samplejournal = readJournal' $ unlines
tests_Hledger_Read = TestList $ tests_Hledger_Read = TestList $
tests_readJournal' tests_readJournal'
++ [ ++ [
tests_Hledger_Read_JournalReader, -- tests_Hledger_Read_JournalReader,
tests_Hledger_Read_TimelogReader, tests_Hledger_Read_TimelogReader,
tests_Hledger_Read_CsvReader, tests_Hledger_Read_CsvReader,

393
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards, NoMonoLocalBinds #-} -- {-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-}
{-| {-|
A reader for hledger's journal file format A reader for hledger's journal file format
@ -30,23 +31,29 @@ module Hledger.Read.JournalReader (
amountp, amountp,
amountp', amountp',
mamountp', mamountp',
emptyline, emptyline
#ifdef TESTS
-- * Tests -- * Tests
tests_Hledger_Read_JournalReader -- disabled by default, HTF not available on windows
,htf_thisModulesTests
,htf_Hledger_Read_JournalReader_importedTests
#endif
) )
where where
import qualified Control.Exception as C import qualified Control.Exception as C
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Error
import Data.Char (isNumber) import Data.Char (isNumber)
import Data.Either (partitionEithers)
import Data.List import Data.List
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe import Data.Maybe
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe (headDef) import Safe (headDef, lastDef)
import Test.HUnit #ifdef TESTS
import Test.Framework
import Text.Parsec.Error
#endif
import Text.ParserCombinators.Parsec hiding (parse) import Text.ParserCombinators.Parsec hiding (parse)
import Text.Printf import Text.Printf
import System.FilePath import System.FilePath
@ -311,41 +318,35 @@ periodictransaction = do
-- | Parse a (possibly unbalanced) transaction. -- | Parse a (possibly unbalanced) transaction.
transaction :: GenParser Char JournalContext Transaction transaction :: GenParser Char JournalContext Transaction
transaction = do transaction = do
-- ptrace "transaction"
date <- date <?> "transaction" date <- date <?> "transaction"
edate <- optionMaybe (effectivedate date) <?> "effective date" edate <- optionMaybe (effectivedate date) <?> "effective date"
status <- status <?> "cleared flag" status <- status <?> "cleared flag"
code <- code <?> "transaction code" code <- code <?> "transaction code"
-- now there can be whitespace followed by a description and/or comment/tag comment description <- descriptionp >>= return . strip
let pdescription = many (noneOf ";\n") >>= return . strip comment <- try followingcomment <|> (newline >> return "")
(description, inlinecomment, inlinetag) <- let tags = tagsInComment comment
try (do many1 spacenonewline
d <- pdescription
(c, m) <- inlinecomment
return (d,c,m))
<|> (newline >> return ("", [], []))
(nextlinecomments, nextlinetags) <- commentlines
let comment = unlines $ inlinecomment ++ nextlinecomments
tags = inlinetag ++ nextlinetags
postings <- postings postings <- postings
return $ txnTieKnot $ Transaction date edate status code description comment tags postings "" return $ txnTieKnot $ Transaction date edate status code description comment tags postings ""
tests_transaction = [ descriptionp = many (noneOf ";\n")
"transaction" ~: do
-- let s `gives` t = assertParseEqual (parseWithCtx nullctx transaction s) t #ifdef TESTS
test_transaction = do
let s `gives` t = do let s `gives` t = do
let p = parseWithCtx nullctx transaction s let p = parseWithCtx nullctx transaction s
assertBool "transaction parser failed" $ isRight p assertBool $ isRight p
let Right t2 = p let Right t2 = p
same f = assertEqual "" (f t) (f t2) -- same f = assertEqual (f t) (f t2)
same tdate assertEqual (tdate t) (tdate t2)
same teffectivedate assertEqual (teffectivedate t) (teffectivedate t2)
same tstatus assertEqual (tstatus t) (tstatus t2)
same tcode assertEqual (tcode t) (tcode t2)
same tdescription assertEqual (tdescription t) (tdescription t2)
same tcomment assertEqual (tcomment t) (tcomment t2)
same ttags assertEqual (ttags t) (ttags t2)
same tpreceding_comment_lines assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2)
same tpostings assertEqual (show $ tpostings t) (show $ tpostings t2)
-- "0000/01/01\n\n" `gives` nulltransaction -- "0000/01/01\n\n" `gives` nulltransaction
unlines [ unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1", "2012/05/14=2012/05/15 (code) desc ; tcomment1",
@ -363,14 +364,14 @@ tests_transaction = [
tstatus=False, tstatus=False,
tcode="code", tcode="code",
tdescription="desc", tdescription="desc",
tcomment="tcomment1\ntcomment2\n", tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",
ttags=[("ttag1","val1")], ttags=[("ttag1","val1")],
tpostings=[ tpostings=[
nullposting{ nullposting{
pstatus=True, pstatus=True,
paccount="a", paccount="a",
pamount=Mixed [usd 1], pamount=Mixed [usd 1],
pcomment="pcomment1\npcomment2\n", pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")], ptags=[("ptag1","val1"),("ptag2","val2")],
ptransaction=Nothing ptransaction=Nothing
@ -379,22 +380,42 @@ tests_transaction = [
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
assertParseEqual (parseWithCtx nullctx transaction entry1_str) entry1 assertRight $ parseWithCtx nullctx transaction $ unlines
assertBool "transaction should not parse just a date" ["2007/01/28 coopportunity"
$ isLeft $ parseWithCtx nullctx transaction "2009/1/1\n" ," expenses:food:groceries $47.18"
assertBool "transaction should require some postings" ," assets:checking $-47.18"
$ isLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n" ,""
let t = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n" ]
assertBool "transaction should not include a comment in the description"
$ either (const False) ((== "a") . tdescription) t -- transaction should not parse just a date
assertBool "parse transaction with following whitespace line" $ assertLeft $ parseWithCtx nullctx transaction "2009/1/1\n"
isRight $ parseWithCtx nullctx transaction $ unlines [
"2012/1/1" -- transaction should not parse just a date and description
assertLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n"
-- transaction should not parse a following comment as part of the description
let p = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n"
assertRight p
assertEqual "a" (let Right p' = p in tdescription p')
-- parse transaction with following whitespace line
assertRight $ parseWithCtx nullctx transaction $ unlines
["2012/1/1"
," a 1" ," a 1"
," b" ," b"
," " ," "
] ]
]
let p = parseWithCtx nullctx transaction $ unlines
["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment"
," ; posting 1 comment 2"
," b"
," ; posting 2 comment"
]
assertRight p
assertEqual 2 (let Right t = p in length $ tpostings t)
#endif
-- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year
-- may be omitted if a default year has already been set. -- may be omitted if a default year has already been set.
@ -470,7 +491,7 @@ code = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `man
-- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments.
postings :: GenParser Char JournalContext [Posting] postings :: GenParser Char JournalContext [Posting]
postings = many1 (try posting) <?> "postings" postings = many1 (try postingp) <?> "postings"
-- linebeginningwithspaces :: GenParser Char JournalContext String -- linebeginningwithspaces :: GenParser Char JournalContext String
-- linebeginningwithspaces = do -- linebeginningwithspaces = do
@ -479,8 +500,8 @@ postings = many1 (try posting) <?> "postings"
-- cs <- restofline -- cs <- restofline
-- return $ sp ++ (c:cs) ++ "\n" -- return $ sp ++ (c:cs) ++ "\n"
posting :: GenParser Char JournalContext Posting postingp :: GenParser Char JournalContext Posting
posting = do postingp = do
many1 spacenonewline many1 spacenonewline
status <- status status <- status
many spacenonewline many spacenonewline
@ -490,20 +511,20 @@ posting = do
_ <- balanceassertion _ <- balanceassertion
_ <- fixedlotprice _ <- fixedlotprice
many spacenonewline many spacenonewline
(inlinecomment, inlinetag) <- inlinecomment comment <- try followingcomment <|> (newline >> return "")
(nextlinecomments, nextlinetags) <- commentlines let tags = tagsInComment comment
let comment = unlines $ inlinecomment ++ nextlinecomments date = dateFromTags tags
tags = inlinetag ++ nextlinetags return posting{pdate=date, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags}
return (Posting status account' amount comment ptype tags Nothing)
tests_posting = [ #ifdef TESTS
"posting" ~: do test_postingp = do
-- let s `gives` r = assertParseEqual (parseWithCtx nullctx posting s) r let s `gives` ep = do
let s `gives` p = do let parse = parseWithCtx nullctx postingp s
let parse = parseWithCtx nullctx posting s assertBool -- "postingp parser"
assertBool "posting parser" $ isRight parse $ isRight parse
let Right p2 = parse let Right ap = parse
same f = assertEqual "" (f p) (f p2) same f = assertEqual (f ep) (f ap)
same pdate
same pstatus same pstatus
same paccount same paccount
same pamount same pamount
@ -511,16 +532,34 @@ tests_posting = [
same ptype same ptype
same ptags same ptags
same ptransaction same ptransaction
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" `gives`
`gives` posting{paccount="expenses:food:dining", pamount=Mixed [usd 10], pcomment=" a: a a \n b: b b \n", ptags=[("a","a a"), ("b","b b")]}
(Posting False "expenses:food:dining" (Mixed [usd 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing)
assertBool "posting parses a quoted commodity with numbers" " a 1 ; [2012/11/28]\n" `gives`
(isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n") ("a" `post` num 1){pcomment=" [2012/11/28]\n"
,ptags=[("date","2012/11/28")]
,pdate=parsedateM "2012/11/28"}
,"posting parses balance assertions and fixed lot prices" ~: do " a 1 ; a:a, [=2012/11/28]\n" `gives`
assertBool "" (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\" =$1 { =2.2 EUR} \n") ("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n"
] ,ptags=[("a","a"), ("date2","2012/11/28")]
,pdate=Nothing}
" a 1 ; a:a\n ; [2012/11/28=2012/11/29],b:b\n" `gives`
("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n"
,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")]
,pdate=parsedateM "2012/11/28"}
assertBool -- "postingp parses a quoted commodity with numbers"
(isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\"\n")
-- ,"postingp parses balance assertions and fixed lot prices" ~: do
assertBool (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
let parse = parseWithCtx nullctx postingp " a\n ;next-line comment\n"
assertRight parse
assertEqual "next-line comment\n" (let Right p = parse in pcomment p)
#endif
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountname :: GenParser Char JournalContext AccountName modifiedaccountname :: GenParser Char JournalContext AccountName
@ -560,13 +599,19 @@ spaceandamountormissing =
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
) <|> return missingmixedamt ) <|> return missingmixedamt
tests_spaceandamountormissing = [ #ifdef TESTS
"spaceandamountormissing" ~: do assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
assertParseEqual (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18]) assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse
assertParseEqual (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt
assertParseEqual (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt is' :: (Eq a, Show a) => a -> a -> Assertion
assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt a `is'` e = assertEqual e a
]
test_spaceandamountormissing = do
assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18])
assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt
assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt
assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt
#endif
-- | Parse a single-commodity amount, with optional symbol on the left or -- | Parse a single-commodity amount, with optional symbol on the left or
-- right, optional unit or total price, and optional (ignored) -- right, optional unit or total price, and optional (ignored)
@ -574,19 +619,19 @@ tests_spaceandamountormissing = [
amountp :: GenParser Char JournalContext Amount amountp :: GenParser Char JournalContext Amount
amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
tests_amountp = [ #ifdef TESTS
"amountp" ~: do test_amountp = do
assertParseEqual (parseWithCtx nullctx amountp "$47.18") (usd 47.18) assertParseEqual' (parseWithCtx nullctx amountp "$47.18") (usd 47.18)
assertParseEqual (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0) assertParseEqual' (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0)
,"amount with unit price" ~: do -- ,"amount with unit price" ~: do
assertParseEqual assertParseEqual'
(parseWithCtx nullctx amountp "$10 @ €0.5") (parseWithCtx nullctx amountp "$10 @ €0.5")
(usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
,"amount with total price" ~: do -- ,"amount with total price" ~: do
assertParseEqual assertParseEqual'
(parseWithCtx nullctx amountp "$10 @@ €5") (parseWithCtx nullctx amountp "$10 @@ €5")
(usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0)) (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
] #endif
-- | Parse an amount from a string, or get an error. -- | Parse an amount from a string, or get an error.
amountp' :: String -> Amount amountp' :: String -> Amount
@ -732,10 +777,10 @@ number = do
return (quantity,precision,decimalpoint,separator,separatorpositions) return (quantity,precision,decimalpoint,separator,separatorpositions)
<?> "number" <?> "number"
tests_number = [ #ifdef TESTS
"number" ~: do test_number = do
let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n let s `is` n = assertParseEqual' (parseWithCtx nullctx number s) n
assertFails = assertBool "" . isLeft . parseWithCtx nullctx number assertFails = assertBool . isLeft . parseWithCtx nullctx number
assertFails "" assertFails ""
"0" `is` (0, 0, '.', ',', []) "0" `is` (0, 0, '.', ',', [])
"1" `is` (1, 0, '.', ',', []) "1" `is` (1, 0, '.', ',', [])
@ -754,9 +799,9 @@ tests_number = [
assertFails "1..1" assertFails "1..1"
assertFails ".1," assertFails ".1,"
assertFails ",1." assertFails ",1."
] #endif
-- older comment parsers -- comment parsers
emptyline :: GenParser Char JournalContext () emptyline :: GenParser Char JournalContext ()
emptyline = do many spacenonewline emptyline = do many spacenonewline
@ -764,87 +809,98 @@ emptyline = do many spacenonewline
newline newline
return () return ()
comment :: GenParser Char JournalContext String followingcomment :: GenParser Char JournalContext String
comment = do followingcomment =
many1 $ char ';' -- ptrace "followingcomment"
many spacenonewline (do first <- many spacenonewline >> followingcommentline
c <- many (noneOf "\n") rest <- many (try (many1 spacenonewline >> followingcommentline))
return $ rstrip c return $ unlines $ first:rest
<?> "comment" ) <|>
do
many spacenonewline >> newline
rest <- many (try (many1 spacenonewline >> followingcommentline))
return $ unlines rest
commentline :: GenParser Char JournalContext String followingcommentline :: GenParser Char JournalContext String
commentline = do followingcommentline = do
many spacenonewline -- ptrace "followingcommentline"
c <- comment char ';'
l <- anyChar `manyTill` eolof
optional newline optional newline
eof return l
return c
<?> "comment"
-- newer comment parsers eolof = (newline >> return ()) <|> eof
inlinecomment :: GenParser Char JournalContext ([String],[Tag]) tagsInComment :: String -> [Tag]
inlinecomment = try (do {tag <- tagcomment; newline; return ([], [tag])}) tagsInComment c = concatMap tagsInCommentLine $ lines c'
<|> (do {c <- comment; newline; return ([rstrip c], [])}) where
<|> (newline >> return ([], [])) c' = ledgerDateSyntaxToTags c
tests_inlinecomment = [ tagsInCommentLine :: String -> [Tag]
"inlinecomment" ~: do tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
let s `gives` r = assertParseEqual (parseWithCtx nullctx inlinecomment s) r where
"; comment \n" `gives` (["comment"],[]) maybetag s = case parseWithCtx nullctx tag s of
";tag: a value \n" `gives` ([],[("tag","a value")]) Right t -> Just t
] Left _ -> Nothing
commentlines :: GenParser Char JournalContext ([String],[Tag]) tag = do
commentlines = do -- ptrace "tag"
comortags <- many $ choice' [(liftM Right tagline) n <- tagname
,(do {many1 spacenonewline; c <- comment; newline; return $ Left c }) -- XXX fix commentnewline v <- tagvalue
] return (n,v)
return $ partitionEithers comortags
tests_commentlines = [ tagname = do
"commentlines" ~: do -- ptrace "tagname"
let s `gives` r = assertParseEqual (parseWithCtx nullctx commentlines s) r n <- many1 $ noneOf ": \t"
" ; comment 1 \n ; tag1: val1 \n ;comment 2\n;unindented comment\n"
`gives` (["comment 1","comment 2"],[("tag1","val1")])
]
-- a comment line containing a tag declaration, eg:
-- ; name: value
tagline :: GenParser Char JournalContext Tag
tagline = do
many1 spacenonewline
tag <- tagcomment
newline
return tag
-- a comment containing a tag, like "; name: some value"
tagcomment :: GenParser Char JournalContext Tag
tagcomment = do
many1 $ char ';'
many spacenonewline
name <- many1 $ noneOf ": \t"
char ':' char ':'
many spacenonewline return n
value <- many (noneOf "\n")
return (name, rstrip value)
<?> "tag comment"
tests_tagcomment = [ tagvalue = do
"tagcomment" ~: do -- ptrace "tagvalue"
let s `gives` r = assertParseEqual (parseWithCtx nullctx tagcomment s) r v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
";tag: a value \n" `gives` ("tag","a value") return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
]
tests_Hledger_Read_JournalReader = TestList $ concat [ ledgerDateSyntaxToTags :: String -> String
tests_number, ledgerDateSyntaxToTags = regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
tests_amountp, where
tests_spaceandamountormissing, replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
tests_tagcomment, replace s = s
tests_inlinecomment,
tests_commentlines, replace' s | isdate s = datetag s
tests_posting, replace' ('=':s) | isdate s = date2tag s
tests_transaction, replace' s | last s =='=' && isdate (init s) = datetag (init s)
replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2
where
ds = splitAtElement '=' s
d1 = headDef "" ds
d2 = lastDef "" ds
replace' s = s
isdate = isJust . parsedateM
datetag s = "date:"++s++", "
date2tag s = "date2:"++s++", "
#ifdef TESTS
test_ledgerDateSyntaxToTags = do
assertEqual "date2:2012/11/28, " $ ledgerDateSyntaxToTags "[=2012/11/28]"
#endif
dateFromTags :: [Tag] -> Maybe Day
dateFromTags = maybe Nothing parsedateM . fmap snd . find ((=="date").fst)
{- old hunit tests
test_Hledger_Read_JournalReader = TestList $ concat [
test_number,
test_amountp,
test_spaceandamountormissing,
test_tagcomment,
test_inlinecomment,
test_commentlines,
test_ledgerDateSyntaxToTags,
test_postingp,
test_transaction,
[ [
"modifiertransaction" ~: do "modifiertransaction" ~: do
assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings 1\n") assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings 1\n")
@ -925,16 +981,5 @@ tests_Hledger_Read_JournalReader = TestList $ concat [
(num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0)) (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0))
]] ]]
-}
entry1_str = unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
entry1 =
txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing,
Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] Nothing] ""

16
hledger/Hledger/Cli/Tests.hs
View File

@ -1,3 +1,5 @@
-- {-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE CPP #-}
{- | {- |
A simple test runner for hledger's built-in unit tests. A simple test runner for hledger's built-in unit tests.
@ -13,8 +15,18 @@ import Test.HUnit
import Hledger import Hledger
import Hledger.Cli import Hledger.Cli
#ifdef TESTS
-- | Run unit tests and exit with success or failure. import Test.Framework
import {-@ HTF_TESTS @-} Hledger.Read.JournalReader
-- | Run HTF unit tests and exit with success or failure.
test' :: CliOpts -> IO ()
test' _opts = htfMain htf_importedTests
#else
-- | Run HUnit unit tests and exit with success or failure.
test' :: CliOpts -> IO () test' :: CliOpts -> IO ()
test' opts = do test' opts = do
results <- runTests opts results <- runTests opts
@ -39,3 +51,5 @@ flatTests opts = TestList $ filter (matchesAccount (queryFromOpts nulldate $ rep
-- | All or pattern-matched tests, in the original suites to show hierarchical names. -- | All or pattern-matched tests, in the original suites to show hierarchical names.
hierarchicalTests opts = filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . testName) tests_Hledger_Cli hierarchicalTests opts = filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . testName) tests_Hledger_Cli
#endif

48
tests/amount-layout-vertical.test
View File

@ -3,15 +3,15 @@
hledgerdev -f - print hledgerdev -f - print
<<< <<<
2010/1/1 2010/1/1
a EUR 1 ; a euro a EUR 1 ; a euro
b USD 1 ; a dollar b USD 1 ; a dollar
c ; a euro and a dollar c ; a euro and a dollar
>>> >>>
2010/01/01 2010/01/01
a EUR 1 ; a euro a EUR 1 ; a euro
b USD 1 ; a dollar b USD 1 ; a dollar
EUR -1 EUR -1
c USD -1 ; a euro and a dollar c USD -1 ; a euro and a dollar
>>>=0 >>>=0
@ -19,9 +19,9 @@ hledgerdev -f - print
hledgerdev -f - register hledgerdev -f - register
<<< <<<
2010/1/1 2010/1/1
a EUR 1 ; a euro a EUR 1 ; a euro
b USD 1 ; a dollar b USD 1 ; a dollar
c ; a euro and a dollar c ; a euro and a dollar
>>> >>>
2010/01/01 a EUR 1 EUR 1 2010/01/01 a EUR 1 EUR 1
EUR 1 EUR 1
@ -34,9 +34,9 @@ hledgerdev -f - register
hledgerdev -f - balance hledgerdev -f - balance
<<< <<<
2010/1/1 2010/1/1
a EUR 1 ; a euro a EUR 1 ; a euro
b USD 1 ; a dollar b USD 1 ; a dollar
c ; a euro and a dollar c ; a euro and a dollar
>>> >>>
EUR 1 a EUR 1 a
USD 1 b USD 1 b
@ -52,20 +52,20 @@ hledgerdev -f - balance
# <<< # <<<
# 2010/1/1 # 2010/1/1
# a EUR 1 @ USD 1.1 ; a euro # a EUR 1 @ USD 1.1 ; a euro
# b USD 1 ; a dollar # b USD 1 ; a dollar
# c ; a euro and a dollar # c ; a euro and a dollar
# >>> # >>>
# 2010/01/01 # 2010/01/01
# a EUR 1 @ USD 1.1 ; a euro # a EUR 1 @ USD 1.1 ; a euro
# b USD 1 ; a dollar # b USD 1 ; a dollar
# EUR -1 @ USD 1.1 # EUR -1 @ USD 1.1
# c USD -1 ; a euro and a dollar # c USD -1 ; a euro and a dollar
# #
## ##
# 2010/01/01 # 2010/01/01
# a EUR 1 @ USD 1.1 ; a euro # a EUR 1 @ USD 1.1 ; a euro
# b USD 1.0 ; a dollar # b USD 1.0 ; a dollar
# c USD -2.1 ; a euro and a dollar # c USD -2.1 ; a euro and a dollar
# #
#>>>=0 #>>>=0
# #
@ -74,8 +74,8 @@ hledgerdev -f - balance
# <<< # <<<
# 2010/1/1 # 2010/1/1
# a EUR 1 @ USD 1.1 ; a euro # a EUR 1 @ USD 1.1 ; a euro
# b USD 1 ; a dollar # b USD 1 ; a dollar
# c ; a euro and a dollar # c ; a euro and a dollar
# >>> # >>>
# 2010/01/01 a EUR 1 EUR 1 # 2010/01/01 a EUR 1 EUR 1
# EUR 1 # EUR 1
@ -89,8 +89,8 @@ hledgerdev -f - balance
# <<< # <<<
# 2010/1/1 # 2010/1/1
# a EUR 1 @ USD 1.1 ; a euro # a EUR 1 @ USD 1.1 ; a euro
# b USD 1 ; a dollar # b USD 1 ; a dollar
# c ; a euro and a dollar # c ; a euro and a dollar
# >>> # >>>
# EUR 1 a # EUR 1 a
# USD 1.0 b # USD 1.0 b

22
tests/comments.test
View File

@ -3,12 +3,14 @@
# 1. # 1.
hledgerdev -f - print hledgerdev -f - print
<<< <<<
2009/01/01 x ; transaction comment 1 2009/01/01 x
; transaction comment 1
; transaction comment 2 ; transaction comment 2
a 1 a 1
b b
>>> >>>
2009/01/01 x ; transaction comment 1 2009/01/01 x
; transaction comment 1
; transaction comment 2 ; transaction comment 2
a 1 a 1
b -1 b -1
@ -35,30 +37,32 @@ hledgerdev -f - print
; isolated journal comment ; isolated journal comment
; pre-transaction journal comment ; pre-transaction journal comment
2009/1/1 x ; transaction comment 2009/1/1 x ; transaction comment
a 1 ; posting 1 comment a 1 ; posting 1 comment
; posting 1 comment 2 ; posting 1 comment 2
b b
; posting 2 comment ; posting 2 comment
; post-transaction journal comment ; post-transaction journal comment
>>> >>>
2009/01/01 x ; transaction comment 2009/01/01 x ; transaction comment
a 1 ; posting 1 comment a 1
; posting 1 comment
; posting 1 comment 2 ; posting 1 comment 2
b -1 ; posting 2 comment b -1 ; posting 2 comment
>>>2
>>>=0 >>>=0
# 4. a posting comment should appear in print # 4. a posting comment should appear in print
hledgerdev -f - print hledgerdev -f - print
<<< <<<
2010/01/01 x 2010/01/01 x
a 1 ; comment a 1 ; comment
b -1 b -1
>>> >>>
2010/01/01 x 2010/01/01 x
a 1 ; comment a 1 ; comment
b -1 b -1
>>>2 >>>2

25
tests/tags.test
View File

@ -28,12 +28,11 @@ hledgerdev -f - print
# 2. reports can filter by tag existence # 2. reports can filter by tag existence
hledgerdev -f - print tag:foo hledgerdev -f - print tag:foo
<<< <<<
2010/01/01 ; foo:bar 2010/01/01 ; foo:bar
a 1 a 1
b -1 b -1
2010/01/02 2010/01/02 ; foo:baz
; foo:baz
c 1 c 1
d -1 d -1
@ -41,13 +40,11 @@ hledgerdev -f - print tag:foo
e 1 e 1
f -1 f -1
>>> >>>
2010/01/01 2010/01/01 ; foo:bar
; foo: bar
a 1 a 1
b -1 b -1
2010/01/02 2010/01/02 ; foo:baz
; foo: baz
c 1 c 1
d -1 d -1
@ -57,8 +54,7 @@ hledgerdev -f - print tag:foo
# 3. or tag value # 3. or tag value
hledgerdev -f - print tag:foo=bar hledgerdev -f - print tag:foo=bar
<<< <<<
2010/01/01 2010/01/01 ; foo:bar
; foo:bar
a 1 a 1
b -1 b -1
@ -71,8 +67,7 @@ hledgerdev -f - print tag:foo=bar
e 1 e 1
f -1 f -1
>>> >>>
2010/01/01 2010/01/01 ; foo:bar
; foo: bar
a 1 a 1
b -1 b -1
@ -83,16 +78,14 @@ hledgerdev -f - print tag:foo=bar
hledgerdev -f - register tag:foo=bar hledgerdev -f - register tag:foo=bar
<<< <<<
2010/01/01 2010/01/01
a 1 ; foo:bar a 1 ; foo:bar
b -1 b -1
2010/01/02 2010/01/02 ; foo:baz
; foo:baz
c 1 c 1
d -1 d -1
2010/01/03 2010/01/03 ; foo:bar
; foo:bar
e 1 e 1
f -1 f -1
>>> >>>