hspec.hs

module Main where

import           Control.Exception    (AsyncException (..),
                                       SomeAsyncException (..))
import           GHC.Stack            (currentCallStack)
import qualified Rerun
import qualified Spec
import           Test.Hspec.Core.Spec
import           Test.Hspec.Runner
import           Test.Import

main :: IO ()
main = Rerun.main $ hspecWith defaultConfig (mapSpecItem_ overflowExplainer Spec.spec)

overflowExplainer :: Item a -> Item a
overflowExplainer item =
  item { itemExample = \params func -> (itemExample item) params (overflowCatcher . func)}

newtype VerboseOverflowException
  = VerboseOverflowException [String]
  deriving (Eq)

instance Exception VerboseOverflowException

instance Show VerboseOverflowException where
  show (VerboseOverflowException cb) = "\n\n" ++ unlines cb

overflowCatcher :: IO a -> IO a
overflowCatcher f =
  catchJust (\e -> guard  (e ==StackOverflow))
            f
            (\_ -> throwM . SomeAsyncException . VerboseOverflowException . drop 1 . dropWhile (not . (isInfixOf ".overflowCatcher")) =<< currentCallStack)