    {- 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 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 { Seconds -> Int
    fromSeconds :: Int }
    	deriving (Seconds -> Seconds -> Bool
    (Seconds -> Seconds -> Bool)
    -> (Seconds -> Seconds -> Bool) -> Eq Seconds
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Seconds -> Seconds -> Bool
    == :: Seconds -> Seconds -> Bool
    $c/= :: Seconds -> Seconds -> Bool
    /= :: Seconds -> Seconds -> Bool
    Eq, Eq Seconds
    Eq Seconds =>
    (Seconds -> Seconds -> Ordering)
    -> (Seconds -> Seconds -> Bool)
    -> (Seconds -> Seconds -> Bool)
    -> (Seconds -> Seconds -> Bool)
    -> (Seconds -> Seconds -> Bool)
    -> (Seconds -> Seconds -> Seconds)
    -> (Seconds -> Seconds -> Seconds)
    -> Ord Seconds
    Seconds -> Seconds -> Bool
    Seconds -> Seconds -> Ordering
    Seconds -> Seconds -> Seconds
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: Seconds -> Seconds -> Ordering
    compare :: Seconds -> Seconds -> Ordering
    $c< :: Seconds -> Seconds -> Bool
    < :: Seconds -> Seconds -> Bool
    $c<= :: Seconds -> Seconds -> Bool
    <= :: Seconds -> Seconds -> Bool
    $c> :: Seconds -> Seconds -> Bool
    > :: Seconds -> Seconds -> Bool
    $c>= :: Seconds -> Seconds -> Bool
    >= :: Seconds -> Seconds -> Bool
    $cmax :: Seconds -> Seconds -> Seconds
    max :: Seconds -> Seconds -> Seconds
    $cmin :: Seconds -> Seconds -> Seconds
    min :: Seconds -> Seconds -> Seconds
    Ord, Int -> Seconds -> ShowS
    [Seconds] -> ShowS
    Seconds -> String
    (Int -> Seconds -> ShowS)
    -> (Seconds -> String) -> ([Seconds] -> ShowS) -> Show Seconds
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Seconds -> ShowS
    showsPrec :: Int -> Seconds -> ShowS
    $cshow :: Seconds -> String
    show :: Seconds -> String
    $cshowList :: [Seconds] -> ShowS
    showList :: [Seconds] -> ShowS
    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 :: forall a. Seconds -> IO a -> IO a
    runEvery Seconds
    n IO a
    a = IO a -> IO a
    forall (f :: * -> *) a b. Applicative f => f a -> f b
    forever (IO a -> IO a) -> IO a -> IO a
    forall a b. (a -> b) -> a -> b
    $ do
    	Seconds -> IO ()
    threadDelaySeconds Seconds
    n
    	IO a
    a

    threadDelaySeconds :: Seconds -> IO ()
    threadDelaySeconds :: Seconds -> IO ()
    threadDelaySeconds (Seconds Int
    n) = Integer -> IO ()
    unboundDelay (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    * Integer
    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 :: Integer -> IO ()
    unboundDelay Integer
    time = do
    	let maxWait :: Integer
    maxWait = Integer -> Integer -> Integer
    forall a. Ord a => a -> a -> a
    min Integer
    time (Integer -> Integer) -> Integer -> Integer
    forall a b. (a -> b) -> a -> b
    $ Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger (Int
    forall a. Bounded a => a
    maxBound :: Int)
    	Int -> IO ()
    threadDelay (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Integer -> Int
    forall a. Num a => Integer -> a
    fromInteger Integer
    maxWait
    	Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Integer
    maxWait Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Integer
    time) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Integer -> IO ()
    unboundDelay (Integer
    time Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    - Integer
    maxWait)

    {- Pauses the main thread, letting children run until program termination. -}
    waitForTermination :: IO ()
    waitForTermination :: IO ()
    waitForTermination = do
    #ifdef mingw32_HOST_OS
    	forever $ threadDelaySeconds (Seconds 6000)
    #else
    	MVar ()
    lock <- IO (MVar ())
    forall a. IO (MVar a)
    newEmptyMVar
    	let check :: Signal -> IO ()
    check Signal
    sig = IO Handler -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO Handler -> IO ()) -> IO Handler -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    		Signal -> Handler -> Maybe SignalSet -> IO Handler
    installHandler Signal
    sig (IO () -> Handler
    CatchOnce (IO () -> Handler) -> IO () -> Handler
    forall a b. (a -> b) -> a -> b
    $ MVar () -> () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar ()
    lock ()) Maybe SignalSet
    forall a. Maybe a
    Nothing
    	Signal -> IO ()
    check Signal
    softwareTermination
    	IO Bool -> IO () -> IO ()
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
    whenM (Fd -> IO Bool
    queryTerminal Fd
    stdInput) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    		Signal -> IO ()
    check Signal
    keyboardSignal
    	MVar () -> IO ()
    forall a. MVar a -> IO a
    takeMVar MVar ()
    lock
    #endif

    oneSecond :: Microseconds
    oneSecond :: Integer
    oneSecond = Integer
    1000000