simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-09-19 02:08:01 +03:00
Code Issues Projects Releases Wiki Activity

lib: switch to megaparsec 7

Browse Source
This commit is contained in:
Alex Chen 2018-09-29 19:32:08 -06:00
parent 26369c28a3
commit 3d2584d869
28 changed files with 282 additions and 349 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 "base-compat-batteries" Prelude.Compat
import Control.Applicative.Permutations
import Control.Monad
import "base-compat-batteries" Data.List.Compat
import Data.Default
@ -96,7 +97,7 @@ import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay)
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Perm
import Text.Megaparsec.Custom
import Text.Printf
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
-- 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)
-- | Like parsePeriodExpr, but call error' on failure.
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' refdate s =
either (error' . ("failed to parse:" ++) . parseErrorPretty) id $
either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $
parsePeriodExpr refdate s
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
@ -380,13 +382,14 @@ fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id
$ (fixSmartDateStrEither d s :: Either (ParseError Char CustomErr) String)
$ (fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)
-- | 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' :: 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
Right sd -> Right $ fixSmartDate d sd
Left e -> Left e
@ -987,7 +990,9 @@ reportingintervalp = choice' [
return $ DayOfMonth n,
do string' "every"
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"
return d_o_y,
do string' "every"

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

@ -194,12 +194,15 @@ rawOptsToInputOpts rawopts = InputOpts{
--- * parsing utilities
-- | 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
rtp = runTextParser
-- | 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
rjp = runJournalParser
@ -208,7 +211,7 @@ runErroringJournalParser, rejp
:: Monad m
=> ErroringJournalParser m a
-> Text
-> m (Either FinalParseError (Either (ParseError Char CustomErr) a))
-> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
runErroringJournalParser p t =
runExceptT $ runParserT (evalStateT p mempty) "" t
rejp = runErroringJournalParser
@ -246,10 +249,10 @@ parseAndFinaliseJournal parser iopts f txt = do
runParserT (evalStateT parser initJournal) f txt
case eep of
Left finalParseError ->
throwError $ finalParseErrorPretty $ attachSource f txt finalParseError
throwError $ finalErrorBundlePretty $ attachSource f txt finalParseError
Right ep -> case ep of
Left e -> throwError $ customParseErrorPretty txt e
Left e -> throwError $ customErrorBundlePretty e
Right pj ->
let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in
@ -267,7 +270,7 @@ parseAndFinaliseJournal' parser iopts f txt = do
, jincludefilestack = [f] }
ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt
case ep of
Left e -> throwError $ customParseErrorPretty txt e
Left e -> throwError $ customErrorBundlePretty e
Right pj ->
let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in
@ -385,43 +388,43 @@ datep = do
datep' :: Maybe Year -> TextParser m Day
datep' mYear = do
startPos <- getPosition
startOffset <- getOffset
d1 <- decimal <?> "year or month"
sep <- satisfy isDateSepChar <?> "date separator"
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"
where
fullDate :: SourcePos -> Integer -> Char -> Int -> TextParser m Day
fullDate startPos year sep1 month = do
fullDate :: Int -> Integer -> Char -> Int -> TextParser m Day
fullDate startOffset year sep1 month = do
sep2 <- satisfy isDateSepChar <?> "date separator"
day <- decimal <?> "day"
endPos <- getPosition
endOffset <- getOffset
let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day
when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startPos endPos $
when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startOffset endOffset $
"invalid date (mixing date separators is not allowed): " ++ dateStr
case fromGregorianValid year month day of
Nothing -> customFailure $ parseErrorAtRegion startPos endPos $
Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"well-formed but invalid date: " ++ dateStr
Just date -> pure $! date
partialDate
:: SourcePos -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day
partialDate startPos mYear month sep day = do
endPos <- getPosition
:: Int -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day
partialDate startOffset mYear month sep day = do
endOffset <- getOffset
case mYear of
Just year ->
case fromGregorianValid year (fromIntegral month) day of
Nothing -> customFailure $ parseErrorAtRegion startPos endPos $
Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"well-formed but invalid date: " ++ dateStr
Just date -> pure $! date
where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day
Nothing -> customFailure $ parseErrorAtRegion startPos endPos $
Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"partial date "++dateStr++" found, but the current year is unknown"
where dateStr = show month ++ [sep] ++ show day
@ -449,26 +452,26 @@ datetimep' mYear = do
where
timeOfDay :: TextParser m TimeOfDay
timeOfDay = do
pos1 <- getPosition
off1 <- getOffset
h' <- twoDigitDecimal <?> "hour"
pos2 <- getPosition
off2 <- getOffset
unless (h' >= 0 && h' <= 23) $ customFailure $
parseErrorAtRegion pos1 pos2 "invalid time (bad hour)"
parseErrorAtRegion off1 off2 "invalid time (bad hour)"
char ':' <?> "':' (hour-minute separator)"
pos3 <- getPosition
off3 <- getOffset
m' <- twoDigitDecimal <?> "minute"
pos4 <- getPosition
off4 <- getOffset
unless (m' >= 0 && m' <= 59) $ customFailure $
parseErrorAtRegion pos3 pos4 "invalid time (bad minute)"
parseErrorAtRegion off3 off4 "invalid time (bad minute)"
s' <- option 0 $ do
char ':' <?> "':' (minute-second separator)"
pos5 <- getPosition
off5 <- getOffset
s' <- twoDigitDecimal <?> "second"
pos6 <- getPosition
off6 <- getOffset
unless (s' >= 0 && s' <= 59) $ customFailure $
parseErrorAtRegion pos5 pos6 "invalid time (bad second)"
parseErrorAtRegion off5 off6 "invalid time (bad second)"
-- we do not support leap seconds
pure s'
@ -565,22 +568,22 @@ amountwithoutpricep = do
suggestedStyle <- getAmountStyle c
commodityspaced <- lift $ skipMany' spacenonewline
sign2 <- lift $ signp
posBeforeNum <- getPosition
offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp
posAfterNum <- getPosition
let numRegion = (posBeforeNum, posAfterNum)
offAfterNum <- getOffset
let numRegion = (offBeforeNum, offAfterNum)
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return $ Amount c (sign (sign2 q)) NoPrice s mult
rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
rightornosymbolamountp mult sign = label "amount" $ do
posBeforeNum <- getPosition
offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp
posAfterNum <- getPosition
let numRegion = (posBeforeNum, posAfterNum)
offAfterNum <- getOffset
let numRegion = (offBeforeNum, offAfterNum)
mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipMany' spacenonewline <*> commoditysymbolp
case mSpaceAndCommodity of
-- right symbol amount
@ -604,7 +607,7 @@ amountwithoutpricep = do
-- For reducing code duplication. Doesn't parse anything. Has the type
-- of a parser only in order to throw parse errors (for convenience).
interpretNumber
:: (SourcePos, SourcePos)
:: (Int, Int) -- offsets
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Int
@ -671,7 +674,7 @@ partialbalanceassertionp :: JournalParser m BalanceAssertion
partialbalanceassertionp = optional $ do
sourcepos <- try $ do
lift (skipMany spacenonewline)
sourcepos <- genericSourcePos <$> lift getPosition
sourcepos <- genericSourcePos <$> lift getSourcePos
char '='
pure sourcepos
lift (skipMany spacenonewline)
@ -830,10 +833,10 @@ rawnumberp = label "number" $ do
fail "invalid number (invalid use of separator)"
mExtraFragment <- optional $ lookAhead $ try $
char ' ' *> getPosition <* digitChar
char ' ' *> getOffset <* digitChar
case mExtraFragment of
Just pos -> customFailure $
parseErrorAt pos "invalid number (excessive trailing digits)"
Just off -> customFailure $
parseErrorAt off "invalid number (excessive trailing digits)"
Nothing -> pure ()
return $ dbg8 "rawnumberp" rawNumber
@ -1193,19 +1196,19 @@ commenttagsanddatesp mYear = do
-- default date is provided. A missing year in DATE2 will be inferred
-- 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)]
--
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]"
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]"
-- Left ...not a bracketed date...
--
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"
-- Left ...1:11:...well-formed but invalid date: 2016/1/32...
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"
-- Left ...1:2:...well-formed but invalid date: 2016/1/32...
--
-- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"
-- Left ...1:6:...partial date 1/31 found, but the current year is unknown...
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"
-- 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...
--
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 Data.Char (toLower, isDigit, isSpace, ord)
import "base-compat-batteries" Data.List.Compat
import Data.List.NonEmpty (fromList)
import Data.Maybe
import Data.Ord
import qualified Data.Set as S
@ -59,12 +58,12 @@ import System.FilePath
import qualified Data.Csv as Cassava
import qualified Data.Csv.Parser.Megaparsec as CassavaMP
import qualified Data.ByteString as B
import Data.ByteString.Lazy (fromStrict)
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Text.Megaparsec.Custom
import Text.Printf (printf)
import Data.Word
import Hledger.Data
import Hledger.Utils
@ -76,7 +75,7 @@ type Record = [Field]
type Field = String
data CSVError = CSVError (ParseError Word8 CassavaMP.ConversionError)
data CSVError = CSVError (ParseErrorBundle BL.ByteString CassavaMP.ConversionError)
deriving Show
reader :: Reader
@ -193,7 +192,7 @@ parseCassava separator path content =
Left msg -> Left $ CSVError msg
Right a -> Right a
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 separator = Cassava.defaultDecodeOptions {
@ -431,19 +430,19 @@ parseAndValidateCsvRules :: FilePath -> T.Text -> ExceptT String IO CsvRules
parseAndValidateCsvRules rulesfile s = do
let rules = parseCsvRules rulesfile s
case rules of
Left e -> ExceptT $ return $ Left $ parseErrorPretty e
Left e -> ExceptT $ return $ Left $ customErrorBundlePretty e
Right r -> do
r_ <- liftIO $ runExceptT $ validateRules r
ExceptT $ case r_ of
Left s -> return $ Left $ parseErrorPretty $ makeParseError rulesfile s
Left s -> return $ Left $ parseErrorPretty $ makeParseError s
Right r -> return $ Right r
where
makeParseError :: FilePath -> String -> ParseError Char String
makeParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s)
makeParseError :: String -> ParseError T.Text String
makeParseError s = FancyError 0 (S.singleton $ ErrorFail s)
-- | 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 (evalStateT rulesp rules) rulesfile s
@ -513,7 +512,7 @@ directives =
]
directivevalp :: CsvRulesParser String
directivevalp = anyChar `manyTill` lift eolof
directivevalp = anySingle `manyTill` lift eolof
fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do
@ -588,7 +587,7 @@ assignmentseparatorp = do
fieldvalp :: CsvRulesParser String
fieldvalp = do
lift $ dbgparse 2 "trying fieldvalp"
anyChar `manyTill` lift eolof
anySingle `manyTill` lift eolof
conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do
@ -631,7 +630,7 @@ regexp = do
lift $ dbgparse 3 "trying regexp"
notFollowedBy matchoperatorp
c <- lift nonspace
cs <- anyChar `manyTill` lift eolof
cs <- anySingle `manyTill` lift eolof
return $ strip $ c:cs
-- fieldmatcher = do

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

