From cf28985cf240ae357c18d58752e2793422b0a400 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 3 Nov 2014 06:52:12 +0100 Subject: [PATCH] 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 --- extra/hledger-rewrite.hs | 6 +- hledger-lib/Hledger/Data/Dates.hs | 50 +++--- hledger-lib/Hledger/Data/OutputFormat.hs | 13 +- hledger-lib/Hledger/Query.hs | 3 +- hledger-lib/Hledger/Read.hs | 3 +- hledger-lib/Hledger/Read/CsvReader.hs | 72 +++++--- hledger-lib/Hledger/Read/JournalReader.hs | 195 +++++++++++++--------- hledger-lib/Hledger/Read/TimelogReader.hs | 6 +- hledger-lib/Hledger/Utils.hs | 23 +-- hledger-lib/Hledger/Utils/Debug.hs | 7 +- hledger-lib/hledger-lib.cabal | 4 +- hledger-web/Handler/Post.hs | 4 +- hledger-web/hledger-web.cabal | 4 +- hledger/Hledger/Cli/Add.hs | 10 +- hledger/Hledger/Cli/Options.hs | 7 +- hledger/hledger.cabal | 6 +- 16 files changed, 244 insertions(+), 169 deletions(-) diff --git a/extra/hledger-rewrite.hs b/extra/hledger-rewrite.hs index 2b51e1a56..fe1833966 100755 --- a/extra/hledger-rewrite.hs +++ b/extra/hledger-rewrite.hs @@ -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 diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 8e3d798ce..0ff8dd4c3 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -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 diff --git a/hledger-lib/Hledger/Data/OutputFormat.hs b/hledger-lib/Hledger/Data/OutputFormat.hs index bd24cc4e9..de55aca21 100644 --- a/hledger-lib/Hledger/Data/OutputFormat.hs +++ b/hledger-lib/Hledger/Data/OutputFormat.hs @@ -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 diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index 469d44741..fe9b14b70 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -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 diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index e7a7df639..d329b2ec6 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index f8000d800..0a2e4b502 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index a3f8c25c5..7bbe7bcf4 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/TimelogReader.hs b/hledger-lib/Hledger/Read/TimelogReader.hs index f425e34d2..bac5a0b32 100644 --- a/hledger-lib/Hledger/Read/TimelogReader.hs +++ b/hledger-lib/Hledger/Read/TimelogReader.hs @@ -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" diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index 73465c054..0b74ed4e3 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -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 diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index e59fb3cef..97b328b20 100644 --- a/hledger-lib/Hledger/Utils/Debug.hs +++ b/hledger-lib/Hledger/Utils/Debug.hs @@ -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 diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index bba7d59af..fc83291ef 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -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 diff --git a/hledger-web/Handler/Post.hs b/hledger-web/Handler/Post.hs index 8e50784b2..7b8b07c9b 100644 --- a/hledger-web/Handler/Post.hs +++ b/hledger-web/Handler/Post.hs @@ -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' diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 6bdef4680..a45118eca 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -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 diff --git a/hledger/Hledger/Cli/Add.hs b/hledger/Hledger/Cli/Add.hs index 55b387862..88c2b7e92 100644 --- a/hledger/Hledger/Cli/Add.hs +++ b/hledger/Hledger/Cli/Add.hs @@ -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 diff --git a/hledger/Hledger/Cli/Options.hs b/hledger/Hledger/Cli/Options.hs index 68111fe66..50a7bd67a 100644 --- a/hledger/Hledger/Cli/Options.hs +++ b/hledger/Hledger/Cli/Options.hs @@ -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 diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 45911592a..80494ce9c 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -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