-- 
-- (c) Susumu Katayama 2009
--
module MagicHaskeller.TimeOut where

import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield)
import Control.Concurrent.SampleVar
import Control.Exception(catch, Exception(..))
-- import System.Posix.Unistd(getSysVar, SysVar(..))
-- import System.Posix.Process(getProcessTimes, ProcessTimes(..))
-- import System.Posix.Types(ClockTick)
import System.CPUTime
import System.IO.Unsafe(unsafePerformIO)
import Control.Monad(when)

import System.IO

import Debug.Trace -- This IS necessary to monitor errors in the subprocs.

-- import Timeout

-- ソースをみた感じ，MVarやSampleVarを作るoverheadは無視できそう．
-- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: SampleVar (Maybe a)}

{-
unsafeEvaluate :: Int -> a -> Maybe a
unsafeEvaluate t e = unsafePerformIO (withTO t (return e)) -- Should I use Control.Exception.evaluate? I do not want to evaluate long lists deeply. 
-}

maybeWithTO :: (a -> IO () -> IO ()) -- ^ seq or deepSeq(=Control.Parallel.Strategies.sforce). For our purposes seq is enough, because @a@ is either 'Bool' or 'Ordering'.
            -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO sq mbt action = maybeWithTO' sq mbt (const action)

maybeWithTO' :: (a -> IO () -> IO ()) -> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
maybeWithTO' _   Nothing  action = do a <- action id
                                      return (Just a)
maybeWithTO' dsq (Just t) action = withTO' dsq t action
--maybeWithTO' dsq (Just t) action = timeout t (action undefined) -- System.Timeout.timeoutを使うと速くなる．

--  'withTO' creates CHTO every time it is called. Currently unused.
-- withTO :: DeepSeq a => Int -> IO a -> IO (Maybe a)
-- withTO timeInMicroSecs action = withTO' deepSeq timeInMicroSecs (const action)
withTO' :: (a -> IO () -> IO ()) -> Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
withTO' dsq timeInMicroSecs action
    = do -- clk_tck <- getSysVar ClockTick
         -- let ticks = fromInteger (clk_tck * toInteger timeInMicroSecs `div` 1000000)
         resSV <- newEmptySampleVar
         do
	   forkIO (catchIt resSV (do
                                   tid <- myThreadId
                                   chtid <- forkIO (do threadDelay timeInMicroSecs
                                                       -- wait deadline -- this line makes sure that timeInMicroSecs has really passed in the process time, but I guess this has no sense, because userTime is shared among Concurrent Haskell threads.
                                                       writeSampleVar resSV Nothing
                                                       killThread tid)
		                   -- res <- action (catchYield tid resSV)
                                   res <- action (yield>>)
		                   res `dsq` writeSampleVar resSV (Just res)
                                   killThread chtid))
           readSampleVar resSV

wrapExecution = id
--wrapExecution = measureExecutionTime

measureExecutionTime act
    = do begin <- getCPUTime
         res <- act
         end <- getCPUTime
         hPutStrLn stderr (show (end - begin))
         return res

-- Catch exceptions such as stack space overflow
catchIt :: (SampleVar (Maybe a)) -> IO () -> IO ()
catchIt sv act = Control.Exception.catch act (handler sv)
-- catchIt sv act = act -- disable

handler sv err = Control.Exception.catch (realHandler sv err) (handler sv)
-- realHandler sv (AsyncException ThreadKilled) = return () -- If the thread is killed by ^C (i.e. not by another thread), sv is left empty. So, the parent thread can catch ^C while waiting.
#ifdef REALDYNAMIC
-- realHandler sv err = trace (show err) $ writeSampleVar sv Nothing
realHandler sv (ErrorCall str) = trace str $ writeSampleVar sv Nothing
#endif
realHandler sv err = writeSampleVar sv Nothing

catchYield       tid sv action = Control.Exception.catch (yield >> action) (childHandler tid sv)
childHandler     tid sv err    = Control.Exception.catch (realChildHandler tid sv err) (childHandler tid sv)
realChildHandler tid sv err    = do writeSampleVar sv Nothing
                                    killThread tid
                                    error "This thread must have been killed...."
{-
wait deadline = do ticksNow <- getProcessTimes
                   let tickNow = userTime ticksNow
                   when (tickNow < deadline) $ do threadDelay 20000
                                                  wait deadline
-}