topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
topHandlerWith cont prog =
    Exception.catches prog [
        Exception.Handler rethrowAsyncExceptions
      , Exception.Handler rethrowExitStatus
      , Exception.Handler handle
      ]
  where
    -- Let async exceptions rise to the top for the default top-handler
    rethrowAsyncExceptions :: Exception.AsyncException -> IO a
    rethrowAsyncExceptions = throwIO

    -- ExitCode gets thrown asynchronously too, and we don't want to print it
    rethrowExitStatus :: ExitCode -> IO a
    rethrowExitStatus = throwIO

    -- Print all other exceptions
    handle :: Exception.SomeException -> IO a
    handle se = do
      hFlush stdout
      pname <- getProgName
      hPutStr stderr (wrapText (message pname se))
      cont se

    message :: String -> Exception.SomeException -> String
    message pname (Exception.SomeException se) =
      case cast se :: Maybe Exception.IOException of
        Just ioe ->
          let file         = case ioeGetFileName ioe of
                               Nothing   -> ""
                               Just path -> path ++ location ++ ": "
              location     = case ioeGetLocation ioe of
                               l@(n:_) | Char.isDigit n -> ':' : l
                               _                        -> ""
              detail       = ioeGetErrorString ioe
          in pname ++ ": " ++ file ++ detail
        Nothing ->
#if __GLASGOW_HASKELL__ < 710
          show se
#else
          Exception.displayException se
#endif
topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
topHandlerWith cont prog =
    Exception.catches prog [
        Exception.Handler rethrowAsyncExceptions
      , Exception.Handler rethrowExitStatus
      , Exception.Handler handle
      ]
  where
    -- Let async exceptions rise to the top for the default top-handler
    rethrowAsyncExceptions :: Exception.AsyncException -> IO a
    rethrowAsyncExceptions = throwIO

    -- ExitCode gets thrown asynchronously too, and we don't want to print it
    rethrowExitStatus :: ExitCode -> IO a
    rethrowExitStatus = throwIO

    -- Print all other exceptions
    handle :: Exception.SomeException -> IO a
    handle se = do
      hFlush stdout
      pname <- getProgName
      hPutStr stderr (wrapText (message pname se))
      cont se

    message :: String -> Exception.SomeException -> String
    message pname (Exception.SomeException se) =
      case cast se :: Maybe Exception.IOException of
        Just ioe ->
          let file         = case ioeGetFileName ioe of
                               Nothing   -> ""
                               Just path -> path ++ location ++ ": "
              location     = case ioeGetLocation ioe of
                               l@(n:_) | Char.isDigit n -> ':' : l
                               _                        -> ""
              detail       = ioeGetErrorString ioe
          in pname ++ ": " ++ file ++ detail
        Nothing ->
#if __GLASGOW_HASKELL__ < 710
          show se
#else
          Exception.displayException se
#endif
topHandlerWith cont prog =
    Exception.catches prog [
        Exception.Handler rethrowAsyncExceptions
      , Exception.Handler rethrowExitStatus
      , Exception.Handler handle
      ]
  where
    -- Let async exceptions rise to the top for the default top-handler
    rethrowAsyncExceptions :: Exception.AsyncException -> IO a
    rethrowAsyncExceptions = throwIO

    -- ExitCode gets thrown asynchronously too, and we don't want to print it
    rethrowExitStatus :: ExitCode -> IO a
    rethrowExitStatus = throwIO

    -- Print all other exceptions
    handle :: Exception.SomeException -> IO a
    handle se = do
      hFlush stdout
      pname <- getProgName
      hPutStr stderr (wrapText (message pname se))
      cont se

    message :: String -> Exception.SomeException -> String
    message pname (Exception.SomeException se) =
      case cast se :: Maybe Exception.IOException of
        Just ioe ->
          let file         = case ioeGetFileName ioe of
                               Nothing   -> ""
                               Just path -> path ++ location ++ ": "
              location     = case ioeGetLocation ioe of
                               l@(n:_) | Char.isDigit n -> ':' : l
                               _                        -> ""
              detail       = ioeGetErrorString ioe
          in pname ++ ": " ++ file ++ detail
        Nothing ->
#if __GLASGOW_HASKELL__ < 710
          show se
#else
          Exception.displayException se
#endif