Hello community,
here is the log from the commit of package ghc-auto-update for openSUSE:Factory
checked in at 2019-07-29 17:25:59
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-auto-update (Old)
and /work/SRC/openSUSE:Factory/.ghc-auto-update.new.4126 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-auto-update"
Mon Jul 29 17:25:59 2019 rev:13 rq:715408 version:0.1.6
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-auto-update/ghc-auto-update.changes
2019-06-30 10:21:31.459622340 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-auto-update.new.4126/ghc-auto-update.changes
2019-07-29 17:26:01.126310486 +0200
@@ -1,0 +2,9 @@
+Wed Jul 10 02:03:01 UTC 2019 - [email protected]
+
+- Update auto-update to version 0.1.6.
+ ## 0.1.6
+
+ * Add control of activation on leading vs. trailing edges for
Control.Debounce
+ [#756](https://github.com/yesodweb/wai/pull/756)
+
+-------------------------------------------------------------------
Old:
----
auto-update-0.1.5.tar.gz
New:
----
auto-update-0.1.6.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-auto-update.spec ++++++
--- /var/tmp/diff_new_pack.109f1y/_old 2019-07-29 17:26:01.642310296 +0200
+++ /var/tmp/diff_new_pack.109f1y/_new 2019-07-29 17:26:01.642310296 +0200
@@ -17,8 +17,9 @@
%global pkg_name auto-update
+%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.1.5
+Version: 0.1.6
Release: 0
Summary: Efficiently run periodic, on-demand actions
License: MIT
@@ -27,6 +28,12 @@
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-rpm-macros
+%if %{with tests}
+BuildRequires: ghc-HUnit-devel
+BuildRequires: ghc-exceptions-devel
+BuildRequires: ghc-hspec-devel
+BuildRequires: ghc-retry-devel
+%endif
%description
API docs and the README are available at
@@ -52,6 +59,9 @@
%install
%ghc_lib_install
+%check
+%cabal_test
+
%post devel
%ghc_pkg_recache
++++++ auto-update-0.1.5.tar.gz -> auto-update-0.1.6.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/ChangeLog.md
new/auto-update-0.1.6/ChangeLog.md
--- old/auto-update-0.1.5/ChangeLog.md 2019-06-18 03:58:46.000000000 +0200
+++ new/auto-update-0.1.6/ChangeLog.md 2019-07-09 09:40:38.000000000 +0200
@@ -1,5 +1,10 @@
# ChangeLog for auto-update
+## 0.1.6
+
+* Add control of activation on leading vs. trailing edges for Control.Debounce
+ [#756](https://github.com/yesodweb/wai/pull/756)
+
## 0.1.5
* Using the Strict and StrictData language extensions for GHC >8.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/Control/Debounce/Internal.hs
new/auto-update-0.1.6/Control/Debounce/Internal.hs
--- old/auto-update-0.1.5/Control/Debounce/Internal.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/auto-update-0.1.6/Control/Debounce/Internal.hs 2019-07-09
09:40:38.000000000 +0200
@@ -0,0 +1,98 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Unstable API which exposes internals for testing.
+module Control.Debounce.Internal (
+ DebounceSettings(..)
+ , DebounceEdge(..)
+ , leadingEdge
+ , trailingEdge
+ , mkDebounceInternal
+ ) where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar,
MVar)
+import Control.Exception (SomeException, handle, mask_)
+import Control.Monad (forever, void)
+
+-- | Settings to control how debouncing should work.
+--
+-- This should be constructed using 'defaultDebounceSettings' and record
+-- update syntax, e.g.:
+--
+-- @
+-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
+-- @
+--
+-- @since 0.1.2
+data DebounceSettings = DebounceSettings
+ { debounceFreq :: Int
+ -- ^ Length of the debounce timeout period in microseconds.
+ --
+ -- Default: 1 second (1000000)
+ --
+ -- @since 0.1.2
+ , debounceAction :: IO ()
+ -- ^ Action to be performed.
+ --
+ -- Note: all exceptions thrown by this action will be silently discarded.
+ --
+ -- Default: does nothing.
+ --
+ -- @since 0.1.2
+ , debounceEdge :: DebounceEdge
+ -- ^ Whether to perform the action on the leading edge or trailing edge of
+ -- the timeout.
+ --
+ -- Default: 'trailingEdge'.
+ --
+ -- @since 0.1.6
+ }
+
+-- | Setting to control whether the action happens at the leading and/or
trailing
+-- edge of the timeout.
+--
+-- @since 0.1.6
+data DebounceEdge =
+ Leading
+ -- ^ Perform the action immediately, and then begin a cooldown period.
+ -- If the trigger happens again during the cooldown, wait until the end of
the cooldown
+ -- and then perform the action again, then enter a new cooldown period.
+ | Trailing
+ -- ^ Start a cooldown period and perform the action when the period ends. If
another trigger
+ -- happens during the cooldown, it has no effect.
+ deriving (Show, Eq)
+
+
+-- | Perform the action immediately, and then begin a cooldown period.
+-- If the trigger happens again during the cooldown, wait until the end of the
cooldown
+-- and then perform the action again, then enter a new cooldown period.
+--
+-- @since 0.1.6
+leadingEdge :: DebounceEdge
+leadingEdge = Leading
+
+-- | Start a cooldown period and perform the action when the period ends. If
another trigger
+-- happens during the cooldown, it has no effect.
+--
+-- @since 0.1.6
+trailingEdge :: DebounceEdge
+trailingEdge = Trailing
+
+mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO
())
+mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do
+ mask_ $ void $ forkIO $ forever $ do
+ takeMVar baton
+ case edge of
+ Leading -> do
+ ignoreExc action
+ delayFn freq
+ Trailing -> do
+ delayFn freq
+ -- Empty the baton of any other activations during the interval
+ void $ tryTakeMVar baton
+ ignoreExc action
+
+ return $ void $ tryPutMVar baton ()
+
+ignoreExc :: IO () -> IO ()
+ignoreExc = handle $ \(_ :: SomeException) -> return ()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/Control/Debounce.hs
new/auto-update-0.1.6/Control/Debounce.hs
--- old/auto-update-0.1.5/Control/Debounce.hs 2019-06-18 03:58:46.000000000
+0200
+++ new/auto-update-0.1.6/Control/Debounce.hs 2019-07-09 09:40:38.000000000
+0200
@@ -11,6 +11,7 @@
-- printString <- 'mkDebounce' 'defaultDebounceSettings'
-- { 'debounceAction' = putStrLn "Running action"
-- , 'debounceFreq' = 5000000 -- 5 seconds
+-- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the
trailing edge
-- }
-- @
--
@@ -25,70 +26,35 @@
-- @since 0.1.2
module Control.Debounce
( -- * Type
- DebounceSettings
+ DI.DebounceSettings
, defaultDebounceSettings
-- * Accessors
- , debounceFreq
- , debounceAction
+ , DI.debounceFreq
+ , DI.debounceAction
+ , DI.debounceEdge
+ , DI.leadingEdge
+ , DI.trailingEdge
-- * Creation
, mkDebounce
) where
-import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)
-import Control.Exception (SomeException, handle, mask_)
-import Control.Monad (forever, void)
-
--- | Settings to control how debouncing should work.
---
--- This should be constructed using 'defaultDebounceSettings' and record
--- update syntax, e.g.:
---
--- @
--- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
--- @
---
--- @since 0.1.2
-data DebounceSettings = DebounceSettings
- { debounceFreq :: Int
- -- ^ Microseconds lag required between subsequence calls to the debounced
- -- action.
- --
- -- Default: 1 second (1000000)
- --
- -- @since 0.1.2
- , debounceAction :: IO ()
- -- ^ Action to be performed.
- --
- -- Note: all exceptions thrown by this action will be silently discarded.
- --
- -- Default: does nothing.
- --
- -- @since 0.1.2
- }
+import Control.Concurrent (newEmptyMVar, threadDelay)
+import qualified Control.Debounce.Internal as DI
-- | Default value for creating a 'DebounceSettings'.
--
-- @since 0.1.2
-defaultDebounceSettings :: DebounceSettings
-defaultDebounceSettings = DebounceSettings
- { debounceFreq = 1000000
- , debounceAction = return ()
+defaultDebounceSettings :: DI.DebounceSettings
+defaultDebounceSettings = DI.DebounceSettings
+ { DI.debounceFreq = 1000000
+ , DI.debounceAction = return ()
+ , DI.debounceEdge = DI.leadingEdge
}
--- | Generate an action which will trigger the debounced action to be
--- performed. The action will either be performed immediately, or after the
--- current cooldown period has expired.
+-- | Generate an action which will trigger the debounced action to be
performed.
--
-- @since 0.1.2
-mkDebounce :: DebounceSettings -> IO (IO ())
-mkDebounce (DebounceSettings freq action) = do
- baton <- newEmptyMVar
- mask_ $ void $ forkIO $ forever $ do
- takeMVar baton
- ignoreExc action
- threadDelay freq
- return $ void $ tryPutMVar baton ()
-
-ignoreExc :: IO () -> IO ()
-ignoreExc = handle $ \(_ :: SomeException) -> return ()
+mkDebounce :: DI.DebounceSettings -> IO (IO ())
+mkDebounce settings = do
+ baton <- newEmptyMVar
+ DI.mkDebounceInternal baton threadDelay settings
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/auto-update.cabal
new/auto-update-0.1.6/auto-update.cabal
--- old/auto-update-0.1.5/auto-update.cabal 2019-06-18 03:58:46.000000000
+0200
+++ new/auto-update-0.1.6/auto-update.cabal 2019-07-09 09:40:38.000000000
+0200
@@ -1,5 +1,5 @@
name: auto-update
-version: 0.1.5
+version: 0.1.6
synopsis: Efficiently run periodic, on-demand actions
description: API docs and the README are available at
<http://www.stackage.org/package/auto-update>.
homepage: https://github.com/yesodweb/wai
@@ -17,6 +17,7 @@
ghc-options: -Wall
exposed-modules: Control.AutoUpdate
Control.Debounce
+ Control.Debounce.Internal
Control.Reaper
other-modules: Control.AutoUpdate.Util
build-depends: base >= 4 && < 5
@@ -26,11 +27,12 @@
-- Test suite is currently not robust enough, gives too many false negatives.
--- test-suite spec
--- main-is: Spec.hs
--- other-modules: Control.AutoUpdateSpec
--- Control.ReaperSpec
--- hs-source-dirs: test
--- type: exitcode-stdio-1.0
--- build-depends: base, auto-update, hspec
--- default-language: Haskell2010
+test-suite spec
+ main-is: Spec.hs
+ other-modules: Control.AutoUpdateSpec
+ Control.DebounceSpec
+ Control.ReaperSpec
+ hs-source-dirs: test
+ type: exitcode-stdio-1.0
+ build-depends: base, auto-update, exceptions, hspec, retry, HUnit
+ default-language: Haskell2010
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/test/Control/AutoUpdateSpec.hs
new/auto-update-0.1.6/test/Control/AutoUpdateSpec.hs
--- old/auto-update-0.1.5/test/Control/AutoUpdateSpec.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/auto-update-0.1.6/test/Control/AutoUpdateSpec.hs 2019-07-09
09:40:38.000000000 +0200
@@ -0,0 +1,35 @@
+module Control.AutoUpdateSpec (spec) where
+
+import Control.AutoUpdate
+import Control.Concurrent (threadDelay)
+import Control.Monad (replicateM_, forM_)
+import Data.IORef
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+spec :: Spec
+spec = return ()
+ -- do
+ -- prop "incrementer" $ \st' -> do
+ -- let st = abs st' `mod` 10000
+ -- ref <- newIORef 0
+ -- next <- mkAutoUpdate defaultUpdateSettings
+ -- { updateAction = atomicModifyIORef ref $ \i ->
+ -- let i' = succ i in i' `seq` (i', i')
+ -- , updateSpawnThreshold = st
+ -- , updateFreq = 10000
+ -- }
+
+ -- forM_ [1..st + 1] $ \i -> do
+ -- j <- next
+ -- j `shouldBe` i
+
+ -- replicateM_ 50 $ do
+ -- i <- next
+ -- i `shouldBe` st + 2
+
+ -- threadDelay 60000
+ -- last1 <- readIORef ref
+ -- threadDelay 20000
+ -- last2 <- readIORef ref
+ -- last2 `shouldBe` last1
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/test/Control/DebounceSpec.hs
new/auto-update-0.1.6/test/Control/DebounceSpec.hs
--- old/auto-update-0.1.5/test/Control/DebounceSpec.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/auto-update-0.1.6/test/Control/DebounceSpec.hs 2019-07-09
09:40:38.000000000 +0200
@@ -0,0 +1,120 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Control.DebounceSpec (spec) where
+
+import Control.Concurrent
+import Control.Debounce
+import qualified Control.Debounce.Internal as DI
+import Control.Monad
+import Control.Monad.Catch
+import Control.Retry
+import Data.IORef
+import Test.HUnit.Lang
+import Test.Hspec
+
+spec :: Spec
+spec = describe "mkDebounce" $ do
+ describe "Leading edge" $ do
+ it "works for a single event" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge
+
+ debounced
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ returnFromWait
+ pause
+ readIORef ref >>= (`shouldBe` 1)
+
+ -- Try another round
+ debounced
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
+
+ returnFromWait
+ pause
+ readIORef ref >>= (`shouldBe` 2)
+
+ it "works for multiple events" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge
+
+ debounced
+ waitForBatonToBeTaken baton
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ returnFromWait
+ pause
+ readIORef ref >>= (`shouldBe` 2)
+
+ describe "Trailing edge" $ do
+ it "works for a single event" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge
+
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
+
+ returnFromWait
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ -- Try another round
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ returnFromWait
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
+
+ it "works for multiple events" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge
+
+ debounced
+ waitForBatonToBeTaken baton
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
+
+ returnFromWait
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+
+-- | Make a controllable delay function
+getWaitAction :: IO (p -> IO (), IO ())
+getWaitAction = do
+ waitVar <- newEmptyMVar
+ let waitAction _ = takeMVar waitVar
+ let returnFromWait = putMVar waitVar ()
+ return (waitAction, returnFromWait)
+
+-- | Get a debounce system with access to the internals for testing
+getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())
+getDebounce edge = do
+ ref :: IORef Int <- newIORef 0
+ let action = modifyIORef ref (+ 1)
+
+ (waitAction, returnFromWait) <- getWaitAction
+
+ baton <- newEmptyMVar
+
+ debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {
+ debounceFreq = 5000000 -- unused
+ , debounceAction = action
+ , debounceEdge = edge
+ }
+
+ return (ref, debounced, baton, returnFromWait)
+
+-- | Pause briefly (100ms)
+pause :: IO ()
+pause = threadDelay 100000
+
+waitForBatonToBeTaken :: MVar () -> IO ()
+waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe`
Nothing)
+
+-- | Wait up to n seconds for an action to complete without throwing an
HUnitFailure
+waitUntil :: Int -> IO a -> IO ()
+waitUntil n action = recovering policy [handler] (\_status -> void action)
+ where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms *
n * 1000 tries = n seconds
+ handler _status = Handler (\(HUnitFailure {}) -> return True)
+
+main :: IO ()
+main = hspec spec
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/test/Control/ReaperSpec.hs
new/auto-update-0.1.6/test/Control/ReaperSpec.hs
--- old/auto-update-0.1.5/test/Control/ReaperSpec.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/auto-update-0.1.6/test/Control/ReaperSpec.hs 2019-07-09
09:40:38.000000000 +0200
@@ -0,0 +1,39 @@
+module Control.ReaperSpec (spec) where
+
+import Control.Concurrent
+import Control.Reaper
+import Data.IORef
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+
+spec :: Spec
+spec = return ()
+-- prop "works" $ \is -> do
+-- reaper <- mkReaper defaultReaperSettings
+-- { reaperAction = action
+-- , reaperDelay = 1000
+-- }
+
+-- let mkTestCase i = do
+-- ref <- newIORef 0
+-- let expected = (abs i `mod` 10) + 1
+-- reaperAdd reaper (expected, ref)
+-- return (expected, ref)
+-- testCases <- mapM mkTestCase is
+
+-- let test (expected, ref) = do
+-- actual <- readIORef ref
+-- actual `shouldBe` (expected :: Int)
+-- threadDelay 100000
+-- mapM_ test testCases
+-- [] <- reaperRead reaper
+-- return ()
+
+-- type Item = (Int, IORef Int)
+
+-- action = mkListAction $ \(i, ref) -> do
+-- modifyIORef ref succ
+-- return $ if i > 1
+-- then Just (pred i, ref)
+-- else Nothing
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.5/test/Spec.hs
new/auto-update-0.1.6/test/Spec.hs
--- old/auto-update-0.1.5/test/Spec.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/auto-update-0.1.6/test/Spec.hs 2015-11-09 03:12:10.000000000 +0100
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
