bugsnag-1.2.0.3: test/Examples.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}

-- | Functions that throw
--
-- These are used in the test suite but are define here so that, hopefully, the
-- path/line/column will remain stable even if we re-organize the tests
-- themselves
module Examples where

import Prelude

import Control.Exception
import Control.Exception.Annotated (checkpointCallStack)
import Data.Bugsnag hiding (Exception)
import GHC.Stack (HasCallStack)
import Network.Bugsnag.Exception
import Network.Bugsnag.StackFrame
import UnliftIO.Exception (throwString)

#if MIN_VERSION_base(4,20,0)
import Control.Exception.Backtrace (collectBacktraces)
#endif

brokenFunctionIO :: IO a
brokenFunctionIO =
  throw $
    AsException $
      defaultException
        { exception_errorClass = "IOException"
        , exception_message = Just "Something exploded"
        , exception_stacktrace = [$(currentStackFrame) "brokenFunctionIO"]
        }

brokenFunction :: HasCallStack => a
brokenFunction = sillyHead [] `seq` undefined

sillyHead :: HasCallStack => [a] -> a
sillyHead (x : _) = x
sillyHead _ = error "empty list"

brokenFunction' :: HasCallStack => IO a
brokenFunction' = sillyHead' []

sillyHead' :: HasCallStack => [a] -> IO a
sillyHead' (x : _) = pure x
sillyHead' _ = throwString "empty list"

brokenFunction'' :: HasCallStack => IO a
brokenFunction'' = sillyHead'' []

sillyHead'' :: HasCallStack => [a] -> IO a
sillyHead'' (x : _) = pure x
sillyHead'' _ = throwString "empty list\n and message with newlines\n\n"

brokenFunctionAnnotated :: HasCallStack => IO a
brokenFunctionAnnotated = checkpointCallStack $ sillyHead' []

-- | An exception type distinct from any other used in this test suite,
--   so that tests can assert on its type name specifically
data Whatever = Whatever
  deriving stock (Show)
  deriving anyclass (Exception)

#if MIN_VERSION_base(4,20,0)
data Boom = Boom deriving stock (Show)
instance Exception Boom

-- | Throws with only base's native (automatic, per-throw) backtrace
-- collection attached -- no @annotated-exception@ involved
brokenFunctionBacktrace :: HasCallStack => IO a
brokenFunctionBacktrace = sillyHeadBacktrace []

sillyHeadBacktrace :: HasCallStack => [a] -> IO a
sillyHeadBacktrace (_ : _) = error "unreachable"
sillyHeadBacktrace [] = throwIO Boom

-- | Like 'brokenFunctionBacktrace', but with a second 'Control.Exception.Backtrace.Backtraces'
-- annotation attached on top, simulating an application-level checkpoint
-- (e.g. @Control.Exception.Annotated.checkpointCallStack@-style, but built on
-- base's native mechanism instead) re-collecting one further up
brokenFunctionBacktraceCheckpointed :: IO a
brokenFunctionBacktraceCheckpointed = do
  bt <- collectBacktraces
  annotateIO bt brokenFunctionBacktrace
#endif