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

lib: move from Text.ParserCombinators.Parsec to Text.Parsec

Browse Source 
NOTE: required to use liftIO in includedirective
SEE: http://www.vex.net/~trebla/haskell/parsec-generally.xhtml#IO
This commit is contained in:
Julien Moutinho 2014-11-03 06:52:12 +01:00
parent 21a200cccc
commit cf28985cf2
16 changed files with 244 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/hledger-rewrite.hs
View File

@ -23,7 +23,7 @@ Tested-with: hledger HEAD ~ 2014/2/4
import Hledger.Cli import Hledger.Cli
-- more utils for parsing -- more utils for parsing
import Control.Applicative hiding (many) import Control.Applicative hiding (many)
import Text.ParserCombinators.Parsec import Text.Parsec
cmdmode :: Mode RawOpts cmdmode :: Mode RawOpts
@ -46,7 +46,7 @@ type PostingExpr = (AccountName, AmountExpr)
data AmountExpr = AmountLiteral String | AmountMultiplier Quantity deriving (Show) data AmountExpr = AmountLiteral String | AmountMultiplier Quantity deriving (Show)
addPostingExprsFromOpts :: RawOpts -> [PostingExpr] addPostingExprsFromOpts :: RawOpts -> [PostingExpr]
addPostingExprsFromOpts = map (either parseerror id . parseWithCtx nullctx postingexprp) . map stripquotes . listofstringopt "add-posting" addPostingExprsFromOpts = map (either parseerror id . runParser postingexprp nullctx "") . map stripquotes . listofstringopt "add-posting"
postingexprp = do postingexprp = do
a <- accountnamep a <- accountnamep
@ -67,7 +67,7 @@ amountexprp =
amountExprRenderer :: Query -> AmountExpr -> (Transaction -> MixedAmount) amountExprRenderer :: Query -> AmountExpr -> (Transaction -> MixedAmount)
amountExprRenderer q aex = amountExprRenderer q aex =
case aex of case aex of
AmountLiteral s -> either parseerror (const . mixed) $ parseWithCtx nullctx amountp s AmountLiteral s -> either parseerror (const . mixed) $ runParser amountp nullctx "" s
AmountMultiplier n -> (`divideMixedAmount` (1 / n)) . (`firstAmountMatching` q) AmountMultiplier n -> (`divideMixedAmount` (1 / n)) . (`firstAmountMatching` q)
where where
firstAmountMatching :: Transaction -> Query -> MixedAmount firstAmountMatching :: Transaction -> Query -> MixedAmount

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