@ -180,30 +180,32 @@ includedirectivep = do
lift (skipSome spacenonewline)
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
void newline
where
getFilePaths :: MonadIO m => SourcePos -> FilePath -> JournalParser m [FilePath]
getFilePaths parserpos filename = do
getFilePaths
:: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath]
getFilePaths parseroff parserpos filename = do
curdir <- lift $ expandPath (takeDirectory $ sourceName parserpos) ""
`orRethrowIOError` (show parserpos ++ " locating " ++ filename)
-- Compiling filename as a glob pattern works even if it is a literal
fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of
Right x -> pure x
Left e -> customFailure $
parseErrorAt parserpos $ "Invalid glob pattern: " ++ e
parseErrorAt parseroff $ "Invalid glob pattern: " ++ e
-- Get all matching files in the current working directory, sorting in
-- lexicographic order to simulate the output of 'ls'.
filepaths <- liftIO $ sort <$> globDir1 fileglob curdir
if (not . null) filepaths
then pure filepaths
else customFailure $ parseErrorAt parserpos $
else customFailure $ parseErrorAt parseroff $
"No existing files match pattern: " ++ filename
parseChild :: MonadIO m => SourcePos -> FilePath -> ErroringJournalParser m ()
@ -229,7 +231,6 @@ includedirectivep = do
-- discard child's parse info, combine other fields
put $ updatedChildj <> parentj
newJournalWithParseStateFrom :: FilePath -> Journal -> Journal
newJournalWithParseStateFrom filepath j = mempty{
jparsedefaultyear = jparsedefaultyear j
@ -279,17 +280,17 @@ commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultiline
-- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
commoditydirectiveonelinep :: JournalParser m ()
commoditydirectiveonelinep = do
(pos, Amount{acommodity,astyle}) <- try $ do
(off, Amount{acommodity,astyle}) <- try $ do
string "commodity"
lift (skipSome spacenonewline)
pos <- getPosition
off <- getOffset
amount <- amountp
pure $ (pos, amount)
pure $ (off, amount)
lift (skipMany spacenonewline)
_ <- lift followingcommentp
let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle}
if asdecimalpoint astyle == Nothing
then customFailure $ parseErrorAt pos pleaseincludedecimalpoint
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
pleaseincludedecimalpoint :: String
@ -316,15 +317,15 @@ formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle
formatdirectivep expectedsym = do
string "format"
lift (skipSome spacenonewline)
pos <- getPosition
off <- getOffset
Amount{acommodity,astyle} <- amountp
_ <- lift followingcommentp
if acommodity==expectedsym
then
if asdecimalpoint astyle == Nothing
then customFailure $ parseErrorAt pos pleaseincludedecimalpoint
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else return $ dbg2 "style from format subdirective" astyle
else customFailure $ parseErrorAt pos $
else customFailure $ parseErrorAt off $
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
keywordp :: String -> JournalParser m ()
@ -366,7 +367,7 @@ basicaliasp = do
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
char '='
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)
regexaliasp :: TextParser m AccountAlias
@ -378,7 +379,7 @@ regexaliasp = do
skipMany spacenonewline
char '='
skipMany spacenonewline
repl <- anyChar `manyTill` eolof
repl <- anySingle `manyTill` eolof
return $ RegexAlias re repl
endaliasesdirectivep :: JournalParser m ()
@ -413,11 +414,11 @@ defaultcommoditydirectivep :: JournalParser m ()
defaultcommoditydirectivep = do
char 'D' <?> "default commodity"
lift (skipSome spacenonewline)
pos <- getPosition
off <- getOffset
Amount{acommodity,astyle} <- amountp
lift restofline
if asdecimalpoint astyle == Nothing
then customFailure $ parseErrorAt pos pleaseincludedecimalpoint
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: JournalParser m MarketPrice
@ -471,12 +472,12 @@ periodictransactionp = do
char '~' <?> "periodic transaction"
lift $ skipMany spacenonewline
-- a period expression
pos <- getPosition
off <- getOffset
d <- liftIO getCurrentDay
(periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp d)
-- In periodic transactions, the period expression has an additional constraint:
case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> customFailure $ parseErrorAt pos e
Just e -> customFailure $ parseErrorAt off e
Nothing -> pure ()
-- 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.
@ -511,7 +512,7 @@ periodictransactionp = do
transactionp :: JournalParser m Transaction
transactionp = do
-- dbgparse 0 "transactionp"
startpos <- getPosition
startpos <- getSourcePos
date <- datep <?> "transaction"
edate <- optional (lift $ secondarydatep date) <?> "secondary date"
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
@ -521,7 +522,7 @@ transactionp = do
(comment, tags) <- lift transactioncommentp
let year = first3 $ toGregorian date
postings <- postingsp (Just year)
endpos <- getPosition
endpos <- getSourcePos
let sourcepos = journalSourcePos startpos endpos
return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings ""
@ -589,8 +590,9 @@ tests_JournalReader = tests "JournalReader" [
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 default year" $ do
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep "1/1"
either (fail.("parse error at "++).parseErrorPretty) (const ok) ep
let s = "1/1"
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 "datetimep" $ do

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

@ -58,7 +58,6 @@ import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Hledger.Data
-- XXX too much reuse ?
@ -105,7 +104,7 @@ timeclockfilep = do many timeclockitemp
-- | Parse a timeclock entry.
timeclockentryp :: JournalParser m TimeclockEntry
timeclockentryp = do
sourcepos <- genericSourcePos <$> lift getPosition
sourcepos <- genericSourcePos <$> lift getSourcePos
code <- oneOf ("bhioO" :: [Char])
lift (skipSome spacenonewline)
datetime <- datetimep

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

@ -104,7 +104,7 @@ timedotdayp = do
timedotentryp :: JournalParser m Transaction
timedotentryp = do
traceParse " timedotentryp"
pos <- genericSourcePos <$> getPosition
pos <- genericSourcePos <$> getSourcePos
lift (skipMany spacenonewline)
a <- modifiedaccountnamep
lift (skipMany spacenonewline)

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

@ -48,7 +48,7 @@ import Data.Default
import Safe
import System.Console.ANSI (hSupportsANSI)
import System.IO (stdout)
import Text.Megaparsec.Error
import Text.Megaparsec.Custom
import Hledger.Data
import Hledger.Query
@ -240,11 +240,11 @@ beginDatesFromRawOpts d = catMaybes . map (begindatefromrawopt d)
where
begindatefromrawopt d (n,v)
| 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)
| n == "period" =
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)
of
(_, DateSpan (Just b) _) -> Just b
@ -258,11 +258,11 @@ endDatesFromRawOpts d = catMaybes . map (enddatefromrawopt d)
where
enddatefromrawopt d (n,v)
| 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)
| n == "period" =
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)
of
(_, DateSpan _ (Just e)) -> Just e
@ -276,7 +276,7 @@ intervalFromRawOpts = lastDef NoInterval . catMaybes . map intervalfromrawopt
where
intervalfromrawopt (n,v)
| 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
| n == "daily" = Just $ Days 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.)
traceParse :: String -> TextParser m ()
traceParse msg = do
pos <- getPosition
pos <- getSourcePos
next <- (T.take peeklength) `fmap` getInput
let (l,c) = (sourceLine pos, sourceColumn pos)
s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String

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

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Hledger.Utils.Parse (
@ -72,15 +73,21 @@ choiceInState = choice . map try
surroundedBy :: Applicative m => m openclose -> m a -> m a
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 ""
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 ""
-- | Run a stateful parser with some initial state on a text.
-- 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'
@ -88,19 +95,23 @@ parseWithState'
=> st
-> StateT st (ParsecT e s Identity) a
-> s
-> (Either (ParseError (Token s) e) a)
-> (Either (ParseErrorBundle s e) a)
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
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
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
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)
nonspace :: TextParser m Char
@ -113,7 +124,7 @@ spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
spacenonewline = satisfy isNonNewlineSpace
restofline :: TextParser m String
restofline = anyChar `manyTill` newline
restofline = anySingle `manyTill` newline
eolof :: TextParser m ()
eolof = (newline >> return ()) <|> eof

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

