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

Merge pull request #880 from awjchen/ExceptTLayer

Browse Source 
Re-implement the 'ExceptT' layer of the parser and switch to megaparsec 7 [WIP]
This commit is contained in:
Simon Michael 2018-10-09 10:33:21 -10:00 committed by GitHub
commit 0f921bfbe0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
30 changed files with 588 additions and 360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -77,6 +77,7 @@ where
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat import "base-compat-batteries" Prelude.Compat
import Control.Applicative.Permutations
import Control.Monad import Control.Monad
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import Data.Default import Data.Default
@ -96,7 +97,7 @@ import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay) import Safe (headMay, lastMay, readMay)
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Text.Megaparsec.Perm import Text.Megaparsec.Custom
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
@ -314,13 +315,14 @@ earliest (Just d1) (Just d2) = Just $ min d1 d2
-- | Parse a period expression to an Interval and overall DateSpan using -- | Parse a period expression to an Interval and overall DateSpan using
-- the provided reference date, or return a parse error. -- the provided reference date, or return a parse error.
parsePeriodExpr :: Day -> Text -> Either (ParseError Char CustomErr) (Interval, DateSpan) parsePeriodExpr
:: Day -> Text -> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s) parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)
-- | Like parsePeriodExpr, but call error' on failure. -- | Like parsePeriodExpr, but call error' on failure.
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan) parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' refdate s = parsePeriodExpr' refdate s =
either (error' . ("failed to parse:" ++) . parseErrorPretty) id $ either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $
parsePeriodExpr refdate s parsePeriodExpr refdate s
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
@ -380,13 +382,14 @@ fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e)) (\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id id
$ (fixSmartDateStrEither d s :: Either (ParseError Char CustomErr) String) $ (fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)
-- | A safe version of fixSmartDateStr. -- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char CustomErr) String fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char CustomErr) Day fixSmartDateStrEither'
:: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
Right sd -> Right $ fixSmartDate d sd Right sd -> Right $ fixSmartDate d sd
Left e -> Left e Left e -> Left e
@ -987,7 +990,9 @@ reportingintervalp = choice' [
return $ DayOfMonth n, return $ DayOfMonth n,
do string' "every" do string' "every"
let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m) let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m)
d_o_y <- makePermParser $ DayOfYear <$$> try (skipMany spacenonewline *> mnth) <||> try (skipMany spacenonewline *> nth) d_o_y <- runPermutation $
DayOfYear <$> toPermutation (try (skipMany spacenonewline *> mnth))
<*> toPermutation (try (skipMany spacenonewline *> nth))
optOf_ "year" optOf_ "year"
return d_o_y, return d_o_y,
do string' "every" do string' "every"

6
hledger-lib/Hledger/Data/Journal.hs
View File