@ -1,4 +1,5 @@
{-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-| {-|
Date parsing and utilities for hledger. Date parsing and utilities for hledger.
@ -75,7 +76,7 @@ import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay) import Safe (headMay, lastMay, readMay)
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec import Text.Parsec
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
@ -438,14 +439,14 @@ and maybe some others:
Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Returns a SmartDate, to be converted to a full date later (see fixSmartDate).
Assumes any text in the parse stream has been lowercased. Assumes any text in the parse stream has been lowercased.
-} -}
smartdate :: GenParser Char st SmartDate smartdate :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
smartdate = do smartdate = do
-- XXX maybe obscures date errors ? see ledgerdate -- XXX maybe obscures date errors ? see ledgerdate
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
return (y,m,d) return (y,m,d)
-- | Like smartdate, but there must be nothing other than whitespace after the date. -- | Like smartdate, but there must be nothing other than whitespace after the date.
smartdateonly :: GenParser Char st SmartDate smartdateonly :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
smartdateonly = do smartdateonly = do
d <- smartdate d <- smartdate
many spacenonewline many spacenonewline
@ -453,6 +454,7 @@ smartdateonly = do
return d return d
datesepchars = "/-." datesepchars = "/-."
datesepchar :: Stream [Char] m Char => ParsecT [Char] st m Char
datesepchar = oneOf datesepchars datesepchar = oneOf datesepchars
validYear, validMonth, validDay :: String -> Bool validYear, validMonth, validDay :: String -> Bool
@ -465,7 +467,7 @@ failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s
failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s
failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s
yyyymmdd :: GenParser Char st SmartDate yyyymmdd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
yyyymmdd = do yyyymmdd = do
y <- count 4 digit y <- count 4 digit
m <- count 2 digit m <- count 2 digit
@ -474,7 +476,7 @@ yyyymmdd = do
failIfInvalidDay d failIfInvalidDay d
return (y,m,d) return (y,m,d)
ymd :: GenParser Char st SmartDate ymd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
ymd = do ymd = do
y <- many1 digit y <- many1 digit
failIfInvalidYear y failIfInvalidYear y
@ -486,7 +488,7 @@ ymd = do
failIfInvalidDay d failIfInvalidDay d
return $ (y,m,d) return $ (y,m,d)
ym :: GenParser Char st SmartDate ym :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
ym = do ym = do
y <- many1 digit y <- many1 digit
failIfInvalidYear y failIfInvalidYear y
@ -495,19 +497,19 @@ ym = do
failIfInvalidMonth m failIfInvalidMonth m
return (y,m,"") return (y,m,"")
y :: GenParser Char st SmartDate y :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
y = do y = do
y <- many1 digit y <- many1 digit
failIfInvalidYear y failIfInvalidYear y
return (y,"","") return (y,"","")
d :: GenParser Char st SmartDate d :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
d = do d = do
d <- many1 digit d <- many1 digit
failIfInvalidDay d failIfInvalidDay d
return ("","",d) return ("","",d)
md :: GenParser Char st SmartDate md :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
md = do md = do
m <- many1 digit m <- many1 digit
failIfInvalidMonth m failIfInvalidMonth m
@ -525,24 +527,24 @@ monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","n
monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
month :: GenParser Char st SmartDate month :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
month = do month = do
m <- choice $ map (try . string) months m <- choice $ map (try . string) months
let i = monthIndex m let i = monthIndex m
return ("",show i,"") return ("",show i,"")
mon :: GenParser Char st SmartDate mon :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
mon = do mon = do
m <- choice $ map (try . string) monthabbrevs m <- choice $ map (try . string) monthabbrevs
let i = monIndex m let i = monIndex m
return ("",show i,"") return ("",show i,"")
today,yesterday,tomorrow :: GenParser Char st SmartDate today,yesterday,tomorrow :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
today = string "today" >> return ("","","today") today = string "today" >> return ("","","today")
yesterday = string "yesterday" >> return ("","","yesterday") yesterday = string "yesterday" >> return ("","","yesterday")
tomorrow = string "tomorrow" >> return ("","","tomorrow") tomorrow = string "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: GenParser Char st SmartDate lastthisnextthing :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
lastthisnextthing = do lastthisnextthing = do
r <- choice [ r <- choice [
string "last" string "last"
@ -562,7 +564,7 @@ lastthisnextthing = do
return ("",r,p) return ("",r,p)
periodexpr :: Day -> GenParser Char st (Interval, DateSpan) periodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan)
periodexpr rdate = choice $ map try [ periodexpr rdate = choice $ map try [
intervalanddateperiodexpr rdate, intervalanddateperiodexpr rdate,
intervalperiodexpr, intervalperiodexpr,
@ -570,7 +572,7 @@ periodexpr rdate = choice $ map try [
(return (NoInterval,DateSpan Nothing Nothing)) (return (NoInterval,DateSpan Nothing Nothing))
] ]
intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) intervalanddateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan)
intervalanddateperiodexpr rdate = do intervalanddateperiodexpr rdate = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
@ -578,20 +580,20 @@ intervalanddateperiodexpr rdate = do
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (i,s) return (i,s)
intervalperiodexpr :: GenParser Char st (Interval, DateSpan) intervalperiodexpr :: Stream [Char] m Char => ParsecT [Char] st m (Interval, DateSpan)
intervalperiodexpr = do intervalperiodexpr = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
return (i, DateSpan Nothing Nothing) return (i, DateSpan Nothing Nothing)
dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) dateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan)
dateperiodexpr rdate = do dateperiodexpr rdate = do
many spacenonewline many spacenonewline
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (NoInterval, s) return (NoInterval, s)
-- Parse a reporting interval. -- Parse a reporting interval.
reportinginterval :: GenParser Char st Interval reportinginterval :: Stream [Char] m Char => ParsecT [Char] st m Interval
reportinginterval = choice' [ reportinginterval = choice' [
tryinterval "day" "daily" Days, tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks, tryinterval "week" "weekly" Weeks,
@ -631,7 +633,7 @@ reportinginterval = choice' [
thsuffix = choice' $ map string ["st","nd","rd","th"] thsuffix = choice' $ map string ["st","nd","rd","th"]
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval tryinterval :: Stream [Char] m Char => String -> String -> (Int -> Interval) -> ParsecT [Char] st m Interval
tryinterval singular compact intcons = tryinterval singular compact intcons =
choice' [ choice' [
do string compact do string compact
@ -649,7 +651,7 @@ reportinginterval = choice' [
] ]
where plural = singular ++ "s" where plural = singular ++ "s"
periodexprdatespan :: Day -> GenParser Char st DateSpan periodexprdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan
periodexprdatespan rdate = choice $ map try [ periodexprdatespan rdate = choice $ map try [
doubledatespan rdate, doubledatespan rdate,
fromdatespan rdate, fromdatespan rdate,
@ -657,7 +659,7 @@ periodexprdatespan rdate = choice $ map try [
justdatespan rdate justdatespan rdate
] ]
doubledatespan :: Day -> GenParser Char st DateSpan doubledatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan
doubledatespan rdate = do doubledatespan rdate = do
optional (string "from" >> many spacenonewline) optional (string "from" >> many spacenonewline)
b <- smartdate b <- smartdate
@ -666,7 +668,7 @@ doubledatespan rdate = do
e <- smartdate e <- smartdate
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
fromdatespan :: Day -> GenParser Char st DateSpan fromdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan
fromdatespan rdate = do fromdatespan rdate = do
b <- choice [ b <- choice [
do do
@ -680,13 +682,13 @@ fromdatespan rdate = do
] ]
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
todatespan :: Day -> GenParser Char st DateSpan todatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan
todatespan rdate = do todatespan rdate = do
choice [string "to", string "-"] >> many spacenonewline choice [string "to", string "-"] >> many spacenonewline
e <- smartdate e <- smartdate
return $ DateSpan Nothing (Just $ fixSmartDate rdate e) return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
justdatespan :: Day -> GenParser Char st DateSpan justdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan
justdatespan rdate = do justdatespan rdate = do
optional (string "in" >> many spacenonewline) optional (string "in" >> many spacenonewline)
d <- smartdate d <- smartdate

13
hledger-lib/Hledger/Data/OutputFormat.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
module Hledger.Data.OutputFormat ( module Hledger.Data.OutputFormat (
parseStringFormat parseStringFormat
, formatsp , formatsp
@ -11,7 +12,7 @@ import Numeric
import Data.Char (isPrint) import Data.Char (isPrint)
import Data.Maybe import Data.Maybe
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec import Text.Parsec
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
@ -34,7 +35,7 @@ parseStringFormat input = case (runParser formatsp () "(unknown)") input of
Parsers Parsers
-} -}
field :: GenParser Char st HledgerFormatField field :: Stream [Char] m Char => ParsecT [Char] st m HledgerFormatField
field = do field = do
try (string "account" >> return AccountField) try (string "account" >> return AccountField)
<|> try (string "depth_spacer" >> return DepthSpacerField) <|> try (string "depth_spacer" >> return DepthSpacerField)
@ -43,7 +44,7 @@ field = do
<|> try (string "total" >> return TotalField) <|> try (string "total" >> return TotalField)
<|> try (many1 digit >>= (\s -> return $ FieldNo $ read s)) <|> try (many1 digit >>= (\s -> return $ FieldNo $ read s))
formatField :: GenParser Char st OutputFormat formatField :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat
formatField = do formatField = do
char '%' char '%'
leftJustified <- optionMaybe (char '-') leftJustified <- optionMaybe (char '-')
@ -58,7 +59,7 @@ formatField = do
Just text -> Just m where ((m,_):_) = readDec text Just text -> Just m where ((m,_):_) = readDec text
_ -> Nothing _ -> Nothing
formatLiteral :: GenParser Char st OutputFormat formatLiteral :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat
formatLiteral = do formatLiteral = do
s <- many1 c s <- many1 c
return $ FormatLiteral s return $ FormatLiteral s
@ -67,12 +68,12 @@ formatLiteral = do
c = (satisfy isPrintableButNotPercentage <?> "printable character") c = (satisfy isPrintableButNotPercentage <?> "printable character")
<|> try (string "%%" >> return '%') <|> try (string "%%" >> return '%')
formatp :: GenParser Char st OutputFormat formatp :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat
formatp = formatp =
formatField formatField
<|> formatLiteral <|> formatLiteral
formatsp :: GenParser Char st [OutputFormat] formatsp :: Stream [Char] m Char => ParsecT [Char] st m [OutputFormat]
formatsp = many formatp formatsp = many formatp
testFormat :: OutputFormat -> String -> String -> Assertion testFormat :: OutputFormat -> String -> String -> Assertion

3
hledger-lib/Hledger/Query.hs
View File

@ -46,7 +46,8 @@ import Data.Maybe
import Data.Time.Calendar import Data.Time.Calendar
import Safe (readDef, headDef, headMay) import Safe (readDef, headDef, headMay)
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec -- import Text.ParserCombinators.Parsec
import Text.Parsec hiding (Empty)
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types

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

@ -235,7 +235,8 @@ tests_Hledger_Read = TestList $
tests_Hledger_Read_CsvReader, tests_Hledger_Read_CsvReader,
"journal" ~: do "journal" ~: do
assertBool "journal should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journal "") r <- runErrorT $ parseWithCtx nullctx JournalReader.journal ""
assertBool "journal should parse an empty file" (isRight $ r)
jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal
either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE

72
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -3,6 +3,8 @@
A reader for CSV data, using an extra rules file to help interpret the data. A reader for CSV data, using an extra rules file to help interpret the data.
-} -}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Read.CsvReader ( module Hledger.Read.CsvReader (
-- * Reader -- * Reader
@ -35,9 +37,9 @@ import System.IO (stderr)
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Test.HUnit import Test.HUnit
import Text.CSV (parseCSV, CSV) import Text.CSV (parseCSV, CSV)
import Text.ParserCombinators.Parsec hiding (parse) import Text.Parsec hiding (parse)
import Text.ParserCombinators.Parsec.Error import Text.Parsec.Pos
import Text.ParserCombinators.Parsec.Pos import Text.Parsec.Error
import Text.Printf (hPrintf,printf) import Text.Printf (hPrintf,printf)
import Hledger.Data import Hledger.Data
@ -90,7 +92,10 @@ readJournalFromCsv mrulesfile csvfile csvdata =
if created if created
then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile
else hPrintf stderr "using conversion rules file %s\n" rulesfile else hPrintf stderr "using conversion rules file %s\n" rulesfile
rules <- either (throwerr.show) id `fmap` parseRulesFile rulesfile rules_ <- liftIO $ runErrorT $ parseRulesFile rulesfile
let rules = case rules_ of
Right (t::CsvRules) -> t
Left err -> throwerr $ show err
dbgAtM 2 "rules" rules dbgAtM 2 "rules" rules
-- apply skip directive -- apply skip directive
@ -324,15 +329,17 @@ getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate
getDirective directivename = lookup directivename . rdirectives getDirective directivename = lookup directivename . rdirectives
parseRulesFile :: FilePath -> IO (Either ParseError CsvRules) parseRulesFile :: FilePath -> ErrorT String IO CsvRules
parseRulesFile f = do parseRulesFile f = do
s <- readFile' f >>= expandIncludes s <- liftIO $ (readFile' f >>= expandIncludes)
let rules = parseCsvRules f s let rules = parseCsvRules f s
return $ case rules of case rules of
Left e -> Left e Left e -> ErrorT $ return $ Left $ show e
Right r -> case validateRules r of Right r -> do
Left e -> Left $ toParseError e r_ <- liftIO $ runErrorT $ validateRules r
Right r -> Right r ErrorT $ case r_ of
Left e -> return $ Left $ show $ toParseError e
Right r -> return $ Right r
where where
toParseError s = newErrorMessage (Message s) (initialPos "") toParseError s = newErrorMessage (Message s) (initialPos "")
@ -355,13 +362,13 @@ parseCsvRules rulesfile s =
runParser rulesp rules rulesfile s runParser rulesp rules rulesfile s
-- | Return the validated rules, or an error. -- | Return the validated rules, or an error.
validateRules :: CsvRules -> Either String CsvRules validateRules :: CsvRules -> ErrorT String IO CsvRules
validateRules rules = do validateRules rules = do
unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1\n" unless (isAssigned "date") $ ErrorT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n"
unless ((amount && not (amountin || amountout)) || unless ((amount && not (amountin || amountout)) ||
(not amount && (amountin && amountout))) (not amount && (amountin && amountout)))
$ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n" $ ErrorT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n"
Right rules ErrorT $ return $ Right rules
where where
amount = isAssigned "amount" amount = isAssigned "amount"
amountin = isAssigned "amount-in" amountin = isAssigned "amount-in"
@ -370,14 +377,14 @@ validateRules rules = do
-- parsers -- parsers
rulesp :: GenParser Char CsvRules CsvRules rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules
rulesp = do rulesp = do
many $ choice' many $ choice'
[blankorcommentline <?> "blank or comment line" [blankorcommentline <?> "blank or comment line"
,(directive >>= updateState . addDirective) <?> "directive" ,(directive >>= modifyState . addDirective) <?> "directive"
,(fieldnamelist >>= updateState . setIndexesAndAssignmentsFromList) <?> "field name list" ,(fieldnamelist >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"
,(fieldassignment >>= updateState . addAssignment) <?> "field assignment" ,(fieldassignment >>= modifyState . addAssignment) <?> "field assignment"
,(conditionalblock >>= updateState . addConditionalBlock) <?> "conditional block" ,(conditionalblock >>= modifyState . addConditionalBlock) <?> "conditional block"
] ]
eof eof
r <- getState r <- getState
@ -386,11 +393,19 @@ rulesp = do
,rconditionalblocks=reverse $ rconditionalblocks r ,rconditionalblocks=reverse $ rconditionalblocks r
} }
blankorcommentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
blankorcommentline = pdbg 3 "trying blankorcommentline" >> choice' [blankline, commentline] blankorcommentline = pdbg 3 "trying blankorcommentline" >> choice' [blankline, commentline]
blankline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
blankline = many spacenonewline >> newline >> return () <?> "blank line" blankline = many spacenonewline >> newline >> return () <?> "blank line"
commentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
commentline = many spacenonewline >> commentchar >> restofline >> return () <?> "comment line" commentline = many spacenonewline >> commentchar >> restofline >> return () <?> "comment line"
commentchar :: Stream [Char] m t => ParsecT [Char] CsvRules m Char
commentchar = oneOf ";#" commentchar = oneOf ";#"
directive :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String)
directive = do directive = do
pdbg 3 "trying directive" pdbg 3 "trying directive"
d <- choice' $ map string directives d <- choice' $ map string directives
@ -409,8 +424,10 @@ directives =
-- ,"base-currency" -- ,"base-currency"
] ]
directiveval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
directiveval = anyChar `manyTill` eolof directiveval = anyChar `manyTill` eolof
fieldnamelist :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]
fieldnamelist = (do fieldnamelist = (do
pdbg 3 "trying fieldnamelist" pdbg 3 "trying fieldnamelist"
string "fields" string "fields"
@ -423,16 +440,20 @@ fieldnamelist = (do
return $ map (map toLower) $ f:fs return $ map (map toLower) $ f:fs
) <?> "field name list" ) <?> "field name list"
fieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
fieldname = quotedfieldname <|> barefieldname fieldname = quotedfieldname <|> barefieldname
quotedfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
quotedfieldname = do quotedfieldname = do
char '"' char '"'
f <- many1 $ noneOf "\"\n:;#~" f <- many1 $ noneOf "\"\n:;#~"
char '"' char '"'
return f return f
barefieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
barefieldname = many1 $ noneOf " \t\n,;#~" barefieldname = many1 $ noneOf " \t\n,;#~"
fieldassignment :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)
fieldassignment = do fieldassignment = do
pdbg 3 "trying fieldassignment" pdbg 3 "trying fieldassignment"
f <- journalfieldname f <- journalfieldname
@ -441,6 +462,7 @@ fieldassignment = do
return (f,v) return (f,v)
<?> "field assignment" <?> "field assignment"
journalfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames) journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames)
journalfieldnames = journalfieldnames =
@ -460,6 +482,7 @@ journalfieldnames =
,"comment" ,"comment"
] ]
assignmentseparator :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
assignmentseparator = do assignmentseparator = do
pdbg 3 "trying assignmentseparator" pdbg 3 "trying assignmentseparator"
choice [ choice [
@ -467,12 +490,15 @@ assignmentseparator = do
try (many spacenonewline >> char ':'), try (many spacenonewline >> char ':'),
space space
] ]
many spacenonewline _ <- many spacenonewline
return ()
fieldval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
fieldval = do fieldval = do
pdbg 2 "trying fieldval" pdbg 2 "trying fieldval"
anyChar `manyTill` eolof anyChar `manyTill` eolof
conditionalblock :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock
conditionalblock = do conditionalblock = do
pdbg 3 "trying conditionalblock" pdbg 3 "trying conditionalblock"
string "if" >> many spacenonewline >> optional newline string "if" >> many spacenonewline >> optional newline
@ -483,6 +509,7 @@ conditionalblock = do
return (ms, as) return (ms, as)
<?> "conditional block" <?> "conditional block"
recordmatcher :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
recordmatcher = do recordmatcher = do
pdbg 2 "trying recordmatcher" pdbg 2 "trying recordmatcher"
-- pos <- currentPos -- pos <- currentPos
@ -493,6 +520,7 @@ recordmatcher = do
return ps return ps
<?> "record matcher" <?> "record matcher"
matchoperator :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
matchoperator = choice' $ map string matchoperator = choice' $ map string
["~" ["~"
-- ,"!~" -- ,"!~"
@ -500,11 +528,13 @@ matchoperator = choice' $ map string
-- ,"!=" -- ,"!="
] ]
patterns :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
patterns = do patterns = do
pdbg 3 "trying patterns" pdbg 3 "trying patterns"
ps <- many regexp ps <- many regexp
return ps return ps
regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
regexp = do regexp = do
pdbg 3 "trying regexp" pdbg 3 "trying regexp"
notFollowedBy matchoperator notFollowedBy matchoperator

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

