diff --git a/Control/Concurrent/Chan/Split.hs b/Control/Concurrent/Chan/Split.hs --- a/Control/Concurrent/Chan/Split.hs +++ b/Control/Concurrent/Chan/Split.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-} module Control.Concurrent.Chan.Split ( -- * Chan pairs InChan() @@ -11,65 +11,73 @@ ) where -import qualified Control.Concurrent.Chan as C -import Data.Functor.Contravariant -import Control.Applicative -import Control.Arrow -import Control.Concurrent.Chan.Class - +-- +-- inspired by Leon P. Smith's from-scratch implementation +-- copy-pasta from Control.Concurrent.Chan +-- +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Control.Concurrent.MVar +import Control.Exception (mask_) +import Data.Typeable --- TODO: test performance of this with and without fmaped / contramap values in --- comparison with standard Chan. Test to see if we can improve performance --- using special constructor for fmaped / contramap version +import Control.Concurrent.Chan.Class +type Stream a = MVar (ChItem a) +data ChItem a = ChItem a (Stream a) --- | The "write side" of a chan pair -data InChan i where - InChan :: (i -> a) -> C.Chan a -> InChan i +-- | The \"write side\" of a chan pair +newtype InChan i = InChan (MVar (Stream i)) -- Invariant: Stream i always empty + deriving (Eq, Typeable) --- | The "read side" of a chan pair -data OutChan o where - OutChan :: (a -> o) -> C.Chan a -> OutChan o +-- | The \"read side\" of a chan pair +newtype OutChan i = OutChan (MVar (Stream i)) + deriving (Eq, Typeable) instance NewSplitChan InChan OutChan where -- | Create corresponding read and write ends of a chan pair. Writes to the -- 'InChan' side can be read on the 'OutChan' side. - newSplitChan = (InChan id &&& OutChan id) <$> C.newChan + newSplitChan = do + hole <- newEmptyMVar + readVar <- newMVar hole + writeVar <- newMVar hole + return ( InChan writeVar, OutChan readVar ) instance SplitChan InChan OutChan where - writeChan (InChan f c) = C.writeChan c . f - writeList2Chan (InChan f c) = C.writeList2Chan c . map f - readChan (OutChan f c) = f <$> C.readChan c - -instance Contravariant InChan where - contramap f' (InChan f c) = InChan (f . f') c - -instance Functor OutChan where - fmap f' (OutChan f c) = OutChan (f' . f) c + writeChan (InChan writeVar) val = do + new_hole <- newEmptyMVar + mask_ $ do + old_hole <- takeMVar writeVar + putMVar old_hole (ChItem val new_hole) + putMVar writeVar new_hole + writeList2Chan ch ls = sequence_ (map (writeChan ch) ls) + readChan (OutChan readVar) = do + modifyMVar readVar $ \read_end -> do + (ChItem val new_read_end) <- readMVar read_end + -- Use readMVar here, not takeMVar, + -- else dupChan doesn't work + return (new_read_end, val) -- | Return a lazy list representing the contents of the supplied OutChan, much -- like System.IO.hGetContents. getChanContents :: OutChan a -> IO [a] -getChanContents (OutChan f c) = map f <$> C.getChanContents c - +getChanContents ch = unsafeInterleaveIO (do + x <- readChan ch + xs <- getChanContents ch + return (x:xs) + ) --- | Duplicate an 'OutChan': the duplicate channel begins empty, but data --- written to the corresponding 'InChan' will appear in both, i.e. consuming a --- value from the copy will have no affect on the values in the original --- OutChan. +-- | Duplicate an 'OutChan': the duplicate channel contains any unread messages +-- in the original (n.b. this differs from the behavior of dupChan in Chan), +-- and data written to the corresponding 'InChan' will appear in both, i.e. +-- consuming a value from the copy will have no affect on the values in the +-- original OutChan. +-- +-- (Note that a duplicated channel is not equal to its original. +-- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.) dupChan :: OutChan a -> IO (OutChan a) -dupChan (OutChan f c) = OutChan f <$> C.dupChan c - -{- --- | EXPERIMENTAL: combine multiple output chans, interleaving their values -mergeOutChans :: [OutChan a] -> IO (OutChan a) -mergeOutChans cs = - as <- mapM C.getChanContents cs - ... --} - +dupChan (OutChan writeVar) = OutChan `fmap` withMVar writeVar newMVar diff --git a/chan-split.cabal b/chan-split.cabal --- a/chan-split.cabal +++ b/chan-split.cabal @@ -8,25 +8,32 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.3.0 +Version: 0.4.0 -- A short (one-line) description of the package. Synopsis: Concurrent Chans as read/write pairs. Also provides generic Chan pair class. -- A longer description of the package. -Description: A wrapper around Control.Concurrent.Chan that splits a Chan - into a pair, one of which allows only read operations, the - other write operations. +Description: An implementation of concurrent channels identical to + Control.Concurrent.Chan, except that the channel is + represented as a pair, one of which allows only read + operations, the other write operations. . - This makes code easier to reason about, allows us to define - useful instances ('Functor' and 'Contravariant') on the chan - pairs. + This makes code easier to reason about (the types strictly + delegate read/write permission), suggests useful instances + (e.g. 'Functor' and 'Contravariant' are easily defined) + on the chan pairs, and simplifies the API. . - In addition this package provides a module that defines a - pair of classes 'ReadableChan' and 'WritableChan' which - defines the basic methods any Chan type should provide. + Furthermore this allows messages sent to channels with no + readers to be trivially garbage-collected, without relying + on inlining optimizations. . + We also provide a module that defines a class 'SplitChan' + which defines the basic methods any pair of Chan types + should provide, allowing easy swapping of Chan + implementations. + . To use standard Chans with these polymorphic functions, import as follows: . @@ -38,23 +45,20 @@ . > import qualified Control.Concurrent.Chan.Split as S . - Note, we do not implement the deprecated unGetChan and + Its interface is mostly backwards compatible with Chan. + Note, we do not implement the deprecated unGetChan and isEmptyChan functions. . This module is used internally by the "simple-actors" package. . - /CHANGES/: - 0.1.3 -> 0.2.0 - - - get Cofunctor from "contravariant" package - - - redefine chan pair classes using fundeps - to express the relationship between input - and output halfs of a Chan - - - define 'NewSplitChan' class for chan pairs that can be - instantiated + /CHANGES/: 0.3.0 -> 0.4.0 . + - In\/OutChans now implemented from scratch (after Leon P Smith's implementation) + . + - no longer implement Functor\/Contravariant instances; drop contravariant dependency + . + - implement Eq and Typeable instances + . -- The license under which the package is released. @@ -100,7 +104,6 @@ , Control.Concurrent.Chan.Class Build-depends: base >= 4 && < 5 - , contravariant ghc-options: -Wall