module Unison.Runtime.Exception
  ( RuntimeExn (BU, PE),
    die,
    exn,
  )
where

import Control.Exception (throw, throwIO)
import GHC.Stack (CallStack, callStack)
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Runtime.Stack (Val)
import Unison.Util.Pretty as P

data RuntimeExn
  = -- | pretty exception
    PE CallStack [Word] (P.Pretty P.ColorText)
  | -- | a failure in Unison code
    BU
      -- | Unison stack
      [(Reference, Int)]
      -- | message
      Text
      -- | Unison value
      Val
  deriving (Int -> RuntimeExn -> ShowS
[RuntimeExn] -> ShowS
RuntimeExn -> String
(Int -> RuntimeExn -> ShowS)
-> (RuntimeExn -> String)
-> ([RuntimeExn] -> ShowS)
-> Show RuntimeExn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RuntimeExn -> ShowS
showsPrec :: Int -> RuntimeExn -> ShowS
$cshow :: RuntimeExn -> String
show :: RuntimeExn -> String
$cshowList :: [RuntimeExn] -> ShowS
showList :: [RuntimeExn] -> ShowS
Show)

instance Exception RuntimeExn

peStr :: (HasCallStack) => [Word] -> String -> RuntimeExn
peStr :: HasCallStack => [Word] -> String -> RuntimeExn
peStr [Word]
issues = CallStack -> [Word] -> Pretty ColorText -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack [Word]
issues (Pretty ColorText -> RuntimeExn)
-> (String -> Pretty ColorText) -> String -> RuntimeExn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
P.lit (ColorText -> Pretty ColorText)
-> (String -> ColorText) -> String -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ColorText
forall a. IsString a => String -> a
fromString
{-# INLINE peStr #-}

die :: (HasCallStack) => [Word] -> String -> IO a
die :: forall a. HasCallStack => [Word] -> String -> IO a
die [Word]
issues String
s = do
  IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> (RuntimeExn -> IO Any) -> RuntimeExn -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeExn -> IO Any
forall e a. Exception e => e -> IO a
throwIO (RuntimeExn -> IO ()) -> RuntimeExn -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Word] -> String -> RuntimeExn
[Word] -> String -> RuntimeExn
peStr [Word]
issues String
s
  -- This is unreachable, but we need it to fix some quirks in GHC's
  -- worker/wrapper optimization, specifically, it seems that when throwIO's polymorphic return
  -- value is specialized to a type like 'Stack' which we want GHC to unbox, it will sometimes
  -- fail to unbox it, possibly because it can't unbox it when it's strictly a type application.
  -- For whatever reason, this seems to fix it while still allowing us to throw exceptions in IO
  -- like we prefer.
  String -> IO a
forall a. HasCallStack => String -> a
error String
"unreachable"
{-# INLINE die #-}

exn :: (HasCallStack) => [Word] -> String -> a
exn :: forall a. HasCallStack => [Word] -> String -> a
exn [Word]
issues = RuntimeExn -> a
forall a e. Exception e => e -> a
throw (RuntimeExn -> a) -> (String -> RuntimeExn) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => [Word] -> String -> RuntimeExn
[Word] -> String -> RuntimeExn
peStr [Word]
issues
{-# INLINE exn #-}