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

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

-- |
-- Module      : Error.Diagnose.Compat.Parsec
-- Description : Compatibility layer for parsec
-- Copyright   : (c) Mesabloo, 2021-2022
-- 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 [Note msg] ->
  -- | The 'PE.ParseError' to transform into a 'Diagnostic'
  PE.ParseError ->
  Diagnostic msg
diagnosticFromParseError :: forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
diagnosticFromParseError ParseError -> Bool
isError Maybe msg
code msg
msg ([Note msg] -> Maybe [Note msg] -> [Note msg]
forall a. a -> Maybe a -> a
fromMaybe [] -> [Note 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)] -> [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) [(Position, Marker msg)]
markers ([Note msg]
defaultHints [Note msg] -> [Note msg] -> [Note msg]
forall a. Semigroup a => a -> a -> a
<> Void -> [Note msg]
forall e msg. HasHints e msg => e -> [Note 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) -> [Char] -> Position
Position (Int, Int)
start (Int, Int)
end (SourcePos -> [Char]
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
$ [Char] -> msg
forall a. IsString a => [Char] -> a
fromString [Char]
"<<unknown error>>")]
    toMarkers Position
source [Message]
msgs =
      let putTogether :: [Message] -> ([[Char]], [[Char]], [[Char]], [[Char]])
putTogether [] = ([], [], [], [])
          putTogether (PE.SysUnExpect [Char]
thing : [Message]
ms) = let ([[Char]]
a, [[Char]]
b, [[Char]]
c, [[Char]]
d) = [Message] -> ([[Char]], [[Char]], [[Char]], [[Char]])
putTogether [Message]
ms in ([Char]
thing [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
a, [[Char]]
b, [[Char]]
c, [[Char]]
d)
          putTogether (PE.UnExpect [Char]
thing : [Message]
ms) = let ([[Char]]
a, [[Char]]
b, [[Char]]
c, [[Char]]
d) = [Message] -> ([[Char]], [[Char]], [[Char]], [[Char]])
putTogether [Message]
ms in ([[Char]]
a, [Char]
thing [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
b, [[Char]]
c, [[Char]]
d)
          putTogether (PE.Expect [Char]
thing : [Message]
ms) = let ([[Char]]
a, [[Char]]
b, [[Char]]
c, [[Char]]
d) = [Message] -> ([[Char]], [[Char]], [[Char]], [[Char]])
putTogether [Message]
ms in ([[Char]]
a, [[Char]]
b, [Char]
thing [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
c, [[Char]]
d)
          putTogether (PE.Message [Char]
thing : [Message]
ms) = let ([[Char]]
a, [[Char]]
b, [[Char]]
c, [[Char]]
d) = [Message] -> ([[Char]], [[Char]], [[Char]], [[Char]])
putTogether [Message]
ms in ([[Char]]
a, [[Char]]
b, [[Char]]
c, [Char]
thing [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
d)

          ([[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub -> [[Char]]
sysUnexpectedList, [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub -> [[Char]]
unexpectedList, [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub -> [[Char]]
expectedList, [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub -> [[Char]]
messages) = [Message] -> ([[Char]], [[Char]], [[Char]], [[Char]])
putTogether [Message]
msgs

          firstSysUnexpectedMessage :: [Char]
firstSysUnexpectedMessage = [[Char]] -> [Char]
forall a. [a] -> a
head [[Char]]
sysUnexpectedList
          unexpectedMessage :: [Char]
unexpectedMessage = [Char]
"unexpected " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> if [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
unexpectedList then if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
firstSysUnexpectedMessage then [Char]
"end of line" else [Char]
firstSysUnexpectedMessage else [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Char]]
unexpectedList)
       in [ (Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ [Char] -> msg
forall a. IsString a => [Char] -> a
fromString [Char]
unexpectedMessage) ]
            [(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
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ [Char] -> msg
forall a. IsString a => [Char] -> a
fromString [Char]
msg) | [Char]
msg <- [[Char]]
messages ]
            [(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
$ [Char] -> msg
forall a. IsString a => [Char] -> a
fromString ([Char] -> msg) -> [Char] -> msg
forall a b. (a -> b) -> a -> b
$ [Char]
"expecting any of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Char]]
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 [Note msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
errorDiagnosticFromParseError :: forall msg.
(IsString msg, HasHints Void msg) =>
Maybe msg
-> msg -> Maybe [Note msg] -> ParseError -> Diagnostic msg
errorDiagnosticFromParseError = (ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note 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 [Note msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
warningDiagnosticFromParseError :: forall msg.
(IsString msg, HasHints Void msg) =>
Maybe msg
-> msg -> Maybe [Note msg] -> ParseError -> Diagnostic msg
warningDiagnosticFromParseError = (ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note 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 :: forall a b. (a -> b) -> (a, a) -> (b, b)
both a -> b
f ~(a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)