{-# 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.Function ((&))
import Data.List (intercalate)
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) ->
msg ->
Maybe [msg] ->
PE.ParseError ->
Diagnostic msg
diagnosticFromParseError :: (ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError ParseError -> Bool
isError 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 = (msg
msg msg
-> (msg -> [(Position, Marker msg)] -> [msg] -> Report msg)
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
forall a b. a -> (a -> b) -> b
& if ParseError -> Bool
isError ParseError
error then msg -> [(Position, Marker msg)] -> [msg] -> Report msg
forall msg. msg -> [(Position, Marker msg)] -> [msg] -> Report msg
err else msg -> [(Position, Marker msg)] -> [msg] -> Report msg
forall msg. msg -> [(Position, Marker msg)] -> [msg] -> Report msg
warn) [(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]
sysUnexpectedList, [FilePath]
unexpectedList, [FilePath]
expectedList, [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]
expectedList)]
errorDiagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
msg ->
Maybe [msg] ->
PE.ParseError ->
Diagnostic msg
errorDiagnosticFromParseError :: msg -> Maybe [msg] -> ParseError -> Diagnostic msg
errorDiagnosticFromParseError = (ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> msg -> Maybe [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) =>
msg ->
Maybe [msg] ->
PE.ParseError ->
Diagnostic msg
warningDiagnosticFromParseError :: msg -> Maybe [msg] -> ParseError -> Diagnostic msg
warningDiagnosticFromParseError = (ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> msg -> Maybe [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 :: (a -> b) -> (a, a) -> (b, b)
both a -> b
f ~(a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)