module Hledger.Read.JournalReader (
reader,
parseAndFinaliseJournal,
genericSourcePos,
getParentAccount,
journalp,
directivep,
defaultyeardirectivep,
marketpricedirectivep,
datetimep,
codep,
accountnamep,
modifiedaccountnamep,
postingp,
amountp,
amountp',
mamountp',
numberp,
statusp,
emptyorcommentlinep,
followingcommentp,
accountaliasp
,tests_Hledger_Read_JournalReader
#ifdef TESTS
,htf_thisModulesTests
,htf_Hledger_Read_JournalReader_importedTests
#endif
)
where
import Prelude ()
import Prelude.Compat hiding (readFile)
import qualified Control.Exception as C
import Control.Monad.Compat
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError, catchError)
import Data.Char (isNumber)
import Data.List.Compat
import Data.List.Split (wordsBy)
import Data.Maybe
import Data.Time.Calendar
import Data.Time.LocalTime
import Safe (headDef, lastDef)
import Test.HUnit
#ifdef TESTS
import Test.Framework
import Text.Parsec.Error
#endif
import Text.Parsec hiding (parse)
import Text.Printf
import System.FilePath
import System.Time (getClockTime)
import Hledger.Data
import Hledger.Utils
reader :: Reader
reader = Reader format detect parse
format :: String
format = "journal"
detect :: FilePath -> String -> Bool
detect f s
| f /= "-" = takeExtension f `elem` ['.':format, ".j"]
| otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal journalp
genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p)
combineJournalUpdates :: [JournalUpdate] -> JournalUpdate
combineJournalUpdates us = foldl' (flip (.)) id <$> sequence us
parseAndFinaliseJournal ::
(ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext))
-> Bool -> FilePath -> String -> ExceptT String IO Journal
parseAndFinaliseJournal parser assrt f s = do
tc <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime
y <- liftIO getCurrentYear
r <- runParserT parser nullctx{ctxYear=Just y} f s
case r of
Right (updates,ctx) -> do
j <- ap updates (return nulljournal)
case journalFinalise tc tl f s ctx assrt j of
Right j' -> return j'
Left estr -> throwError estr
Left e -> throwError $ show e
setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()
setYear y = modifyState (\ctx -> ctx{ctxYear=Just y})
getYear :: Stream [Char] m Char => ParsecT s JournalContext m (Maybe Integer)
getYear = liftM ctxYear getState
setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m ()
setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs})
getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe (Commodity,AmountStyle))
getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState
pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m ()
pushParentAccount parent = modifyState addParentAccount
where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
popParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
popParentAccount = do ctx0 <- getState
case ctxAccount ctx0 of
[] -> unexpected "End of account block with no beginning"
(_:rest) -> setState $ ctx0 { ctxAccount = rest }
getParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m ()
addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
getAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m [AccountAlias]
getAccountAliases = liftM ctxAliases getState
clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
getIndex :: Stream [Char] m Char => ParsecT s JournalContext m Integer
getIndex = liftM ctxTransactionIndex getState
setIndex :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()
setIndex i = modifyState (\ctx -> ctx{ctxTransactionIndex=i})
journalp :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)
journalp = do
journalupdates <- many journalItem
eof
finalctx <- getState
return $ (combineJournalUpdates journalupdates, finalctx)
where
journalItem = choice [ directivep
, liftM (return . addTransaction) transactionp
, liftM (return . addModifierTransaction) modifiertransactionp
, liftM (return . addPeriodicTransaction) periodictransactionp
, liftM (return . addMarketPrice) marketpricedirectivep
, emptyorcommentlinep >> return (return id)
, multilinecommentp >> return (return id)
] <?> "journal transaction or directive"
directivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
directivep = do
optional $ char '!'
choice' [
includedirectivep
,aliasdirectivep
,endaliasesdirectivep
,accountdirectivep
,enddirectivep
,tagdirectivep
,endtagdirectivep
,defaultyeardirectivep
,defaultcommoditydirectivep
,commodityconversiondirectivep
,ignoredpricecommoditydirectivep
]
<?> "directive"
includedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
includedirectivep = do
string "include"
many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
let curdir = takeDirectory (sourceName outerPos)
let (u::ExceptT String IO (Journal -> Journal, JournalContext)) = do
filepath <- expandPath curdir filename
txt <- readFileOrError outerPos filepath
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
r <- runParserT journalp outerState filepath txt
case r of
Right (ju, ctx) -> do
u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)
, ju
] `catchError` (throwError . (inIncluded ++))
return (u, ctx)
Left err -> throwError $ inIncluded ++ show err
where readFileOrError pos fp =
ExceptT $ liftM Right (readFile' fp) `C.catch`
\e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))
r <- liftIO $ runExceptT u
case r of
Left err -> return $ throwError err
Right (ju, _finalparsectx) -> return $ ExceptT $ return $ Right ju
journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
accountdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
accountdirectivep = do
string "account"
many1 spacenonewline
parent <- accountnamep
newline
pushParentAccount parent
return $ ExceptT $ return $ Right id
enddirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
enddirectivep = do
string "end"
popParentAccount
return $ ExceptT $ return $ Right id
aliasdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
aliasdirectivep = do
string "alias"
many1 spacenonewline
alias <- accountaliasp
addAccountAlias alias
return $ return id
accountaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias
basicaliasp = do
old <- rstrip <$> (many1 $ noneOf "=")
char '='
many spacenonewline
new <- rstrip <$> anyChar `manyTill` eolof
return $ BasicAlias old new
regexaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias
regexaliasp = do
char '/'
re <- many1 $ noneOf "/\n\r"
char '/'
many spacenonewline
char '='
many spacenonewline
repl <- rstrip <$> anyChar `manyTill` eolof
return $ RegexAlias re repl
endaliasesdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
endaliasesdirectivep = do
string "end aliases"
clearAccountAliases
return (return id)
tagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
tagdirectivep = do
string "tag" <?> "tag directive"
many1 spacenonewline
_ <- many1 nonspace
restofline
return $ return id
endtagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline
return $ return id
defaultyeardirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
defaultyeardirectivep = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
let y' = read y
failIfInvalidYear y
setYear y'
return $ return id
defaultcommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
defaultcommoditydirectivep = do
char 'D' <?> "default commodity"
many1 spacenonewline
Amount{..} <- amountp
setDefaultCommodityAndStyle (acommodity, astyle)
restofline
return $ return id
marketpricedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) MarketPrice
marketpricedirectivep = do
char 'P' <?> "market price"
many spacenonewline
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep
many1 spacenonewline
symbol <- commoditysymbolp
many spacenonewline
price <- amountp
restofline
return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
commoditysymbolp
restofline
return $ return id
commodityconversiondirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
commodityconversiondirectivep = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
amountp
many spacenonewline
char '='
many spacenonewline
amountp
restofline
return $ return id
modifiertransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction
modifiertransactionp = do
char '=' <?> "modifier transaction"
many spacenonewline
valueexpr <- restofline
postings <- postingsp
return $ ModifierTransaction valueexpr postings
periodictransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction
periodictransactionp = do
char '~' <?> "periodic transaction"
many spacenonewline
periodexpr <- restofline
postings <- postingsp
return $ PeriodicTransaction periodexpr postings
transactionp :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction
transactionp = do
sourcepos <- genericSourcePos <$> getPosition
date <- datep <?> "transaction"
edate <- optionMaybe (secondarydatep date) <?> "secondary date"
lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
status <- statusp <?> "cleared status"
code <- codep <?> "transaction code"
description <- descriptionp >>= return . strip
comment <- try followingcommentp <|> (newline >> return "")
let tags = tagsInComment comment
postings <- postingsp
i' <- (+1) <$> getIndex
setIndex i'
return $ txnTieKnot $ Transaction i' sourcepos date edate status code description comment tags postings ""
descriptionp = many (noneOf ";\n")
#ifdef TESTS
test_transactionp = do
let s `gives` t = do
let p = parseWithCtx nullctx transactionp 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=Uncleared,
tcode="code",
tdescription="desc",
tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pstatus=Cleared,
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=""
}
unlines [
"2015/1/1",
]
`gives`
nulltransaction{
tdate=parsedate "2015/01/01",
}
assertRight $ parseWithCtx nullctx transactionp $ unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
assertLeft $ parseWithCtx nullctx transactionp "2009/1/1\n"
assertLeft $ parseWithCtx nullctx transactionp "2009/1/1 a\n"
let p = parseWithCtx nullctx transactionp "2009/1/1 a ;comment\n b 1\n"
assertRight p
assertEqual "a" (let Right p' = p in tdescription p')
assertRight $ parseWithCtx nullctx transactionp $ unlines
["2012/1/1"
," a 1"
," b"
," "
]
let p = parseWithCtx nullctx transactionp $ 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
datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day
datep = do
datestr <- do
c <- digit
cs <- many $ choice' [digit, datesepchar]
return $ c:cs
let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
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 :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime
datetimep = do
day <- datep
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')
secondarydatep :: Stream [Char] m Char => Day -> ParsecT [Char] JournalContext m Day
secondarydatep 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 datep
return edate
statusp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ClearedStatus
statusp =
choice'
[ many spacenonewline >> char '*' >> return Cleared
, many spacenonewline >> char '!' >> return Pending
, return Uncleared
]
<?> "cleared status"
codep :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
postingsp :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting]
postingsp = many (try postingp) <?> "postings"
postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting
postingp = do
many1 spacenonewline
status <- statusp
many spacenonewline
account <- modifiedaccountnamep
let (ptype, account') = (accountNamePostingType account, unbracket account)
amount <- spaceandamountormissingp
massertion <- partialbalanceassertionp
_ <- fixedlotpricep
many spacenonewline
ctx <- getState
comment <- try followingcommentp <|> (newline >> return "")
let tags = tagsInComment comment
date <- case dateValueFromTags tags of
Nothing -> return Nothing
Just v -> case runParser (datep <* eof) ctx "" v of
Right d -> return $ Just d
Left err -> parserFail $ show err
date2 <- case date2ValueFromTags tags of
Nothing -> return Nothing
Just v -> case runParser (datep <* eof) ctx "" v of
Right d -> return $ Just d
Left err -> parserFail $ show err
return posting
{ pdate=date
, pdate2=date2
, 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
modifiedaccountnamep :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName
modifiedaccountnamep = do
parent <- getParentAccount
aliases <- getAccountAliases
a <- accountnamep
return $
accountNameApplyAliases aliases $
joinAccountNames parent
a
accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName
accountnamep = do
a <- do
c <- nonspace
cs <- striptrailingspace <$> many (nonspace <|> singlespace)
return $ c:cs
when (accountNameFromComponents (accountNameComponents a) /= a)
(fail $ "account name seems ill-formed: "++a)
return a
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
striptrailingspace "" = ""
striptrailingspace s = if last s == ' ' then init s else s
spaceandamountormissingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount
spaceandamountormissingp =
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_spaceandamountormissingp = do
assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp " $47.18") (Mixed [usd 47.18])
assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp "$47.18") missingmixedamt
assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp " ") missingmixedamt
assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp "") missingmixedamt
#endif
amountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
#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 =
case runParser (amountp <* eof) nullctx "" s of
Right t -> t
Left err -> error' $ show err
mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp'
signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String
signp = do
sign <- optionMaybe $ oneOf "+-"
return $ case sign of Just '-' -> "-"
_ -> ""
leftsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
leftsymbolamountp = do
sign <- signp
c <- commoditysymbolp
sp <- many spacenonewline
(q,prec,mdec,mgrps) <- numberp
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
p <- priceamountp
let applysign = if sign=="-" then negate else id
return $ applysign $ Amount c q p s
<?> "left-symbol amount"
rightsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
rightsymbolamountp = do
(q,prec,mdec,mgrps) <- numberp
sp <- many spacenonewline
c <- commoditysymbolp
p <- priceamountp
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return $ Amount c q p s
<?> "right-symbol amount"
nosymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
nosymbolamountp = do
(q,prec,mdec,mgrps) <- numberp
p <- priceamountp
defcs <- getDefaultCommodityAndStyle
let (c,s) = case defcs of
Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})
Nothing -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})
return $ Amount c q p s
<?> "no-symbol amount"
commoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
quotedcommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String
quotedcommoditysymbolp = do
char '"'
s <- many1 $ noneOf ";\n\""
char '"'
return s
simplecommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String
simplecommoditysymbolp = many1 (noneOf nonsimplecommoditychars)
priceamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Price
priceamountp =
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
partialbalanceassertionp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)
partialbalanceassertionp =
try (do
many spacenonewline
char '='
many spacenonewline
a <- amountp
return $ Just $ Mixed [a])
<|> return Nothing
fixedlotpricep :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount)
fixedlotpricep =
try (do
many spacenonewline
char '{'
many spacenonewline
char '='
many spacenonewline
a <- amountp
many spacenonewline
char '}'
return $ Just a)
<|> return Nothing
numberp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
numberp = do
sign <- signp
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
dbg8 "numberp parsed" (sign,parts) `seq` return ()
let (numparts, puncparts) = partition numeric parts
(ok, mdecimalpoint, mseparator) =
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 ((/= mdecimalpoint) . Just . head) parts
(intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')
groupsizes = reverse $ case map length intparts of
(a:b:cs) | a < b -> b:cs
gs -> gs
mgrps = maybe Nothing (Just . (`DigitGroups` groupsizes)) $ mseparator
let 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'
return $ dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps)
<?> "numberp"
where
numeric = isNumber . headDef '_'
multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
multilinecommentp = do
string "comment" >> many spacenonewline >> newline
go
where
go = try (eof <|> (string "end comment" >> newline >> return ()))
<|> (anyLine >> go)
anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
emptyorcommentlinep = do
many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return ""))
return ()
followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
followingcommentp =
do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return ""))
newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp))
return $ unlines $ samelinecomment:newlinecomments
commentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
commentp = commentStartingWithp commentchars
commentchars :: [Char]
commentchars = "#;*"
semicoloncommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
semicoloncommentp = commentStartingWithp ";"
commentStartingWithp :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String
commentStartingWithp 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 runParser (tagp <* eof) nullctx "" s of
Right t -> Just t
Left _ -> Nothing
tagp = do
n <- tagnamep
v <- tagvaluep
return (n,v)
tagnamep = do
n <- many1 $ noneOf ": \t"
char ':'
return n
tagvaluep = 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
tests_Hledger_Read_JournalReader = TestList $ concat [
]