{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Skeletest.Internal.Error (
  SkeletestError (..),
  skeletestError,
  skeletestPluginError,
  invariantViolation,
) where

import Control.Monad.IO.Class (MonadIO)
import Data.Text (Text)
import Data.Text qualified as Text
import GHC qualified
import GHC.Stack (HasCallStack, callStack, prettyCallStack)
import UnliftIO.Exception (Exception (..), impureThrow, throwIO)

data SkeletestError
  = -- | Thrown for most errors, unless an error needs to be specially caught.
    SkeletestError Text
  | -- | A user error during compilation, e.g. during the preprocessor or plugin phases.
    CompilationError (Maybe GHC.SrcSpan) Text
  | -- | Skip the currently running test
    SkipTest Text
  deriving (Int -> SkeletestError -> ShowS
[SkeletestError] -> ShowS
SkeletestError -> String
(Int -> SkeletestError -> ShowS)
-> (SkeletestError -> String)
-> ([SkeletestError] -> ShowS)
-> Show SkeletestError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SkeletestError -> ShowS
showsPrec :: Int -> SkeletestError -> ShowS
$cshow :: SkeletestError -> String
show :: SkeletestError -> String
$cshowList :: [SkeletestError] -> ShowS
showList :: [SkeletestError] -> ShowS
Show)

instance Exception SkeletestError where
  displayException :: SkeletestError -> String
displayException =
    Text -> String
Text.unpack (Text -> String)
-> (SkeletestError -> Text) -> SkeletestError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      SkeletestError Text
msg -> Text
msg
      CompilationError Maybe SrcSpan
_ Text
msg ->
        [Text] -> Text
Text.unlines
          [ Text
""
          , Text
"******************** skeletest failure ********************"
          , Text
msg
          ]
      SkipTest Text
msg -> Text
"SKIP: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

skeletestError :: (MonadIO m) => Text -> m a
skeletestError :: forall (m :: * -> *) a. MonadIO m => Text -> m a
skeletestError = SkeletestError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SkeletestError -> m a) -> (Text -> SkeletestError) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SkeletestError
SkeletestError

skeletestPluginError :: Maybe GHC.SrcSpan -> String -> a
skeletestPluginError :: forall a. Maybe SrcSpan -> String -> a
skeletestPluginError Maybe SrcSpan
mloc = SkeletestError -> a
forall e a. Exception e => e -> a
impureThrow (SkeletestError -> a) -> (String -> SkeletestError) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcSpan -> Text -> SkeletestError
CompilationError Maybe SrcSpan
mloc (Text -> SkeletestError)
-> (String -> Text) -> String -> SkeletestError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

invariantViolation :: (HasCallStack) => String -> a
invariantViolation :: forall a. HasCallStack => String -> a
invariantViolation = SkeletestError -> a
forall e a. Exception e => e -> a
impureThrow (SkeletestError -> a) -> (String -> SkeletestError) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SkeletestError
SkeletestError (Text -> SkeletestError)
-> (String -> Text) -> String -> SkeletestError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
toMessage
 where
  toMessage :: ShowS
toMessage String
msg =
    [String] -> String
unlines
      [ String
"Invariant violation: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg
      , String
"**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues"
      , String
""
      , CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
      ]