Base.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.



-- | A module containing various definitions relating to the CSP\/CSPPoison
-- monads, and poison.  Not publicly visible.
module Control.Concurrent.CHP.Base where

import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM
import qualified Control.Exception.Extensible as C
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Trans
import qualified Data.Map as Map
import Data.Unique
import System.IO
import qualified Text.PrettyPrint.HughesPJ

import Control.Concurrent.CHP.Guard
import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId
import Control.Concurrent.CHP.Traces.Base

-- ======
-- Types:
-- ======

-- | An internal dummy type for poison errors
newtype PoisonError = PoisonError ()

-- | An enrolled wrapper for barriers that shows at the type-level whether
-- you are enrolled on a barrier.  Enrolled Barriers should never be passed
-- to two (or more) processes running in parallel; if two processes synchronise
-- based on a single enroll call, undefined behaviour will result.
newtype Enrolled b a = Enrolled (b a) deriving (Eq)

-- | The central monad of the library.  You can use
-- 'Control.Concurrent.CHP.Monad.runCHP' and
-- 'Control.Concurrent.CHP.Monad.runCHP_' to execute programs in this
-- monad.
newtype CHP a = PoisonT (ErrorT PoisonError CHP' a)
  deriving (Functor, Monad, MonadIO)

instance Applicative CHP where
  pure = return
  (<*>) = ap

data CHP' a = AltableTRet a | AltableT {
  -- The guard, and body to execute after the guard
  getAltable :: Either String [(Guard, TraceT IO a)],
  -- The body to execute without a guard
  getStandard :: TraceT IO a }

-- ========
-- Classes:
-- ========

-- | A monad transformer class that is very similar to 'MonadIO'.  This can be
-- useful if you want to add monad transformers (such as 'StateT', 'ReaderT') on
-- top of the 'CHP' monad.
class MonadIO m => MonadCHP m where
  liftCHP :: CHP a -> m a

-- | A class representing a type of trace.  The main useful function is 'runCHPAndTrace',
-- but because its type is only determined by its return type, you may wish
-- to use the already-typed functions offered in each trace module -- see the
-- modules in "Control.Concurrent.CHP.Traces".
--
-- The trace type involved became parameterised in version 1.3.0.
class Trace t where
  -- | Runs the given CHP program, and returns its return value and the trace.
  --  The return value is a Maybe type because the process may have exited
  -- due to uncaught poison.  In that case Nothing is return as the result.
  runCHPAndTrace :: CHP a -> IO (Maybe a, t Unique)
  -- | The empty trace.
  emptyTrace :: t u
  -- | Pretty-prints the given trace using the "Text.PrettyPrint.HughesPJ"
  -- module.
  prettyPrint :: Ord u => t u -> Text.PrettyPrint.HughesPJ.Doc

  -- | Added in version 1.3.0.
  labelAll :: Ord u => t u -> t String

-- | A class indicating that something is poisonable.
class Poisonable c where
  -- | Poisons the given item.
  poison :: MonadCHP m => c -> m ()
  -- | Checks if the given item is poisoned.  If it is, a poison exception
  -- will be thrown.
  --
  -- Added in version 1.0.2.
  checkForPoison :: MonadCHP m => c -> m ()

-- ==========
-- Functions: 
-- ==========

pullOutStandard :: CHP' a -> TraceT IO a
pullOutStandard m = case m of
  AltableTRet x -> return x
  AltableT _ st -> st

pullOutAltable :: CHP' a -> Either String [(Guard, TraceT IO a)]
pullOutAltable m = case m of
  AltableTRet _ -> badGuard "return"
  AltableT alt _ -> alt

liftTrace :: TraceT IO a -> CHP' a
liftTrace m = AltableT (badGuard "lifted action") m

wrapPoison :: CHP a -> CHP' (WithPoison a)
wrapPoison (PoisonT m) = (liftM $ either (const PoisonItem) NoPoison) $
  runErrorT m

unwrapPoison :: CHP' (WithPoison a) -> CHP a
unwrapPoison m = PoisonT (lift m) >>= checkPoison

-- | Checks for poison, and either returns the value, or throws a poison exception
checkPoison :: WithPoison a -> CHP a
checkPoison (NoPoison x) = return x
checkPoison PoisonItem = PoisonT $ throwError $ PoisonError ()

liftPoison :: CHP' a -> CHP a
liftPoison = PoisonT . lift

-- | Throws a poison exception.
throwPoison :: CHP a
throwPoison = checkPoison PoisonItem

-- | Allows you to provide a handler for sections with poison.  It is usually
-- used in an infix form as follows:
--
-- > (readChannel c >>= writeChannel d) `onPoisonTrap` (poison c >> poison d)
--
-- It handles the poison and does not rethrow it (unless your handler
-- does so).  If you want to rethrow (and actually, you'll find you usually
-- do), use 'onPoisonRethrow'
onPoisonTrap :: CHP a -> CHP a -> CHP a
onPoisonTrap (PoisonT body) (PoisonT handler) = PoisonT $ body `catchError` (const handler)

-- | Like 'onPoisonTrap', this function allows you to provide a handler
--  for poison.  The difference with this function is that even if the
--  poison handler does not throw, the poison exception will always be
--  re-thrown after the handler anyway.  That is, the following lines of
--  code all have identical behaviour:
--
-- > foo
-- > foo `onPoisonRethrow` throwPoison
-- > foo `onPoisonRethrow` return ()
onPoisonRethrow :: CHP a -> CHP () -> CHP a
onPoisonRethrow (PoisonT body) (PoisonT handler) = PoisonT $
  body `catchError` (\err -> handler >> throwError err)

