STM.hs

{-# LANGUAGE FlexibleInstances, MagicHash, UnboxedTuples #-}
module Acme.TimeMachine.STM
    (
        Entanglement,
        AtomicTimeMachine,
        doSTM,
        atomicallyTM,
        runATM,
        runATMIO
    )
    where

import Control.Monad.IO.Class (MonadIO(..))
import GHC.Conc (STM(..), atomically)
import GHC.Prim (State#, RealWorld)
import Acme.TimeMachine
import Acme.TimeMachine.Suspension
import Acme.TimeMachine.Undoable

-- | State of the STM.
data Entanglement = Entanglement# (State# RealWorld)

-- | Undo-able atomic software transaction monad.
-- Lets you perform and unperform side-effectful atomic transactions.
type AtomicTimeMachine = Undoable Entanglement

-- | Run an STM action.
doSTM :: STM a -> AtomicTimeMachine a
doSTM (STM m) = Undoable $ \l@(~(Suspension u _)) -> let (v, r) = case m (case u of Entanglement# e# -> e#) of (# e#, r #) -> (Entanglement# e#, r) in (Suspension v l, r)

-- | Embed an undo-able transaction in an undo-able computation.
atomicallyTM :: AtomicTimeMachine a -> TimeMachine a
atomicallyTM = liftIO . runATMIO

-- | Execute an undo-able transaction.
runATM :: AtomicTimeMachine a -> STM a
runATM (Undoable f) = STM $ \i# -> case f (mkSuspension $ Entanglement# i#) of ~(Suspension s _, r) -> case s of Entanglement# i# -> (# i#, r #)

-- | Execute an undo-able transaction within the IO monad.
runATMIO :: AtomicTimeMachine a -> IO a
runATMIO = atomically . runATM