{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}

-- | Defines a simple exception type and utilities to throw it. The
-- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException'
-- type.  It omits the exception constructors that involve
-- pretty-printing via 'GHC.Utils.Outputable.SDoc'.
--
-- The reason for this is to avoid import cycles / use of boot files.
-- "GHC.Utils.Outputable" has many transitive dependencies.
-- To throw exceptions from these modules, the functions here can be used
-- without introducing import cycles.
module GHC.Utils.Panic.Plain
  ( PlainGhcException(..)
  , showPlainGhcException

  , panic, sorry, pgmError
  , cmdLineError, cmdLineErrorIO
  , assertPanic
  , assert, assertM, massert
  ) where

import GHC.Settings.Config
import GHC.Utils.Constants
import GHC.Utils.Exception as Exception
import GHC.Stack
import GHC.Prelude.Basic

import Control.Monad (when)
import System.IO.Unsafe

-- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits
-- the constructors that involve pretty-printing via
-- 'GHC.Utils.Outputable.SDoc'.  Due to the implementation of 'fromException'
-- for 'GHC.Utils.Panic.GhcException', this type can be caught as a
-- 'GHC.Utils.Panic.GhcException'.
--
-- Note that this should only be used for throwing exceptions, not for
-- catching, as 'GHC.Utils.Panic.GhcException' will not be converted to this
-- type when catching.
data PlainGhcException
  -- | Some other fatal signal (SIGHUP,SIGTERM)
  = PlainSignal Int

  -- | Prints the short usage msg after the error
  | PlainUsageError        String

  -- | A problem with the command line arguments, but don't print usage.
  | PlainCmdLineError      String

  -- | The 'impossible' happened.
  | PlainPanic             String

  -- | The user tickled something that's known not to work yet,
  --   but we're not counting it as a bug.
  | PlainSorry             String

  -- | An installation problem.
  | PlainInstallationError String

  -- | An error in the user's code, probably.
  | PlainProgramError      String

instance Exception PlainGhcException

instance Show PlainGhcException where
  showsPrec :: Int -> PlainGhcException -> ShowS
showsPrec Int
_ PlainGhcException
e = PlainGhcException -> ShowS
showPlainGhcException PlainGhcException
e

-- | Short usage information to display when we are given the wrong cmd line arguments.
short_usage :: String
short_usage :: String
short_usage = String
"Usage: For basic information, try the `--help' option."

-- | Append a description of the given exception to this string.
showPlainGhcException :: PlainGhcException -> ShowS
showPlainGhcException :: PlainGhcException -> ShowS
showPlainGhcException =
  \case
    PlainSignal Int
n -> String -> ShowS
showString String
"signal: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
n
    PlainUsageError String
str -> String -> ShowS
showString String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
short_usage
    PlainCmdLineError String
str -> String -> ShowS
showString String
str
    PlainPanic String
s -> ShowS -> ShowS
panicMsg (String -> ShowS
showString String
s)
    PlainSorry String
s -> ShowS -> ShowS
sorryMsg (String -> ShowS
showString String
s)
    PlainInstallationError String
str -> String -> ShowS
showString String
str
    PlainProgramError String
str -> String -> ShowS
showString String
str
  where
    sorryMsg :: ShowS -> ShowS
    sorryMsg :: ShowS -> ShowS
sorryMsg ShowS
s =
        String -> ShowS
showString String
"sorry! (unimplemented feature or known bug)\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (String
"  GHC version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n\t")
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n"

    panicMsg :: ShowS -> ShowS
    panicMsg :: ShowS -> ShowS
panicMsg ShowS
s =
        String -> ShowS
showString String
"panic! (the 'impossible' happened)\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (String
"  GHC version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n\t")
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug\n"

throwPlainGhcException :: PlainGhcException -> a
throwPlainGhcException :: forall a. PlainGhcException -> a
throwPlainGhcException = PlainGhcException -> a
forall a e. (?callStack::CallStack, Exception e) => e -> a
Exception.throw

-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
panic :: forall a. (?callStack::CallStack) => String -> a
panic    String
x = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
   stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
   let doc = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"  "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (CallStack -> String
prettyCallStack CallStack
(?callStack::CallStack) => CallStack
callStack)
   if null stack
      then throwPlainGhcException (PlainPanic (x ++ '\n' : doc))
      else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))

sorry :: forall a. (?callStack::CallStack) => String -> a
sorry    String
x = PlainGhcException -> a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainSorry String
x)
pgmError :: forall a. (?callStack::CallStack) => String -> a
pgmError String
x = PlainGhcException -> a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainProgramError String
x)

cmdLineError :: String -> a
cmdLineError :: forall a. String -> a
cmdLineError = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> (String -> IO a) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. String -> IO a
cmdLineErrorIO

cmdLineErrorIO :: String -> IO a
cmdLineErrorIO :: forall a. String -> IO a
cmdLineErrorIO String
x = do
  stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
  if null stack
    then throwPlainGhcException (PlainCmdLineError x)
    else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))

-- | Throw a failed assertion exception for a given filename and line number.
assertPanic :: String -> Int -> a
assertPanic :: forall a. String -> Int -> a
assertPanic String
file Int
line =
  AssertionFailed -> a
forall a e. (?callStack::CallStack, Exception e) => e -> a
Exception.throw (String -> AssertionFailed
Exception.AssertionFailed
           (String
"ASSERT failed! file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", line " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line))


assertPanic' :: HasCallStack => a
assertPanic' :: forall a. (?callStack::CallStack) => a
assertPanic' =
  let doc :: String
doc = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"  "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (CallStack -> String
prettyCallStack CallStack
(?callStack::CallStack) => CallStack
callStack)
  in
  AssertionFailed -> a
forall a e. (?callStack::CallStack, Exception e) => e -> a
Exception.throw (String -> AssertionFailed
Exception.AssertionFailed
           (String
"ASSERT failed!\n"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((?callStack::CallStack) => String) -> String
forall a.
(?callStack::CallStack) =>
((?callStack::CallStack) => a) -> a
withFrozenCallStack String
(?callStack::CallStack) => String
doc))

assert :: HasCallStack => Bool -> a -> a
{-# INLINE assert #-}
assert :: forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
cond a
a =
  if Bool
debugIsOn Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cond
    then ((?callStack::CallStack) => a) -> a
forall a.
(?callStack::CallStack) =>
((?callStack::CallStack) => a) -> a
withFrozenCallStack a
(?callStack::CallStack) => a
forall a. (?callStack::CallStack) => a
assertPanic'
    else a
a

massert :: (HasCallStack, Applicative m) => Bool -> m ()
{-# INLINE massert #-}
massert :: forall (m :: * -> *).
(?callStack::CallStack, Applicative m) =>
Bool -> m ()
massert Bool
cond = ((?callStack::CallStack) => m ()) -> m ()
forall a.
(?callStack::CallStack) =>
((?callStack::CallStack) => a) -> a
withFrozenCallStack (Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
cond (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

assertM :: (HasCallStack, Monad m) => m Bool -> m ()
{-# INLINE assertM #-}
assertM :: forall (m :: * -> *).
(?callStack::CallStack, Monad m) =>
m Bool -> m ()
assertM m Bool
mcond
  | Bool
debugIsOn = ((?callStack::CallStack) => m ()) -> m ()
forall a.
(?callStack::CallStack) =>
((?callStack::CallStack) => a) -> a
withFrozenCallStack (((?callStack::CallStack) => m ()) -> m ())
-> ((?callStack::CallStack) => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
      res <- m Bool
mcond
      when (not res) assertPanic'
  | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()