@ -163,6 +163,7 @@ instance Sem.Semigroup Journal where
,jparsealiases = jparsealiases j2 ,jparsealiases = jparsealiases j2
-- ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2 -- ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2
,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2 ,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2
,jincludefilestack = jincludefilestack j2
,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2 ,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2
,jcommodities = jcommodities j1 <> jcommodities j2 ,jcommodities = jcommodities j1 <> jcommodities j2
,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2 ,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2
@ -189,8 +190,9 @@ nulljournal = Journal {
,jparseparentaccounts = [] ,jparseparentaccounts = []
,jparsealiases = [] ,jparsealiases = []
-- ,jparsetransactioncount = 0 -- ,jparsetransactioncount = 0
,jparsetimeclockentries = [] ,jparsetimeclockentries = []
,jdeclaredaccounts = [] ,jincludefilestack = []
,jdeclaredaccounts = []
,jcommodities = M.fromList [] ,jcommodities = M.fromList []
,jinferredcommodities = M.fromList [] ,jinferredcommodities = M.fromList []
,jmarketprices = [] ,jmarketprices = []

1
hledger-lib/Hledger/Data/Types.hs
View File

@ -366,6 +366,7 @@ data Journal = Journal {
,jparsealiases :: [AccountAlias] -- ^ the current account name aliases in effect, specified by alias directives (& options ?) ,jparsealiases :: [AccountAlias] -- ^ the current account name aliases in effect, specified by alias directives (& options ?)
-- ,jparsetransactioncount :: Integer -- ^ the current count of transactions parsed so far (only journal format txns, currently) -- ,jparsetransactioncount :: Integer -- ^ the current count of transactions parsed so far (only journal format txns, currently)
,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out ,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out
,jincludefilestack :: [FilePath]
-- principal data -- principal data
,jdeclaredaccounts :: [AccountName] -- ^ Accounts declared by account directives, in parse order (after journal finalisation) ,jdeclaredaccounts :: [AccountName] -- ^ Accounts declared by account directives, in parse order (after journal finalisation)
,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives ,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives

142
hledger-lib/Hledger/Read/Common.hs
View File

@ -29,10 +29,13 @@ module Hledger.Read.Common (
rtp, rtp,
runJournalParser, runJournalParser,
rjp, rjp,
runErroringJournalParser,
rejp,
genericSourcePos, genericSourcePos,
journalSourcePos, journalSourcePos,
applyTransactionModifiers, applyTransactionModifiers,
parseAndFinaliseJournal, parseAndFinaliseJournal,
parseAndFinaliseJournal',
setYear, setYear,
getYear, getYear,
setDefaultCommodityAndStyle, setDefaultCommodityAndStyle,
@ -99,7 +102,7 @@ where
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile) import "base-compat-batteries" Prelude.Compat hiding (readFile)
import "base-compat-batteries" Control.Monad.Compat import "base-compat-batteries" Control.Monad.Compat
import Control.Monad.Except (ExceptT(..), throwError) import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Bifunctor (bimap, second) import Data.Bifunctor (bimap, second)
import Data.Char import Data.Char
@ -191,15 +194,28 @@ rawOptsToInputOpts rawopts = InputOpts{
--- * parsing utilities --- * parsing utilities
-- | Run a text parser in the identity monad. See also: parseWithState. -- | Run a text parser in the identity monad. See also: parseWithState.
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char CustomErr) a runTextParser, rtp
:: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser p t = runParser p "" t runTextParser p t = runParser p "" t
rtp = runTextParser rtp = runTextParser
-- | Run a journal parser in some monad. See also: parseWithState. -- | Run a journal parser in some monad. See also: parseWithState.
runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either (ParseError Char CustomErr) a) runJournalParser, rjp
:: Monad m
=> JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
runJournalParser p t = runParserT (evalStateT p mempty) "" t runJournalParser p t = runParserT (evalStateT p mempty) "" t
rjp = runJournalParser rjp = runJournalParser
-- | Run an erroring journal parser in some monad. See also: parseWithState.
runErroringJournalParser, rejp
:: Monad m
=> ErroringJournalParser m a
-> Text
-> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
runErroringJournalParser p t =
runExceptT $ runParserT (evalStateT p mempty) "" t
rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p) genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)
@ -221,19 +237,46 @@ applyTransactionModifiers j = j { jtxns = map applyallmodifiers $ jtxns j }
-- | Given a megaparsec ParsedJournal parser, input options, file -- | Given a megaparsec ParsedJournal parser, input options, file
-- path and file content: parse and post-process a Journal, or give an error. -- path and file content: parse and post-process a Journal, or give an error.
parseAndFinaliseJournal :: JournalParser IO ParsedJournal -> InputOpts parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
-> FilePath -> Text -> ExceptT String IO Journal -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal parser iopts f txt = do parseAndFinaliseJournal parser iopts f txt = do
t <- liftIO getClockTime t <- liftIO getClockTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
ep <- liftIO $ runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt let initJournal = nulljournal
{ jparsedefaultyear = Just y
, jincludefilestack = [f] }
eep <- liftIO $ runExceptT $
runParserT (evalStateT parser initJournal) f txt
case eep of
Left finalParseError ->
throwError $ finalErrorBundlePretty $ attachSource f txt finalParseError
Right ep -> case ep of
Left e -> throwError $ customErrorBundlePretty e
Right pj ->
let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in
case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of
Right j -> return j
Left e -> throwError e
parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts
-> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal' parser iopts f txt = do
t <- liftIO getClockTime
y <- liftIO getCurrentYear
let initJournal = nulljournal
{ jparsedefaultyear = Just y
, jincludefilestack = [f] }
ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt
case ep of case ep of
Left e -> throwError $ customErrorBundlePretty e
Right pj -> Right pj ->
let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in
case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of
Right j -> return j Right j -> return j
Left e -> throwError e Left e -> throwError e
Left e -> throwError $ customParseErrorPretty txt e
setYear :: Year -> JournalParser m () setYear :: Year -> JournalParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
@ -345,43 +388,43 @@ datep = do
datep' :: Maybe Year -> TextParser m Day datep' :: Maybe Year -> TextParser m Day
datep' mYear = do datep' mYear = do
startPos <- getPosition startOffset <- getOffset
d1 <- decimal <?> "year or month" d1 <- decimal <?> "year or month"
sep <- satisfy isDateSepChar <?> "date separator" sep <- satisfy isDateSepChar <?> "date separator"
d2 <- decimal <?> "month or day" d2 <- decimal <?> "month or day"
fullDate startPos d1 sep d2 <|> partialDate startPos mYear d1 sep d2 fullDate startOffset d1 sep d2 <|> partialDate startOffset mYear d1 sep d2
<?> "full or partial date" <?> "full or partial date"
where where
fullDate :: SourcePos -> Integer -> Char -> Int -> TextParser m Day fullDate :: Int -> Integer -> Char -> Int -> TextParser m Day
fullDate startPos year sep1 month = do fullDate startOffset year sep1 month = do
sep2 <- satisfy isDateSepChar <?> "date separator" sep2 <- satisfy isDateSepChar <?> "date separator"
day <- decimal <?> "day" day <- decimal <?> "day"
endPos <- getPosition endOffset <- getOffset
let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day
when (sep1 /= sep2) $ parseErrorAtRegion startPos endPos $ when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startOffset endOffset $
"invalid date (mixing date separators is not allowed): " ++ dateStr "invalid date (mixing date separators is not allowed): " ++ dateStr
case fromGregorianValid year month day of case fromGregorianValid year month day of
Nothing -> parseErrorAtRegion startPos endPos $ Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"well-formed but invalid date: " ++ dateStr "well-formed but invalid date: " ++ dateStr
Just date -> pure $! date Just date -> pure $! date
partialDate partialDate
:: SourcePos -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day :: Int -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day
partialDate startPos mYear month sep day = do partialDate startOffset mYear month sep day = do
endPos <- getPosition endOffset <- getOffset
case mYear of case mYear of
Just year -> Just year ->
case fromGregorianValid year (fromIntegral month) day of case fromGregorianValid year (fromIntegral month) day of
Nothing -> parseErrorAtRegion startPos endPos $ Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"well-formed but invalid date: " ++ dateStr "well-formed but invalid date: " ++ dateStr
Just date -> pure $! date Just date -> pure $! date
where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day
Nothing -> parseErrorAtRegion startPos endPos $ Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"partial date "++dateStr++" found, but the current year is unknown" "partial date "++dateStr++" found, but the current year is unknown"
where dateStr = show month ++ [sep] ++ show day where dateStr = show month ++ [sep] ++ show day
@ -409,26 +452,27 @@ datetimep' mYear = do
where where
timeOfDay :: TextParser m TimeOfDay timeOfDay :: TextParser m TimeOfDay
timeOfDay = do timeOfDay = do
pos1 <- getPosition off1 <- getOffset
h' <- twoDigitDecimal <?> "hour" h' <- twoDigitDecimal <?> "hour"
pos2 <- getPosition off2 <- getOffset
unless (h' >= 0 && h' <= 23) $ parseErrorAtRegion pos1 pos2 unless (h' >= 0 && h' <= 23) $ customFailure $
"invalid time (bad hour)" parseErrorAtRegion off1 off2 "invalid time (bad hour)"
char ':' <?> "':' (hour-minute separator)" char ':' <?> "':' (hour-minute separator)"
pos3 <- getPosition off3 <- getOffset
m' <- twoDigitDecimal <?> "minute" m' <- twoDigitDecimal <?> "minute"
pos4 <- getPosition off4 <- getOffset
unless (m' >= 0 && m' <= 59) $ parseErrorAtRegion pos3 pos4 unless (m' >= 0 && m' <= 59) $ customFailure $
"invalid time (bad minute)" parseErrorAtRegion off3 off4 "invalid time (bad minute)"
s' <- option 0 $ do s' <- option 0 $ do
char ':' <?> "':' (minute-second separator)" char ':' <?> "':' (minute-second separator)"
pos5 <- getPosition off5 <- getOffset
s' <- twoDigitDecimal <?> "second" s' <- twoDigitDecimal <?> "second"
pos6 <- getPosition off6 <- getOffset
unless (s' >= 0 && s' <= 59) $ parseErrorAtRegion pos5 pos6 unless (s' >= 0 && s' <= 59) $ customFailure $
"invalid time (bad second)" -- we do not support leap seconds parseErrorAtRegion off5 off6 "invalid time (bad second)"
-- we do not support leap seconds
pure s' pure s'
pure $ TimeOfDay h' m' (fromIntegral s') pure $ TimeOfDay h' m' (fromIntegral s')
@ -524,22 +568,22 @@ amountwithoutpricep = do
suggestedStyle <- getAmountStyle c suggestedStyle <- getAmountStyle c
commodityspaced <- lift $ skipMany' spacenonewline commodityspaced <- lift $ skipMany' spacenonewline
sign2 <- lift $ signp sign2 <- lift $ signp
posBeforeNum <- getPosition offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp mExponent <- lift $ optional $ try exponentp
posAfterNum <- getPosition offAfterNum <- getOffset
let numRegion = (posBeforeNum, posAfterNum) let numRegion = (offBeforeNum, offAfterNum)
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return $ Amount c (sign (sign2 q)) NoPrice s mult return $ Amount c (sign (sign2 q)) NoPrice s mult
rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
rightornosymbolamountp mult sign = label "amount" $ do rightornosymbolamountp mult sign = label "amount" $ do
posBeforeNum <- getPosition offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp mExponent <- lift $ optional $ try exponentp
posAfterNum <- getPosition offAfterNum <- getOffset
let numRegion = (posBeforeNum, posAfterNum) let numRegion = (offBeforeNum, offAfterNum)
mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipMany' spacenonewline <*> commoditysymbolp mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipMany' spacenonewline <*> commoditysymbolp
case mSpaceAndCommodity of case mSpaceAndCommodity of
-- right symbol amount -- right symbol amount
@ -563,7 +607,7 @@ amountwithoutpricep = do
-- For reducing code duplication. Doesn't parse anything. Has the type -- For reducing code duplication. Doesn't parse anything. Has the type
-- of a parser only in order to throw parse errors (for convenience). -- of a parser only in order to throw parse errors (for convenience).
interpretNumber interpretNumber
:: (SourcePos, SourcePos) :: (Int, Int) -- offsets
-> Maybe AmountStyle -> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber -> Either AmbiguousNumber RawNumber
-> Maybe Int -> Maybe Int
@ -571,7 +615,8 @@ amountwithoutpricep = do
interpretNumber posRegion suggestedStyle ambiguousNum mExp = interpretNumber posRegion suggestedStyle ambiguousNum mExp =
let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum
in case fromRawNumber rawNum mExp of in case fromRawNumber rawNum mExp of
Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg Left errMsg -> customFailure $
uncurry parseErrorAtRegion posRegion errMsg
Right res -> pure res Right res -> pure res
-- | Parse an amount from a string, or get an error. -- | Parse an amount from a string, or get an error.
@ -629,7 +674,7 @@ partialbalanceassertionp :: JournalParser m BalanceAssertion
partialbalanceassertionp = optional $ do partialbalanceassertionp = optional $ do
sourcepos <- try $ do sourcepos <- try $ do
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
sourcepos <- genericSourcePos <$> lift getPosition sourcepos <- genericSourcePos <$> lift getSourcePos
char '=' char '='
pure sourcepos pure sourcepos
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
@ -788,9 +833,10 @@ rawnumberp = label "number" $ do
fail "invalid number (invalid use of separator)" fail "invalid number (invalid use of separator)"
mExtraFragment <- optional $ lookAhead $ try $ mExtraFragment <- optional $ lookAhead $ try $
char ' ' *> getPosition <* digitChar char ' ' *> getOffset <* digitChar
case mExtraFragment of case mExtraFragment of
Just pos -> parseErrorAt pos "invalid number (excessive trailing digits)" Just off -> customFailure $
parseErrorAt off "invalid number (excessive trailing digits)"
Nothing -> pure () Nothing -> pure ()
return $ dbg8 "rawnumberp" rawNumber return $ dbg8 "rawnumberp" rawNumber
@ -1150,19 +1196,19 @@ commenttagsanddatesp mYear = do
-- default date is provided. A missing year in DATE2 will be inferred -- default date is provided. A missing year in DATE2 will be inferred
-- from DATE. -- from DATE.
-- --
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]" -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]"
-- Right [("date",2016-01-02),("date2",2016-03-04)] -- Right [("date",2016-01-02),("date2",2016-03-04)]
-- --
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]" -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]"
-- Left ...not a bracketed date... -- Left ...not a bracketed date...
-- --
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]" -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"
-- Left ...1:11:...well-formed but invalid date: 2016/1/32... -- Left ...1:2:...well-formed but invalid date: 2016/1/32...
-- --
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]" -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"
-- Left ...1:6:...partial date 1/31 found, but the current year is unknown... -- Left ...1:2:...partial date 1/31 found, but the current year is unknown...
-- --
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
-- Left ...1:13:...expecting month or day... -- Left ...1:13:...expecting month or day...
-- --
bracketeddatetagsp bracketeddatetagsp

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

