{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

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

-- |
-- Module      : Error.Diagnose.Compat.Parsec
-- Description : Compatibility layer for parsec
-- Copyright   : (c) Mesabloo, 2021
-- License     : BSD3
-- Stability   : experimental
-- Portability : Portable
module Error.Diagnose.Compat.Parsec
  ( diagnosticFromParseError,
    errorDiagnosticFromParseError,
    warningDiagnosticFromParseError,
    module Error.Diagnose.Compat.Hints,
  )
where

import Data.Bifunctor (second)
import Data.List (intercalate, nub)
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.Void (Void)
import Error.Diagnose
import Error.Diagnose.Compat.Hints (HasHints (..))
import qualified Text.Parsec.Error as PE
import qualified Text.Parsec.Pos as PP

-- | Generates a diagnostic from a 'PE.ParseError'.
diagnosticFromParseError ::
  forall msg.
  (IsString msg, HasHints Void msg) =>
  -- | Determine whether the diagnostic is an error or a warning
  (PE.ParseError -> Bool) ->
  -- | An optional error code
  Maybe msg ->
  -- | The main error of the diagnostic
  msg ->
  -- | Default hints
  Maybe [msg] ->
  -- | The 'PE.ParseError' to transform into a 'Diagnostic'
  PE.ParseError ->
  Diagnostic msg
diagnosticFromParseError :: (ParseError -> Bool)
-> Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError ParseError -> Bool
isError Maybe msg
code msg
msg ([msg] -> Maybe [msg] -> [msg]
forall a. a -> Maybe a -> a
fromMaybe [] -> [msg]
defaultHints) ParseError
error =
  let pos :: Position
pos = SourcePos -> Position
fromSourcePos (SourcePos -> Position) -> SourcePos -> Position
forall a b. (a -> b) -> a -> b
$ ParseError -> SourcePos
PE.errorPos ParseError
error
      markers :: [(Position, Marker msg)]
markers = Position -> [Message] -> [(Position, Marker msg)]
toMarkers Position
pos ([Message] -> [(Position, Marker msg)])
-> [Message] -> [(Position, Marker msg)]
forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
PE.errorMessages ParseError
error
      report :: Report msg
report = (if ParseError -> Bool
isError ParseError
error then Maybe msg -> msg -> [(Position, Marker msg)] -> [msg] -> Report msg
forall msg.
Maybe msg -> msg -> [(Position, Marker msg)] -> [msg] -> Report msg
err Maybe msg
code msg
msg else Maybe msg -> msg -> [(Position, Marker msg)] -> [msg] -> Report msg
forall msg.
Maybe msg -> msg -> [(Position, Marker msg)] -> [msg] -> Report msg
warn Maybe msg
code msg
msg) [(Position, Marker msg)]
markers ([msg]
defaultHints [msg] -> [msg] -> [msg]
forall a. Semigroup a => a -> a -> a
<> Void -> [msg]
forall e msg. HasHints e msg => e -> [msg]
hints (Void
forall a. HasCallStack => a
undefined :: Void))
   in Diagnostic msg -> Report msg -> Diagnostic msg
forall msg. Diagnostic msg -> Report msg -> Diagnostic msg
addReport Diagnostic msg
forall a. Default a => a
def Report msg
report
  where
    fromSourcePos :: PP.SourcePos -> Position
    fromSourcePos :: SourcePos -> Position
fromSourcePos SourcePos
pos =
      let start :: (Int, Int)
start = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SourcePos -> Int
PP.sourceLine SourcePos
pos, SourcePos -> Int
PP.sourceColumn SourcePos
pos)
          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) -> FilePath -> Position
Position (Int, Int)
start (Int, Int)
end (SourcePos -> FilePath
PP.sourceName SourcePos
pos)

    toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)]
    toMarkers :: Position -> [Message] -> [(Position, Marker msg)]
toMarkers Position
source [] = [(Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString FilePath
"<<unknown error>>")]
    toMarkers Position
source [Message]
msgs =
      let putTogether :: [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [] = ([], [], [], [])
          putTogether (PE.SysUnExpect FilePath
thing : [Message]
ms) = let ([FilePath]
a, [FilePath]
b, [FilePath]
c, [FilePath]
d) = [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [Message]
ms in (FilePath
thing FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
a, [FilePath]
b, [FilePath]
c, [FilePath]
d)
          putTogether (PE.UnExpect FilePath
thing : [Message]
ms) = let ([FilePath]
a, [FilePath]
b, [FilePath]
c, [FilePath]
d) = [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [Message]
ms in ([FilePath]
a, FilePath
thing FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
b, [FilePath]
c, [FilePath]
d)
          putTogether (PE.Expect FilePath
thing : [Message]
ms) = let ([FilePath]
a, [FilePath]
b, [FilePath]
c, [FilePath]
d) = [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [Message]
ms in ([FilePath]
a, [FilePath]
b, FilePath
thing FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
c, [FilePath]
d)
          putTogether (PE.Message FilePath
thing : [Message]
ms) = let ([FilePath]
a, [FilePath]
b, [FilePath]
c, [FilePath]
d) = [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [Message]
ms in ([FilePath]
a, [FilePath]
b, [FilePath]
c, FilePath
thing FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
d)

          ([FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub -> [FilePath]
sysUnexpectedList, [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub -> [FilePath]
unexpectedList, [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub -> [FilePath]
expectedList, [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub -> [FilePath]
messages) = [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [Message]
msgs
       in [ (Position
source, Marker msg
marker) | FilePath
unexpected <- if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
unexpectedList then [FilePath]
sysUnexpectedList else [FilePath]
unexpectedList, let marker :: Marker msg
marker = msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString (FilePath -> msg) -> FilePath -> msg
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
unexpected
          ]
            [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [ (Position
source, Marker msg
marker) | FilePath
msg <- [FilePath]
messages, let marker :: Marker msg
marker = msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString FilePath
msg
               ]
            [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
Where (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString (FilePath -> msg) -> FilePath -> msg
forall a b. (a -> b) -> a -> b
$ FilePath
"expecting any of " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [FilePath]
expectedList))]

-- | Generates an error diagnostic from a 'PE.ParseError'.
errorDiagnosticFromParseError ::
  forall msg.
  (IsString msg, HasHints Void msg) =>
  -- | An optional error code
  Maybe msg ->
  -- | The main error message of the diagnostic
  msg ->
  -- | Default hints
  Maybe [msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
errorDiagnosticFromParseError :: Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
errorDiagnosticFromParseError = (ParseError -> Bool)
-> Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError (Bool -> ParseError -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Generates a warning diagnostic from a 'PE.ParseError'.
warningDiagnosticFromParseError ::
  forall msg.
  (IsString msg, HasHints Void msg) =>
  -- | An optional error code
  Maybe msg ->
  -- | The main error message of the diagnostic
  msg ->
  -- | Default hints
  Maybe [msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
warningDiagnosticFromParseError :: Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
warningDiagnosticFromParseError = (ParseError -> Bool)
-> Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg -> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError (Bool -> ParseError -> 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)