@ -1,5 +1,6 @@
-- {-# OPTIONS_GHC -F -pgmF htfpp #-} -- {-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-} {-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-| {-|
A reader for hledger's journal file format A reader for hledger's journal file format
@ -58,7 +59,7 @@ import Safe (headDef, lastDef)
import Test.Framework import Test.Framework
import Text.Parsec.Error import Text.Parsec.Error
#endif #endif
import Text.ParserCombinators.Parsec hiding (parse) import Text.Parsec hiding (parse)
import Text.Printf import Text.Printf
import System.FilePath import System.FilePath
import System.Time (getClockTime) import System.Time (getClockTime)
@ -96,12 +97,13 @@ combineJournalUpdates us = liftM (foldl' (.) id) $ sequence us
-- | Given a JournalUpdate-generating parsec parser, file path and data string, -- | Given a JournalUpdate-generating parsec parser, file path and data string,
-- parse and post-process a Journal so that it's ready to use, or give an error. -- parse and post-process a Journal so that it's ready to use, or give an error.
parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ErrorT String IO Journal parseJournalWith :: (ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ErrorT String IO Journal
parseJournalWith p assrt f s = do parseJournalWith p assrt f s = do
tc <- liftIO getClockTime tc <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime tl <- liftIO getCurrentLocalTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
case runParser p nullctx{ctxYear=Just y} f s of r <- runParserT p nullctx{ctxYear=Just y} f s
case r of
Right (updates,ctx) -> do Right (updates,ctx) -> do
j <- updates `ap` return nulljournal j <- updates `ap` return nulljournal
case journalFinalise tc tl f s ctx assrt j of case journalFinalise tc tl f s ctx assrt j of
@ -109,46 +111,46 @@ parseJournalWith p assrt f s = do
Left estr -> throwError estr Left estr -> throwError estr
Left e -> throwError $ show e Left e -> throwError $ show e
setYear :: Integer -> GenParser tok JournalContext () setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()
setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) setYear y = modifyState (\ctx -> ctx{ctxYear=Just y})
getYear :: GenParser tok JournalContext (Maybe Integer) getYear :: Stream [Char] m Char => ParsecT s JournalContext m (Maybe Integer)
getYear = liftM ctxYear getState getYear = liftM ctxYear getState
setDefaultCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext () setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m ()
setDefaultCommodityAndStyle cs = updateState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs}) setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs})
getDefaultCommodityAndStyle :: GenParser tok JournalContext (Maybe (Commodity,AmountStyle)) getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe (Commodity,AmountStyle))
getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState
pushParentAccount :: String -> GenParser tok JournalContext () pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m ()
pushParentAccount parent = updateState addParentAccount pushParentAccount parent = modifyState addParentAccount
where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 } where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
popParentAccount :: GenParser tok JournalContext () popParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
popParentAccount = do ctx0 <- getState popParentAccount = do ctx0 <- getState
case ctxAccount ctx0 of case ctxAccount ctx0 of
[] -> unexpected "End of account block with no beginning" [] -> unexpected "End of account block with no beginning"
(_:rest) -> setState $ ctx0 { ctxAccount = rest } (_:rest) -> setState $ ctx0 { ctxAccount = rest }
getParentAccount :: GenParser tok JournalContext String getParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
addAccountAlias :: AccountAlias -> GenParser tok JournalContext () addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m ()
addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases}) addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
getAccountAliases :: GenParser tok JournalContext [AccountAlias] getAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m [AccountAlias]
getAccountAliases = liftM ctxAliases getState getAccountAliases = liftM ctxAliases getState
clearAccountAliases :: GenParser tok JournalContext () clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]}) clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
-- parsers -- parsers
-- | Top-level journal parser. Returns a single composite, I/O performing, -- | Top-level journal parser. Returns a single composite, I/O performing,
-- error-raising "JournalUpdate" (and final "JournalContext") which can be -- error-raising "JournalUpdate" (and final "JournalContext") which can be
-- applied to an empty journal to get the final result. -- applied to an empty journal to get the final result.
journal :: GenParser Char JournalContext (JournalUpdate,JournalContext) journal :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext)
journal = do journal = do
journalupdates <- many journalItem journalupdates <- many journalItem
eof eof
@ -168,7 +170,7 @@ journal = do
] <?> "journal transaction or directive" ] <?> "journal transaction or directive"
-- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directive :: GenParser Char JournalContext JournalUpdate directive :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
directive = do directive = do
optional $ char '!' optional $ char '!'
choice' [ choice' [
@ -186,7 +188,7 @@ directive = do
] ]
<?> "directive" <?> "directive"
includedirective :: GenParser Char JournalContext JournalUpdate includedirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
includedirective = do includedirective = do
string "include" string "include"
many1 spacenonewline many1 spacenonewline
@ -194,36 +196,48 @@ includedirective = do
outerState <- getState outerState <- getState
outerPos <- getPosition outerPos <- getPosition
let curdir = takeDirectory (sourceName outerPos) let curdir = takeDirectory (sourceName outerPos)
return $ do filepath <- expandPath curdir filename let (u::ErrorT String IO (Journal -> Journal, JournalContext)) = do
txt <- readFileOrError outerPos filepath filepath <- expandPath curdir filename
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" txt <- readFileOrError outerPos filepath
case runParser journal outerState filepath txt of let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++)) r <- runParserT journal outerState filepath txt
Left err -> throwError $ inIncluded ++ show err case r of
where readFileOrError pos fp = 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 =
ErrorT $ liftM Right (readFile' fp) `C.catch` ErrorT $ liftM Right (readFile' fp) `C.catch`
\e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException)) \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))
r <- liftIO $ runErrorT u
case r of
Left err -> return $ throwError err
Right (ju, ctx) -> return $ ErrorT $ return $ Right ju
journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
-- XXX currently called in reverse order of includes, I can't see why -- XXX currently called in reverse order of includes, I can't see why
accountdirective :: GenParser Char JournalContext JournalUpdate accountdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
accountdirective = do accountdirective = do
string "account" string "account"
many1 spacenonewline many1 spacenonewline
parent <- accountnamep parent <- accountnamep
newline newline
pushParentAccount parent pushParentAccount parent
return $ return id -- return $ return id
return $ ErrorT $ return $ Right id
enddirective :: GenParser Char JournalContext JournalUpdate enddirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
enddirective = do enddirective = do
string "end" string "end"
popParentAccount popParentAccount
return (return id) -- return (return id)
return $ ErrorT $ return $ Right id
aliasdirective :: GenParser Char JournalContext JournalUpdate aliasdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
aliasdirective = do aliasdirective = do
string "alias" string "alias"
many1 spacenonewline many1 spacenonewline
@ -234,13 +248,13 @@ aliasdirective = do
,accountNameWithoutPostingType $ strip alias) ,accountNameWithoutPostingType $ strip alias)
return $ return id return $ return id
endaliasesdirective :: GenParser Char JournalContext JournalUpdate endaliasesdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
endaliasesdirective = do endaliasesdirective = do
string "end aliases" string "end aliases"
clearAccountAliases clearAccountAliases
return (return id) return (return id)
tagdirective :: GenParser Char JournalContext JournalUpdate tagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
tagdirective = do tagdirective = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
many1 spacenonewline many1 spacenonewline
@ -248,13 +262,13 @@ tagdirective = do
restofline restofline
return $ return id return $ return id
endtagdirective :: GenParser Char JournalContext JournalUpdate endtagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
endtagdirective = do endtagdirective = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive" (string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline restofline
return $ return id return $ return id
defaultyeardirective :: GenParser Char JournalContext JournalUpdate defaultyeardirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
defaultyeardirective = do defaultyeardirective = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
many spacenonewline many spacenonewline
@ -264,7 +278,7 @@ defaultyeardirective = do
setYear y' setYear y'
return $ return id return $ return id
defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate defaultcommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
defaultcommoditydirective = do defaultcommoditydirective = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
many1 spacenonewline many1 spacenonewline
@ -273,7 +287,7 @@ defaultcommoditydirective = do
restofline restofline
return $ return id return $ return id
historicalpricedirective :: GenParser Char JournalContext HistoricalPrice historicalpricedirective :: ParsecT [Char] JournalContext (ErrorT String IO) HistoricalPrice
historicalpricedirective = do historicalpricedirective = do
char 'P' <?> "historical price" char 'P' <?> "historical price"
many spacenonewline many spacenonewline
@ -285,7 +299,7 @@ historicalpricedirective = do
restofline restofline
return $ HistoricalPrice date symbol price return $ HistoricalPrice date symbol price
ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
ignoredpricecommoditydirective = do ignoredpricecommoditydirective = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
many1 spacenonewline many1 spacenonewline
@ -293,7 +307,7 @@ ignoredpricecommoditydirective = do
restofline restofline
return $ return id return $ return id
commodityconversiondirective :: GenParser Char JournalContext JournalUpdate commodityconversiondirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
commodityconversiondirective = do commodityconversiondirective = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
many1 spacenonewline many1 spacenonewline
@ -305,7 +319,7 @@ commodityconversiondirective = do
restofline restofline
return $ return id return $ return id
modifiertransaction :: GenParser Char JournalContext ModifierTransaction modifiertransaction :: ParsecT [Char] JournalContext (ErrorT String IO) ModifierTransaction
modifiertransaction = do modifiertransaction = do
char '=' <?> "modifier transaction" char '=' <?> "modifier transaction"
many spacenonewline many spacenonewline
@ -313,7 +327,7 @@ modifiertransaction = do
postings <- postings postings <- postings
return $ ModifierTransaction valueexpr postings return $ ModifierTransaction valueexpr postings
periodictransaction :: GenParser Char JournalContext PeriodicTransaction periodictransaction :: ParsecT [Char] JournalContext (ErrorT String IO) PeriodicTransaction
periodictransaction = do periodictransaction = do
char '~' <?> "periodic transaction" char '~' <?> "periodic transaction"
many spacenonewline many spacenonewline
@ -322,7 +336,7 @@ periodictransaction = do
return $ PeriodicTransaction periodexpr postings return $ PeriodicTransaction periodexpr postings
-- | Parse a (possibly unbalanced) transaction. -- | Parse a (possibly unbalanced) transaction.
transaction :: GenParser Char JournalContext Transaction transaction :: ParsecT [Char] JournalContext (ErrorT String IO) Transaction
transaction = do transaction = do
-- ptrace "transaction" -- ptrace "transaction"
sourcepos <- getPosition sourcepos <- getPosition
@ -427,7 +441,7 @@ test_transaction = do
-- | 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.
datep :: GenParser Char JournalContext Day datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day
datep = do datep = do
-- hacky: try to ensure precise errors for invalid dates -- hacky: try to ensure precise errors for invalid dates
-- XXX reported error position is not too good -- XXX reported error position is not too good
@ -452,7 +466,7 @@ datep = do
-- timezone will be ignored; the time is treated as local time. Fewer -- timezone will be ignored; the time is treated as local time. Fewer
-- digits are allowed, except in the timezone. The year may be omitted if -- digits are allowed, except in the timezone. The year may be omitted if
-- a default year has already been set. -- a default year has already been set.
datetimep :: GenParser Char JournalContext LocalTime datetimep :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime
datetimep = do datetimep = do
day <- datep day <- datep
many1 spacenonewline many1 spacenonewline
@ -480,7 +494,7 @@ datetimep = do
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Day -> GenParser Char JournalContext Day secondarydatep :: Stream [Char] m Char => Day -> ParsecT [Char] JournalContext m Day
secondarydatep primarydate = do secondarydatep primarydate = do
char '=' char '='
-- kludgy way to use primary date for default year -- kludgy way to use primary date for default year
@ -493,24 +507,24 @@ secondarydatep primarydate = do
edate <- withDefaultYear primarydate datep edate <- withDefaultYear primarydate datep
return edate return edate
status :: GenParser Char JournalContext Bool status :: Stream [Char] m Char => ParsecT [Char] JournalContext m Bool
status = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False status = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False
codep :: GenParser Char JournalContext String codep :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
-- 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 :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting]
postings = many1 (try postingp) <?> "postings" postings = many1 (try postingp) <?> "postings"
-- linebeginningwithspaces :: GenParser Char JournalContext String -- linebeginningwithspaces :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
-- linebeginningwithspaces = do -- linebeginningwithspaces = do
-- sp <- many1 spacenonewline -- sp <- many1 spacenonewline
-- c <- nonspace -- c <- nonspace
-- cs <- restofline -- cs <- restofline
-- return $ sp ++ (c:cs) ++ "\n" -- return $ sp ++ (c:cs) ++ "\n"
postingp :: GenParser Char JournalContext Posting postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting
postingp = do postingp = do
many1 spacenonewline many1 spacenonewline
status <- status status <- status
@ -525,9 +539,27 @@ postingp = do
comment <- try followingcommentp <|> (newline >> return "") comment <- try followingcommentp <|> (newline >> return "")
let tags = tagsInComment comment let tags = tagsInComment comment
-- oh boy -- oh boy
d <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx datep `fmap` dateValueFromTags tags) date <- case dateValueFromTags tags of
d2 <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx datep `fmap` date2ValueFromTags tags) Nothing -> return Nothing
return posting{pdate=d, pdate2=d2, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags, pbalanceassertion=massertion} Just v -> case runParser datep 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 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 #ifdef TESTS
test_postingp = do test_postingp = do
@ -577,7 +609,7 @@ test_postingp = do
#endif #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 :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName
modifiedaccountname = do modifiedaccountname = do
a <- accountnamep a <- accountnamep
prefix <- getParentAccount prefix <- getParentAccount
@ -589,7 +621,7 @@ modifiedaccountname = do
-- them, and are terminated by two or more spaces. They should have one or -- them, and are terminated by two or more spaces. They should have one or
-- more components of at least one character, separated by the account -- more components of at least one character, separated by the account
-- separator char. -- separator char.
accountnamep :: GenParser Char st AccountName accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName
accountnamep = do accountnamep = do
a <- many1 (nonspace <|> singlespace) a <- many1 (nonspace <|> singlespace)
let a' = striptrailingspace a let a' = striptrailingspace a
@ -607,7 +639,7 @@ accountnamep = do
-- | Parse whitespace then an amount, with an optional left or right -- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special -- currency symbol and optional price, or return the special
-- "missing" marker amount. -- "missing" marker amount.
spaceandamountormissing :: GenParser Char JournalContext MixedAmount spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount
spaceandamountormissing = spaceandamountormissing =
try (do try (do
many1 spacenonewline many1 spacenonewline
@ -631,7 +663,7 @@ test_spaceandamountormissing = do
-- | 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)
-- ledger-style balance assertion or fixed lot price declaration. -- ledger-style balance assertion or fixed lot price declaration.
amountp :: GenParser Char JournalContext Amount amountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
#ifdef TESTS #ifdef TESTS
@ -650,19 +682,22 @@ test_amountp = do
-- | 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
amountp' s = either (error' . show) id $ parseWithCtx nullctx amountp s amountp' s =
case runParser amountp nullctx "" s of
Right t -> t
Left err -> error' $ show err
-- | Parse a mixed amount from a string, or get an error. -- | Parse a mixed amount from a string, or get an error.
mamountp' :: String -> MixedAmount mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp' mamountp' = Mixed . (:[]) . amountp'
signp :: GenParser Char JournalContext String signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String
signp = do signp = do
sign <- optionMaybe $ oneOf "+-" sign <- optionMaybe $ oneOf "+-"
return $ case sign of Just '-' -> "-" return $ case sign of Just '-' -> "-"
_ -> "" _ -> ""
leftsymbolamount :: GenParser Char JournalContext Amount leftsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
leftsymbolamount = do leftsymbolamount = do
sign <- signp sign <- signp
c <- commoditysymbol c <- commoditysymbol
@ -674,7 +709,7 @@ leftsymbolamount = do
return $ applysign $ Amount c q p s return $ applysign $ Amount c q p s
<?> "left-symbol amount" <?> "left-symbol amount"
rightsymbolamount :: GenParser Char JournalContext Amount rightsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
rightsymbolamount = do rightsymbolamount = do
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- numberp
sp <- many spacenonewline sp <- many spacenonewline
@ -684,7 +719,7 @@ rightsymbolamount = do
return $ Amount c q p s return $ Amount c q p s
<?> "right-symbol amount" <?> "right-symbol amount"
nosymbolamount :: GenParser Char JournalContext Amount nosymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
nosymbolamount = do nosymbolamount = do
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- numberp
p <- priceamount p <- priceamount
@ -696,20 +731,20 @@ nosymbolamount = do
return $ Amount c q p s return $ Amount c q p s
<?> "no-symbol amount" <?> "no-symbol amount"
commoditysymbol :: GenParser Char JournalContext String commoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String
commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol" commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"
quotedcommoditysymbol :: GenParser Char JournalContext String quotedcommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String
quotedcommoditysymbol = do quotedcommoditysymbol = do
char '"' char '"'
s <- many1 $ noneOf ";\n\"" s <- many1 $ noneOf ";\n\""
char '"' char '"'
return s return s
simplecommoditysymbol :: GenParser Char JournalContext String simplecommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String
simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)
priceamount :: GenParser Char JournalContext Price priceamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Price
priceamount = priceamount =
try (do try (do
many spacenonewline many spacenonewline
@ -725,7 +760,7 @@ priceamount =
return $ UnitPrice a)) return $ UnitPrice a))
<|> return NoPrice <|> return NoPrice
partialbalanceassertion :: GenParser Char JournalContext (Maybe MixedAmount) partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)
partialbalanceassertion = partialbalanceassertion =
try (do try (do
many spacenonewline many spacenonewline
@ -735,7 +770,7 @@ partialbalanceassertion =
return $ Just $ Mixed [a]) return $ Just $ Mixed [a])
<|> return Nothing <|> return Nothing
-- balanceassertion :: GenParser Char JournalContext (Maybe MixedAmount) -- balanceassertion :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe MixedAmount)
-- balanceassertion = -- balanceassertion =
-- try (do -- try (do
-- many spacenonewline -- many spacenonewline
@ -746,7 +781,7 @@ partialbalanceassertion =
-- <|> return Nothing -- <|> return Nothing
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotprice :: GenParser Char JournalContext (Maybe Amount) fixedlotprice :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount)
fixedlotprice = fixedlotprice =
try (do try (do
many spacenonewline many spacenonewline
@ -772,7 +807,7 @@ fixedlotprice =
-- seen following the decimal point), the decimal point character used if any, -- seen following the decimal point), the decimal point character used if any,
-- and the digit group style if any. -- and the digit group style if any.
-- --
numberp :: GenParser Char JournalContext (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) numberp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
numberp = do numberp = do
-- a number is an optional sign followed by a sequence of digits possibly -- a number is an optional sign followed by a sequence of digits possibly
-- interspersed with periods, commas, or both -- interspersed with periods, commas, or both
@ -848,7 +883,7 @@ test_numberp = do
-- comment parsers -- comment parsers
multilinecommentp :: GenParser Char JournalContext () multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
multilinecommentp = do multilinecommentp = do
string "comment" >> newline string "comment" >> newline
go go
@ -857,25 +892,25 @@ multilinecommentp = do
<|> (anyLine >> go) <|> (anyLine >> go)
anyLine = anyChar `manyTill` newline anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: GenParser Char JournalContext () emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
emptyorcommentlinep = do emptyorcommentlinep = do
many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return "")) many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return ""))
return () return ()
followingcommentp :: GenParser Char JournalContext String followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
followingcommentp = followingcommentp =
-- ptrace "followingcommentp" -- ptrace "followingcommentp"
do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return "")) do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment)) newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
return $ unlines $ samelinecomment:newlinecomments return $ unlines $ samelinecomment:newlinecomments
comment :: GenParser Char JournalContext String comment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
comment = commentStartingWith "#;" comment = commentStartingWith "#;"
semicoloncomment :: GenParser Char JournalContext String semicoloncomment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
semicoloncomment = commentStartingWith ";" semicoloncomment = commentStartingWith ";"
commentStartingWith :: String -> GenParser Char JournalContext String commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String
commentStartingWith cs = do commentStartingWith cs = do
-- ptrace "commentStartingWith" -- ptrace "commentStartingWith"
oneOf cs oneOf cs
@ -892,7 +927,7 @@ tagsInComment c = concatMap tagsInCommentLine $ lines c'
tagsInCommentLine :: String -> [Tag] tagsInCommentLine :: String -> [Tag]
tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ',' tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
where where
maybetag s = case parseWithCtx nullctx tag s of maybetag s = case runParser tag nullctx "" s of
Right t -> Just t Right t -> Just t
Left _ -> Nothing Left _ -> Nothing

