module Slab.Error
( Error (..)
, unwrap
, display
) where
import Data.List.NonEmpty qualified as NE (toList)
import Data.Set qualified as S (toList)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.IO qualified as TL
import Data.Void (Void)
import System.Exit (exitFailure)
import Text.Megaparsec hiding (Label, label, parse, parseErrorPretty, unexpected)
import Text.Megaparsec qualified as M
import Text.Pretty.Simple (pShowNoColor)
data Error
= ParseError (ParseErrorBundle Text Void)
| PreProcessError Text
| EvaluateError Text
| ExecuteError Text
deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq)
unwrap :: Either Error a -> IO a
unwrap :: forall a. Either Error a -> IO a
unwrap = \case
Left Error
err -> do
Error -> IO ()
display Error
err
IO a
forall a. IO a
exitFailure
Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
display :: Error -> IO ()
display :: Error -> IO ()
display = \case
ParseError ParseErrorBundle Text Void
err ->
Text -> IO ()
T.putStrLn (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
err
EvaluateError Text
err ->
Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error during evaluation: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
Error
err ->
Text -> IO ()
TL.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Error -> Text
forall a. Show a => a -> Text
pShowNoColor Error
err
parseErrorPretty :: ParseErrorBundle Text Void -> Text
parseErrorPretty :: ParseErrorBundle Text Void -> Text
parseErrorPretty (ParseErrorBundle NonEmpty (ParseError Text Void)
errors PosState Text
posState) =
case NonEmpty (ParseError Text Void) -> [ParseError Text Void]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (ParseError Text Void)
errors of
[] -> Text
"Unknown error"
(ParseError Text Void
e : [ParseError Text Void]
_) -> case ParseError Text Void
e of
TrivialError Int
offset Maybe (ErrorItem (Token Text))
unexpected Set (ErrorItem (Token Text))
expected ->
let
pos :: SourcePos
pos = PosState Text -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos (PosState Text -> SourcePos) -> PosState Text -> SourcePos
forall a b. (a -> b) -> a -> b
$ Int -> PosState Text -> PosState Text
forall s. TraversableStream s => Int -> PosState s -> PosState s
reachOffsetNoLine Int
offset PosState Text
posState
errorPos :: Text
errorPos =
String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos (SourcePos -> Pos
sourceLine SourcePos
pos)))
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos (SourcePos -> Pos
sourceColumn SourcePos
pos)))
unexpectedMsg :: Text
unexpectedMsg =
Text -> (ErrorItem Char -> Text) -> Maybe (ErrorItem Char) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Text
"Unexpected end of input."
(\ErrorItem Char
u -> Text
"Unexpected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorItem Char -> Text
errorItemPretty ErrorItem Char
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".")
Maybe (ErrorItem Char)
Maybe (ErrorItem (Token Text))
unexpected
expectedMsg :: Text
expectedMsg =
if Set (ErrorItem Char) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (ErrorItem Char)
Set (ErrorItem (Token Text))
expected
then Text
""
else Text
"Expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text)
-> (Set (ErrorItem (Token Text)) -> [Text])
-> Set (ErrorItem (Token Text))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrorItem Char -> Text) -> [ErrorItem Char] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ErrorItem Char -> Text
errorItemPretty ([ErrorItem Char] -> [Text])
-> (Set (ErrorItem Char) -> [ErrorItem Char])
-> Set (ErrorItem Char)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (ErrorItem Char) -> [ErrorItem Char]
forall a. Set a -> [a]
S.toList (Set (ErrorItem (Token Text)) -> Text)
-> Set (ErrorItem (Token Text)) -> Text
forall a b. (a -> b) -> a -> b
$ Set (ErrorItem (Token Text))
expected) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
in
[Text] -> Text
T.unwords
[ Text
"Error at"
, Text
errorPos
, Text
"-"
, Text
unexpectedMsg
, if Text -> Bool
T.null Text
expectedMsg then Text
"." else Text
expectedMsg
]
FancyError Int
offset Set (ErrorFancy Void)
err -> Text
"Complex error at position " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
offset) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
TL.toStrict (Set (ErrorFancy Void) -> Text
forall a. Show a => a -> Text
pShowNoColor Set (ErrorFancy Void)
err)
errorItemPretty :: ErrorItem Char -> Text
errorItemPretty :: ErrorItem Char -> Text
errorItemPretty = \case
Tokens NonEmpty Char
ts -> Text
"character '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Char
ts) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
M.Label NonEmpty Char
label -> String -> Text
T.pack (NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Char
label)
ErrorItem Char
EndOfInput -> Text
"end of input"