Add AutoUpdate example to tests

This commit is contained in:
Michael Walker 2016-03-31 14:37:02 +01:00
parent 2952b75526
commit 9e68038e2b
3 changed files with 131 additions and 2 deletions

View File

@ -0,0 +1,126 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-
The auto-update package:
https://hackage.haskell.org/package/auto-update
Users found a possible deadlock and livelock:
https://www.reddit.com/r/haskell/comments/2i5d7m/updating_autoupdate/
This is the code from Control.AutoUpdate modified to use the
@MonadConc@ abstraction, with tests added to verify that the issues
identified are caught.. The original code is available under the MIT
license, which is reproduced below.
- - - - -
Copyright (c) 2014 Michael Snoyman
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-}
module Examples.AutoUpdate (tests) where
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.Conc.Class
-- test imports
import Test.DejaFu (Bounds(..), Failure(..), MemType(..), defaultBounds, gives)
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (hUnitTestToTests)
import Test.HUnit (test)
import Test.HUnit.DejaFu
tests :: [Test]
tests = hUnitTestToTests $ test
[ testDejafu' SequentialConsistency
defaultBounds
deadlocks
"deadlocks"
(gives [Left Deadlock, Right ()])
, testDejafu' SequentialConsistency
defaultBounds { preemptionBound = Just 3 }
nondeterministic
"nondeterministic"
(gives [Left Deadlock, Right 0, Right 1])
]
-- This exhibits a deadlock with no preemptions.
deadlocks :: MonadConc m => m ()
deadlocks = join (mkAutoUpdate defaultUpdateSettings)
-- This exhibits nondeterminism with three preemptions.
nondeterministic :: forall m. MonadConc m => m Int
nondeterministic = do
var <- newCRef 0
let settings = (defaultUpdateSettings :: UpdateSettings m ())
{ updateAction = atomicModifyCRef var (\x -> (x+1, x)) }
auto <- mkAutoUpdate settings
auto
auto
-------------------------------------------------------------------------------
data UpdateSettings m a = UpdateSettings
{ updateFreq :: Int
, updateSpawnThreshold :: Int
, updateAction :: m a
}
defaultUpdateSettings :: MonadConc m => UpdateSettings m ()
defaultUpdateSettings = UpdateSettings
{ updateFreq = 1000000
, updateSpawnThreshold = 3
, updateAction = return ()
}
mkAutoUpdate :: MonadConc m => UpdateSettings m a -> m (m a)
mkAutoUpdate us = do
currRef <- newCRef Nothing
needsRunning <- newEmptyMVar
lastValue <- newEmptyMVar
void $ fork $ forever $ do
takeMVar needsRunning
a <- catchSome $ updateAction us
writeCRef currRef $ Just a
void $ tryTakeMVar lastValue
putMVar lastValue a
threadDelay $ updateFreq us
writeCRef currRef Nothing
void $ takeMVar lastValue
return $ do
mval <- readCRef currRef
case mval of
Just val -> return val
Nothing -> do
void $ tryPutMVar needsRunning ()
readMVar lastValue
catchSome :: MonadConc m => m a -> m a
catchSome act = catch act $
\e -> throw (e :: SomeException)

View File

@ -5,8 +5,9 @@ import Test.Framework (defaultMain, testGroup)
import qualified Cases.SingleThreaded as ST
import qualified Cases.MultiThreaded as MT
import qualified Cases.Litmus as L
import qualified Examples.Logger as EL
import qualified Examples.AutoUpdate as EA
import qualified Examples.ClassLaws as EC
import qualified Examples.Logger as EL
import qualified Examples.Philosophers as EP
main :: IO ()
@ -17,8 +18,9 @@ main = defaultMain
, testGroup "Litmus" L.tests
]
, testGroup "Examples"
[ testGroup "Message Logger" EL.tests
[ testGroup "auto-update" EA.tests
, testGroup "Class Laws" EC.tests
, testGroup "Dining Philosophers" EP.tests
, testGroup "Message Logger" EL.tests
]
]

View File

@ -23,6 +23,7 @@ executable dejafu-tests
, Cases.MultiThreaded
, Cases.Litmus
, Examples.AutoUpdate
, Examples.ClassLaws
, Examples.Logger
, Examples.Philosophers