6
hledger-lib/Hledger/Read/TimelogReader.hs
View File

@ -51,7 +51,7 @@ import Control.Monad
import Control.Monad.Error import Control.Monad.Error
import Data.List (isPrefixOf) import Data.List (isPrefixOf)
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec hiding (parse) import Text.Parsec hiding (parse)
import System.FilePath import System.FilePath
import Hledger.Data import Hledger.Data
@ -81,7 +81,7 @@ detect f s
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
parse _ = parseJournalWith timelogFile parse _ = parseJournalWith timelogFile
timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext) timelogFile :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate, JournalContext)
timelogFile = do items <- many timelogItem timelogFile = do items <- many timelogItem
eof eof
ctx <- getState ctx <- getState
@ -98,7 +98,7 @@ timelogFile = do items <- many timelogItem
] <?> "timelog entry, or default year or historical price directive" ] <?> "timelog entry, or default year or historical price directive"
-- | Parse a timelog entry. -- | Parse a timelog entry.
timelogentry :: GenParser Char JournalContext TimeLogEntry timelogentry :: ParsecT [Char] JournalContext (ErrorT String IO) TimeLogEntry
timelogentry = do timelogentry = do
sourcepos <- getPosition sourcepos <- getPosition
code <- oneOf "bhioO" code <- oneOf "bhioO"