@ -38,7 +38,6 @@ import Control.Monad.Except
import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Control.Monad.State.Strict (StateT, get, modify', evalStateT)
import Data.Char (toLower, isDigit, isSpace, ord) import Data.Char (toLower, isDigit, isSpace, ord)
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import Data.List.NonEmpty (fromList)
import Data.Maybe import Data.Maybe
import Data.Ord import Data.Ord
import qualified Data.Set as S import qualified Data.Set as S
@ -59,12 +58,12 @@ import System.FilePath
import qualified Data.Csv as Cassava import qualified Data.Csv as Cassava
import qualified Data.Csv.Parser.Megaparsec as CassavaMP import qualified Data.Csv.Parser.Megaparsec as CassavaMP
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.ByteString.Lazy (fromStrict) import qualified Data.ByteString.Lazy as BL
import Data.Foldable import Data.Foldable
import Text.Megaparsec hiding (parse) import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Text.Megaparsec.Custom
import Text.Printf (printf) import Text.Printf (printf)
import Data.Word
import Hledger.Data import Hledger.Data
import Hledger.Utils import Hledger.Utils
@ -76,7 +75,7 @@ type Record = [Field]
type Field = String type Field = String
data CSVError = CSVError (ParseError Word8 CassavaMP.ConversionError) data CSVError = CSVError (ParseErrorBundle BL.ByteString CassavaMP.ConversionError)
deriving Show deriving Show
reader :: Reader reader :: Reader
@ -193,7 +192,7 @@ parseCassava separator path content =
Left msg -> Left $ CSVError msg Left msg -> Left $ CSVError msg
Right a -> Right a Right a -> Right a
where parseResult = fmap parseResultToCsv $ CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path lazyContent where parseResult = fmap parseResultToCsv $ CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path lazyContent
lazyContent = fromStrict $ T.encodeUtf8 content lazyContent = BL.fromStrict $ T.encodeUtf8 content
decodeOptions :: Char -> Cassava.DecodeOptions decodeOptions :: Char -> Cassava.DecodeOptions
decodeOptions separator = Cassava.defaultDecodeOptions { decodeOptions separator = Cassava.defaultDecodeOptions {
@ -431,19 +430,19 @@ parseAndValidateCsvRules :: FilePath -> T.Text -> ExceptT String IO CsvRules
parseAndValidateCsvRules rulesfile s = do parseAndValidateCsvRules rulesfile s = do
let rules = parseCsvRules rulesfile s let rules = parseCsvRules rulesfile s
case rules of case rules of
Left e -> ExceptT $ return $ Left $ parseErrorPretty e Left e -> ExceptT $ return $ Left $ customErrorBundlePretty e
Right r -> do Right r -> do
r_ <- liftIO $ runExceptT $ validateRules r r_ <- liftIO $ runExceptT $ validateRules r
ExceptT $ case r_ of ExceptT $ case r_ of
Left s -> return $ Left $ parseErrorPretty $ makeParseError rulesfile s Left s -> return $ Left $ parseErrorPretty $ makeParseError s
Right r -> return $ Right r Right r -> return $ Right r
where where
makeParseError :: FilePath -> String -> ParseError Char String makeParseError :: String -> ParseError T.Text String
makeParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s) makeParseError s = FancyError 0 (S.singleton $ ErrorFail s)
-- | Parse this text as CSV conversion rules. The file path is for error messages. -- | Parse this text as CSV conversion rules. The file path is for error messages.
parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char CustomErr) CsvRules parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text CustomErr) CsvRules
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
parseCsvRules rulesfile s = parseCsvRules rulesfile s =
runParser (evalStateT rulesp rules) rulesfile s runParser (evalStateT rulesp rules) rulesfile s
@ -513,7 +512,7 @@ directives =
] ]
directivevalp :: CsvRulesParser String directivevalp :: CsvRulesParser String
directivevalp = anyChar `manyTill` lift eolof directivevalp = anySingle `manyTill` lift eolof
fieldnamelistp :: CsvRulesParser [CsvFieldName] fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do fieldnamelistp = (do
@ -588,7 +587,7 @@ assignmentseparatorp = do
fieldvalp :: CsvRulesParser String fieldvalp :: CsvRulesParser String
fieldvalp = do fieldvalp = do
lift $ dbgparse 2 "trying fieldvalp" lift $ dbgparse 2 "trying fieldvalp"
anyChar `manyTill` lift eolof anySingle `manyTill` lift eolof
conditionalblockp :: CsvRulesParser ConditionalBlock conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do conditionalblockp = do
@ -631,7 +630,7 @@ regexp = do
lift $ dbgparse 3 "trying regexp" lift $ dbgparse 3 "trying regexp"
notFollowedBy matchoperatorp notFollowedBy matchoperatorp
c <- lift nonspace c <- lift nonspace
cs <- anyChar `manyTill` lift eolof cs <- anySingle `manyTill` lift eolof
return $ strip $ c:cs return $ strip $ c:cs
-- fieldmatcher = do -- fieldmatcher = do

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

@ -124,10 +124,10 @@ aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++qu
-- | A journal parser. Accumulates and returns a "ParsedJournal", -- | A journal parser. Accumulates and returns a "ParsedJournal",
-- which should be finalised/validated before use. -- which should be finalised/validated before use.
-- --
-- >>> rjp (journalp <* eof) "2015/1/1\n a 0\n" -- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n"
-- Right Journal with 1 transactions, 1 accounts -- Right (Right Journal with 1 transactions, 1 accounts)
-- --
journalp :: MonadIO m => JournalParser m ParsedJournal journalp :: MonadIO m => ErroringJournalParser m ParsedJournal
journalp = do journalp = do
many addJournalItemP many addJournalItemP
eof eof
@ -135,7 +135,7 @@ journalp = do
-- | A side-effecting parser; parses any kind of journal item -- | A side-effecting parser; parses any kind of journal item
-- and updates the parse state accordingly. -- and updates the parse state accordingly.
addJournalItemP :: MonadIO m => JournalParser m () addJournalItemP :: MonadIO m => ErroringJournalParser m ()
addJournalItemP = addJournalItemP =
-- all journal line types can be distinguished by the first -- all journal line types can be distinguished by the first
-- character, can use choice without backtracking -- character, can use choice without backtracking
@ -154,7 +154,7 @@ addJournalItemP =
-- | Parse any journal directive and update the parse state accordingly. -- | Parse any journal directive and update the parse state accordingly.
-- Cf http://hledger.org/manual.html#directives, -- Cf http://hledger.org/manual.html#directives,
-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directivep :: MonadIO m => JournalParser m () directivep :: MonadIO m => ErroringJournalParser m ()
directivep = (do directivep = (do
optional $ char '!' optional $ char '!'
choice [ choice [
@ -174,78 +174,74 @@ directivep = (do
] ]
) <?> "directive" ) <?> "directive"
includedirectivep :: MonadIO m => JournalParser m () includedirectivep :: MonadIO m => ErroringJournalParser m ()
includedirectivep = do includedirectivep = do
string "include" string "include"
lift (skipSome spacenonewline) lift (skipSome spacenonewline)
filename <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet filename <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet
parentpos <- getPosition parentoff <- getOffset
parentpos <- getSourcePos
filepaths <- getFilePaths parentpos filename filepaths <- getFilePaths parentoff parentpos filename
forM_ filepaths $ parseChild parentpos forM_ filepaths $ parseChild parentpos
void newline void newline
where where
getFilePaths parserpos filename = do getFilePaths
:: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath]
getFilePaths parseroff parserpos filename = do
curdir <- lift $ expandPath (takeDirectory $ sourceName parserpos) "" curdir <- lift $ expandPath (takeDirectory $ sourceName parserpos) ""
`orRethrowIOError` (show parserpos ++ " locating " ++ filename) `orRethrowIOError` (show parserpos ++ " locating " ++ filename)
-- Compiling filename as a glob pattern works even if it is a literal -- Compiling filename as a glob pattern works even if it is a literal
fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of
Right x -> pure x Right x -> pure x
Left e -> parseErrorAt parserpos $ "Invalid glob pattern: " ++ e Left e -> customFailure $
parseErrorAt parseroff $ "Invalid glob pattern: " ++ e
-- Get all matching files in the current working directory, sorting in -- Get all matching files in the current working directory, sorting in
-- lexicographic order to simulate the output of 'ls'. -- lexicographic order to simulate the output of 'ls'.
filepaths <- liftIO $ sort <$> globDir1 fileglob curdir filepaths <- liftIO $ sort <$> globDir1 fileglob curdir
if (not . null) filepaths if (not . null) filepaths
then pure filepaths then pure filepaths
else parseErrorAt parserpos $ "No existing files match pattern: " ++ filename else customFailure $ parseErrorAt parseroff $
"No existing files match pattern: " ++ filename
parseChild :: MonadIO m => SourcePos -> FilePath -> ErroringJournalParser m ()
parseChild parentpos filepath = do parseChild parentpos filepath = do
parentfilestack <- fmap sourceName . statePos <$> getParserState parentj <- get
when (filepath `elem` parentfilestack)
$ parseErrorAt parentpos ("Cyclic include: " ++ filepath)
childInput <- lift $ readFilePortably filepath let parentfilestack = jincludefilestack parentj
`orRethrowIOError` (show parentpos ++ " reading " ++ filepath) when (filepath `elem` parentfilestack) $
fail ("Cyclic include: " ++ filepath)
-- save parent state childInput <- lift $ readFilePortably filepath
parentParserState <- getParserState `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
parentj <- get let initChildj = newJournalWithParseStateFrom filepath parentj
let childj = newJournalWithParseStateFrom parentj let parser = choiceInState
[ journalp
, timeclockfilep
, timedotfilep
] -- can't include a csv file yet, that reader is special
updatedChildj <- journalAddFile (filepath, childInput) <$>
parseIncludeFile parser initChildj filepath childInput
-- set child state -- discard child's parse info, combine other fields
setInput childInput put $ updatedChildj <> parentj
pushPosition $ initialPos filepath
put childj
-- parse include file newJournalWithParseStateFrom :: FilePath -> Journal -> Journal
let parsers = [ journalp newJournalWithParseStateFrom filepath j = mempty{
, timeclockfilep jparsedefaultyear = jparsedefaultyear j
, timedotfilep ,jparsedefaultcommodity = jparsedefaultcommodity j
] -- can't include a csv file yet, that reader is special ,jparseparentaccounts = jparseparentaccounts j
updatedChildj <- journalAddFile (filepath, childInput) <$> ,jparsealiases = jparsealiases j
region (withSource childInput) (choiceInState parsers) ,jcommodities = jcommodities j
-- ,jparsetransactioncount = jparsetransactioncount j
-- restore parent state, prepending the child's parse info ,jparsetimeclockentries = jparsetimeclockentries j
setParserState parentParserState ,jincludefilestack = filepath : jincludefilestack j
put $ updatedChildj <> parentj }
-- discard child's parse info, prepend its (reversed) list data, combine other fields
newJournalWithParseStateFrom :: Journal -> Journal
newJournalWithParseStateFrom j = mempty{
jparsedefaultyear = jparsedefaultyear j
,jparsedefaultcommodity = jparsedefaultcommodity j
,jparseparentaccounts = jparseparentaccounts j
,jparsealiases = jparsealiases j
,jcommodities = jcommodities j
-- ,jparsetransactioncount = jparsetransactioncount j
,jparsetimeclockentries = jparsetimeclockentries j
}
-- | Lift an IO action into the exception monad, rethrowing any IO -- | Lift an IO action into the exception monad, rethrowing any IO
-- error with the given message prepended. -- error with the given message prepended.
@ -284,17 +280,17 @@ commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultiline
-- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n" -- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
commoditydirectiveonelinep :: JournalParser m () commoditydirectiveonelinep :: JournalParser m ()
commoditydirectiveonelinep = do commoditydirectiveonelinep = do
(pos, Amount{acommodity,astyle}) <- try $ do (off, Amount{acommodity,astyle}) <- try $ do
string "commodity" string "commodity"
lift (skipSome spacenonewline) lift (skipSome spacenonewline)
pos <- getPosition off <- getOffset
amount <- amountp amount <- amountp
pure $ (pos, amount) pure $ (off, amount)
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
_ <- lift followingcommentp _ <- lift followingcommentp
let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle} let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle}
if asdecimalpoint astyle == Nothing if asdecimalpoint astyle == Nothing
then parseErrorAt pos pleaseincludedecimalpoint then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j}) else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
pleaseincludedecimalpoint :: String pleaseincludedecimalpoint :: String
@ -321,15 +317,15 @@ formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle
formatdirectivep expectedsym = do formatdirectivep expectedsym = do
string "format" string "format"
lift (skipSome spacenonewline) lift (skipSome spacenonewline)
pos <- getPosition off <- getOffset
Amount{acommodity,astyle} <- amountp Amount{acommodity,astyle} <- amountp
_ <- lift followingcommentp _ <- lift followingcommentp
if acommodity==expectedsym if acommodity==expectedsym
then then
if asdecimalpoint astyle == Nothing if asdecimalpoint astyle == Nothing
then parseErrorAt pos pleaseincludedecimalpoint then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else return $ dbg2 "style from format subdirective" astyle else return $ dbg2 "style from format subdirective" astyle
else parseErrorAt pos $ else customFailure $ parseErrorAt off $
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
keywordp :: String -> JournalParser m () keywordp :: String -> JournalParser m ()
@ -371,7 +367,7 @@ basicaliasp = do
old <- rstrip <$> (some $ noneOf ("=" :: [Char])) old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
char '=' char '='
skipMany spacenonewline skipMany spacenonewline
new <- rstrip <$> anyChar `manyTill` eolof -- eol in journal, eof in command lines, normally new <- rstrip <$> anySingle `manyTill` eolof -- eol in journal, eof in command lines, normally
return $ BasicAlias (T.pack old) (T.pack new) return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: TextParser m AccountAlias regexaliasp :: TextParser m AccountAlias
@ -383,7 +379,7 @@ regexaliasp = do
skipMany spacenonewline skipMany spacenonewline
char '=' char '='
skipMany spacenonewline skipMany spacenonewline
repl <- anyChar `manyTill` eolof repl <- anySingle `manyTill` eolof
return $ RegexAlias re repl return $ RegexAlias re repl
endaliasesdirectivep :: JournalParser m () endaliasesdirectivep :: JournalParser m ()
@ -418,11 +414,11 @@ defaultcommoditydirectivep :: JournalParser m ()
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
lift (skipSome spacenonewline) lift (skipSome spacenonewline)
pos <- getPosition off <- getOffset
Amount{acommodity,astyle} <- amountp Amount{acommodity,astyle} <- amountp
lift restofline lift restofline
if asdecimalpoint astyle == Nothing if asdecimalpoint astyle == Nothing
then parseErrorAt pos pleaseincludedecimalpoint then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else setDefaultCommodityAndStyle (acommodity, astyle) else setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: JournalParser m MarketPrice marketpricedirectivep :: JournalParser m MarketPrice
@ -484,17 +480,20 @@ periodictransactionp = do
char '~' <?> "periodic transaction" char '~' <?> "periodic transaction"
lift $ skipMany spacenonewline lift $ skipMany spacenonewline
-- a period expression -- a period expression
off <- getOffset
pos <- getPosition pos <- getPosition
-- if there's a default year in effect, use Y/1/1 as base for partial/relative dates
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
mdefaultyear <- getYear mdefaultyear <- getYear
let refdate = case mdefaultyear of let refdate = case mdefaultyear of
Nothing -> today Nothing -> today
Just y -> fromGregorian y 1 1 Just y -> fromGregorian y 1 1
(periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp refdate) (periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp refdate)
-- In periodic transactions, the period expression has an additional constraint: -- In periodic transactions, the period expression has an additional constraint:
case checkPeriodicTransactionStartDate interval span periodtxt of case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> parseErrorAt pos e Just e -> customFailure $ parseErrorAt off e
Nothing -> pure () Nothing -> pure ()
-- The line can end here, or it can continue with one or more spaces -- The line can end here, or it can continue with one or more spaces
-- and then zero or more of the following fields. A bit awkward. -- and then zero or more of the following fields. A bit awkward.
@ -529,7 +528,7 @@ periodictransactionp = do
transactionp :: JournalParser m Transaction transactionp :: JournalParser m Transaction
transactionp = do transactionp = do
-- dbgparse 0 "transactionp" -- dbgparse 0 "transactionp"
startpos <- getPosition startpos <- getSourcePos
date <- datep <?> "transaction" date <- datep <?> "transaction"
edate <- optional (lift $ secondarydatep date) <?> "secondary date" edate <- optional (lift $ secondarydatep date) <?> "secondary date"
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline" lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
@ -539,7 +538,7 @@ transactionp = do
(comment, tags) <- lift transactioncommentp (comment, tags) <- lift transactioncommentp
let year = first3 $ toGregorian date let year = first3 $ toGregorian date
postings <- postingsp (Just year) postings <- postingsp (Just year)
endpos <- getPosition endpos <- getSourcePos
let sourcepos = journalSourcePos startpos endpos let sourcepos = journalSourcePos startpos endpos
return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings "" return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings ""
@ -607,8 +606,9 @@ tests_JournalReader = tests "JournalReader" [
test "YYYY.MM.DD" $ expectParse datep "2018.01.01" test "YYYY.MM.DD" $ expectParse datep "2018.01.01"
test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown" test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown"
test "yearless date with default year" $ do test "yearless date with default year" $ do
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep "1/1" let s = "1/1"
either (fail.("parse error at "++).parseErrorPretty) (const ok) ep ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s
either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep
test "no leading zero" $ expectParse datep "2018/1/1" test "no leading zero" $ expectParse datep "2018/1/1"
,test "datetimep" $ do ,test "datetimep" $ do
@ -795,8 +795,8 @@ tests_JournalReader = tests "JournalReader" [
,tests "directivep" [ ,tests "directivep" [
test "supports !" $ do test "supports !" $ do
expectParse directivep "!account a\n" expectParseE directivep "!account a\n"
expectParse directivep "!D 1.0\n" expectParseE directivep "!D 1.0\n"
] ]
,test "accountdirectivep" $ do ,test "accountdirectivep" $ do
@ -819,8 +819,8 @@ tests_JournalReader = tests "JournalReader" [
expectParse ignoredpricecommoditydirectivep "N $\n" expectParse ignoredpricecommoditydirectivep "N $\n"
,test "includedirectivep" $ do ,test "includedirectivep" $ do
test "include" $ expectParseError includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile" test "include" $ expectParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"
test "glob" $ expectParseError includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" test "glob" $ expectParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*"
,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep ,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep
"P 2017/01/30 BTC $922.83\n" "P 2017/01/30 BTC $922.83\n"
@ -839,7 +839,7 @@ tests_JournalReader = tests "JournalReader" [
,tests "journalp" [ ,tests "journalp" [
test "empty file" $ expectParseEq journalp "" nulljournal test "empty file" $ expectParseEqE journalp "" nulljournal
] ]
] ]

5
hledger-lib/Hledger/Read/TimeclockReader.hs
View File

@ -58,7 +58,6 @@ import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Text.Megaparsec hiding (parse) import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Hledger.Data import Hledger.Data
-- XXX too much reuse ? -- XXX too much reuse ?
@ -78,7 +77,7 @@ reader = Reader
-- format, saving the provided file path and the current time, or give an -- format, saving the provided file path and the current time, or give an
-- error. -- error.
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse = parseAndFinaliseJournal timeclockfilep parse = parseAndFinaliseJournal' timeclockfilep
timeclockfilep :: MonadIO m => JournalParser m ParsedJournal timeclockfilep :: MonadIO m => JournalParser m ParsedJournal
timeclockfilep = do many timeclockitemp timeclockfilep = do many timeclockitemp
@ -105,7 +104,7 @@ timeclockfilep = do many timeclockitemp
-- | Parse a timeclock entry. -- | Parse a timeclock entry.
timeclockentryp :: JournalParser m TimeclockEntry timeclockentryp :: JournalParser m TimeclockEntry
timeclockentryp = do timeclockentryp = do
sourcepos <- genericSourcePos <$> lift getPosition sourcepos <- genericSourcePos <$> lift getSourcePos
code <- oneOf ("bhioO" :: [Char]) code <- oneOf ("bhioO" :: [Char])
lift (skipSome spacenonewline) lift (skipSome spacenonewline)
datetime <- datetimep datetime <- datetimep

4
hledger-lib/Hledger/Read/TimedotReader.hs
View File

@ -64,7 +64,7 @@ reader = Reader
-- | Parse and post-process a "Journal" from the timedot format, or give an error. -- | Parse and post-process a "Journal" from the timedot format, or give an error.
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse = parseAndFinaliseJournal timedotfilep parse = parseAndFinaliseJournal' timedotfilep
timedotfilep :: JournalParser m ParsedJournal timedotfilep :: JournalParser m ParsedJournal
timedotfilep = do many timedotfileitemp timedotfilep = do many timedotfileitemp
@ -104,7 +104,7 @@ timedotdayp = do
timedotentryp :: JournalParser m Transaction timedotentryp :: JournalParser m Transaction
timedotentryp = do timedotentryp = do
traceParse " timedotentryp" traceParse " timedotentryp"
pos <- genericSourcePos <$> getPosition pos <- genericSourcePos <$> getSourcePos
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
a <- modifiedaccountnamep a <- modifiedaccountnamep
lift (skipMany spacenonewline) lift (skipMany spacenonewline)

12
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -48,7 +48,7 @@ import Data.Default
import Safe import Safe
import System.Console.ANSI (hSupportsANSI) import System.Console.ANSI (hSupportsANSI)
import System.IO (stdout) import System.IO (stdout)
import Text.Megaparsec.Error import Text.Megaparsec.Custom
import Hledger.Data import Hledger.Data
import Hledger.Query import Hledger.Query
@ -240,11 +240,11 @@ beginDatesFromRawOpts d = catMaybes . map (begindatefromrawopt d)
where where
begindatefromrawopt d (n,v) begindatefromrawopt d (n,v)
| n == "begin" = | n == "begin" =
either (\e -> usageError $ "could not parse "++n++" date: "++parseErrorPretty e) Just $ either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $
fixSmartDateStrEither' d (T.pack v) fixSmartDateStrEither' d (T.pack v)
| n == "period" = | n == "period" =
case case
either (\e -> usageError $ "could not parse period option: "++parseErrorPretty e) id $ either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $
parsePeriodExpr d (stripquotes $ T.pack v) parsePeriodExpr d (stripquotes $ T.pack v)
of of
(_, DateSpan (Just b) _) -> Just b (_, DateSpan (Just b) _) -> Just b
@ -258,11 +258,11 @@ endDatesFromRawOpts d = catMaybes . map (enddatefromrawopt d)
where where
enddatefromrawopt d (n,v) enddatefromrawopt d (n,v)
| n == "end" = | n == "end" =
either (\e -> usageError $ "could not parse "++n++" date: "++parseErrorPretty e) Just $ either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $
fixSmartDateStrEither' d (T.pack v) fixSmartDateStrEither' d (T.pack v)
| n == "period" = | n == "period" =
case case
either (\e -> usageError $ "could not parse period option: "++parseErrorPretty e) id $ either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $
parsePeriodExpr d (stripquotes $ T.pack v) parsePeriodExpr d (stripquotes $ T.pack v)
of of
(_, DateSpan _ (Just e)) -> Just e (_, DateSpan _ (Just e)) -> Just e
@ -276,7 +276,7 @@ intervalFromRawOpts = lastDef NoInterval . catMaybes . map intervalfromrawopt
where where
intervalfromrawopt (n,v) intervalfromrawopt (n,v)
| n == "period" = | n == "period" =
either (\e -> usageError $ "could not parse period option: "++parseErrorPretty e) (Just . fst) $ either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) (Just . fst) $
parsePeriodExpr nulldate (stripquotes $ T.pack v) -- reference date does not affect the interval parsePeriodExpr nulldate (stripquotes $ T.pack v) -- reference date does not affect the interval
| n == "daily" = Just $ Days 1 | n == "daily" = Just $ Days 1
| n == "weekly" = Just $ Weeks 1 | n == "weekly" = Just $ Weeks 1

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

@ -225,7 +225,7 @@ plogAt lvl
-- (position and next input) to the console. (See also megaparsec's dbg.) -- (position and next input) to the console. (See also megaparsec's dbg.)
traceParse :: String -> TextParser m () traceParse :: String -> TextParser m ()
traceParse msg = do traceParse msg = do
pos <- getPosition pos <- getSourcePos
next <- (T.take peeklength) `fmap` getInput next <- (T.take peeklength) `fmap` getInput
let (l,c) = (sourceLine pos, sourceColumn pos) let (l,c) = (sourceLine pos, sourceColumn pos)
s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String

36
hledger-lib/Hledger/Utils/Parse.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Hledger.Utils.Parse ( module Hledger.Utils.Parse (
@ -5,6 +6,7 @@ module Hledger.Utils.Parse (
SimpleTextParser, SimpleTextParser,
TextParser, TextParser,
JournalParser, JournalParser,
ErroringJournalParser,
choice', choice',
choiceInState, choiceInState,
@ -27,6 +29,7 @@ module Hledger.Utils.Parse (
) )
where where
import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict (StateT, evalStateT) import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Char import Data.Char
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
@ -52,6 +55,11 @@ type TextParser m a = ParsecT CustomErr Text m a
-- | A parser of text in some monad, with a journal as state. -- | A parser of text in some monad, with a journal as state.
type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a
-- | A parser of text in some monad, with a journal as state, that can throw a
-- "final" parse error that does not backtrack.
type ErroringJournalParser m a =
StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
-- | Backtracking choice, use this when alternatives share a prefix. -- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail. -- Consumes no input if all choices fail.
choice' :: [TextParser m a] -> TextParser m a choice' :: [TextParser m a] -> TextParser m a
@ -65,15 +73,21 @@ choiceInState = choice . map try
surroundedBy :: Applicative m => m openclose -> m a -> m a surroundedBy :: Applicative m => m openclose -> m a -> m a
surroundedBy p = between p p surroundedBy p = between p p
parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith p = runParser p "" parsewith p = runParser p ""
parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a parsewithString
:: Parsec e String a -> String -> Either (ParseErrorBundle String e) a
parsewithString p = runParser p "" parsewithString p = runParser p ""
-- | Run a stateful parser with some initial state on a text. -- | Run a stateful parser with some initial state on a text.
-- See also: runTextParser, runJournalParser. -- See also: runTextParser, runJournalParser.
parseWithState :: Monad m => st -> StateT st (ParsecT CustomErr Text m) a -> Text -> m (Either (ParseError Char CustomErr) a) parseWithState
:: Monad m
=> st
-> StateT st (ParsecT CustomErr Text m) a
-> Text
-> m (Either (ParseErrorBundle Text CustomErr) a)
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
parseWithState' parseWithState'
@ -81,19 +95,23 @@ parseWithState'
=> st => st
-> StateT st (ParsecT e s Identity) a -> StateT st (ParsecT e s Identity) a
-> s -> s
-> (Either (ParseError (Token s) e) a) -> (Either (ParseErrorBundle s e) a)
parseWithState' ctx p s = runParser (evalStateT p ctx) "" s parseWithState' ctx p s = runParser (evalStateT p ctx) "" s
fromparse :: (Show t, Show e) => Either (ParseError t e) a -> a fromparse
:: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a
fromparse = either parseerror id fromparse = either parseerror id
parseerror :: (Show t, Show e) => ParseError t e -> a parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a
parseerror e = error' $ showParseError e parseerror e = error' $ showParseError e
showParseError :: (Show t, Show e) => ParseError t e -> String showParseError
:: (Show t, Show (Token t), Show e)
=> ParseErrorBundle t e -> String
showParseError e = "parse error at " ++ show e showParseError e = "parse error at " ++ show e
showDateParseError :: (Show t, Show e) => ParseError t e -> String showDateParseError
:: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
nonspace :: TextParser m Char nonspace :: TextParser m Char
@ -106,7 +124,7 @@ spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
spacenonewline = satisfy isNonNewlineSpace spacenonewline = satisfy isNonNewlineSpace
restofline :: TextParser m String restofline :: TextParser m String
restofline = anyChar `manyTill` newline restofline = anySingle `manyTill` newline
eolof :: TextParser m () eolof :: TextParser m ()
eolof = (newline >> return ()) <|> eof eolof = (newline >> return ()) <|> eof

86
hledger-lib/Hledger/Utils/Test.hs
View File

@ -16,13 +16,18 @@ module Hledger.Utils.Test (
,is ,is
,expectEqPP ,expectEqPP
,expectParse ,expectParse
,expectParseE
,expectParseError ,expectParseError
,expectParseErrorE
,expectParseEq ,expectParseEq
,expectParseEqE
,expectParseEqOn ,expectParseEqOn
,expectParseEqOnE
) )
where where
import Control.Exception import Control.Exception
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.State.Strict (StateT, evalStateT) import Control.Monad.State.Strict (StateT, evalStateT)
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@ -101,12 +106,34 @@ is = flip expectEqPP
-- | Test that this stateful parser runnable in IO successfully parses -- | Test that this stateful parser runnable in IO successfully parses
-- all of the given input text, showing the parse error if it fails. -- all of the given input text, showing the parse error if it fails.
-- Suitable for hledger's JournalParser parsers. -- Suitable for hledger's JournalParser parsers.
expectParse :: (Monoid st, Eq a, Show a, HasCallStack) => expectParse :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test ()
expectParse parser input = do expectParse parser input = do
ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input) ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input)
either (fail.(++"\n").("\nparse error at "++).parseErrorPretty) (const ok) ep either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty)
(const ok)
ep
-- Suitable for hledger's ErroringJournalParser parsers.
expectParseE
:: (Monoid st, Eq a, Show a, HasCallStack)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text
-> E.Test ()
expectParseE parser input = do
let filepath = ""
eep <- E.io $ runExceptT $
runParserT (evalStateT (parser <* eof) mempty) filepath input
case eep of
Left finalErr ->
let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr
in fail $ "parse error at " <> prettyErr
Right ep ->
either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty)
(const ok)
ep
-- | Test that this stateful parser runnable in IO fails to parse -- | Test that this stateful parser runnable in IO fails to parse
-- the given input text, with a parse error containing the given string. -- the given input text, with a parse error containing the given string.
@ -117,22 +144,75 @@ expectParseError parser input errstr = do
case ep of case ep of
Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n" Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"
Left e -> do Left e -> do
let e' = parseErrorPretty e let e' = customErrorBundlePretty e
if errstr `isInfixOf` e' if errstr `isInfixOf` e'
then ok then ok
else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n" else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
expectParseErrorE
:: (Monoid st, Eq a, Show a, HasCallStack)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text
-> String
-> E.Test ()
expectParseErrorE parser input errstr = do
let filepath = ""
eep <- E.io $ runExceptT $ runParserT (evalStateT parser mempty) filepath input
case eep of
Left finalErr -> do
let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr
if errstr `isInfixOf` prettyErr
then ok
else fail $ "\nparse error is not as expected:\n" ++ prettyErr ++ "\n"
Right ep -> case ep of
Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"
Left e -> do
let e' = customErrorBundlePretty e
if errstr `isInfixOf` e'
then ok
else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
-- | Like expectParse, but also test the parse result is an expected value, -- | Like expectParse, but also test the parse result is an expected value,
-- pretty-printing both if it fails. -- pretty-printing both if it fails.
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) => expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEq parser input expected = expectParseEqOn parser input id expected expectParseEq parser input expected = expectParseEqOn parser input id expected
expectParseEqE
:: (Monoid st, Eq a, Show a, HasCallStack)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text
-> a
-> E.Test ()
expectParseEqE parser input expected = expectParseEqOnE parser input id expected
-- | Like expectParseEq, but transform the parse result with the given function -- | Like expectParseEq, but transform the parse result with the given function
-- before comparing it. -- before comparing it.
expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) => expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOn parser input f expected = do expectParseEqOn parser input f expected = do
ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input
either (fail . (++"\n") . ("\nparse error at "++) . parseErrorPretty) (expectEqPP expected . f) ep either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)
(expectEqPP expected . f)
ep
expectParseEqOnE
:: (Monoid st, Eq b, Show b, HasCallStack)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text
-> (a -> b)
-> b
-> E.Test ()
expectParseEqOnE parser input f expected = do
let filepath = ""
eep <- E.io $ runExceptT $
runParserT (evalStateT (parser <* eof) mempty) filepath input
case eep of
Left finalErr ->
let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr
in fail $ "parse error at " <> prettyErr
Right ep ->
either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)
(expectEqPP expected . f)
ep

396
hledger-lib/Text/Megaparsec/Custom.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
@ -9,25 +8,44 @@ module Text.Megaparsec.Custom (
-- * Custom parse error type -- * Custom parse error type
CustomErr, CustomErr,
-- * Throwing custom parse errors -- * Constructing custom parse errors
parseErrorAt, parseErrorAt,
parseErrorAtRegion, parseErrorAtRegion,
withSource,
-- * Pretty-printing custom parse errors -- * Pretty-printing custom parse errors
customParseErrorPretty customErrorBundlePretty,
-- * "Final" parse errors
FinalParseError,
FinalParseError',
FinalParseErrorBundle,
FinalParseErrorBundle',
-- * Constructing "final" parse errors
finalError,
finalFancyFailure,
finalFail,
finalCustomFailure,
-- * Pretty-printing "final" parse errors
finalErrorBundlePretty,
attachSource,
-- * Handling parse errors from include files with "final" parse errors
parseIncludeFile,
) )
where where
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile) import "base-compat-batteries" Prelude.Compat hiding (readFile)
import Control.Monad.Except
import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Foldable (asum, toList) import Data.Foldable (asum, toList)
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as S import qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec import Text.Megaparsec
@ -39,13 +57,9 @@ import Text.Megaparsec
data CustomErr data CustomErr
-- | Fail with a message at a specific source position interval. The -- | Fail with a message at a specific source position interval. The
-- interval must be contained within a single line. -- interval must be contained within a single line.
= ErrorFailAt SourcePos -- Starting position = ErrorFailAt Int -- Starting offset
Pos -- Ending position (column; same line as start) Int -- Ending offset
String -- Error message String -- Error message
-- | Attach a source file to a parse error (for error reporting from
-- include files, e.g. with the 'region' parser combinator)
| ErrorWithSource Text -- Source file contents
(ParseError Char CustomErr) -- The original
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
-- We require an 'Ord' instance for 'CustomError' so that they may be -- We require an 'Ord' instance for 'CustomError' so that they may be
@ -53,76 +67,68 @@ data CustomErr
-- derive it, but this requires an (orphan) instance for 'ParseError'. -- derive it, but this requires an (orphan) instance for 'ParseError'.
-- Hopefully this does not cause any trouble. -- Hopefully this does not cause any trouble.
deriving instance (Ord c, Ord e) => Ord (ParseError c e) deriving instance (Eq (Token c), Ord (Token c), Ord c, Ord e) => Ord (ParseError c e)
instance ShowErrorComponent CustomErr where instance ShowErrorComponent CustomErr where
showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg
showErrorComponent (ErrorWithSource _ e) = parseErrorTextPretty e errorComponentLen (ErrorFailAt startOffset endOffset _) =
endOffset - startOffset
--- * Throwing custom parse errors --- * Constructing custom parse errors
-- | Fail at a specific source position. -- | Fail at a specific source position, given by the raw offset from the
-- start of the input stream (the number of tokens processed at that
-- point).
parseErrorAt :: MonadParsec CustomErr s m => SourcePos -> String -> m a parseErrorAt :: Int -> String -> CustomErr
parseErrorAt pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg) parseErrorAt offset msg = ErrorFailAt offset (offset+1) msg
{-# INLINABLE parseErrorAt #-}
-- | Fail at a specific source interval (within a single line). The -- | Fail at a specific source interval, given by the raw offsets of its
-- interval is inclusive on the left and exclusive on the right; that is, -- endpoints from the start of the input stream (the numbers of tokens
-- it spans from the start position to just before (and not including) the -- processed at those points).
-- end position. --
-- Note that care must be taken to ensure that the specified interval does
-- not span multiple lines of the input source, as this will not be
-- checked.
parseErrorAtRegion parseErrorAtRegion
:: MonadParsec CustomErr s m :: Int -- ^ Start offset
=> SourcePos -- ^ Start position -> Int -- ^ End end offset
-> SourcePos -- ^ End position -> String -- ^ Error message
-> String -- ^ Error message -> CustomErr
-> m a parseErrorAtRegion startOffset endOffset msg =
parseErrorAtRegion startPos endPos msg = if startOffset < endOffset
let startCol = sourceColumn startPos then ErrorFailAt startOffset endOffset msg
endCol' = mkPos $ subtract 1 $ unPos $ sourceColumn endPos else ErrorFailAt startOffset (startOffset+1) msg
endCol = if startCol <= endCol'
&& sourceLine startPos == sourceLine endPos
then endCol' else startCol
in customFailure (ErrorFailAt startPos endCol msg)
{-# INLINABLE parseErrorAtRegion #-}
-- | Attach a source file to a parse error. Intended for use with the
-- 'region' parser combinator.
withSource :: Text -> ParseError Char CustomErr -> ParseError Char CustomErr
withSource s e =
FancyError (errorPos e) $ S.singleton $ ErrorCustom $ ErrorWithSource s e
--- * Pretty-printing custom parse errors --- * Pretty-printing custom parse errors
-- | Pretty-print our custom parse errors and display the line on which -- | Pretty-print our custom parse errors and display the line on which
-- the parse error occured. Use this instead of 'parseErrorPretty'. -- the parse error occured.
-- --
-- If any custom errors are present, arbitrarily take the first one (since -- Use this instead of 'errorBundlePretty' when custom parse errors are
-- only one custom error should be used at a time). -- thrown, otherwise the continuous highlighting in the pretty-printed
-- parse error will be displaced from its proper position.
customParseErrorPretty :: Text -> ParseError Char CustomErr -> String customErrorBundlePretty :: ParseErrorBundle Text CustomErr -> String
customParseErrorPretty source err = case findCustomError err of customErrorBundlePretty errBundle =
Nothing -> customParseErrorPretty' source err pos1 let errBundle' = errBundle
{ bundleErrors = fmap setCustomErrorOffset $ bundleErrors errBundle }
Just (ErrorWithSource customSource customErr) -> in errorBundlePretty errBundle'
customParseErrorPretty customSource customErr
Just (ErrorFailAt sourcePos col errMsg) ->
let newPositionStack = sourcePos NE.:| NE.tail (errorPos err)
errorIntervalLength = mkPos $ max 1 $
unPos col - unPos (sourceColumn sourcePos) + 1
newErr :: ParseError Char Void
newErr = FancyError newPositionStack (S.singleton (ErrorFail errMsg))
in customParseErrorPretty' source newErr errorIntervalLength
where where
findCustomError :: ParseError Char CustomErr -> Maybe CustomErr setCustomErrorOffset
:: ParseError Text CustomErr -> ParseError Text CustomErr
setCustomErrorOffset err = case findCustomError err of
Nothing -> err
Just errFailAt@(ErrorFailAt startOffset _ _) ->
FancyError startOffset $ S.singleton $ ErrorCustom errFailAt
-- If any custom errors are present, arbitrarily take the first one
-- (since only one custom error should be used at a time).
findCustomError :: ParseError Text CustomErr -> Maybe CustomErr
findCustomError err = case err of findCustomError err = case err of
FancyError _ errSet -> FancyError _ errSet ->
finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
@ -132,117 +138,183 @@ customParseErrorPretty source err = case findCustomError err of
finds f = asum . map f . toList finds f = asum . map f . toList
--- * Modified Megaparsec source --- * "Final" parse errors
--
-- | A type representing "final" parse errors that cannot be backtracked
-- from and are guaranteed to halt parsing. The anti-backtracking
-- behaviour is implemented by an 'ExceptT' layer in the parser's monad
-- stack, using this type as the 'ExceptT' error type.
--
-- We have three goals for this type:
-- (1) it should be possible to convert any parse error into a "final"
-- parse error,
-- (2) it should be possible to take a parse error thrown from an include
-- file and re-throw it in the parent file, and
-- (3) the pretty-printing of "final" parse errors should be consistent
-- with that of ordinary parse errors, but should also report a stack of
-- files for errors thrown from include files.
--
-- In order to pretty-print a "final" parse error (goal 3), it must be
-- bundled with include filepaths and its full source text. When a "final"
-- parse error is thrown from within a parser, we do not have access to
-- the full source, so we must hold the parse error until it can be joined
-- with its source (and include filepaths, if it was thrown from an
-- include file) by the parser's caller.
--
-- A parse error with include filepaths and its full source text is
-- represented by the 'FinalParseErrorBundle' type, while a parse error in
-- need of either include filepaths, full source text, or both is
-- represented by the 'FinalParseError' type.
-- The below code has been copied from Megaparsec (v.6.4.1, data FinalParseError' e
-- Text.Megaparsec.Error) and modified to suit our needs. These changes are -- a parse error thrown as a "final" parse error
-- indicated by square brackets. The following copyright notice, conditions, = FinalError (ParseError Text e)
-- and disclaimer apply to all code below this point. -- a parse error obtained from running a parser, e.g. using 'runParserT'
| FinalBundle (ParseErrorBundle Text e)
-- a parse error thrown from an include file
| FinalBundleWithStack (FinalParseErrorBundle' e)
deriving (Show)
type FinalParseError = FinalParseError' CustomErr
-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT
-- FinalParseError m' is an instance of Alternative and MonadPlus, which
-- is needed to use some parser combinators, e.g. 'many'.
-- --
-- Copyright © 2015–2018 Megaparsec contributors<br> -- This monoid instance simply takes the first (left-most) error.
-- Copyright © 2007 Paolo Martini<br>
-- Copyright © 1999–2000 Daan Leijen instance Semigroup (FinalParseError' e) where
e <> _ = e
instance Monoid (FinalParseError' e) where
mempty = FinalError $ FancyError 0 $
S.singleton (ErrorFail "default parse error")
mappend = (<>)
-- | A type bundling a 'ParseError' with its full source text, filepath,
-- and stack of include files. Suitable for pretty-printing.
-- --
-- All rights reserved. -- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with
-- -- its full source text and filepath, so we just add a stack of include
-- Redistribution and use in source and binary forms, with or without -- files.
-- modification, are permitted provided that the following conditions are met:
-- data FinalParseErrorBundle' e = FinalParseErrorBundle'
-- * Redistributions of source code must retain the above copyright notice, { finalErrorBundle :: ParseErrorBundle Text e
-- this list of conditions and the following disclaimer. , includeFileStack :: [FilePath]
-- } deriving (Show)
-- * Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr
-- and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
-- NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
-- OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
-- EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- | Pretty-print a 'ParseError Char CustomErr' and display the line on --- * Constructing and throwing final parse errors
-- which the parse error occurred. The rendered 'String' always ends with
-- a newline.
customParseErrorPretty' -- | Convert a "regular" parse error into a "final" parse error.
:: ( ShowToken (Token s)
, LineToken (Token s) finalError :: ParseError Text e -> FinalParseError' e
, ShowErrorComponent e finalError = FinalError
, Stream s )
=> s -- ^ Original input stream -- | Like megaparsec's 'fancyFailure', but as a "final" parse error.
-> ParseError (Token s) e -- ^ Parse error to render
-> Pos -- ^ Length of error interval [added] finalFancyFailure
-> String -- ^ Result of rendering :: (MonadParsec e s m, MonadError (FinalParseError' e) m)
customParseErrorPretty' = customParseErrorPretty_ defaultTabWidth => S.Set (ErrorFancy e) -> m a
finalFancyFailure errSet = do
offset <- getOffset
throwError $ FinalError $ FancyError offset errSet
-- | Like 'fail', but as a "final" parse error.
finalFail
:: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a
finalFail = finalFancyFailure . S.singleton . ErrorFail
-- | Like megaparsec's 'customFailure', but as a "final" parse error.
finalCustomFailure
:: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a
finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom
customParseErrorPretty_ --- * Pretty-printing "final" parse errors
:: forall s e.
( ShowToken (Token s) -- | Pretty-print a "final" parse error: print the stack of include files,
, LineToken (Token s) -- then apply the pretty-printer for parse error bundles. Note that
, ShowErrorComponent e -- 'attachSource' must be used on a "final" parse error before it can be
, Stream s ) -- pretty-printed.
=> Pos -- ^ Tab width
-> s -- ^ Original input stream finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String
-> ParseError (Token s) e -- ^ Parse error to render finalErrorBundlePretty bundle =
-> Pos -- ^ Length of error interval [added] concatMap showIncludeFilepath (includeFileStack bundle)
-> String -- ^ Result of rendering <> customErrorBundlePretty (finalErrorBundle bundle)
customParseErrorPretty_ w s e l =
sourcePosStackPretty (errorPos e) <> ":\n" <>
padding <> "|\n" <>
lineNumber <> " | " <> rline <> "\n" <>
padding <> "| " <> rpadding <> highlight <> "\n" <> -- [added `highlight`]
parseErrorTextPretty e
where where
epos = NE.head (errorPos e) -- [changed from NE.last to NE.head] showIncludeFilepath path = "in file included from " <> path <> ",\n"
lineNumber = (show . unPos . sourceLine) epos
padding = replicate (length lineNumber + 1) ' '
rpadding = replicate (unPos (sourceColumn epos) - 1) ' '
highlight = replicate (unPos l) '^' -- [added]
rline =
case rline' of
[] -> "<empty line>"
xs -> expandTab w xs
rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $
selectLine (sourceLine epos) s
-- | Select a line from input stream given its number. -- | Supply a filepath and source text to a "final" parse error so that it
-- can be pretty-printed. You must ensure that you provide the appropriate
-- source text and filepath.
selectLine attachSource
:: forall s. (LineToken (Token s), Stream s) :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
=> Pos -- ^ Number of line to select attachSource filePath sourceText finalParseError = case finalParseError of
-> s -- ^ Input stream
-> Tokens s -- ^ Selected line -- A parse error thrown directly with the 'FinalError' constructor
selectLine l = go pos1 -- requires both source and filepath.
FinalError parseError ->
let bundle = ParseErrorBundle
{ bundleErrors = parseError NE.:| []
, bundlePosState = initialPosState filePath sourceText }
in FinalParseErrorBundle'
{ finalErrorBundle = bundle
, includeFileStack = [] }
-- A 'ParseErrorBundle' already has the appropriate source and filepath
-- and so needs neither.
FinalBundle peBundle -> FinalParseErrorBundle'
{ finalErrorBundle = peBundle
, includeFileStack = [] }
-- A parse error from a 'FinalParseErrorBundle' was thrown from an
-- include file, so we add the filepath to the stack.
FinalBundleWithStack fpeBundle -> fpeBundle
{ includeFileStack = filePath : includeFileStack fpeBundle }
--- * Handling parse errors from include files with "final" parse errors
-- | Parse a file with the given parser and initial state, discarding the
-- final state and re-throwing any parse errors as "final" parse errors.
parseIncludeFile
:: Monad m
=> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
-> st
-> FilePath
-> Text
-> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
parseIncludeFile parser initialState filepath text =
catchError parser' handler
where where
go !n !s = parser' = do
if n == l eResult <- lift $ lift $
then fst (takeWhile_ notNewline s) runParserT (evalStateT parser initialState) filepath text
else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s)) case eResult of
notNewline = not . tokenIsNewline Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle
stripNewline s = Right result -> pure result
case take1_ s of
Nothing -> s
Just (_, s') -> s'
-- | Replace tab characters with given number of spaces. -- Attach source and filepath of the include file to its parse errors
handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e
expandTab
:: Pos
-> String
-> String
expandTab w' = go 0
where
go 0 [] = []
go 0 ('\t':xs) = go w xs
go 0 (x:xs) = x : go 0 xs
go !n xs = ' ' : go (n - 1) xs
w = unPos w'
--- * Helpers
-- Like megaparsec's 'initialState', but instead for 'PosState'. Used when
-- constructing 'ParseErrorBundle's. The values for "tab width" and "line
-- prefix" are taken from 'initialState'.
initialPosState :: FilePath -> Text -> PosState Text
initialPosState filePath sourceText = PosState
{ pstateInput = sourceText
, pstateOffset = 0
, pstateSourcePos = initialPos filePath
, pstateTabWidth = defaultTabWidth
, pstateLinePrefix = "" }

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

@ -2,7 +2,7 @@
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 02f1a6c7e0679654979a211571c7d927ae759fb5831bfd8b180bab19a9bea977 -- hash: 22a6817292c6f2d53f935ce939331bea06b956c94b4e391d198760704ec294b3
name: hledger-lib name: hledger-lib
version: 1.11.99 version: 1.11.99
@ -122,7 +122,7 @@ library
, extra , extra
, filepath , filepath
, hashtables >=1.2.3.1 , hashtables >=1.2.3.1
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -222,7 +222,7 @@ test-suite doctests
, extra , extra
, filepath , filepath
, hashtables >=1.2.3.1 , hashtables >=1.2.3.1
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -322,7 +322,7 @@ test-suite easytests
, filepath , filepath
, hashtables >=1.2.3.1 , hashtables >=1.2.3.1
, hledger-lib , hledger-lib
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time

2
hledger-lib/package.yaml
View File

@ -57,7 +57,7 @@ dependencies:
- easytest - easytest
- filepath - filepath
- hashtables >=1.2.3.1 - hashtables >=1.2.3.1
- megaparsec >=6.4.1 && < 7 - megaparsec >=7.0.0 && <8
- mtl - mtl
- mtl-compat - mtl-compat
- old-time - old-time

4
hledger-ui/Hledger/UI/ErrorScreen.hs
View File

@ -112,8 +112,8 @@ esHandle _ _ = error "event handler called with wrong screen type, should not ha
-- Temporary, we should keep the original parse error location. XXX -- Temporary, we should keep the original parse error location. XXX
hledgerparseerrorpositionp :: ParsecT Void String t (String, Int, Int) hledgerparseerrorpositionp :: ParsecT Void String t (String, Int, Int)
hledgerparseerrorpositionp = do hledgerparseerrorpositionp = do
anyChar `manyTill` char '"' anySingle `manyTill` char '"'
f <- anyChar `manyTill` (oneOf ['"','\n']) f <- anySingle `manyTill` (oneOf ['"','\n'])
string " (line " string " (line "
l <- read <$> some digitChar l <- read <$> some digitChar
string ", column " string ", column "

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

@ -2,7 +2,7 @@
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 4d019af731dfbe758d41b4a95151b8ba358a733fe52ae6333854b7430aec13ff -- hash: fb0ef2467dcf115f1fc7a6f9d7781ec6912e7545a52921968067666c1747fff4
name: hledger-ui name: hledger-ui
version: 1.11.99 version: 1.11.99
@ -77,7 +77,7 @@ executable hledger-ui
, fsnotify >=0.2.1.2 && <0.4 , fsnotify >=0.2.1.2 && <0.4
, hledger >=1.11.99 && <1.12 , hledger >=1.11.99 && <1.12
, hledger-lib >=1.11.99 && <1.12 , hledger-lib >=1.11.99 && <1.12
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, microlens >=0.4 , microlens >=0.4
, microlens-platform >=0.2.3.1 , microlens-platform >=0.2.3.1
, pretty-show >=1.6.4 , pretty-show >=1.6.4

2
hledger-ui/package.yaml
View File

@ -54,7 +54,7 @@ dependencies:
- fsnotify >=0.2.1.2 && <0.4 - fsnotify >=0.2.1.2 && <0.4
- microlens >=0.4 - microlens >=0.4
- microlens-platform >=0.2.3.1 - microlens-platform >=0.2.3.1
- megaparsec >=6.4.1 && < 7 - megaparsec >=7.0.0 && <8
- pretty-show >=1.6.4 - pretty-show >=1.6.4
- process >=1.2 - process >=1.2
- safe >=0.2 - safe >=0.2

4
hledger-web/Hledger/Web/Widget/AddForm.hs
View File

@ -21,7 +21,7 @@ import qualified Data.Text as T
import Data.Time (Day) import Data.Time (Day)
import Text.Blaze.Internal (Markup, preEscapedString) import Text.Blaze.Internal (Markup, preEscapedString)
import Text.JSON import Text.JSON
import Text.Megaparsec (eof, parseErrorPretty, runParser) import Text.Megaparsec (eof, errorBundlePretty, runParser)
import Yesod import Yesod
import Hledger import Hledger
@ -131,7 +131,7 @@ validatePostings a b =
catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs
catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs
errorToFormMsg = first (("Invalid value: " <>) . T.pack . parseErrorPretty) errorToFormMsg = first (("Invalid value: " <>) . T.pack . errorBundlePretty)
validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip

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

@ -2,7 +2,7 @@
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 3a93b8df7229c5b65b88f7003205c93bcc295013203a85e0ed937303c18d8c84 -- hash: 443e668fdd64fb57d1d9488224df0bc6ee4e796bcc75f81655a92850ff809d34
name: hledger-web name: hledger-web
version: 1.11.99 version: 1.11.99
@ -127,8 +127,6 @@ flag threaded
default: True default: True
library library
hs-source-dirs:
./.
exposed-modules: exposed-modules:
Hledger.Web Hledger.Web
Hledger.Web.Application Hledger.Web.Application
@ -148,6 +146,8 @@ library
Hledger.Web.Widget.Common Hledger.Web.Widget.Common
other-modules: other-modules:
Paths_hledger_web Paths_hledger_web
hs-source-dirs:
./.
ghc-options: -Wall -fwarn-tabs ghc-options: -Wall -fwarn-tabs
cpp-options: -DVERSION="1.11.99" cpp-options: -DVERSION="1.11.99"
build-depends: build-depends:
@ -169,7 +169,7 @@ library
, http-client , http-client
, http-conduit , http-conduit
, json , json
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, semigroups , semigroups
, shakespeare >=2.0.2.2 , shakespeare >=2.0.2.2

2
hledger-web/package.yaml
View File

@ -114,7 +114,7 @@ library:
- http-conduit - http-conduit
- http-client - http-client
- json - json
- megaparsec >=6.4.1 && < 7 - megaparsec >=7.0.0 && <8
- mtl - mtl
- semigroups - semigroups
- shakespeare >=2.0.2.2 - shakespeare >=2.0.2.2

2
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -296,7 +296,7 @@ amountAndCommentWizard EntryState{..} = do
amountandcommentp = do amountandcommentp = do
a <- amountp a <- amountp
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar) c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle)
-- eof -- eof
return (a,c) return (a,c)
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings

2
hledger/Hledger/Cli/Commands/Rewrite.hs
View File

@ -193,7 +193,7 @@ transactionModifierFromOpts CliOpts{rawopts_=rawopts,reportopts_=ropts} =
where where
q = T.pack $ query_ ropts q = T.pack $ query_ ropts
ps = map (parseposting . stripquotes . T.pack) $ listofstringopt "add-posting" rawopts ps = map (parseposting . stripquotes . T.pack) $ listofstringopt "add-posting" rawopts
parseposting t = either (error' . parseErrorPretty' t') id ep parseposting t = either (error' . errorBundlePretty) id ep
where where
ep = runIdentity (runJournalParser (postingp Nothing <* eof) t') ep = runIdentity (runJournalParser (postingp Nothing <* eof) t')
t' = " " <> t <> "\n" -- inject space and newline for proper parsing t' = " " <> t <> "\n" -- inject space and newline for proper parsing

10
hledger/hledger.cabal
View File

@ -2,7 +2,7 @@
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: fc4b42dee35f79a4fed845e87b2e5c08b3c68466fe1cf59d952e6be4f15df413 -- hash: 78515e93d6f08be6d098bdd697b951a1577e4e71c6b24ad64cf69916d3af191c
name: hledger name: hledger
version: 1.11.99 version: 1.11.99
@ -131,7 +131,7 @@ library
, here , here
, hledger-lib >=1.11.99 && <1.12 , hledger-lib >=1.11.99 && <1.12
, lucid , lucid
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -182,7 +182,7 @@ executable hledger
, here , here
, hledger , hledger
, hledger-lib >=1.11.99 && <1.12 , hledger-lib >=1.11.99 && <1.12
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -236,7 +236,7 @@ test-suite test
, here , here
, hledger , hledger
, hledger-lib >=1.11.99 && <1.12 , hledger-lib >=1.11.99 && <1.12
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -291,7 +291,7 @@ benchmark bench
, hledger , hledger
, hledger-lib >=1.11.99 && <1.12 , hledger-lib >=1.11.99 && <1.12
, html , html
, megaparsec >=6.4.1 && <7 , megaparsec >=7.0.0 && <8
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time

2
hledger/package.yaml
View File

@ -93,7 +93,7 @@ dependencies:
- filepath - filepath
- haskeline >=0.6 - haskeline >=0.6
- here - here
- megaparsec >=6.4.1 && < 7 - megaparsec >=7.0.0 && <8
- mtl - mtl
- mtl-compat - mtl-compat
- old-time - old-time

8
stack-ghc7.10.yaml
View File

@ -26,8 +26,8 @@ extra-deps:
- base-orphans-0.7 - base-orphans-0.7
- bifunctors-5.5.2 - bifunctors-5.5.2
- brick-0.37.1 - brick-0.37.1
- cassava-megaparsec-1.0.0 - cassava-megaparsec-2.0.0
- config-ini-0.2.2.0 - config-ini-0.2.3.0
- criterion-1.4.1.0 - criterion-1.4.1.0
- data-clist-0.1.2.1 - data-clist-0.1.2.1
- directory-1.2.7.0 - directory-1.2.7.0
@ -43,13 +43,13 @@ extra-deps:
- integer-logarithms-1.0.2.1 - integer-logarithms-1.0.2.1
- kan-extensions-5.1 - kan-extensions-5.1
- lens-4.16.1 - lens-4.16.1
- megaparsec-6.4.1 - megaparsec-7.0.1
- microstache-1.0.1.1 - microstache-1.0.1.1
- mmorph-1.1.2 - mmorph-1.1.2
- monad-control-1.0.2.3 - monad-control-1.0.2.3
- network-2.6.3.5 - network-2.6.3.5
- optparse-applicative-0.14.2.0 - optparse-applicative-0.14.2.0
- parser-combinators-0.4.0 - parser-combinators-1.0.0
- persistent-2.7.0 - persistent-2.7.0
- persistent-template-2.5.4 - persistent-template-2.5.4
- profunctors-5.2.2 - profunctors-5.2.2

7
stack-ghc8.0.yaml
View File

@ -20,7 +20,8 @@ extra-deps:
- base-compat-0.10.1 - base-compat-0.10.1
- base-compat-batteries-0.10.1 - base-compat-batteries-0.10.1
- bifunctors-5.5.2 - bifunctors-5.5.2
- cassava-megaparsec-1.0.0 - cassava-megaparsec-2.0.0
- config-ini-0.2.3.0
- criterion-1.4.1.0 - criterion-1.4.1.0
- doctest-0.16.0 - doctest-0.16.0
- generics-sop-0.3.2.0 - generics-sop-0.3.2.0
@ -29,11 +30,11 @@ extra-deps:
- http-types-0.12.1 - http-types-0.12.1
- insert-ordered-containers-0.2.1.0 - insert-ordered-containers-0.2.1.0
- lens-4.16.1 - lens-4.16.1
- megaparsec-6.4.1 - megaparsec-7.0.1
- microstache-1.0.1.1 - microstache-1.0.1.1
- mmorph-1.1.2 - mmorph-1.1.2
- network-2.6.3.5 - network-2.6.3.5
- parser-combinators-0.4.0 - parser-combinators-1.0.0
- persistent-template-2.5.4 - persistent-template-2.5.4
- scientific-0.3.6.2 - scientific-0.3.6.2
- servant-0.13.0.1 - servant-0.13.0.1

5
stack-ghc8.2.yaml
View File

@ -15,9 +15,12 @@ extra-deps:
- aeson-1.3.1.1 - aeson-1.3.1.1
- base-compat-0.10.1 - base-compat-0.10.1
- base-compat-batteries-0.10.1 - base-compat-batteries-0.10.1
- cassava-megaparsec-1.0.0 - cassava-megaparsec-2.0.0
- config-ini-0.2.3.0
- criterion-1.4.1.0 - criterion-1.4.1.0
- doctest-0.16.0 - doctest-0.16.0
- megaparsec-7.0.1
- parser-combinators-1.0.0
- swagger2-2.2.2 - swagger2-2.2.2
# avoid no hashable instance for AccountName from doctests # avoid no hashable instance for AccountName from doctests
- hashtables-1.2.3.1 - hashtables-1.2.3.1

4
stack.yaml
View File

@ -10,7 +10,9 @@ packages:
- hledger-api - hledger-api
extra-deps: extra-deps:
- cassava-megaparsec-1.0.0 - cassava-megaparsec-2.0.0
- megaparsec-7.0.1
- config-ini-0.2.3.0
nix: nix:
pure: false pure: false

2
tests/journal/parse-errors.test
View File

@ -12,7 +12,7 @@ hledger: -:1:5:
1 | 2018 1 | 2018
| ^ | ^
unexpected newline unexpected newline
expecting date separator or the rest of year or month expecting date separator or digit
>=1 >=1