packages feed

entwine 0.0.1 → 0.0.2

raw patch · 15 files changed

+621/−20 lines, 15 filesdep ~async

Dependency ranges changed: async

Files

Changes.md view
@@ -1,3 +1,7 @@+* 0.0.2+ - Update async to 2.2. This version of async changed the exceptions thrown, see+   https://hackage.haskell.org/package/async-2.2/changelog for more details.+ * 0.0.1  - Initial release and cleanup from ambiata/twine  - Rename to entwine from twine, due to existing project called twine.
entwine.cabal view
@@ -1,5 +1,5 @@ name:                  entwine-version:               0.0.1+version:               0.0.2 license:               BSD3 license-file:          LICENSE author:                Ambiata <info@ambiata.com>@@ -13,7 +13,7 @@ build-type:            Simple description:           entwine - Concurrency tools -tested-with: GHC == 8.0.2, GHC == 8.2.2+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4 extra-source-files:   README.md   Changes.md@@ -25,7 +25,7 @@ library   build-depends:                        base                            >= 3          && < 5-                     , async                           >= 2.0        && < 2.2+                     , async                           == 2.2.*                      , containers                      >= 0.5        && < 0.7                      , exceptions                      >= 0.6        && < 0.9                      , monad-loops                     == 0.4.*@@ -69,10 +69,21 @@   hs-source-dirs:                        test +  other-modules:       Test.Disorder+                       Test.Entwine.Async+                       Test.Entwine.Data.Duration+                       Test.Entwine.Data.Finalizer+                       Test.Entwine.Data.Gate+                       Test.Entwine.Data.Parallel+                       Test.Entwine.Data.Pin+                       Test.Entwine.Data.Queue+                       Test.Entwine.Parallel++   build-depends:                        base                            >= 3          && < 5                      , entwine-                     , async                           >= 2.0        && < 2.3+                     , async                           == 2.2.*                      , directory                       >= 1.2        && < 1.4                      , exceptions                      >= 0.6        && < 0.9                      , process                         >= 1.2        && < 1.7@@ -83,6 +94,7 @@                      , QuickCheck                      == 2.10.*                      , quickcheck-instances            == 0.3.* + test-suite test-io   type:                exitcode-stdio-1.0 @@ -93,10 +105,15 @@   hs-source-dirs:                        test +  other-modules:       Test.Disorder+                       Test.IO.Entwine.Guard+                       Test.IO.Entwine.Loop+                       Test.IO.Entwine.Snooze+   build-depends:                        base                            >= 3          && < 5                      , entwine-                     , async                           >= 2.0        && < 2.3+                     , async                           == 2.2.*                      , directory                       >= 1.2        && < 1.4                      , exceptions                      , process                         >= 1.2        && < 1.7
src/Entwine/Async.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-} module Entwine.Async (     AsyncTimeout (..)   , renderAsyncTimeout@@ -10,10 +11,9 @@   import           Control.Concurrent.Async (Async, waitSTM, waitEither)-import           Control.Concurrent.Async (async, cancel, wait)+import           Control.Concurrent.Async (async, cancel, wait, AsyncCancelled) import           Control.Concurrent.STM (atomically, orElse, retry)-import           Control.Exception.Base (AsyncException (..))-import           Control.Monad.Catch (catch, throwM)+import           Control.Monad.Catch (catches, throwM, Handler(..)) import           Control.Monad.IO.Class (liftIO) import           Control.Monad.Trans.Either @@ -51,18 +51,10 @@       liftIO $ writeIORef r True       liftIO $ cancel a       (liftIO $ wait a)-        `catch`-          (\(ae :: AsyncException) ->-            case ae of-              ThreadKilled -> do-                liftIO (readIORef r) >>=-                  bool (liftIO $ throwM ae) (left $ AsyncTimeout d)-              StackOverflow ->-                liftIO $ throwM ae-              HeapOverflow ->-                liftIO $ throwM ae-              UserInterrupt ->-                liftIO $ throwM ae)+        `catches` [ Handler (\ (ax :: AsyncCancelled) -> do+                                liftIO (readIORef r) >>=+                                  bool (liftIO $ throwM ax) (left $ AsyncTimeout d)+                            )]  waitEitherBoth :: Async a -> Async b -> Async c -> IO (Either a (b, c)) waitEitherBoth a b c =
+ test/Test/Disorder.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Disorder (+    testIO+  , withCPUTime+  , disorderMain+  , disorderCliMain+  ) where++import           Control.Monad+import           Control.Monad.IO.Class (liftIO, MonadIO)++import           Test.QuickCheck+import           Test.QuickCheck.Monadic++import           System.Directory+import           System.Process+import           System.Exit+import           System.IO+import           System.CPUTime (getCPUTime)++testIO :: forall a. (Testable a) => IO a -> Property+testIO mx = monadicIO $ do+  p <- (run mx)+  stop p :: PropertyM IO a++-- | Perform an action and return the CPU time it takes, in picoseconds+-- (actual precision varies with implementation).+withCPUTime :: MonadIO m => m a -> m (Integer, a)+withCPUTime a = do+  t1 <- liftIO getCPUTime+  r <- a+  t2 <- liftIO getCPUTime+  return (t2 - t1, r)++disorderMain :: [IO Bool] -> IO ()+disorderMain tests =+  sanity >> sequence tests >>= \rs -> unless (and rs) exitFailure++disorderCliMain :: [String] -> IO ()+disorderCliMain arguments =+  let ignore p = ".." == p || "." == p || "core" == p+      exec t = callProcess ("test/cli/" ++ t ++ "/run") arguments+   in sanity >> filter (not . ignore) <$> getDirectoryContents "test/cli/" >>= mapM_ exec++sanity :: IO ()+sanity =+  hSetBuffering stdout LineBuffering >> hSetBuffering stderr LineBuffering
+ test/Test/Entwine/Async.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Async where++import           Control.Concurrent.Async (async, wait, cancel)+import           Control.Monad.Catch (catchAll)+import           Control.Monad.Trans.Either++import           Test.Disorder (testIO)++import           Entwine.P++import           System.IO++import           Test.QuickCheck++import           Entwine.Async+import           Entwine.Data+import           Entwine.Snooze (snooze)++prop_wait_no_timeout = testIO $ do+  a <- async . snooze $ microseconds 5+  e <- runEitherT $ waitWithTimeout a (microseconds 10)+  pure $ e === Right ()++prop_cancel_outside = testIO $ do+  a <- async $ (snooze (milliseconds 20) >> pure True)+  e <- async $ runEitherT $ waitWithTimeout a (milliseconds 5)+  cancel a+  r <- wait e `catchAll` (\_ -> pure . Right $ False)+  pure $ r === Right False++prop_wait_timeout = testIO $ do+  a <- async $ (snooze $ milliseconds 20)+  e <- runEitherT $ waitWithTimeout a (milliseconds 5)+  pure $ e === Left (AsyncTimeout (milliseconds 5))++return []+tests :: IO Bool+tests = $forAllProperties $ quickCheckWithResult (stdArgs { maxSuccess = 10 })
+ test/Test/Entwine/Data/Duration.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Data.Duration where++import           Entwine.P++import           System.IO++import           Test.QuickCheck++import           Entwine.Data.Duration++--+-- Symmetric conversions+--++prop_microseconds n =+  toMicroseconds (microseconds n) === n++prop_milliseconds n =+  toMilliseconds (milliseconds n) === n++prop_seconds n =+  toSeconds (seconds n) === n++prop_minutes n =+  toMinutes (minutes n) === n++prop_hours n =+  toHours (hours n) === n++--+-- Scaling+--++prop_microseconds_scale n =+  toMicroseconds (microseconds n) === n++prop_milliseconds_scale n =+  toMicroseconds (milliseconds n) === (n * 1000)++prop_seconds_scale n =+  toMicroseconds (seconds n) === (n * 1000 * 1000)++prop_minutes_scale n =+  toMicroseconds (minutes n) === (n * 60 * 1000 * 1000)++prop_hours_scale n =+  toMicroseconds (hours n) === (n * 60 * 60 * 1000 * 1000)++--+-- Sanity checks+--++prop_sanity = conjoin [+    hours 1 === minutes 60+  , minutes 1 === seconds 60+  , seconds 1 === milliseconds 1000+  , milliseconds 1 === microseconds 1000++  ]++return []+tests :: IO Bool+tests = $quickCheckAll
+ test/Test/Entwine/Data/Finalizer.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Data.Finalizer where++import           Test.Disorder (testIO)++import           Entwine.P++import           System.IO++import           Test.QuickCheck++import           Entwine.Data.Finalizer+import           Entwine.Data.Pin+++prop_simple = once . testIO $ do+  p <- newPin+  let f = Finalizer $ pullPin p+  finalize f+  checkPin p++prop_monoid = once . testIO $ do+  p1 <- newPin+  p2 <- newPin+  let f = Finalizer (pullPin p1) <> Finalizer (pullPin p2)+  finalize f+  (&&) <$> checkPin p1 <*> checkPin p2+++return []+tests :: IO Bool+tests = $quickCheckAll
+ test/Test/Entwine/Data/Gate.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Data.Gate where++import           Test.Disorder (testIO)++import           Entwine.P++import           Test.QuickCheck++import           Entwine.Data.Gate++--+-- A new gate should isOpen+--++prop_isOpen = once . testIO $+  newGate >>=+    isOpen >>=+      pure . (===) True+++--+-- A gate that has been closed should not be open+--++prop_close = once . testIO $+  newGate >>= \c ->+    close c >>+      isOpen c >>=+        pure . (===) False+++--+-- A gate can be closed multiple times+--++prop_close_multiple = once . testIO $+  newGate >>= \c ->+    close c >> close c >> pure True++return []+tests = $quickCheckAll
+ test/Test/Entwine/Data/Parallel.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Data.Parallel where++import           Test.Disorder (testIO)++import           Entwine.P++import           System.IO++import           Test.QuickCheck+import           Test.QuickCheck.Instances ()++import           Entwine.Data.Parallel++prop_short_circuit = testIO $ do+  r <- newResult (Right () :: Either Text ())+  _ <- addResult r (Left "fail")+  _ <- addResult r (Right ())+  z <- getResult r+  pure $ z === (Left "fail")++prop_read (a :: Int) = testIO $ do+  r <- newResult a+  z <- getResult r+  pure $ z === a++prop_read_read (a :: Int) = testIO $ do+  r <- newResult a+  _ <- getResult r+  z <- getResult r+  pure $ z === a++return []+tests :: IO Bool+tests = $quickCheckAll
+ test/Test/Entwine/Data/Pin.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Data.Pin where++import           Control.Concurrent.Async (async, waitBoth)++import           Test.Disorder (testIO)++import           Entwine.P++import           Test.QuickCheck (quickCheckAll, once, (===))++import           Entwine.Data.Pin+++--+-- We are really just testing that our restricted use of MVar+-- is safe. The point of wrapping it up is preventing dead/live+-- locks, and generally make it more pleasant and less error-+-- prone+--+++--+-- A new pin should not be pulled+--++prop_new = once . testIO $+  newPin >>= checkPin >>= pure . (===) False+++--+-- A pulled pin should be pulled+--++prop_pull = once . testIO $+  newPin >>= \p -> pullPin p >> checkPin p >>= pure . (===) True+++--+-- A pin can be pulled multiple times without blocking+--++prop_pull_pull = once . testIO $+  newPin >>= \p -> pullPin p >> pullPin p >> checkPin p >>= pure . (===) True++--+-- A pin can be pulled without blocking+--++prop_wait = once . testIO $+  newPin >>= \p -> pullPin p >> waitForPin p >> pure True+++--+-- Multiple things can be blocked on a pin+--+prop_multiple = once . testIO $+  newPin >>= \p -> do+   x <- async $ waitForPin p+   y <- async $ waitForPin p+   pullPin p+   r <- waitBoth x y+   pure $ r === ((), ())++--+-- Multiple things can be blocked on a pin+--+prop_multiple_inline = once . testIO $+  newPin >>= \p ->+   pullPin p >> waitForPin p >> waitForPin p >> pure True+++return []+tests = $quickCheckAll
+ test/Test/Entwine/Data/Queue.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Data.Queue where++import           Entwine.P++import           System.IO++import           Test.Disorder+import           Test.QuickCheck+import           Test.QuickCheck.Instances ()++import           Entwine.Data.Queue++prop_read_write (a :: Int) = testIO $ do+  q <- newQueue 1+  writeQueue q a+  r <- readQueue q+  pure $ r === a++prop_empty = testIO $ do+  q <- newQueue 1+  e <- isQueueEmpty q+  pure $ e === True++prop_try_read_non_blocking = testIO $ do+  q <- newQueue 1+  m <- tryReadQueue q+  pure $ m === (Nothing :: Maybe Int)++return []+tests :: IO Bool+tests = $quickCheckAll
+ test/Test/Entwine/Parallel.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Entwine.Parallel where++import           Control.Concurrent.MVar+import           Control.Monad.Catch+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Either++import           Test.Disorder (testIO)++import           Entwine.P++import           System.IO+import           System.IO.Error++import           Test.QuickCheck++import           Entwine.Data+import           Entwine.Parallel++data Fail =+  IFailed++prop_consume = forAll (choose (1, 10 :: Int)) $ \n -> testIO $ do+  r <- newMVar ([] :: [Int])++  let pro = \q -> forM_ [1..n] (writeQueue q)++      work :: Int -> EitherT Fail IO ()+      work i =+        liftIO $ modifyMVar_ r (\l -> pure $ i : l)++  _ <- runEitherT $ consume_ pro 1 work++  g <- readMVar r++  pure $ length g === n++prop_worker_fail = forAll (choose (1, 1000 :: Int)) $ \n -> testIO $ do+  let pro = \q -> forM_ [1..n] (writeQueue q)+      work = const $ left IFailed++  r <- runEitherT $ consume_ pro 1 work+  z <- pure $ case r of+    (Left (WorkerError IFailed)) ->+      True+    _ ->+      False+  pure $ z === True++prop_worker_blow_up_worker = forAll (choose (1, 1000 :: Int)) $ \n -> testIO $ do+  let pro = \q -> forM_ [1..n] (writeQueue q)+      work = const . throwM . userError $ "what is this?"++  r <- runEitherT $ consume_ pro 1 work+  z <- pure $ case r of+    (Left (BlowUpError _)) ->+      True+    _ ->+      False+  pure $ z === True++prop_worker_blow_up_producer = testIO $ do+  let pro = const . throwM . userError $ "producer"+      work = const $ pure ()++  r <- runEitherT $ consume_ pro 1 work+  z <- pure $ case r of+    (Left (BlowUpError _)) ->+      True+    _ ->+      False+  pure $ z === True++prop_empty_producer = testIO $ do+  let pro = const $ pure ()+      work = const $ pure ()++  r <- runEitherT $ consume_ pro 1 work+  pure $ (isRight r) === True+++return []+tests :: IO Bool+tests = $quickCheckAll
+ test/Test/IO/Entwine/Guard.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.IO.Entwine.Guard where++import           Control.Concurrent+import           Control.Monad.Catch+import           Control.Monad.Trans.Either++import           Test.Disorder++import           Entwine.P++import           System.IO+import           System.IO.Error++import           Test.QuickCheck+import           Test.QuickCheck.Instances ()++import           Entwine.Guard++data HResult =+  HExplosion | HError Text | HGraceful deriving (Eq, Show)++handler v = TerminationHandler {+    onExplosion = const $ putMVar v HExplosion >> pure Die+  , onError = \t -> putMVar v (HError t) >> pure Die+  , onGraceful = putMVar v HGraceful >> pure Die+  }++prop_guard_graceful =+  testIO $ do+    v <- newEmptyMVar+    withThread v (pure ()) $ do+      r <- takeMVar v+      pure $ r === HGraceful++prop_guard_error t =+  testIO $ do+    v <- newEmptyMVar+    withThread v (left t) $ do+      r <- takeMVar v+      pure $ r === HError t++prop_guard_explosion =+  testIO $ do+    v <- newEmptyMVar+    withThread v (throwM $ userError "explodez") $ do+      r <- takeMVar v+      pure $ r === HExplosion++withThread :: MVar HResult -> EitherT Text IO () -> IO a -> IO a+withThread v action =+  bracket (forkIO $ guarded (handler v) action) killThread . const++return []+tests :: IO Bool+tests = $forAllProperties $ quickCheckWithResult (stdArgs { maxSuccess = 3 })
+ test/Test/IO/Entwine/Loop.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.IO.Entwine.Loop where++import           Control.Concurrent.Async (async)+import           Control.Monad.Trans.Either (runEitherT)++import           Test.Disorder++import           Entwine.P++import           Test.QuickCheck++import           Entwine.Async (waitWithTimeout)+import           Entwine.Data.Gate+import           Entwine.Data.Duration (milliseconds, seconds)+import           Entwine.Loop++prop_loop = testIO $ do+  g <- newGate+  x <- async $ loop (milliseconds 1) g (pure ()) >> pure True+  close g+  r <- runEitherT $ waitWithTimeout x (seconds 1)+  pure $ r === Right True++return []+tests = $quickCheckAll
+ test/Test/IO/Entwine/Snooze.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.IO.Entwine.Snooze where++import           Data.Time++import           Test.Disorder++import           Entwine.P++import           System.IO++import           Test.QuickCheck++import           Entwine.Snooze+++prop_snooze = forAll (choose (1, 3)) $ \n -> testIO $ do+  s <- getCurrentTime+  snooze . seconds $ n+  e <- getCurrentTime+  let elapsed = diffUTCTime e s+  let expected = (fromInteger . toInteger) n+  pure . counterexample ("Elapsed: " <> show elapsed <> " , Snooze: " <> show expected) $+    elapsed >= expected && elapsed < expected + 1+++return []+tests :: IO Bool+tests = $forAllProperties $ quickCheckWithResult (stdArgs { maxSuccess = 3 })