0434674c85
Avoids users thinking this scan is a big deal, when it's not in the majority of repos. showSideActionAfter has some ugly caveats, since it has to display in the background of another action. I could not see a better way to do it and it works fine in this particular case. It also doesn't really belong in Annex.Concurrent, but cannot go in Messages due to an import loop. Sponsored-by: Dartmouth College's Datalad project
78 lines
1.9 KiB
Haskell
78 lines
1.9 KiB
Haskell
{- thread scheduling
|
|
-
|
|
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
|
|
- Copyright 2011 Bas van Dijk & Roel van Dijk
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Utility.ThreadScheduler (
|
|
Seconds(..),
|
|
Microseconds,
|
|
runEvery,
|
|
threadDelaySeconds,
|
|
waitForTermination,
|
|
oneSecond,
|
|
unboundDelay,
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Control.Concurrent
|
|
#ifndef mingw32_HOST_OS
|
|
import Control.Monad.IfElse
|
|
import System.Posix.IO
|
|
#endif
|
|
#ifndef mingw32_HOST_OS
|
|
import System.Posix.Signals
|
|
import System.Posix.Terminal
|
|
#endif
|
|
|
|
newtype Seconds = Seconds { fromSeconds :: Int }
|
|
deriving (Eq, Ord, Show)
|
|
|
|
type Microseconds = Integer
|
|
|
|
{- Runs an action repeatedly forever, sleeping at least the specified number
|
|
- of seconds in between. -}
|
|
runEvery :: Seconds -> IO a -> IO a
|
|
runEvery n a = forever $ do
|
|
threadDelaySeconds n
|
|
a
|
|
|
|
threadDelaySeconds :: Seconds -> IO ()
|
|
threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
|
|
|
|
{- Like threadDelay, but not bounded by an Int.
|
|
-
|
|
- There is no guarantee that the thread will be rescheduled promptly when the
|
|
- delay has expired, but the thread will never continue to run earlier than
|
|
- specified.
|
|
-
|
|
- Taken from the unbounded-delay package to avoid a dependency for 4 lines
|
|
- of code.
|
|
-}
|
|
unboundDelay :: Microseconds -> IO ()
|
|
unboundDelay time = do
|
|
let maxWait = min time $ toInteger (maxBound :: Int)
|
|
threadDelay $ fromInteger maxWait
|
|
when (maxWait /= time) $ unboundDelay (time - maxWait)
|
|
|
|
{- Pauses the main thread, letting children run until program termination. -}
|
|
waitForTermination :: IO ()
|
|
waitForTermination = do
|
|
#ifdef mingw32_HOST_OS
|
|
forever $ threadDelaySeconds (Seconds 6000)
|
|
#else
|
|
lock <- newEmptyMVar
|
|
let check sig = void $
|
|
installHandler sig (CatchOnce $ putMVar lock ()) Nothing
|
|
check softwareTermination
|
|
whenM (queryTerminal stdInput) $
|
|
check keyboardSignal
|
|
takeMVar lock
|
|
#endif
|
|
|
|
oneSecond :: Microseconds
|
|
oneSecond = 1000000
|