{-# 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.Simulation
-- Copyright   : (c) Jochem Berndsen 2008
-- License     : BSD3
--
-- Maintainer  : jochem@functor.nl
-- Stability   : experimental
-- Portability : unportable
--
-- This module defines the Simulation monad, with
-- functions to create processes and set actions.

module Control.Hasim.Simulation (
    -- * Data types
    Simulation,
    SimMonad,
    unSim,

    -- * Process creation
    mkAnonProcess,
    mkProcess,
    setAction,

    -- * Simulation creation
    createSimulation
) where

-- Internal imports
import Control.Hasim.Process
import Control.Hasim.Types

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

-- | Data type representing a simulation.
newtype Simulation = Sim { unSim :: [Process] } 

-- | The simulation monad called 'SimMonad'. In this
-- monad you can define a simulation to be run.
type SimMonad a = StateT SimState IO a

-- | The state of the SimMonad
data SimState = SimState { currentId :: Id 
                           -- ^ The identifier that will be used for
                           -- the next process
                         , processes :: [Process]
                           -- ^ All processes that are created
                         }

-- | The initial state of the SimMonad
initialSimState :: SimState 
initialSimState = SimState { currentId = 1, processes = [] }

-- | Increase the current identifier of the SimMonad
incId :: SimState -> SimState
incId st = st { currentId = currentId st + 1 }

-- | Append a process to the state of the SimMonad
appendProcess :: Proc pkt st -> SimState -> SimState
appendProcess p st = st { processes = Process p : processes st }

-- | Make an anonymous process.
mkAnonProcess :: SimMonad (Proc pkt ())
mkAnonProcess = mkProcess "<anonymous>" ()

-- | Make a process with a name. This name will be used
-- in logging and error messages
mkProcess :: String -- ^ The name of the new process.
          -> st -- ^ The initial state of the process.
          -> SimMonad (Proc pkt st)
mkProcess name' st = do
    state <- get
    p <- lift $ mkProcessWId (currentId state) st name'
    put $ appendProcess p . incId $ state
    return $! p

mkProcessWId :: Id -> st -> String -> IO (Proc pkt st)
mkProcessWId identifier' st name' = do
    let c = error "Control.Hasim.Simulation.mkProcess : invalid continuation called"
    acceptor' <- newIORef [(const Refuse, c)]
    action' <- newIORef Nothing
    wakeup' <- newIORef Nothing
    state' <- newIORef st
    let p = Proc { acceptor = acceptor'
                 , action = action'
                 , identifier = identifier'
                 , name = name'
                 , wakeup = wakeup'
                 , currentState = state'
                 }
    return $! p

-- | Set the action of the process.
setAction :: Proc pkt st -- ^ The process of which the action should be set
          -> Action pkt st () -- ^ The action to be set
          -> SimMonad ()
setAction proc act = lift $ writeIORef (action proc) (Just runnable) where

    runnable = toRunnable proc act

-- | Create a simulation from a SimMonad (a simulation definition).
-- If the simulation is invalid, 'error' will be called.
createSimulation :: SimMonad () -> IO Simulation
createSimulation m = execStateT m initialSimState >>= \simstate -> do
    let sim = Sim (processes simstate)
    result <- validate sim 
    case result of
        Nothing -> return $! sim
        (Just msg) -> do
            putStrLn "The simulation definition is erroneous."
            putStrLn msg 
            error "invalid simulation"
        

-- Validation of simulations
validate :: Simulation -> IO (Maybe String)
validate sim = foldM (\res val -> 
        if isNothing res
            then val sim
            else return res
        ) Nothing [atLeastOneProcess, processesHaveActions]

type SimValidation = Simulation -> IO (Maybe String)

atLeastOneProcess :: SimValidation
atLeastOneProcess sim = return $ do
    guard . null . unSim $ sim
    return $! "There are zero processes defined."

processesHaveActions :: SimValidation
processesHaveActions sim = do
    unset <- filterM (\(Process proc) -> isNothing `liftM` readIORef (action proc)) (unSim sim)
    return $ do
        guard $ not (null unset)
        return $! "The following processes do not have an action set:\n" ++ 
            concatMap (\(Process proc) -> " * " ++ name proc ++ "\n") unset