lib: switch to megaparsec 7

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"

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 :: Int -> Integer -> Char -> Int -> TextParser m Day
-  fullDate startPos year sep1 month = do
+  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
+    :: Int -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day
-  partialDate startPos mYear month sep day = do
+  partialDate startOffset mYear month sep day = do
-    endPos <- getPosition
+    endOffset <- getOffset
     case mYear of
       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
+    offAfterNum <- getOffset
-    let numRegion = (posBeforeNum, posAfterNum)
+    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
+    offAfterNum <- getOffset
-    let numRegion = (posBeforeNum, posAfterNum)
+    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 $
+    Just off -> customFailure $
-                  parseErrorAt pos "invalid number (excessive trailing digits)"
+                  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]"
+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"
--- Left ...1:11:...well-formed but invalid date: 2016/1/32...
+-- Left ...1:2:...well-formed but invalid date: 2016/1/32...
 --
--- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"
+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"
--- Left ...1:6:...partial date 1/31 found, but the current year is unknown...
+-- Left ...1:2:...partial date 1/31 found, but the current year is unknown...
 --
--- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
 -- Left ...1:13:...expecting month or day...
 --
 bracketeddatetagsp

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 :: String -> ParseError T.Text String
-    makeParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s)
+    makeParseError s = FancyError 0 (S.singleton $ ErrorFail s)
 
 -- | Parse this text as CSV conversion rules. The file path is for error messages.
-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

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
-    getFilePaths parserpos filename = do
+      :: 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"
+      let s = "1/1"
-      either (fail.("parse error at "++).parseErrorPretty) (const ok) ep
+      ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s
+      either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep
     test "no leading zero" $ expectParse datep "2018/1/1"
 
   ,test "datetimep" $ do

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

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)

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

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

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

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,9 +128,10 @@ 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)
+    Right ep ->
+      either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty)
              (const ok)
              ep
 
@@ -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
 

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
+  = ErrorFailAt Int -- Starting offset
-                Pos -- Ending position (column; same line as start)
+                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 :: Int -> String -> CustomErr
-parseErrorAt pos msg = ErrorFailAt pos (sourceColumn pos) msg
+parseErrorAt offset msg = ErrorFailAt offset (offset+1) msg
 
--- | Fail at a specific source interval (within a single line). The
+-- | Fail at a specific source interval, given by the raw offsets of its
--- interval is inclusive on the left and exclusive on the right; that is,
+-- endpoints from the start of the input stream (the numbers of tokens
--- it spans from the start position to just before (and not including) the
+-- processed at those points).
--- end position.
+--
+-- Note that care must be taken to ensure that the specified interval does
+-- not span multiple lines of the input source, as this will not be
+-- checked.
 
 parseErrorAtRegion
-  :: SourcePos -- ^ Start position
+  :: Int    -- ^ Start offset
-  -> SourcePos -- ^ End position
+  -> Int    -- ^ End end offset
   -> String -- ^ Error message
   -> CustomErr
-parseErrorAtRegion startPos endPos msg =
+parseErrorAtRegion startOffset endOffset msg =
-  let startCol = sourceColumn startPos
+  if startOffset < endOffset
-      endCol' = mkPos $ subtract 1 $ unPos $ sourceColumn endPos
+    then ErrorFailAt startOffset endOffset msg
-      endCol = if startCol <= endCol'
+    else ErrorFailAt startOffset (startOffset+1) msg
-                    && sourceLine startPos == sourceLine endPos
-               then endCol' else startCol
-  in  ErrorFailAt startPos endCol 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
+-- Use this instead of 'errorBundlePretty' when custom parse errors are
--- only one custom error should be used at a time).
+-- thrown, otherwise the continuous highlighting in the pretty-printed
+-- parse error will be displaced from its proper position.
 
-customParseErrorPretty :: Text -> ParseError Char CustomErr -> String
+customErrorBundlePretty :: ParseErrorBundle Text CustomErr -> String
-customParseErrorPretty source err = case findCustomError err of
+customErrorBundlePretty errBundle =
-  Nothing -> customParseErrorPretty' source err pos1
+  let errBundle' = errBundle
-
+        { bundleErrors = fmap setCustomErrorOffset $ bundleErrors errBundle }
-  Just (ErrorFailAt sourcePos col errMsg) ->
+  in  errorBundlePretty errBundle'
-    let newPositionStack = sourcePos NE.:| NE.tail (errorPos err)
-        errorIntervalLength = mkPos $ max 1 $
-          unPos col - unPos (sourceColumn sourcePos) + 1
-
-        newErr :: ParseError Char Void
-        newErr = FancyError newPositionStack (S.singleton (ErrorFail errMsg))
-
-    in  customParseErrorPretty' source newErr errorIntervalLength
 
   where
-    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
+-- In order to pretty-print our custom parse errors, we must bundle them
--- source text and its filepaths (the 'ErrorBundle' constructor). However,
+-- with their full source text and filepaths (the 'FinalBundleWithStack'
--- when an error is thrown from within a parser, we do not have access to
+-- constructor). However, when an error is thrown from within a parser, we
--- the (full) source, so we must hold the parse error until it can be
+-- do not have access to the full source, so we must hold the parse error
--- joined with the source text and its filepath by the parser's caller
+-- (the 'FinalError' constructor) until it can be joined with the source
--- (the 'ErrorFinal' constructor).
+-- text and its filepath by the parser's caller.
 
 data FinalParseError' e
-  = ErrorFinal  (ParseError Char e)
+  = FinalError           (ParseError Text e)
-  | ErrorBundle (FinalParseErrorBundle' 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,21 +170,15 @@ instance Semigroup (FinalParseError' e) where
   e <> _ = e
 
 instance Monoid (FinalParseError' e) where
-  mempty = ErrorFinal $
+  mempty = FinalError $ FancyError 0 $
-    FancyError (initialPos "" NE.:| [])
+            S.singleton (ErrorFail "default parse error")
-               (S.singleton (ErrorFail "default parse error"))
   mappend = (<>)
 
--- | A type bundling a 'ParseError' with its source file and a stack of
+-- | A type bundling a 'ParseError' with its full source file and a stack
--- include file paths (for pretty printing). Although Megaparsec 6
+-- of include file paths (for pretty printing).
--- 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.
 
 data FinalParseErrorBundle' e = FinalParseErrorBundle'
-  { finalParseError :: ParseError Char e
+  { finalErrorBundle :: ParseErrorBundle Text e
-  , errorSource     :: Text
   , sourceFileStack  :: NE.NonEmpty FilePath
   } deriving (Show)
 
@@ -189,8 +189,8 @@ type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr
 
 -- | Convert a "regular" parse error into a "final" parse error.
 
-errorFinal :: ParseError Char e -> FinalParseError' e
+finalError :: ParseError Text e -> FinalParseError' e
-errorFinal = ErrorFinal
+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
+  offset <- getOffset
-  let parseErr = FancyError (pos NE.:| []) errSet
+  throwError $ FinalError $ FancyError offset errSet
-  throwError $ ErrorFinal parseErr
 
 -- | 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 =
+attachSource filePath sourceText finalParseError = case finalParseError of
-  case finalParseError of
+
-    ErrorFinal parseError -> FinalParseErrorBundle'
+    FinalError parseError ->
-      { finalParseError = parseError
+      let bundle = ParseErrorBundle
-      , errorSource     = sourceText
+            { bundleErrors = parseError NE.:| []
-      , sourceFileStack = filePath NE.:| []
+            , bundlePosState = initialPosState filePath sourceText }
-      }
+      in  FinalParseErrorBundle'
-    ErrorBundle bundle -> bundle
+            { finalErrorBundle = bundle
-      { sourceFileStack = filePath NE.<| sourceFileStack 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
+finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String
-finalParseErrorPretty bundle =
+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,
+-- The "tab width" and "line prefix" are taken from the defaults defined
--- Text.Megaparsec.Error) and modified to suit our needs. These changes are
+-- in 'initialState'.
--- indicated by square brackets. The following copyright notice, conditions,
--- and disclaimer apply to all code below this point.
---
--- Copyright © 2015–2018 Megaparsec contributors<br>
--- Copyright © 2007 Paolo Martini<br>
--- Copyright © 1999–2000 Daan Leijen
---
--- All rights reserved.
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright notice,
---   this list of conditions and the following disclaimer in the documentation
---   and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS
--- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
--- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
--- NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
--- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
--- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
--- OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
--- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
--- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
--- EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-
--- | Pretty-print a 'ParseError Char CustomErr' and display the line on
--- which the parse error occurred. The rendered 'String' always ends with
--- a newline.
-
-customParseErrorPretty'
-  :: ( ShowToken (Token s)
-     , LineToken (Token s)
-     , ShowErrorComponent e
-     , Stream s )
-  => s                 -- ^ Original input stream
-  -> ParseError (Token s) e -- ^ Parse error to render
-  -> Pos               -- ^ Length of error interval [added]
-  -> String            -- ^ Result of rendering
-customParseErrorPretty' = customParseErrorPretty_ defaultTabWidth
-
-
-customParseErrorPretty_
-  :: forall s e.
-     ( ShowToken (Token s)
-     , LineToken (Token s)
-     , ShowErrorComponent e
-     , Stream s )
-  => Pos               -- ^ Tab width
-  -> s                 -- ^ Original input stream
-  -> ParseError (Token s) e -- ^ Parse error to render
-  -> Pos               -- ^ Length of error interval [added]
-  -> String            -- ^ Result of rendering
-customParseErrorPretty_ w s e l =
-  sourcePosStackPretty (errorPos e) <> ":\n" <>
-    padding <> "|\n" <>
-    lineNumber <> " | " <> rline <> "\n" <>
-    padding <> "| " <> rpadding <> highlight <> "\n" <> -- [added `highlight`]
-    parseErrorTextPretty e
-  where
-    epos       = NE.head (errorPos e) -- [changed from NE.last to NE.head]
-    lineNumber = (show . unPos . sourceLine) epos
-    padding    = replicate (length lineNumber + 1) ' '
-    rpadding   = replicate (unPos (sourceColumn epos) - 1) ' '
-    highlight  = replicate (unPos l) '^' -- [added]
-    rline      =
-      case rline' of
-        [] -> "<empty line>"
-        xs -> expandTab w xs
-    rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $
-      selectLine (sourceLine epos) s
-
--- | Select a line from input stream given its number.
-
-selectLine
-  :: forall s. (LineToken (Token s), Stream s)
-  => Pos               -- ^ Number of line to select
-  -> s                 -- ^ Input stream
-  -> Tokens s          -- ^ Selected line
-selectLine l = go pos1
-  where
-    go !n !s =
-      if n == l
-        then fst (takeWhile_ notNewline s)
-        else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))
-    notNewline = not . tokenIsNewline
-    stripNewline s =
-      case take1_ s of
-        Nothing -> s
-        Just (_, s') -> s'
-
--- | Replace tab characters with given number of spaces.
-
-expandTab
-  :: Pos
-  -> String
-  -> String
-expandTab w' = go 0
-  where
-    go 0 []        = []
-    go 0 ('\t':xs) = go w xs
-    go 0 (x:xs)    = x : go 0 xs
-    go !n xs       = ' ' : go (n - 1) xs
-    w              = unPos w'
 
+initialPosState :: FilePath -> Text -> PosState Text
+initialPosState filePath sourceText = PosState
+  { pstateInput      = sourceText
+  , pstateOffset     = 0
+  , pstateSourcePos  = initialPos filePath
+  , pstateTabWidth   = defaultTabWidth
+  , pstateLinePrefix = "" }

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

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

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 '"'
+  anySingle `manyTill` char '"'
-  f <- anyChar `manyTill` (oneOf ['"','\n'])
+  f <- anySingle `manyTill` (oneOf ['"','\n'])
   string " (line "
   l <- read <$> some digitChar
   string ", column "

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

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

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
 

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

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

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

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

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

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

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
+- cassava-megaparsec-2.0.0
-- config-ini-0.2.2.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

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

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

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

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