chp 1.7.1 → 1.8.0

raw patch · 7 files changed

+329/−17 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Concurrent/CHP/Alt.hs +7/−1
• Control/Concurrent/CHP/Barriers.hs +2/−2
• Control/Concurrent/CHP/Behaviours.hs +16/−2
• Control/Concurrent/CHP/Connect.hs +53/−6
• Control/Concurrent/CHP/Connect/TwoDim.hs +231/−0
• Control/Concurrent/CHP/Enroll.hs +16/−3
• chp.cabal +4/−3

@@ -101,7 +101,7 @@ -- This only waits for the first action in both (reading from channel c, or writing -- to channel e), not for all of the actions (as, for example, an STM transaction -- would).-module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>), every, (<&>)) where+module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>), every, every_, (<&>)) where  import Control.Arrow import Control.Concurrent.STM@@ -318,6 +318,12 @@     foldM1 :: Monad m => (b -> b -> m b) -> [b] -> m b     foldM1 f (y:ys) = foldM f y ys     foldM1 _ _ = error "Reached unreachable code in every; guards empty in non-empty case"++-- | Like 'every' but discards the results.+--+-- Added in version 1.8.0.+every_ :: [CHP a] -> CHP ()+every_ ps = every ps >> return ()  -- | A useful operator that acts like 'every'.  The operator is associative and -- commutative (see 'every' for notes on idempotence).  When you have lots of things

@@ -150,7 +150,7 @@  -- | Creates a new barrier with no processes enrolled newBarrier :: CHP Barrier-newBarrier = newPhasedBarrier ()+newBarrier = newPhasedBarrier' () $ BarOpts (const ()) (const "") Nothing  newBarrierEvent :: (phase -> String) -> TVar phase -> IO Event newBarrierEvent sh tv = newEvent (liftM (BarrierSync . sh) $ readTVar tv) 0@@ -174,7 +174,7 @@ -- | Creates a new barrier with no processes enrolled and labels it in traces -- using the given label.  See 'newBarrier'. newBarrierWithLabel :: String -> CHP Barrier-newBarrierWithLabel = newPhasedBarrier' () . barLabel+newBarrierWithLabel = newPhasedBarrier' () . BarOpts (const ()) (const "") . Just  -- | Gets the identifier of a Barrier.  Useful if you want to identify it in -- the trace later on.

@@ -32,7 +32,7 @@ -- -- This whole module was added in CHP 1.6.0. module Control.Concurrent.CHP.Behaviours (-  CHPBehaviour, offer, offerAll, alongside, alongside_, endWhen, once, repeatedly, repeatedly_,+  CHPBehaviour, offer, offerAll, alongside, alongside_, endWhen, once, upTo, repeatedly, repeatedly_,   repeatedlyRecurse, repeatedlyRecurse_) where  import Control.Applicative@@ -60,12 +60,26 @@ -- it just won't be offered again during the call to 'offer'.  Thus if you only -- offer some 'once' items without any 'endWhen', then after all the 'once' events -- have happened, the process will deadlock.+--+-- @once m@ can be thought of as a shortcut for @listToMaybe <$> upTo1 m@ once :: CHP a -> CHPBehaviour (Maybe a) once m = CHPBehaviour Nothing (Just $ (\x -> CHPBehaviour (Just x) (Just stop)) <$> m) ++-- | Offers the given behaviour up to the given number of times, returning a list+-- of the results (in chronological order).  Like 'once', when the limit is reached,+-- the call to 'offer' is not terminated, so you still require an 'endWhen'.+--+-- Added in version 1.8.0.+upTo :: Int -> CHP a -> CHPBehaviour [a]+upTo n m = reverse <$> upTo' []+  where+    upTo' xs+      = CHPBehaviour xs $ Just $ if length xs >= n then stop else (upTo' . (:xs)) <$> m+ -- | Repeatedly offers the given behaviour until the outer call to 'offer' is terminated -- by an 'endWhen' event.  A list is returned (in chronological order) of the results--- of each occurrence of the behaviour.+-- of each occurrence of the behaviour.  @repeatedly@ is like an unbounded @upTo@. repeatedly :: forall a. CHP a -> CHPBehaviour [a] repeatedly m = reverse <$> repeatedly' []   where