-- | Poisons all the given items.  A handy shortcut for @mapM_ poison@.
poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m ()
poisonAll ps = mapM_ poison ps


liftSTM :: MonadIO m => STM a -> m a
liftSTM = liftIO . atomically

getProcessId :: TraceT IO ProcessId
getProcessId = do x <- ask
                  case x of
                    Trace (pid,_,_) -> return pid
                    NoTrace pid -> return pid

wrapProcess :: CHP a -> (CHP' (Either PoisonError a) -> IO (Either PoisonError a)) -> IO (Maybe (Either () a))
wrapProcess (PoisonT proc) unwrapInner
  = do let inner = runErrorT proc
       x <- liftM Just (unwrapInner inner) `C.catches` allHandlers
       case x of
         Nothing -> return Nothing
         Just (Left _) -> return $ Just $ Left ()
         Just (Right y) -> return $ Just $ Right y
  where
    response :: C.Exception e => e -> IO (Maybe a)
    response x = liftIO (hPutStrLn stderr $ "(CHP) Thread terminated with: " ++ show x)
                   >> return Nothing

    allHandlers = [C.Handler (response :: C.IOException -> IO (Maybe a))
                  ,C.Handler (response :: C.AsyncException -> IO (Maybe a))
                  ,C.Handler (response :: C.NonTermination -> IO (Maybe a))
#if __GLASGOW_HASKELL__ >= 611
                  ,C.Handler (response :: C.BlockedIndefinitelyOnSTM -> IO (Maybe a))
#else
                  ,C.Handler (response :: C.BlockedIndefinitely -> IO (Maybe a))
#endif
                  ,C.Handler (response :: C.Deadlock -> IO (Maybe a))
                  ]

runCHPProgramWith :: TraceStore -> CHP a -> IO (Maybe a)
runCHPProgramWith start p
  = do r <- wrapProcess p run
       case r of
         Nothing -> return Nothing
         Just (Left _) -> return Nothing
         Just (Right x) -> return (Just x)
  where
    run :: CHP' (Either PoisonError a) -> IO (Either PoisonError a)
    run = flip runReaderT start . pullOutStandard
    --run m = runStateT ({-liftM (either (const Nothing) Just) $ -} pullOutStandard m) start

runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> IO t) -> CHP a -> IO (Maybe a, t)
runCHPProgramWith' subStart f p
  = do tv <- atomically $ newTVar Map.empty
       x <- runCHPProgramWith (Trace (rootProcessId, tv, subStart)) p
--                             `C.catch` const (return (Nothing,
--                               Trace (undefined, undefined, subStart)))
       l <- atomically $ readTVar tv
       t' <- f l
       return (x, t')

newtype ManyToOneTVar a = ManyToOneTVar (TVar a, TVar (Maybe a))
  deriving Eq

newManyToOneTVar :: a -> STM (ManyToOneTVar a)
newManyToOneTVar x
  = do tvInter <- newTVar x
       tvFinal <- newTVar Nothing
       return $ ManyToOneTVar (tvInter, tvFinal)

writeManyToOneTVar :: (a -> Bool, STM a) -> (a -> a) -> ManyToOneTVar a -> STM a
writeManyToOneTVar (done, reset) f (ManyToOneTVar (tvInter, tvFinal))
  = do x <- readTVar tvInter
       if done (f x)
         then do writeTVar tvFinal $ Just $ f x
                 reset >>= writeTVar tvInter
         else writeTVar tvInter $ f x
       return $ f x

readManyToOneTVar :: ManyToOneTVar a -> STM a
readManyToOneTVar (ManyToOneTVar (_tvInter, tvFinal))
  = do x <- readTVar tvFinal >>= maybe retry return
       writeTVar tvFinal Nothing
       return x

resetManyToOneTVar :: ManyToOneTVar a -> a -> STM ()
resetManyToOneTVar (ManyToOneTVar (tvInter, tvFinal)) x
  = writeTVar tvInter x >> writeTVar tvFinal Nothing

-- ==========
-- Instances: 
-- ==========

instance Error PoisonError where
  noMsg = PoisonError ()

instance (Error e, MonadCHP m) => MonadCHP (ErrorT e m) where
  liftCHP = lift . liftCHP

instance MonadCHP m => MonadCHP (ReaderT r m) where
  liftCHP = lift . liftCHP

instance MonadCHP m => MonadCHP (StateT s m) where
  liftCHP = lift . liftCHP

instance (Monoid w, MonadCHP m) => MonadCHP (WriterT w m) where
  liftCHP = lift . liftCHP

instance MonadCHP CHP where
  liftCHP = id

-- The monad is lazy, and very similar to the writer monad
instance Monad CHP' where
  -- m :: AltableT g m a
  -- f :: a -> AltableT g m b
  m >>= f = case m of
             AltableTRet x -> f x
             AltableT altBody nonAlt ->
              let altBody' = liftM (map $ second (>>= pullOutStandard . f)) altBody
                  nonAlt' = nonAlt >>= pullOutStandard . f
              in AltableT altBody' nonAlt'
  return x = AltableTRet x

instance MonadIO CHP' where
  liftIO m = liftTrace (liftIO m)