{-# LANGUAGE RankNTypes #-}
-- | Syntactic sugar that improves the usability of 'Control.Exception.assert'
-- and 'error'. The original @assert@ function is here re-exported
-- for convenience.
--
-- Make sure to enable assertions for your cabal package, e.g., by setting
--
-- > ghc-options: -fno-ignore-asserts
--
-- in your .cabal file. Otherwise, some of the functions will have
-- no effect at all.
module Control.Exception.Assert.Sugar
  ( assert, blame, showFailure, swith, allB
    -- * DEPRECATED
  , twith, failure, forceEither
  ) where

import           Control.Exception (assert)
import           Data.Text (Text)
import           Debug.Trace (trace)
import           Prelude
import qualified Text.Show.Pretty as Show.Pretty (ppShow)

infix 1 `blame`
-- | If the condition fails, display the value blamed for the failure.
-- Used as in
--
-- > assert (age < 120 `blame` age) $ savings / (120 - age)
blame :: Show v => Bool -> v -> Bool
{-# NOINLINE blame #-}
blame :: Bool -> v -> Bool
blame Bool
True v
_ = Bool
True
blame Bool
False v
blamed = String -> Bool -> Bool
forall a. String -> a -> a
trace (v -> String
forall v. Show v => v -> String
blameMessage v
blamed) Bool
False

blameMessage :: Show v => v -> String
blameMessage :: v -> String
blameMessage v
blamed = String
"Contract failed and the following is to blame:\n  "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ v -> String
forall v. Show v => v -> String
Show.Pretty.ppShow v
blamed

infix 2 `showFailure`
-- | A helper function for 'error'. To be used as in
--
-- > case xs of
-- >   0 : _ -> error $ "insignificant zero" `showFailure` xs
--
-- Fixing the first argument to @String@ instead of anything Showable
-- prevents warnings about defaulting, even when @OverloadedStrings@
-- extension is enabled.
showFailure :: Show v => String -> v -> String
{-# NOINLINE showFailure #-}
showFailure :: String -> v -> String
showFailure String
s v
blamed =
  String
"Internal failure occurred and the following is to blame:\n  "
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  "
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ v -> String
forall v. Show v => v -> String
Show.Pretty.ppShow v
blamed

infix 2 `swith`
-- | Syntactic sugar for the pair operation, to be used for 'blame' as in
--
-- > assert (age < 120 `blame` "age too high" `swith` age) $ savings / (120 - age)
--
-- Fixing the first component of the pair to @String@ prevents warnings
-- about defaulting, even when @OverloadedStrings@ extension is enabled.
swith :: String -> v -> (String, v)
{-# INLINE swith #-}
swith :: String -> v -> (String, v)
swith String
s v
blamed = (String
s, v
blamed)

-- | Like 'List.all', but if the predicate fails, blame all the list elements
-- and especially those for which it fails. To be used as in
--
-- > assert (allB (<= height) [yf, y1, y2])
allB :: Show v => (v -> Bool) -> [v] -> Bool
{-# NOINLINE allB #-}
allB :: (v -> Bool) -> [v] -> Bool
allB v -> Bool
predicate [v]
l = case (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all v -> Bool
predicate [v]
l of
  Bool
True -> Bool
True
  Bool
False -> String -> Bool -> Bool
forall a. String -> a -> a
trace ((v -> Bool) -> [v] -> String
forall v. Show v => (v -> Bool) -> [v] -> String
allBMessage v -> Bool
predicate [v]
l) Bool
False

allBMessage :: Show v => (v -> Bool) -> [v] -> String
allBMessage :: (v -> Bool) -> [v] -> String
allBMessage v -> Bool
predicate [v]
l =
  String
"The following items on the list don't respect the contract:\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [v] -> String
forall v. Show v => v -> String
Show.Pretty.ppShow ((v -> Bool) -> [v] -> [v]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (v -> Bool) -> v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Bool
predicate) [v]
l)
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nout of all the list items below:\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [v] -> String
forall v. Show v => v -> String
Show.Pretty.ppShow [v]
l

-- * DEPRECATED

infix 2 `twith`
-- | Syntactic sugar for the pair operation, to be used for 'blame' as in
--
-- > assert (age < 120 `blame` "age too high" `twith` age) $ savings / (120 - age)
-- Fixing the first component of the pair to @Text@ prevents warnings
-- about defaulting, even when @OverloadedStrings@ extension is enabled.
{-# DEPRECATED twith
      "consider using 'swith' instead, for simplicity, because GHC optimizes lazy 'String' constants very well." #-}
twith :: Text -> b -> (Text, b)
{-# INLINE twith #-}
twith :: Text -> b -> (Text, b)
twith Text
t b
b = (Text
t, b
b)

infix 1 `failure`
-- | Like 'error', but shows the source position (in newer GHCs
-- @error@ shows source position as well, hence deprecation)
-- and also the value to blame for the failure. To be used as in
--
-- > case xs of
-- >   0 : _ -> assert `failure` (xs, "has an insignificant zero")
{-# DEPRECATED failure
      "use 'error' and 'showFailure' instead, now that 'error' prints source positions." #-}
failure :: Show a => (forall x. Bool -> x -> x) -> a -> b
{-# NOINLINE failure #-}
failure :: (forall x. Bool -> x -> x) -> a -> b
failure forall x. Bool -> x -> x
asrt a
blamed =
  let s :: String
s = String
"Internal failure occurred and the following is to blame:\n  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall v. Show v => v -> String
Show.Pretty.ppShow a
blamed
  in String -> b -> b
forall a. String -> a -> a
trace String
s
     (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ Bool -> b -> b
forall x. Bool -> x -> x
asrt Bool
False
     (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ String -> b
forall a. HasCallStack => String -> a
error String
"Control.Exception.Assert.Sugar.failure"
         -- Lack of no-ignore-asserts or GHC < 7.4.

infix 1 `forceEither`
-- | Assuming that @Left@ signifies an error condition,
-- check the @Either@ value and, if @Left@ is encountered,
-- fail outright and show the error message (in newer GHCs
-- @error@ shows source position as well, hence deprecation). Used as in
--
-- > assert `forceEither` parseOrFailWithMessage code
forceEither :: Show a => (forall x. Bool -> x -> x) -> Either a b -> b
{-# DEPRECATED forceEither
      "use 'either (error . show) id' instead, now that 'error' prints source positions." #-}
{-# NOINLINE forceEither #-}
forceEither :: (forall x. Bool -> x -> x) -> Either a b -> b
forceEither forall x. Bool -> x -> x
asrt (Left a
a)  = forall x. Bool -> x -> x
asrt (forall x. Bool -> x -> x) -> a -> b
forall a b. Show a => (forall x. Bool -> x -> x) -> a -> b
`failure` a
a
forceEither forall x. Bool -> x -> x
_    (Right b
b) = b
b