@@ -32,7 +32,8 @@ -- This whole module was added in version 1.7.0. module Control.Concurrent.CHP.Connect   (Connectable(..), (<=>), (|<=>), (<=>|), (|<=>|), pipelineConnect, pipelineConnectComplete,-    cycleConnect, ConnectableExtra(..), connectWith) where+    pipelineConnectCompleteT, cycleConnect, connectList, connectList_, ChannelPair,+    ConnectableExtra(..), connectWith) where  import Control.Applicative import Control.Arrow@@ -55,8 +56,41 @@ -- 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 ()) -> CHP ()+  --+  -- The type of this function was generalised in CHP 1.8.0+  -- from @((l, r) -> CHP ()) -> CHP ()@ to @((l, r) -> CHP a) -> CHP a@+  connect :: ((l, r) -> CHP a) -> CHP a +-- | A pair of channels.  The main use of this type is with the Connectable class,+-- as it allows you to wire together two processes that take the exact same channel+-- pair, e.g. both are of type @ChannelPair (Chanin Int) (Chanout Int) -> CHP ()@.  With the+-- normal Connectable pair instances, one would need to be of type @(Chanin Int,+-- Chanout Int) -> CHP ()@, and the other of type @(Chanout Int, Chanin Int) ->+-- CHP ()@.+data ChannelPair l r = ChannelPair l r+  deriving (Eq, Show)++instance Connectable l r => Connectable (ChannelPair l r) (ChannelPair l r) where+  connect f = connect $ \(lx, rx) -> connect $ \(ly, ry) -> +    f (ChannelPair lx ry, ChannelPair ly rx)++-- | Like 'connect', but provides the process a list of items of the specified size,+-- and runs it.+--+-- This function was added in version 1.8.0.+connectList :: Connectable l r => Int -> ([(l, r)] -> CHP a) -> CHP a+connectList n p | n == 0 = p []+                | n > 0 = connect $ \lr -> connectList (n - 1) $ p . (lr :)+                | otherwise = error $ "Control.Concurrent.CHP.Connect.connectList: negative parameter " ++ show n++-- | Like 'connectList' but ignores the results.+--+-- This function was added in version 1.8.0.+connectList_ :: Connectable l r => Int -> ([(l, r)] -> CHP a) -> CHP ()+connectList_ n p | n == 0 = p [] >> return ()+                 | n > 0 = connect $ \lr -> connectList_ (n - 1) $ p . (lr :)+                 | otherwise = error $ "Control.Concurrent.CHP.Connect.connectList_: negative parameter " ++ show n+ -- | Joins together the given two processes and runs them in parallel. (|<=>|) :: Connectable l r => (l -> CHP ()) -> (r -> CHP ()) -> CHP () (|<=>|) p q = connect $ \(x, y) -> p x <|*|> q y@@ -85,17 +119,30 @@ -- 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 [p] = p-pipelineConnect (p:ps) = p <=> pipelineConnect ps+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 [] end = begin |<=>| end pipelineConnectComplete begin middle end-  = (begin |<=> pipelineConnect middle) |<=>| end+  = (foldl (|<=>) begin middle) |<=>| end++-- | Like 'pipelineConnectComplete' but allows a customised function to run all+-- the processes in parallel.  So @pipelineConnectCompleteT runParallel@ is the+-- same as @pipelineConnectComplete@.  The list of items given to the first function+-- will be in the order: begin process, middle processes, end process, as you would+-- expect.+--+-- This function was added in version 1.8.0.+pipelineConnectCompleteT :: Connectable l r =>+  ([a] -> CHP b) -> (l -> a) -> [r -> l -> a] -> (r -> a) -> CHP b+pipelineConnectCompleteT run begin [] end+  = connect $ \(l, r) -> run [begin l, end r]+pipelineConnectCompleteT run begin (p:ps) end+  = connect $ \(l, r) ->+      pipelineConnectCompleteT (run . (begin l :)) (p r) ps end  -- | Like 'pipelineConnect' but also connects the last process into the first. --  If the list is empty, it returns immediately.

