Monad.hs

-- Communicating Haskell Processes.
-- Copyright (c) 2008, University of Kent.
-- All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--  * Neither the name of the University of Kent nor the names of its
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-- | This module contains all the central monads in the CHP library.
module Control.Concurrent.CHP.Monad
  (
   -- * CHP Monad
  CHP, MonadCHP(..), runCHP, runCHP_,

  onPoisonTrap, onPoisonRethrow, throwPoison, Poisonable(..), poisonAll,

  -- * LoopWhileT Monad
  LoopWhileT, loop, while,

  -- * Primitive actions
  skip, stop, waitFor
   ) where

import Control.Concurrent
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Trans

-- This module primarily re-exports the public definitions from
-- Control.Concurrent.CHP.{Base,CSP,Poison}:

import Control.Concurrent.CHP.Base
import Control.Concurrent.CHP.Guard
import Control.Concurrent.CHP.Traces.TraceOff

-- | Runs a CHP program.  You should use this once, at the top-level of your
-- program.  Do not ever use this function twice in parallel and attempt to
-- communicate between those processes using channels.  Instead, run this function
-- once and use it to spawn off the parallel processes that you need.
runCHP :: CHP a -> IO (Maybe a)
runCHP = liftM fst . (runCHPAndTrace :: CHP a -> IO (Maybe a, TraceOff))

-- | Runs a CHP program.  Like 'runCHP' but discards the output.
runCHP_ :: CHP a -> IO ()
runCHP_ p = runCHP p >> return ()

-- | A monad transformer for easier looping.  This is independent of the
-- CHP aspects, but has all the right type-classes defined for it to make
-- it easy to use with the CHP library.
newtype Monad m => LoopWhileT m a = LWT { getLoop :: m (Maybe a) }

instance Monad m => Monad (LoopWhileT m) where
  -- m :: RW (Maybe (m a))
  -- f :: a -> RW (Maybe (m b)) 
  m >>= f = LWT $ do x <- getLoop m
                     case x of
                       Nothing -> return Nothing
                       Just m' -> getLoop $ f m'
  return x = LWT $ return $ Just x

instance MonadTrans LoopWhileT where
  lift m = LWT $ m >>= return . Just

instance MonadIO m => MonadIO (LoopWhileT m) where
  liftIO = lift . liftIO

instance MonadCHP m => MonadCHP (LoopWhileT m) where
  liftCHP = lift . liftCHP

instance MonadError e m => MonadError e (LoopWhileT m) where
  throwError e = lift $ throwError e
  catchError m h = LWT $ catchError (getLoop m) (getLoop . h)

--TODO instances for all the other monad transformers

-- | Runs the given action in a loop, executing it repeatedly until a 'while'
-- statement inside it has a False condition.  If you use 'loop' without 'while',
-- the effect is the same as 'forever'.
loop :: Monad m => LoopWhileT m a -> m ()
loop l = do x <- getLoop l
            case x of
              Nothing -> return ()
              Just _ -> loop l

-- | Continues executing the loop if the given value is True.  If the value
-- is False, the loop is broken immediately, and control jumps back to the
-- next action after the outer 'loop' statement.  Thus you can build pre-condition,
-- post-condition, and "mid-condition" loops, placing the condition wherever
-- you like.
while :: Monad m => Bool -> LoopWhileT m ()
while b = LWT $ if b then (return $ Just ()) else return Nothing


-- | Waits for the specified number of microseconds (millionths of a second).
-- There is no guaranteed precision, but the wait will never complete in less
-- time than the parameter given.
-- 
-- Suitable for use in an 'alt', but note that waitFor 0 is not the same
-- as skip.  'waitFor' 0 '</>' x will not always select the first guard,
-- depending on x.  Included in this is the lack of guarantee that
-- 'waitFor' 0 '</>' 'waitFor' n will select the first guard for any value
-- of n (including 0).  It is not useful to use two waitFor guards in a
-- single 'alt' anyway.
--
-- /NOTE:/ If you wish to use this as part of a choice, you must use @-threaded@
-- as a GHC compilation option (at least under 6.8.2).
waitFor :: Int -> CHP ()
waitFor n = liftPoison $ AltableT (guardWaitFor n, return ()) (liftIO $ threadDelay n)
-- TODO maybe fix the above lack of guarantees by keeping timeout guards explicit.

-- TODO add waitUntil

-- | The classic skip process\/guard.  Does nothing, and is always ready.
--
-- Suitable for use in an 'alt'.
skip :: CHP ()
skip = liftPoison $ AltableT (skipGuard, return ()) (return ())

-- | The stop guard.  Its main use is that it is never ready in a choice, so
-- can be used to mask out guards.  If you actually execute stop, that process
-- will do nothing more.  Any parent process waiting for it to complete will
-- wait forever.
stop :: CHP ()
stop = liftPoison $ AltableT (stopGuard, liftIO hang) (liftIO hang)
  where
    -- Strangely, I can't work out a good way to actually implement stop.
    -- If you wait on a variable that will never be ready, GHC will wake
    -- you up with an exception.  If you loop doing that, you'll burn the
    -- CPU.  Throwing an exception would be caught and terminate the
    -- process, which is not the desired behaviour.  The only thing I can think
    -- to do is to repeatedly wait for a very long time.
    hang :: IO ()
    hang = forever $ threadDelay maxBound