Traced exceptions. module Is: https://gist.github.com/LSLeary/7165377d1a28bf76aa4c0aae189a6968

Traced.hs

{-# LANGUAGE GADTs, PatternSynonyms, LambdaCase, BlockArguments #-}

module Traced (
  Traced(..),
  catchTraced,
  trace,
) where

-- base
import Type.Reflection (typeOf, pattern App)
import Control.Exception (Exception(..), SomeException(..))
import System.Exit (ExitCode(ExitFailure))

-- exceptions
import Control.Monad.Catch (MonadCatch(..), catches, Handler(..), throwM)

import Is (pattern Is)


data Traced e = [String] :- e
 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
infix 5 :-

instance Exception e => Exception (Traced e) where
  displayException = \case
    [] :- e -> displayException e
    ss :- e -> "Traced:"
            ++ foldMap (\s -> "\n * " ++ s) ss
            ++ "\n * " ++ displayException e

catchTraced :: (MonadCatch m, Exception e) => m a -> (Traced e -> m a) -> m a
catchTraced act h = act `catches`
  [ Handler h
  , Handler \e -> h ([] :- e)
  ]

trace :: MonadCatch m => String -> m a -> m a
trace s act = act `catch` \(SomeException e) -> case typeOf e of
  Is @Traced `App` _ -> case e of t :- e' -> throwM ((s:t) :- e')
  _                  ->                      throwM ([s  ] :- e )


-- $> putStrLn . displayException $ words "How does this look?" :- ExitFailure 1

-- $> _test `all` [0 .. 3]

_test :: Word -> Bool
_test n = check caught
 where
  check (Left  _) = False
  check (Right b) = b
  caught = traces `catchTraced` \t ->
    pure (t == labels :- ExitFailure 1)
  traces = foldr trace (throwM (ExitFailure 1)) labels
  labels = show <$> [1 .. n]