CallStack.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

-- | Adds support to work with exceptions that pack a rendered call stack.
module Util.Control.Exception.CallStack (
  throwIO, throwSTM,
) where

import Control.Concurrent.STM (STM)
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as E
import Data.Text (Text, pack)
import GHC.Stack (
  HasCallStack,
  callStack,
  currentCallStack,
  prettyCallStack,
  renderStack,
  withFrozenCallStack,
 )

type CallStack = Text

throwIO :: (E.Exception e, HasCallStack) => (CallStack -> e) -> IO a
throwIO mkException = withFrozenCallStack $ do
  ccs <- currentCallStack
  let stack
        | null ccs = prettyCallStack callStack
        | otherwise = renderStack ccs
  E.throw $ mkException $ pack stack

throwSTM :: (E.Exception e, HasCallStack) => (CallStack -> e) -> STM a
throwSTM mkException = withFrozenCallStack $ do
  let stack = prettyCallStack callStack
  STM.throwSTM $ mkException $ pack stack