Allow user-specific conversion of Megaparsec custom error component

src/Error/Diagnose.hs

@@ -220,6 +220,8 @@ import Error.Diagnose.Style as Export
 --   One simply needs to convert the 'Text.Megaparsec.ParseErrorBundle' which is returned by running a parser into a 'Diagnostic' by using 'Error.Diagnose.Compat.Megaparsec.diagnosticFromBundle'.
 --   Several wrappers are included for easy creation of kinds (error, warning) of diagnostics.
 --
+--  A specific instance of 'HasHint' may be provided to convert the user-specific Parser error (the @e@ in megaparsec's @Parse e s@) into a Diagnose 'Report'.
+--
 --   __Note:__ the returned diagnostic does not include file contents, which needs to be added manually afterwards.
 --
 --   As a quick example:

src/Error/Diagnose/Compat/Hints.hs

@@ -2,15 +2,24 @@
 
 module Error.Diagnose.Compat.Hints where
 
-import Error.Diagnose (Note)
+import Error.Diagnose (Note, Position, Report)
 
 -- | A class mapping custom errors of type @e@ with messages of type @msg@.
 class HasHints e msg where
   -- | Defines all the hints associated with a given custom error.
   hints :: e -> [Note msg]
+  -- | Allows a custom conversion of a user-specific megaparsec error (the @e@ in
+  -- megaparsec's @Parser e s@) into a Diagnose 'Report'.  A default Report is
+  -- provided in the event that there is no useful customization.
+  mkReports :: [Report msg] -> Position -> e -> [Report msg]
+
+  hints = const mempty
+  mkReports defRep _pos _e = defRep
+
 
 -- this is a sane default for 'Void'
 -- but this can be redefined
 --
 -- instance HasHints Void msg where
 --   hints _ = mempty
+--   mkReport defRep _ _ = defRep

src/Error/Diagnose/Compat/Megaparsec.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -32,9 +35,15 @@ import Error.Diagnose.Compat.Hints (HasHints (..))
 import qualified Text.Megaparsec as MP
 
 -- | Transforms a megaparsec 'MP.ParseErrorBundle' into a well-formated 'Diagnostic' ready to be shown.
+--
+-- This may be accompanied by providing a specific instance of 'HasHints' for the
+-- specific user error type used with megaparsec (i.e. the @e@ in @Parser e s@).
+-- If no specific instance is provided, a default error report with no hints is
+-- generated.
 diagnosticFromBundle ::
   forall msg s e.
-  (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
+  (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s
+  , AddBundleError e msg ) =>
   -- | How to decide whether this is an error or a warning diagnostic
   (MP.ParseError s e -> Bool) ->
   -- | An optional error code
@@ -47,20 +56,27 @@ diagnosticFromBundle ::
   MP.ParseErrorBundle s e ->
   Diagnostic msg
 diagnosticFromBundle isError code msg (fromMaybe [] -> trivialHints) MP.ParseErrorBundle {..} =
-  foldl addReport mempty (toLabeledPosition <$> bundleErrors)
+  foldl (addBundleError toLabeledPosition) mempty bundleErrors
   where
-    toLabeledPosition :: MP.ParseError s e -> Report msg
+    toLabeledPosition :: MP.ParseError s e -> [Report msg]
     toLabeledPosition error =
       let (_, pos) = MP.reachOffset (MP.errorOffset error) bundlePosState
           source = fromSourcePos (MP.pstateSourcePos pos)
           msgs = fromString @msg <$> lines (MP.parseErrorTextPretty error)
-       in flip
+          errRep = flip
             (if isError error then Err code msg else Warn code msg)
             (errorHints error)
             if
                 | [m] <- msgs -> [(source, This m)]
                 | [m1, m2] <- msgs -> [(source, This m1), (source, Where m2)]
                 | otherwise -> [(source, This $ fromString "<<Unknown error>>")]
+      in case error of
+        MP.TrivialError {} -> [errRep]
+        MP.FancyError _ errs ->
+          let mkRep = \case
+                MP.ErrorCustom ce -> mkReports [errRep] source ce
+                _ -> [errRep]
+          in concat $ mkRep <$> Set.toList errs
 
     fromSourcePos :: MP.SourcePos -> Position
     fromSourcePos MP.SourcePos {..} =
@@ -75,10 +91,31 @@ diagnosticFromBundle isError code msg (fromMaybe [] -> trivialHints) MP.ParseErr
         MP.ErrorCustom e -> hints e
         _ -> mempty
 
+class AddBundleError e msg where
+  addBundleError :: (MP.ParseError s e -> [Report msg])
+                 -> Diagnostic msg
+                 -> MP.ParseError s e
+                 -> Diagnostic msg
+
+instance {-# OVERLAPPING #-} AddBundleError (Diagnostic msg) msg where
+  addBundleError defaultFun diag err =
+    case err of
+      MP.FancyError _ errs ->
+        let eachErr = \case
+              MP.ErrorCustom d -> (d <>)
+              _ -> flip (foldl addReport) (defaultFun err)
+        in foldr eachErr diag (Set.toList errs)
+      _ -> foldl addReport diag (defaultFun err)
+
+instance {-# OVERLAPPABLE #-} AddBundleError e msg where
+  addBundleError defaultFun diag = foldl addReport diag . defaultFun
+
+
 -- | Creates an error diagnostic from a megaparsec 'MP.ParseErrorBundle'.
 errorDiagnosticFromBundle ::
   forall msg s e.
-  (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
+  (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s
+  , AddBundleError e msg ) =>
   -- | An optional error code
   Maybe msg ->
   -- | The error message of the diagnostic
@@ -93,7 +130,8 @@ errorDiagnosticFromBundle = diagnosticFromBundle (const True)
 -- | Creates a warning diagnostic from a megaparsec 'MP.ParseErrorBundle'.
 warningDiagnosticFromBundle ::
   forall msg s e.
-  (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
+  (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s
+  , AddBundleError e msg ) =>
   -- | An optional error code
   Maybe msg ->
   -- | The error message of the diagnostic