ExceptST.hs

-- this is so wrong.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash, UnboxedTuples #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ExceptST (
    ExceptST, runExceptST, liftST, throwExceptST,
    -- * examples
    allNonNegative,
    ) where

import Control.Exception (Exception, toException, fromException, throwIO, catch)
import Control.Monad.ST (ST, stToIO)
import GHC.Exts (Any)
import System.IO.Unsafe (unsafePerformIO)
import Unsafe.Coerce (unsafeCoerce)

import Control.Monad (forM)

-------------------------------------------------------------------------------
-- Example
-------------------------------------------------------------------------------

{-|

>>> allNonNegative [0..10]
Right [0,1,2,3,4,5,6,7,8,9,10]

>>> allNonNegative $ [0..10] ++ [-1] ++ [0..10]
Left (-1)

@ghc -O -fforce-recomp -ddump-simpl -dsuppress-all ExceptST.hs@ gives us
scary code, which doesn't match on `Left` all the time.
It matches on tuple to get @RealWorld@ token, but that won't exist
at runtime.

@
-- RHS size: {terms: 21, types: 36, coercions: 17, joins: 0/0}
allNonNegative1
allNonNegative1
  = \ @ a_a2VC @ e_a2VB e1_a3Kx eta_B1 ->
      case e1_a3Kx of wild_a3mo
      { SomeException @ e2_a3mv $dException1_a3mw e3_a3mx ->
      case sameTypeRep
             (($p1Exception $dException1_a3mw) `cast` <Co:4>)
             $fExceptionExceptSTException3
      of {
        False -> raiseIO# wild_a3mo eta_B1;
        True -> (# eta_B1, Left (e3_a3mx `cast` <Co:13>) #)
      }
      }

Rec {
-- RHS size: {terms: 33, types: 53, coercions: 9, joins: 0/0}
allNonNegative2
allNonNegative2
  = \ ds_a3F7 eta_B1 ->
      case ds_a3F7 of {
        [] -> (# eta_B1, [] #);
        : y_a3Fc ys_a3Fd ->
          case y_a3Fc of wild1_a44l { I# x_a44n ->
          case >=# x_a44n 0# of {
            __DEFAULT ->
              case raiseIO#
                     ($fExceptionExceptSTException_$ctoException
                        (wild1_a44l `cast` <Co:9>))
                     eta_B1
              of wild2_00 {
              };
            1# ->
              case allNonNegative2 ys_a3Fd eta_B1 of
              { (# ipv2_a3Hq, ipv3_a3Hr #) ->
              (# ipv2_a3Hq, : wild1_a44l ipv3_a3Hr #)
              }
          }
          }
      }
end Rec }

-- RHS size: {terms: 23, types: 82, coercions: 0, joins: 0/0}
allNonNegative
allNonNegative
  = \ xs_a1rQ ->
      case runRW#
             (\ s_a3lC ->
                case noDuplicate# s_a3lC of s'_a3lD { __DEFAULT ->
                catch#
                  (\ s1_a3I9 ->
                     case allNonNegative2 xs_a1rQ s1_a3I9 of
                     { (# ipv_a3Ic, ipv1_a3Id #) ->
                     (# ipv_a3Ic, Right ipv1_a3Id #)
                     })
                  allNonNegative1
                  s'_a3lD
                })
      of
      { (# ipv_a3lG, ipv1_a3lH #) ->
      ipv1_a3lH
      }
@
-}
allNonNegative :: [Int] -> Either Int [Int]
allNonNegative xs = runExceptST $ forM xs $ \x ->
    if x >= 0
    then return x
    else throwExceptST x

-------------------------------------------------------------------------------
-- Guts
-------------------------------------------------------------------------------

newtype ExceptST s e a = ExceptST (IO a)
  deriving newtype (Functor, Applicative, Monad)

liftST :: ST s a -> ExceptST s e a
liftST = ExceptST . stToIO . unsafeCoerce

runExceptST :: forall e a. (forall s. ExceptST s e a) -> Either e a
runExceptST (ExceptST action) = unsafePerformIO $
    fmap Right action `catch` \(ExceptSTException e) ->
    return (Left (unsafeCoerce e))

throwExceptST :: e -> ExceptST s e a
throwExceptST e = ExceptST $ throwIO $ ExceptSTException (unsafeCoerce e)

-- exercise: add catchExceptST

newtype ExceptSTException = ExceptSTException Any

instance Show ExceptSTException where
    showsPrec _ _ = showString "<ExceptSTException>"

instance Exception ExceptSTException