@@ -0,0 +1,231 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | This module contains helper functions for wiring up collections of processes+-- into a two-dimensional arrangement.+--+-- This module was added in version 1.8.0.+module Control.Concurrent.CHP.Connect.TwoDim+  (FourWay(..), wrappedGridFour, wrappedGridFour_,+   FourWayDiag(..), EightWay, wrappedGridEight, wrappedGridEight_) where++import Control.Arrow+import Control.Concurrent.CHP+import Control.Concurrent.CHP.Connect+import Control.Monad+import Data.List++import Prelude hiding (abs)++-- | A data type representing four-way connectivity for a process, with channels+-- to the left and right, above and below.+data FourWay above below left right+  = FourWay { above :: above, below :: below, left :: left, right :: right }+    deriving (Eq)++-- | A data type representing four-way diagonal connectivity for a process, with+-- channels above-left, below-right, above-right and below-left.+data FourWayDiag aboveLeft belowRight aboveRight belowLeft+  = FourWayDiag { aboveLeft :: aboveLeft, belowRight :: belowRight, aboveRight :: aboveRight, belowLeft :: belowLeft }+    deriving (Eq)++-- | EightWay is simply a synonym for a pair of 'FourWay' and 'FourWayDiag'.+type EightWay a b l r al br ar bl  = (FourWay a b l r, FourWayDiag al br ar bl)++-- | Wires the given grid of processes (that require four-way connectivity) together+-- into a wrapped around grid (a torus) and runs them all in parallel.+--+-- The parameter is a list of rows, and should be rectangular (i.e. all the rows+-- should be the same length).  If not, an error will result.  The return value+-- is guaranteed to be the same shape as the input.+--+-- It is worth remembering that if you have only one row or one column (or+-- both), processes can be connected to themselves, so make sure that if a+-- process is connected to itself (e.g. its left channel connects to its right+-- channel), it is coded such that it won't deadlock -- or if needed, checks for this+-- possibility using 'sameChannel'.  Processes may also be connected to each other+-- multiple times -- in a two-wide grid, each process's left channel connects to+-- the same process as its right.+wrappedGridFour :: (Connectable above below, Connectable left right) =>+  [[FourWay above below left right -> CHP a]] -> CHP [[a]]+wrappedGridFour ps+  -- If ps == [], this will succeed, and map connectRowCycle ps will be [],+  -- and thus connectColumnsCycle _ [] will return [] (without forcing the+  -- head call), and it will all work correctly.+  | length (nub $ map length ps) <= 1+     = connectColumnsCycle (length (head ps)) $ map connectRowCycle ps+  | otherwise+     = error $ "Control.Concurrent.CHP.Connect.TwoDim.wrappedGrid: Non-rectangular input "+               ++ " height: " ++ show (length ps) ++ " widths: " ++ show (map length ps)++-- | Like 'wrappedGridFour' but discards the return values.+wrappedGridFour_ :: (Connectable above below, Connectable left right) =>+  [[FourWay above below left right -> CHP a]] -> CHP ()+wrappedGridFour_ ps = wrappedGridFour ps >> return () --TODO fix this++-- | Like 'wrappedGridFour' but provides eight-way connectivity.+--+-- The note on 'wrappedGridFour' about processes being connected to themselves+-- applies here too -- as does the note about processes being connected to+-- each other multiple times.  If you have one row, a process's left,+-- above-left and below-left channels all connect to the same process.  If you+-- have a two-by-two grid, a process's four diagonal channels all connect to+-- the same process.+wrappedGridEight :: (Connectable above below, Connectable left right,+              Connectable aboveLeft belowRight, Connectable belowLeft aboveRight) =>+  [[EightWay above below left right aboveLeft belowRight aboveRight belowLeft -> CHP a]] -> CHP [[a]]+wrappedGridEight ps+  | length (nub $ map length ps) <= 1+     = connectColumnsCycleDiag (length (head ps)) $ map connectRowCycleDiag ps+  | otherwise+     = error $ "Control.Concurrent.CHP.Connect.TwoDim.wrappedGridDiag: Non-rectangular input "+               ++ " height: " ++ show (length ps) ++ " widths: " ++ show (map length ps)++-- | Like 'wrappedGridEight' but discards the output.+wrappedGridEight_ :: (Connectable above below, Connectable left right,+              Connectable aboveLeft belowRight, Connectable belowLeft aboveRight) =>+  [[EightWay above below left right aboveLeft belowRight aboveRight belowLeft -> CHP a]] -> CHP ()+wrappedGridEight_ ps = wrappedGridEight ps >> return ()+++connectRowCycle :: Connectable left right =>+  [FourWay above below left right -> CHP a] -> ([(above, below)] -> CHP [a])+connectRowCycle [] _ = return []+connectRowCycle allps abs = connect $+  foldr connLR+        -- The last process is special because it must take both channels for itself:+        (liftM (:[]) . last allps . uncurry (uncurry FourWay $ last abs))+        (zip (init allps) (init abs))++connLR :: Connectable left right =>+          (FourWay above below left right -> CHP a, (above, below))+       -> ((left, right) -> CHP [a])+       -> ((left, right) -> CHP [a])+connLR (p, (a, b)) q (l, r)+  = liftM (uncurry (:)) . connect $ \(l', r') -> p (FourWay a b l r') <||> q (l', r)++connectColumnsCycle :: Connectable above below => Int -> [[(above, below)] -> CHP [a]] -> CHP [[a]]+connectColumnsCycle _ [] = return []+connectColumnsCycle n ps = connectList n $ foldl1 (connAB n) (map (liftM (:[]) .) ps)++connAB :: Connectable above below => Int -> ([(above, below)] -> CHP [a]) -> ([(above, below)] -> CHP [a]) -> ([(above, below)] -> CHP [a])+connAB n p q abs = liftM (uncurry (++)) $ connectList n $ \abs' -> p (zip (map fst abs) (map snd abs'))+  <||> q (zip (map fst abs') (map snd abs))++connectColumnsCycleDiag :: (Connectable a b, Connectable bl ar, Connectable al br) =>+  Int -> [[((a, b), FourWayDiag al br ar bl)] -> CHP [z]] -> CHP [[z]]+connectColumnsCycleDiag _ [] = return []+connectColumnsCycleDiag n ps = connectList n $ \abs ->+  connectList n $ \leadingDiag -> connectList n $ \otherDiag ->+    foldl1 (connABDiag n) (map (liftM (:[]) .) ps)+      $ zip abs [FourWayDiag al br ar bl+                | (_, ar) <- otherDiag+                | (bl, _) <- shiftRight otherDiag+                | (al, _) <- leadingDiag+                | (_, br) <- shiftLeft leadingDiag]++-- Let's imagine we have a square:+--+-- A B C+-- D E F+-- G H I+--+-- We pass in the outer-most channels as the processes need them to be wired.+--+-- So for example, A will recieve:+-- aboveLeft: AI+-- aboveRight AH+-- belowLeft: AF+-- belowRight: AE+--+-- So for example when we create the leadingDiag channels:+--+-- \1 \2 \3 +-- A  B  C+--+-- The ends are passed to the above channels as-is, but to the below channels shifted lleft:+--+-- G  H  I+-- \2 \3 \1+--+-- For the otherDiag, shifted right when below:+--+-- /1 /2 /3+-- A  B  C+--+-- G  H  I+-- /3 /1 /2++shiftLeft, shiftRight :: [a] -> [a]+shiftLeft [] = []+shiftLeft xs = tail xs ++ [head xs]+shiftRight [] = []+shiftRight xs = last xs : init xs++connABDiag :: (Connectable above below, Connectable al br, Connectable bl ar) =>+  Int -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a])+  -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a])+  -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a])+connABDiag n p q abs = liftM (uncurry (++)) $ connectList n $ \abs' ->+  connectList n $ \leadingDiag -> connectList n $ \otherDiag ->+    p [((a, b), FourWayDiag al br ar bl)+      | ((a, _), _) <- abs+      | (_, b) <- abs'+      | (_, FourWayDiag al _ ar _) <- abs+      | (bl, _) <- shiftRight otherDiag+      | (_, br) <- shiftLeft leadingDiag+      ]+  <||>+    q [((a, b), FourWayDiag al br ar bl)+      | ((_, b), _) <- abs+      | (a, _) <- abs'+      | (al, _) <- leadingDiag+      | (_, ar) <- otherDiag+      | (_, FourWayDiag _ br _ bl) <- abs+      ]+-- We are given our own above and below as we need them to be arranged already.+++connectRowCycleDiag :: Connectable l r =>+  [EightWay a b l r al br ar bl -> CHP z]+  -> ([((a, b), FourWayDiag al br ar bl)] -> CHP [z])+connectRowCycleDiag [] _ = return []+connectRowCycleDiag allps abs = connect $+  foldr connLRDiag+        -- The last process is special because it must take both channels for itself:+        (\lr -> liftM (:[]) $ last allps $ first (($ lr) . uncurry . uncurry FourWay) (last abs))+        (zip (init allps) (init abs))+++connLRDiag :: Connectable l r =>+          (EightWay a b l r al br ar bl -> CHP z, ((a, b), FourWayDiag al br ar bl))+       -> ((l, r) -> CHP [z])+       -> ((l, r) -> CHP [z])+connLRDiag (p, ((a, b), diag)) q (l, r)+  = liftM (uncurry (:)) . connect $ \(l', r') -> p (FourWay a b l r', diag) <||> q (l', r)

@@ -31,7 +31,7 @@ -- channels).  module Control.Concurrent.CHP.Enroll (Enrolled, Enrollable(..), furtherEnroll,-  enrollPair, enrollList, enrollAll, enrollAll_) where+  enrollPair, enrollList, enrollAll, enrollAll_, enrollAllT, enrollOneMany) where  import Control.Concurrent.CHP.Base import Control.Concurrent.CHP.Parallel@@ -85,10 +85,23 @@ -- -- Added in version 1.7.0. enrollAll :: Enrollable b p => CHP (b p) -> [Enrolled b p -> CHP a] -> CHP [a]-enrollAll mbar ps = mbar >>= flip enrollList (runParallel . zipWith ($) ps) . replicate (length ps)+enrollAll = enrollAllT runParallel +enrollAllT :: Enrollable b p => ([a] -> CHP c) -> CHP (b p) -> [Enrolled b p -> a] -> CHP c+enrollAllT run mbar ps = mbar >>= flip enrollList (run . zipWith ($) ps) . replicate (length ps)++enrollOneMany :: Enrollable b p => ([Enrolled b p] -> CHP a) -> [(CHP (b p), Enrolled b p -> CHP c)] -> CHP (a, [c])+enrollOneMany p [] = p [] >>= \x -> return (x, [])+enrollOneMany p ((mbar, q) : rest)+  = do bar <- mbar+       enrollPair (bar, bar) $ \(b0, b1) ->+         do ((p', q'), rest') <- enrollOneMany (\bs -> p (b0:bs) <||> q b1) rest+            return (p', q' : rest')+--TODO there is probably a better way to implement the above++ -- | Like enrollAll, but discards the results. -- -- Added in version 1.7.0. enrollAll_ :: Enrollable b p => CHP (b p) -> [Enrolled b p -> CHP a] -> CHP ()-enrollAll_ mbar ps = mbar >>= flip enrollList (runParallel_ . zipWith ($) ps) . replicate (length ps)+enrollAll_ = enrollAllT runParallel_

