Add Bounded Channel

escape-from-itunes.cabal

@@ -18,13 +18,15 @@ library
   exposed-modules:     Itunes
                      , Args
                      , Attributes
+                     , Channel
   build-depends:       base >= 4.7 && < 5
                      , idiii == 0.1.3.3
                      , optparse-applicative == 0.14.3.0
                      , regex-compat == 0.95.1
                      , data-accessor == 0.2.2.8
                      , directory == 1.3.3.1
                      , filepath == 1.4.2
+                     , stm == 2.5.0.0
   default-language:    Haskell2010
 
 executable escape-from-itunes

src/Channel.hs

@@ -0,0 +1,41 @@
+module Channel where
+
+-- This code liberally borrowed from _Parallel and Concurrent Programming
+-- in Haskell_ by Simon Marlow: TBQueue.hs p 190
+
+import Control.Concurrent.STM ( STM
+                              , TVar
+                              , newTVar
+                              , readTVar
+                              , writeTVar
+                              , retry)
+
+data Channel a = Channel (TVar Int) (TVar [a]) (TVar [a])
+
+newChannel :: Int -> STM (Channel a)
+newChannel size = Channel <$> (newTVar size) <*> (newTVar []) <*> (newTVar [])
+
+writeChan :: Channel a -> a -> STM ()
+writeChan (Channel size _read write) a = do
+    avail <- readTVar size
+    if avail == 0
+      then retry
+      else writeTVar size (avail - 1)
+    listend <- readTVar write
+    writeTVar write (a:listend)
+
+readChan :: Channel a -> STM a
+readChan (Channel size read write) = do
+    avail <- readTVar size
+    writeTVar size (avail + 1)
+    xs <- readTVar read
+    case xs of
+      (x:xs') -> do writeTVar read xs'
+                    return x
+      [] -> do ys <- readTVar write
+               case ys of
+                 [] -> retry
+                 _ -> do let (z:zs) = reverse ys
+                         writeTVar write []
+                         writeTVar read zs
+                         return z

stack.yaml

@@ -45,6 +45,7 @@ extra-deps: [
   , data-accessor-0.2.2.8
   , directory-1.3.3.1
   , filepath-1.4.2
+  , stm-2.5.0.0
 ]
 
 # Override default flag values for local packages and extra-deps