-- 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.Concurrent.STM
import qualified Control.Exception 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 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)

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

data CHP' a = AltableT {
  -- The guard, and body to execute after the guard
  getAltable :: (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".
class Show t => 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)
  -- | The empty trace.
  emptyTrace :: t
  -- | Pretty-prints the given trace using the "Text.PrettyPrint.HughesPJ"
  -- module.
  prettyPrint :: t -> Text.PrettyPrint.HughesPJ.Doc

-- | A class indicating that something is poisonable.
class Poisonable c where
  -- | Poisons the given item.
  poison :: MonadCHP m => c -> m ()

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

liftTrace :: TraceT IO a -> CHP' a
liftTrace m = AltableT (badGuard, m) 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) `onPoison` (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) <- get
                  case x of
                    Trace (pid,_,_) -> return pid
                    NoTrace -> return emptyProcessId

runCHPProgramWith :: TraceStore -> (TraceStore -> t) -> CHP a -> IO (Maybe a, t)
runCHPProgramWith start f (PoisonT p)
  = do (x, (_, t)) <- runStateT (liftM (either (const Nothing) Just) $ getStandard $ runErrorT p) ([], start)
       return (x, f t)

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

-- ==========
-- 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 = 
              let ~(grd, altBody) = getAltable m
                  nonAlt = getStandard m
                  altBody' = altBody >>= getStandard . f
                  nonAlt' = nonAlt >>= getStandard . f
              in AltableT (grd, altBody') nonAlt'
  return x = AltableT (badGuard, return x) (return x)

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