megaparsec: improve compatibility layer by providing more wrappers

src/Error/Diagnose/Compat/Megaparsec.hs

@@ -8,7 +8,11 @@
 
 {-# OPTIONS -Wno-name-shadowing #-}
 
-module Error.Diagnose.Compat.Megaparsec (diagnosticFromBundle) where
+module Error.Diagnose.Compat.Megaparsec
+( diagnosticFromBundle
+, errorDiagnosticFromBundle
+, warningDiagnosticFromBundle
+) where
 
 import Data.Bifunctor (second)
 import Data.Function ((&))
@@ -22,13 +26,14 @@ 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.
-diagnosticFromBundle :: forall msg s e.
-                        (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s)
-                     => Bool                      -- ^ Is this supposed to be a warning or an error?
-                     -> msg                       -- ^ The error message of the diagnostic
-                     -> Maybe [msg]               -- ^ Default hints when trivial errors are reported
-                     -> MP.ParseErrorBundle s e   -- ^ The bundle to create a diagnostic from
-                     -> Diagnostic msg
+diagnosticFromBundle
+  :: forall msg s e.
+     (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s)
+  => (MP.ParseError s e -> Bool)    -- ^ How to decide whether this is an error or a warning diagnostic
+  -> msg                            -- ^ The error message of the diagnostic
+  -> Maybe [msg]                    -- ^ Default hints when trivial errors are reported
+  -> MP.ParseErrorBundle s e        -- ^ The bundle to create a diagnostic from
+  -> Diagnostic msg
 diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBundle{..} =
   foldl addReport def (toLabeledPosition <$> bundleErrors)
   where
@@ -37,7 +42,7 @@ diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBun
       let (_, pos) = MP.reachOffset (MP.errorOffset error) bundlePosState
           source   = fromSourcePos (MP.pstateSourcePos pos)
           msgs     = fromString @msg <$> lines (MP.parseErrorTextPretty error)
-      in flip (msg & if isError then err else warn) (errorHints error)
+      in flip (msg & if isError error then err else warn) (errorHints error)
            if | [m] <- msgs      -> [ (source, This m) ]
               | [m1, m2] <- msgs -> [ (source, This m1), (source, Where m2) ]
               | otherwise        -> [ (source, This $ fromString "<<Unknown error>>") ]
@@ -54,6 +59,31 @@ diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBun
       MP.ErrorCustom e -> hints e
       _                -> mempty
 
+-- | 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)
+  => msg                              -- ^ The error message of the diagnostic
+  -> Maybe [msg]                      -- ^ Default hints when trivial errors are reported
+  -> MP.ParseErrorBundle s e          -- ^ The bundle to create a diagnostic from
+  -> Diagnostic msg
+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)
+  => msg                              -- ^ The error message of the diagnostic
+  -> Maybe [msg]                      -- ^ Default hints when trivial errors are reported
+  -> MP.ParseErrorBundle s e          -- ^ The bundle to create a diagnostic from
+  -> Diagnostic msg
+warningDiagnosticFromBundle = diagnosticFromBundle (const False)
+
+
+------------------------------------
+------------ INTERNAL --------------
+------------------------------------
+
 -- | Applies a computation to both element of a tuple.
 --
 --   > both f = bimap @(,) f f

src/Error/Diagnose/Diagnostic/Internal.hs

@@ -20,8 +20,8 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 
 #ifdef USE_AESON
 import Data.Aeson (ToJSON(..), encode, object, (.=))
-#endif
 import Data.ByteString.Lazy (ByteString)
+#endif
 import Data.Default (Default, def)
 import Data.Foldable (fold)
 import Data.HashMap.Lazy (HashMap)