Proof of concept for interruptible-checked IO

SafeIO.hs

module System.SafeIO where

import "base" Control.Concurrent ( ThreadId )
import "base" Control.Concurrent qualified as Unsafe
import "base" Control.Exception ( AsyncException(..), Exception(..) )
import "base" Control.Exception qualified as Unsafe
import "base" Prelude ( Applicative(..), Functor(..), Monad(..), const, ($), (.) )
import "base" System.IO qualified as Unsafe

data Uninterruptible

data Interruptible

newtype SafeIO i a = SafeIO { unSafeIO :: Unsafe.IO a }

instance Functor (SafeIO i) where
  fmap f = SafeIO . fmap f . unSafeIO

instance Applicative (SafeIO i) where
  pure = SafeIO . pure
  SafeIO f <*> SafeIO x = SafeIO $ f <*> x

instance Monad (SafeIO i) where
  SafeIO x >>= f = SafeIO $ x >>= unSafeIO . f

liftInterruptibleIO :: Unsafe.IO a -> SafeIO Interruptible a
liftInterruptibleIO = SafeIO

liftUninterruptibleIO :: Unsafe.IO a -> SafeIO i a
liftUninterruptibleIO = SafeIO

mask :: ((forall a. SafeIO o a -> SafeIO Uninterruptible a) -> SafeIO Uninterruptible b) -> SafeIO o b
mask unmaskToSafeIO = SafeIO $ Unsafe.mask \unsafeUnmask -> unSafeIO $ unmaskToSafeIO $ SafeIO . unsafeUnmask . unSafeIO

mask_ :: SafeIO Uninterruptible b -> SafeIO o b
mask_ io = mask (const io)

forkIO :: SafeIO i () -> SafeIO i ThreadId
forkIO (SafeIO io) = SafeIO (Unsafe.forkIO io)

forkIOWithUnmask :: ((forall a. SafeIO i a -> SafeIO Uninterruptible a) -> SafeIO Uninterruptible ()) -> SafeIO o ThreadId
forkIOWithUnmask unmaskToSafeIO = SafeIO $ Unsafe.forkIOWithUnmask \unsafeUnmask -> unSafeIO $ unmaskToSafeIO $ SafeIO . unsafeUnmask . unSafeIO

myThreadId :: SafeIO i ThreadId
myThreadId = SafeIO Unsafe.myThreadId

killThread :: ThreadId -> SafeIO Interruptible ()
killThread tId = throwTo tId ThreadKilled

throwTo :: Exception e => ThreadId -> e -> SafeIO Interruptible ()
throwTo tId e = SafeIO $ Unsafe.throwTo tId e

test :: SafeIO Interruptible ()
test = do
  someThreadId <- forkIO $ pure ()
  otherThreadId <- mask \unmask -> forkIO do
    killThread someThreadId
  tid2 <- mask_ $ mask \restore -> forkIOWithUnmask \unmask -> do
    unmask $ killThread someThreadId
  pure ()