diff --git a/Control/Concurrent/CHP.hs b/Control/Concurrent/CHP.hs --- a/Control/Concurrent/CHP.hs +++ b/Control/Concurrent/CHP.hs @@ -27,38 +27,21 @@ -- 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 re-exports the core functionality of the CHP library. Other --- modules that you also may wish to import are: --- --- * "Control.Concurrent.CHP.Actions" --- --- * "Control.Concurrent.CHP.Arrow" --- --- * "Control.Concurrent.CHP.Behaviours" --- --- * "Control.Concurrent.CHP.Buffers" --- --- * "Control.Concurrent.CHP.Common" --- --- * "Control.Concurrent.CHP.Connect" --- --- * "Control.Concurrent.CHP.Console" --- --- * "Control.Concurrent.CHP.Test" --- --- * "Control.Concurrent.CHP.Traces" --- --- * "Control.Concurrent.CHP.Utils" +-- | This module re-exports all of the functionality of the CHP library, except +-- the traces mechanism available in the "Control.Concurrent.CHP.Traces" module. -- -- For an overview of the library, take a look at the CHP tutorial: -- available from -- the main CHP website: , or take -- a look at the CHP blog: . +-- +-- You should also look at the chp-plus package, which contains a lot of useful +-- further functionality built on top of CHP. module Control.Concurrent.CHP ( module Control.Concurrent.CHP.Alt, module Control.Concurrent.CHP.Barriers, - module Control.Concurrent.CHP.BroadcastChannels, module Control.Concurrent.CHP.Channels, + module Control.Concurrent.CHP.Channels.BroadcastReduce, module Control.Concurrent.CHP.Clocks, module Control.Concurrent.CHP.Enroll, module Control.Concurrent.CHP.Monad, @@ -67,8 +50,8 @@ import Control.Concurrent.CHP.Alt import Control.Concurrent.CHP.Barriers -import Control.Concurrent.CHP.BroadcastChannels import Control.Concurrent.CHP.Channels +import Control.Concurrent.CHP.Channels.BroadcastReduce import Control.Concurrent.CHP.Clocks import Control.Concurrent.CHP.Enroll import Control.Concurrent.CHP.Monad diff --git a/Control/Concurrent/CHP/Actions.hs b/Control/Concurrent/CHP/Actions.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Actions.hs +++ /dev/null @@ -1,122 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2009, 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 action wrappers around channel-ends. --- --- In CHP, there are a variety of channel-ends. Enrolled Chanin, Shared Chanout, --- plain Chanin, and so on. The difference between these ends can be important; --- enrolled channel-ends can be resigned from, shared channel-ends need to be claimed --- before use. But sometimes you just want to ignore those differences and read --- and write from the channel-end regardless of its type. In particular, you want --- to pass a channel-end to a process without the process worrying about its type. --- --- Actions allow you to do this. A send action is like a monadic function (@a --- -> CHP()@ for sending an item, but can be poisoned too. A recv action is like --- something of type @CHP a@ that again can be poisoned. -module Control.Concurrent.CHP.Actions - ( SendAction, RecvAction, - sendAction, recvAction, - makeSendAction, makeRecvAction, - makeSendAction', makeRecvAction', - makeCustomSendAction, makeCustomRecvAction, - nullSendAction, nullRecvAction - ) where - -import Control.Concurrent.CHP -import Control.Monad - --- | A send action. See 'sendAction'. Note that it is poisonable. -newtype SendAction a = SendAction (a -> CHP (), CHP (), CHP ()) --- | A receive action. See 'recvAction'. Note that it is poisonable. -newtype RecvAction a = RecvAction (CHP a, CHP (), CHP ()) - --- | Sends a data item using the given sendAction. Whether this operation can --- be used in a choice (see 'alt') is entirely dependent on whether the original --- action could be used in an alt. For all of CHP's channels, this is true, but --- for your own custom send actions, probably not. -sendAction :: SendAction a -> a -> CHP () -sendAction (SendAction (s, _, _)) = s - --- | Receives a data item using the given recvAction. Whether this operation can --- be used in a choice (see 'alt') is entirely dependent on whether the original --- action could be used in an alt. For all of CHP's channels, this is true, but --- for your own custom receive actions, probably not. -recvAction :: RecvAction a -> CHP a -recvAction (RecvAction (s, _, _)) = s - -instance Poisonable (SendAction c) where - poison (SendAction (_,p,_)) = liftCHP p - checkForPoison (SendAction (_,_,c)) = liftCHP c - -instance Poisonable (RecvAction c) where - poison (RecvAction (_,p,_)) = liftCHP p - checkForPoison (RecvAction (_,_,c)) = liftCHP c - --- | Given a writing channel end, gives back the corresponding 'SendAction'. -makeSendAction :: (WriteableChannel w, Poisonable (w a)) => w a -> SendAction a -makeSendAction c = SendAction (writeChannel c, poison c, checkForPoison c) - --- | Like 'makeSendAction', but always applies the given function before sending --- the item. -makeSendAction' :: (WriteableChannel w, Poisonable (w b)) => - w b -> (a -> b) -> SendAction a -makeSendAction' c f = SendAction (writeChannel c . f, poison c, checkForPoison c) - --- | Given a reading channel end, gives back the corresponding 'RecvAction'. -makeRecvAction :: (ReadableChannel r, Poisonable (r a)) => r a -> RecvAction a -makeRecvAction c = RecvAction (readChannel c, poison c, checkForPoison c) - --- | Like 'makeRecvAction', but always applies the given function after receiving --- an item. -makeRecvAction' :: (ReadableChannel r, Poisonable (r a)) => - r a -> (a -> b) -> RecvAction b -makeRecvAction' c f = RecvAction (liftM f $ readChannel c, poison c, checkForPoison c) - --- | Creates a custom send operation. The first parameter should perform the send, --- the second parameter should poison your communication channel, and the third --- parameter should check whether the communication channel is already poisoned. --- Generally, you will want to use 'makeSendAction' instead of this function. -makeCustomSendAction :: (a -> CHP ()) -> CHP () -> CHP () -> SendAction a -makeCustomSendAction x y z = SendAction (x, y, z) - --- | Creates a custom receive operation. The first parameter should perform the receive, --- the second parameter should poison your communication channel, and the third --- parameter should check whether the communication channel is already poisoned. --- Generally, you will want to use 'makeRecvAction' instead of this function. -makeCustomRecvAction :: CHP a -> CHP () -> CHP () -> RecvAction a -makeCustomRecvAction x y z = RecvAction (x, y, z) - --- | Acts like a SendAction, but just discards the data. -nullSendAction :: SendAction a -nullSendAction = SendAction (const $ return (), return (), return ()) - --- | Acts like a RecvAction, but always gives back the given data item. -nullRecvAction :: a -> RecvAction a -nullRecvAction x = RecvAction (return x, return (), return ()) - diff --git a/Control/Concurrent/CHP/Alt.hs b/Control/Concurrent/CHP/Alt.hs --- a/Control/Concurrent/CHP/Alt.hs +++ b/Control/Concurrent/CHP/Alt.hs @@ -103,6 +103,7 @@ -- would). module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (), every, every_, (<&>)) where +import Control.Applicative import Control.Arrow import Control.Concurrent.STM import Control.Monad.Reader @@ -173,7 +174,7 @@ -- Whichever channel is chosen by both processes will not satisfy the priority -- at one end (if such priority between channels was supported). priAlt :: [CHP a] -> CHP a -priAlt items = unwrapPoison $ priAlt' $ map wrapPoison items +priAlt = unwrapPoison . priAlt' . map wrapPoison -- | A useful operator to perform an 'alt'. This operator is associative, -- and has arbitrary priority. When you have lots of guards, it is probably easier @@ -331,7 +332,7 @@ -- -- Added in version 1.1.0 (<&>) :: forall a b. CHP a -> CHP b -> CHP (a, b) -(<&>) a b = every [a >>= return . Left, b >>= return . Right] >>= return . merge +(<&>) a b = merge <$> every [Left <$> a, Right <$> b] where merge :: [Either a b] -> (a, b) merge [Left x, Right y] = (x, y) @@ -396,8 +397,8 @@ getRec (Signal PoisonItem, _) = PoisonItem getRec (Signal (NoPoison n), m) = case both !! n of - (EventGuard rec _ _, body) -> - NoPoison (rec (makeLookup m), body) + (EventGuard recF _ _, body) -> + NoPoison (recF (makeLookup m), body) (_, body) -> NoPoison ([], body) tv <- liftIO $ newTVarIO Nothing pid <- getProcessId diff --git a/Control/Concurrent/CHP/Arrow.hs b/Control/Concurrent/CHP/Arrow.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Arrow.hs +++ /dev/null @@ -1,334 +0,0 @@ --- 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. - - --- | Provides an instance of Arrow for process pipelines. As described in --- the original paper on arrows, they can be used to represent stream processing, --- so CHP seemed like a possible fit for an arrow. --- --- Whether this is /actually/ an instance of Arrow depends on technicalities. --- This can be demonstrated with the arrow law @arr id >>> f = f = f >>> arr --- id@. Whether CHP satisfies this arrow law depends on the definition of --- equality. --- --- * If equality means that given the same input value, both arrows produce the --- same corresponding output value, this is an arrow. --- --- * If equality means you give the arrows the same single input and wait for the single output, --- and the output is the same, this is an arrow. --- --- * If equality means that you can feed the arrows lots of inputs (one after --- the other) and the behaviour should be the same with regards to communication, --- this is not an arrow. --- --- The problem lies in the buffering inherent in arrows. Imagine if @f@ is --- a single function. @f@ is effectively a buffer of one. You can feed it --- a single value, but no more than that until you read its output. However, --- if you have @arr id >>> f@, that can accept two inputs (one held by the --- @arr id@ process and one held by @f@) before you must accept the output. --- --- I am fairly confident that the arrow laws are satisfied for the --- definition of equality that given the same single input, they will --- produce the same single output. If you don't worry too much about the --- behavioural difference, and just take arrows as another way to wire --- together a certain class of process network, you should do fine. --- --- Added in version 1.0.2. -module Control.Concurrent.CHP.Arrow (ProcessPipeline, runPipeline, arrowProcess, arrStrict, - ProcessPipelineLabel, runPipelineLabel, arrowProcessLabel, arrLabel, arrStrictLabel, - (*>>>*), (*<<<*), (*&&&*), (*****)) where - --- I have got this module to work on GHC 6.8 and 6.10 by following the CPP-variant --- instructions on this page: http://haskell.org/haskellwiki/Upgrading_packages - -#if __GLASGOW_HASKELL__ >= 609 -import Control.Category -import Prelude hiding ((.), id) -#endif - -import Control.Arrow -#if __GLASGOW_HASKELL__ < 610 - hiding (pure) -#endif -import Control.Monad -import Control.Parallel.Strategies - -import Control.Concurrent.CHP -import qualified Control.Concurrent.CHP.Common as CHP -import Control.Concurrent.CHP.Utils - --- | ProcessPipelineLabel is a version of 'ProcessPipeline' that allows the processes --- to be labelled, and thus in turn for the channels connecting the processes to --- be automatically labelled. ProcessPipelineLabel is not an instance of Arrow, --- but it does have a lot of similarly named functions for working with it. This --- awkwardness is due to the extra Show constraints on the connectors that allow --- the arrow's contents to appear in traces. --- --- If you don't use traces, use 'ProcessPipeline'. If you do use traces, and want --- to have better labels on the process and values used in your arrows, consider --- switching to ProcessPipelineLabel. --- --- ProcessPipelineLabel and all the functions that use it, were added in version --- 1.5.0. -data ProcessPipelineLabel a b = ProcessPipelineLabel - { runPipelineLabel :: Chanin a -> Chanout b -> CHP () - -- ^ Like 'runPipeline' but for 'ProcessPipelineLabel' - , _pipelineLabels :: (String, String) - } - --- | Like 'arrowProcess', but allows the process to be labelled. The same --- warnings as 'arrowProcess' apply. -arrowProcessLabel :: String -> (Chanin a -> Chanout b -> CHP ()) -> ProcessPipelineLabel a b -arrowProcessLabel l p = ProcessPipelineLabel p (l, l) - --- | Like 'arr' for 'ProcessPipeline', but allows the process to be labelled. -arrLabel :: String -> (a -> b) -> ProcessPipelineLabel a b -arrLabel l = arrowProcessLabel l . CHP.map - --- | Like 'arrStrict', but allows the process to be labelled. -arrStrictLabel :: NFData b => String -> (a -> b) -> ProcessPipelineLabel a b -arrStrictLabel l = arrowProcessLabel l . CHP.map' - --- | The '(>>>)' arrow combinator, for 'ProcessPipelineLabel'. -(*>>>*) :: Show b => ProcessPipelineLabel a b -> ProcessPipelineLabel b c - -> ProcessPipelineLabel a c -(*>>>*) (ProcessPipelineLabel p (pl, pr)) (ProcessPipelineLabel q (ql, qr)) - = ProcessPipelineLabel (p |->|^ (pr ++ "->" ++ ql, q)) (pl, qr) - --- | The '(<<<)' arrow combinator, for 'ProcessPipelineLabel'. -(*<<<*) :: Show b => ProcessPipelineLabel b c -> ProcessPipelineLabel a b - -> ProcessPipelineLabel a c -(*<<<*) = flip (*>>>*) - --- | The '(&&&)' arrow combinator, for 'ProcessPipelineLabel'. -(*&&&*) :: (Show b, Show c, Show c') => ProcessPipelineLabel b c -> ProcessPipelineLabel b c' -> ProcessPipelineLabel b (c, c') -(*&&&*) (ProcessPipelineLabel p (pl, pr)) - (ProcessPipelineLabel q (ql, qr)) - = ProcessPipelineLabel proc (mix pl ql, mix pr qr) - where - mix a b = "(" ++ a ++ "*&&&*" ++ b ++ ")" - proc input output - = do deltaP <- oneToOneChannel' $ chanLabel $ pl ++ ".in" - deltaQ <- oneToOneChannel' $ chanLabel $ ql ++ ".in" - joinP <- oneToOneChannel' $ chanLabel $ pr ++ ".out" - joinQ <- oneToOneChannel' $ chanLabel $ qr ++ ".out" - runParallel_ - [CHP.parDelta input (writers [deltaP, deltaQ]) - ,p (reader deltaP) (writer joinP) - ,q (reader deltaQ) (writer joinQ) - ,CHP.join (,) (reader joinP) (reader joinQ) output - ] - --- | The '(***)' arrow combinator, for 'ProcessPipelineLabel'. -(*****) :: (Show b, Show b', Show c, Show c') => ProcessPipelineLabel b c -> ProcessPipelineLabel b' c' - -> ProcessPipelineLabel (b, b') (c, c') -(*****) (ProcessPipelineLabel p (pl, pr)) - (ProcessPipelineLabel q (ql, qr)) - = ProcessPipelineLabel proc (mix pl ql, mix pr qr) - where - mix a b = "(" ++ a ++ "*****" ++ b ++ ")" - proc input output - = do deltaP <- oneToOneChannel' $ chanLabel $ mix pl ql ++ "->" ++ pl - deltaQ <- oneToOneChannel' $ chanLabel $ mix pl ql ++ "->" ++ ql - joinP <- oneToOneChannel' $ chanLabel $ pr ++ "->" ++ mix pr qr - joinQ <- oneToOneChannel' $ chanLabel $ qr ++ "->" ++ mix pr qr - runParallel_ - [CHP.split input (writer deltaP) (writer deltaQ) - ,p (reader deltaP) (writer joinP) - ,q (reader deltaQ) (writer joinQ) - ,CHP.join (,) (reader joinP) (reader joinQ) output - ] - - --- | The type that is an instance of 'Arrow' for process pipelines. See 'runPipeline'. --- --- The 'Functor' instance was added in version 1.6.0. -data ProcessPipeline a b = ProcessPipeline - { runPipeline :: Chanin a -> Chanout b -> CHP () - -- ^ Given a 'ProcessPipeline' (formed using its 'Arrow' instance) and - -- the channels to plug into the ends of the pipeline, returns the process - -- representing the pipeline. - -- - -- The pipeline will run forever (until poisoned) and you must run it in - -- parallel to whatever is feeding it the inputs and reading off the outputs. - -- Imagine that you want a process pipeline that takes in a pair of numbers, - -- doubles the first and adds one to the second. You could encode this - -- in an arrow using: - -- - -- > runPipeline (arr (*2) *** arr (+1)) - -- - -- Arrows are more useful where you already have processes written that - -- process data and you want to easily wire them together. The arrow notation - -- is probably easier for doing that than declaring all the channels yourself - -- and composing everything in parallel. - } - --- | Adds a wrapper that forms this process into the right data type to be --- part of an arrow. --- --- Any process you apply this to should produce exactly one output per --- input, or else you will find odd behaviour resulting (including deadlock). --- So for example, /don't/ use @arrowProcess ('Control.Concurrent.CHP.Common.filter' --- ...)@ or @arrowProcess 'Control.Concurrent.CHP.Common.stream'@ inside any arrow combinators --- other than >>> and <<<. --- --- Added in version 1.1.0 -arrowProcess :: (Chanin a -> Chanout b -> CHP ()) -> ProcessPipeline a b -arrowProcess = ProcessPipeline - --- | Like the arr function of the ProcessPipeline arrow instance, but fully evaluates --- the result before sending it. If you are building process pipelines with arrows to --- try and get some parallel speed-up, you should try this function instead of --- arr itself. --- --- Added in version 1.3.2 -arrStrict :: NFData b => (a -> b) -> ProcessPipeline a b -arrStrict = ProcessPipeline . CHP.map' - -instance Functor (ProcessPipeline a) where - fmap f x = x >>> arr f - -#if __GLASGOW_HASKELL__ >= 609 -instance Category ProcessPipeline where - (ProcessPipeline q) . (ProcessPipeline p) = ProcessPipeline (p |->| q) - id = ProcessPipeline CHP.id -#endif - -instance Arrow ProcessPipeline where -#if __GLASGOW_HASKELL__ < 609 - (ProcessPipeline p) >>> (ProcessPipeline q) = ProcessPipeline (p |->| q) -#endif - arr = ProcessPipeline . CHP.map - - first (ProcessPipeline p) = ProcessPipeline $ \in_ out -> do - c <- newChannel - c' <- newChannel - d <- newChannel - runParallel_ - [ CHP.split in_ (writer c) (writer d) - , p (reader c) (writer c') - , CHP.join (,) (reader c') (reader d) out - ] - - second (ProcessPipeline p) = ProcessPipeline $ \in_ out -> do - c <- newChannel - c' <- newChannel - d <- newChannel - runParallel_ - [ CHP.split in_ (writer d) (writer c) - , p (reader c) (writer c') - , CHP.join (,) (reader d) (reader c') out - ] - - (ProcessPipeline p) *** (ProcessPipeline q) = ProcessPipeline $ \in_ out -> do - c <- newChannel - c' <- newChannel - d <- newChannel - d' <- newChannel - runParallel_ - [ CHP.split in_ (writer c) (writer d) - , p (reader c) (writer c') - , q (reader d) (writer d') - , CHP.join (,) (reader c') (reader d') out - ] - - (ProcessPipeline p) &&& (ProcessPipeline q) = ProcessPipeline $ \in_ out -> do - c <- newChannel - c' <- newChannel - d <- newChannel - d' <- newChannel - runParallel_ - [ CHP.parDelta in_ [writer c, writer d] - , p (reader c) (writer c') - , q (reader d) (writer d') - , CHP.join (,) (reader c') (reader d') out - ] - -instance ArrowChoice ProcessPipeline where - left (ProcessPipeline p) = ProcessPipeline $ \in_ out -> do - c <- oneToOneChannel - d <- oneToOneChannel - (forever $ do x <- readChannel in_ - case x of - Left l -> do writeChannel (writer c) l - l' <- readChannel (reader d) - writeChannel out (Left l') - Right r -> writeChannel out (Right r) - ) <||> p (reader c) (writer d) - return () - - right (ProcessPipeline p) = ProcessPipeline $ \in_ out -> do - c <- oneToOneChannel - d <- oneToOneChannel - (forever $ do x <- readChannel in_ - case x of - Right r -> do writeChannel (writer c) r - r' <- readChannel (reader d) - writeChannel out (Right r') - Left l -> writeChannel out (Left l) - ) <||> p (reader c) (writer d) - return () - - (ProcessPipeline p) ||| (ProcessPipeline q) - = ProcessPipeline $ \in_ out -> do - c <- oneToOneChannel - c' <- oneToOneChannel - d <- oneToOneChannel - d' <- oneToOneChannel - runParallel_ - [ forever $ do x <- readChannel in_ - x' <- case x of - Left l -> do writeChannel (writer c) l - readChannel (reader c') - Right r -> do writeChannel (writer d) r - readChannel (reader d') - writeChannel out x' - , p (reader c) (writer c') - , q (reader d) (writer d') - ] - - (ProcessPipeline p) +++ (ProcessPipeline q) - = ProcessPipeline $ \in_ out -> do - c <- oneToOneChannel - c' <- oneToOneChannel - d <- oneToOneChannel - d' <- oneToOneChannel - runParallel_ - [ forever $ do x <- readChannel in_ - x' <- case x of - Left l -> do writeChannel (writer c) l - l' <- readChannel (reader c') - return (Left l') - Right r -> do writeChannel (writer d) r - r' <- readChannel (reader d') - return (Right r') - writeChannel out x' - , p (reader c) (writer c') - , q (reader d) (writer d') - ] diff --git a/Control/Concurrent/CHP/Base.hs b/Control/Concurrent/CHP/Base.hs --- a/Control/Concurrent/CHP/Base.hs +++ b/Control/Concurrent/CHP/Base.hs @@ -38,10 +38,12 @@ 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 @@ -137,11 +139,10 @@ AltableT alt _ -> alt liftTrace :: TraceT IO a -> CHP' a -liftTrace m = AltableT (badGuard "lifted action") m +liftTrace = AltableT (badGuard "lifted action") wrapPoison :: CHP a -> CHP' (WithPoison a) -wrapPoison (PoisonT m) = (liftM $ either (const PoisonItem) NoPoison) $ - runErrorT m +wrapPoison (PoisonT m) = either (const PoisonItem) NoPoison <$> runErrorT m unwrapPoison :: CHP' (WithPoison a) -> CHP a unwrapPoison m = PoisonT (lift m) >>= checkPoison @@ -184,7 +185,7 @@ -- | Poisons all the given items. A handy shortcut for @mapM_ poison@. poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m () -poisonAll ps = mapM_ poison ps +poisonAll = mapM_ poison liftSTM :: MonadIO m => STM a -> m a @@ -250,7 +251,7 @@ } instance Eq (ManyToOneTVar a) where - (==) tvA tvB = mtoFinal tvA == mtoFinal tvB + (==) = (==) `on` mtoFinal newManyToOneTVar :: (a -> Bool) -> STM a -> a -> STM (ManyToOneTVar a) newManyToOneTVar f r x @@ -301,6 +302,9 @@ 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 @@ -311,7 +315,10 @@ let altBody' = liftM (map $ second (>>= pullOutStandard . f)) altBody nonAlt' = nonAlt >>= pullOutStandard . f in AltableT altBody' nonAlt' - return x = AltableTRet x + return = AltableTRet +instance Functor CHP' where + fmap = liftM + instance MonadIO CHP' where - liftIO m = liftTrace (liftIO m) + liftIO = liftTrace . liftIO diff --git a/Control/Concurrent/CHP/Behaviours.hs b/Control/Concurrent/CHP/Behaviours.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Behaviours.hs +++ /dev/null @@ -1,204 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2009, 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 CHP behaviours. See 'offer' for details. --- --- This whole module was added in CHP 1.6.0. -module Control.Concurrent.CHP.Behaviours ( - CHPBehaviour, offer, offerAll, alongside, alongside_, endWhen, once, upTo, repeatedly, repeatedly_, - repeatedlyRecurse, repeatedlyRecurse_) where - -import Control.Applicative -import Control.Monad - -import Control.Concurrent.CHP - --- | This data represents a behaviour (potentially repeated) that will result in --- returning a value of type @a@. See 'offer' for more details. -data CHPBehaviour a = CHPBehaviour a (Maybe (CHP (CHPBehaviour a))) - -instance Functor CHPBehaviour where - fmap f (CHPBehaviour x Nothing) = CHPBehaviour (f x) Nothing - fmap f (CHPBehaviour x (Just m)) = CHPBehaviour (f x) (Just $ fmap f <$> m) - --- | Offers the given behaviour, and when it occurs, ends the entire call to 'offer'. --- Returns Just the result if the behaviour happens, otherwise gives Nothing. -endWhen :: CHP a -> CHPBehaviour (Maybe a) -endWhen m = CHPBehaviour Nothing (Just $ (\x -> CHPBehaviour (Just x) Nothing) <$> m) - --- | Offers the given behaviour, and when it occurs, does not offer it again. --- Returns Just the result if the behaviour happens, otherwise gives Nothing. --- 'once' is different to 'endWhen' because the latter terminates the call to 'offer' --- regardless of other behaviours, whereas 'once' does not terminate the call to 'offer', --- it just won't be offered again during the call to 'offer'. Thus if you only --- offer some 'once' items without any 'endWhen', then after all the 'once' events --- have happened, the process will deadlock. --- --- @once m@ can be thought of as a shortcut for @listToMaybe <$> upTo1 m@ -once :: CHP a -> CHPBehaviour (Maybe a) -once m = CHPBehaviour Nothing (Just $ (\x -> CHPBehaviour (Just x) (Just stop)) <$> m) - - --- | Offers the given behaviour up to the given number of times, returning a list --- of the results (in chronological order). Like 'once', when the limit is reached, --- the call to 'offer' is not terminated, so you still require an 'endWhen'. --- --- Added in version 1.8.0. -upTo :: Int -> CHP a -> CHPBehaviour [a] -upTo n m = reverse <$> upTo' [] - where - upTo' xs - = CHPBehaviour xs $ Just $ if length xs >= n then stop else (upTo' . (:xs)) <$> m - --- | Repeatedly offers the given behaviour until the outer call to 'offer' is terminated --- by an 'endWhen' event. A list is returned (in chronological order) of the results --- of each occurrence of the behaviour. @repeatedly@ is like an unbounded @upTo@. -repeatedly :: forall a. CHP a -> CHPBehaviour [a] -repeatedly m = reverse <$> repeatedly' [] - where - repeatedly' :: [a] -> CHPBehaviour [a] - repeatedly' xs = CHPBehaviour xs $ Just $ - (\x -> repeatedly' (x:xs)) <$> m - --- | Like 'repeatedly', but discards the output. Useful if the event is likely --- to occur a lot, and you don't need the results. -repeatedly_ :: CHP a -> CHPBehaviour () -repeatedly_ m = CHPBehaviour () $ Just $ m >> return (repeatedly_ m) - --- | Like 'repeatedly', but allows some state (of type @a@) to be passed from one --- subsequent call to another, as well as generating the results of type @b@. --- To begin with the function (first parameter) will be called with the initial --- state (second parameter). If chosen, it will return the new state, and a result --- to be accumulated into the list. The second call to the function will be passed --- the new state, to then return the even newer state and a second result, and --- so on. --- --- If you want to use this with the StateT monad transformer from the mtl library, --- you can call: --- --- > repeatedlyRecurse (runStateT myStateAction) initialState --- > where --- > myStateAction :: StateT s CHP a --- > initialState :: s -repeatedlyRecurse :: forall a b. (a -> CHP (b, a)) -> a -> CHPBehaviour [b] -repeatedlyRecurse f = fmap reverse . repeatedlyRecurse' [] - where - repeatedlyRecurse' :: [b] -> a -> CHPBehaviour [b] - repeatedlyRecurse' rs x = CHPBehaviour rs $ Just $ - (\(r, y) -> repeatedlyRecurse' (r : rs) y) <$> f x - --- | Like 'repeatedlyRecurse', but does not accumulate a list of results. --- --- If you want to use this with the StateT monad transformer from the mtl library, --- you can call: --- --- > repeatedlyRecurse (execStateT myStateAction) initialState --- > where --- > myStateAction :: StateT s CHP a --- > initialState :: s -repeatedlyRecurse_ :: forall a. (a -> CHP a) -> a -> CHPBehaviour () -repeatedlyRecurse_ f = repeatedlyRecurse' - where - repeatedlyRecurse' :: a -> CHPBehaviour () - repeatedlyRecurse' x = CHPBehaviour () $ Just $ repeatedlyRecurse' <$> f x - --- | Offers one behaviour alongside another, combining their semantics. See 'offer'. --- --- This operation is semantically associative and commutative. -alongside :: CHPBehaviour a -> CHPBehaviour b -> CHPBehaviour (a, b) -alongside oa@(CHPBehaviour a mfa) ob@(CHPBehaviour b mfb) - = CHPBehaviour (a, b) (do fa <- mfa - fb <- mfb - return $ (flip alongside ob <$> fa) <-> (alongside oa <$> fb) - ) - --- | Offers one behaviour alongside another, combining their semantics. See 'offer'. --- Unlike 'alongside', discards the output of the behaviours. --- --- This operation is associative and commutative. -alongside_ :: CHPBehaviour a -> CHPBehaviour b -> CHPBehaviour () -alongside_ (CHPBehaviour _ mfa) (CHPBehaviour _ mfb) - = CHPBehaviour () (liftM2 (<->) (liftM blank <$> mfa) (liftM blank <$> mfb)) - where - blank :: CHPBehaviour c -> CHPBehaviour () - blank = fmap (const ()) - -infixr `alongside` - --- | Offers the given behaviour until finished. --- --- For example, --- --- > offer $ repeatedly p `alongside` repeatedly q --- --- will repeatedly offer p and q without ever terminating. This: --- --- > offer $ repeatedly p `alongside` repeatedly q `alongside` endWhen r --- --- will offer p repeatedly and q repeatedly and r, until r happens, at which point --- the behaviour will end. --- This: --- --- > offer $ once p `alongside` endWhen q --- --- will offer p and q; if p happens first it will wait for q, but if q happens --- first it will finish. This: --- --- > offer $ once p `alongside` endWhen q `alongside` endWhen r --- --- permits p to happen at most once, while either of q or r happening will finish --- the call. --- --- All sorts of combinations are possible, but it is important to note that you --- need at least one 'endWhen' event if you ever intend the call to finish. Some --- laws involving 'offer' (ignoring the types and return values) are: --- --- > offer (repeatedly p) == forever p --- > offer (once p) == p >> stop -- i.e. it does not finish --- > offer (endWhen q) == Just <$> q --- > offer (endWhen p `alongside` endWhen q) == p <-> q --- > offer (once p `alongside` endWhen q) == (p >> q) <-> q --- --- Most other uses of 'offer' and 'alongside' do not reduce down to simple CHP --- programs, which is of course their attraction. -offer :: CHPBehaviour a -> CHP a -offer (CHPBehaviour x Nothing) = return x -offer (CHPBehaviour _x (Just m)) = m >>= offer - --- | Offers all the given behaviours together, and gives back a list of the outcomes. --- --- This is roughly a shorthand for @offer . foldl1 alongside@, except that if you --- pass the empty list, you simply get the empty list returned (rather than an --- error) -offerAll :: [CHPBehaviour a] -> CHP [a] -offerAll [] = return [] -offerAll bs = offer $ foldl1 (\x y -> fmap (uncurry (++)) $ alongside x y) bs' - where - bs' = map (fmap (:[])) bs diff --git a/Control/Concurrent/CHP/BroadcastChannels.hs b/Control/Concurrent/CHP/BroadcastChannels.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/BroadcastChannels.hs +++ /dev/null @@ -1,35 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2008--2009, 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. - --- | Since version 1.5.0, this module is a synonym for the "Control.Concurrent.CHP.Channels.BroadcastReduce" --- module, and is liable to be removed in a future version. -module Control.Concurrent.CHP.BroadcastChannels - (module Control.Concurrent.CHP.Channels.BroadcastReduce) where - -import Control.Concurrent.CHP.Channels.BroadcastReduce diff --git a/Control/Concurrent/CHP/Buffers.hs b/Control/Concurrent/CHP/Buffers.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Buffers.hs +++ /dev/null @@ -1,145 +0,0 @@ --- 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. - - --- | Various processes that act like buffers. Poisoning either end of a buffer --- process is immediately passed on to the other side, in contrast to C++CSP2 --- and JCSP. -module Control.Concurrent.CHP.Buffers (fifoBuffer, infiniteBuffer, - accumulatingInfiniteBuffer, overflowingBuffer, overwritingBuffer) - where - -import Control.Monad -import Data.Foldable -import Data.Sequence (Seq, viewl, ViewL(..)) -import qualified Data.Sequence as Seq - -import Control.Concurrent.CHP -import qualified Control.Concurrent.CHP.Common as Common - --- | Acts like a limited capacity FIFO buffer of the given size. When it is --- full it accepts no input, and when it is empty it offers no output. -fifoBuffer :: forall a. Int -> Chanin a -> Chanout a -> CHP () -fifoBuffer n in_ out - | n < 0 = return () - | n == 0 = Common.id in_ out - | otherwise = fifo Seq.empty `onPoisonRethrow` (poison in_ >> poison out) - where - fifo :: Seq a -> CHP () - fifo s | Seq.null s = takeIn - | Seq.length s == n = sendOut - | otherwise = takeIn <-> sendOut - where - takeIn = readChannel in_ >>= fifo . addLast s - sendOut = do writeChannel out (seqHead s) - fifo (removeHead s) - --- | Acts like a FIFO buffer with unlimited capacity. Use with caution; make --- sure you do not let the buffer grow so large that it eats up all your memory. --- When it is empty, it offers no output. It always accepts input. -infiniteBuffer :: forall a. Chanin a -> Chanout a -> CHP () -infiniteBuffer in_ out - = buff Seq.empty `onPoisonRethrow` (poison in_ >> poison out) - where - buff :: Seq a -> CHP () - buff s | Seq.null s = takeIn - | otherwise = sendOut takeIn - where - takeIn = readChannel in_ >>= buff . addLast s - sendOut = do writeChannel out (seqHead s) - buff (removeHead s) - --- | Acts like a FIFO buffer with unlimited capacity, but accumulates --- sequential inputs into a list which it offers in a single output. Use with --- caution; make sure you do not let the buffer grow so large that it eats up --- all your memory. When it is empty, it offers the empty list. It always --- accepts input. Once it has sent out a value (or values) it removes them --- from its internal storage. --- --- Added in version 1.2.0. -accumulatingInfiniteBuffer :: forall a. Chanin a -> Chanout [a] -> CHP () -accumulatingInfiniteBuffer in_ out - = buff Seq.empty `onPoisonRethrow` (poison in_ >> poison out) - where - buff :: Seq a -> CHP () - buff s | Seq.null s = takeIn >>= buff - | otherwise = (sendOut takeIn) >>= buff - where - takeIn = liftM (addLast s) $ readChannel in_ - sendOut = do writeChannel out (toList s) - return Seq.empty - - --- | Acts like a FIFO buffer of limited capacity, except that when it is full, --- it always accepts input and discards it. When it is empty, it does not offer output. -overflowingBuffer :: forall a. Int -> Chanin a -> Chanout a -> CHP () -overflowingBuffer n in_ out - | n < 0 = return () - | n == 0 = Common.id in_ out - | otherwise = flow Seq.empty `onPoisonRethrow` (poison in_ >> poison out) - where - flow :: Seq a -> CHP () - flow s | Seq.null s = takeIn - | Seq.length s == n = sendOut <-> dropItem - | otherwise = takeIn <-> sendOut - where - takeIn = readChannel in_ >>= flow . addLast s - dropItem = readChannel in_ >> flow s - sendOut = do writeChannel out (seqHead s) - flow (removeHead s) - --- | Acts like a FIFO buffer of limited capacity, except that when it is full, --- it always accepts input and pushes out the oldest item in the buffer. When --- it is empty, it does not offer output. -overwritingBuffer :: forall a. Int -> Chanin a -> Chanout a -> CHP () -overwritingBuffer n in_ out - | n < 0 = return () - | n == 0 = Common.id in_ out - | otherwise = over Seq.empty `onPoisonRethrow` (poison in_ >> poison out) - where - over :: Seq a -> CHP () - over s | Seq.null s = takeIn - | Seq.length s == n = sendOut <-> takeInOver - | otherwise = takeIn <-> sendOut - where - takeIn = readChannel in_ >>= over . addLast s - takeInOver = readChannel in_ >>= over . removeHead . addLast s - sendOut = do writeChannel out (seqHead s) - over (removeHead s) - -seqHead :: Seq a -> a -seqHead s = case viewl s of - EmptyL -> error "Internal code logic error in buffer" - x :< _ -> x - -removeHead :: Seq a -> Seq a -removeHead = Seq.drop 1 - -addLast :: Seq a -> a -> Seq a -addLast = (Seq.|>) diff --git a/Control/Concurrent/CHP/CSP.hs b/Control/Concurrent/CHP/CSP.hs --- a/Control/Concurrent/CHP/CSP.hs +++ b/Control/Concurrent/CHP/CSP.hs @@ -52,13 +52,13 @@ -- First engages in event, then executes the body. The returned value is suitable -- for use in an alt buildOnEventPoison :: (Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique]) -> Event.Event -> EventActions -> CHP a -> CHP a -buildOnEventPoison rec e act body +buildOnEventPoison recE e act body = liftPoison (AltableT (Right [(theGuard, return True)]) (return False)) >>= \b -> if b then body else alt [liftPoison $ AltableT (Right [(theGuard, return ())]) (return ())] >> body where - theGuard = EventGuard (rec (Event.getEventUnique e)) act [e] + theGuard = EventGuard (recE (Event.getEventUnique e)) act [e] scopeBlock :: CHP a -> (a -> CHP b) -> IO () -> CHP b scopeBlock start body errorEnd @@ -71,14 +71,14 @@ wrapIndiv :: (Unique -> (Unique -> Integer) -> String -> [RecordedIndivEvent Unique]) -> Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique] -wrapIndiv rec u lu = rec u (fst . lu) (Event.getEventTypeVal $ snd $ lu u) +wrapIndiv recE u lu = recE u (fst . lu) (Event.getEventTypeVal $ snd $ lu u) -- | Synchronises on the given barrier. You must be enrolled on a barrier in order -- to synchronise on it. Returns the new phase, following the synchronisation. syncBarrierWith :: (Unique -> (Unique -> Integer) -> String -> [RecordedIndivEvent Unique]) -> (Int -> STM ()) -> Enrolled PhasedBarrier phase -> CHP phase -syncBarrierWith rec storeN (Enrolled (Barrier (e,tv, fph))) - = buildOnEventPoison (wrapIndiv rec) e (EventActions incPhase (return ())) +syncBarrierWith recE storeN (Enrolled (Barrier (e,tv, fph))) + = buildOnEventPoison (wrapIndiv recE) e (EventActions incPhase (return ())) (liftIO $ atomically $ readTVar tv) where incPhase :: Map.Map Unique Int -> STM () diff --git a/Control/Concurrent/CHP/Channels.hs b/Control/Concurrent/CHP/Channels.hs --- a/Control/Concurrent/CHP/Channels.hs +++ b/Control/Concurrent/CHP/Channels.hs @@ -32,8 +32,8 @@ -- -- A communication in CHP is always synchronised: the writer must wait until the -- reader arrives to take the data. There is thus no automatic or underlying buffering --- of data. (If you want to use buffers, see the "Control.Concurrent.CHP.Buffers" --- module). +-- of data. (If you want to use buffers, see the Control.Concurrent.CHP.Buffers +-- module in the chp-plus package). -- -- If it helps, a channel communication can be thought of as a distributed binding. -- Imagine you have a process that creates a channel and then becomes the parallel diff --git a/Control/Concurrent/CHP/Channels/Base.hs b/Control/Concurrent/CHP/Channels/Base.hs --- a/Control/Concurrent/CHP/Channels/Base.hs +++ b/Control/Concurrent/CHP/Channels/Base.hs @@ -169,8 +169,7 @@ case x of PoisonItem -> return PoisonItem NoPoison _ -> return $ NoPoison ()) - sendWriteChannelC (STMChan (_, tv)) val - = sendData tv val + sendWriteChannelC (STMChan (_, tv)) = sendData tv endWriteChannelC (STMChan (_, tv)) = consumeAck tv diff --git a/Control/Concurrent/CHP/Channels/BroadcastReduce.hs b/Control/Concurrent/CHP/Channels/BroadcastReduce.hs --- a/Control/Concurrent/CHP/Channels/BroadcastReduce.hs +++ b/Control/Concurrent/CHP/Channels/BroadcastReduce.hs @@ -109,8 +109,7 @@ instance Enrollable BroadcastChanin a where enroll c@(BI (BC (b,_,_))) f = enroll b (const $ f (Enrolled c)) - resign (Enrolled (BI (BC (b,_,_)))) m - = resign (Enrolled b) m + resign (Enrolled (BI (BC (b,_,_)))) = resign (Enrolled b) instance WriteableChannel BroadcastChanout where extWriteChannel' (BO (BC (b, tvSend, tvAck))) m @@ -141,8 +140,8 @@ checkForPoison (Enrolled (BI (BC (b,_,_)))) = checkForPoison $ Enrolled b newBroadcastChannel :: CHP (BroadcastChannel a) -newBroadcastChannel = do - do b@(Barrier (e, _, _)) <- newBarrier +newBroadcastChannel + = do b@(Barrier (e, _, _)) <- newBarrier -- Writer is always enrolled: liftIO $ atomically $ enrollEvent e tvSend <- liftIO $ atomically $ newTVar Nothing @@ -208,8 +207,7 @@ instance Enrollable ReduceChanout a where enroll c@(GO (GC (b,_,_))) f = enroll b (const $ f (Enrolled c)) - resign (Enrolled (GO (GC (b,_,_)))) m - = resign (Enrolled b) m + resign (Enrolled (GO (GC (b,_,_)))) = resign (Enrolled b) instance WriteableChannel (Enrolled ReduceChanout) where extWriteChannel' (Enrolled (GO (GC (b, tv, (f,_))))) m @@ -246,8 +244,8 @@ checkForPoison (GI (GC (b,_,_))) = checkForPoison $ Enrolled b newReduceChannel :: Monoid a => CHP (ReduceChannel a) -newReduceChannel = do - do b@(Barrier (e, _, _)) <- newBarrier +newReduceChannel + = do b@(Barrier (e, _, _)) <- newBarrier -- Writer is always enrolled: liftIO $ atomically $ enrollEvent e mtv <- liftIO $ atomically $ newManyToOneTVar ((== 0) . fst) (return (0, Nothing)) (0, Nothing) diff --git a/Control/Concurrent/CHP/Channels/Communication.hs b/Control/Concurrent/CHP/Channels/Communication.hs --- a/Control/Concurrent/CHP/Channels/Communication.hs +++ b/Control/Concurrent/CHP/Channels/Communication.hs @@ -56,8 +56,9 @@ ReadableChannel(..), WriteableChannel(..), writeValue, writeChannelStrict ) where + +import Control.DeepSeq import Control.Monad -import Control.Parallel.Strategies import Data.Monoid import Control.Concurrent.CHP.Base @@ -85,7 +86,7 @@ -- | Starts the communication, then performs the given extended action, then -- sends the result of that down the channel. extWriteChannel :: chanEnd a -> CHP a -> CHP () - extWriteChannel c m = extWriteChannel' c (liftM (flip (,) ()) m) + extWriteChannel c = extWriteChannel' c . liftM (flip (,) ()) -- | Like extWriteChannel, but allows a value to be returned from the inner action. -- @@ -120,7 +121,7 @@ -- -- Added in version 1.0.2. writeChannelStrict :: (NFData a, WriteableChannel chanEnd) => chanEnd a -> a -> CHP () -writeChannelStrict c x = (writeChannel c $| rnf) x +writeChannelStrict c x = case rnf x of () -> writeChannel c x -- ========== -- Instances: diff --git a/Control/Concurrent/CHP/Clocks.hs b/Control/Concurrent/CHP/Clocks.hs --- a/Control/Concurrent/CHP/Clocks.hs +++ b/Control/Concurrent/CHP/Clocks.hs @@ -259,8 +259,8 @@ poisonTimerData :: TimerData time -> STM () poisonTimerData td - = do mapM_ poisonTVar $ map (snd . snd) (timerOffersAfter td) - mapM_ poisonTVar $ map (snd . snd) (timerOffersBefore td) + = do mapM_ (poisonTVar . snd . snd) (timerOffersAfter td) + mapM_ (poisonTVar . snd . snd) (timerOffersBefore td) maybe (return ()) (poisonTVar . snd) (timerOffersNext td) mapM_ poisonTVar $ timerEventPool td @@ -327,14 +327,14 @@ liftSTM (modifyTVar tv $ enrollTimerData $ Just ev) >>= checkPoison x <- f $ Enrolled tim - ts <- liftPoison $ liftTrace $ ask + ts <- liftPoison . liftTrace $ ask liftSTM (modifyTVar' tv $ checkCompletion u sh ts . resignTimerData True) >>= checkPoison return x -- For temporary resignations, we don't touch the event pool resign (Enrolled (Clock (tv, u, sh))) m - = do ts <- liftPoison $ liftTrace $ ask + = do ts <- liftPoison . liftTrace $ ask liftSTM (modifyTVar' tv (checkCompletion u sh ts . resignTimerData False)) >>= checkPoison x <- m @@ -406,7 +406,7 @@ -- to display times in traces. newClock :: (Ord time, Show time) => time -> CHP (Clock time) newClock t = do tv <- liftSTM $ newTVar $ NoPoison $ emptyTimerData t - u <- liftIO $ Event.newEventUnique + u <- liftIO Event.newEventUnique return $ Clock (tv, u, show) -- | Creates a clock that starts at the given time, and gives it the given @@ -414,7 +414,7 @@ newClockWithLabel :: (Ord time, Show time) => time -> String -> CHP (Clock time) newClockWithLabel t l = do tv <- liftSTM $ newTVar $ NoPoison $ emptyTimerData t - u <- liftIO $ Event.newEventUnique + u <- liftIO Event.newEventUnique liftPoison $ liftTrace $ labelUnique u l return $ Clock (tv, u, show) @@ -422,8 +422,8 @@ getCurrentTime (Enrolled (Clock (tv, _, _))) = liftSTM (liftM (fmap curTime) $ readTVar tv) >>= checkPoison wait c@(Enrolled (Clock (_, u, sh))) mt - = do ts <- liftPoison $ liftTrace $ ask - pid <- liftPoison $ liftTrace $ getProcessId + = do ts <- liftPoison . liftTrace $ ask + pid <- liftPoison . liftTrace $ getProcessId waitAct <- liftSTM $ waitClock pid ts c mt (t, s) <- liftSTM waitAct >>= checkPoison liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u s $ sh t] diff --git a/Control/Concurrent/CHP/Common.hs b/Control/Concurrent/CHP/Common.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Common.hs +++ /dev/null @@ -1,307 +0,0 @@ --- 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 collection of useful common processes that are useful when plumbing --- together a process network. All the processes here rethrow poison when --- it is encountered, as this gives the user maximum flexibility (they can --- let it propagate it, or ignore it). --- --- The names here overlap with standard Prelude names. This is --- deliberate, as the processes act in a similar manner to the --- corresponding Prelude versions. It is expected that you will do --- something like: --- --- > import qualified Control.Concurrent.CHP.Common as Common --- --- or: --- --- > import qualified Control.Concurrent.CHP.Common as CHP --- --- to circumvent this problem. -module Control.Concurrent.CHP.Common where - -import Control.Monad -import Control.Parallel.Strategies -import qualified Data.Traversable as Traversable -import Prelude (Bool(..), Maybe(..), Enum, Ord, ($), (<), Int, otherwise, (.)) -import qualified Prelude - -import Control.Concurrent.CHP - --- | Forever forwards the value onwards, unchanged. Adding this to your process --- network effectively adds a single-place buffer. -id :: (ReadableChannel r, Poisonable (r a), - WriteableChannel w, Poisonable (w a)) => r a -> w a -> CHP () -id in_ out = (forever $ - do x <- readChannel in_ - writeChannel out x - ) `onPoisonRethrow` (poison in_ >> poison out) - --- | Forever forwards the value onwards. This is --- like 'id' but does not add any buffering to your network, and its presence --- is indetectable to the process either side. --- --- extId is a unit of the associative operator 'Control.Concurrent.CHP.Utils.|->|'. --- --- The behaviour of this process was corrected in version 1.1.0 to work properly --- when the reader of its output channel was offering choice. -extId :: Chanin a -> Chanout a -> CHP () -extId in_ out = do - c <- oneToOneChannel - forever $ - extReadChannel in_ (writeChannel (writer c)) - <&> - extWriteChannel out (readChannel (reader c)) - --- | A process that waits for an input, then sends it out on /all/ its output --- channels (in order) during an extended rendezvous. This is often used to send the --- output on to both the normal recipient (without introducing buffering) and --- also to a listener process that wants to examine the value. If the listener --- process is first in the list, and does not take the input immediately, the --- value will not be sent to the other recipients until it does. The name --- of the process derives from the notion of a wire-tap, since the listener --- is hidden from the other processes (it does not visibly change the semantics --- for them -- except when the readers of the channels are offering a choice). -tap :: Chanin a -> [Chanout a] -> CHP () -tap in_ outs = (forever $ - extReadChannel in_ - (\x -> mapM_ (Prelude.flip writeChannel x) outs) - ) `onPoisonRethrow` (poison in_ >> poisonAll outs) - --- | Sends out a single value first (the prefix) then behaves like id. -prefix :: a -> Chanin a -> Chanout a -> CHP () -prefix x in_ out = (writeChannel out x >> id in_ out) - `onPoisonRethrow` (poison in_ >> poison out) - --- | Discards the first value it receives then act likes id. --- --- Added in version 1.5.0. -tail :: Chanin a -> Chanout a -> CHP () -tail input output = do readChannel input `onPoisonRethrow` (poison input >> poison output) - id input output - --- | Forever reads in a value, and then sends out its successor (using 'Prelude.succ'). -succ :: Enum a => Chanin a -> Chanout a -> CHP () -succ = map Prelude.succ - --- | Reads in a value, and sends it out in parallel on all the given output --- channels. -parDelta :: Chanin a -> [Chanout a] -> CHP () -parDelta in_ outs = (forever $ - do x <- readChannel in_ - runParallel_ $ Prelude.map (Prelude.flip writeChannel x) outs - ) `onPoisonRethrow` (poison in_ >> mapM_ poison outs) - --- | Forever reads in a value, transforms it using the given function, and sends it --- out again. Note that the transformation is not applied strictly, so don't --- assume that this process will actually perform the computation. If you --- require a strict transformation, use 'map''. -map :: (a -> b) -> Chanin a -> Chanout b -> CHP () -map f in_ out = forever (readChannel in_ >>= writeChannel out . f) - `onPoisonRethrow` (poison in_ >> poison out) - --- | Like 'map', but applies the transformation strictly before sending on --- the value. --- --- Added in version 1.1.0. -map' :: NFData b => (a -> b) -> Chanin a -> Chanout b -> CHP () -map' f in_ out = forever (readChannel in_ >>= writeChannelStrict out . f) - `onPoisonRethrow` (poison in_ >> poison out) - --- | Forever reads in a value, and then based on applying the given function --- either discards it (if the function returns False) or sends it on (if --- the function returns True). -filter :: (a -> Bool) -> Chanin a -> Chanout a -> CHP () -filter f in_ out = forever (do - x <- readChannel in_ - when (f x) (writeChannel out x) - ) `onPoisonRethrow` (poison in_ >> poison out) - --- | Streams all items in a 'Data.Traversable.Traversable' container out --- in the order given by 'Data.Traversable.mapM' on the output channel (one at --- a time). Lists, 'Prelude.Maybe', and 'Data.Set.Set' are all instances --- of 'Data.Traversable.Traversable', so this can be used for all of --- those. -stream :: Traversable.Traversable t => Chanin (t a) -> Chanout a -> CHP () -stream in_ out = (forever $ do - xs <- readChannel in_ - Traversable.mapM (writeChannel out) xs) - `onPoisonRethrow` (poison in_ >> poison out) - --- | Forever waits for input from one of its many channels and sends it --- out again on the output channel. -merger :: [Chanin a] -> Chanout a -> CHP () -merger ins out = (forever $ alt (Prelude.map readChannel ins) >>= writeChannel out) - `onPoisonRethrow` (poisonAll ins >> poison out) - --- | Sends out the specified value on the given channel the specified number --- of times, then finishes. -replicate :: Int -> a -> Chanout a -> CHP () -replicate n x c = replicateM_ n (writeChannel c x) `onPoisonRethrow` poison c - --- | Forever sends out the same value on the given channel, until poisoned. --- Similar to the white-hole processes in some other frameworks. -repeat :: a -> Chanout a -> CHP () -repeat x c = (forever $ writeChannel c x) `onPoisonRethrow` poison c - --- | Forever reads values from the channel and discards them, until poisoned. --- Similar to the black-hole processes in some other frameworks. -consume :: Chanin a -> CHP () -consume c = (forever $ readChannel c) `onPoisonRethrow` poison c - --- | For the duration of the given process, acts as a consume process, but stops --- when the given process stops. Note that there could be a timing issue where --- extra inputs are consumed at the end of the lifetime of the process. --- Note also that while poison from the given process will be propagated on the --- consumption channel, there is no mechanism to propagate poison from the consumption --- channel into the given process. --- --- Added in version 1.2.0. -consumeAlongside :: Chanin a -> CHP b -> CHP b -consumeAlongside in_ proc - = do c <- oneToOneChannel' $ chanLabel "consumeAlongside-Internal" - (x,_) <- - ((do x <- proc - writeChannel (writer c) () - return x - ) `onPoisonRethrow` poison (writer c)) - <||> - (inner (reader c) `onPoisonRethrow` poison (reader c)) - return x - where - inner c = do cont <- alt - [readChannel c >> return False - ,readChannel in_ >> return True - ] - if cont - then inner c - else return () - --- | Forever reads a value from both its input channels in parallel, then joins --- the two values using the given function and sends them out again. For example, --- @join (,) c d@ will pair the values read from @c@ and @d@ and send out the --- pair on the output channel, whereas @join (&&)@ will send out the conjunction --- of two boolean values, @join (==)@ will read two values and output whether --- they are equal or not, etc. -join :: (a -> b -> c) -> Chanin a -> Chanin b -> Chanout c -> CHP () -join f in0 in1 out = (forever $ do - [Prelude.Left x, Prelude.Right y] <- runParallel - [liftM Prelude.Left $ readChannel in0, liftM Prelude.Right $ readChannel in1] - writeChannel out $ f x y - ) `onPoisonRethrow` (poison in0 >> poison in1 >> poison out) - --- | Forever reads a value from all its input channels in parallel, then joins --- the values into a list in the same order as the channels, and sends them out again. -joinList :: [Chanin a] -> Chanout [a] -> CHP () -joinList ins out = (forever $ runParMapM readChannel ins >>= writeChannel out - ) `onPoisonRethrow` (poisonAll ins >> poison out) - - --- | Forever reads a pair from its input channel, then in parallel sends out --- the first and second parts of the pair on its output channels. --- --- Added in version 1.0.2. -split :: Chanin (a, b) -> Chanout a -> Chanout b -> CHP () -split in_ outA outB = (forever $ do - (a, b) <- readChannel in_ - writeChannel outA a <||> writeChannel outB b - ) `onPoisonRethrow` (poison in_ >> poison outA >> poison outB) - --- | A sorter process. When it receives its first @Just x@ data item, it keeps --- it. When it receieves a second, it keeps the lowest of the two, and sends --- out the other one. When it receives Nothing, it sends out its data value, --- then sends Nothing too. The overall effect when chaining these things together --- is a sorting pump. You inject all the values with Just, then send in a --- single Nothing to get the results out (in reverse order). -sorter :: Ord a => Chanin (Maybe a) -> Chanout (Maybe a) -> CHP () -sorter = sorter' (<) - --- | Like sorter, but with a custom comparison method. You should pass in --- the equivalent of less-than: (<). -sorter' :: forall a. (a -> a -> Bool) -> Chanin (Maybe a) -> Chanout (Maybe a) -> CHP () -sorter' lt in_ out = internal Nothing `onPoisonRethrow` (poison in_ >> poison out) - where - internal :: Maybe a -> CHP () - internal curVal = do newVal <- readChannel in_ - case (curVal, newVal) of - -- Flush, but we're empty: - (Nothing, Nothing) -> do writeChannel out newVal - internal curVal - -- Flush: - (Just _, Nothing) -> do writeChannel out curVal - writeChannel out newVal - internal curVal - -- New value, we were empty: - (Nothing, Just _) -> internal newVal - -- New value, we had one already: - (Just cur, Just new) - | new `lt` cur -> do writeChannel out curVal - internal newVal - | otherwise -> do writeChannel out newVal - internal curVal - --- | A shared variable process. Given an initial value and two channels, it --- continually offers to output its current value or read in a new one. --- --- Added in version 1.1.1 --- --- Note that prior to version 1.2.0 (i.e. in version 1.1.1) there was a bug where --- poison would not be propagated between the input and output. -valueStore :: (ReadableChannel r, Poisonable (r a), - WriteableChannel w, Poisonable (w a)) => - a -> r a -> w a -> CHP () -valueStore val input output - = inner val `onPoisonRethrow` (poison input >> poison output) - where - inner x = ((writeChannel output x >> return x) <-> readChannel input) >>= inner - --- | A shared variable process. The same as valueStore, but initially waits --- to read its starting value before then offering to either output its current --- value or read in a new one. --- --- Added in version 1.1.1 --- --- Note that prior to version 1.2.0 (i.e. in version 1.1.1) there was a bug where --- poison would not be propagated between the input and output. -valueStore' :: (ReadableChannel r, Poisonable (r a), - WriteableChannel w, Poisonable (w a)) => r a -> w a -> CHP () -valueStore' input output - = (readChannel input >>= \x -> valueStore x input output) - `onPoisonRethrow` (poison input >> poison output) - --- | Continually waits for a specific time on the given clock, each time applying --- the function to work out the next specific time to wait for. The most common --- thing to pass is Prelude.succ or (+1). --- --- Added in version 1.2.0. -advanceTime :: (Waitable c, Ord t) => (t -> t) -> Enrolled c t -> CHP () -advanceTime f c = do t <- getCurrentTime c - inner (f t) - where - inner t = wait c (Just t) >>= inner . f diff --git a/Control/Concurrent/CHP/Connect.hs b/Control/Concurrent/CHP/Connect.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Connect.hs +++ /dev/null @@ -1,232 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2008--2009, 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 of operators for connecting processes together. --- --- This whole module was added in version 1.7.0. -module Control.Concurrent.CHP.Connect - (Connectable(..), (<=>), (|<=>), (<=>|), (|<=>|), pipelineConnect, pipelineConnectComplete, - pipelineConnectCompleteT, cycleConnect, connectList, connectList_, ChannelPair, - ConnectableExtra(..), connectWith) where - -import Control.Applicative -import Control.Arrow - -import Control.Concurrent.CHP - --- | Like 'Connectable', but allows an extra parameter. --- --- The API (and name) for this is still in flux, so do not rely on it just yet. -class ConnectableExtra l r where - type ConnectableParam l - -- | Runs the given code with the two items connected. - connectExtra :: ConnectableParam l -> ((l, r) -> CHP ()) -> CHP () - --- | Indicates that its two parameters can be joined together automatically. --- --- Rather than use 'connect' directly, you will want to use the operators such --- as '(<=>)'. There are different forms of this operator for in the middle of --- a pipeline (where you still need further parameters to each process), and at --- the ends. See also 'pipelineConnect' and 'pipelineConnectComplete'. -class Connectable l r where - -- | Runs the given code with the two items connected. - -- - -- The type of this function was generalised in CHP 1.8.0 - -- from @((l, r) -> CHP ()) -> CHP ()@ to @((l, r) -> CHP a) -> CHP a@ - connect :: ((l, r) -> CHP a) -> CHP a - --- | A pair of channels. The main use of this type is with the Connectable class, --- as it allows you to wire together two processes that take the exact same channel --- pair, e.g. both are of type @ChannelPair (Chanin Int) (Chanout Int) -> CHP ()@. With the --- normal Connectable pair instances, one would need to be of type @(Chanin Int, --- Chanout Int) -> CHP ()@, and the other of type @(Chanout Int, Chanin Int) -> --- CHP ()@. -data ChannelPair l r = ChannelPair l r - deriving (Eq, Show) - -instance Connectable l r => Connectable (ChannelPair l r) (ChannelPair l r) where - connect f = connect $ \(lx, rx) -> connect $ \(ly, ry) -> - f (ChannelPair lx ry, ChannelPair ly rx) - --- | Like 'connect', but provides the process a list of items of the specified size, --- and runs it. --- --- This function was added in version 1.8.0. -connectList :: Connectable l r => Int -> ([(l, r)] -> CHP a) -> CHP a -connectList n p | n == 0 = p [] - | n > 0 = connect $ \lr -> connectList (n - 1) $ p . (lr :) - | otherwise = error $ "Control.Concurrent.CHP.Connect.connectList: negative parameter " ++ show n - --- | Like 'connectList' but ignores the results. --- --- This function was added in version 1.8.0. -connectList_ :: Connectable l r => Int -> ([(l, r)] -> CHP a) -> CHP () -connectList_ n p | n == 0 = p [] >> return () - | n > 0 = connect $ \lr -> connectList_ (n - 1) $ p . (lr :) - | otherwise = error $ "Control.Concurrent.CHP.Connect.connectList_: negative parameter " ++ show n - --- | Joins together the given two processes and runs them in parallel. -(|<=>|) :: Connectable l r => (l -> CHP ()) -> (r -> CHP ()) -> CHP () -(|<=>|) p q = connect $ \(x, y) -> p x <|*|> q y - -jpo :: ConnectableExtra l r => ConnectableParam l -> (l -> CHP ()) -> (r -> CHP ()) -> CHP () -jpo o p q = connectExtra o $ \(x, y) -> p x <|*|> q y - --- | Joins together the given two processes and runs them in parallel. -(<=>) :: Connectable l r => (a -> l -> CHP ()) -> (r -> b -> CHP ()) -> a -> b -> CHP () -(<=>) p q x y = p x |<=>| flip q y - --- | Joins together the given two processes and runs them in parallel. -(<=>|) :: Connectable l r => (a -> l -> CHP ()) -> (r -> CHP ()) -> a -> CHP () -(<=>|) p q x = p x |<=>| q - --- | Joins together the given two processes and runs them in parallel. -(|<=>) :: Connectable l r => (l -> CHP ()) -> (r -> b -> CHP ()) -> b -> CHP () -(|<=>) p q x = p |<=>| flip q x - --- | Like '(<=>)' but with 'ConnectableExtra' -connectWith :: ConnectableExtra l r => ConnectableParam l -> - (a -> l -> CHP ()) -> (r -> b -> CHP ()) -> a -> b -> CHP () -connectWith o p q x y = jpo o (p x) (flip q y) - --- | Like @foldl1 (<=>)@; connects a pipeline of processes together. If the list --- is empty, it returns a process that ignores both its arguments and returns instantly. -pipelineConnect :: Connectable l r => [r -> l -> CHP ()] -> r -> l -> CHP () -pipelineConnect [] = const . const $ return () -pipelineConnect ps = foldl1 (<=>) ps - --- | Connects the given beginning process, the list of middle processes, and --- the end process into a pipeline and runs them all in parallel. If the list --- is empty, it connects the beginning directly to the end. -pipelineConnectComplete :: Connectable l r => - (l -> CHP ()) -> [r -> l -> CHP ()] -> (r -> CHP ()) -> CHP () -pipelineConnectComplete begin middle end - = (foldl (|<=>) begin middle) |<=>| end - --- | Like 'pipelineConnectComplete' but allows a customised function to run all --- the processes in parallel. So @pipelineConnectCompleteT runParallel@ is the --- same as @pipelineConnectComplete@. The list of items given to the first function --- will be in the order: begin process, middle processes, end process, as you would --- expect. --- --- This function was added in version 1.8.0. -pipelineConnectCompleteT :: Connectable l r => - ([a] -> CHP b) -> (l -> a) -> [r -> l -> a] -> (r -> a) -> CHP b -pipelineConnectCompleteT run begin [] end - = connect $ \(l, r) -> run [begin l, end r] -pipelineConnectCompleteT run begin (p:ps) end - = connect $ \(l, r) -> - pipelineConnectCompleteT (run . (begin l :)) (p r) ps end - --- | Like 'pipelineConnect' but also connects the last process into the first. --- If the list is empty, it returns immediately. -cycleConnect :: Connectable l r => [r -> l -> CHP ()] -> CHP () -cycleConnect [] = return () -cycleConnect ps = connect . uncurry . flip . pipelineConnect $ ps - -instance Connectable (Chanout a) (Chanin a) where - connect = (>>=) ((writer &&& reader) <$> oneToOneChannel) -instance ConnectableExtra (Chanout a) (Chanin a) where - type ConnectableParam (Chanout a) = ChanOpts a - connectExtra o = (>>=) ((writer &&& reader) <$> oneToOneChannel' o) - -instance Connectable (Chanin a) (Chanout a) where - connect = (>>=) ((reader &&& writer) <$> oneToOneChannel) -instance ConnectableExtra (Chanin a) (Chanout a) where - type ConnectableParam (Chanin a) = ChanOpts a - connectExtra o = (>>=) ((reader &&& writer) <$> oneToOneChannel' o) - -instance Connectable (Enrolled PhasedBarrier ()) (Enrolled PhasedBarrier ()) where - connect m = do b <- newBarrier - enroll b $ \b0 -> enroll b $ \b1 -> m (b0, b1) - -instance ConnectableExtra (Enrolled PhasedBarrier ph) (Enrolled PhasedBarrier ph) where - type ConnectableParam (Enrolled PhasedBarrier ph) = (ph, BarOpts ph) - connectExtra (ph, o) m - = do b <- newPhasedBarrier' ph o - enroll b $ \b0 -> enroll b $ \b1 -> m (b0, b1) - - -instance (Connectable al ar, Connectable bl br) => Connectable (al, bl) (ar, br) where - connect m = connect $ \(ax, ay) -> connect $ \(bx, by) -> m ((ax, bx), (ay, by)) -instance (ConnectableExtra al ar, ConnectableExtra bl br) => ConnectableExtra (al, bl) (ar, br) where - type ConnectableParam (al, bl) = (ConnectableParam al, ConnectableParam bl) - connectExtra (ao, bo) m = connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) -> m ((ax, bx), (ay, by)) - -instance (Connectable al ar, Connectable bl br, Connectable cl cr) => - Connectable (al, bl, cl) (ar, br, cr) where - connect m = connect $ \(ax, ay) -> connect $ \(bx, by) -> - connect $ \(cx, cy) -> m ((ax, bx, cx), (ay, by, cy)) - -instance (ConnectableExtra al ar, ConnectableExtra bl br, ConnectableExtra cl cr) => - ConnectableExtra (al, bl, cl) (ar, br, cr) where - type ConnectableParam (al, bl, cl) = (ConnectableParam al, ConnectableParam bl, ConnectableParam cl) - connectExtra (ao, bo, co) m - = connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) -> - connectExtra co $ \(cx, cy) -> m ((ax, bx, cx), (ay, by, cy)) - -instance (Connectable al ar, Connectable bl br, Connectable cl cr, - Connectable dl dr) => - Connectable (al, bl, cl, dl) (ar, br, cr, dr) where - connect m = connect $ \(ax, ay) -> connect $ \(bx, by) -> - connect $ \(cx, cy) -> connect $ \(dx, dy) -> - m ((ax, bx, cx, dx), (ay, by, cy, dy)) -instance (ConnectableExtra al ar, ConnectableExtra bl br, ConnectableExtra cl cr, - ConnectableExtra dl dr) => - ConnectableExtra (al, bl, cl, dl) (ar, br, cr, dr) where - type ConnectableParam (al, bl, cl, dl) - = (ConnectableParam al, - ConnectableParam bl, - ConnectableParam cl, - ConnectableParam dl) - connectExtra (ao, bo, co, do_) m - = connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) -> - connectExtra co $ \(cx, cy) -> connectExtra do_ $ \(dx, dy) -> - m ((ax, bx, cx, dx), (ay, by, cy, dy)) - -instance (Connectable al ar, Connectable bl br, Connectable cl cr, - Connectable dl dr, Connectable el er) => - Connectable (al, bl, cl, dl, el) (ar, br, cr, dr, er) where - connect m = connect $ \(ax, ay) -> connect $ \(bx, by) -> - connect $ \(cx, cy) -> connect $ \(dx, dy) -> - connect $ \(ex, ey) -> m ((ax, bx, cx, dx, ex), (ay, by, cy, dy, ey)) -instance (ConnectableExtra al ar, ConnectableExtra bl br, ConnectableExtra cl cr, - ConnectableExtra dl dr, ConnectableExtra el er) => - ConnectableExtra (al, bl, cl, dl, el) (ar, br, cr, dr, er) where - type ConnectableParam (al, bl, cl, dl, el) - = (ConnectableParam al, - ConnectableParam bl, - ConnectableParam cl, - ConnectableParam dl, - ConnectableParam el) - connectExtra (ao, bo, co, do_, eo) m - = connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) -> - connectExtra co $ \(cx, cy) -> connectExtra do_ $ \(dx, dy) -> - connectExtra eo $ \(ex, ey) -> m ((ax, bx, cx, dx, ex), (ay, by, cy, dy, ey)) - diff --git a/Control/Concurrent/CHP/Connect/TwoDim.hs b/Control/Concurrent/CHP/Connect/TwoDim.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Connect/TwoDim.hs +++ /dev/null @@ -1,231 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2008--2009, 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 helper functions for wiring up collections of processes --- into a two-dimensional arrangement. --- --- This module was added in version 1.8.0. -module Control.Concurrent.CHP.Connect.TwoDim - (FourWay(..), wrappedGridFour, wrappedGridFour_, - FourWayDiag(..), EightWay, wrappedGridEight, wrappedGridEight_) where - -import Control.Arrow -import Control.Concurrent.CHP -import Control.Concurrent.CHP.Connect -import Control.Monad -import Data.List - -import Prelude hiding (abs) - --- | A data type representing four-way connectivity for a process, with channels --- to the left and right, above and below. -data FourWay above below left right - = FourWay { above :: above, below :: below, left :: left, right :: right } - deriving (Eq) - --- | A data type representing four-way diagonal connectivity for a process, with --- channels above-left, below-right, above-right and below-left. -data FourWayDiag aboveLeft belowRight aboveRight belowLeft - = FourWayDiag { aboveLeft :: aboveLeft, belowRight :: belowRight, aboveRight :: aboveRight, belowLeft :: belowLeft } - deriving (Eq) - --- | EightWay is simply a synonym for a pair of 'FourWay' and 'FourWayDiag'. -type EightWay a b l r al br ar bl = (FourWay a b l r, FourWayDiag al br ar bl) - --- | Wires the given grid of processes (that require four-way connectivity) together --- into a wrapped around grid (a torus) and runs them all in parallel. --- --- The parameter is a list of rows, and should be rectangular (i.e. all the rows --- should be the same length). If not, an error will result. The return value --- is guaranteed to be the same shape as the input. --- --- It is worth remembering that if you have only one row or one column (or --- both), processes can be connected to themselves, so make sure that if a --- process is connected to itself (e.g. its left channel connects to its right --- channel), it is coded such that it won't deadlock -- or if needed, checks for this --- possibility using 'sameChannel'. Processes may also be connected to each other --- multiple times -- in a two-wide grid, each process's left channel connects to --- the same process as its right. -wrappedGridFour :: (Connectable above below, Connectable left right) => - [[FourWay above below left right -> CHP a]] -> CHP [[a]] -wrappedGridFour ps - -- If ps == [], this will succeed, and map connectRowCycle ps will be [], - -- and thus connectColumnsCycle _ [] will return [] (without forcing the - -- head call), and it will all work correctly. - | length (nub $ map length ps) <= 1 - = connectColumnsCycle (length (head ps)) $ map connectRowCycle ps - | otherwise - = error $ "Control.Concurrent.CHP.Connect.TwoDim.wrappedGrid: Non-rectangular input " - ++ " height: " ++ show (length ps) ++ " widths: " ++ show (map length ps) - --- | Like 'wrappedGridFour' but discards the return values. -wrappedGridFour_ :: (Connectable above below, Connectable left right) => - [[FourWay above below left right -> CHP a]] -> CHP () -wrappedGridFour_ ps = wrappedGridFour ps >> return () --TODO fix this - --- | Like 'wrappedGridFour' but provides eight-way connectivity. --- --- The note on 'wrappedGridFour' about processes being connected to themselves --- applies here too -- as does the note about processes being connected to --- each other multiple times. If you have one row, a process's left, --- above-left and below-left channels all connect to the same process. If you --- have a two-by-two grid, a process's four diagonal channels all connect to --- the same process. -wrappedGridEight :: (Connectable above below, Connectable left right, - Connectable aboveLeft belowRight, Connectable belowLeft aboveRight) => - [[EightWay above below left right aboveLeft belowRight aboveRight belowLeft -> CHP a]] -> CHP [[a]] -wrappedGridEight ps - | length (nub $ map length ps) <= 1 - = connectColumnsCycleDiag (length (head ps)) $ map connectRowCycleDiag ps - | otherwise - = error $ "Control.Concurrent.CHP.Connect.TwoDim.wrappedGridDiag: Non-rectangular input " - ++ " height: " ++ show (length ps) ++ " widths: " ++ show (map length ps) - --- | Like 'wrappedGridEight' but discards the output. -wrappedGridEight_ :: (Connectable above below, Connectable left right, - Connectable aboveLeft belowRight, Connectable belowLeft aboveRight) => - [[EightWay above below left right aboveLeft belowRight aboveRight belowLeft -> CHP a]] -> CHP () -wrappedGridEight_ ps = wrappedGridEight ps >> return () - - -connectRowCycle :: Connectable left right => - [FourWay above below left right -> CHP a] -> ([(above, below)] -> CHP [a]) -connectRowCycle [] _ = return [] -connectRowCycle allps abs = connect $ - foldr connLR - -- The last process is special because it must take both channels for itself: - (liftM (:[]) . last allps . uncurry (uncurry FourWay $ last abs)) - (zip (init allps) (init abs)) - -connLR :: Connectable left right => - (FourWay above below left right -> CHP a, (above, below)) - -> ((left, right) -> CHP [a]) - -> ((left, right) -> CHP [a]) -connLR (p, (a, b)) q (l, r) - = liftM (uncurry (:)) . connect $ \(l', r') -> p (FourWay a b l r') <||> q (l', r) - -connectColumnsCycle :: Connectable above below => Int -> [[(above, below)] -> CHP [a]] -> CHP [[a]] -connectColumnsCycle _ [] = return [] -connectColumnsCycle n ps = connectList n $ foldl1 (connAB n) (map (liftM (:[]) .) ps) - -connAB :: Connectable above below => Int -> ([(above, below)] -> CHP [a]) -> ([(above, below)] -> CHP [a]) -> ([(above, below)] -> CHP [a]) -connAB n p q abs = liftM (uncurry (++)) $ connectList n $ \abs' -> p (zip (map fst abs) (map snd abs')) - <||> q (zip (map fst abs') (map snd abs)) - -connectColumnsCycleDiag :: (Connectable a b, Connectable bl ar, Connectable al br) => - Int -> [[((a, b), FourWayDiag al br ar bl)] -> CHP [z]] -> CHP [[z]] -connectColumnsCycleDiag _ [] = return [] -connectColumnsCycleDiag n ps = connectList n $ \abs -> - connectList n $ \leadingDiag -> connectList n $ \otherDiag -> - foldl1 (connABDiag n) (map (liftM (:[]) .) ps) - $ zip abs [FourWayDiag al br ar bl - | (_, ar) <- otherDiag - | (bl, _) <- shiftRight otherDiag - | (al, _) <- leadingDiag - | (_, br) <- shiftLeft leadingDiag] - --- Let's imagine we have a square: --- --- A B C --- D E F --- G H I --- --- We pass in the outer-most channels as the processes need them to be wired. --- --- So for example, A will recieve: --- aboveLeft: AI --- aboveRight AH --- belowLeft: AF --- belowRight: AE --- --- So for example when we create the leadingDiag channels: --- --- \1 \2 \3 --- A B C --- --- The ends are passed to the above channels as-is, but to the below channels shifted lleft: --- --- G H I --- \2 \3 \1 --- --- For the otherDiag, shifted right when below: --- --- /1 /2 /3 --- A B C --- --- G H I --- /3 /1 /2 - -shiftLeft, shiftRight :: [a] -> [a] -shiftLeft [] = [] -shiftLeft xs = tail xs ++ [head xs] -shiftRight [] = [] -shiftRight xs = last xs : init xs - -connABDiag :: (Connectable above below, Connectable al br, Connectable bl ar) => - Int -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a]) - -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a]) - -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a]) -connABDiag n p q abs = liftM (uncurry (++)) $ connectList n $ \abs' -> - connectList n $ \leadingDiag -> connectList n $ \otherDiag -> - p [((a, b), FourWayDiag al br ar bl) - | ((a, _), _) <- abs - | (_, b) <- abs' - | (_, FourWayDiag al _ ar _) <- abs - | (bl, _) <- shiftRight otherDiag - | (_, br) <- shiftLeft leadingDiag - ] - <||> - q [((a, b), FourWayDiag al br ar bl) - | ((_, b), _) <- abs - | (a, _) <- abs' - | (al, _) <- leadingDiag - | (_, ar) <- otherDiag - | (_, FourWayDiag _ br _ bl) <- abs - ] --- We are given our own above and below as we need them to be arranged already. - - -connectRowCycleDiag :: Connectable l r => - [EightWay a b l r al br ar bl -> CHP z] - -> ([((a, b), FourWayDiag al br ar bl)] -> CHP [z]) -connectRowCycleDiag [] _ = return [] -connectRowCycleDiag allps abs = connect $ - foldr connLRDiag - -- The last process is special because it must take both channels for itself: - (\lr -> liftM (:[]) $ last allps $ first (($ lr) . uncurry . uncurry FourWay) (last abs)) - (zip (init allps) (init abs)) - - -connLRDiag :: Connectable l r => - (EightWay a b l r al br ar bl -> CHP z, ((a, b), FourWayDiag al br ar bl)) - -> ((l, r) -> CHP [z]) - -> ((l, r) -> CHP [z]) -connLRDiag (p, ((a, b), diag)) q (l, r) - = liftM (uncurry (:)) . connect $ \(l', r') -> p (FourWay a b l r', diag) <||> q (l', r) diff --git a/Control/Concurrent/CHP/Console.hs b/Control/Concurrent/CHP/Console.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Console.hs +++ /dev/null @@ -1,114 +0,0 @@ --- 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. - --- | Contains a process for easily using stdin, stdout and stderr as channels. -module Control.Concurrent.CHP.Console where - -import Control.Concurrent -import Control.Concurrent.STM -import qualified Control.Exception.Extensible as C -import Control.Monad -import Control.Monad.Trans ---import Data.Maybe -import System.IO - -import Control.Concurrent.CHP - --- | A set of channels to be given to the process to run, containing channels --- for stdin, stdout and stderr. -data ConsoleChans = ConsoleChans { cStdin :: Chanin Char, cStdout :: Chanout - Char, cStderr :: Chanout Char } - --- | A function for running the given CHP process that wants console channels. --- When your program finishes, the console channels are automatically poisoned, --- but it's good practice to poison them yourself when you finish. Only ever --- run one of these processes at a time, or undefined behaviour will result. --- --- When using this process, due to the way that the console handlers are terminated, --- you may sometimes see a notice that a thread was killed. This is normal behaviour --- (unfortunately). -consoleProcess :: (ConsoleChans -> CHP ()) -> CHP () -consoleProcess mainProc - = do [cin, cout, cerr] <- replicateM 3 oneToOneChannel - tvs@[tvinId, tvoutId, tverrId] <- liftIO $ atomically $ replicateM 3 $ newTVar Nothing - runParallel_ - [ inHandler tvinId (writer cin) - , outHandler tvoutId stdout (reader cout) - , outHandler tverrId stderr (reader cerr) - , do ids <- mapM getId tvs - (mainProc $ ConsoleChans (reader cin) (writer cout) (writer cerr)) - `onPoisonTrap` (return ()) - poison (reader cin) - poison (writer cout) - poison (writer cerr) - -- Poison won't do it if the handlers are blocked on input or - -- output. Therefore we throw them an exception to "knock them - -- off" their current action and make them exit. - liftIO yield - liftIO $ mapM_ killThread ids - ] - where - getId :: TVar (Maybe a) -> CHP a - getId tv = liftIO $ atomically $ readTVar tv >>= maybe retry return - - -- Like liftIO, but turns any caught exceptions into throwing poison - liftIO' :: IO a -> CHP a - liftIO' m = liftIO (liftM Just m `C.catches` handlers) - >>= maybe throwPoison return - where - response :: C.Exception e => e -> IO (Maybe a) - response = const $ return Nothing - - handlers = [C.Handler (response :: C.IOException -> IO (Maybe a)) - ,C.Handler (response :: C.AsyncException -> 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)) - ] - - inHandler :: TVar (Maybe ThreadId) -> Chanout Char -> CHP () - inHandler tv c - = do liftIO $ myThreadId >>= atomically . writeTVar tv . Just - if rtsSupportsBoundThreads - then (forever $ do ready <- liftIO $ hWaitForInput stdin 100 - checkForPoison c - when ready $ - liftIO' getChar >>= writeChannel c) - `onPoisonTrap` (poison c) - else (forever $ liftIO' getChar >>= writeChannel c) - `onPoisonTrap` (poison c) - - outHandler :: TVar (Maybe ThreadId) -> Handle -> Chanin Char -> CHP () - outHandler tv h c - = do liftIO $ myThreadId >>= atomically . writeTVar tv . Just - (forever $ readChannel c >>= liftIO' . hPutChar h) - `onPoisonTrap` (poison c) diff --git a/Control/Concurrent/CHP/Enroll.hs b/Control/Concurrent/CHP/Enroll.hs --- a/Control/Concurrent/CHP/Enroll.hs +++ b/Control/Concurrent/CHP/Enroll.hs @@ -74,7 +74,7 @@ -- | Like 'enroll' but enrolls on the given list of barriers enrollList :: Enrollable b p => [b p] -> ([Enrolled b p] -> CHP a) -> CHP a enrollList [] f = f [] -enrollList (b:bs) f = enroll b $ \eb -> enrollList bs $ \ebs -> f (eb:ebs) +enrollList (b:bs) f = enroll b $ \eb -> enrollList bs $ f . (eb:) -- | Given a command to allocate a new barrier, and a list of processes that use -- that barrier, enrolls the appropriate number of times (i.e. the list length) diff --git a/Control/Concurrent/CHP/Event.hs b/Control/Concurrent/CHP/Event.hs --- a/Control/Concurrent/CHP/Event.hs +++ b/Control/Concurrent/CHP/Event.hs @@ -31,7 +31,11 @@ module Control.Concurrent.CHP.Event (RecordedEventType(..), Event, getEventUnique, SignalVar, SignalValue(..), enableEvents, disableEvents, newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison, - testAll, getEventTypeVal) where + getEventTypeVal +#ifdef CHP_TEST + , testAll +#endif + ) where import Control.Arrow import Control.Concurrent.STM @@ -44,8 +48,9 @@ import qualified Data.Traversable as T import Data.Unique import Prelude hiding (seq) +#ifdef CHP_TEST import Test.HUnit hiding (test) - +#endif import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.ProcessId @@ -364,8 +369,8 @@ -- one: (if Map.size (unionAll otherEvents) == 1 then next - else (next ++ zip (repeat $ return ()) - (Map.keys $ unionAll otherEvents))) + else next ++ zip (repeat $ return ()) + (Map.keys $ unionAll otherEvents)) else -- No way it could be ready, so ignore it: discoverRelatedOffersAll a next @@ -427,7 +432,7 @@ PoisonItem -> return PoisonItem NoPoison (count, seq, offers) -> do writeTVar (getEventTVar e) $ NoPoison (count - 1, seq, offers) - if (count - 1 == length offers) + if count - 1 == length offers then liftM (fmap $ \mu -> [((r,u),pids) | (u,(r,pids)) <- Map.toList mu]) $ discoverAndResolve $ Right e else return $ NoPoison [] @@ -558,11 +563,11 @@ -- Testing: ---------------------------------------------------------------------- ---------------------------------------------------------------------- - +#ifdef CHP_TEST -- Tests if two lists have the same elements, but not necessarily in the same order: (**==**) :: Eq a => [a] -> [a] -> Bool -a **==** b = (length a == length b) && (null $ a \\ b) +a **==** b = (length a == length b) && null (a \\ b) (**/=**) :: Eq a => [a] -> [a] -> Bool a **/=** b = not $ a **==** b @@ -655,7 +660,7 @@ {- Offers: -} [ [(Bool, [Int]) {- events -}]] -> {-Starting events:-} [Int] -> IO () test testName eventCounts offerSets startEvents = do (events, realOffers) <- makeTestEvents (map fst eventCounts) (map (map snd) offerSets) - let expectedResult' = NoPoison $ + let expectedResult' = NoPoison ([OfferSet (tv,pid,[off | (m,off) <- zip [0..] offs, fst $ offerSets !! n !! m]) | (n,OfferSet (tv,pid,offs)) <- zip [0..] realOffers] ,Set.fromList [events !! n @@ -854,4 +859,8 @@ | (n,(NoPoison count, st)) <- zip [0..] eventCounts] uncurry (assertEqual testName) (unzip $ catMaybes c) - showStuff = show . fmap (map (\(u,x) -> (hashUnique u, x)) . Map.toList) + showStuff = show . fmap (map (first hashUnique) . Map.toList) + +#endif +-- CHP_TEST + diff --git a/Control/Concurrent/CHP/Guard.hs b/Control/Concurrent/CHP/Guard.hs --- a/Control/Concurrent/CHP/Guard.hs +++ b/Control/Concurrent/CHP/Guard.hs @@ -30,6 +30,7 @@ module Control.Concurrent.CHP.Guard where import Control.Concurrent.STM +import Control.Monad import Control.Monad.Trans import qualified Data.Map as Map import Data.Monoid @@ -78,8 +79,7 @@ = TimeoutGuard $ do signalDone <- liftIO $ registerDelay n return $ do b <- readTVar signalDone - if b == False - then retry - else return () + when (not b) retry + diff --git a/Control/Concurrent/CHP/Monad.hs b/Control/Concurrent/CHP/Monad.hs --- a/Control/Concurrent/CHP/Monad.hs +++ b/Control/Concurrent/CHP/Monad.hs @@ -36,9 +36,6 @@ onPoisonTrap, onPoisonRethrow, throwPoison, Poisonable(..), poisonAll, - -- * LoopWhileT Monad - LoopWhileT, loop, while, - -- * Primitive actions skip, stop, waitFor ) where @@ -92,48 +89,6 @@ -- | A convenient version of embedCHP1 that ignores the result embedCHP1_ :: (a -> CHP b) -> CHP (a -> IO ()) embedCHP1_ = liftM (\m x -> m x >> return ()) . embedCHP1 - - --- | 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 - --- | 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 diff --git a/Control/Concurrent/CHP/Mutex.hs b/Control/Concurrent/CHP/Mutex.hs --- a/Control/Concurrent/CHP/Mutex.hs +++ b/Control/Concurrent/CHP/Mutex.hs @@ -35,7 +35,7 @@ type Mutex = MVar () claimMutex :: MonadIO m => Mutex -> m () -claimMutex m = liftIO $ takeMVar m +claimMutex = liftIO . takeMVar newMutex :: MonadIO m => m Mutex newMutex = liftIO $ newMVar () diff --git a/Control/Concurrent/CHP/Parallel.hs b/Control/Concurrent/CHP/Parallel.hs --- a/Control/Concurrent/CHP/Parallel.hs +++ b/Control/Concurrent/CHP/Parallel.hs @@ -179,6 +179,6 @@ r <- wrapProcess p $ flip runReaderT blank . pullOutStandard C.block $ atomically $ do (poisonedAlready, n) <- readTVar b - writeTVar b $ (poisonedAlready || isNothing r, n - 1) + writeTVar b (poisonedAlready || isNothing r, n - 1) return () diff --git a/Control/Concurrent/CHP/Test.hs b/Control/Concurrent/CHP/Test.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Test.hs +++ /dev/null @@ -1,325 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2009, 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 some useful functions for testing CHP programs, both in --- the QuickCheck 2 framework and using HUnit. --- --- This whole module was added in version 1.4.0. -module Control.Concurrent.CHP.Test (QuickCheckCHP, qcCHP, qcCHP', propCHPInOut, testCHP, testCHPInOut, - testCHP', CHPTestResult(..), (=*=), CHPTest, withCheck, assertCHP, assertCHP', - assertCHPEqual, assertCHPEqual') where - -import Control.Arrow -import Control.Monad -import Control.Monad.Error (ErrorT, runErrorT, throwError) -import Control.Monad.Trans (MonadIO) -import Data.Maybe -import Data.Monoid -import Data.Unique -import Test.HUnit (assertFailure, Test(..)) -import Test.QuickCheck (Gen, forAll) -import Test.QuickCheck.Property (Property, Result(..), Testable(..), failed, succeeded, liftIOResult) -import Text.PrettyPrint.HughesPJ - -import Control.Concurrent.CHP -import Control.Concurrent.CHP.Traces - --- | A wrapper around the CHP type that supports some QuickCheck 'Testable' instances. --- See 'qcCHP' and 'qcCHP''. --- --- Added in version 1.5.0. -newtype QuickCheckCHP a = QCCHP (IO (Maybe a, Doc)) - --- | Turns a CHP program into a 'QuickCheckCHP' for use with 'Testable' instances. --- --- Equivalent to @qcCHP' . runCHP_CSPTrace@. --- --- Added in version 1.5.0. -qcCHP :: CHP a -> QuickCheckCHP a -qcCHP = qcCHP' . runCHP_CSPTrace - --- | Takes the command that runs a CHP program and gives back a 'QuickCheckCHP' --- item for use with 'Testable' instances. --- --- You use this function like: --- --- > qcCHP' (runCHP_CSPTrace p) --- --- To test process @p@ with a CSP trace if it fails. To turn off the display of --- tracing when a test fails, use: --- --- > qcCHP' (runCHP_TraceOff p) --- --- Added in version 1.5.0. -qcCHP' :: Trace t => IO (Maybe a, t Unique) -> QuickCheckCHP a -qcCHP' = QCCHP . liftM (second prettyPrint) - -qcResult :: IO (Maybe Result, Doc) -> Property -qcResult m = liftIOResult $ - do (mr, t) <- m - case mr of - Just r -> return $ r { reason = reason r ++ "; trace: " ++ show t } - Nothing -> return $ failed { reason = "QuickCheckCHP Failure (deadlock/uncaught poison); trace: " ++ show t } - -chpToQC :: CHPTestResult -> Result -chpToQC (CHPTestPass) = succeeded -chpToQC (CHPTestFail msg) = failed { reason = msg } - -boolToResult :: Bool -> Result -boolToResult b = if b then succeeded else failed - -instance Testable (QuickCheckCHP Bool) where - property (QCCHP x) = qcResult $ liftM (first $ fmap boolToResult) x - -instance Testable (QuickCheckCHP Result) where - property (QCCHP x) = qcResult x - -instance Testable (QuickCheckCHP CHPTestResult) where - property (QCCHP x) = qcResult $ liftM (first $ fmap chpToQC) x - - - --- | Tests a process that takes a single input and produces a single output, using --- QuickCheck. --- --- The first parameter is a pure function that takes the input to the process, --- the output the process gave back, and indicates whether this is okay (True = --- test pass, False = test fail). The second parameter is the process to test, --- and the third parameter is the thing to use to generate the inputs (passing 'arbitrary' --- is the simplest thing to do). --- --- Here are a couple of example uses: --- --- > propCHPInOut (==) Common.id (arbitrary :: Gen Int) --- --- > propCHPInOut (const $ (< 0)) (Common.map (negate . abs)) (arbitrary :: Gen Int) --- --- The test starts the process afresh each time, and shuts it down after the single --- output has been produced (by poisoning both its channels). Any poison from --- the process being tested after it has produced its output is consequently ignored, --- but poison instead of producing an output will cause a test failure. --- If the process does not produce an output or poison (for example if you test --- something like the Common.filter process), the test will deadlock. -propCHPInOut :: Show a => (a -> b -> Bool) -> (Chanin a -> Chanout b -> CHP ()) -> Gen a -> Property -propCHPInOut f p gen - = forAll gen $ \x -> qcCHP $ - do c <- oneToOneChannel - d <- oneToOneChannel - (_,r) <- (p (reader c) (writer d) - `onPoisonTrap` (poison (reader c) >> poison (writer d))) - <||> ((do writeChannel (writer c) x - y <- readChannel (reader d) - poison (writer c) >> poison (reader d) - return $ f x y - ) `onPoisonTrap` return False) - return r - --- | Takes a CHP program that returns a Bool (True = test passed, False = test --- failed) and forms it into an HUnit test. --- --- Note that if the program exits with poison, this is counted as a test failure. -testCHP :: CHP Bool -> Test -testCHP = TestCase . (>>= assertWithTrace) . runCHPAndTrace - where - assertWithTrace :: (Maybe Bool, CSPTrace Unique) -> IO () - assertWithTrace (Just True, _) = return () - assertWithTrace (Just False, t) = assertFailure $ "testCHP Failure; trace: " ++ show (prettyPrint t) - assertWithTrace (Nothing, t) = assertFailure $ "testCHP Failure (deadlock/uncaught poison); trace: " ++ show (prettyPrint t) - --- | A helper type for describing a more detailed result of a CHP test. You can --- construct these values manually, or using the '(=*=)' operator. --- --- Added in version 1.5.0. -data CHPTestResult = CHPTestPass | CHPTestFail String - -instance Monoid CHPTestResult where - mempty = CHPTestPass - mappend CHPTestPass y = y - mappend x _ = x - --- | Checks if two things are equal; passes the test if they are, otherwise fails --- and gives an error that shows the two things in question. --- --- Added in version 1.5.0. -(=*=) :: (Eq a, Show a) => a -> a -> CHPTestResult -(=*=) expected act - | expected == act = CHPTestPass - | otherwise = CHPTestFail $ "Expected: " ++ show expected ++ "; Actual: " ++ show act - --- | Like 'testCHP' but allows you to return the more descriptive 'CHPTestResult' --- type, rather than a plain Bool. --- --- Added in version 1.5.0. -testCHP' :: CHP CHPTestResult -> Test -testCHP' p = TestCase $ do (r, t) <- runCHP_CSPTrace p - case r of - Just CHPTestPass -> return () - Just (CHPTestFail s) -> assertFailure $ - s ++ "; trace: " ++ show t - Nothing -> assertFailure $ "testCHP' Failure (deadlock/uncaught poison); trace: " - ++ show t - --- | See withCheck. Added in version 1.5.0. -newtype CHPTest a = CHPTest (ErrorT String CHP a) - deriving (Monad, MonadIO, MonadCHP) - --- | A helper function that allows you to create CHP tests in an assertion style, either --- for use with HUnit or QuickCheck 2. --- --- Any poison thrown by the first argument (the left-hand side when this function --- is used infix) is trapped and ignored. Poison thrown by the second argument --- (the right-hand side when used infix) is counted as a test failure. --- --- As an example, imagine that you have a process that should repeatedly --- output the same value (42), called @myProc@. There are several ways to test --- this, but for the purposes of illustration we will start by testing the --- first two values: --- --- > myTest :: Test --- > myTest = testCHP' $ do --- > c <- oneToOneChannel --- > myProc (writer c) --- > `withCheck` do x0 <- liftCHP $ readChannel (reader c) --- > assertCHPEqual (poison (reader c)) "First value" 42 x0 --- > x1 <- liftCHP $ readChannel (reader c) --- > poison (reader c) -- Shutdown myProc --- > assertCHPEqual' "Second value" 42 x1 --- --- This demonstrates the typical pattern: a do block with some initialisation to --- begin with (creating channels, enrolling on barriers), then a withCheck call --- with the thing you want to test on the left-hand side, and the part doing the --- testing with the asserts on the right-hand side. Most CHP actions must be surrounded --- by 'liftCHP', and assertions can then be made about the values. --- --- Poison is used twice in our example. The assertCHPEqual function takes as a --- first argument the command to execute if the assertion fails. The problem --- is that if the assertion fails, the right-hand side will finish. But it is --- composed in parallel with the left-hand side, which does not know to finish --- (deadlock!). Thus we must pass a command to execute if the assertion fails --- that will shutdown the right-hand side. The second assertion doesn't need --- this, because by the time we make the assertion, we have already inserted --- the poison. Don't forget that you must poison to shut down the left-hand --- side if your test is successful or else you will again get deadlock. --- --- A better way to test this process is of course to read in a much larger number --- of samples and check they are all the same, for example: --- --- > myTest :: Test --- > myTest = testCHP' $ do --- > c <- oneToOneChannel --- > myProc (writer c) --- > `withCheck` do xs <- liftCHP $ replicateM 1000 $ readChannel (reader c) --- > poison (reader c) -- Shutdown myProc --- > assertCHPEqual' "1000 values" xs (replicate 1000 42) --- --- Added in version 1.5.0. -withCheck :: CHP a -> CHPTest () -> CHP CHPTestResult -withCheck p (CHPTest t) = liftM snd $ (p `onPoisonTrap` return undefined) <||> do - er <- runErrorT t - case er of - Left msg -> return $ CHPTestFail msg - Right _ -> return CHPTestPass - --- | Checks that the given Bool is True. If it is, the assertion passes and the --- test continues. If it is False, the given command is run (which should shut --- down the left-hand side of withCheck) and the test finishes, failing with the --- given String. --- --- Added in version 1.5.0. -assertCHP :: CHP () -> String -> Bool -> CHPTest () -assertCHP comp msg passed - | passed = return () - | otherwise = liftCHP comp >> CHPTest (throwError msg) - --- | Checks that the given values are equal (first is the expected value of the --- test, second is the actual value). If they are equal, the assertion passes and the --- test continues. If they are not equal, the given command is run (which should shut --- down the left-hand side of withCheck) and the test finishes, failing with the --- a message formed of the given String, and describing the two values. --- --- Added in version 1.5.0. -assertCHPEqual :: (Eq a, Show a) => CHP () -> String -> a -> a -> CHPTest () -assertCHPEqual comp msg expected act - = assertCHP comp - (msg ++ "; expected: " ++ show expected ++ "; actual: " ++ show act) - (expected == act) - --- | Like 'assertCHP' but issues no shutdown command. You should only use this --- function if you are sure that the left-hand side of withCheck has already completed. --- --- Added in version 1.5.0. -assertCHP' :: String -> Bool -> CHPTest () -assertCHP' = assertCHP (return ()) - --- | Like 'assertCHPEqual' but issues no shutdown command. You should only use this --- function if you are sure that the left-hand side of withCheck has already completed. --- --- Added in version 1.5.0. -assertCHPEqual' :: (Eq a, Show a) => String -> a -> a -> CHPTest () -assertCHPEqual' = assertCHPEqual (return ()) - --- | Tests a process that takes a single input and produces a single output, using --- HUnit. --- --- The first parameter is a pure function that takes the input to the process, --- the output the process gave back, and indicates whether this is okay (True = --- test pass, False = test fail). The second parameter is the process to test, --- and the third parameter is the input to send to the process. --- --- The intention is that you will either create several tests with the same first --- two parameters or use a const function as the first parameter. So for example, --- here is how you might test the identity process with several tests: --- --- > let check = testCHPInOut (==) Common.id --- > in TestList [check 0, check 3, check undefined] --- --- Whereas here is how you could test a slightly different process: --- --- > let check = testCHPInOut (const $ (< 0)) (Common.map (negate . abs)) --- > in TestList $ map check [-5..5] --- --- The test starts the process afresh each time, and shuts it down after the single --- output has been produced (by poisoning both its channels). Any poison from --- the process being tested after it has produced its output is consequently ignored, --- but poison instead of producing an output will cause a test failure. --- If the process does not produce an output or poison (for example if you test --- something like the Common.filter process), the test will deadlock. -testCHPInOut :: (a -> b -> Bool) -> (Chanin a -> Chanout b -> CHP ()) -> a -> Test -testCHPInOut f p x - = testCHP $ do c <- oneToOneChannel - d <- oneToOneChannel - liftM snd $ (p (reader c) (writer d) - `onPoisonTrap` (poison (reader c) >> poison (writer d))) - <||> ((do writeChannel (writer c) x - y <- readChannel (reader d) - poison (writer c) >> poison (reader d) - return $ f x y - ) `onPoisonTrap` return False) - - diff --git a/Control/Concurrent/CHP/Traces.hs b/Control/Concurrent/CHP/Traces.hs --- a/Control/Concurrent/CHP/Traces.hs +++ b/Control/Concurrent/CHP/Traces.hs @@ -151,7 +151,7 @@ | otherwise = c makeCont (StructuralSequence 0 _) _ = ContDone makeCont (StructuralSequence n es) pid - = mconcat (map (uncurry makeCont) $ zip es pidsPlusOne) + = mconcat (zipWith makeCont es pidsPlusOne) `mappend` makeCont (StructuralSequence (n-1) es) (last pidsPlusOne) where pidsPlusOne = take (1 + length es) $ iterate incPid pid @@ -160,7 +160,7 @@ where ParSeq p s = last ps makeCont (StructuralParallel es) pid - = mergePar (map (uncurry makeCont) $ zip es (parPids pid)) + = mergePar (zipWith makeCont es (parPids pid)) where parPids (ProcessId ps) = [ProcessId $ ps ++ [ParSeq i 0] | i <- [0..]] diff --git a/Control/Concurrent/CHP/Traces/Base.hs b/Control/Concurrent/CHP/Traces/Base.hs --- a/Control/Concurrent/CHP/Traces/Base.hs +++ b/Control/Concurrent/CHP/Traces/Base.hs @@ -115,8 +115,8 @@ nameEvent (t, c) = liftM (++ suffix) $ getName prefix c where (prefix, suffix) = case t of - ChannelComm x -> ("_c", if null x then "" else "." ++ x) - BarrierSync x -> ("_b", if null x then "" else "." ++ x) + ChannelComm x -> ("_c", if null x then "" else '.' : x) + BarrierSync x -> ("_b", if null x then "" else '.' : x) ClockSync st -> ("_t", ':' : st) nameEvent' :: Ord u => RecordedEvent u -> State (Map.Map u String) (RecordedEvent String) @@ -205,10 +205,10 @@ -- | Records an event where you were one of the people involved recordEvent :: [RecordedIndivEvent Unique] -> TraceT IO () -recordEvent e = ask >>= lift . mapSubTrace rec +recordEvent e = ask >>= lift . mapSubTrace recH where - rec (Hierarchy es) = modifyIORef es (addParEventsH (map StrEvent e)) - rec _ = return () + recH (Hierarchy es) = modifyIORef es (addParEventsH (map StrEvent e)) + recH _ = return () mergeSubProcessTraces :: [TraceStore] -> TraceT IO () mergeSubProcessTraces ts @@ -278,8 +278,7 @@ labelEvent :: Event -> String -> TraceT IO () -labelEvent e l - = labelUnique (getEventUnique e) l +labelEvent e = labelUnique (getEventUnique e) labelUnique :: Unique -> String -> TraceT IO () labelUnique u l diff --git a/Control/Concurrent/CHP/Traces/CSP.hs b/Control/Concurrent/CHP/Traces/CSP.hs --- a/Control/Concurrent/CHP/Traces/CSP.hs +++ b/Control/Concurrent/CHP/Traces/CSP.hs @@ -54,7 +54,7 @@ runCHPProgramWith' st (flip toPublic st) p prettyPrint (CSPTrace (labels, events)) - = char '<' <+> (sep $ punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>' + = char '<' <+> sep (punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>' labelAll (CSPTrace (labels, events)) = CSPTrace (Map.empty, evalState (mapM nameEvent' events) labels) @@ -79,6 +79,6 @@ runCHP_CSPTraceAndPrint :: CHP a -> IO () runCHP_CSPTraceAndPrint p = do (_, tr) <- runCHP_CSPTrace p - putStrLn $ show $ tr + putStrLn $ show tr diff --git a/Control/Concurrent/CHP/Traces/Structural.hs b/Control/Concurrent/CHP/Traces/Structural.hs --- a/Control/Concurrent/CHP/Traces/Structural.hs +++ b/Control/Concurrent/CHP/Traces/Structural.hs @@ -122,7 +122,7 @@ pp (StructuralSequence 1 es) = sep $ intersperse (text "->") $ map pp es pp (StructuralSequence n es) - = int n <> char '*' <> (parens $ sep $ + = int n <> char '*' <> parens (sep $ intersperse (text "->") $ map pp es) pp (StructuralParallel es) = parens $ sep $ intersperse (text "||") $ map pp es diff --git a/Control/Concurrent/CHP/Traces/VCR.hs b/Control/Concurrent/CHP/Traces/VCR.hs --- a/Control/Concurrent/CHP/Traces/VCR.hs +++ b/Control/Concurrent/CHP/Traces/VCR.hs @@ -61,7 +61,7 @@ runCHPProgramWith' st (flip toPublic st) p prettyPrint (VCRTrace (labels, eventSets)) - = char '<' <+> (sep $ punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>' + = char '<' <+> sep (punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>' where es = evalState (mapM nameVCR eventSets) labels diff --git a/Control/Concurrent/CHP/Utils.hs b/Control/Concurrent/CHP/Utils.hs deleted file mode 100644 --- a/Control/Concurrent/CHP/Utils.hs +++ /dev/null @@ -1,267 +0,0 @@ --- Communicating Haskell Processes. --- Copyright (c) 2008--2009, 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 collection of useful functions to use with the library. --- --- The most useful operation is 'pipeline' which you can use to wire up a list --- of processes into a line, and run them. The corresponding '|->|' operator is --- a simple binary version that can be a little more concise. When the pipeline --- has channels going in both directions rather than just one, 'dualPipeline' and/or --- '|<->|' can be used. Several other variants on these functions are also provided, --- including operators to use at the beginning and ends of pipelines. --- --- Most of the functions in this module are superseded or generalised by those --- in the "Control.Concurrent.CHP.Connect" module since version 1.7.0, so you should --- look to use those connectors rather than these, as the connects in this module --- may be removed at some point in the future. -module Control.Concurrent.CHP.Utils where - -import Control.Monad - -import Control.Concurrent.CHP - --- | Wires given processes up in a forward cycle. That is, the first process --- writes to the second, and receives from the last. It returns the list of --- wired-up processes, which you will almost certainly want to run in parallel. -wireCycle :: Channel r w => [r a -> w a -> proc] -> CHP [proc] -wireCycle procs - = do chan <- newChannel - wirePipeline procs (reader chan) (writer chan) - -- return [p (reader $ chans !! i) (writer $ chans !! ((i + 1) `mod` n)) | (p, i) <- zip procs [0..]] - --- | Like wireCycle, but works with processes that connect with a channel in both --- directions. --- --- This function was added in version 1.4.0. -wireDualCycle :: (Channel r w, Channel r' w') => - [(r a, w' b) -> (r' b, w a) -> proc] -> CHP [proc] -wireDualCycle procs - = do c <- newChannel - d <- newChannel - wireDualPipeline procs (reader c, writer d) (reader d, writer c) - --- | Wires the given processes up in a forward pipeline. The first process --- in the list is connected to the given reading channel-end (the first parameter) --- and the writing end of a new channel, A. The second process is wired up --- to the reading end of A, and the writing end of the next new channel, B. --- This proceeds all the way to the end of the list, until the final process --- is wired to the reading end of Z (if you have 27 processes in the list, --- and therefore 26 channels in the middle of them) and the second parameter. --- The list of wired-up processes is returned, which you can then run in parallel. -wirePipeline :: forall a r w proc. Channel r w => [r a -> w a -> proc] -> r a -> w a - -> CHP [proc] -wirePipeline [] _ _ = return [] -wirePipeline procs in_ out - = do chans <- replicateM (n - 1) newChannel - -- return $ map (wire chans) $ zip procs [0..] - return $ (\(w, ps) -> head procs in_ w : ps) $ (foldr wireF (out, []) $ zip (tail procs) chans) - where - n = length procs - - -- One way of doing it: - {- - wire :: [OneToOneChannel a] -> (Chanin a -> Chanout a -> CSProcess, Int) -> CSProcess - wire cs (p, i) - | i == 0 = p in_ (writer $ cs !! 0) - | i == n - 1 = p (reader $ cs !! i) out - | otherwise = p (reader $ cs !! i) (writer $ cs !! (i + 1)) - -} - -- A way without indexing (possibly a bit more efficient): - wireF :: (r a -> w a -> proc, Chan r w a) -> (w a, [proc]) -> (w a, [proc]) - wireF (p, c) (w, ps) = (writer c, p (reader c) w : ps) - --- | Like wirePipeline, but works with processes that connect with a channel in both --- directions. --- --- This function was added in version 1.4.0. -wireDualPipeline :: forall a b r w r' w' proc. (Channel r w, Channel r' w') => - [(r a, w' b) -> (r' b, w a) -> proc] -> (r a, w' b) -> (r' b, w a) -> CHP [proc] -wireDualPipeline [] _ _ = return [] -wireDualPipeline procs@(first:rest) in_ out - = do chans <- replicateM (n - 1) newChannel - chans' <- replicateM (n - 1) newChannel - return $ (\(w, ps) -> first in_ w : ps) - $ (foldr wireF (out, []) $ zip3 rest chans chans') - where - n = length procs - - wireF :: ((r a, w' b) -> (r' b, w a) -> proc, Chan r w a, Chan r' w' b) - -> ((r' b, w a), [proc]) -> ((r' b, w a), [proc]) - wireF (p, c, d) (w, ps) = ((reader d, writer c), p (reader c, writer d) w : ps) - --- | A specialised version of 'wirePipeline'. Given a list of processes, composes --- them into an ordered pipeline, that takes the channel-ends for the sticking --- out ends of the pipeline and gives a process that returns a list of their --- results. This is equivalent to 'wirePipeline', with the return value fed --- to 'runParallel'. --- --- Added in version 1.0.2. -pipeline :: [Chanin a -> Chanout a -> CHP b] -> Chanin a -> Chanout a -> CHP [b] -pipeline procs in_ out = wirePipeline procs in_ out >>= runParallel - --- | Like pipeline, but works with processes that connect with a channel in both --- directions. --- --- This function was added in version 1.4.0. -dualPipeline :: [(Chanin a, Chanout b) -> (Chanin b, Chanout a) -> CHP c] - -> (Chanin a, Chanout b) -> (Chanin b, Chanout a) -> CHP [c] -dualPipeline p i o = wireDualPipeline p i o >>= runParallel - --- | A specialised version of 'wireCycle'. Given a list of processes, composes --- them into a cycle and runs them all in parallel. This is equivalent to --- 'wireCycle' with the return value fed into 'runParallel'. --- --- Added in version 1.0.2. -cycle :: [Chanin a -> Chanout a -> CHP b] -> CHP [b] -cycle procs = wireCycle procs >>= runParallel - --- | Like cycle, but works with processes that connect with a channel in both --- directions. --- --- This function was added in version 1.4.0. -dualCycle :: [(Chanin a, Chanout b) -> (Chanin b, Chanout a) -> CHP c] - -> CHP [c] -dualCycle p = wireDualCycle p >>= runParallel - - --- | Process composition. Given two processes, composes them into a pipeline, --- like function composition (but with an opposite ordering). The function --- is associative. Using wirePipeline will be more efficient than @foldl1 --- (|->|)@ for more than two processes. --- --- The type for this process became more specific in version 1.2.0. -(|->|) :: (a -> Chanout b -> CHP ()) -> (Chanin b -> c -> CHP ()) -> - (a -> c -> CHP ()) -(|->|) p q x y = do c <- oneToOneChannel - runParallel_ [p x (writer c), q (reader c) y] - --- | Like (|->|), but labels the channel and uses show for the traces. --- --- Added in version 1.5.0. -(|->|^) :: Show b => (a -> Chanout b -> CHP ()) -> (String, Chanin b -> c -> CHP ()) -> - (a -> c -> CHP ()) -(|->|^) p (l, q) x y - = do c <- oneToOneChannel' $ chanLabel l - runParallel_ [p x (writer c), q (reader c) y] - --- | Process composition that works with processes that connect with a channel in both --- directions. Like (|->|), but connects a channel in each direction. --- --- This function was added in version 1.4.0. - -(|<->|) :: (a -> (Chanin b, Chanout c) -> CHP ()) - -> ((Chanin c, Chanout b) -> d -> CHP ()) - -> (a -> d -> CHP ()) -(|<->|) p q x y = do c <- oneToOneChannel - d <- oneToOneChannel - runParallel_ [p x (reader d, writer c), q (reader c, writer d) y] - --- | The reversed version of the other operator. --- --- The type for this process became more specific in version 1.2.0. -(|<-|) :: (Chanin b -> c -> CHP ()) -> (a -> Chanout b -> CHP ()) -> - (a -> c -> CHP ()) -(|<-|) = flip (|->|) - --- | A function to use at the start of a pipeline you are chaining together with --- the '|->|' operator. --- Added in version 1.2.0. -(->|) :: (Chanout b -> CHP ()) -> (Chanin b -> c -> CHP ()) - -> (c -> CHP ()) -(->|) p q x = do c <- oneToOneChannel - runParallel_ [p (writer c), q (reader c) x] - --- | A function to use at the end of a pipeline you are chaining together with --- the '|->|' operator. --- Added in version 1.2.0. -(|->) :: (a -> Chanout b -> CHP ()) -> (Chanin b -> CHP ()) - -> (a -> CHP ()) -(|->) p q x = do c <- oneToOneChannel - runParallel_ [p x (writer c), q (reader c)] - --- | A function to use at the start of a pipeline you are chaining together with --- the '|<->|' operator. --- Added in version 1.4.0. -(|<->) :: (a -> (Chanin b, Chanout c) -> CHP ()) -> ((Chanin c, Chanout b) -> CHP ()) - -> (a -> CHP ()) -(|<->) p q x = do c <- oneToOneChannel - d <- oneToOneChannel - runParallel_ [p x (reader d, writer c), q (reader c, writer d)] - --- | A function to use at the end of a pipeline you are chaining together with --- the '|<->|' operator. --- Added in version 1.4.0. -(<->|) :: ((Chanin b, Chanout c) -> CHP ()) -> ((Chanin c, Chanout b) -> a -> CHP ()) - -> (a -> CHP ()) -(<->|) p q x = do c <- oneToOneChannel - d <- oneToOneChannel - runParallel_ [p (reader d, writer c), q (reader c, writer d) x] - -{- --- Like runParallel, but offers a choice between the leading event of each --- parallel branch such that if any leading event of a parallel branch is --- poisoned, any siblings still waiting for their leading event will also be --- poisoned. Note however that any handlers in the sibling branches will not --- execute, as technically they did not encounter poison. --- --- If all the branches have just one event (e.g. a readChannel), this ensures that --- the parallel composition will not deadlock in the presence of poison. --- --- Added in version 1.5.0. -runParallelPoison :: [CHP a] -> CHP [a] -runParallelPoison ps - = do b <- newBarrierWithLabel "runParallelPoison" - -- The barrier can never sync properly, but it can be poisoned: - enroll b $ const $ enrollList (replicate (length ps) b) $ - \ebs -> runParallel $ zipWith useBar ebs ps - where - useBar :: EnrolledBarrier -> CHP a -> CHP a - useBar b p = (p <-> (syncBarrier b >> throwPoison)) `onPoisonRethrow` (poison b) - --- Like runParallel_, but offers a choice between the leading event of each --- parallel branch such that if any leading event of a parallel branch is --- poisoned, any siblings still waiting for their leading event will also be --- poisoned. Note however that any handlers in the sibling branches will not --- execute, as technically they did not encounter poison. --- --- If all the branches have just one event (e.g. a readChannel), this ensures that --- the parallel composition will not deadlock in the presence of poison. --- --- Added in version 1.5.0. -runParallelPoison_ :: [CHP a] -> CHP () -runParallelPoison_ ps - = do b <- newBarrierWithLabel "runParallelPoison" - -- The barrier can never sync properly, but it can be poisoned: - enroll b $ const $ enrollList (replicate (length ps) b) $ - \ebs -> runParallel_ $ zipWith useBar ebs ps - where - useBar :: EnrolledBarrier -> CHP a -> CHP a - useBar b p = (p <-> (syncBarrier b >> throwPoison)) `onPoisonRethrow` (poison b) --} - diff --git a/chp.cabal b/chp.cabal --- a/chp.cabal +++ b/chp.cabal @@ -1,13 +1,13 @@ Name: chp -Version: 1.8.0 +Version: 2.0.0 Synopsis: An implementation of concurrency ideas from Communicating Sequential Processes License: BSD3 License-file: LICENSE Author: Neil Brown Maintainer: neil@twistedsquare.com -Copyright: Copyright (c) 2008--2009, University of Kent +Copyright: Copyright (c) 2008--2010, University of Kent Stability: Stable -Tested-with: GHC==6.8.2, GHC==6.10.1 +Tested-with: GHC==6.10.4, GHC==6.12.1 Description: The Communicating Haskell Processes (CHP) library is an implementation of message-passing concurrency ideas from Hoare's Communicating Sequential Processes. More details and @@ -15,22 +15,19 @@ , and there is also now a blog with examples of using the library: . The library requires at - least GHC 6.8.1. + least GHC 6.8.1. NOTE: since version 2.0.0, some capabilities + that were present in version 1.x have been moved out to the + chp-plus package. Homepage: http://www.cs.kent.ac.uk/projects/ofa/chp/ Category: Concurrency Cabal-Version: >= 1.2.3 Build-Type: Simple -Build-Depends: base >= 3 && < 5, extensible-exceptions >= 0.1.1.0, containers, HUnit, mtl, parallel >= 1 && < 2, pretty, QuickCheck >= 2, stm +Build-Depends: base >= 3 && < 5, containers, deepseq >= 1.1 && < 1.2, extensible-exceptions >= 0.1.1.0, loop-while, mtl, pretty, stm Exposed-modules: Control.Concurrent.CHP - Control.Concurrent.CHP.Actions Control.Concurrent.CHP.Alt - Control.Concurrent.CHP.Arrow Control.Concurrent.CHP.Barriers - Control.Concurrent.CHP.Behaviours - Control.Concurrent.CHP.BroadcastChannels - Control.Concurrent.CHP.Buffers Control.Concurrent.CHP.Channels Control.Concurrent.CHP.Channels.BroadcastReduce Control.Concurrent.CHP.Channels.Communication @@ -38,20 +35,14 @@ Control.Concurrent.CHP.Channels.Ends Control.Concurrent.CHP.Channels.Synonyms Control.Concurrent.CHP.Clocks - Control.Concurrent.CHP.Common - Control.Concurrent.CHP.Connect - Control.Concurrent.CHP.Connect.TwoDim - Control.Concurrent.CHP.Console Control.Concurrent.CHP.Enroll Control.Concurrent.CHP.Monad Control.Concurrent.CHP.Parallel - Control.Concurrent.CHP.Test Control.Concurrent.CHP.Traces Control.Concurrent.CHP.Traces.CSP Control.Concurrent.CHP.Traces.Structural Control.Concurrent.CHP.Traces.TraceOff Control.Concurrent.CHP.Traces.VCR - Control.Concurrent.CHP.Utils Other-modules: Control.Concurrent.CHP.Base Control.Concurrent.CHP.Channels.Base @@ -63,8 +54,7 @@ Control.Concurrent.CHP.ProcessId Control.Concurrent.CHP.Traces.Base -Extensions: ScopedTypeVariables MultiParamTypeClasses - FlexibleInstances TypeFamilies ParallelListComp - GeneralizedNewtypeDeriving CPP BangPatterns +Extensions: BangPatterns CPP FlexibleInstances GeneralizedNewtypeDeriving + MultiParamTypeClasses ScopedTypeVariables GHC-Options: -Wall -auto-all