{-# OPTIONS -fglasgow-exts #-}

{-
 - Copyright (c) 2008,  Jochem Berndsen
 - All rights reserved.
 - 
 - Redistribution and use in source and binary forms, with or without
 - modification, are permitted provided that the following conditions
 - are met:
 - 
 -   1. Redistributions of source code must retain the above copyright
 -      notice, this list of conditions and the following disclaimer.
 -   2. Redistributions in binary form must reproduce the above copyright
 -      notice, this list of conditions and the following disclaimer in the
 -      documentation and/or other materials provided with the distribution.
 -   3. Neither the name of the author nor the names of its contributors
 -      may be used to endorse or promote products derived from this software
 -      without specific prior written permission.
 - 
 - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS
 - ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 - TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 - PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS
 - BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 - CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 - SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 - INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 - CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 - ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 - POSSIBILITY OF SUCH DAMAGE.
 -}


-- |
-- Module      : Control.Hasim.SimRun
-- Copyright   : (c) Jochem Berndsen 2008
-- License     : BSD3
--
-- Maintainer  : jochem@functor.nl
-- Stability   : experimental
-- Portability : unportable
--
-- This module takes care of actually running a simulation.

module Control.Hasim.SimRun (
    runSimulation
) where

-- Internal imports
import Control.Hasim.DES
import Control.Hasim.Process
import Control.Hasim.Simulation
import Control.Hasim.Types
import Control.Hasim.WatchMap

-- External imports
import Control.Monad.State
import Data.IORef
import Data.Maybe

-- | The simulation run monad, composed of IO plus the state monad.
type SimRunM a = StateT SimRunSt IO a

-- | The state of the simulation.
data SimRunSt = SimRunSt { des :: DES
                         , time :: Time
                         , watchmap :: WatchMap
                         , latestPid :: Id
                         }

-- | Run the simulation.
runSimulation :: Simulation -> IO ()
runSimulation sim = initDES (unSim sim) >>= evalStateT run . initSimRunSt 

-- | Given a DES, the initial simulation run state.
initSimRunSt :: DES -> SimRunSt
initSimRunSt des' = SimRunSt { des = des'
                             , time = 0
                             , watchmap = emptyWM
                             , latestPid = -1 
                             }

-- | Return the current DES.
getDES :: SimRunM DES
getDES = des `liftM` get

-- | Set the DES.
putDES :: DES -> SimRunM ()
putDES newdes = get >>= \st -> put (st { des = newdes })

-- | Return the current Watchmap.
getWatchmap :: SimRunM WatchMap
getWatchmap = watchmap `liftM` get

-- | Set the Watchmap.
putWatchmap :: WatchMap -> SimRunM ()
putWatchmap newwm = get >>= \st -> put (st { watchmap = newwm })

-- | Return the current time.
getTime :: SimRunM Time
getTime = time `liftM` get

-- | Set the current time.
putTime :: Time -> SimRunM ()
putTime newtime = get >>= \st -> put (st { time = newtime })