@@ -1,12 +1,12 @@ Name:            chp-Version:         1.7.1+Version:         1.8.0 Synopsis:        An implementation of concurrency ideas from Communicating Sequential Processes License:         BSD3 License-file:    LICENSE Author:          Neil Brown Maintainer:      neil@twistedsquare.com Copyright:       Copyright (c) 2008--2009, University of Kent-Stability:       Provisional+Stability:       Stable Tested-with:     GHC==6.8.2, GHC==6.10.1 Description:     The Communicating Haskell Processes (CHP) library is an                  implementation of message-passing concurrency ideas from@@ -40,6 +40,7 @@                  Control.Concurrent.CHP.Clocks                  Control.Concurrent.CHP.Common                  Control.Concurrent.CHP.Connect+                 Control.Concurrent.CHP.Connect.TwoDim                  Control.Concurrent.CHP.Console                  Control.Concurrent.CHP.Enroll                  Control.Concurrent.CHP.Monad@@ -63,7 +64,7 @@                  Control.Concurrent.CHP.Traces.Base  Extensions:      ScopedTypeVariables MultiParamTypeClasses-                 FlexibleInstances TypeFamilies+                 FlexibleInstances TypeFamilies ParallelListComp                  GeneralizedNewtypeDeriving CPP BangPatterns  GHC-Options:     -Wall -auto-all