module Slab.Error
  ( Error (..)
  , unwrap
  ) 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)

--------------------------------------------------------------------------------

-- | Represent all errors emitted by Slab. I.e. this is used in each stage
-- (`Slab.Parse`, `Slab.PreProcess`, `Slab.Evaluate`, `Slab.ExecuteError`).
data Error
  = ParseError (ParseErrorBundle Text Void)
  | PreProcessError Text -- TODO Add specific variants instead of using Text.
  | EvaluateError Text -- TODO Add specific variants instead of using Text.
  | ExecuteError Text -- TODO Add specific variants instead of using 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)

-- | Extract a Right value, or die, emitting an error message.
unwrap :: Either Error a -> IO a
unwrap :: forall a. Either Error a -> IO a
unwrap = \case
  Left (ParseError ParseErrorBundle Text Void
err) -> do
    -- Our custom function seems actually worse than errorBundlePretty.
    -- T.putStrLn . parseErrorPretty $ 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
    IO a
forall a. IO a
exitFailure
  Left Error
err -> do
    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
    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

--------------------------------------------------------------------------------
-- Convert parse errors to a user-friendly message.
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"