-- | Return the next event to be run in the DES, and 
-- update the DES.
popEvent :: SimRunM Event
popEvent = do
    curDES <- getDES
    when (isEmpty curDES) (error "Control.Hasim.SimRun.popEvent : empty DES")
    let (evt, des') = removeNext curDES
    putDES des'
    return $! evt

-- | Run the simulation. Return only if the DES is empty.
run :: SimRunM ()
run = do
    curDES <- getDES
    if isEmpty curDES
        then return ()
        else popEvent >>= runEvent >> run

-- | Warp to the time of the next event.
warp :: Event -> SimRunM ()
warp evt = do
    oldtime <- getTime
    when (eTime evt < oldtime) 
        (error "Control.Hasim.SimRun.runEvent : invalid time warp")
    putTime $ eTime evt

-- | Run an event.
runEvent :: Event -> SimRunM ()
runEvent evt = do
    warp evt
    stepRunnable (eRunnable evt)
    
-- | Schedule a 'Runnable' at a certain time in the DES. 
-- All other Runnables of the related 'Process' are removed.
reschedule :: Time -> Runnable -> SimRunM ()
reschedule newtime newrun = do
    curDES <- getDES
    putDES (update newtime newrun curDES)

-- | Same as 'reschedule', but only execute if the Runnable
-- is a Just.
maybeReschedule :: Time -> Maybe Runnable -> SimRunM ()
maybeReschedule t = maybe
    (return ())
    (reschedule t)
     
-- | Schedule a 'Runnable' at the current time. All other
-- Runnables of the related 'Process' are removed.
rescheduleNow :: Runnable -> SimRunM ()
rescheduleNow newrun = do
    t <- getTime
    reschedule t newrun

-- | Same as 'rescheduleNow', but only execute if the Runnable
-- is a Just.
maybeRescheduleNow :: Maybe Runnable -> SimRunM ()
maybeRescheduleNow = maybe (return ()) rescheduleNow

-- | Execute the PopAcceptor primitive.
execPopAcceptor :: Proc pkt st -> SimRunM ()
execPopAcceptor proc = lift $ acceptor proc `modifyIORef` tail

-- | Return the head of the acceptor stack.
getAcceptor :: Proc pkt st -> SimRunM (Acceptor pkt st, Maybe Runnable)
getAcceptor proc = do
    accs <- lift $ readIORef (acceptor proc)
    when (null accs) 
        (error $ 
            "Control.Hasim.SimRun.getAcceptor : " ++
            "sending to empty acceptor list"
        )
    return $! head accs

-- | Add a watch to the Watchmap.
addWatch :: Proc a stA -- ^ The process that watches.
         -> Proc b stB -- ^ The process that is being watched.
         -> SimRunM ()
addWatch watcher watched = do
    wm <- getWatchmap
    let p1 = Process watcher
    let p2 = Process watched
    putWatchmap (register p1 p2 wm)

-- | Execute a Send primitive
execSend :: Proc a stA -- ^ The sender process
         -> pkt -- ^ The packet to be sent
         -> Proc pkt stB -- ^ The receiver process
         -> Time -- ^ The maximum time of sending
         -> (Maybe (Bool -> Runnable)) -- ^ The continuation
         -> SimRunM ()
execSend sender pkt recv maxtime cont = do
    -- Two possibilities:
    -- - we succeed in sending: return True, reschedule the receiver
    -- - we do not succeed; set our wakeup-function, reschedule an event
    
    (targetAcceptor, finallyCont) <- getAcceptor recv
    case targetAcceptor pkt of
        Refuse -> do
            -- Target does not accept our packet!
            -- Reschedule us for a false return
            let rhs = case cont of
                    Nothing -> Nothing
                    Just cont' -> Just (\() -> cont' False)
            maybeReschedule maxtime $ 
                Just (Run sender (Unwatch recv) rhs)
            -- Add us to watcher list
            addWatch sender recv
            -- Set our wakeup function
            lift (wakeup sender `writeIORef` 
                Just (Run sender (Send pkt recv maxtime) cont)
                )

        Interrupt f -> do
            -- Target accepts
            -- Unwatch us (if necessary)
            execUnwatch sender recv
            -- Reschedule us for true return
            maybeRescheduleNow (cont >>= return . ($True))
            -- Reschedule target
            rescheduleNow $ (toRunnable recv f) `rcatMaybe` finallyCont

        Parallel f -> do
            -- Target accepts
            -- Unwatch us (if necessary)
            execUnwatch sender recv
            -- Reschedule us for true return
            maybeRescheduleNow (cont >>= return . ($True))
            -- On target, perform the state-changing computation
            lift $ currentState recv `modifyIORef` f

           
-- | Execute the Unwatch primitive.
execUnwatch :: Proc a stA -- ^ The process that watched
            -> Proc b stB -- ^ The process that is being watched
            -> SimRunM ()
execUnwatch sender recv = do
    {- Remove from watchmap -}
    wm <- getWatchmap
    let p1 = Process sender
    let p2 = Process recv
    putWatchmap (unregister p1 p2 wm)
    {- Unset wakeup function -}
    lift (wakeup sender `writeIORef` Nothing)

-- | Concatenate two 'Runnable's. Because of lack of
-- type information, there is no flow of return values
-- between the two 'Runnable's.
rcat :: Runnable -> Runnable -> Runnable
(Run proc prim (Just c)) `rcat` r = Run proc prim (Just $ \x -> c x `rcat` r)
(Run proc prim Nothing) `rcat` r = Run proc prim (Just $ const r)

