-- 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 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 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 <- 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) $ pullOutStandard $ runErrorT p) start
       return (x, f t)

runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> 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 = 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)