module Hledger.Read.JournalReader (
reader,
parseJournalWith,
getParentAccount,
journal,
directive,
defaultyeardirective,
historicalpricedirective,
datetimep,
codep,
accountnamep,
postingp,
amountp,
amountp',
mamountp',
numberp,
emptyorcommentlinep,
followingcommentp
#ifdef TESTS
,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.List
import Data.List.Split (wordsBy)
import Data.Maybe
import Data.Time.Calendar
import Data.Time.LocalTime
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
import System.Time (getClockTime)
import Hledger.Data
import Hledger.Utils
import Prelude hiding (readFile)
reader :: Reader
reader = Reader format detect parse
format :: String
format = "journal"
detect :: FilePath -> String -> Bool
detect f _ = takeExtension f `elem` ['.':format, ".j"]
parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal
parse _ =
parseJournalWith journal
combineJournalUpdates :: [JournalUpdate] -> JournalUpdate
combineJournalUpdates us = liftM (foldl' (.) id) $ sequence us
parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal
parseJournalWith p f s = do
tc <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime
y <- liftIO getCurrentYear
case runParser p nullctx{ctxYear=Just y} f s of
Right (updates,ctx) -> do
j <- updates `ap` return nulljournal
case journalFinalise tc tl f s ctx j of
Right j' -> return j'
Left estr -> throwError estr
Left e -> throwError $ show e
setYear :: Integer -> GenParser tok JournalContext ()
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
getYear :: GenParser tok JournalContext (Maybe Integer)
getYear = liftM ctxYear getState
setCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext ()
setCommodityAndStyle cs = updateState (\ctx -> ctx{ctxCommodityAndStyle=Just cs})
getCommodityAndStyle :: GenParser tok JournalContext (Maybe (Commodity,AmountStyle))
getCommodityAndStyle = ctxCommodityAndStyle `fmap` getState
pushParentAccount :: String -> GenParser tok JournalContext ()
pushParentAccount parent = updateState addParentAccount
where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
popParentAccount :: GenParser tok JournalContext ()
popParentAccount = do ctx0 <- getState
case ctxAccount ctx0 of
[] -> unexpected "End of account block with no beginning"
(_:rest) -> setState $ ctx0 { ctxAccount = rest }
getParentAccount :: GenParser tok JournalContext String
getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()
addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]
getAccountAliases = liftM ctxAliases getState
clearAccountAliases :: GenParser tok JournalContext ()
clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
journal :: GenParser Char JournalContext (JournalUpdate,JournalContext)
journal = do
journalupdates <- many journalItem
eof
finalctx <- getState
return $ (combineJournalUpdates journalupdates, finalctx)
where
journalItem = choice [ directive
, liftM (return . addTransaction) transaction
, liftM (return . addModifierTransaction) modifiertransaction
, liftM (return . addPeriodicTransaction) periodictransaction
, liftM (return . addHistoricalPrice) historicalpricedirective
, emptyorcommentlinep >> return (return id)
] <?> "journal transaction or directive"
directive :: GenParser Char JournalContext JournalUpdate
directive = do
optional $ char '!'
choice' [
includedirective
,aliasdirective
,endaliasesdirective
,accountdirective
,enddirective
,tagdirective
,endtagdirective
,defaultyeardirective
,defaultcommoditydirective
,commodityconversiondirective
,ignoredpricecommoditydirective
]
<?> "directive"
includedirective :: GenParser Char JournalContext JournalUpdate
includedirective = do
string "include"
many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
let curdir = takeDirectory (sourceName outerPos)
return $ do filepath <- expandPath curdir filename
txt <- readFileOrError outerPos filepath
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
case runParser journal outerState filepath txt of
Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))
Left err -> throwError $ inIncluded ++ show err
where readFileOrError pos fp =
ErrorT $ liftM Right (readFile' fp) `C.catch`
\e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))
journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
accountdirective :: GenParser Char JournalContext JournalUpdate
accountdirective = do
string "account"
many1 spacenonewline
parent <- accountnamep
newline
pushParentAccount parent
return $ return id
enddirective :: GenParser Char JournalContext JournalUpdate
enddirective = do
string "end"
popParentAccount
return (return id)
aliasdirective :: GenParser Char JournalContext JournalUpdate
aliasdirective = do
string "alias"
many1 spacenonewline
orig <- many1 $ noneOf "="
char '='
alias <- restofline
addAccountAlias (accountNameWithoutPostingType $ strip orig
,accountNameWithoutPostingType $ strip alias)
return $ return id
endaliasesdirective :: GenParser Char JournalContext JournalUpdate
endaliasesdirective = do
string "end aliases"
clearAccountAliases
return (return id)
tagdirective :: GenParser Char JournalContext JournalUpdate
tagdirective = do
string "tag" <?> "tag directive"
many1 spacenonewline
_ <- many1 nonspace
restofline
return $ return id
endtagdirective :: GenParser Char JournalContext JournalUpdate
endtagdirective = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline
return $ return id
defaultyeardirective :: GenParser Char JournalContext JournalUpdate
defaultyeardirective = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
let y' = read y
failIfInvalidYear y
setYear y'
return $ return id
defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate
defaultcommoditydirective = do
char 'D' <?> "default commodity"
many1 spacenonewline
Amount{..} <- amountp
setCommodityAndStyle (acommodity, astyle)
restofline
return $ return id
historicalpricedirective :: GenParser Char JournalContext HistoricalPrice
historicalpricedirective = do
char 'P' <?> "historical price"
many spacenonewline
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> date
many1 spacenonewline
symbol <- commoditysymbol
many spacenonewline
price <- amountp
restofline
return $ HistoricalPrice date symbol price
ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate
ignoredpricecommoditydirective = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
commoditysymbol
restofline
return $ return id
commodityconversiondirective :: GenParser Char JournalContext JournalUpdate
commodityconversiondirective = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
amountp
many spacenonewline
char '='
many spacenonewline
amountp
restofline
return $ return id
modifiertransaction :: GenParser Char JournalContext ModifierTransaction
modifiertransaction = do
char '=' <?> "modifier transaction"
many spacenonewline
valueexpr <- restofline
postings <- postings
return $ ModifierTransaction valueexpr postings
periodictransaction :: GenParser Char JournalContext PeriodicTransaction
periodictransaction = do
char '~' <?> "periodic transaction"
many spacenonewline
periodexpr <- restofline
postings <- postings
return $ PeriodicTransaction periodexpr postings
transaction :: GenParser Char JournalContext Transaction
transaction = do
date <- date <?> "transaction"
edate <- optionMaybe (secondarydate date) <?> "secondary date"
status <- status <?> "cleared flag"
code <- codep <?> "transaction code"
description <- descriptionp >>= return . strip
comment <- try followingcommentp <|> (newline >> return "")
let tags = tagsInComment comment
postings <- postings
return $ txnTieKnot $ Transaction date edate status code description comment tags postings ""
descriptionp = many (noneOf ";\n")
#ifdef TESTS
test_transaction = do
let s `gives` t = do
let p = parseWithCtx nullctx transaction s
assertBool $ isRight p
let Right t2 = p
assertEqual (tdate t) (tdate t2)
assertEqual (tdate2 t) (tdate2 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)
unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
" ; ttag1: val1",
" * a $1.00 ; pcomment1",
" ; pcomment2",
" ; ptag1: val1",
" ; ptag2: val2"
]
`gives`
nulltransaction{
tdate=parsedate "2012/05/14",
tdate2=Just $ parsedate "2012/05/15",
tstatus=False,
tcode="code",
tdescription="desc",
tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pstatus=True,
paccount="a",
pamount=Mixed [usd 1],
pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")],
ptransaction=Nothing
}
],
tpreceding_comment_lines=""
}
assertRight $ parseWithCtx nullctx transaction $ unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
assertLeft $ parseWithCtx nullctx transaction "2009/1/1\n"
assertLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n"
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')
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
date :: GenParser Char JournalContext Day
date = do
datestr <- many1 $ choice' [digit, datesepchar]
let dateparts = wordsBy (`elem` datesepchars) datestr
currentyear <- getYear
[y,m,d] <- case (dateparts,currentyear) of
([m,d],Just y) -> return [show y,m,d]
([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
([y,m,d],_) -> return [y,m,d]
_ -> fail $ "bad date: " ++ datestr
let maybedate = fromGregorianValid (read y) (read m) (read d)
case maybedate of
Nothing -> fail $ "bad date: " ++ datestr
Just date -> return date
<?> "full or partial date"
datetimep :: GenParser Char JournalContext LocalTime
datetimep = do
day <- date
many1 spacenonewline
h <- many1 digit
let h' = read h
guard $ h' >= 0 && h' <= 23
char ':'
m <- many1 digit
let m' = read m
guard $ m' >= 0 && m' <= 59
s <- optionMaybe $ char ':' >> many1 digit
let s' = case s of Just sstr -> read sstr
Nothing -> 0
guard $ s' >= 0 && s' <= 59
optionMaybe $ do
plusminus <- oneOf "-+"
d1 <- digit
d2 <- digit
d3 <- digit
d4 <- digit
return $ plusminus:d1:d2:d3:d4:""
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydate :: Day -> GenParser Char JournalContext Day
secondarydate primarydate = do
char '='
let withDefaultYear d p = do
y <- getYear
let (y',_,_) = toGregorian d in setYear y'
r <- p
when (isJust y) $ setYear $ fromJust y
return r
edate <- withDefaultYear primarydate date
return edate
status :: GenParser Char JournalContext Bool
status = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False
codep :: GenParser Char JournalContext String
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
postings :: GenParser Char JournalContext [Posting]
postings = many1 (try postingp) <?> "postings"
postingp :: GenParser Char JournalContext Posting
postingp = do
many1 spacenonewline
status <- status
many spacenonewline
account <- modifiedaccountname
let (ptype, account') = (accountNamePostingType account, unbracket account)
amount <- spaceandamountormissing
massertion <- balanceassertion
_ <- fixedlotprice
many spacenonewline
ctx <- getState
comment <- try followingcommentp <|> (newline >> return "")
let tags = tagsInComment comment
d <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` dateValueFromTags tags)
d2 <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` date2ValueFromTags tags)
return posting{pdate=d, pdate2=d2, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags, pbalanceassertion=massertion}
#ifdef TESTS
test_postingp = do
let s `gives` ep = do
let parse = parseWithCtx nullctx postingp s
assertBool
$ isRight parse
let Right ap = parse
same f = assertEqual (f ep) (f ap)
same pdate
same pstatus
same paccount
same pamount
same pcomment
same ptype
same ptags
same ptransaction
" 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")]}
" 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"}
" 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
(isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\"\n")
assertBool (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
#endif
modifiedaccountname :: GenParser Char JournalContext AccountName
modifiedaccountname = do
a <- accountnamep
prefix <- getParentAccount
let prefixed = prefix `joinAccountNames` a
aliases <- getAccountAliases
return $ accountNameApplyAliases aliases prefixed
accountnamep :: GenParser Char st AccountName
accountnamep = do
a <- many1 (nonspace <|> singlespace)
let a' = striptrailingspace a
when (accountNameFromComponents (accountNameComponents a') /= a')
(fail $ "account name seems ill-formed: "++a')
return a'
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
striptrailingspace s = if last s == ' ' then init s else s
spaceandamountormissing :: GenParser Char JournalContext MixedAmount
spaceandamountormissing =
try (do
many1 spacenonewline
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
) <|> return 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
amountp :: GenParser Char JournalContext Amount
amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
#ifdef TESTS
test_amountp = do
assertParseEqual' (parseWithCtx nullctx amountp "$47.18") (usd 47.18)
assertParseEqual' (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0)
assertParseEqual'
(parseWithCtx nullctx amountp "$10 @ €0.5")
(usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
assertParseEqual'
(parseWithCtx nullctx amountp "$10 @@ €5")
(usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
#endif
amountp' :: String -> Amount
amountp' s = either (error' . show) id $ parseWithCtx nullctx amountp s
mamountp' :: String -> MixedAmount
mamountp' = mixed . amountp'
signp :: GenParser Char JournalContext String
signp = do
sign <- optionMaybe $ oneOf "+-"
return $ case sign of Just '-' -> "-"
_ -> ""
leftsymbolamount :: GenParser Char JournalContext Amount
leftsymbolamount = do
sign <- signp
c <- commoditysymbol
sp <- many spacenonewline
(q,prec,dec,sep,seppos) <- numberp
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
p <- priceamount
let applysign = if sign=="-" then negate else id
return $ applysign $ Amount c q p s
<?> "left-symbol amount"
rightsymbolamount :: GenParser Char JournalContext Amount
rightsymbolamount = do
(q,prec,dec,sep,seppos) <- numberp
sp <- many spacenonewline
c <- commoditysymbol
p <- priceamount
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
return $ Amount c q p s
<?> "right-symbol amount"
nosymbolamount :: GenParser Char JournalContext Amount
nosymbolamount = do
(q,prec,dec,sep,seppos) <- numberp
p <- priceamount
defcs <- getCommodityAndStyle
let (c,s) = case defcs of
Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})
Nothing -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos})
return $ Amount c q p s
<?> "no-symbol amount"
commoditysymbol :: GenParser Char JournalContext String
commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"
quotedcommoditysymbol :: GenParser Char JournalContext String
quotedcommoditysymbol = do
char '"'
s <- many1 $ noneOf ";\n\""
char '"'
return s
simplecommoditysymbol :: GenParser Char JournalContext String
simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)
priceamount :: GenParser Char JournalContext Price
priceamount =
try (do
many spacenonewline
char '@'
try (do
char '@'
many spacenonewline
a <- amountp
return $ TotalPrice a)
<|> (do
many spacenonewline
a <- amountp
return $ UnitPrice a))
<|> return NoPrice
balanceassertion :: GenParser Char JournalContext (Maybe MixedAmount)
balanceassertion =
try (do
many spacenonewline
char '='
many spacenonewline
a <- amountp
return $ Just $ Mixed [a])
<|> return Nothing
fixedlotprice :: GenParser Char JournalContext (Maybe Amount)
fixedlotprice =
try (do
many spacenonewline
char '{'
many spacenonewline
char '='
many spacenonewline
a <- amountp
many spacenonewline
char '}'
return $ Just a)
<|> return Nothing
numberp :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])
numberp = do
sign <- signp
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
let numeric = isNumber . headDef '_'
(numparts, puncparts) = partition numeric parts
(ok,decimalpoint',separator') =
case (numparts,puncparts) of
([],_) -> (False, Nothing, Nothing)
(_,[]) -> (True, Nothing, Nothing)
(_,[d:""]) -> (True, Just d, Nothing)
(_,[_]) -> (False, Nothing, Nothing)
(_,_:_:_) -> let (s:ss, d) = (init puncparts, last puncparts)
in if (any ((/=1).length) puncparts
|| any (s/=) ss
|| head parts == s)
then (False, Nothing, Nothing)
else if s == d
then (True, Nothing, Just $ head s)
else (True, Just $ head d, Just $ head s)
when (not ok) (fail $ "number seems ill-formed: "++concat parts)
let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts
(intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')
separatorpositions = reverse $ map length $ drop 1 intparts
int = concat $ "":intparts
frac = concat $ "":fracpart
precision = length frac
int' = if null int then "0" else int
frac' = if null frac then "0" else frac
quantity = read $ sign++int'++"."++frac'
(decimalpoint, separator) = case (decimalpoint', separator') of (Just d, Just s) -> (d,s)
(Just '.',Nothing) -> ('.',',')
(Just ',',Nothing) -> (',','.')
(Nothing, Just '.') -> (',','.')
(Nothing, Just ',') -> ('.',',')
_ -> ('.',',')
return (quantity,precision,decimalpoint,separator,separatorpositions)
<?> "numberp"
#ifdef TESTS
test_numberp = do
let s `is` n = assertParseEqual' (parseWithCtx nullctx numberp s) n
assertFails = assertBool . isLeft . parseWithCtx nullctx numberp
assertFails ""
"0" `is` (0, 0, '.', ',', [])
"1" `is` (1, 0, '.', ',', [])
"1.1" `is` (1.1, 1, '.', ',', [])
"1,000.1" `is` (1000.1, 1, '.', ',', [3])
"1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2])
"1,000,000" `is` (1000000, 0, '.', ',', [3,3])
"1." `is` (1, 0, '.', ',', [])
"1," `is` (1, 0, ',', '.', [])
".1" `is` (0.1, 1, '.', ',', [])
",1" `is` (0.1, 1, ',', '.', [])
assertFails "1,000.000,1"
assertFails "1.000,000.1"
assertFails "1,000.000.1"
assertFails "1,,1"
assertFails "1..1"
assertFails ".1,"
assertFails ",1."
#endif
emptyorcommentlinep :: GenParser Char JournalContext ()
emptyorcommentlinep = do
many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return ""))
return ()
followingcommentp :: GenParser Char JournalContext String
followingcommentp =
do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
return $ unlines $ samelinecomment:newlinecomments
comment :: GenParser Char JournalContext String
comment = commentStartingWith "#;"
semicoloncomment :: GenParser Char JournalContext String
semicoloncomment = commentStartingWith ";"
commentStartingWith :: String -> GenParser Char JournalContext String
commentStartingWith cs = do
oneOf cs
many spacenonewline
l <- anyChar `manyTill` eolof
optional newline
return l
tagsInComment :: String -> [Tag]
tagsInComment c = concatMap tagsInCommentLine $ lines c'
where
c' = ledgerDateSyntaxToTags c
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
tag = do
n <- tagname
v <- tagvalue
return (n,v)
tagname = do
n <- many1 $ noneOf ": \t"
char ':'
return n
tagvalue = do
v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
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
dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String
dateValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts
date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts