From c0b78562d53255fb00440a53197ba247c6b83800 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Wed, 13 Nov 2024 06:16:47 +0700
Subject: [PATCH] Add
 `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`

---
 CHANGELOG.md             |  2 +
 Text/Megaparsec/Error.hs | 86 ++++++++++++++++++++++++++++++++++++----
 2 files changed, 81 insertions(+), 7 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7b984229..6b4201d2 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -10,6 +10,8 @@
 * `many` and `some` of the `Alternative` instance of `ParsecT` are now more
   efficient, since they use the monadic implementations under the hood.
   [Issue 567](https://github.com/mrkkrp/megaparsec/issues/567).
+* Add `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`. [PR
+  573](https://github.com/mrkkrp/megaparsec/pull/573).
 
 ## Megaparsec 9.6.1
 
diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs
index 63e23089..1f7b4c8a 100644
--- a/Text/Megaparsec/Error.hs
+++ b/Text/Megaparsec/Error.hs
@@ -41,12 +41,15 @@ module Text.Megaparsec.Error
     -- * Pretty-printing
     ShowErrorComponent (..),
     errorBundlePretty,
+    errorBundlePrettyForGhcPreProcessors,
+    errorBundlePrettyWith,
     parseErrorPretty,
     parseErrorTextPretty,
     showErrorItem,
   )
 where
 
+import Control.Arrow ((>>>))
 import Control.DeepSeq
 import Control.Exception
 import Control.Monad.State.Strict
@@ -349,24 +352,25 @@ instance ShowErrorComponent Void where
   showErrorComponent = absurd
 
 -- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will
--- be pretty-printed in order together with the corresponding offending
--- lines by doing a single pass over the input stream. The rendered 'String'
--- always ends with a newline.
+-- be pretty-printed in order, by applying a provided format function, with
+-- a single pass over the input stream.
 --
--- @since 7.0.0
-errorBundlePretty ::
+-- @since 9.7.0
+errorBundlePrettyWith ::
   forall s e.
   ( VisualStream s,
     TraversableStream s,
     ShowErrorComponent e
   ) =>
+  -- | Format function for a single 'ParseError'
+  (Maybe String -> SourcePos -> ParseError s e -> String) ->
   -- | Parse error bundle to display
   ParseErrorBundle s e ->
   -- | Textual rendition of the bundle
   String
-errorBundlePretty ParseErrorBundle {..} =
+errorBundlePrettyWith format ParseErrorBundle {..} =
   let (r, _) = foldl f (id, bundlePosState) bundleErrors
-   in drop 1 (r "")
+   in r ""
   where
     f ::
       (ShowS, PosState s) ->
@@ -376,6 +380,36 @@ errorBundlePretty ParseErrorBundle {..} =
       where
         (msline, pst') = reachOffset (errorOffset e) pst
         epos = pstateSourcePos pst'
+        outChunk = format msline epos e
+
+-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will
+-- be pretty-printed in order together with the corresponding offending
+-- lines by doing a single pass over the input stream. The rendered 'String'
+-- always ends with a newline.
+--
+-- @since 7.0.0
+errorBundlePretty ::
+  forall s e.
+  ( VisualStream s,
+    TraversableStream s,
+    ShowErrorComponent e
+  ) =>
+  -- | Parse error bundle to display
+  ParseErrorBundle s e ->
+  -- | Textual rendition of the bundle
+  String
+errorBundlePretty = drop 1 . errorBundlePrettyWith format
+  where
+    format ::
+      ( VisualStream s,
+        ShowErrorComponent e
+      ) =>
+      Maybe String ->
+      SourcePos ->
+      ParseError s e ->
+      String
+    format msline epos e = outChunk
+      where
         outChunk =
           "\n"
             <> sourcePosPretty epos
@@ -418,6 +452,44 @@ errorBundlePretty ParseErrorBundle {..} =
             FancyError _ xs ->
               E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs
 
+-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will
+-- be pretty-printed in order by doing a single pass over the input stream.
+--
+-- The rendered format is suitable for custom GHC pre-processors (as can be
+-- specified with -F -pgmF).
+--
+-- @since 9.7.0
+errorBundlePrettyForGhcPreProcessors ::
+  forall s e.
+  ( VisualStream s,
+    TraversableStream s,
+    ShowErrorComponent e
+  ) =>
+  -- | Parse error bundle to display
+  ParseErrorBundle s e ->
+  -- | Textual rendition of the bundle
+  String
+errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format
+  where
+    format ::
+      ( VisualStream s,
+        ShowErrorComponent e
+      ) =>
+      Maybe String ->
+      SourcePos ->
+      ParseError s e ->
+      String
+    format _msline epos e =
+      sourcePosPretty epos
+        <> ":"
+        <> indent (parseErrorTextPretty e)
+
+    indent :: String -> String
+    indent =
+      lines >>> \case
+        [err] -> err
+        err -> intercalate "\n" $ map (" " <>) err
+
 -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a
 -- newline.
 --