23
hledger-lib/Hledger/Utils.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-| {-|
Standard imports and utilities which are useful everywhere, or needed low Standard imports and utilities which are useful everywhere, or needed low
@ -42,7 +43,7 @@ import System.Directory (getHomeDirectory)
import System.FilePath((</>), isRelative) import System.FilePath((</>), isRelative)
import System.IO import System.IO
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec import Text.Parsec
import Text.Printf import Text.Printf
-- import qualified Data.Map as Map -- import qualified Data.Map as Map
@ -333,14 +334,14 @@ treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath
-- | Backtracking choice, use this when alternatives share a prefix. -- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail. -- Consumes no input if all choices fail.
choice' :: [GenParser tok st a] -> GenParser tok st a choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
choice' = choice . map Text.ParserCombinators.Parsec.try choice' = choice . map Text.Parsec.try
parsewith :: Parser a -> String -> Either ParseError a parsewith :: Parsec [Char] () a -> String -> Either ParseError a
parsewith p = parse p "" parsewith p = runParser p () ""
parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a)
parseWithCtx ctx p = runParser p ctx "" parseWithCtx ctx p = runParserT p ctx ""
fromparse :: Either ParseError a -> a fromparse :: Either ParseError a -> a
fromparse = either parseerror id fromparse = either parseerror id
@ -354,16 +355,16 @@ showParseError e = "parse error at " ++ show e
showDateParseError :: ParseError -> String showDateParseError :: ParseError -> String
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
nonspace :: GenParser Char st Char nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char
nonspace = satisfy (not . isSpace) nonspace = satisfy (not . isSpace)
spacenonewline :: GenParser Char st Char spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char
spacenonewline = satisfy (`elem` " \v\f\t") spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: GenParser Char st String restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String
restofline = anyChar `manyTill` newline restofline = anyChar `manyTill` newline
eolof :: GenParser Char st () eolof :: (Stream [Char] m Char) => ParsecT [Char] st m ()
eolof = (newline >> return ()) <|> eof eolof = (newline >> return ()) <|> eof
-- time -- time

