simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-11-10 05:39:31 +03:00
Code Issues 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 "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"

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

@ -163,6 +163,7 @@ instance Sem.Semigroup Journal where
,jparsealiases = jparsealiases j2
-- ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2
,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2
,jincludefilestack = jincludefilestack j2
,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2
,jcommodities = jcommodities j1 <> jcommodities j2
,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2
@ -189,8 +190,9 @@ nulljournal = Journal {
,jparseparentaccounts = []
,jparsealiases = []
-- ,jparsetransactioncount = 0
,jparsetimeclockentries = []
,jdeclaredaccounts = []
,jparsetimeclockentries = []
,jincludefilestack = []
,jdeclaredaccounts = []
,jcommodities = M.fromList []
,jinferredcommodities = M.fromList []
,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 ?)
-- ,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
,jincludefilestack :: [FilePath]
-- principal data
,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

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

@ -29,10 +29,13 @@ module Hledger.Read.Common (
rtp,
runJournalParser,
rjp,
runErroringJournalParser,
rejp,
genericSourcePos,
journalSourcePos,
applyTransactionModifiers,
parseAndFinaliseJournal,
parseAndFinaliseJournal',
setYear,
getYear,
setDefaultCommodityAndStyle,
@ -99,7 +102,7 @@ where
import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile)
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 Data.Bifunctor (bimap, second)
import Data.Char
@ -191,15 +194,28 @@ 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
-- | 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 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
-- 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
parseAndFinaliseJournal parser iopts f txt = do
t <- liftIO getClockTime
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
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
Left e -> throwError $ customParseErrorPretty txt e
setYear :: Year -> JournalParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
@ -345,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) $ 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 -> 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 -> 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 -> 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
@ -409,26 +452,27 @@ datetimep' mYear = do
where
timeOfDay :: TextParser m TimeOfDay
timeOfDay = do
pos1 <- getPosition
off1 <- getOffset
h' <- twoDigitDecimal <?> "hour"
pos2 <- getPosition
unless (h' >= 0 && h' <= 23) $ parseErrorAtRegion pos1 pos2
"invalid time (bad hour)"
off2 <- getOffset
unless (h' >= 0 && h' <= 23) $ customFailure $
parseErrorAtRegion off1 off2 "invalid time (bad hour)"
char ':' <?> "':' (hour-minute separator)"
pos3 <- getPosition
off3 <- getOffset
m' <- twoDigitDecimal <?> "minute"
pos4 <- getPosition
unless (m' >= 0 && m' <= 59) $ parseErrorAtRegion pos3 pos4
"invalid time (bad minute)"
off4 <- getOffset
unless (m' >= 0 && m' <= 59) $ customFailure $
parseErrorAtRegion off3 off4 "invalid time (bad minute)"
s' <- option 0 $ do
char ':' <?> "':' (minute-second separator)"
pos5 <- getPosition
off5 <- getOffset
s' <- twoDigitDecimal <?> "second"
pos6 <- getPosition
unless (s' >= 0 && s' <= 59) $ parseErrorAtRegion pos5 pos6
"invalid time (bad second)" -- we do not support leap seconds
off6 <- getOffset
unless (s' >= 0 && s' <= 59) $ customFailure $
parseErrorAtRegion off5 off6 "invalid time (bad second)"
-- we do not support leap seconds
pure s'
pure $ TimeOfDay h' m' (fromIntegral s')
@ -524,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
@ -563,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
@ -571,7 +615,8 @@ amountwithoutpricep = do
interpretNumber posRegion suggestedStyle ambiguousNum mExp =
let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum
in case fromRawNumber rawNum mExp of
Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg
Left errMsg -> customFailure $
uncurry parseErrorAtRegion posRegion errMsg
Right res -> pure res
-- | Parse an amount from a string, or get an error.
@ -629,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)
@ -788,9 +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 -> parseErrorAt pos "invalid number (excessive trailing digits)"
Just off -> customFailure $
parseErrorAt off "invalid number (excessive trailing digits)"
Nothing -> pure ()
return $ dbg8 "rawnumberp" rawNumber
@ -1150,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

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",
-- which should be finalised/validated before use.
--
-- >>> rjp (journalp <* eof) "2015/1/1\n a 0\n"
-- Right Journal with 1 transactions, 1 accounts
-- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n"
-- Right (Right Journal with 1 transactions, 1 accounts)
--
journalp :: MonadIO m => JournalParser m ParsedJournal
journalp :: MonadIO m => ErroringJournalParser m ParsedJournal
journalp = do
many addJournalItemP
eof
@ -135,7 +135,7 @@ journalp = do
-- | A side-effecting parser; parses any kind of journal item
-- and updates the parse state accordingly.
addJournalItemP :: MonadIO m => JournalParser m ()
addJournalItemP :: MonadIO m => ErroringJournalParser m ()
addJournalItemP =
-- all journal line types can be distinguished by the first
-- character, can use choice without backtracking
@ -154,7 +154,7 @@ addJournalItemP =
-- | Parse any journal directive and update the parse state accordingly.
-- Cf http://hledger.org/manual.html#directives,
-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directivep :: MonadIO m => JournalParser m ()
directivep :: MonadIO m => ErroringJournalParser m ()
directivep = (do
optional $ char '!'
choice [
@ -174,78 +174,74 @@ directivep = (do
]
) <?> "directive"
includedirectivep :: MonadIO m => JournalParser m ()
includedirectivep :: MonadIO m => ErroringJournalParser m ()
includedirectivep = do
string "include"
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 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 -> 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
-- lexicographic order to simulate the output of 'ls'.
filepaths <- liftIO $ sort <$> globDir1 fileglob curdir
if (not . null) 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
parentfilestack <- fmap sourceName . statePos <$> getParserState
when (filepath `elem` parentfilestack)
$ parseErrorAt parentpos ("Cyclic include: " ++ filepath)
parentj <- get
childInput <- lift $ readFilePortably filepath
`orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
let parentfilestack = jincludefilestack parentj
when (filepath `elem` parentfilestack) $
fail ("Cyclic include: " ++ filepath)
-- save parent state
parentParserState <- getParserState
parentj <- get
childInput <- lift $ readFilePortably filepath
`orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
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
setInput childInput
pushPosition $ initialPos filepath
put childj
-- discard child's parse info, combine other fields
put $ updatedChildj <> parentj
-- parse include file
let parsers = [ journalp
, timeclockfilep
, timedotfilep
] -- can't include a csv file yet, that reader is special
updatedChildj <- journalAddFile (filepath, childInput) <$>
region (withSource childInput) (choiceInState parsers)
-- restore parent state, prepending the child's parse info
setParserState parentParserState
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
}
newJournalWithParseStateFrom :: FilePath -> Journal -> Journal
newJournalWithParseStateFrom filepath j = mempty{
jparsedefaultyear = jparsedefaultyear j
,jparsedefaultcommodity = jparsedefaultcommodity j
,jparseparentaccounts = jparseparentaccounts j
,jparsealiases = jparsealiases j
,jcommodities = jcommodities j
-- ,jparsetransactioncount = jparsetransactioncount j
,jparsetimeclockentries = jparsetimeclockentries j
,jincludefilestack = filepath : jincludefilestack j
}
-- | Lift an IO action into the exception monad, rethrowing any IO
-- error with the given message prepended.
@ -284,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 parseErrorAt pos pleaseincludedecimalpoint
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
pleaseincludedecimalpoint :: String
@ -321,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 parseErrorAt pos pleaseincludedecimalpoint
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
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
keywordp :: String -> JournalParser m ()
@ -371,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
@ -383,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 ()
@ -418,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 parseErrorAt pos pleaseincludedecimalpoint
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: JournalParser m MarketPrice
@ -484,17 +480,20 @@ periodictransactionp = do
char '~' <?> "periodic transaction"
lift $ skipMany spacenonewline
-- a period expression
off <- getOffset
pos <- getPosition
-- if there's a default year in effect, use Y/1/1 as base for partial/relative dates
today <- liftIO getCurrentDay
mdefaultyear <- getYear
let refdate = case mdefaultyear of
Nothing -> today
Just y -> fromGregorian y 1 1
(periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp refdate)
-- In periodic transactions, the period expression has an additional constraint:
case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> 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.
@ -529,7 +528,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"
@ -539,7 +538,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 ""
@ -607,8 +606,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
@ -795,8 +795,8 @@ tests_JournalReader = tests "JournalReader" [
,tests "directivep" [
test "supports !" $ do
expectParse directivep "!account a\n"
expectParse directivep "!D 1.0\n"
expectParseE directivep "!account a\n"
expectParseE directivep "!D 1.0\n"
]
,test "accountdirectivep" $ do
@ -819,8 +819,8 @@ tests_JournalReader = tests "JournalReader" [
expectParse ignoredpricecommoditydirectivep "N $\n"
,test "includedirectivep" $ do
test "include" $ expectParseError includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"
test "glob" $ 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" $ expectParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*"
,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep
"P 2017/01/30 BTC $922.83\n"
@ -839,7 +839,7 @@ tests_JournalReader = tests "JournalReader" [
,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 qualified Data.Text as T
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Hledger.Data
-- XXX too much reuse ?
@ -78,7 +77,7 @@ reader = Reader
-- format, saving the provided file path and the current time, or give an
-- error.
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse = parseAndFinaliseJournal timeclockfilep
parse = parseAndFinaliseJournal' timeclockfilep
timeclockfilep :: MonadIO m => JournalParser m ParsedJournal
timeclockfilep = do many timeclockitemp
@ -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

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 :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse = parseAndFinaliseJournal timedotfilep
parse = parseAndFinaliseJournal' timedotfilep
timedotfilep :: JournalParser m ParsedJournal
timedotfilep = do many timedotfileitemp
@ -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

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

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Hledger.Utils.Parse (
@ -5,6 +6,7 @@ module Hledger.Utils.Parse (
SimpleTextParser,
TextParser,
JournalParser,
ErroringJournalParser,
choice',
choiceInState,
@ -27,6 +29,7 @@ module Hledger.Utils.Parse (
)
where
import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Char
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.
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.
-- Consumes no input if all choices fail.
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 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'
@ -81,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
@ -106,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

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

@ -16,13 +16,18 @@ module Hledger.Utils.Test (
,is
,expectEqPP
,expectParse
,expectParseE
,expectParseError
,expectParseErrorE
,expectParseEq
,expectParseEqE
,expectParseEqOn
,expectParseEqOnE
)
where
import Control.Exception
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.State.Strict (StateT, evalStateT)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
@ -101,12 +106,34 @@ is = flip expectEqPP
-- | Test that this stateful parser runnable in IO successfully parses
-- all of the given input text, showing the parse error if it fails.
-- Suitable for hledger's JournalParser parsers.
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
:: (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
-- the given input text, with a parse error containing the given string.
@ -117,22 +144,75 @@ 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"
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,
-- pretty-printing both if it fails.
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
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
-- before comparing it.
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)
=> 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 LambdaCase #-}
{-# LANGUAGE PackageImports #-}
@ -9,25 +8,44 @@ module Text.Megaparsec.Custom (
-- * Custom parse error type
CustomErr,
-- * Throwing custom parse errors
-- * Constructing custom parse errors
parseErrorAt,
parseErrorAtRegion,
withSource,
-- * 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
import Prelude ()
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 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
@ -39,13 +57,9 @@ 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
-- | 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)
-- 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'.
-- 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
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 pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg)
{-# INLINABLE parseErrorAt #-}
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
:: MonadParsec CustomErr s m
=> SourcePos -- ^ Start position
-> SourcePos -- ^ End position
-> String -- ^ Error message
-> m a
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 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
:: Int -- ^ Start offset
-> Int -- ^ End end offset
-> String -- ^ Error message
-> CustomErr
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 (ErrorWithSource customSource customErr) ->
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
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
@ -132,117 +138,183 @@ customParseErrorPretty source err = case findCustomError err of
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,
-- 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.
data FinalParseError' e
-- a parse error thrown as a "final" parse error
= FinalError (ParseError Text e)
-- 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>
-- Copyright © 2007 Paolo Martini<br>
-- Copyright © 1999–2000 Daan Leijen
-- This monoid instance simply takes the first (left-most) error.
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.
--
-- 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.
-- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with
-- its full source text and filepath, so we just add a stack of include
-- files.
data FinalParseErrorBundle' e = FinalParseErrorBundle'
{ finalErrorBundle :: ParseErrorBundle Text e
, includeFileStack :: [FilePath]
} deriving (Show)
type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr
-- | Pretty-print a 'ParseError Char CustomErr' and display the line on
-- which the parse error occurred. The rendered 'String' always ends with
-- a newline.
--- * Constructing and throwing final parse errors
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
-- | Convert a "regular" parse error into a "final" parse error.
finalError :: ParseError Text e -> FinalParseError' e
finalError = FinalError
-- | Like megaparsec's 'fancyFailure', but as a "final" parse error.
finalFancyFailure
:: (MonadParsec e s m, MonadError (FinalParseError' e) m)
=> 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_
:: 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
--- * Pretty-printing "final" parse errors
-- | Pretty-print a "final" parse error: print the stack of include files,
-- then apply the pretty-printer for parse error bundles. Note that
-- 'attachSource' must be used on a "final" parse error before it can be
-- pretty-printed.
finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String
finalErrorBundlePretty bundle =
concatMap showIncludeFilepath (includeFileStack bundle)
<> customErrorBundlePretty (finalErrorBundle bundle)
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
showIncludeFilepath path = "in file included from " <> path <> ",\n"
-- | 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
:: forall s. (LineToken (Token s), Stream s)
=> Pos -- ^ Number of line to select
-> s -- ^ Input stream
-> Tokens s -- ^ Selected line
selectLine l = go pos1
attachSource
:: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource filePath sourceText finalParseError = case finalParseError of
-- A parse error thrown directly with the 'FinalError' constructor
-- 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
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'
parser' = do
eResult <- lift $ lift $
runParserT (evalStateT parser initialState) filepath text
case eResult of
Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle
Right result -> pure result
-- | 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
--
-- hash: 02f1a6c7e0679654979a211571c7d927ae759fb5831bfd8b180bab19a9bea977
-- hash: 22a6817292c6f2d53f935ce939331bea06b956c94b4e391d198760704ec294b3
name: hledger-lib
version: 1.11.99
@ -122,7 +122,7 @@ library
, extra
, filepath
, hashtables >=1.2.3.1
, megaparsec >=6.4.1 && <7
, megaparsec >=7.0.0 && <8
, 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 >=7.0.0 && <8
, 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 >=7.0.0 && <8
, 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 >=7.0.0 && <8
- 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: 4d019af731dfbe758d41b4a95151b8ba358a733fe52ae6333854b7430aec13ff
-- hash: fb0ef2467dcf115f1fc7a6f9d7781ec6912e7545a52921968067666c1747fff4
name: hledger-ui
version: 1.11.99
@ -77,7 +77,7 @@ executable hledger-ui
, fsnotify >=0.2.1.2 && <0.4
, hledger >=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-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 >=7.0.0 && <8
- 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

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

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 3a93b8df7229c5b65b88f7003205c93bcc295013203a85e0ed937303c18d8c84
-- hash: 443e668fdd64fb57d1d9488224df0bc6ee4e796bcc75f81655a92850ff809d34
name: hledger-web
version: 1.11.99
@ -127,8 +127,6 @@ flag threaded
default: True
library
hs-source-dirs:
./.
exposed-modules:
Hledger.Web
Hledger.Web.Application
@ -148,6 +146,8 @@ library
Hledger.Web.Widget.Common
other-modules:
Paths_hledger_web
hs-source-dirs:
./.
ghc-options: -Wall -fwarn-tabs
cpp-options: -DVERSION="1.11.99"
build-depends:
@ -169,7 +169,7 @@ library
, http-client
, http-conduit
, json
, megaparsec >=6.4.1 && <7
, megaparsec >=7.0.0 && <8
, 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 >=7.0.0 && <8
- 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: fc4b42dee35f79a4fed845e87b2e5c08b3c68466fe1cf59d952e6be4f15df413
-- hash: 78515e93d6f08be6d098bdd697b951a1577e4e71c6b24ad64cf69916d3af191c
name: hledger
version: 1.11.99
@ -131,7 +131,7 @@ library
, here
, hledger-lib >=1.11.99 && <1.12
, lucid
, megaparsec >=6.4.1 && <7
, megaparsec >=7.0.0 && <8
, mtl
, mtl-compat
, old-time
@ -182,7 +182,7 @@ executable hledger
, here
, hledger
, hledger-lib >=1.11.99 && <1.12
, megaparsec >=6.4.1 && <7
, megaparsec >=7.0.0 && <8
, mtl
, mtl-compat
, old-time
@ -236,7 +236,7 @@ test-suite test
, here
, hledger
, hledger-lib >=1.11.99 && <1.12
, megaparsec >=6.4.1 && <7
, megaparsec >=7.0.0 && <8
, mtl
, mtl-compat
, old-time
@ -291,7 +291,7 @@ benchmark bench
, hledger
, hledger-lib >=1.11.99 && <1.12
, html
, megaparsec >=6.4.1 && <7
, megaparsec >=7.0.0 && <8
, 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 >=7.0.0 && <8
- 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