{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-}

module Pugs.AST.SIO (
    MonadSTM,

    SIO,
    runSTM, runIO,
    liftSTM, liftIO,
) where
import Pugs.Internals

data SIO a = MkSTM !(STM a) | MkIO !(IO a) | MkSIO !a
    deriving (Typeable)

runSTM :: SIO a -> STM a
runSTM (MkSTM stm)  = stm
runSTM (MkIO _)     = fail "Unsafe IO caught in STM"
runSTM (MkSIO x)    = return x

runIO :: SIO a -> IO a
runIO (MkIO io)     = io
runIO (MkSTM stm)   = atomically stm
runIO (MkSIO x)     = return x

instance Monad SIO where
    return a = MkSIO a
    (MkIO io)   >>= k = MkIO $ do { a <- io; runIO (k a) }
    (MkSTM stm) >>= k = MkSTM $ do { a <- stm; runSTM (k a) }
    (MkSIO x)   >>= k = k x

-- | Typeclass of monadic types that an @STM@ monad can be lifted to.
class (Monad m) => MonadSTM m where
    liftSTM :: STM a -> m a

instance MonadSTM STM where
    liftSTM = id

instance MonadSTM IO where
    liftSTM = atomically

instance MonadIO SIO where
    liftIO io = MkIO io

instance MonadSTM SIO where
    liftSTM stm = MkSTM stm