7
hledger-lib/Hledger/Utils/Debug.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, FlexibleContexts #-}
-- | Debugging helpers -- | Debugging helpers
-- more: -- more:
@ -23,7 +23,7 @@ import Safe (readDef)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit import System.Exit
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Text.ParserCombinators.Parsec import Text.Parsec
import Text.Printf import Text.Printf
#if __GLASGOW_HASKELL__ >= 704 #if __GLASGOW_HASKELL__ >= 704
@ -54,7 +54,7 @@ traceWith f e = trace (f e) e
-- | Parsec trace - show the current parsec position and next input, -- | Parsec trace - show the current parsec position and next input,
-- and the provided label if it's non-null. -- and the provided label if it's non-null.
ptrace :: String -> GenParser Char st () ptrace :: Stream [Char] m t => String -> ParsecT [Char] st m ()
ptrace msg = do ptrace msg = do
pos <- getPosition pos <- getPosition
next <- take peeklength `fmap` getInput next <- take peeklength `fmap` getInput
@ -199,6 +199,7 @@ dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg
-- input) to the console when the debug level is at or above -- input) to the console when the debug level is at or above
-- this level. Uses unsafePerformIO. -- this level. Uses unsafePerformIO.
-- pdbgAt :: GenParser m => Float -> String -> m () -- pdbgAt :: GenParser m => Float -> String -> m ()
pdbg :: Stream [Char] m t => Int -> String -> ParsecT [Char] st m ()
pdbg level msg = when (level <= debugLevel) $ ptrace msg pdbg level msg = when (level <= debugLevel) $ ptrace msg

