{-# 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 (forall a. a -> Maybe a -> a
fromMaybe [] -> [Note msg]
defaultHints) ParseError
error =
let pos :: Position
pos = SourcePos -> Position
fromSourcePos 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 forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
PE.errorMessages ParseError
error
report :: Report msg
report = (if ParseError -> Bool
isError ParseError
error then forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
Err Maybe msg
code msg
msg else 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 forall a. Semigroup a => a -> a -> a
<> forall e msg. HasHints e msg => e -> [Note msg]
hints (forall a. HasCallStack => a
undefined :: Void))
in forall msg. Diagnostic msg -> Report msg -> Diagnostic msg
addReport forall a. Monoid a => a
mempty Report msg
report
where
fromSourcePos :: PP.SourcePos -> Position
fromSourcePos :: SourcePos -> Position
fromSourcePos SourcePos
pos =
let start :: (Int, Int)
start = forall a b. (a -> b) -> (a, a) -> (b, b)
both 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 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (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 (SourcePos -> String
PP.sourceName SourcePos
pos)
toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)]
toMarkers :: Position -> [Message] -> [(Position, Marker msg)]
toMarkers Position
source [] = [(Position
source, forall msg. msg -> Marker msg
This forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
"<<unknown error>>")]
toMarkers Position
source [Message]
msgs =
let putTogether :: [Message] -> ([String], [String], [String], [String])
putTogether [] = ([], [], [], [])
putTogether (PE.SysUnExpect String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in (String
thing forall a. a -> [a] -> [a]
: [String]
a, [String]
b, [String]
c, [String]
d)
putTogether (PE.UnExpect String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in ([String]
a, String
thing forall a. a -> [a] -> [a]
: [String]
b, [String]
c, [String]
d)
putTogether (PE.Expect String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in ([String]
a, [String]
b, String
thing forall a. a -> [a] -> [a]
: [String]
c, [String]
d)
putTogether (PE.Message String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in ([String]
a, [String]
b, [String]
c, String
thing forall a. a -> [a] -> [a]
: [String]
d)
(forall a. Eq a => [a] -> [a]
nub -> [String]
sysUnexpectedList, forall a. Eq a => [a] -> [a]
nub -> [String]
unexpectedList, forall a. Eq a => [a] -> [a]
nub -> [String]
expectedList, forall a. Eq a => [a] -> [a]
nub -> [String]
messages) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
msgs
firstSysUnexpectedMessage :: String
firstSysUnexpectedMessage = forall a. [a] -> a
head [String]
sysUnexpectedList
unexpectedMessage :: String
unexpectedMessage = String
"unexpected " forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unexpectedList then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
firstSysUnexpectedMessage then String
"end of line" else String
firstSysUnexpectedMessage else forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
unexpectedList)
in [ (Position
source, forall msg. msg -> Marker msg
This forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
unexpectedMessage) ]
forall a. Semigroup a => a -> a -> a
<> [ (Position
source, forall msg. msg -> Marker msg
This forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
msg) | String
msg <- [String]
messages ]
forall a. Semigroup a => a -> a -> a
<> [ (Position
source, forall msg. msg -> Marker msg
Where forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"expecting any of " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
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 = forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
diagnosticFromParseError (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 = forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
diagnosticFromParseError (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)