parse posting dates, better comment/tag handling, begin using HTF for unit testing
This commit is contained in:
Simon Michael
parent
d0bd0663b6
commit
e75abc4625
12
MANUAL.md
12
MANUAL.md
@ -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
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
- 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
|
||||
|
||||
|
||||
@ -28,6 +28,7 @@ module Hledger.Data.Dates (
|
||||
getCurrentYear,
|
||||
nulldate,
|
||||
spanContainsDate,
|
||||
parsedateM,
|
||||
parsedate,
|
||||
showDate,
|
||||
elapsedSeconds,
|
||||
|
||||
@ -64,7 +64,8 @@ instance Show Posting where show = showPosting
|
||||
|
||||
nullposting, posting :: Posting
|
||||
nullposting = Posting
|
||||
{pstatus=False
|
||||
{pdate=Nothing
|
||||
,pstatus=False
|
||||
,paccount=""
|
||||
,pamount=nullmixedamt
|
||||
,pcomment=""
|
||||
@ -98,7 +99,7 @@ tagsAsLines :: [(String, String)] -> [String]
|
||||
tagsAsLines mds = map (\(k,v) -> " ; " ++ k++": "++v) mds
|
||||
|
||||
showComment :: String -> String
|
||||
showComment s = if null s then "" else " ; " ++ s
|
||||
showComment s = if null s then "" else " ;" ++ s
|
||||
|
||||
-- XXX refactor
|
||||
showPostingForRegister :: Posting -> String
|
||||
@ -132,8 +133,13 @@ accountNamesFromPostings = nub . map paccount
|
||||
sumPostings :: [Posting] -> MixedAmount
|
||||
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 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
|
||||
-- as cleared, returns True. Otherwise, return the parent
|
||||
|
||||
@ -115,14 +115,13 @@ tests_showTransactionUnelided = [
|
||||
]
|
||||
}
|
||||
`gives` unlines [
|
||||
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
|
||||
" ; tcomment2",
|
||||
" ; ttag1: val1",
|
||||
"2012/05/14=2012/05/15 (code) desc",
|
||||
" ;tcomment1",
|
||||
" ;tcomment2",
|
||||
" $1.00",
|
||||
" * a 2.0h ; pcomment1",
|
||||
" ; pcomment2",
|
||||
" ; ptag1: val1",
|
||||
" ; ptag2: val2",
|
||||
" * a 2.0h",
|
||||
" ;pcomment1",
|
||||
" ;pcomment2",
|
||||
""
|
||||
]
|
||||
]
|
||||
@ -131,26 +130,30 @@ tests_showTransactionUnelided = [
|
||||
showTransaction' :: Bool -> Transaction -> String
|
||||
showTransaction' elide t =
|
||||
unlines $ [descriptionline]
|
||||
++ commentlines
|
||||
++ (tagsAsLines $ ttags t)
|
||||
++ multilinecomment
|
||||
-- ++ (tagsAsLines $ ttags t)
|
||||
++ (postingsAsLines elide t (tpostings t))
|
||||
++ [""]
|
||||
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)
|
||||
showdate = printf "%-10s" . showDate
|
||||
showedate = printf "=%s" . showdate
|
||||
status = if tstatus t then " *" else ""
|
||||
code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""
|
||||
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 s
|
||||
| null s = ("", [])
|
||||
| otherwise = (" ; " ++ first, map (indent . ("; "++)) rest)
|
||||
where (first:rest) = lines s
|
||||
| length ls == 1 = (prefix $ head ls, [])
|
||||
| otherwise = ("", (prefix $ head ls):(map prefix $ tail ls))
|
||||
where
|
||||
ls = lines s
|
||||
prefix = indent . (";"++)
|
||||
|
||||
postingsAsLines :: Bool -> Transaction -> [Posting] -> [String]
|
||||
postingsAsLines elide t ps
|
||||
@ -161,12 +164,12 @@ postingsAsLines elide t ps
|
||||
postingAsLines :: Bool -> [Posting] -> Posting -> [String]
|
||||
postingAsLines elideamount ps p =
|
||||
postinglines
|
||||
++ commentlines
|
||||
++ tagsAsLines (ptags p)
|
||||
++ multilinecomment
|
||||
-- ++ tagsAsLines (ptags p)
|
||||
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)
|
||||
(firstcomment, commentlines) = commentLines $ pcomment p
|
||||
(inlinecomment, multilinecomment) = commentLines $ pcomment p
|
||||
showacct p =
|
||||
indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))
|
||||
where
|
||||
@ -178,21 +181,21 @@ postingAsLines elideamount ps p =
|
||||
tests_postingAsLines = [
|
||||
"postingAsLines" ~: do
|
||||
let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p)
|
||||
nullposting `gives` [" 0"]
|
||||
nullposting{
|
||||
posting `gives` [" 0"]
|
||||
posting{
|
||||
pstatus=True,
|
||||
paccount="a",
|
||||
pamount=Mixed [usd 1, hrs 2],
|
||||
pcomment="pcomment1\npcomment2\n",
|
||||
pcomment="pcomment1\npcomment2\n tag3: val3 \n",
|
||||
ptype=RegularPosting,
|
||||
ptags=[("ptag1","val1"),("ptag2","val2")]
|
||||
}
|
||||
`gives` [
|
||||
" $1.00",
|
||||
" * a 2.0h ; pcomment1",
|
||||
" ; pcomment2",
|
||||
" ; ptag1: val1",
|
||||
" ; ptag2: val2"
|
||||
" * a 2.0h",
|
||||
" ;pcomment1",
|
||||
" ;pcomment2",
|
||||
" ; tag3: val3 "
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
@ -76,6 +76,7 @@ data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
|
||||
type Tag = (String, String)
|
||||
|
||||
data Posting = Posting {
|
||||
pdate :: Maybe Day, -- ^ this posting's clearing date, if different from the transaction's
|
||||
pstatus :: Bool,
|
||||
paccount :: AccountName,
|
||||
pamount :: MixedAmount,
|
||||
@ -89,7 +90,7 @@ data Posting = Posting {
|
||||
-- The equality test for postings ignores the parent transaction's
|
||||
-- identity, to avoid infinite loops.
|
||||
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 {
|
||||
tdate :: Day,
|
||||
@ -247,6 +248,8 @@ data Account = Account {
|
||||
aboring :: Bool -- ^ used in the accounts report to label elidable parents
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- | A Ledger has the journal it derives from, and the accounts
|
||||
-- derived from that. Accounts are accessible both list-wise and
|
||||
-- tree-wise, since each one knows its parent and subs; the first
|
||||
|
||||
@ -216,7 +216,7 @@ samplejournal = readJournal' $ unlines
|
||||
tests_Hledger_Read = TestList $
|
||||
tests_readJournal'
|
||||
++ [
|
||||
tests_Hledger_Read_JournalReader,
|
||||
-- tests_Hledger_Read_JournalReader,
|
||||
tests_Hledger_Read_TimelogReader,
|
||||
tests_Hledger_Read_CsvReader,
|
||||
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE RecordWildCards, NoMonoLocalBinds #-}
|
||||
-- {-# OPTIONS_GHC -F -pgmF htfpp #-}
|
||||
{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-}
|
||||
{-|
|
||||
|
||||
A reader for hledger's journal file format
|
||||
@ -30,23 +31,29 @@ module Hledger.Read.JournalReader (
|
||||
amountp,
|
||||
amountp',
|
||||
mamountp',
|
||||
emptyline,
|
||||
emptyline
|
||||
#ifdef TESTS
|
||||
-- * Tests
|
||||
tests_Hledger_Read_JournalReader
|
||||
-- disabled by default, HTF not available on windows
|
||||
,htf_thisModulesTests
|
||||
,htf_Hledger_Read_JournalReader_importedTests
|
||||
#endif
|
||||
)
|
||||
where
|
||||
import qualified Control.Exception as C
|
||||
import Control.Monad
|
||||
import Control.Monad.Error
|
||||
import Data.Char (isNumber)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.List
|
||||
import Data.List.Split (wordsBy)
|
||||
import Data.Maybe
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.LocalTime
|
||||
import Safe (headDef)
|
||||
import Test.HUnit
|
||||
import Safe (headDef, lastDef)
|
||||
#ifdef TESTS
|
||||
import Test.Framework
|
||||
import Text.Parsec.Error
|
||||
#endif
|
||||
import Text.ParserCombinators.Parsec hiding (parse)
|
||||
import Text.Printf
|
||||
import System.FilePath
|
||||
@ -311,41 +318,35 @@ periodictransaction = do
|
||||
-- | Parse a (possibly unbalanced) transaction.
|
||||
transaction :: GenParser Char JournalContext Transaction
|
||||
transaction = do
|
||||
-- ptrace "transaction"
|
||||
date <- date <?> "transaction"
|
||||
edate <- optionMaybe (effectivedate date) <?> "effective date"
|
||||
status <- status <?> "cleared flag"
|
||||
code <- code <?> "transaction code"
|
||||
-- now there can be whitespace followed by a description and/or comment/tag comment
|
||||
let pdescription = many (noneOf ";\n") >>= return . strip
|
||||
(description, inlinecomment, inlinetag) <-
|
||||
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
|
||||
description <- descriptionp >>= return . strip
|
||||
comment <- try followingcomment <|> (newline >> return "")
|
||||
let tags = tagsInComment comment
|
||||
postings <- postings
|
||||
return $ txnTieKnot $ Transaction date edate status code description comment tags postings ""
|
||||
|
||||
tests_transaction = [
|
||||
"transaction" ~: do
|
||||
-- let s `gives` t = assertParseEqual (parseWithCtx nullctx transaction s) t
|
||||
descriptionp = many (noneOf ";\n")
|
||||
|
||||
#ifdef TESTS
|
||||
test_transaction = do
|
||||
let s `gives` t = do
|
||||
let p = parseWithCtx nullctx transaction s
|
||||
assertBool "transaction parser failed" $ isRight p
|
||||
assertBool $ isRight p
|
||||
let Right t2 = p
|
||||
same f = assertEqual "" (f t) (f t2)
|
||||
same tdate
|
||||
same teffectivedate
|
||||
same tstatus
|
||||
same tcode
|
||||
same tdescription
|
||||
same tcomment
|
||||
same ttags
|
||||
same tpreceding_comment_lines
|
||||
same tpostings
|
||||
-- same f = assertEqual (f t) (f t2)
|
||||
assertEqual (tdate t) (tdate t2)
|
||||
assertEqual (teffectivedate t) (teffectivedate t2)
|
||||
assertEqual (tstatus t) (tstatus t2)
|
||||
assertEqual (tcode t) (tcode t2)
|
||||
assertEqual (tdescription t) (tdescription t2)
|
||||
assertEqual (tcomment t) (tcomment t2)
|
||||
assertEqual (ttags t) (ttags t2)
|
||||
assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2)
|
||||
assertEqual (show $ tpostings t) (show $ tpostings t2)
|
||||
-- "0000/01/01\n\n" `gives` nulltransaction
|
||||
unlines [
|
||||
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
|
||||
@ -363,14 +364,14 @@ tests_transaction = [
|
||||
tstatus=False,
|
||||
tcode="code",
|
||||
tdescription="desc",
|
||||
tcomment="tcomment1\ntcomment2\n",
|
||||
tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",
|
||||
ttags=[("ttag1","val1")],
|
||||
tpostings=[
|
||||
nullposting{
|
||||
pstatus=True,
|
||||
paccount="a",
|
||||
pamount=Mixed [usd 1],
|
||||
pcomment="pcomment1\npcomment2\n",
|
||||
pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n",
|
||||
ptype=RegularPosting,
|
||||
ptags=[("ptag1","val1"),("ptag2","val2")],
|
||||
ptransaction=Nothing
|
||||
@ -379,22 +380,42 @@ tests_transaction = [
|
||||
tpreceding_comment_lines=""
|
||||
}
|
||||
|
||||
assertParseEqual (parseWithCtx nullctx transaction entry1_str) entry1
|
||||
assertBool "transaction should not parse just a date"
|
||||
$ isLeft $ parseWithCtx nullctx transaction "2009/1/1\n"
|
||||
assertBool "transaction should require some postings"
|
||||
$ 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
|
||||
assertBool "parse transaction with following whitespace line" $
|
||||
isRight $ parseWithCtx nullctx transaction $ unlines [
|
||||
"2012/1/1"
|
||||
assertRight $ parseWithCtx nullctx transaction $ unlines
|
||||
["2007/01/28 coopportunity"
|
||||
," expenses:food:groceries $47.18"
|
||||
," assets:checking $-47.18"
|
||||
,""
|
||||
]
|
||||
|
||||
-- transaction should not parse just a date
|
||||
assertLeft $ parseWithCtx nullctx transaction "2009/1/1\n"
|
||||
|
||||
-- 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"
|
||||
," 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
|
||||
-- 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.
|
||||
postings :: GenParser Char JournalContext [Posting]
|
||||
postings = many1 (try posting) <?> "postings"
|
||||
postings = many1 (try postingp) <?> "postings"
|
||||
|
||||
-- linebeginningwithspaces :: GenParser Char JournalContext String
|
||||
-- linebeginningwithspaces = do
|
||||
@ -479,8 +500,8 @@ postings = many1 (try posting) <?> "postings"
|
||||
-- cs <- restofline
|
||||
-- return $ sp ++ (c:cs) ++ "\n"
|
||||
|
||||
posting :: GenParser Char JournalContext Posting
|
||||
posting = do
|
||||
postingp :: GenParser Char JournalContext Posting
|
||||
postingp = do
|
||||
many1 spacenonewline
|
||||
status <- status
|
||||
many spacenonewline
|
||||
@ -490,20 +511,20 @@ posting = do
|
||||
_ <- balanceassertion
|
||||
_ <- fixedlotprice
|
||||
many spacenonewline
|
||||
(inlinecomment, inlinetag) <- inlinecomment
|
||||
(nextlinecomments, nextlinetags) <- commentlines
|
||||
let comment = unlines $ inlinecomment ++ nextlinecomments
|
||||
tags = inlinetag ++ nextlinetags
|
||||
return (Posting status account' amount comment ptype tags Nothing)
|
||||
comment <- try followingcomment <|> (newline >> return "")
|
||||
let tags = tagsInComment comment
|
||||
date = dateFromTags tags
|
||||
return posting{pdate=date, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags}
|
||||
|
||||
tests_posting = [
|
||||
"posting" ~: do
|
||||
-- let s `gives` r = assertParseEqual (parseWithCtx nullctx posting s) r
|
||||
let s `gives` p = do
|
||||
let parse = parseWithCtx nullctx posting s
|
||||
assertBool "posting parser" $ isRight parse
|
||||
let Right p2 = parse
|
||||
same f = assertEqual "" (f p) (f p2)
|
||||
#ifdef TESTS
|
||||
test_postingp = do
|
||||
let s `gives` ep = do
|
||||
let parse = parseWithCtx nullctx postingp s
|
||||
assertBool -- "postingp parser"
|
||||
$ isRight parse
|
||||
let Right ap = parse
|
||||
same f = assertEqual (f ep) (f ap)
|
||||
same pdate
|
||||
same pstatus
|
||||
same paccount
|
||||
same pamount
|
||||
@ -511,16 +532,34 @@ tests_posting = [
|
||||
same ptype
|
||||
same ptags
|
||||
same ptransaction
|
||||
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
|
||||
`gives`
|
||||
(Posting False "expenses:food:dining" (Mixed [usd 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing)
|
||||
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" `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")]}
|
||||
|
||||
assertBool "posting parses a quoted commodity with numbers"
|
||||
(isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n")
|
||||
" a 1 ; [2012/11/28]\n" `gives`
|
||||
("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
|
||||
assertBool "" (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
|
||||
]
|
||||
" a 1 ; a:a, [=2012/11/28]\n" `gives`
|
||||
("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.
|
||||
modifiedaccountname :: GenParser Char JournalContext AccountName
|
||||
@ -560,13 +599,19 @@ spaceandamountormissing =
|
||||
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
|
||||
) <|> return missingmixedamt
|
||||
|
||||
tests_spaceandamountormissing = [
|
||||
"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
|
||||
]
|
||||
#ifdef TESTS
|
||||
assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
|
||||
assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse
|
||||
|
||||
is' :: (Eq a, Show a) => a -> a -> Assertion
|
||||
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
|
||||
-- right, optional unit or total price, and optional (ignored)
|
||||
@ -574,19 +619,19 @@ tests_spaceandamountormissing = [
|
||||
amountp :: GenParser Char JournalContext Amount
|
||||
amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
|
||||
|
||||
tests_amountp = [
|
||||
"amountp" ~: do
|
||||
assertParseEqual (parseWithCtx nullctx amountp "$47.18") (usd 47.18)
|
||||
assertParseEqual (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0)
|
||||
,"amount with unit price" ~: do
|
||||
assertParseEqual
|
||||
#ifdef TESTS
|
||||
test_amountp = do
|
||||
assertParseEqual' (parseWithCtx nullctx amountp "$47.18") (usd 47.18)
|
||||
assertParseEqual' (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0)
|
||||
-- ,"amount with unit price" ~: do
|
||||
assertParseEqual'
|
||||
(parseWithCtx nullctx amountp "$10 @ €0.5")
|
||||
(usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
|
||||
,"amount with total price" ~: do
|
||||
assertParseEqual
|
||||
-- ,"amount with total price" ~: do
|
||||
assertParseEqual'
|
||||
(parseWithCtx nullctx amountp "$10 @@ €5")
|
||||
(usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
|
||||
]
|
||||
#endif
|
||||
|
||||
-- | Parse an amount from a string, or get an error.
|
||||
amountp' :: String -> Amount
|
||||
@ -732,10 +777,10 @@ number = do
|
||||
return (quantity,precision,decimalpoint,separator,separatorpositions)
|
||||
<?> "number"
|
||||
|
||||
tests_number = [
|
||||
"number" ~: do
|
||||
let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n
|
||||
assertFails = assertBool "" . isLeft . parseWithCtx nullctx number
|
||||
#ifdef TESTS
|
||||
test_number = do
|
||||
let s `is` n = assertParseEqual' (parseWithCtx nullctx number s) n
|
||||
assertFails = assertBool . isLeft . parseWithCtx nullctx number
|
||||
assertFails ""
|
||||
"0" `is` (0, 0, '.', ',', [])
|
||||
"1" `is` (1, 0, '.', ',', [])
|
||||
@ -754,9 +799,9 @@ tests_number = [
|
||||
assertFails "1..1"
|
||||
assertFails ".1,"
|
||||
assertFails ",1."
|
||||
]
|
||||
#endif
|
||||
|
||||
-- older comment parsers
|
||||
-- comment parsers
|
||||
|
||||
emptyline :: GenParser Char JournalContext ()
|
||||
emptyline = do many spacenonewline
|
||||
@ -764,87 +809,98 @@ emptyline = do many spacenonewline
|
||||
newline
|
||||
return ()
|
||||
|
||||
comment :: GenParser Char JournalContext String
|
||||
comment = do
|
||||
many1 $ char ';'
|
||||
many spacenonewline
|
||||
c <- many (noneOf "\n")
|
||||
return $ rstrip c
|
||||
<?> "comment"
|
||||
followingcomment :: GenParser Char JournalContext String
|
||||
followingcomment =
|
||||
-- ptrace "followingcomment"
|
||||
(do first <- many spacenonewline >> followingcommentline
|
||||
rest <- many (try (many1 spacenonewline >> followingcommentline))
|
||||
return $ unlines $ first:rest
|
||||
) <|>
|
||||
do
|
||||
many spacenonewline >> newline
|
||||
rest <- many (try (many1 spacenonewline >> followingcommentline))
|
||||
return $ unlines rest
|
||||
|
||||
commentline :: GenParser Char JournalContext String
|
||||
commentline = do
|
||||
many spacenonewline
|
||||
c <- comment
|
||||
followingcommentline :: GenParser Char JournalContext String
|
||||
followingcommentline = do
|
||||
-- ptrace "followingcommentline"
|
||||
char ';'
|
||||
l <- anyChar `manyTill` eolof
|
||||
optional newline
|
||||
eof
|
||||
return c
|
||||
<?> "comment"
|
||||
return l
|
||||
|
||||
-- newer comment parsers
|
||||
eolof = (newline >> return ()) <|> eof
|
||||
|
||||
inlinecomment :: GenParser Char JournalContext ([String],[Tag])
|
||||
inlinecomment = try (do {tag <- tagcomment; newline; return ([], [tag])})
|
||||
<|> (do {c <- comment; newline; return ([rstrip c], [])})
|
||||
<|> (newline >> return ([], []))
|
||||
tagsInComment :: String -> [Tag]
|
||||
tagsInComment c = concatMap tagsInCommentLine $ lines c'
|
||||
where
|
||||
c' = ledgerDateSyntaxToTags c
|
||||
|
||||
tests_inlinecomment = [
|
||||
"inlinecomment" ~: do
|
||||
let s `gives` r = assertParseEqual (parseWithCtx nullctx inlinecomment s) r
|
||||
"; comment \n" `gives` (["comment"],[])
|
||||
";tag: a value \n" `gives` ([],[("tag","a value")])
|
||||
]
|
||||
tagsInCommentLine :: String -> [Tag]
|
||||
tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
|
||||
where
|
||||
maybetag s = case parseWithCtx nullctx tag s of
|
||||
Right t -> Just t
|
||||
Left _ -> Nothing
|
||||
|
||||
commentlines :: GenParser Char JournalContext ([String],[Tag])
|
||||
commentlines = do
|
||||
comortags <- many $ choice' [(liftM Right tagline)
|
||||
,(do {many1 spacenonewline; c <- comment; newline; return $ Left c }) -- XXX fix commentnewline
|
||||
]
|
||||
return $ partitionEithers comortags
|
||||
tag = do
|
||||
-- ptrace "tag"
|
||||
n <- tagname
|
||||
v <- tagvalue
|
||||
return (n,v)
|
||||
|
||||
tests_commentlines = [
|
||||
"commentlines" ~: do
|
||||
let s `gives` r = assertParseEqual (parseWithCtx nullctx commentlines s) r
|
||||
" ; 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"
|
||||
tagname = do
|
||||
-- ptrace "tagname"
|
||||
n <- many1 $ noneOf ": \t"
|
||||
char ':'
|
||||
many spacenonewline
|
||||
value <- many (noneOf "\n")
|
||||
return (name, rstrip value)
|
||||
<?> "tag comment"
|
||||
return n
|
||||
|
||||
tests_tagcomment = [
|
||||
"tagcomment" ~: do
|
||||
let s `gives` r = assertParseEqual (parseWithCtx nullctx tagcomment s) r
|
||||
";tag: a value \n" `gives` ("tag","a value")
|
||||
]
|
||||
tagvalue = do
|
||||
-- ptrace "tagvalue"
|
||||
v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
|
||||
return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
|
||||
|
||||
tests_Hledger_Read_JournalReader = TestList $ concat [
|
||||
tests_number,
|
||||
tests_amountp,
|
||||
tests_spaceandamountormissing,
|
||||
tests_tagcomment,
|
||||
tests_inlinecomment,
|
||||
tests_commentlines,
|
||||
tests_posting,
|
||||
tests_transaction,
|
||||
ledgerDateSyntaxToTags :: String -> String
|
||||
ledgerDateSyntaxToTags = regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
|
||||
where
|
||||
replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
|
||||
replace s = s
|
||||
|
||||
replace' s | isdate s = datetag s
|
||||
replace' ('=':s) | isdate s = date2tag s
|
||||
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
|
||||
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))
|
||||
|
||||
]]
|
||||
|
||||
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] ""
|
||||
-}
|
||||
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
-- {-# OPTIONS_GHC -F -pgmF htfpp #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{- |
|
||||
|
||||
A simple test runner for hledger's built-in unit tests.
|
||||
@ -13,8 +15,18 @@ import Test.HUnit
|
||||
import Hledger
|
||||
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' opts = do
|
||||
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.
|
||||
hierarchicalTests opts = filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . testName) tests_Hledger_Cli
|
||||
|
||||
#endif
|
||||
|
||||
@ -3,15 +3,15 @@
|
||||
hledgerdev -f - print
|
||||
<<<
|
||||
2010/1/1
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
c ; a euro and a dollar
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
c ; a euro and a dollar
|
||||
>>>
|
||||
2010/01/01
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
EUR -1
|
||||
c USD -1 ; a euro and a dollar
|
||||
c USD -1 ; a euro and a dollar
|
||||
|
||||
>>>=0
|
||||
|
||||
@ -19,9 +19,9 @@ hledgerdev -f - print
|
||||
hledgerdev -f - register
|
||||
<<<
|
||||
2010/1/1
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
c ; a euro and a dollar
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
c ; a euro and a dollar
|
||||
>>>
|
||||
2010/01/01 a EUR 1 EUR 1
|
||||
EUR 1
|
||||
@ -34,9 +34,9 @@ hledgerdev -f - register
|
||||
hledgerdev -f - balance
|
||||
<<<
|
||||
2010/1/1
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
c ; a euro and a dollar
|
||||
a EUR 1 ; a euro
|
||||
b USD 1 ; a dollar
|
||||
c ; a euro and a dollar
|
||||
>>>
|
||||
EUR 1 a
|
||||
USD 1 b
|
||||
@ -52,20 +52,20 @@ hledgerdev -f - balance
|
||||
# <<<
|
||||
# 2010/1/1
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1 ; a dollar
|
||||
# c ; a euro and a dollar
|
||||
# b USD 1 ; a dollar
|
||||
# c ; a euro and a dollar
|
||||
# >>>
|
||||
# 2010/01/01
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1 ; a dollar
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1 ; a dollar
|
||||
# EUR -1 @ USD 1.1
|
||||
# c USD -1 ; a euro and a dollar
|
||||
# c USD -1 ; a euro and a dollar
|
||||
#
|
||||
##
|
||||
# 2010/01/01
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1.0 ; a dollar
|
||||
# c USD -2.1 ; a euro and a dollar
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1.0 ; a dollar
|
||||
# c USD -2.1 ; a euro and a dollar
|
||||
#
|
||||
#>>>=0
|
||||
#
|
||||
@ -74,8 +74,8 @@ hledgerdev -f - balance
|
||||
# <<<
|
||||
# 2010/1/1
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1 ; a dollar
|
||||
# c ; a euro and a dollar
|
||||
# b USD 1 ; a dollar
|
||||
# c ; a euro and a dollar
|
||||
# >>>
|
||||
# 2010/01/01 a EUR 1 EUR 1
|
||||
# EUR 1
|
||||
@ -89,8 +89,8 @@ hledgerdev -f - balance
|
||||
# <<<
|
||||
# 2010/1/1
|
||||
# a EUR 1 @ USD 1.1 ; a euro
|
||||
# b USD 1 ; a dollar
|
||||
# c ; a euro and a dollar
|
||||
# b USD 1 ; a dollar
|
||||
# c ; a euro and a dollar
|
||||
# >>>
|
||||
# EUR 1 a
|
||||
# USD 1.0 b
|
||||
|
||||
@ -3,12 +3,14 @@
|
||||
# 1.
|
||||
hledgerdev -f - print
|
||||
<<<
|
||||
2009/01/01 x ; transaction comment 1
|
||||
2009/01/01 x
|
||||
; transaction comment 1
|
||||
; transaction comment 2
|
||||
a 1
|
||||
b
|
||||
>>>
|
||||
2009/01/01 x ; transaction comment 1
|
||||
2009/01/01 x
|
||||
; transaction comment 1
|
||||
; transaction comment 2
|
||||
a 1
|
||||
b -1
|
||||
@ -35,30 +37,32 @@ hledgerdev -f - print
|
||||
; isolated journal comment
|
||||
|
||||
; pre-transaction journal comment
|
||||
2009/1/1 x ; transaction comment
|
||||
a 1 ; posting 1 comment
|
||||
2009/1/1 x ; transaction comment
|
||||
a 1 ; posting 1 comment
|
||||
; posting 1 comment 2
|
||||
b
|
||||
; posting 2 comment
|
||||
; post-transaction journal comment
|
||||
>>>
|
||||
2009/01/01 x ; transaction comment
|
||||
a 1 ; posting 1 comment
|
||||
2009/01/01 x ; transaction comment
|
||||
a 1
|
||||
; posting 1 comment
|
||||
; posting 1 comment 2
|
||||
b -1 ; posting 2 comment
|
||||
b -1 ; posting 2 comment
|
||||
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 4. a posting comment should appear in print
|
||||
hledgerdev -f - print
|
||||
<<<
|
||||
2010/01/01 x
|
||||
a 1 ; comment
|
||||
a 1 ; comment
|
||||
b -1
|
||||
|
||||
>>>
|
||||
2010/01/01 x
|
||||
a 1 ; comment
|
||||
a 1 ; comment
|
||||
b -1
|
||||
|
||||
>>>2
|
||||
|
||||
@ -28,12 +28,11 @@ hledgerdev -f - print
|
||||
# 2. reports can filter by tag existence
|
||||
hledgerdev -f - print tag:foo
|
||||
<<<
|
||||
2010/01/01 ; foo:bar
|
||||
2010/01/01 ; foo:bar
|
||||
a 1
|
||||
b -1
|
||||
|
||||
2010/01/02
|
||||
; foo:baz
|
||||
2010/01/02 ; foo:baz
|
||||
c 1
|
||||
d -1
|
||||
|
||||
@ -41,13 +40,11 @@ hledgerdev -f - print tag:foo
|
||||
e 1
|
||||
f -1
|
||||
>>>
|
||||
2010/01/01
|
||||
; foo: bar
|
||||
2010/01/01 ; foo:bar
|
||||
a 1
|
||||
b -1
|
||||
|
||||
2010/01/02
|
||||
; foo: baz
|
||||
2010/01/02 ; foo:baz
|
||||
c 1
|
||||
d -1
|
||||
|
||||
@ -57,8 +54,7 @@ hledgerdev -f - print tag:foo
|
||||
# 3. or tag value
|
||||
hledgerdev -f - print tag:foo=bar
|
||||
<<<
|
||||
2010/01/01
|
||||
; foo:bar
|
||||
2010/01/01 ; foo:bar
|
||||
a 1
|
||||
b -1
|
||||
|
||||
@ -71,8 +67,7 @@ hledgerdev -f - print tag:foo=bar
|
||||
e 1
|
||||
f -1
|
||||
>>>
|
||||
2010/01/01
|
||||
; foo: bar
|
||||
2010/01/01 ; foo:bar
|
||||
a 1
|
||||
b -1
|
||||
|
||||
@ -83,16 +78,14 @@ hledgerdev -f - print tag:foo=bar
|
||||
hledgerdev -f - register tag:foo=bar
|
||||
<<<
|
||||
2010/01/01
|
||||
a 1 ; foo:bar
|
||||
a 1 ; foo:bar
|
||||
b -1
|
||||
|
||||
2010/01/02
|
||||
; foo:baz
|
||||
2010/01/02 ; foo:baz
|
||||
c 1
|
||||
d -1
|
||||
|
||||
2010/01/03
|
||||
; foo:bar
|
||||
2010/01/03 ; foo:bar
|
||||
e 1
|
||||
f -1
|
||||
>>>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user