4
hledger-lib/hledger-lib.cabal
View File

@ -95,7 +95,7 @@ library
,mtl ,mtl
,old-locale ,old-locale
,old-time ,old-time
,parsec ,parsec >= 3
,regex-tdfa ,regex-tdfa
,regexpr >= 0.5.1 ,regexpr >= 0.5.1
,safe >= 0.2 ,safe >= 0.2
@ -130,7 +130,7 @@ test-suite tests
, mtl , mtl
, old-locale , old-locale
, old-time , old-time
, parsec , parsec >= 3
, regex-tdfa , regex-tdfa
, regexpr , regexpr
, safe , safe

4
hledger-web/Handler/Post.hs
View File

@ -10,7 +10,7 @@ import Data.List (intercalate, sort)
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
import Data.Text (unpack) import Data.Text (unpack)
import qualified Data.Text as T import qualified Data.Text as T
import Text.Parsec (digit, eof, many1, string) import Text.Parsec (digit, eof, many1, string, runParser)
import Text.Printf (printf) import Text.Printf (printf)
import Hledger.Utils import Hledger.Utils
@ -64,7 +64,7 @@ handleAdd = do
map fst amtparams `elem` [[1..num], [1..num-1]] = [] map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["malformed account/amount parameters"] | otherwise = ["malformed account/amount parameters"]
eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams
eamts = map (parseWithCtx nullctx (amountp <* eof) . strip . T.unpack . snd) amtparams eamts = map (runParser (amountp <* eof) nullctx "" . strip . T.unpack . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts) (amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts' amts | length amts' == num = amts'

4
hledger-web/hledger-web.cabal
View File

@ -137,7 +137,7 @@ library
, network-conduit , network-conduit
, conduit-extra , conduit-extra
, old-locale , old-locale
, parsec , parsec >= 3
, regexpr >= 0.5.1 , regexpr >= 0.5.1
, safe >= 0.2 , safe >= 0.2
, shakespeare >= 2.0 , shakespeare >= 2.0
@ -208,7 +208,7 @@ executable hledger-web
, network-conduit , network-conduit
, conduit-extra , conduit-extra
, old-locale , old-locale
, parsec , parsec >= 3
, regexpr >= 0.5.1 , regexpr >= 0.5.1
, safe >= 0.2 , safe >= 0.2
, shakespeare >= 2.0 && < 2.1 , shakespeare >= 2.0 && < 2.1

10
hledger/Hledger/Cli/Add.hs
View File

@ -23,7 +23,7 @@ import System.Console.Haskeline.Completion
import System.Console.Wizard import System.Console.Wizard
import System.Console.Wizard.Haskeline import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn ) import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.ParserCombinators.Parsec hiding (Line) import Text.Parsec
import Text.Printf import Text.Printf
import Hledger import Hledger
@ -178,7 +178,8 @@ dateAndCodeWizard EntryState{..} = do
where where
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
where where
edc = parseWithCtx nullctx dateandcodep $ lowercase s edc = runParser dateandcodep nullctx "" $ lowercase s
dateandcodep :: Stream [Char] m t => ParsecT [Char] JournalContext m (SmartDate, String)
dateandcodep = do dateandcodep = do
d <- smartdate d <- smartdate
c <- optionMaybe codep c <- optionMaybe codep
@ -241,7 +242,7 @@ accountWizard EntryState{..} = do
parseAccountOrDotOrNull _ _ "." = dbg $ Just "." -- . always signals end of txn parseAccountOrDotOrNull _ _ "." = dbg $ Just "." -- . always signals end of txn
parseAccountOrDotOrNull "" True "" = dbg $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn parseAccountOrDotOrNull "" True "" = dbg $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn
parseAccountOrDotOrNull def@(_:_) _ "" = dbg $ Just def -- when there's a default, "" means use that parseAccountOrDotOrNull def@(_:_) _ "" = dbg $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg $ either (const Nothing) validateAccount $ parseWithCtx (jContext esJournal) accountnamep s -- otherwise, try to parse the input as an accountname parseAccountOrDotOrNull _ _ s = dbg $ either (const Nothing) validateAccount $ runParser accountnamep (jContext esJournal) "" s -- otherwise, try to parse the input as an accountname
dbg = id -- strace dbg = id -- strace
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just s | otherwise = Just s
@ -265,8 +266,9 @@ amountAndCommentWizard EntryState{..} = do
maybeRestartTransaction $ maybeRestartTransaction $
line $ green $ printf "Amount %d%s: " pnum (showDefault def) line $ green $ printf "Amount %d%s: " pnum (showDefault def)
where where
parseAmountAndComment = either (const Nothing) Just . parseWithCtx nodefcommodityctx amountandcommentp parseAmountAndComment = either (const Nothing) Just . runParser amountandcommentp nodefcommodityctx ""
nodefcommodityctx = (jContext esJournal){ctxDefaultCommodityAndStyle=Nothing} nodefcommodityctx = (jContext esJournal){ctxDefaultCommodityAndStyle=Nothing}
amountandcommentp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Amount, String)
amountandcommentp = do amountandcommentp = do
a <- amountp a <- amountp
many spacenonewline many spacenonewline

