chan (empty) → 0.0.0

raw patch · 6 files changed

+228/−0 lines, 6 filesdep +asyncdep +basedep +chansetup-changed

Dependencies added: async, base, chan

Files

• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• chan.cabal +36/−0
• src/Control/Concurrent/Chan/Extra.hs +106/−0
• test/Spec.hs +53/−0

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++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 Author name here nor the names of other+      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.

@@ -0,0 +1,1 @@+# chan

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,36 @@+name:                chan+version:             0.0.0+synopsis:            Some extra kit for Chans+-- description:+homepage:            https://github.com/athanclark/chan#readme+license:             BSD3+license-file:        LICENSE+author:              Athan Clark+maintainer:          athan.clark@gmail.com+copyright:           2017 Athan Clark+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Control.Concurrent.Chan.Extra+  build-depends:       base >= 4.7 && < 5+                     , async+                     -- , since+  default-language:    Haskell2010++test-suite chan-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , chan+                     , async+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/athanclark/chan

@@ -0,0 +1,106 @@+module Control.Concurrent.Chan.Extra where++import Data.IORef (newIORef, readIORef, writeIORef)+-- import Data.Time.Since (timeSince, newTimeSince)+import Control.Monad (forever)+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, tryTakeMVar, putMVar)+import Control.Concurrent.Chan (Chan, readChan, writeChan, newChan)+import Control.Concurrent.Async (Async, async, cancel, wait)++++type DiffNanosec = Int++-- type TotalNanosec = Int+++-- debounceDynamic :: (NominalDiffTime -> NominalDiffTime) -> Chan a -> IO (Chan a, Async ())+-- debounceDynamic toWait outputChan = do+--   sinceRef <- newTimeSince+--   totalWaited <- newIORef 0+--   presentedChan <- newChan+--   writingThread <- newEmptyMVar++--   let invokeWrite x = do+--         putStrLn "Being run.."++--         waited <- readIORef totalWaited+--         let toWaitFurther = toWait waited+--         writeIORef totalWaited (waited + toWaitFurther)++--         -- FIXME must use clocktime - overlayed invocations have+--         -- no concept of time spent, only have knoweldge of invocations+--         -- made++--         threadDelay toWaitFurther+--         putStrLn "waited done"+--         writeChan outputChan x++--   writer <- async $ forever $ do+--     x <- readChan presentedChan++--     newWriter <- async (invokeWrite x)++--     mInvoker <- tryTakeMVar writingThread+--     case mInvoker of+--       Nothing -> pure ()+--       Just i -> cancel i+--     print "killed"+--     putMVar writingThread newWriter++--   pure (presentedChan, writer)++debounceStatic :: DiffNanosec -> Chan a -> IO (Chan a, Async ())+debounceStatic toWaitFurther outputChan = do+  presentedChan <- newChan+  writingThread <- newEmptyMVar++  let invokeWrite x = do+        threadDelay toWaitFurther+        writeChan outputChan x++  writer <- async $ forever $ do+    x <- readChan presentedChan++    newWriter <- async (invokeWrite x)++    mInvoker <- tryTakeMVar writingThread+    case mInvoker of+      Nothing -> pure ()+      Just i -> cancel i+    putMVar writingThread newWriter++  pure (presentedChan, writer)++++intersperseStatic :: DiffNanosec -> IO a -> Chan a -> IO (Chan a, Async (), Async ())+intersperseStatic timeBetween xM outputChan = do+  presentedChan <- newChan+  writingThread <- newEmptyMVar++  let invokeWritePing = do+        threadDelay timeBetween+        x <- xM+        writeChan outputChan x++  writer <- async $ forever $ do+    mInvoker <- tryTakeMVar writingThread+    case mInvoker of+      Nothing -> pure ()+      Just i -> wait i+    newWriter <- async invokeWritePing+    putMVar writingThread newWriter++  listener <- async $ forever $ do+    y <- readChan presentedChan++    mInvoker <- tryTakeMVar writingThread+    case mInvoker of+      Nothing -> pure ()+      Just i -> cancel i++    writeChan outputChan y++  pure (presentedChan, writer, listener)

@@ -0,0 +1,53 @@+import Control.Monad (forever)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Chan (newChan, writeChan, readChan)+import Control.Concurrent.Chan.Extra (debounceStatic, intersperseStatic)+import Control.Concurrent.Async (async)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)++main :: IO ()+main = do++  outgoing <- newChan+  (incoming, _) <- debounceStatic 1000000 outgoing++  lock <- newEmptyMVar++  _ <- async $ forever $ do+    x <- readChan outgoing+    print x+    putMVar lock ()++  putStrLn "writing 1..."+  writeChan incoming 1++  _ <- takeMVar lock++  putStrLn "writing 2..."+  writeChan incoming 1+  writeChan incoming 2++  _ <- takeMVar lock++++  outgoing <- newChan+  (incoming, _, _) <- intersperseStatic 1000000 (pure 0) outgoing++  lock <- newEmptyMVar++  _ <- async $ forever $ do+    x <- readChan outgoing+    print x+    putMVar lock ()++  threadDelay 3000000++  putStrLn "Writing 1..."+  writeChan incoming 1+  _ <- takeMVar lock+  putStrLn "writing 2..."+  writeChan incoming 2+  _ <- takeMVar lock++  pure ()