-- 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.LoopWhile
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Trans
import Data.Function (on)
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 = AltableT (badGuard "lifted action")

wrapPoison :: CHP a -> CHP' (WithPoison a)
wrapPoison (PoisonT m) = 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 = mapM_ poison


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')

data ManyToOneTVar a = ManyToOneTVar
  { mtoIsFinalValue :: a -> Bool
  , mtoReset :: STM a
  , mtoInter :: TVar a
  , mtoFinal :: TVar (Maybe a)
  }

instance Eq (ManyToOneTVar a) where
  (==) = (==) `on` mtoFinal

newManyToOneTVar :: (a -> Bool) -> STM a -> a -> STM (ManyToOneTVar a)
newManyToOneTVar f r x
  = do tvInter <- newTVar x
       tvFinal <- newTVar $ if f x then Just x else Nothing
       return $ ManyToOneTVar f r tvInter tvFinal

writeManyToOneTVar :: (a -> a) -> ManyToOneTVar a -> STM a
writeManyToOneTVar f (ManyToOneTVar done reset 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 _done _reset _tvInter tvFinal)
  = do x <- readTVar tvFinal >>= maybe retry return
       writeTVar tvFinal Nothing
       return x

-- If the value is final, it is stored as final!
resetManyToOneTVar :: ManyToOneTVar a -> a -> STM ()
resetManyToOneTVar (ManyToOneTVar done reset tvInter tvFinal) x
  | done x = (reset >>= writeTVar tvInter) >> writeTVar tvFinal (Just x)
  | otherwise = 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

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

-- 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 = AltableTRet

instance Functor CHP' where
  fmap = liftM

instance MonadIO CHP' where
  liftIO = liftTrace . liftIO