diff --git a/Control/Concurrent/CHP/Alt.hs b/Control/Concurrent/CHP/Alt.hs --- a/Control/Concurrent/CHP/Alt.hs +++ b/Control/Concurrent/CHP/Alt.hs @@ -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 diff --git a/Control/Concurrent/CHP/Barriers.hs b/Control/Concurrent/CHP/Barriers.hs --- a/Control/Concurrent/CHP/Barriers.hs +++ b/Control/Concurrent/CHP/Barriers.hs @@ -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. diff --git a/Control/Concurrent/CHP/Behaviours.hs b/Control/Concurrent/CHP/Behaviours.hs --- a/Control/Concurrent/CHP/Behaviours.hs +++ b/Control/Concurrent/CHP/Behaviours.hs @@ -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 diff --git a/Control/Concurrent/CHP/Connect.hs b/Control/Concurrent/CHP/Connect.hs --- a/Control/Concurrent/CHP/Connect.hs +++ b/Control/Concurrent/CHP/Connect.hs @@ -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. diff --git a/Control/Concurrent/CHP/Connect/TwoDim.hs b/Control/Concurrent/CHP/Connect/TwoDim.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Connect/TwoDim.hs @@ -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) diff --git a/Control/Concurrent/CHP/Enroll.hs b/Control/Concurrent/CHP/Enroll.hs --- a/Control/Concurrent/CHP/Enroll.hs +++ b/Control/Concurrent/CHP/Enroll.hs @@ -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_ diff --git a/chp.cabal b/chp.cabal --- a/chp.cabal +++ b/chp.cabal @@ -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