chp 1.8.0 → 2.0.0

raw patch · 32 files changed

+97/−2471 lines, 32 filesdep +deepseqdep +loop-whiledep −HUnitdep −QuickCheckdep −parallelPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, loop-while

Dependencies removed: HUnit, QuickCheck, parallel

API changes (from Hackage documentation)

Files

• Control/Concurrent/CHP.hs +7/−24
• Control/Concurrent/CHP/Actions.hs +0/−122
• Control/Concurrent/CHP/Alt.hs +5/−4
• Control/Concurrent/CHP/Arrow.hs +0/−334
• Control/Concurrent/CHP/Base.hs +14/−7
• Control/Concurrent/CHP/Behaviours.hs +0/−204
• Control/Concurrent/CHP/BroadcastChannels.hs +0/−35
• Control/Concurrent/CHP/Buffers.hs +0/−145
• Control/Concurrent/CHP/CSP.hs +5/−5
• Control/Concurrent/CHP/Channels.hs +2/−2
• Control/Concurrent/CHP/Channels/Base.hs +1/−2
• Control/Concurrent/CHP/Channels/BroadcastReduce.hs +6/−8
• Control/Concurrent/CHP/Channels/Communication.hs +4/−3
• Control/Concurrent/CHP/Clocks.hs +8/−8
• Control/Concurrent/CHP/Common.hs +0/−307
• Control/Concurrent/CHP/Connect.hs +0/−232
• Control/Concurrent/CHP/Connect/TwoDim.hs +0/−231
• Control/Concurrent/CHP/Console.hs +0/−114
• Control/Concurrent/CHP/Enroll.hs +1/−1
• Control/Concurrent/CHP/Event.hs +18/−9
• Control/Concurrent/CHP/Guard.hs +3/−3
• Control/Concurrent/CHP/Monad.hs +0/−45
• Control/Concurrent/CHP/Mutex.hs +1/−1
• Control/Concurrent/CHP/Parallel.hs +1/−1
• Control/Concurrent/CHP/Test.hs +0/−325
• Control/Concurrent/CHP/Traces.hs +2/−2
• Control/Concurrent/CHP/Traces/Base.hs +6/−7
• Control/Concurrent/CHP/Traces/CSP.hs +2/−2
• Control/Concurrent/CHP/Traces/Structural.hs +1/−1
• Control/Concurrent/CHP/Traces/VCR.hs +1/−1
• Control/Concurrent/CHP/Utils.hs +0/−267
• chp.cabal +9/−19

@@ -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: -- <http://www.cs.kent.ac.uk/projects/ofa/chp/tutorial.pdf> available from -- the main CHP website: <http://www.cs.kent.ac.uk/projects/ofa/chp/>, or take -- a look at the CHP blog: <http://chplib.wordpress.com/>.+--+-- 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

@@ -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 ())-

@@ -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

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

@@ -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

@@ -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

@@ -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

@@ -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.|>)

@@ -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 ()

@@ -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

@@ -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 

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

@@ -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: 

@@ -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]

@@ -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

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

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

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

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

@@ -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+

@@ -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+  

@@ -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

@@ -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 ()

@@ -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 () 

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

@@ -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..]] 

@@ -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

@@ -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  

@@ -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

@@ -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 

@@ -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)--}-

@@ -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 @@                  <http://www.cs.kent.ac.uk/projects/ofa/chp/>, and there is                  also now a blog with examples of using the library:                  <http://chplib.wordpress.com/>.  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