-- |
-- Module:      Acme.RealWorld
-- Copyright:   (c) Joseph Adams 2011
-- Maintainer:  joeyadams3.14159@gmail.com
-- Portability: GHC-only
--
-- Primitives for manipulating the state of the universe.

{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Acme.RealWorld (
    -- * The RealWorld type
    RealWorld,

    -- * Universe manipulation primitives
    getWorld,
    putWorld,
    execIO,

    -- * Derived combinators
    hypothetically,
) where

import Control.Exception (bracket)
import GHC.IO
import GHC.Exts

fromState :: State# RealWorld -> RealWorld
fromState = unsafeCoerce#

toState :: RealWorld -> State# RealWorld
toState = unsafeCoerce#

-- | Retrieve the current state of the universe.
getWorld :: IO RealWorld
getWorld = IO (\s -> (# s, fromState s #))

-- | Set the current state of the universe.  Program values are not affected by
-- this operation, but the rest of the universe is.
--
-- 'putWorld' may not be called on the same state twice (this is enforced by
-- the runtime system).  Otherwise, it would be possible to trap the universe
-- in a temporal loop:
--
-- >getWorld >>= forever . putWorld
putWorld :: RealWorld -> IO ()
putWorld s' = IO (\_ -> (# toState s', () #))

-- | Given an action, construct a function that, given a state of the universe,
-- returns the state of the universe after the action has occurred.
--
-- Example:
--
-- >main = do
-- >    let f = execIO $ putStrLn "Second"
-- >        g = execIO $ putStrLn "First"
-- >        getWorld >>= putWorld . f . g
execIO :: IO a -> RealWorld -> RealWorld
execIO (IO k) = \w -> case k (toState w) of (# s', _ #) -> fromState s'

-- | Perform an action and return its value, but undo any side effects to the
-- universe.  Thus, it appears to return instantly, regardless of how long the
-- action would take to run.
--
-- The caller must ensure that the program /would/ have enough time to perform
-- the computation.  Otherwise, either an exception will be thrown, or the
-- operation will block because it never gets a chance to restore the original
-- state of the universe.
hypothetically :: IO a -> IO a
hypothetically action = bracket getWorld putWorld (\_ -> action)