{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS -Wno-name-shadowing #-}
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
diagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
(PE.ParseError -> Bool) ->
Maybe msg ->
msg ->
Maybe [Note msg] ->
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)) ]
errorDiagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
Maybe msg ->
msg ->
Maybe [Note msg] ->
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)
warningDiagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
Maybe msg ->
msg ->
Maybe [Note msg] ->
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)
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)