mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 10:17:35 +03:00
lib: move from Text.ParserCombinators.Parsec to Text.Parsec
NOTE: required to use liftIO in includedirective SEE: http://www.vex.net/~trebla/haskell/parsec-generally.xhtml#IO
This commit is contained in:
parent
21a200cccc
commit
cf28985cf2
@ -23,7 +23,7 @@ Tested-with: hledger HEAD ~ 2014/2/4
|
||||
import Hledger.Cli
|
||||
-- more utils for parsing
|
||||
import Control.Applicative hiding (many)
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Text.Parsec
|
||||
|
||||
|
||||
cmdmode :: Mode RawOpts
|
||||
@ -46,7 +46,7 @@ type PostingExpr = (AccountName, AmountExpr)
|
||||
data AmountExpr = AmountLiteral String | AmountMultiplier Quantity deriving (Show)
|
||||
|
||||
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
|
||||
a <- accountnamep
|
||||
@ -67,7 +67,7 @@ amountexprp =
|
||||
amountExprRenderer :: Query -> AmountExpr -> (Transaction -> MixedAmount)
|
||||
amountExprRenderer q aex =
|
||||
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)
|
||||
where
|
||||
firstAmountMatching :: Transaction -> Query -> MixedAmount
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE NoMonoLocalBinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-|
|
||||
|
||||
Date parsing and utilities for hledger.
|
||||
@ -75,7 +76,7 @@ import Data.Time.LocalTime
|
||||
import Safe (headMay, lastMay, readMay)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
import Test.HUnit
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Text.Parsec
|
||||
import Text.Printf
|
||||
|
||||
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).
|
||||
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
|
||||
-- XXX maybe obscures date errors ? see ledgerdate
|
||||
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
|
||||
return (y,m,d)
|
||||
|
||||
-- | 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
|
||||
d <- smartdate
|
||||
many spacenonewline
|
||||
@ -453,6 +454,7 @@ smartdateonly = do
|
||||
return d
|
||||
|
||||
datesepchars = "/-."
|
||||
datesepchar :: Stream [Char] m Char => ParsecT [Char] st m Char
|
||||
datesepchar = oneOf datesepchars
|
||||
|
||||
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
|
||||
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
|
||||
y <- count 4 digit
|
||||
m <- count 2 digit
|
||||
@ -474,7 +476,7 @@ yyyymmdd = do
|
||||
failIfInvalidDay d
|
||||
return (y,m,d)
|
||||
|
||||
ymd :: GenParser Char st SmartDate
|
||||
ymd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
ymd = do
|
||||
y <- many1 digit
|
||||
failIfInvalidYear y
|
||||
@ -486,7 +488,7 @@ ymd = do
|
||||
failIfInvalidDay d
|
||||
return $ (y,m,d)
|
||||
|
||||
ym :: GenParser Char st SmartDate
|
||||
ym :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
ym = do
|
||||
y <- many1 digit
|
||||
failIfInvalidYear y
|
||||
@ -495,19 +497,19 @@ ym = do
|
||||
failIfInvalidMonth m
|
||||
return (y,m,"")
|
||||
|
||||
y :: GenParser Char st SmartDate
|
||||
y :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
y = do
|
||||
y <- many1 digit
|
||||
failIfInvalidYear y
|
||||
return (y,"","")
|
||||
|
||||
d :: GenParser Char st SmartDate
|
||||
d :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
d = do
|
||||
d <- many1 digit
|
||||
failIfInvalidDay d
|
||||
return ("","",d)
|
||||
|
||||
md :: GenParser Char st SmartDate
|
||||
md :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
md = do
|
||||
m <- many1 digit
|
||||
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
|
||||
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
|
||||
m <- choice $ map (try . string) months
|
||||
let i = monthIndex m
|
||||
return ("",show i,"")
|
||||
|
||||
mon :: GenParser Char st SmartDate
|
||||
mon :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
mon = do
|
||||
m <- choice $ map (try . string) monthabbrevs
|
||||
let i = monIndex m
|
||||
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")
|
||||
yesterday = string "yesterday" >> return ("","","yesterday")
|
||||
tomorrow = string "tomorrow" >> return ("","","tomorrow")
|
||||
|
||||
lastthisnextthing :: GenParser Char st SmartDate
|
||||
lastthisnextthing :: Stream [Char] m Char => ParsecT [Char] st m SmartDate
|
||||
lastthisnextthing = do
|
||||
r <- choice [
|
||||
string "last"
|
||||
@ -562,7 +564,7 @@ lastthisnextthing = do
|
||||
|
||||
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 [
|
||||
intervalanddateperiodexpr rdate,
|
||||
intervalperiodexpr,
|
||||
@ -570,7 +572,7 @@ periodexpr rdate = choice $ map try [
|
||||
(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
|
||||
many spacenonewline
|
||||
i <- reportinginterval
|
||||
@ -578,20 +580,20 @@ intervalanddateperiodexpr rdate = do
|
||||
s <- periodexprdatespan rdate
|
||||
return (i,s)
|
||||
|
||||
intervalperiodexpr :: GenParser Char st (Interval, DateSpan)
|
||||
intervalperiodexpr :: Stream [Char] m Char => ParsecT [Char] st m (Interval, DateSpan)
|
||||
intervalperiodexpr = do
|
||||
many spacenonewline
|
||||
i <- reportinginterval
|
||||
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
|
||||
many spacenonewline
|
||||
s <- periodexprdatespan rdate
|
||||
return (NoInterval, s)
|
||||
|
||||
-- Parse a reporting interval.
|
||||
reportinginterval :: GenParser Char st Interval
|
||||
reportinginterval :: Stream [Char] m Char => ParsecT [Char] st m Interval
|
||||
reportinginterval = choice' [
|
||||
tryinterval "day" "daily" Days,
|
||||
tryinterval "week" "weekly" Weeks,
|
||||
@ -631,7 +633,7 @@ reportinginterval = choice' [
|
||||
thsuffix = choice' $ map string ["st","nd","rd","th"]
|
||||
|
||||
-- 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 =
|
||||
choice' [
|
||||
do string compact
|
||||
@ -649,7 +651,7 @@ reportinginterval = choice' [
|
||||
]
|
||||
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 [
|
||||
doubledatespan rdate,
|
||||
fromdatespan rdate,
|
||||
@ -657,7 +659,7 @@ periodexprdatespan rdate = choice $ map try [
|
||||
justdatespan rdate
|
||||
]
|
||||
|
||||
doubledatespan :: Day -> GenParser Char st DateSpan
|
||||
doubledatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan
|
||||
doubledatespan rdate = do
|
||||
optional (string "from" >> many spacenonewline)
|
||||
b <- smartdate
|
||||
@ -666,7 +668,7 @@ doubledatespan rdate = do
|
||||
e <- smartdate
|
||||
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
|
||||
b <- choice [
|
||||
do
|
||||
@ -680,13 +682,13 @@ fromdatespan rdate = do
|
||||
]
|
||||
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
|
||||
choice [string "to", string "-"] >> many spacenonewline
|
||||
e <- smartdate
|
||||
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
|
||||
optional (string "in" >> many spacenonewline)
|
||||
d <- smartdate
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Hledger.Data.OutputFormat (
|
||||
parseStringFormat
|
||||
, formatsp
|
||||
@ -11,7 +12,7 @@ import Numeric
|
||||
import Data.Char (isPrint)
|
||||
import Data.Maybe
|
||||
import Test.HUnit
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Text.Parsec
|
||||
import Text.Printf
|
||||
|
||||
import Hledger.Data.Types
|
||||
@ -34,7 +35,7 @@ parseStringFormat input = case (runParser formatsp () "(unknown)") input of
|
||||
Parsers
|
||||
-}
|
||||
|
||||
field :: GenParser Char st HledgerFormatField
|
||||
field :: Stream [Char] m Char => ParsecT [Char] st m HledgerFormatField
|
||||
field = do
|
||||
try (string "account" >> return AccountField)
|
||||
<|> try (string "depth_spacer" >> return DepthSpacerField)
|
||||
@ -43,7 +44,7 @@ field = do
|
||||
<|> try (string "total" >> return TotalField)
|
||||
<|> 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
|
||||
char '%'
|
||||
leftJustified <- optionMaybe (char '-')
|
||||
@ -58,7 +59,7 @@ formatField = do
|
||||
Just text -> Just m where ((m,_):_) = readDec text
|
||||
_ -> Nothing
|
||||
|
||||
formatLiteral :: GenParser Char st OutputFormat
|
||||
formatLiteral :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat
|
||||
formatLiteral = do
|
||||
s <- many1 c
|
||||
return $ FormatLiteral s
|
||||
@ -67,12 +68,12 @@ formatLiteral = do
|
||||
c = (satisfy isPrintableButNotPercentage <?> "printable character")
|
||||
<|> try (string "%%" >> return '%')
|
||||
|
||||
formatp :: GenParser Char st OutputFormat
|
||||
formatp :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat
|
||||
formatp =
|
||||
formatField
|
||||
<|> formatLiteral
|
||||
|
||||
formatsp :: GenParser Char st [OutputFormat]
|
||||
formatsp :: Stream [Char] m Char => ParsecT [Char] st m [OutputFormat]
|
||||
formatsp = many formatp
|
||||
|
||||
testFormat :: OutputFormat -> String -> String -> Assertion
|
||||
|
@ -46,7 +46,8 @@ import Data.Maybe
|
||||
import Data.Time.Calendar
|
||||
import Safe (readDef, headDef, headMay)
|
||||
import Test.HUnit
|
||||
import Text.ParserCombinators.Parsec
|
||||
-- import Text.ParserCombinators.Parsec
|
||||
import Text.Parsec hiding (Empty)
|
||||
|
||||
import Hledger.Utils
|
||||
import Hledger.Data.Types
|
||||
|
@ -235,7 +235,8 @@ tests_Hledger_Read = TestList $
|
||||
tests_Hledger_Read_CsvReader,
|
||||
|
||||
"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
|
||||
either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE
|
||||
|
||||
|
@ -3,6 +3,8 @@
|
||||
A reader for CSV data, using an extra rules file to help interpret the data.
|
||||
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Hledger.Read.CsvReader (
|
||||
-- * Reader
|
||||
@ -35,9 +37,9 @@ import System.IO (stderr)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
import Test.HUnit
|
||||
import Text.CSV (parseCSV, CSV)
|
||||
import Text.ParserCombinators.Parsec hiding (parse)
|
||||
import Text.ParserCombinators.Parsec.Error
|
||||
import Text.ParserCombinators.Parsec.Pos
|
||||
import Text.Parsec hiding (parse)
|
||||
import Text.Parsec.Pos
|
||||
import Text.Parsec.Error
|
||||
import Text.Printf (hPrintf,printf)
|
||||
|
||||
import Hledger.Data
|
||||
@ -90,7 +92,10 @@ readJournalFromCsv mrulesfile csvfile csvdata =
|
||||
if created
|
||||
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
|
||||
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
|
||||
|
||||
-- apply skip directive
|
||||
@ -324,15 +329,17 @@ getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate
|
||||
getDirective directivename = lookup directivename . rdirectives
|
||||
|
||||
|
||||
parseRulesFile :: FilePath -> IO (Either ParseError CsvRules)
|
||||
parseRulesFile :: FilePath -> ErrorT String IO CsvRules
|
||||
parseRulesFile f = do
|
||||
s <- readFile' f >>= expandIncludes
|
||||
s <- liftIO $ (readFile' f >>= expandIncludes)
|
||||
let rules = parseCsvRules f s
|
||||
return $ case rules of
|
||||
Left e -> Left e
|
||||
Right r -> case validateRules r of
|
||||
Left e -> Left $ toParseError e
|
||||
Right r -> Right r
|
||||
case rules of
|
||||
Left e -> ErrorT $ return $ Left $ show e
|
||||
Right r -> do
|
||||
r_ <- liftIO $ runErrorT $ validateRules r
|
||||
ErrorT $ case r_ of
|
||||
Left e -> return $ Left $ show $ toParseError e
|
||||
Right r -> return $ Right r
|
||||
where
|
||||
toParseError s = newErrorMessage (Message s) (initialPos "")
|
||||
|
||||
@ -355,13 +362,13 @@ parseCsvRules rulesfile s =
|
||||
runParser rulesp rules rulesfile s
|
||||
|
||||
-- | Return the validated rules, or an error.
|
||||
validateRules :: CsvRules -> Either String CsvRules
|
||||
validateRules :: CsvRules -> ErrorT String IO CsvRules
|
||||
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)) ||
|
||||
(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"
|
||||
Right rules
|
||||
$ 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"
|
||||
ErrorT $ return $ Right rules
|
||||
where
|
||||
amount = isAssigned "amount"
|
||||
amountin = isAssigned "amount-in"
|
||||
@ -370,14 +377,14 @@ validateRules rules = do
|
||||
|
||||
-- parsers
|
||||
|
||||
rulesp :: GenParser Char CsvRules CsvRules
|
||||
rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules
|
||||
rulesp = do
|
||||
many $ choice'
|
||||
[blankorcommentline <?> "blank or comment line"
|
||||
,(directive >>= updateState . addDirective) <?> "directive"
|
||||
,(fieldnamelist >>= updateState . setIndexesAndAssignmentsFromList) <?> "field name list"
|
||||
,(fieldassignment >>= updateState . addAssignment) <?> "field assignment"
|
||||
,(conditionalblock >>= updateState . addConditionalBlock) <?> "conditional block"
|
||||
,(directive >>= modifyState . addDirective) <?> "directive"
|
||||
,(fieldnamelist >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"
|
||||
,(fieldassignment >>= modifyState . addAssignment) <?> "field assignment"
|
||||
,(conditionalblock >>= modifyState . addConditionalBlock) <?> "conditional block"
|
||||
]
|
||||
eof
|
||||
r <- getState
|
||||
@ -386,11 +393,19 @@ rulesp = do
|
||||
,rconditionalblocks=reverse $ rconditionalblocks r
|
||||
}
|
||||
|
||||
blankorcommentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
||||
blankorcommentline = pdbg 3 "trying blankorcommentline" >> choice' [blankline, commentline]
|
||||
|
||||
blankline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
||||
blankline = many spacenonewline >> newline >> return () <?> "blank line"
|
||||
|
||||
commentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
||||
commentline = many spacenonewline >> commentchar >> restofline >> return () <?> "comment line"
|
||||
|
||||
commentchar :: Stream [Char] m t => ParsecT [Char] CsvRules m Char
|
||||
commentchar = oneOf ";#"
|
||||
|
||||
directive :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String)
|
||||
directive = do
|
||||
pdbg 3 "trying directive"
|
||||
d <- choice' $ map string directives
|
||||
@ -409,8 +424,10 @@ directives =
|
||||
-- ,"base-currency"
|
||||
]
|
||||
|
||||
directiveval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
directiveval = anyChar `manyTill` eolof
|
||||
|
||||
fieldnamelist :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]
|
||||
fieldnamelist = (do
|
||||
pdbg 3 "trying fieldnamelist"
|
||||
string "fields"
|
||||
@ -423,16 +440,20 @@ fieldnamelist = (do
|
||||
return $ map (map toLower) $ f:fs
|
||||
) <?> "field name list"
|
||||
|
||||
fieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
fieldname = quotedfieldname <|> barefieldname
|
||||
|
||||
quotedfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
quotedfieldname = do
|
||||
char '"'
|
||||
f <- many1 $ noneOf "\"\n:;#~"
|
||||
char '"'
|
||||
return f
|
||||
|
||||
barefieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
barefieldname = many1 $ noneOf " \t\n,;#~"
|
||||
|
||||
fieldassignment :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)
|
||||
fieldassignment = do
|
||||
pdbg 3 "trying fieldassignment"
|
||||
f <- journalfieldname
|
||||
@ -441,6 +462,7 @@ fieldassignment = do
|
||||
return (f,v)
|
||||
<?> "field assignment"
|
||||
|
||||
journalfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames)
|
||||
|
||||
journalfieldnames =
|
||||
@ -460,6 +482,7 @@ journalfieldnames =
|
||||
,"comment"
|
||||
]
|
||||
|
||||
assignmentseparator :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
||||
assignmentseparator = do
|
||||
pdbg 3 "trying assignmentseparator"
|
||||
choice [
|
||||
@ -467,12 +490,15 @@ assignmentseparator = do
|
||||
try (many spacenonewline >> char ':'),
|
||||
space
|
||||
]
|
||||
many spacenonewline
|
||||
_ <- many spacenonewline
|
||||
return ()
|
||||
|
||||
fieldval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
fieldval = do
|
||||
pdbg 2 "trying fieldval"
|
||||
anyChar `manyTill` eolof
|
||||
|
||||
conditionalblock :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock
|
||||
conditionalblock = do
|
||||
pdbg 3 "trying conditionalblock"
|
||||
string "if" >> many spacenonewline >> optional newline
|
||||
@ -483,6 +509,7 @@ conditionalblock = do
|
||||
return (ms, as)
|
||||
<?> "conditional block"
|
||||
|
||||
recordmatcher :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
|
||||
recordmatcher = do
|
||||
pdbg 2 "trying recordmatcher"
|
||||
-- pos <- currentPos
|
||||
@ -493,6 +520,7 @@ recordmatcher = do
|
||||
return ps
|
||||
<?> "record matcher"
|
||||
|
||||
matchoperator :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
matchoperator = choice' $ map string
|
||||
["~"
|
||||
-- ,"!~"
|
||||
@ -500,11 +528,13 @@ matchoperator = choice' $ map string
|
||||
-- ,"!="
|
||||
]
|
||||
|
||||
patterns :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
|
||||
patterns = do
|
||||
pdbg 3 "trying patterns"
|
||||
ps <- many regexp
|
||||
return ps
|
||||
|
||||
regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
||||
regexp = do
|
||||
pdbg 3 "trying regexp"
|
||||
notFollowedBy matchoperator
|
||||
|
@ -1,5 +1,6 @@
|
||||
-- {-# OPTIONS_GHC -F -pgmF htfpp #-}
|
||||
{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-}
|
||||
{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-|
|
||||
|
||||
A reader for hledger's journal file format
|
||||
@ -58,7 +59,7 @@ import Safe (headDef, lastDef)
|
||||
import Test.Framework
|
||||
import Text.Parsec.Error
|
||||
#endif
|
||||
import Text.ParserCombinators.Parsec hiding (parse)
|
||||
import Text.Parsec hiding (parse)
|
||||
import Text.Printf
|
||||
import System.FilePath
|
||||
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,
|
||||
-- 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
|
||||
tc <- liftIO getClockTime
|
||||
tl <- liftIO getCurrentLocalTime
|
||||
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
|
||||
j <- updates `ap` return nulljournal
|
||||
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 e -> throwError $ show e
|
||||
|
||||
setYear :: Integer -> GenParser tok JournalContext ()
|
||||
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
|
||||
setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()
|
||||
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
|
||||
|
||||
setDefaultCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext ()
|
||||
setDefaultCommodityAndStyle cs = updateState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs})
|
||||
setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m ()
|
||||
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
|
||||
|
||||
pushParentAccount :: String -> GenParser tok JournalContext ()
|
||||
pushParentAccount parent = updateState addParentAccount
|
||||
pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m ()
|
||||
pushParentAccount parent = modifyState addParentAccount
|
||||
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
|
||||
case ctxAccount ctx0 of
|
||||
[] -> unexpected "End of account block with no beginning"
|
||||
(_: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
|
||||
|
||||
addAccountAlias :: AccountAlias -> GenParser tok JournalContext ()
|
||||
addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
|
||||
addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m ()
|
||||
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
|
||||
|
||||
clearAccountAliases :: GenParser tok JournalContext ()
|
||||
clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
|
||||
clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
|
||||
clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
|
||||
|
||||
-- parsers
|
||||
|
||||
-- | Top-level journal parser. Returns a single composite, I/O performing,
|
||||
-- error-raising "JournalUpdate" (and final "JournalContext") which can be
|
||||
-- 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
|
||||
journalupdates <- many journalItem
|
||||
eof
|
||||
@ -168,7 +170,7 @@ journal = do
|
||||
] <?> "journal transaction or directive"
|
||||
|
||||
-- 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
|
||||
optional $ char '!'
|
||||
choice' [
|
||||
@ -186,7 +188,7 @@ directive = do
|
||||
]
|
||||
<?> "directive"
|
||||
|
||||
includedirective :: GenParser Char JournalContext JournalUpdate
|
||||
includedirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
includedirective = do
|
||||
string "include"
|
||||
many1 spacenonewline
|
||||
@ -194,36 +196,48 @@ includedirective = do
|
||||
outerState <- getState
|
||||
outerPos <- getPosition
|
||||
let curdir = takeDirectory (sourceName outerPos)
|
||||
return $ do filepath <- expandPath curdir filename
|
||||
txt <- readFileOrError outerPos filepath
|
||||
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
|
||||
case runParser journal outerState filepath txt of
|
||||
Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))
|
||||
Left err -> throwError $ inIncluded ++ show err
|
||||
where readFileOrError pos fp =
|
||||
let (u::ErrorT 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 journal 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 =
|
||||
ErrorT $ liftM Right (readFile' fp) `C.catch`
|
||||
\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 f j@Journal{files=fs} = j{files=fs++[f]}
|
||||
-- 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
|
||||
string "account"
|
||||
many1 spacenonewline
|
||||
parent <- accountnamep
|
||||
newline
|
||||
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
|
||||
string "end"
|
||||
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
|
||||
string "alias"
|
||||
many1 spacenonewline
|
||||
@ -234,13 +248,13 @@ aliasdirective = do
|
||||
,accountNameWithoutPostingType $ strip alias)
|
||||
return $ return id
|
||||
|
||||
endaliasesdirective :: GenParser Char JournalContext JournalUpdate
|
||||
endaliasesdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
endaliasesdirective = do
|
||||
string "end aliases"
|
||||
clearAccountAliases
|
||||
return (return id)
|
||||
|
||||
tagdirective :: GenParser Char JournalContext JournalUpdate
|
||||
tagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
tagdirective = do
|
||||
string "tag" <?> "tag directive"
|
||||
many1 spacenonewline
|
||||
@ -248,13 +262,13 @@ tagdirective = do
|
||||
restofline
|
||||
return $ return id
|
||||
|
||||
endtagdirective :: GenParser Char JournalContext JournalUpdate
|
||||
endtagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
endtagdirective = do
|
||||
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
|
||||
restofline
|
||||
return $ return id
|
||||
|
||||
defaultyeardirective :: GenParser Char JournalContext JournalUpdate
|
||||
defaultyeardirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
defaultyeardirective = do
|
||||
char 'Y' <?> "default year"
|
||||
many spacenonewline
|
||||
@ -264,7 +278,7 @@ defaultyeardirective = do
|
||||
setYear y'
|
||||
return $ return id
|
||||
|
||||
defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate
|
||||
defaultcommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
defaultcommoditydirective = do
|
||||
char 'D' <?> "default commodity"
|
||||
many1 spacenonewline
|
||||
@ -273,7 +287,7 @@ defaultcommoditydirective = do
|
||||
restofline
|
||||
return $ return id
|
||||
|
||||
historicalpricedirective :: GenParser Char JournalContext HistoricalPrice
|
||||
historicalpricedirective :: ParsecT [Char] JournalContext (ErrorT String IO) HistoricalPrice
|
||||
historicalpricedirective = do
|
||||
char 'P' <?> "historical price"
|
||||
many spacenonewline
|
||||
@ -285,7 +299,7 @@ historicalpricedirective = do
|
||||
restofline
|
||||
return $ HistoricalPrice date symbol price
|
||||
|
||||
ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate
|
||||
ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
ignoredpricecommoditydirective = do
|
||||
char 'N' <?> "ignored-price commodity"
|
||||
many1 spacenonewline
|
||||
@ -293,7 +307,7 @@ ignoredpricecommoditydirective = do
|
||||
restofline
|
||||
return $ return id
|
||||
|
||||
commodityconversiondirective :: GenParser Char JournalContext JournalUpdate
|
||||
commodityconversiondirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
|
||||
commodityconversiondirective = do
|
||||
char 'C' <?> "commodity conversion"
|
||||
many1 spacenonewline
|
||||
@ -305,7 +319,7 @@ commodityconversiondirective = do
|
||||
restofline
|
||||
return $ return id
|
||||
|
||||
modifiertransaction :: GenParser Char JournalContext ModifierTransaction
|
||||
modifiertransaction :: ParsecT [Char] JournalContext (ErrorT String IO) ModifierTransaction
|
||||
modifiertransaction = do
|
||||
char '=' <?> "modifier transaction"
|
||||
many spacenonewline
|
||||
@ -313,7 +327,7 @@ modifiertransaction = do
|
||||
postings <- postings
|
||||
return $ ModifierTransaction valueexpr postings
|
||||
|
||||
periodictransaction :: GenParser Char JournalContext PeriodicTransaction
|
||||
periodictransaction :: ParsecT [Char] JournalContext (ErrorT String IO) PeriodicTransaction
|
||||
periodictransaction = do
|
||||
char '~' <?> "periodic transaction"
|
||||
many spacenonewline
|
||||
@ -322,7 +336,7 @@ periodictransaction = do
|
||||
return $ PeriodicTransaction periodexpr postings
|
||||
|
||||
-- | Parse a (possibly unbalanced) transaction.
|
||||
transaction :: GenParser Char JournalContext Transaction
|
||||
transaction :: ParsecT [Char] JournalContext (ErrorT String IO) Transaction
|
||||
transaction = do
|
||||
-- ptrace "transaction"
|
||||
sourcepos <- getPosition
|
||||
@ -427,7 +441,7 @@ test_transaction = do
|
||||
|
||||
-- | 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.
|
||||
datep :: GenParser Char JournalContext Day
|
||||
datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day
|
||||
datep = do
|
||||
-- hacky: try to ensure precise errors for invalid dates
|
||||
-- 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
|
||||
-- digits are allowed, except in the timezone. The year may be omitted if
|
||||
-- a default year has already been set.
|
||||
datetimep :: GenParser Char JournalContext LocalTime
|
||||
datetimep :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime
|
||||
datetimep = do
|
||||
day <- datep
|
||||
many1 spacenonewline
|
||||
@ -480,7 +494,7 @@ datetimep = do
|
||||
-- return $ localTimeToUTC tz' $ 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
|
||||
char '='
|
||||
-- kludgy way to use primary date for default year
|
||||
@ -493,24 +507,24 @@ secondarydatep primarydate = do
|
||||
edate <- withDefaultYear primarydate datep
|
||||
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
|
||||
|
||||
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 ""
|
||||
|
||||
-- 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"
|
||||
|
||||
-- linebeginningwithspaces :: GenParser Char JournalContext String
|
||||
-- linebeginningwithspaces :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
|
||||
-- linebeginningwithspaces = do
|
||||
-- sp <- many1 spacenonewline
|
||||
-- c <- nonspace
|
||||
-- cs <- restofline
|
||||
-- return $ sp ++ (c:cs) ++ "\n"
|
||||
|
||||
postingp :: GenParser Char JournalContext Posting
|
||||
postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting
|
||||
postingp = do
|
||||
many1 spacenonewline
|
||||
status <- status
|
||||
@ -525,9 +539,27 @@ postingp = do
|
||||
comment <- try followingcommentp <|> (newline >> return "")
|
||||
let tags = tagsInComment comment
|
||||
-- oh boy
|
||||
d <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx datep `fmap` dateValueFromTags tags)
|
||||
d2 <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx datep `fmap` date2ValueFromTags tags)
|
||||
return posting{pdate=d, pdate2=d2, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags, pbalanceassertion=massertion}
|
||||
date <- case dateValueFromTags tags of
|
||||
Nothing -> return Nothing
|
||||
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
|
||||
test_postingp = do
|
||||
@ -577,7 +609,7 @@ test_postingp = do
|
||||
#endif
|
||||
|
||||
-- | 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
|
||||
a <- accountnamep
|
||||
prefix <- getParentAccount
|
||||
@ -589,7 +621,7 @@ modifiedaccountname = do
|
||||
-- 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
|
||||
-- separator char.
|
||||
accountnamep :: GenParser Char st AccountName
|
||||
accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName
|
||||
accountnamep = do
|
||||
a <- many1 (nonspace <|> singlespace)
|
||||
let a' = striptrailingspace a
|
||||
@ -607,7 +639,7 @@ accountnamep = do
|
||||
-- | Parse whitespace then an amount, with an optional left or right
|
||||
-- currency symbol and optional price, or return the special
|
||||
-- "missing" marker amount.
|
||||
spaceandamountormissing :: GenParser Char JournalContext MixedAmount
|
||||
spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount
|
||||
spaceandamountormissing =
|
||||
try (do
|
||||
many1 spacenonewline
|
||||
@ -631,7 +663,7 @@ test_spaceandamountormissing = do
|
||||
-- | Parse a single-commodity amount, with optional symbol on the left or
|
||||
-- right, optional unit or total price, and optional (ignored)
|
||||
-- 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
|
||||
|
||||
#ifdef TESTS
|
||||
@ -650,19 +682,22 @@ test_amountp = do
|
||||
|
||||
-- | Parse an amount from a string, or get an error.
|
||||
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.
|
||||
mamountp' :: String -> MixedAmount
|
||||
mamountp' = Mixed . (:[]) . amountp'
|
||||
|
||||
signp :: GenParser Char JournalContext String
|
||||
signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String
|
||||
signp = do
|
||||
sign <- optionMaybe $ oneOf "+-"
|
||||
return $ case sign of Just '-' -> "-"
|
||||
_ -> ""
|
||||
|
||||
leftsymbolamount :: GenParser Char JournalContext Amount
|
||||
leftsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
|
||||
leftsymbolamount = do
|
||||
sign <- signp
|
||||
c <- commoditysymbol
|
||||
@ -674,7 +709,7 @@ leftsymbolamount = do
|
||||
return $ applysign $ Amount c q p s
|
||||
<?> "left-symbol amount"
|
||||
|
||||
rightsymbolamount :: GenParser Char JournalContext Amount
|
||||
rightsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
|
||||
rightsymbolamount = do
|
||||
(q,prec,mdec,mgrps) <- numberp
|
||||
sp <- many spacenonewline
|
||||
@ -684,7 +719,7 @@ rightsymbolamount = do
|
||||
return $ Amount c q p s
|
||||
<?> "right-symbol amount"
|
||||
|
||||
nosymbolamount :: GenParser Char JournalContext Amount
|
||||
nosymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount
|
||||
nosymbolamount = do
|
||||
(q,prec,mdec,mgrps) <- numberp
|
||||
p <- priceamount
|
||||
@ -696,20 +731,20 @@ nosymbolamount = do
|
||||
return $ Amount c q p s
|
||||
<?> "no-symbol amount"
|
||||
|
||||
commoditysymbol :: GenParser Char JournalContext String
|
||||
commoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String
|
||||
commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"
|
||||
|
||||
quotedcommoditysymbol :: GenParser Char JournalContext String
|
||||
quotedcommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String
|
||||
quotedcommoditysymbol = do
|
||||
char '"'
|
||||
s <- many1 $ noneOf ";\n\""
|
||||
char '"'
|
||||
return s
|
||||
|
||||
simplecommoditysymbol :: GenParser Char JournalContext String
|
||||
simplecommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String
|
||||
simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)
|
||||
|
||||
priceamount :: GenParser Char JournalContext Price
|
||||
priceamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Price
|
||||
priceamount =
|
||||
try (do
|
||||
many spacenonewline
|
||||
@ -725,7 +760,7 @@ priceamount =
|
||||
return $ UnitPrice a))
|
||||
<|> return NoPrice
|
||||
|
||||
partialbalanceassertion :: GenParser Char JournalContext (Maybe MixedAmount)
|
||||
partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)
|
||||
partialbalanceassertion =
|
||||
try (do
|
||||
many spacenonewline
|
||||
@ -735,7 +770,7 @@ partialbalanceassertion =
|
||||
return $ Just $ Mixed [a])
|
||||
<|> return Nothing
|
||||
|
||||
-- balanceassertion :: GenParser Char JournalContext (Maybe MixedAmount)
|
||||
-- balanceassertion :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe MixedAmount)
|
||||
-- balanceassertion =
|
||||
-- try (do
|
||||
-- many spacenonewline
|
||||
@ -746,7 +781,7 @@ partialbalanceassertion =
|
||||
-- <|> return Nothing
|
||||
|
||||
-- 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 =
|
||||
try (do
|
||||
many spacenonewline
|
||||
@ -772,7 +807,7 @@ fixedlotprice =
|
||||
-- seen following the decimal point), the decimal point character used 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
|
||||
-- a number is an optional sign followed by a sequence of digits possibly
|
||||
-- interspersed with periods, commas, or both
|
||||
@ -848,7 +883,7 @@ test_numberp = do
|
||||
|
||||
-- comment parsers
|
||||
|
||||
multilinecommentp :: GenParser Char JournalContext ()
|
||||
multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
|
||||
multilinecommentp = do
|
||||
string "comment" >> newline
|
||||
go
|
||||
@ -857,25 +892,25 @@ multilinecommentp = do
|
||||
<|> (anyLine >> go)
|
||||
anyLine = anyChar `manyTill` newline
|
||||
|
||||
emptyorcommentlinep :: GenParser Char JournalContext ()
|
||||
emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()
|
||||
emptyorcommentlinep = do
|
||||
many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return ""))
|
||||
return ()
|
||||
|
||||
followingcommentp :: GenParser Char JournalContext String
|
||||
followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
|
||||
followingcommentp =
|
||||
-- ptrace "followingcommentp"
|
||||
do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
|
||||
newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
|
||||
return $ unlines $ samelinecomment:newlinecomments
|
||||
|
||||
comment :: GenParser Char JournalContext String
|
||||
comment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
|
||||
comment = commentStartingWith "#;"
|
||||
|
||||
semicoloncomment :: GenParser Char JournalContext String
|
||||
semicoloncomment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String
|
||||
semicoloncomment = commentStartingWith ";"
|
||||
|
||||
commentStartingWith :: String -> GenParser Char JournalContext String
|
||||
commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String
|
||||
commentStartingWith cs = do
|
||||
-- ptrace "commentStartingWith"
|
||||
oneOf cs
|
||||
@ -892,7 +927,7 @@ tagsInComment c = concatMap tagsInCommentLine $ lines c'
|
||||
tagsInCommentLine :: String -> [Tag]
|
||||
tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
|
||||
where
|
||||
maybetag s = case parseWithCtx nullctx tag s of
|
||||
maybetag s = case runParser tag nullctx "" s of
|
||||
Right t -> Just t
|
||||
Left _ -> Nothing
|
||||
|
||||
|
@ -51,7 +51,7 @@ import Control.Monad
|
||||
import Control.Monad.Error
|
||||
import Data.List (isPrefixOf)
|
||||
import Test.HUnit
|
||||
import Text.ParserCombinators.Parsec hiding (parse)
|
||||
import Text.Parsec hiding (parse)
|
||||
import System.FilePath
|
||||
|
||||
import Hledger.Data
|
||||
@ -81,7 +81,7 @@ detect f s
|
||||
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
|
||||
parse _ = parseJournalWith timelogFile
|
||||
|
||||
timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)
|
||||
timelogFile :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate, JournalContext)
|
||||
timelogFile = do items <- many timelogItem
|
||||
eof
|
||||
ctx <- getState
|
||||
@ -98,7 +98,7 @@ timelogFile = do items <- many timelogItem
|
||||
] <?> "timelog entry, or default year or historical price directive"
|
||||
|
||||
-- | Parse a timelog entry.
|
||||
timelogentry :: GenParser Char JournalContext TimeLogEntry
|
||||
timelogentry :: ParsecT [Char] JournalContext (ErrorT String IO) TimeLogEntry
|
||||
timelogentry = do
|
||||
sourcepos <- getPosition
|
||||
code <- oneOf "bhioO"
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-|
|
||||
|
||||
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.IO
|
||||
import Test.HUnit
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Text.Parsec
|
||||
import Text.Printf
|
||||
-- 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.
|
||||
-- Consumes no input if all choices fail.
|
||||
choice' :: [GenParser tok st a] -> GenParser tok st a
|
||||
choice' = choice . map Text.ParserCombinators.Parsec.try
|
||||
choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
|
||||
choice' = choice . map Text.Parsec.try
|
||||
|
||||
parsewith :: Parser a -> String -> Either ParseError a
|
||||
parsewith p = parse p ""
|
||||
parsewith :: Parsec [Char] () a -> String -> Either ParseError a
|
||||
parsewith p = runParser p () ""
|
||||
|
||||
parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a
|
||||
parseWithCtx ctx p = runParser p ctx ""
|
||||
parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a)
|
||||
parseWithCtx ctx p = runParserT p ctx ""
|
||||
|
||||
fromparse :: Either ParseError a -> a
|
||||
fromparse = either parseerror id
|
||||
@ -354,16 +355,16 @@ showParseError e = "parse error at " ++ show e
|
||||
showDateParseError :: ParseError -> String
|
||||
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)
|
||||
|
||||
spacenonewline :: GenParser Char st Char
|
||||
spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char
|
||||
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
|
||||
|
||||
eolof :: GenParser Char st ()
|
||||
eolof :: (Stream [Char] m Char) => ParsecT [Char] st m ()
|
||||
eolof = (newline >> return ()) <|> eof
|
||||
|
||||
-- time
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, FlexibleContexts #-}
|
||||
-- | Debugging helpers
|
||||
|
||||
-- more:
|
||||
@ -23,7 +23,7 @@ import Safe (readDef)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Text.Parsec
|
||||
import Text.Printf
|
||||
|
||||
#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,
|
||||
-- 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
|
||||
pos <- getPosition
|
||||
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
|
||||
-- this level. Uses unsafePerformIO.
|
||||
-- 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
|
||||
|
||||
|
||||
|
@ -95,7 +95,7 @@ library
|
||||
,mtl
|
||||
,old-locale
|
||||
,old-time
|
||||
,parsec
|
||||
,parsec >= 3
|
||||
,regex-tdfa
|
||||
,regexpr >= 0.5.1
|
||||
,safe >= 0.2
|
||||
@ -130,7 +130,7 @@ test-suite tests
|
||||
, mtl
|
||||
, old-locale
|
||||
, old-time
|
||||
, parsec
|
||||
, parsec >= 3
|
||||
, regex-tdfa
|
||||
, regexpr
|
||||
, safe
|
||||
|
@ -10,7 +10,7 @@ import Data.List (intercalate, sort)
|
||||
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
|
||||
import Data.Text (unpack)
|
||||
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 Hledger.Utils
|
||||
@ -64,7 +64,7 @@ handleAdd = do
|
||||
map fst amtparams `elem` [[1..num], [1..num-1]] = []
|
||||
| otherwise = ["malformed account/amount parameters"]
|
||||
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)
|
||||
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
|
||||
amts | length amts' == num = amts'
|
||||
|
@ -137,7 +137,7 @@ library
|
||||
, network-conduit
|
||||
, conduit-extra
|
||||
, old-locale
|
||||
, parsec
|
||||
, parsec >= 3
|
||||
, regexpr >= 0.5.1
|
||||
, safe >= 0.2
|
||||
, shakespeare >= 2.0
|
||||
@ -208,7 +208,7 @@ executable hledger-web
|
||||
, network-conduit
|
||||
, conduit-extra
|
||||
, old-locale
|
||||
, parsec
|
||||
, parsec >= 3
|
||||
, regexpr >= 0.5.1
|
||||
, safe >= 0.2
|
||||
, shakespeare >= 2.0 && < 2.1
|
||||
|
@ -23,7 +23,7 @@ import System.Console.Haskeline.Completion
|
||||
import System.Console.Wizard
|
||||
import System.Console.Wizard.Haskeline
|
||||
import System.IO ( stderr, hPutStr, hPutStrLn )
|
||||
import Text.ParserCombinators.Parsec hiding (Line)
|
||||
import Text.Parsec
|
||||
import Text.Printf
|
||||
|
||||
import Hledger
|
||||
@ -178,7 +178,8 @@ dateAndCodeWizard EntryState{..} = do
|
||||
where
|
||||
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
|
||||
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
|
||||
d <- smartdate
|
||||
c <- optionMaybe codep
|
||||
@ -241,7 +242,7 @@ accountWizard EntryState{..} = do
|
||||
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 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
|
||||
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
|
||||
| otherwise = Just s
|
||||
@ -265,8 +266,9 @@ amountAndCommentWizard EntryState{..} = do
|
||||
maybeRestartTransaction $
|
||||
line $ green $ printf "Amount %d%s: " pnum (showDefault def)
|
||||
where
|
||||
parseAmountAndComment = either (const Nothing) Just . parseWithCtx nodefcommodityctx amountandcommentp
|
||||
parseAmountAndComment = either (const Nothing) Just . runParser amountandcommentp nodefcommodityctx ""
|
||||
nodefcommodityctx = (jContext esJournal){ctxDefaultCommodityAndStyle=Nothing}
|
||||
amountandcommentp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Amount, String)
|
||||
amountandcommentp = do
|
||||
a <- amountp
|
||||
many spacenonewline
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-|
|
||||
|
||||
Common cmdargs modes and flags, a command-line options type, and
|
||||
@ -74,7 +75,7 @@ import System.Environment
|
||||
import System.Exit (exitSuccess)
|
||||
import System.FilePath
|
||||
import Test.HUnit
|
||||
import Text.ParserCombinators.Parsec as P
|
||||
import Text.Parsec
|
||||
|
||||
import Hledger
|
||||
import Hledger.Data.OutputFormat as OutputFormat
|
||||
@ -453,14 +454,14 @@ parseWidth s = case (runParser outputwidthp () "(unknown)") s of
|
||||
Left e -> Left $ show e
|
||||
Right x -> Right x
|
||||
|
||||
outputwidthp :: GenParser Char st OutputWidth
|
||||
outputwidthp :: Stream [Char] m t => ParsecT [Char] st m OutputWidth
|
||||
outputwidthp =
|
||||
try (do w <- widthp
|
||||
ws <- many1 (char ',' >> widthp)
|
||||
return $ FieldWidths $ w:ws)
|
||||
<|> TotalWidth `fmap` widthp
|
||||
|
||||
widthp :: GenParser Char st Width
|
||||
widthp :: Stream [Char] m t => ParsecT [Char] st m Width
|
||||
widthp = (string "auto" >> return Auto)
|
||||
<|> (Width . read) `fmap` many1 digit
|
||||
|
||||
|
@ -79,7 +79,7 @@ library
|
||||
,mtl
|
||||
,old-locale
|
||||
,old-time
|
||||
,parsec
|
||||
,parsec >= 3
|
||||
,process
|
||||
,regex-tdfa
|
||||
,regexpr >= 0.5.1
|
||||
@ -129,7 +129,7 @@ executable hledger
|
||||
,mtl
|
||||
,old-locale
|
||||
,old-time
|
||||
,parsec
|
||||
,parsec >= 3
|
||||
,process
|
||||
,regex-tdfa
|
||||
,regexpr >= 0.5.1
|
||||
@ -168,7 +168,7 @@ test-suite tests
|
||||
, mtl
|
||||
, old-locale
|
||||
, old-time
|
||||
, parsec
|
||||
, parsec >= 3
|
||||
, process
|
||||
, regex-tdfa
|
||||
, regexpr
|
||||
|
Loading…
Reference in New Issue
Block a user