Skip to content

Commit

Permalink
Merge pull request #965 from kazu-yamamoto/fourmolu
Browse files Browse the repository at this point in the history
Fourmolu
  • Loading branch information
kazu-yamamoto authored Jan 11, 2024
2 parents 85cc5fb + bf70caa commit b18612c
Show file tree
Hide file tree
Showing 149 changed files with 6,125 additions and 4,859 deletions.
82 changes: 50 additions & 32 deletions auto-update/Control/AutoUpdate.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}

-- | In a multithreaded environment, running actions on a regularly scheduled
-- background thread can dramatically improve performance.
-- For example, web servers need to return the current time with each HTTP response.
Expand Down Expand Up @@ -29,39 +30,52 @@
--
-- For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing this library>.
module Control.AutoUpdate (
-- * Type
UpdateSettings
, defaultUpdateSettings
-- * Accessors
, updateAction
, updateFreq
, updateSpawnThreshold
-- * Creation
, mkAutoUpdate
, mkAutoUpdateWithModify
) where
-- * Type
UpdateSettings,
defaultUpdateSettings,

-- * Accessors
updateAction,
updateFreq,
updateSpawnThreshold,

-- * Creation
mkAutoUpdate,
mkAutoUpdateWithModify,
) where

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<*>))
#endif
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
takeMVar, tryPutMVar)
import Control.Exception (SomeException, catch, mask_, throw,
try)
import Control.Monad (void)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (
newEmptyMVar,
putMVar,
readMVar,
takeMVar,
tryPutMVar,
)
import Control.Exception (
SomeException,
catch,
mask_,
throw,
try,
)
import Control.Monad (void)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)

-- | Default value for creating an 'UpdateSettings'.
--
-- @since 0.1.0
defaultUpdateSettings :: UpdateSettings ()
defaultUpdateSettings = UpdateSettings
{ updateFreq = 1000000
, updateSpawnThreshold = 3
, updateAction = return ()
}
defaultUpdateSettings =
UpdateSettings
{ updateFreq = 1000000
, updateSpawnThreshold = 3
, updateAction = return ()
}

-- | Settings to control how values are updated.
--
Expand All @@ -74,7 +88,7 @@ defaultUpdateSettings = UpdateSettings
--
-- @since 0.1.0
data UpdateSettings a = UpdateSettings
{ updateFreq :: Int
{ updateFreq :: Int
-- ^ Microseconds between update calls. Same considerations as
-- 'threadDelay' apply.
--
Expand All @@ -91,7 +105,7 @@ data UpdateSettings a = UpdateSettings
-- Default: 3
--
-- @since 0.1.0
, updateAction :: IO a
, updateAction :: IO a
-- ^ Action to be performed to get the current value.
--
-- Default: does nothing.
Expand Down Expand Up @@ -137,12 +151,16 @@ mkAutoUpdateHelper us updateActionModify = do
let fillRefOnExit f = do
eres <- try f
case eres of
Left e -> writeIORef currRef $ error $
"Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
++ show (e :: SomeException)
Right () -> writeIORef currRef $ error $
"Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
++ "which should be impossible due to usage of infinite loop"
Left e ->
writeIORef currRef $
error $
"Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
++ show (e :: SomeException)
Right () ->
writeIORef currRef $
error $
"Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
++ "which should be impossible due to usage of infinite loop"

-- fork the worker thread immediately. Note that we mask async exceptions,
-- but *not* in an uninterruptible manner. This will allow a
Expand Down
7 changes: 4 additions & 3 deletions auto-update/Control/AutoUpdate/Util.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,8 @@
{-# LANGUAGE CPP #-}
module Control.AutoUpdate.Util
( atomicModifyIORef'
) where

module Control.AutoUpdate.Util (
atomicModifyIORef',
) where

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
Expand Down
45 changes: 24 additions & 21 deletions auto-update/Control/Debounce.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,37 +23,40 @@
-- See the fast-logger package ("System.Log.FastLogger") for real-world usage.
--
-- @since 0.1.2
module Control.Debounce
( -- * Type
DI.DebounceSettings
, defaultDebounceSettings
-- * Accessors
, DI.debounceFreq
, DI.debounceAction
, DI.debounceEdge
, DI.leadingEdge
, DI.trailingEdge
-- * Creation
, mkDebounce
) where
module Control.Debounce (
-- * Type
DI.DebounceSettings,
defaultDebounceSettings,

import Control.Concurrent (newEmptyMVar, threadDelay)
-- * Accessors
DI.debounceFreq,
DI.debounceAction,
DI.debounceEdge,
DI.leadingEdge,
DI.trailingEdge,

-- * Creation
mkDebounce,
) where

import Control.Concurrent (newEmptyMVar, threadDelay)
import qualified Control.Debounce.Internal as DI

-- | Default value for creating a 'DebounceSettings'.
--
-- @since 0.1.2
defaultDebounceSettings :: DI.DebounceSettings
defaultDebounceSettings = DI.DebounceSettings
{ DI.debounceFreq = 1000000
, DI.debounceAction = return ()
, DI.debounceEdge = DI.leadingEdge
}
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.
--
-- @since 0.1.2
mkDebounce :: DI.DebounceSettings -> IO (IO ())
mkDebounce settings = do
baton <- newEmptyMVar
DI.mkDebounceInternal baton threadDelay settings
baton <- newEmptyMVar
DI.mkDebounceInternal baton threadDelay settings
65 changes: 35 additions & 30 deletions auto-update/Control/Debounce/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,17 +2,22 @@

-- | Unstable API which exposes internals for testing.
module Control.Debounce.Internal (
DebounceSettings(..)
, DebounceEdge(..)
, leadingEdge
, trailingEdge
, mkDebounceInternal
) where
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)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (
MVar,
takeMVar,
tryPutMVar,
tryTakeMVar,
)
import Control.Exception (SomeException, handle, mask_)
import Control.Monad (forever, void)

-- | Settings to control how debouncing should work.
--
Expand All @@ -25,7 +30,7 @@ import Control.Monad (forever, void)
--
-- @since 0.1.2
data DebounceSettings = DebounceSettings
{ debounceFreq :: Int
{ debounceFreq :: Int
-- ^ Length of the debounce timeout period in microseconds.
--
-- Default: 1 second (1000000)
Expand All @@ -52,16 +57,15 @@ data DebounceSettings = DebounceSettings
-- 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)

data DebounceEdge
= -- | 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.
Leading
| -- | Start a cooldown period and perform the action when the period ends. If another trigger
-- happens during the cooldown, it has no effect.
Trailing
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
Expand All @@ -78,19 +82,20 @@ leadingEdge = Leading
trailingEdge :: DebounceEdge
trailingEdge = Trailing

mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
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
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 ()

Expand Down
Loading

0 comments on commit b18612c

Please sign in to comment.