module Network.Tremulous.Scheduler(
	  Event(..), Scheduler
	, newScheduler, addScheduled, addScheduledBatch
	, addScheduledInstant, deleteScheduled
	, putMVar', pureModifyMVar
) where
import Prelude hiding (Maybe(..))
import Network.Tremulous.StrictMaybe
import Control.Monad
import Control.Concurrent
import Control.Exception
import Data.Typeable
import Data.Foldable
import Network.Tremulous.MicroTime

data Interrupt = Interrupt
	deriving (Typeable, Show)

instance Exception Interrupt

data Scheduler id a = (Eq id, Ord id) =>
	Scheduler	{ sync		:: !(MVar ())
			, queue		:: !(MVar [Event id a])
			}

data Event id a = E
	{ time		:: !MicroTime
	, idn		:: !id
	, storage	:: !a
	}

newScheduler :: (Eq a, Ord a) => Int -> (Scheduler a b -> a -> b -> IO ()) -> Maybe (IO ()) -> IO (Scheduler a b)
newScheduler throughput func finalizer = do
	queue		<- newMVar []
	sync		<- newEmptyMVar
	let sched	=  Scheduler{..}
	uninterruptibleMask $ \a -> forkIO $ runner sched a
	return sched

	where
	runner sched@Scheduler{..} restore = do
		takeMVar sync
		tid <- myThreadId
		let loop = do
			q <- takeMVar queue
			case q of
				[] -> putMVar' queue q >> case finalizer of
					Nothing -> do
						takeMVar sync
						loop
					Just a -> a

				E{time=0, ..} : qs -> do
					putMVar' queue qs
					func sched idn storage
					when (throughput > 0)
						(threadDelay throughput)
					loop

				E {..} : qs -> do
					now <- getMicroTime
					if now >= time then do
						putMVar' queue qs
						func sched idn storage
						when (throughput > 0)
							(threadDelay throughput)
					else do
						putMVar' queue q
						tryTakeMVar sync
						syncid <- forkIOUnmasked $ takeMVar sync >> throwTo tid Interrupt
						let wait = fromIntegral (time - now)
						waited <- falseOnInterrupt $ restore $ threadDelay wait
						when waited $ do
							killThread syncid
							pureModifyMVar queue $ deleteID idn
							func sched idn storage
							when (throughput > 0)
								(threadDelay throughput)
					loop
			in loop

signal :: MVar () -> IO ()
signal a = tryPutMVar a () >> return ()

addScheduled :: Scheduler id a -> Event id a -> IO ()
addScheduled Scheduler{..} event = do
	pureModifyMVar queue $ insertTimed event
	signal sync

addScheduledBatch :: Foldable f => Scheduler id a -> f (Event id a) -> IO ()
addScheduledBatch Scheduler{..} events = do
	pureModifyMVar queue $ \q -> foldl' (flip insertTimed) q events
	signal sync

addScheduledInstant :: Scheduler id a -> [(id, a)] -> IO ()
addScheduledInstant Scheduler{..} events = do
	pureModifyMVar queue $ \q -> (map (uncurry (E 0)) events) ++ q
	signal sync

deleteScheduled :: Scheduler id a -> id -> IO ()
deleteScheduled Scheduler{..} ident = do
	pureModifyMVar queue $ deleteID ident
	signal sync


falseOnInterrupt :: IO a -> IO Bool
falseOnInterrupt f = handle (\Interrupt -> return False) (f >> return True)

insertTimed :: (Ord id, Eq id) => Event id a -> [Event id a] -> [Event id a]
insertTimed e (x:xs)
	| time e >= time x	= x : insertTimed e xs
	| otherwise		= e : x : xs
insertTimed e []		= [e]

deleteID :: (Ord id, Eq id) => id -> [Event id a] -> [Event id a]
deleteID match xss = case xss of
	x:xs	| idn x == match	-> xs
		| otherwise		-> x : deleteID match xs
	[]				-> []

putMVar' :: MVar a -> a -> IO ()
putMVar' m !a = putMVar m a

pureModifyMVar :: MVar a -> (a -> a) -> IO ()
pureModifyMVar m f = putMVar' m . f =<< takeMVar m