-- | Same as rcat, but now the right hand side may be Nothing,
-- in which case nothing is done.
rcatMaybe :: Runnable -> Maybe Runnable -> Runnable
rcatMaybe r = maybe r (rcat r)

-- | Execute the WithAcceptor primitive.
execWithAcceptor :: Proc pkt st -- ^ The process that is executing this primitive
                 -> Acceptor pkt st -- ^ The acceptor that is being pushed
                                 -- onto the stack
                 -> Action pkt st () -- ^ The action in the body
                 -> Maybe Runnable -- ^ The continuation
                 -> SimRunM ()
execWithAcceptor proc acc try cont = do
    -- push the acceptor with the continuation
    lift $ acceptor proc `modifyIORef` ((acc, cont):)
    -- reschedule the try block with the continuation
    rescheduleNow $ (toRunnable proc try) `rcatMaybe` cont


-- | Execute the head of the Runnable. 
stepRunnable :: Runnable -> SimRunM ()
stepRunnable (Run proc prim rest) = do
    -- Do case distinction on the next primitive
    -- action to be executed.
    case prim of 

        -- Return.
        Ret x -> do
            -- Return x, reschedule the action to
            -- occur immediately.
            let next = rest >>= return . ($x)
            maybeRescheduleNow next
    
        Wait t -> do
            -- Wait for a time interval. Return ()
            let next = rest >>= return . ($())
            -- Reschedule at a time in the future.
            curTime <- getTime
            maybeReschedule (curTime + t) next

        Send pkt recv timeout -> do
            -- Send a packet. This function
            -- takes care of rescheduling, since
            -- it is fairly complicated.
            execSend proc pkt recv timeout rest

        Unwatch rcv -> do
            -- Execute Unwatch.
            execUnwatch proc rcv
            -- Return (), reschedule immediately
            let next = rest >>= return . ($())
            maybeRescheduleNow next

        WithAcceptor acc c -> do
            -- Push an acceptor. First, find
            -- the continuation.
            let next = rest >>= return . ($())
            execWithAcceptor proc acc c next -- takes care of rescheduling

        PopAcceptor -> do
            -- Pop an acceptor.
            execPopAcceptor proc
            -- Return (), reschedule immediately.
            let next = rest >>= return . ($())
            maybeRescheduleNow next

        PerformIO io -> do
            -- Perform an IO operation.
            r <- lift io
            -- Return the IO result, reschedule immediately.
            let next = rest >>= return . ($r)
            maybeRescheduleNow next

        ObserveTime -> do
            -- Observe the time.
            t <- getTime
            -- Return the current time, reschedule immediately.
            let next = rest >>= return . ($t)
            maybeRescheduleNow next

        GetState -> do
            -- Observe the state.
            st <- lift $ readIORef (currentState proc)
            -- Return the state result, reschedule immediately.
            let next = rest >>= return . ($st)
            maybeRescheduleNow next

        PutState st -> do
            -- Set the state
            lift $ currentState proc `writeIORef` st
            -- REeturn (), reschedule immediately
            let next = rest >>= return . ($())
            maybeRescheduleNow next

        WaitForever -> do
            -- Remove us from the discrete event set,
            -- i.e. don't reschedule us.
            return ()
    
    when (wake (Atom prim)) $ do
        -- This was a wakeup event, reschedule all 
        -- watchers to now.
        wm <- getWatchmap
        forM_ (watchers wm (Process proc)) (\(Process p') -> do
            x <- lift (readIORef $ wakeup p')
            maybeRescheduleNow x
            )

-- | Is this event a wakeup event? i.e. must all watchers
-- be woken?
wake :: Atom -> Bool
wake (Atom (Ret _)) = False
wake (Atom (Wait _)) = False
wake (Atom (Send _ _ _)) = False
wake (Atom (Unwatch _)) = False
wake (Atom (WithAcceptor _ _)) = True
wake (Atom (PopAcceptor)) = True
wake (Atom (ObserveTime)) = False
wake (Atom (PerformIO _)) = False
wake (Atom (GetState)) = False
wake (Atom (PutState _)) = False
wake (Atom (WaitForever)) = False