{- 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Seconds -> Seconds -> Bool
$c/= :: Seconds -> Seconds -> Bool
== :: Seconds -> Seconds -> Bool
$c== :: Seconds -> Seconds -> Bool
Eq, Eq 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
min :: Seconds -> Seconds -> Seconds
$cmin :: Seconds -> Seconds -> Seconds
max :: Seconds -> Seconds -> Seconds
$cmax :: Seconds -> Seconds -> Seconds
>= :: Seconds -> Seconds -> Bool
$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
compare :: Seconds -> Seconds -> Ordering
$ccompare :: Seconds -> Seconds -> Ordering
Ord, Int -> Seconds -> ShowS
[Seconds] -> ShowS
Seconds -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Seconds] -> ShowS
$cshowList :: [Seconds] -> ShowS
show :: Seconds -> String
$cshow :: Seconds -> String
showsPrec :: Int -> Seconds -> ShowS
$cshowsPrec :: Int -> 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 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n 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 = forall a. Ord a => a -> a -> a
min Integer
time forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int)
	Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
maxWait
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
maxWait forall a. Eq a => a -> a -> Bool
/= Integer
time) forall a b. (a -> b) -> a -> b
$ Integer -> IO ()
unboundDelay (Integer
time 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 <- forall a. IO (MVar a)
newEmptyMVar
	let check :: Signal -> IO ()
check Signal
sig = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
		Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig (IO () -> Handler
CatchOnce forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) forall a. Maybe a
Nothing
	Signal -> IO ()
check Signal
softwareTermination
	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Fd -> IO Bool
queryTerminal Fd
stdInput) forall a b. (a -> b) -> a -> b
$
		Signal -> IO ()
check Signal
keyboardSignal
	forall a. MVar a -> IO a
takeMVar MVar ()
lock
#endif

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