7
hledger/Hledger/Cli/Options.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-| {-|
Common cmdargs modes and flags, a command-line options type, and Common cmdargs modes and flags, a command-line options type, and
@ -74,7 +75,7 @@ import System.Environment
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.FilePath import System.FilePath
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec as P import Text.Parsec
import Hledger import Hledger
import Hledger.Data.OutputFormat as OutputFormat import Hledger.Data.OutputFormat as OutputFormat
@ -453,14 +454,14 @@ parseWidth s = case (runParser outputwidthp () "(unknown)") s of
Left e -> Left $ show e Left e -> Left $ show e
Right x -> Right x Right x -> Right x
outputwidthp :: GenParser Char st OutputWidth outputwidthp :: Stream [Char] m t => ParsecT [Char] st m OutputWidth
outputwidthp = outputwidthp =
try (do w <- widthp try (do w <- widthp
ws <- many1 (char ',' >> widthp) ws <- many1 (char ',' >> widthp)
return $ FieldWidths $ w:ws) return $ FieldWidths $ w:ws)
<|> TotalWidth `fmap` widthp <|> TotalWidth `fmap` widthp
widthp :: GenParser Char st Width widthp :: Stream [Char] m t => ParsecT [Char] st m Width
widthp = (string "auto" >> return Auto) widthp = (string "auto" >> return Auto)
<|> (Width . read) `fmap` many1 digit <|> (Width . read) `fmap` many1 digit

6
hledger/hledger.cabal
View File

@ -79,7 +79,7 @@ library
,mtl ,mtl
,old-locale ,old-locale
,old-time ,old-time
,parsec ,parsec >= 3
,process ,process
,regex-tdfa ,regex-tdfa
,regexpr >= 0.5.1 ,regexpr >= 0.5.1
@ -129,7 +129,7 @@ executable hledger
,mtl ,mtl
,old-locale ,old-locale
,old-time ,old-time
,parsec ,parsec >= 3
,process ,process
,regex-tdfa ,regex-tdfa
,regexpr >= 0.5.1 ,regexpr >= 0.5.1
@ -168,7 +168,7 @@ test-suite tests
, mtl , mtl
, old-locale , old-locale
, old-time , old-time
, parsec , parsec >= 3
, process , process
, regex-tdfa , regex-tdfa
, regexpr , regexpr