diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 0e5334348..2838f3b3c 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -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" diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 89c1f1880..b305fa957 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 34dae98a0..419bf2435 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 4b94f9d0d..06dc034d1 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/TimeclockReader.hs b/hledger-lib/Hledger/Read/TimeclockReader.hs index 597c2648d..e997b59ec 100644 --- a/hledger-lib/Hledger/Read/TimeclockReader.hs +++ b/hledger-lib/Hledger/Read/TimeclockReader.hs @@ -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 diff --git a/hledger-lib/Hledger/Read/TimedotReader.hs b/hledger-lib/Hledger/Read/TimedotReader.hs index aca5776e6..2eafd0902 100644 --- a/hledger-lib/Hledger/Read/TimedotReader.hs +++ b/hledger-lib/Hledger/Read/TimedotReader.hs @@ -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) diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 271060386..17687b838 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -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 diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index 567a3db27..055282dfc 100644 --- a/hledger-lib/Hledger/Utils/Debug.hs +++ b/hledger-lib/Hledger/Utils/Debug.hs @@ -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 diff --git a/hledger-lib/Hledger/Utils/Parse.hs b/hledger-lib/Hledger/Utils/Parse.hs index eb723ef6d..3a7c0bbae 100644 --- a/hledger-lib/Hledger/Utils/Parse.hs +++ b/hledger-lib/Hledger/Utils/Parse.hs @@ -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 diff --git a/hledger-lib/Hledger/Utils/Test.hs b/hledger-lib/Hledger/Utils/Test.hs index c382cd311..98f939b79 100644 --- a/hledger-lib/Hledger/Utils/Test.hs +++ b/hledger-lib/Hledger/Utils/Test.hs @@ -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 diff --git a/hledger-lib/Text/Megaparsec/Custom.hs b/hledger-lib/Text/Megaparsec/Custom.hs index 6fd034cbc..53993390d 100644 --- a/hledger-lib/Text/Megaparsec/Custom.hs +++ b/hledger-lib/Text/Megaparsec/Custom.hs @@ -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
--- Copyright © 2007 Paolo Martini
--- 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 - [] -> "" - 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 = "" } diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 921d64418..279523bbb 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -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 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index aa9a36a09..27f24573b 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -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 diff --git a/hledger-ui/Hledger/UI/ErrorScreen.hs b/hledger-ui/Hledger/UI/ErrorScreen.hs index ec04ca0de..5ca55eb3f 100644 --- a/hledger-ui/Hledger/UI/ErrorScreen.hs +++ b/hledger-ui/Hledger/UI/ErrorScreen.hs @@ -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 " diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index f83db7047..fd8d94165 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -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 diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index ac79b2667..c3b125f63 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -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 diff --git a/hledger-web/Hledger/Web/Widget/AddForm.hs b/hledger-web/Hledger/Web/Widget/AddForm.hs index c66d2767e..47e85f070 100644 --- a/hledger-web/Hledger/Web/Widget/AddForm.hs +++ b/hledger-web/Hledger/Web/Widget/AddForm.hs @@ -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 diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 2c5b97f0a..6100b055a 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -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 diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index 6edd856f5..e8200ab86 100644 --- a/hledger-web/package.yaml +++ b/hledger-web/package.yaml @@ -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 diff --git a/hledger/Hledger/Cli/Commands/Add.hs b/hledger/Hledger/Cli/Commands/Add.hs index 1182f2aae..032010625 100644 --- a/hledger/Hledger/Cli/Commands/Add.hs +++ b/hledger/Hledger/Cli/Commands/Add.hs @@ -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 diff --git a/hledger/Hledger/Cli/Commands/Rewrite.hs b/hledger/Hledger/Cli/Commands/Rewrite.hs index 5234bc462..893436b2a 100755 --- a/hledger/Hledger/Cli/Commands/Rewrite.hs +++ b/hledger/Hledger/Cli/Commands/Rewrite.hs @@ -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 diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 1175d08f2..4516ca6aa 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -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 diff --git a/hledger/package.yaml b/hledger/package.yaml index b79cbab8d..d4e4b86aa 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -93,7 +93,7 @@ dependencies: - filepath - haskeline >=0.6 - here -- megaparsec >=6.4.1 && < 7 +- megaparsec >=6.4.1 - mtl - mtl-compat - old-time diff --git a/stack-ghc7.10.yaml b/stack-ghc7.10.yaml index 5f2e9c07e..2b6e51fc8 100644 --- a/stack-ghc7.10.yaml +++ b/stack-ghc7.10.yaml @@ -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 diff --git a/stack-ghc8.0.yaml b/stack-ghc8.0.yaml index df616e2e4..d566e2b24 100644 --- a/stack-ghc8.0.yaml +++ b/stack-ghc8.0.yaml @@ -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 diff --git a/stack-ghc8.2.yaml b/stack-ghc8.2.yaml index a72106c7d..a579ae2e6 100644 --- a/stack-ghc8.2.yaml +++ b/stack-ghc8.2.yaml @@ -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 diff --git a/stack.yaml b/stack.yaml index b5814d9c9..cec70e4b6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/tests/journal/parse-errors.test b/tests/journal/parse-errors.test index 32093fff8..b24347f78 100644 --- a/tests/journal/parse-errors.test +++ b/tests/journal/parse-errors.test @@ -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