Add AutoUpdate example to tests

dejafu-tests/Examples/AutoUpdate.hs

@@ -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)

dejafu-tests/Main.hs

@@ -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
     ]
   ]

dejafu-tests/dejafu-tests.cabal

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