mirror of
https://github.com/Mesabloo/diagnose.git
synced 2024-09-11 11:26:56 +03:00
megaparsec: improve compatibility layer by providing more wrappers
This commit is contained in:
parent
dfcaa689e9
commit
3937e63775
@ -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
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user