{-
 - 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.Action
-- Copyright   : (c) Jochem Berndsen 2008
-- License     : BSD3
--
-- Maintainer  : jochem@functor.nl
-- Stability   : experimental
-- Portability : unportable
--
-- Convenience functions and shadowing of API internals.
-- Likely to be a more stable interface then 'Control.Hasim.Process'.

module Control.Hasim.Action (
    -- * Time
    getTime,

    -- * Waiting
    wait,
    waitForever,

    -- * Sending
    send,
    trySend,
    sendBlock,

    -- * Receiving
    withAcceptor,
    withoutInterruptions,
    receive,
    poll,

) where

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

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

-- If at all possible, we do sanity checks and parameter
-- validation of library user input in this module. This will
-- cause less confusion and earlier error messages.
-- This may shadow some problems in the base library, though.

-- State getting/setting is done via MonadState,
-- IO is done via MonadIO.

-- | Get the current time. The result will be nonnegative.
getTime :: Action pkt st Time
getTime = Prim ObserveTime

-- | Wait for a nonnegative time period.
wait :: Time -- ^ The time period we wait. Must be nonnegative.
     -> Action pkt st ()
wait t 
    | t >= 0 = do
        -- The Wait primitive has a *relative time*
        Prim (Wait t)

    | otherwise = error $
        "Control.Hasim.Action.wait : waiting for a negative time " ++
        "is not allowed; parameter was `" ++ show t ++ "`"
    
-- | Send a packet to a process, with a timeout
-- time interval. Returns True iff the
-- packet was accepted.
send :: pkt -- ^ The packet we send.
     -> Proc pkt st -- ^ The receiver process
     -> Time -- ^ The timeout. Must be nonnegative.
     -> Action pkt' st' Bool
send pkt proc timeout
    | timeout >= 0 = do
        -- The "Send" has a *absolute time*
        -- This means we have to inspect the time first.
        t <- getTime
        Prim (Send pkt proc (t + timeout))
    
    | otherwise = error $
        "Control.Hasim.Action.send : sending with a negative " ++
        "timeout is not allowed; parameter was `" ++ show timeout ++ "`"


-- | Send a packet. Return True iff the packet was
-- accepted immediately. Do not wait in case the
-- packet was not accepted.
trySend :: pkt -- ^ The packet we send
        -> Proc pkt st -- ^ The receiver process
        -> Action pkt' st' Bool
trySend pkt proc = send pkt proc 0

-- | Send a packet. Wait as long as necessary to deliver the packet.
sendBlock :: pkt -- ^ The packet we send
          -> Proc pkt st -- ^ The receiver process
          -> Action pkt' st' ()
sendBlock pkt proc = send pkt proc 1e80 >>= \b ->
    unless b $ sendBlock pkt proc

-- | Execute an action with an 'Acceptor' function
withAcceptor :: Acceptor pkt st -- ^ The acceptor to set
             -> Action pkt st () -- ^ The action to be executed
             -> Action pkt st ()
withAcceptor acc try = do
    Prim (WithAcceptor acc try)
    Prim PopAcceptor

-- | Execute an action without interruptions from incoming packets.
withoutInterruptions :: Action pkt st () -> Action pkt st ()
withoutInterruptions = withAcceptor (const Refuse)

-- | Wait forever. This can be useful in case you want to block,
-- waiting for incoming packets.
waitForever :: Action pkt st ()
waitForever = Prim WaitForever

-- | Receive a packet. Block until the first packet comes in.
receive :: Action pkt st pkt
receive = do
    s <- liftIO $ newIORef $ error $
        "Control.Hasim.Action.receive : undefined packet"
    withAcceptor (\pkt -> Interrupt (liftIO $ writeIORef s pkt)) waitForever
    result <- liftIO $ readIORef s
    return result

-- | Receive a packet, non-blocking.
poll :: Action pkt st (Maybe pkt)
poll = do
    -- Trigger the sending of packets
    s <- liftIO $ newIORef Nothing
    withAcceptor 
        (\pkt -> Interrupt (liftIO $ writeIORef s (Just pkt))) 
        (return ())
    result <- liftIO $ readIORef s
    return result