@ -112,7 +112,9 @@ expectParse :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test ()
expectParse parser input = do
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
@ -126,11 +128,12 @@ expectParseE parser input = do
runParserT (evalStateT (parser <* eof) mempty) filepath input
case eep of
Left finalErr ->
let prettyErr = finalParseErrorPretty $ attachSource filepath input finalErr
let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr
in fail $ "parse error at " <> prettyErr
Right ep -> either (fail.(++"\n").("\nparse error at "++).parseErrorPretty)
(const ok)
ep
Right ep ->
either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty)
(const ok)
ep
-- | Test that this stateful parser runnable in IO fails to parse
-- the given input text, with a parse error containing the given string.
@ -141,7 +144,7 @@ expectParseError parser input errstr = do
case ep of
Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"
Left e -> do
let e' = parseErrorPretty e
let e' = customErrorBundlePretty e
if errstr `isInfixOf` e'
then ok
else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
@ -157,14 +160,14 @@ expectParseErrorE parser input errstr = do
eep <- E.io $ runExceptT $ runParserT (evalStateT parser mempty) filepath input
case eep of
Left finalErr -> do
let prettyErr = finalParseErrorPretty $ attachSource filepath input finalErr
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' = parseErrorPretty e
let e' = customErrorBundlePretty e
if errstr `isInfixOf` e'
then ok
else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
@ -189,7 +192,9 @@ expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOn parser input f expected = do
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)
@ -204,10 +209,10 @@ expectParseEqOnE parser input f expected = do
runParserT (evalStateT (parser <* eof) mempty) filepath input
case eep of
Left finalErr ->
let prettyErr = finalParseErrorPretty $ attachSource filepath input finalErr
let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr
in fail $ "parse error at " <> prettyErr
Right ep ->
either (fail . (++"\n") . ("\nparse error at "++) . parseErrorPretty)
either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)
(expectEqPP expected . f)
ep

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

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PackageImports #-}
@ -14,7 +13,7 @@ module Text.Megaparsec.Custom (
parseErrorAtRegion,
-- * Pretty-printing custom parse errors
customParseErrorPretty,
customErrorBundlePretty,
-- * Final parse error types
@ -24,7 +23,7 @@ module Text.Megaparsec.Custom (
FinalParseErrorBundle',
-- * Constructing final parse errors
errorFinal,
finalError,
finalFancyFailure,
finalFail,
finalCustomFailure,
@ -34,7 +33,7 @@ module Text.Megaparsec.Custom (
attachSource,
-- * Pretty-printing final parse errors
finalParseErrorPretty,
finalErrorBundlePretty,
)
where
@ -45,10 +44,8 @@ import Control.Monad.Except
import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Foldable (asum, toList)
import qualified Data.List.NonEmpty as NE
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as S
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec
@ -60,8 +57,8 @@ import Text.Megaparsec
data CustomErr
-- | Fail with a message at a specific source position interval. The
-- interval must be contained within a single line.
= ErrorFailAt SourcePos -- Starting position
Pos -- Ending position (column; same line as start)
= ErrorFailAt Int -- Starting offset
Int -- Ending offset
String -- Error message
deriving (Show, Eq, Ord)
@ -70,62 +67,68 @@ data CustomErr
-- derive it, but this requires an (orphan) instance for 'ParseError'.
-- 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
showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg
errorComponentLen (ErrorFailAt startOffset endOffset _) =
endOffset - startOffset
--- * 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 :: SourcePos -> String -> CustomErr
parseErrorAt pos msg = ErrorFailAt pos (sourceColumn pos) msg
parseErrorAt :: Int -> String -> CustomErr
parseErrorAt offset msg = ErrorFailAt offset (offset+1) msg
-- | Fail at a specific source interval (within a single line). The
-- interval is inclusive on the left and exclusive on the right; that is,
-- it spans from the start position to just before (and not including) the
-- end position.
-- | Fail at a specific source interval, given by the raw offsets of its
-- endpoints from the start of the input stream (the numbers of tokens
-- processed at those points).
--
-- 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
:: SourcePos -- ^ Start position
-> SourcePos -- ^ End position
-> String -- ^ Error message
:: Int -- ^ Start offset
-> Int -- ^ End end offset
-> String -- ^ Error message
-> CustomErr
parseErrorAtRegion startPos endPos msg =
let startCol = sourceColumn startPos
endCol' = mkPos $ subtract 1 $ unPos $ sourceColumn endPos
endCol = if startCol <= endCol'
&& sourceLine startPos == sourceLine endPos
then endCol' else startCol
in ErrorFailAt startPos endCol msg
parseErrorAtRegion startOffset endOffset msg =
if startOffset < endOffset
then ErrorFailAt startOffset endOffset msg
else ErrorFailAt startOffset (startOffset+1) msg
--- * Pretty-printing custom parse errors
-- | 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
-- only one custom error should be used at a time).
-- Use this instead of 'errorBundlePretty' when custom parse errors are
-- thrown, otherwise the continuous highlighting in the pretty-printed
-- parse error will be displaced from its proper position.
customParseErrorPretty :: Text -> ParseError Char CustomErr -> String
customParseErrorPretty source err = case findCustomError err of
Nothing -> customParseErrorPretty' source err pos1
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
customErrorBundlePretty :: ParseErrorBundle Text CustomErr -> String
customErrorBundlePretty errBundle =
let errBundle' = errBundle
{ bundleErrors = fmap setCustomErrorOffset $ bundleErrors errBundle }
in errorBundlePretty errBundle'
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
FancyError _ errSet ->
finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
@ -139,23 +142,26 @@ customParseErrorPretty source err = case findCustomError err of
-- | A parse error type intended for throwing parse errors without the
-- possiblity of backtracking. Intended for use as the error type in an
-- 'ExceptT' layer of the parser.
-- 'ExceptT' layer of the parser. The 'ExceptT' layer is responsible for
-- handling include files, so this type also records a stack of include
-- files in order to report the stack in parse errors.
--
-- In order to pretty-print a parse error, we must bundle it with the
-- source text and its filepaths (the 'ErrorBundle' constructor). However,
-- when an 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 the source text and its filepath by the parser's caller
-- (the 'ErrorFinal' constructor).
-- In order to pretty-print our custom parse errors, we must bundle them
-- with their full source text and filepaths (the 'FinalBundleWithStack'
-- constructor). However, when an error is thrown from within a parser, we
-- do not have access to the full source, so we must hold the parse error
-- (the 'FinalError' constructor) until it can be joined with the source
-- text and its filepath by the parser's caller.
data FinalParseError' e
= ErrorFinal (ParseError Char e)
| ErrorBundle (FinalParseErrorBundle' e)
= FinalError (ParseError Text e)
| FinalBundle (ParseErrorBundle Text e)
| FinalBundleWithStack (FinalParseErrorBundle' e)
deriving (Show)
type FinalParseError = FinalParseError' CustomErr
-- A 'Monoid' instance is necessary for 'ExceptT (FinalParseError'' e)' to
-- A 'Monoid' instance is necessary for 'ExceptT (FinalParseError' e)' to
-- be an instance of Alternative and MonadPlus, which are required for the
-- use of e.g. the 'many' parser combinator. This monoid instance simply
-- takes the first (left-most) error.
@ -164,22 +170,16 @@ instance Semigroup (FinalParseError' e) where
e <> _ = e
instance Monoid (FinalParseError' e) where
mempty = ErrorFinal $
FancyError (initialPos "" NE.:| [])
(S.singleton (ErrorFail "default parse error"))
mempty = FinalError $ FancyError 0 $
S.singleton (ErrorFail "default parse error")
mappend = (<>)
-- | A type bundling a 'ParseError' with its source file and a stack of
-- include file paths (for pretty printing). Although Megaparsec 6
-- maintains a stack of source files, making a field of this type
-- redundant, this capability will be removed in Megaparsec 7. Therefore,
-- we implement stacks of source files here for a smoother transition in
-- the future.
-- | A type bundling a 'ParseError' with its full source file and a stack
-- of include file paths (for pretty printing).
data FinalParseErrorBundle' e = FinalParseErrorBundle'
{ finalParseError :: ParseError Char e
, errorSource :: Text
, sourceFileStack :: NE.NonEmpty FilePath
{ finalErrorBundle :: ParseErrorBundle Text e
, sourceFileStack :: NE.NonEmpty FilePath
} deriving (Show)
type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr
@ -189,8 +189,8 @@ type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr
-- | Convert a "regular" parse error into a "final" parse error.
errorFinal :: ParseError Char e -> FinalParseError' e
errorFinal = ErrorFinal
finalError :: ParseError Text e -> FinalParseError' e
finalError = FinalError
-- | Like 'fancyFailure', but as a "final" parse error.
@ -198,9 +198,8 @@ finalFancyFailure
:: (MonadParsec e s m, MonadError (FinalParseError' e) m)
=> S.Set (ErrorFancy e) -> m a
finalFancyFailure errSet = do
pos <- getPosition
let parseErr = FancyError (pos NE.:| []) errSet
throwError $ ErrorFinal parseErr
offset <- getOffset
throwError $ FinalError $ FancyError offset errSet
-- | Like 'fail', but as a "final" parse error.
@ -235,24 +234,30 @@ parseIncludeFile parser initState filepath text =
eResult <- lift $ lift $
runParserT (evalStateT parser initState) filepath text
case eResult of
Left parseError -> throwError $ errorFinal parseError
Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle
Right result -> pure result
handler e = throwError $ ErrorBundle $ attachSource filepath text e
handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e
attachSource
:: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource filePath sourceText finalParseError =
case finalParseError of
ErrorFinal parseError -> FinalParseErrorBundle'
{ finalParseError = parseError
, errorSource = sourceText
, sourceFileStack = filePath NE.:| []
}
ErrorBundle bundle -> bundle
{ sourceFileStack = filePath NE.<| sourceFileStack bundle
}
attachSource filePath sourceText finalParseError = case finalParseError of
FinalError parseError ->
let bundle = ParseErrorBundle
{ bundleErrors = parseError NE.:| []
, bundlePosState = initialPosState filePath sourceText }
in FinalParseErrorBundle'
{ finalErrorBundle = bundle
, sourceFileStack = filePath NE.:| [] }
FinalBundle peBundle -> FinalParseErrorBundle'
{ finalErrorBundle = peBundle
, sourceFileStack = filePath NE.:| [] }
FinalBundleWithStack fpeBundle -> fpeBundle
{ sourceFileStack = filePath NE.<| sourceFileStack fpeBundle }
--- * Pretty-printing final parse errors
@ -260,125 +265,23 @@ attachSource filePath sourceText finalParseError =
-- | Pretty-print a "final" parse error: print the stack of include files,
-- then apply the pretty-printer for custom parse errors.
finalParseErrorPretty :: FinalParseErrorBundle' CustomErr -> String
finalParseErrorPretty bundle =
finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String
finalErrorBundlePretty bundle =
concatMap printIncludeFile (NE.init (sourceFileStack bundle))
<> customParseErrorPretty (errorSource bundle) (finalParseError bundle)
<> customErrorBundlePretty (finalErrorBundle bundle)
where
printIncludeFile path = "in file included from " <> path <> ",\n"
--- * Modified Megaparsec source
--- * Helpers
-- The below code has been copied from Megaparsec (v.6.4.1,
-- Text.Megaparsec.Error) and modified to suit our needs. These changes are
-- indicated by square brackets. The following copyright notice, conditions,
-- and disclaimer apply to all code below this point.
--
-- Copyright © 2015–2018 Megaparsec contributors<br>
-- Copyright © 2007 Paolo Martini<br>
-- Copyright © 1999–2000 Daan Leijen
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- * Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation
-- 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
-- which the parse error occurred. The rendered 'String' always ends with
-- a newline.
customParseErrorPretty'
:: ( ShowToken (Token s)
, LineToken (Token s)
, ShowErrorComponent e
, Stream s )
=> s -- ^ Original input stream
-> ParseError (Token s) e -- ^ Parse error to render
-> Pos -- ^ Length of error interval [added]
-> String -- ^ Result of rendering
customParseErrorPretty' = customParseErrorPretty_ defaultTabWidth
customParseErrorPretty_
:: forall s e.
( ShowToken (Token s)
, LineToken (Token s)
, ShowErrorComponent e
, Stream s )
=> Pos -- ^ Tab width
-> s -- ^ Original input stream
-> ParseError (Token s) e -- ^ Parse error to render
-> Pos -- ^ Length of error interval [added]
-> String -- ^ Result of rendering
customParseErrorPretty_ w s e l =
sourcePosStackPretty (errorPos e) <> ":\n" <>
padding <> "|\n" <>
lineNumber <> " | " <> rline <> "\n" <>
padding <> "| " <> rpadding <> highlight <> "\n" <> -- [added `highlight`]
parseErrorTextPretty e
where
epos = NE.head (errorPos e) -- [changed from NE.last to NE.head]
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.
selectLine
:: forall s. (LineToken (Token s), Stream s)
=> Pos -- ^ Number of line to select
-> s -- ^ Input stream
-> Tokens s -- ^ Selected line
selectLine l = go pos1
where
go !n !s =
if n == l
then fst (takeWhile_ notNewline s)
else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))
notNewline = not . tokenIsNewline
stripNewline s =
case take1_ s of
Nothing -> s
Just (_, s') -> s'
-- | Replace tab characters with given number of spaces.
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'
-- The "tab width" and "line prefix" are taken from the defaults defined
-- in '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
--
-- hash: 5d69eead3be5d0a10a8e272a4bdf63ba320e9e6914fae3d6031538bd8bd6206d
-- hash: 54632c4329f85aa921fb91abbed9c0871465e0cfb4cdfa05a390447c6d796b83
name: hledger-lib
version: 1.10.99
@ -122,7 +122,7 @@ library
, extra
, filepath
, hashtables >=1.2.3.1
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time
@ -222,7 +222,7 @@ test-suite doctests
, extra
, filepath
, hashtables >=1.2.3.1
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time
@ -322,7 +322,7 @@ test-suite easytests
, filepath
, hashtables >=1.2.3.1
, hledger-lib
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time

2
hledger-lib/package.yaml
View File

@ -57,7 +57,7 @@ dependencies:
- easytest
- filepath
- hashtables >=1.2.3.1
- megaparsec >=6.4.1 && < 7
- megaparsec >=6.4.1
- mtl
- mtl-compat
- 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
hledgerparseerrorpositionp :: ParsecT Void String t (String, Int, Int)
hledgerparseerrorpositionp = do
anyChar `manyTill` char '"'
f <- anyChar `manyTill` (oneOf ['"','\n'])
anySingle `manyTill` char '"'
f <- anySingle `manyTill` (oneOf ['"','\n'])
string " (line "
l <- read <$> some digitChar
string ", column "

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

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: fc23afcaa9a76cad46878b6bc6d6f9f6bb3f59623438031956b1d8cdb9315c17
-- hash: 88116009cafa64bb3351a332b88f9848d895f7bc4e614a8647f9c26c6405ba35
name: hledger-ui
version: 1.10.99
@ -77,7 +77,7 @@ executable hledger-ui
, fsnotify >=0.2.1.2 && <0.4
, hledger >=1.10.99 && <1.11
, hledger-lib >=1.10.99 && <1.11
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, microlens >=0.4
, microlens-platform >=0.2.3.1
, pretty-show >=1.6.4

2
hledger-ui/package.yaml
View File

@ -54,7 +54,7 @@ dependencies:
- fsnotify >=0.2.1.2 && <0.4
- microlens >=0.4
- microlens-platform >=0.2.3.1
- megaparsec >=6.4.1 && < 7
- megaparsec >=6.4.1
- pretty-show >=1.6.4
- process >=1.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 Text.Blaze.Internal (Markup, preEscapedString)
import Text.JSON
import Text.Megaparsec (eof, parseErrorPretty, runParser)
import Text.Megaparsec (eof, errorBundlePretty, runParser)
import Yesod
import Hledger
@ -131,7 +131,7 @@ validatePostings a b =
catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : 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
validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip

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

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: f7bbdd2a2c0bf60f14a1c2d1538414933ed62708598213563167d021baba748b
-- hash: b77366b5a138b9d5a3b4c4541bfb875642f06b621bd690712d022f53ab1afbf6
name: hledger-web
version: 1.10.99
@ -169,7 +169,7 @@ library
, http-client
, http-conduit
, json
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, semigroups
, shakespeare >=2.0.2.2

2
hledger-web/package.yaml
View File

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

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

@ -296,7 +296,7 @@ amountAndCommentWizard EntryState{..} = do
amountandcommentp = do
a <- amountp
lift (skipMany spacenonewline)
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar)
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle)
-- eof
return (a,c)
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
q = T.pack $ query_ ropts
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
ep = runIdentity (runJournalParser (postingp Nothing <* eof) t')
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
--
-- hash: 70e6e178ba5d2d6601ebf07e79fdcc19d2480a0544225da23ee3155e928fd85c
-- hash: eeed47cc18e00b190b0dd220f044f4f63c60442fa26ee301c44454b5f66e09ca
name: hledger
version: 1.10.99
@ -131,7 +131,7 @@ library
, here
, hledger-lib >=1.10.99 && <1.11
, lucid
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time
@ -182,7 +182,7 @@ executable hledger
, here
, hledger
, hledger-lib >=1.10.99 && <1.11
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time
@ -236,7 +236,7 @@ test-suite test
, here
, hledger
, hledger-lib >=1.10.99 && <1.11
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time
@ -291,7 +291,7 @@ benchmark bench
, hledger
, hledger-lib >=1.10.99 && <1.11
, html
, megaparsec >=6.4.1 && <7
, megaparsec >=6.4.1
, mtl
, mtl-compat
, old-time

2
hledger/package.yaml
View File

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

8
stack-ghc7.10.yaml
View File

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

7
stack-ghc8.0.yaml
View File

@ -20,7 +20,8 @@ extra-deps:
- base-compat-0.10.1
- base-compat-batteries-0.10.1
- 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
- doctest-0.16.0
- generics-sop-0.3.2.0
@ -29,11 +30,11 @@ extra-deps:
- http-types-0.12.1
- insert-ordered-containers-0.2.1.0
- lens-4.16.1
- megaparsec-6.4.1
- megaparsec-7.0.1
- microstache-1.0.1.1
- mmorph-1.1.2
- network-2.6.3.5
- parser-combinators-0.4.0
- parser-combinators-1.0.0
- persistent-template-2.5.4
- scientific-0.3.6.2
- servant-0.13.0.1

5
stack-ghc8.2.yaml
View File

@ -15,9 +15,12 @@ extra-deps:
- aeson-1.3.1.1
- base-compat-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
- doctest-0.16.0
- megaparsec-7.0.1
- parser-combinators-1.0.0
- swagger2-2.2.2
# avoid no hashable instance for AccountName from doctests
- hashtables-1.2.3.1

4
stack.yaml
View File

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

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

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