diff --git a/Control/Concurrent/CHP/Actions.hs b/Control/Concurrent/CHP/Actions.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Actions.hs @@ -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 ()) + diff --git a/Control/Concurrent/CHP/Arrow.hs b/Control/Concurrent/CHP/Arrow.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Arrow.hs @@ -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') + ] diff --git a/Control/Concurrent/CHP/Behaviours.hs b/Control/Concurrent/CHP/Behaviours.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Behaviours.hs @@ -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 diff --git a/Control/Concurrent/CHP/Buffers.hs b/Control/Concurrent/CHP/Buffers.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Buffers.hs @@ -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.|>) diff --git a/Control/Concurrent/CHP/Common.hs b/Control/Concurrent/CHP/Common.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Common.hs @@ -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 diff --git a/Control/Concurrent/CHP/Connect.hs b/Control/Concurrent/CHP/Connect.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Connect.hs @@ -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)) + 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,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) diff --git a/Control/Concurrent/CHP/Console.hs b/Control/Concurrent/CHP/Console.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Console.hs @@ -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 diff --git a/Control/Concurrent/CHP/Test.hs b/Control/Concurrent/CHP/Test.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/CHP/Test.hs @@ -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) + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/chp-plus.cabal b/chp-plus.cabal new file mode 100644 --- /dev/null +++ b/chp-plus.cabal @@ -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