{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE DerivingVia #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TextShow.Control.Exception () where
import Control.Exception.Base
import Data.Text.Lazy.Builder (fromString)
#if MIN_VERSION_base(4,9,0)
import Data.Text.Lazy.Builder (singleton)
#endif
import Prelude ()
import Prelude.Compat
import TextShow.Classes (TextShow(..))
import TextShow.FromStringTextShow (FromStringShow(..))
import TextShow.TH.Internal (deriveTextShow)
#if __GLASGOW_HASKELL__ >= 806
deriving via FromStringShow SomeException instance TextShow SomeException
#else
instance TextShow SomeException where
showbPrec p (SomeException e) = showbPrec p $ FromStringShow e
{-# INLINE showbPrec #-}
#endif
#if __GLASGOW_HASKELL__ >= 806
deriving via FromStringShow IOException instance TextShow IOException
#else
instance TextShow IOException where
showb = showb . FromStringShow
{-# INLINE showb #-}
#endif
instance TextShow ArithException where
showb :: ArithException -> Builder
showb ArithException
Overflow = Builder
"arithmetic overflow"
showb ArithException
Underflow = Builder
"arithmetic underflow"
showb ArithException
LossOfPrecision = Builder
"loss of precision"
showb ArithException
DivideByZero = Builder
"divide by zero"
showb ArithException
Denormal = Builder
"denormal"
#if MIN_VERSION_base(4,6,0)
showb ArithException
RatioZeroDenominator = Builder
"Ratio has zero denominator"
#endif
instance TextShow ArrayException where
showb :: ArrayException -> Builder
showb (IndexOutOfBounds String
s)
= Builder
"array index out of range"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then Builder
": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
s
else Builder
forall a. Monoid a => a
mempty)
showb (UndefinedElement String
s)
= Builder
"undefined array element"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then Builder
": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
s
else Builder
forall a. Monoid a => a
mempty)
{-# INLINE showb #-}
instance TextShow AssertionFailed where
showb :: AssertionFailed -> Builder
showb (AssertionFailed String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
#if MIN_VERSION_base(4,7,0)
instance TextShow SomeAsyncException where
showb :: SomeAsyncException -> Builder
showb (SomeAsyncException e
e) = FromStringShow e -> Builder
forall a. TextShow a => a -> Builder
showb (FromStringShow e -> Builder) -> FromStringShow e -> Builder
forall a b. (a -> b) -> a -> b
$ e -> FromStringShow e
forall a. a -> FromStringShow a
FromStringShow e
e
{-# INLINE showb #-}
#endif
instance TextShow AsyncException where
showb :: AsyncException -> Builder
showb AsyncException
StackOverflow = Builder
"stack overflow"
showb AsyncException
HeapOverflow = Builder
"heap overflow"
showb AsyncException
ThreadKilled = Builder
"thread killed"
showb AsyncException
UserInterrupt = Builder
"user interrupt"
{-# INLINE showb #-}
instance TextShow NonTermination where
showb :: NonTermination -> Builder
showb NonTermination
NonTermination = Builder
"<<loop>>"
{-# INLINE showb #-}
instance TextShow NestedAtomically where
showb :: NestedAtomically -> Builder
showb NestedAtomically
NestedAtomically = Builder
"Control.Concurrent.STM.atomically was nested"
{-# INLINE showb #-}
instance TextShow BlockedIndefinitelyOnMVar where
showb :: BlockedIndefinitelyOnMVar -> Builder
showb BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar = Builder
"thread blocked indefinitely in an MVar operation"
{-# INLINE showb #-}
instance TextShow BlockedIndefinitelyOnSTM where
showb :: BlockedIndefinitelyOnSTM -> Builder
showb BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM = Builder
"thread blocked indefinitely in an STM transaction"
{-# INLINE showb #-}
#if MIN_VERSION_base(4,8,0)
instance TextShow AllocationLimitExceeded where
showb :: AllocationLimitExceeded -> Builder
showb AllocationLimitExceeded
AllocationLimitExceeded = Builder
"allocation limit exceeded"
{-# INLINE showb #-}
#endif
#if MIN_VERSION_base(4,9,0)
instance TextShow TypeError where
showb :: TypeError -> Builder
showb (TypeError String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
#endif
#if MIN_VERSION_base(4,10,0)
instance TextShow CompactionFailed where
showb :: CompactionFailed -> Builder
showb (CompactionFailed String
why) = String -> Builder
fromString (String
"compaction failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
why)
#endif
#if MIN_VERSION_base(4,11,0)
instance TextShow FixIOException where
showbPrec :: Int -> FixIOException -> Builder
showbPrec Int
_ FixIOException
FixIOException = String -> Builder
fromString String
"cyclic evaluation in fixIO"
#endif
instance TextShow Deadlock where
showb :: Deadlock -> Builder
showb Deadlock
Deadlock = Builder
"<<deadlock>>"
{-# INLINE showb #-}
instance TextShow NoMethodError where
showb :: NoMethodError -> Builder
showb (NoMethodError String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
instance TextShow PatternMatchFail where
showb :: PatternMatchFail -> Builder
showb (PatternMatchFail String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
instance TextShow RecConError where
showb :: RecConError -> Builder
showb (RecConError String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
instance TextShow RecSelError where
showb :: RecSelError -> Builder
showb (RecSelError String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
instance TextShow RecUpdError where
showb :: RecUpdError -> Builder
showb (RecUpdError String
err) = String -> Builder
fromString String
err
{-# INLINE showb #-}
instance TextShow ErrorCall where
#if MIN_VERSION_base(4,9,0)
showb :: ErrorCall -> Builder
showb (ErrorCallWithLocation String
err String
"") = String -> Builder
fromString String
err
showb (ErrorCallWithLocation String
err String
loc) =
String -> Builder
fromString String
err Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'\n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
loc
#else
showb (ErrorCall err) = fromString err
#endif
$(deriveTextShow ''MaskingState)