acme-missiles-0.2.1: Acme/Missiles.hs

-- |
-- Module:          Acme.Missiles
-- License:         Public domain
-- Portability:     non-portable
--
-- The 'launchMissiles' action, as mentioned in:
--
--   * /Beautiful concurrency/, by Simon Peyton Jones, to appear in
--     \"Beautiful code\", ed Greg Wilson, O'Reilly 2007.
--     <http://research.microsoft.com/en-us/um/people/simonpj/papers/stm/index.htm#beautiful>

module Acme.Missiles (
    launchMissiles,

    -- * Launching missiles in the 'STM' monad
    withMissilesDo,
    launchMissilesSTM,
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (bracket)
import Control.Monad (forever)
import System.IO.Unsafe (unsafePerformIO)

-- | Cause serious international side effects.
launchMissiles :: IO ()
launchMissiles = putStrLn "Nuclear launch detected."

-- | Perform initialization needed to launch missiles in the 'STM' monad.
withMissilesDo :: IO a -> IO a
withMissilesDo action =
        bracket (forkIO doLaunching)
                killThread
                (\_ -> action)
    where
        doLaunching = forever $ do
            atomically $ do
                n <- readTVar missileCommand
                if n > 0
                    then writeTVar missileCommand (n - 1)
                    else retry
            launchMissiles

-- | Launch missiles within an 'STM' computation.  Even if the memory
-- transaction is retried, only one salvo of missiles will be launched.
--
-- Example:
--
-- >import Acme.Missiles
-- >import Control.Concurrent
-- >import Control.Concurrent.STM
-- >
-- >main :: IO ()
-- >main = withMissilesDo $ do
-- >    xv <- atomically $ newTVar (2 :: Int)
-- >    yv <- atomically $ newTVar (1 :: Int)
-- >    atomically $ do
-- >        x <- readTVar xv
-- >        y <- readTVar yv
-- >        if x > y
-- >            then launchMissilesSTM
-- >            else return ()
-- >    threadDelay 100000
launchMissilesSTM :: STM ()
launchMissilesSTM = do
    n <- readTVar missileCommand
    writeTVar missileCommand $! n + 1

missileCommand :: TVar Integer
{-# NOINLINE missileCommand #-}
missileCommand = unsafePerformIO (newTVarIO 0)