slave-thread 1.0.2.3 → 1.0.2.4
raw patch · 3 files changed
+153/−159 lines, 3 filesdep +tastydep +tasty-hunitdep +tasty-quickcheckdep −HTFdep ~QuickCheckdep ~quickcheck-instancesdep ~rerebasePVP ok
version bump matches the API change (PVP)
Dependencies added: tasty, tasty-hunit, tasty-quickcheck
Dependencies removed: HTF
Dependency ranges changed: QuickCheck, quickcheck-instances, rerebase
API changes (from Hackage documentation)
Files
- library/SlaveThread.hs +7/−5
- slave-thread.cabal +31/−57
- test/Main.hs +115/−97
library/SlaveThread.hs view
@@ -90,13 +90,15 @@ forkIOWithoutHandler $ do slaveThread <- myThreadId catch- (unmask $ do- computation- -- Context management:- killSlaves slaveThread- waitForSlavesToDie slaveThread)+ (unmask (void computation)) (PartialHandler.totalizeRethrowingTo_ masterThread (PartialHandler.onThreadKilled (return ())))+ -- Context management:+ catch+ (do+ killSlaves slaveThread+ waitForSlavesToDie slaveThread)+ (PartialHandler.totalizeRethrowingTo_ masterThread mempty) -- Finalization: catch (void finalizer) $ PartialHandler.totalizeRethrowingTo_ masterThread $ mempty
slave-thread.cabal view
@@ -1,9 +1,6 @@-name:- slave-thread-version:- 1.0.2.3-synopsis:- A fundamental solution to ghost threads and silent exceptions+name: slave-thread+version: 1.0.2.4+synopsis: A fundamental solution to ghost threads and silent exceptions description: Vanilla thread management in Haskell is low level and it does not approach the problems related to thread deaths.@@ -37,42 +34,26 @@ This protects you from silent exceptions and lets you be sure of getting informed if your program gets brought to an erroneous state.-category:- Concurrency, Concurrent, Error Handling, Exceptions, Failure-homepage:- https://github.com/nikita-volkov/slave-thread -bug-reports:- https://github.com/nikita-volkov/slave-thread/issues -author:- Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:- Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:- (c) 2014, Nikita Volkov-license:- MIT-license-file:- LICENSE-build-type:- Simple-cabal-version:- >=1.10+category: Concurrency, Concurrent, Error Handling, Exceptions, Failure+homepage: https://github.com/nikita-volkov/slave-thread+bug-reports: https://github.com/nikita-volkov/slave-thread/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2014, Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10 source-repository head- type:- git- location:- git://github.com/nikita-volkov/slave-thread.git+ type: git+ location: git://github.com/nikita-volkov/slave-thread.git library- hs-source-dirs:- library- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010- exposed-modules:- SlaveThread+ hs-source-dirs: library+ default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language: Haskell2010+ exposed-modules: SlaveThread build-depends: base >=4.9 && <5, deferred-folds >=0.9 && <0.10,@@ -83,24 +64,17 @@ transformers >=0.5 && <0.6 test-suite test- type: - exitcode-stdio-1.0- hs-source-dirs: - test- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010- ghc-options:- -threaded- "-with-rtsopts=-N"- -funbox-strict-fields- main-is: - Main.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples+ default-language: Haskell2010+ main-is: Main.hs build-depends:- HTF ==0.13.*,- QuickCheck >=2.6 && <3,- quickcheck-instances ==0.3.*,- rerebase >=1 && <2,+ QuickCheck >=2.8.1 && <3,+ quickcheck-instances >=0.3.11 && <0.4,+ rerebase <2, SafeSemaphore ==0.10.*,- slave-thread+ slave-thread,+ tasty >=0.12 && <2,+ tasty-hunit >=0.9 && <0.11,+ tasty-quickcheck >=0.9 && <0.11
test/Main.hs view
@@ -1,112 +1,130 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-} module Main where import Prelude-import Test.Framework+import Control.Concurrent.STM import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified Test.QuickCheck.Property as QuickCheck import qualified SlaveThread as S import qualified Control.Concurrent.SSem as SSem -main = - htfMain $ htf_thisModulesTests---test_failingInFinalizerDoesntBreakEverything =- do- finalizer1CalledVar <- newTVarIO False- finalizer2CalledVar <- newTVarIO False- let- finalizer1 =- atomically $ writeTVar finalizer1CalledVar True- finalizer2 =- do- atomically $ writeTVar finalizer2CalledVar True- throwIO (userError "finalizer2 failed")- in do- result :: Either SomeException () <- try $ do+main =+ defaultMain $+ testGroup "All" $ [+ testCase "Failing in finalizer doesn't break everything" $ do+ finalizer1CalledVar <- newTVarIO False+ finalizer2CalledVar <- newTVarIO False+ result <- let+ finalizer1 =+ atomically $ writeTVar finalizer1CalledVar True+ finalizer2 =+ do+ atomically $ writeTVar finalizer2CalledVar True+ throwIO (userError "finalizer2 failed")+ in try @SomeException $ do S.forkFinally finalizer1 $ do S.forkFinally finalizer2 $ threadDelay 100 threadDelay (10^4)- assertEqual "Left user error (finalizer2 failed)" (show result)- finalizer2Called <- atomically (readTVar finalizer2CalledVar)- finalizer1Called <- atomically (readTVar finalizer1CalledVar)- assertEqual True finalizer2Called- assertEqual True finalizer1Called--test_forkedThreadsRunFine = - replicateM 100000 $ do- var <- newMVar 0- let increment = modifyMVar_ var (return . succ)- semaphore <- SSem.new 0- S.fork $ do- increment- semaphore' <- SSem.new (-1)- S.fork $ do- increment- SSem.signal semaphore'- S.fork $ do- increment- SSem.signal semaphore'- SSem.wait semaphore'- SSem.signal semaphore- SSem.wait semaphore- assertEqual 3 =<< readMVar var--test_killingAThreadKillsDeepSlaves = - replicateM 100000 $ do- var <- newMVar 0- semaphore <- SSem.new 0- thread <- - S.forkFinally (SSem.signal semaphore) $ do- join $ forkWait $ do- join $ forkWait $ do- w <- forkWait $ do+ assertEqual "" "Left user error (finalizer2 failed)" (show result)+ finalizer2Called <- atomically (readTVar finalizer2CalledVar)+ finalizer1Called <- atomically (readTVar finalizer1CalledVar)+ assertEqual "" True finalizer2Called+ assertEqual "" True finalizer1Called+ ,+ testCase "Forked threads run fine" $ do+ replicateM_ 100000 $ do+ var <- newMVar 0+ let increment = modifyMVar_ var (return . succ)+ semaphore <- SSem.new 0+ S.fork $ do+ increment+ semaphore' <- SSem.new (-1)+ S.fork $ do+ increment+ SSem.signal semaphore'+ S.fork $ do+ increment+ SSem.signal semaphore'+ SSem.wait semaphore'+ SSem.signal semaphore+ SSem.wait semaphore+ assertEqual "" 3 =<< readMVar var+ ,+ testCase "Killing a thread kills deep slaves" $ do+ replicateM_ 100000 $ do+ var <- newMVar 0+ semaphore <- SSem.new 0+ thread <-+ S.forkFinally (SSem.signal semaphore) $ do+ join $ forkWait $ do+ join $ forkWait $ do+ w <- forkWait $ do+ threadDelay $ 10^6+ modifyMVar_ var (return . succ)+ threadDelay $ 10^6+ modifyMVar_ var (return . succ)+ w+ killThread thread+ SSem.wait semaphore+ assertEqual "" 0 =<< readMVar var+ ,+ testCase "Dying normally kills slaves" $ do+ replicateM_ 100000 $ do+ var <- newIORef 0+ let increment = modifyIORef var (+1)+ semaphore <- SSem.new 0+ S.forkFinally (SSem.signal semaphore) $ do+ S.fork $ do+ threadDelay $ 10^6+ increment+ S.fork $ do+ threadDelay $ 10^6+ increment+ SSem.wait semaphore+ assertEqual "" 0 =<< readIORef var+ ,+ testCase "Finalization is in order" $ do+ replicateM_ 100000 $ do+ var <- newMVar []+ semaphore <- SSem.new 0+ S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (1:)) >> SSem.signal semaphore)) $ do+ semaphore' <- SSem.new 0+ S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (2:)) >> SSem.signal semaphore')) $ do+ S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return ()+ S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return ()+ SSem.wait semaphore'+ SSem.wait semaphore+ assertEqual "" [1,2,3,3] =<< readMVar var+ ,+ testCase "Exceptions don't get lost" $ do+ replicateM_ 100000 $ do+ result <- try @SomeException $ do+ S.fork $ do+ S.fork $ do+ error "!"+ threadDelay $ 10^6+ threadDelay $ 10^6+ assertBool "" (isLeft result)+ ,+ testCase "Slaves are finalized before master" $ do+ replicateM_ 100000 $ do+ ready <- newEmptyMVar+ var <- newEmptyTMVarIO+ thread <-+ S.forkFinally (atomically (tryPutTMVar var 1)) $ do+ S.forkFinally (atomically (tryPutTMVar var 0)) $ threadDelay $ 10^6- modifyMVar_ var (return . succ)+ putMVar ready () threadDelay $ 10^6- modifyMVar_ var (return . succ)- w- killThread thread- SSem.wait semaphore- assertEqual 0 =<< readMVar var--test_dyingNormallyKillsSlaves = - replicateM 100000 $ do- var <- newIORef 0- let increment = modifyIORef var (+1)- semaphore <- SSem.new 0- S.forkFinally (SSem.signal semaphore) $ do- S.fork $ do- threadDelay $ 10^6- increment- S.fork $ do- threadDelay $ 10^6- increment- SSem.wait semaphore- assertEqual 0 =<< readIORef var--test_finalizationOrder = - replicateM 100000 $ do- var <- newMVar []- semaphore <- SSem.new 0- S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (1:)) >> SSem.signal semaphore)) $ do- semaphore' <- SSem.new 0- S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (2:)) >> SSem.signal semaphore')) $ do- S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return ()- S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return ()- SSem.wait semaphore'- SSem.wait semaphore- assertEqual [1,2,3,3] =<< readMVar var--test_exceptionsDontGetLost = - replicateM 100000 $ do- assertThrowsSomeIO $ do- S.fork $ do- S.fork $ do- error "!"- threadDelay $ 10^6- threadDelay $ 10^6+ takeMVar ready+ killThread thread+ assertEqual "First finalizer is not slave" 0 =<< atomically (readTMVar var)+ ] forkWait :: IO a -> IO (IO ()) forkWait io =@@ -115,5 +133,5 @@ S.fork $ do r <- try io putMVar v ()- either (throwIO :: SomeException -> IO a) return r+ either (throwIO @SomeException) return r return $ takeMVar v