packages feed

chp-plus (empty) → 1.0.0

raw patch · 12 files changed

+2004/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, chp, containers, deepseq, extensible-exceptions, mtl, pretty, stm

Files

+ Control/Concurrent/CHP/Actions.hs view
@@ -0,0 +1,122 @@+-- 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 ())+
+ Control/Concurrent/CHP/Arrow.hs view
@@ -0,0 +1,324 @@+-- 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.+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.DeepSeq+import Control.Monad+++import Control.Concurrent.CHP+import qualified Control.Concurrent.CHP.Common as CHP+import Control.Concurrent.CHP.Connect++-- | 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.+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 (connectWith (chanLabel $ pr ++ "->" ++ ql) p 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'.+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 <<<.+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.+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')+          ]
+ Control/Concurrent/CHP/Behaviours.hs view
@@ -0,0 +1,199 @@+-- 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.+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'.+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 $ (repeatedly' . (: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
+ Control/Concurrent/CHP/Buffers.hs view
@@ -0,0 +1,143 @@+-- 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.+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.|>)
+ Control/Concurrent/CHP/Common.hs view
@@ -0,0 +1,282 @@+-- 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.DeepSeq+import Control.Monad+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.|->|'.+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.+tail :: Chanin a -> Chanout a -> CHP ()+tail input output = (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.+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.+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+                   ]+                 when cont (inner c)++-- | 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.+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.+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.+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).+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
+ Control/Concurrent/CHP/Connect.hs view
@@ -0,0 +1,221 @@+-- 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.+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.+  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.+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.+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.+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))+
+ Control/Concurrent/CHP/Connect/TwoDim.hs view
@@ -0,0 +1,229 @@+-- 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.+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)
+ Control/Concurrent/CHP/Console.hs view
@@ -0,0 +1,114 @@+-- 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
+ Control/Concurrent/CHP/Test.hs view
@@ -0,0 +1,301 @@+-- 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.+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''.+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@.+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)+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.+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.+(=*=) :: (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.+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.+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)+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.+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.+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.+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.+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)++
+ LICENSE view
@@ -0,0 +1,27 @@+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.
+ Setup.lhs view
@@ -0,0 +1,5 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ chp-plus.cabal view
@@ -0,0 +1,37 @@+Name:            chp-plus+Version:         1.0.0+Synopsis:        A set of high-level concurrency utilities built on Communicating Haskell Processes+License:         BSD3+License-file:    LICENSE+Author:          Neil Brown+Maintainer:      neil@twistedsquare.com+Copyright:       Copyright (c) 2008--2010, University of Kent and Neil Brown+Stability:       Stable+Tested-with:     GHC==6.10.4, GHC==6.12.1+Description:     In version 1.0.0, this package contains functionality split+                 off during the chp 1.x to 2.0 transition.  In future, it will+                 contain any new CHP features that build on the core library,+                 and that do not require access to CHP's internals.  This+                 package is closely tied to the chp 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, chp >= 2.0 && < 2.1, containers, deepseq >= 1.1 && < 1.2, extensible-exceptions >= 0.1.1.0, HUnit, mtl, pretty, QuickCheck >= 2, stm++Exposed-modules: 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.Connect.TwoDim+                 Control.Concurrent.CHP.Console+                 Control.Concurrent.CHP.Test++Extensions:      CPP FlexibleInstances GeneralizedNewtypeDeriving+                 MultiParamTypeClasses ParallelListComp ScopedTypeVariables+                 TypeFamilies++GHC-Options:     -Wall -auto-all