{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS -Wno-name-shadowing #-}

-- |
-- Module      : Error.Diagnose.Compat.Megaparsec
-- Description : Compatibility layer for megaparsec
-- Copyright   : (c) Mesabloo, 2021-2022
-- License     : BSD3
-- Stability   : experimental
-- Portability : Portable
module Error.Diagnose.Compat.Megaparsec
  ( diagnosticFromBundle,
    errorDiagnosticFromBundle,
    warningDiagnosticFromBundle,
    module Error.Diagnose.Compat.Hints,
  )
where

import Data.Bifunctor (second)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (toList)
import Data.String (IsString (..))
import Error.Diagnose
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) =>
  -- | How to decide whether this is an error or a warning diagnostic
  (MP.ParseError s e -> Bool) ->
  -- | An optional error code
  Maybe msg ->
  -- | The error message of the diagnostic
  msg ->
  -- | Default hints when trivial errors are reported
  Maybe [Note msg] ->
  -- | The bundle to create a diagnostic from
  MP.ParseErrorBundle s e ->
  Diagnostic msg
diagnosticFromBundle :: (ParseError s e -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
diagnosticFromBundle ParseError s e -> Bool
isError Maybe msg
code msg
msg ([Note msg] -> Maybe [Note msg] -> [Note msg]
forall a. a -> Maybe a -> a
fromMaybe [] -> [Note msg]
trivialHints) MP.ParseErrorBundle {NonEmpty (ParseError s e)
PosState s
bundleErrors :: forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundlePosState :: forall s e. ParseErrorBundle s e -> PosState s
bundlePosState :: PosState s
bundleErrors :: NonEmpty (ParseError s e)
..} =
  (Diagnostic msg -> Report msg -> Diagnostic msg)
-> Diagnostic msg -> NonEmpty (Report msg) -> Diagnostic msg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Diagnostic msg -> Report msg -> Diagnostic msg
forall msg. Diagnostic msg -> Report msg -> Diagnostic msg
addReport Diagnostic msg
forall a. Default a => a
def (ParseError s e -> Report msg
toLabeledPosition (ParseError s e -> Report msg)
-> NonEmpty (ParseError s e) -> NonEmpty (Report msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ParseError s e)
bundleErrors)
  where
    toLabeledPosition :: MP.ParseError s e -> Report msg
    toLabeledPosition :: ParseError s e -> Report msg
toLabeledPosition ParseError s e
error =
      let (Maybe String
_, PosState s
pos) = Int -> PosState s -> (Maybe String, PosState s)
forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe String, PosState s)
MP.reachOffset (ParseError s e -> Int
forall s e. ParseError s e -> Int
MP.errorOffset ParseError s e
error) PosState s
bundlePosState
          source :: Position
source = SourcePos -> Position
fromSourcePos (PosState s -> SourcePos
forall s. PosState s -> SourcePos
MP.pstateSourcePos PosState s
pos)
          msgs :: [msg]
msgs = IsString msg => String -> msg
forall a. IsString a => String -> a
fromString @msg (String -> msg) -> [String] -> [msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines (ParseError s e -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
MP.parseErrorTextPretty ParseError s e
error)
       in ([(Position, Marker msg)] -> [Note msg] -> Report msg)
-> [Note msg] -> [(Position, Marker msg)] -> Report msg
forall a b c. (a -> b -> c) -> b -> a -> c
flip
            (if ParseError s e -> Bool
isError ParseError s e
error then Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
err Maybe msg
code msg
msg else Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
warn Maybe msg
code msg
msg)
            (ParseError s e -> [Note msg]
errorHints ParseError s e
error)
            if
                | [msg
m] <- [msg]
msgs -> [(Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
This msg
m)]
                | [msg
m1, msg
m2] <- [msg]
msgs -> [(Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
This msg
m1), (Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
Where msg
m2)]
                | Bool
otherwise -> [(Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ String -> msg
forall a. IsString a => String -> a
fromString String
"<<Unknown error>>")]

    fromSourcePos :: MP.SourcePos -> Position
    fromSourcePos :: SourcePos -> Position
fromSourcePos MP.SourcePos {String
Pos
sourceName :: SourcePos -> String
sourceLine :: SourcePos -> Pos
sourceColumn :: SourcePos -> Pos
sourceColumn :: Pos
sourceLine :: Pos
sourceName :: String
..} =
      let start :: (Int, Int)
start = (Pos -> Int) -> (Pos, Pos) -> (Int, Int)
forall a b. (a -> b) -> (a, a) -> (b, b)
both (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> (Pos -> Int) -> Pos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Int
MP.unPos) (Pos
sourceLine, Pos
sourceColumn)
          end :: (Int, Int)
end = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int, Int)
start
       in (Int, Int) -> (Int, Int) -> String -> Position
Position (Int, Int)
start (Int, Int)
end String
sourceName

    errorHints :: MP.ParseError s e -> [Note msg]
    errorHints :: ParseError s e -> [Note msg]
errorHints MP.TrivialError {} = [Note msg]
trivialHints
    errorHints (MP.FancyError Int
_ Set (ErrorFancy e)
errs) =
      Set (ErrorFancy e) -> [ErrorFancy e]
forall a. Set a -> [a]
Set.toList Set (ErrorFancy e)
errs [ErrorFancy e] -> (ErrorFancy e -> [Note msg]) -> [Note msg]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        MP.ErrorCustom e
e -> e -> [Note msg]
forall e msg. HasHints e msg => e -> [Note msg]
hints e
e
        ErrorFancy e
_ -> [Note msg]
forall a. Monoid a => a
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) =>
  -- | An optional error code
  Maybe msg ->
  -- | The error message of the diagnostic
  msg ->
  -- | Default hints when trivial errors are reported
  Maybe [Note msg] ->
  -- | The bundle to create a diagnostic from
  MP.ParseErrorBundle s e ->
  Diagnostic msg
errorDiagnosticFromBundle :: Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
errorDiagnosticFromBundle = (ParseError s e -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
forall msg s e.
(IsString msg, Stream s, HasHints e msg, ShowErrorComponent e,
 VisualStream s, TraversableStream s) =>
(ParseError s e -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
diagnosticFromBundle (Bool -> ParseError s e -> Bool
forall a b. a -> b -> a
const Bool
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) =>
  -- | An optional error code
  Maybe msg ->
  -- | The error message of the diagnostic
  msg ->
  -- | Default hints when trivial errors are reported
  Maybe [Note msg] ->
  -- | The bundle to create a diagnostic from
  MP.ParseErrorBundle s e ->
  Diagnostic msg
warningDiagnosticFromBundle :: Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
warningDiagnosticFromBundle = (ParseError s e -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
forall msg s e.
(IsString msg, Stream s, HasHints e msg, ShowErrorComponent e,
 VisualStream s, TraversableStream s) =>
(ParseError s e -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseErrorBundle s e
-> Diagnostic msg
diagnosticFromBundle (Bool -> ParseError s e -> Bool
forall a b. a -> b -> a
const Bool
False)

------------------------------------
------------ INTERNAL --------------
------------------------------------

-- | Applies a computation to both element of a tuple.
--
--   > both f = bimap @(,) f f
both :: (a -> b) -> (a, a) -> (b, b)
both :: (a -> b) -> (a, a) -> (b, b)
both a -> b
f ~(a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)