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
-- 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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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.
-}
{-# 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

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

@ -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

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

@ -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"

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
@ -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

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

@ -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

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

@ -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

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 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'

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

@ -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

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.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

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

@ -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

6
hledger/hledger.cabal
View File

@ -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