{-# LANGUAGE TypeFamilies, FlexibleInstances #-}

-- |
-- Module     : Simulation.Aivika.IO.Resource.Preemption.Base
-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- This module defines an optimised preemptible resource, where
-- the 'IO' monad is an instance of 'MonadResource'.
--
module Simulation.Aivika.IO.Resource.Preemption.Base () where

import Control.Monad
import Control.Monad.Trans

import Data.Maybe
import Data.IORef

import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Ref.Base
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Internal.Cont
import Simulation.Aivika.Trans.Internal.Process
import Simulation.Aivika.Trans.Resource.Preemption.Base

import Simulation.Aivika.IO.DES

import qualified Simulation.Aivika.PriorityQueue as PQ

-- | The 'IO' monad is an instance of 'MonadResource'.
instance MonadResource IO where
-- instance (Monad m, MonadDES m, MonadIO m, MonadTemplate m) => MonadResource m where

  {-# SPECIALISE instance MonadResource IO #-}

  -- | A template-based implementation of the preemptible resource.
  data Resource IO = 
    Resource { resourceMaxCount0 :: Maybe Int,
               resourceCountRef :: IORef Int,
               resourceActingQueue :: PQ.PriorityQueue (ResourceActingItem IO),
               resourceWaitQueue :: PQ.PriorityQueue (ResourceAwaitingItem IO) }

  {-# INLINABLE newResource #-}
  newResource count =
    Simulation $ \r ->
    do when (count < 0) $
         throwComp $
         SimulationRetry $
         "The resource count cannot be negative: " ++
         "newResource."
       countRef <- liftIO $ newIORef count
       actingQueue <- liftIO PQ.newQueue
       waitQueue <- liftIO PQ.newQueue
       return Resource { resourceMaxCount0 = Just count,
                         resourceCountRef = countRef,
                         resourceActingQueue = actingQueue,
                         resourceWaitQueue = waitQueue }

  {-# INLINABLE newResourceWithMaxCount #-}
  newResourceWithMaxCount count maxCount =
    Simulation $ \r ->
    do when (count < 0) $
         throwComp $
         SimulationRetry $
         "The resource count cannot be negative: " ++
         "newResourceWithMaxCount."
       case maxCount of
         Just maxCount | count > maxCount ->
           throwComp $
           SimulationRetry $
           "The resource count cannot be greater than " ++
           "its maximum value: newResourceWithMaxCount."
         _ ->
           return ()
       countRef <- liftIO $ newIORef count
       actingQueue <- liftIO PQ.newQueue
       waitQueue <- liftIO PQ.newQueue
       return Resource { resourceMaxCount0 = maxCount,
                         resourceCountRef = countRef,
                         resourceActingQueue = actingQueue,
                         resourceWaitQueue = waitQueue }

  {-# INLINABLE resourceCount #-}
  resourceCount r =
    Event $ \p -> liftIO $ readIORef (resourceCountRef r)

  {-# INLINABLE resourceMaxCount #-}
  resourceMaxCount = resourceMaxCount0

  {-# INLINABLE requestResourceWithPriority #-}
  requestResourceWithPriority r priority =
    Process $ \pid ->
    Cont $ \c ->
    Event $ \p ->
    do a <- liftIO $ readIORef (resourceCountRef r)
       if a == 0
         then do f <- liftIO $ PQ.queueNull (resourceActingQueue r)
                 if f
                   then do c <- invokeEvent p $
                                freezeContReentering c () $
                                invokeCont c $
                                invokeProcess pid $
                                requestResourceWithPriority r priority
                           liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c)
                   else do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r)
                           let p0 = - p0'
                               pid0 = actingItemId item0
                           if priority < p0
                             then do liftIO $ PQ.dequeue (resourceActingQueue r)
                                     liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid
                                     liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0)
                                     invokeEvent p $ processPreemptionBegin pid0
                                     invokeEvent p $ resumeCont c ()
                             else do c <- invokeEvent p $
                                          freezeContReentering c () $
                                          invokeCont c $
                                          invokeProcess pid $
                                          requestResourceWithPriority r priority
                                     liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c)
         else do let a' = a - 1
                 a' `seq` liftIO $ writeIORef (resourceCountRef r) a'
                 liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid
                 invokeEvent p $ resumeCont c ()

  {-# INLINABLE releaseResource #-}
  releaseResource r = 
    Process $ \pid ->
    Cont $ \c ->
    Event $ \p ->
    do f <- liftIO $ fmap isJust $ PQ.queueDeleteBy (resourceActingQueue r) (\item -> actingItemId item == pid)
       if f
         then do invokeEvent p $ releaseResource' r
                 invokeEvent p $ resumeCont c ()
         else throwComp $
              SimulationRetry
              "The resource was not acquired by this process: releaseResource"
               
  {-# INLINABLE usingResourceWithPriority #-}
  usingResourceWithPriority r priority m =
    do requestResourceWithPriority r priority
       finallyProcess m $ releaseResource r

  {-# INLINABLE incResourceCount #-}
  incResourceCount r n
    | n < 0     = throwEvent $ SimulationRetry "The increment cannot be negative: incResourceCount"
    | n == 0    = return ()
    | otherwise =
      do releaseResource' r
         incResourceCount r (n - 1)

  {-# INLINABLE decResourceCount #-}
  decResourceCount r n
    | n < 0     = throwEvent $ SimulationRetry "The decrement cannot be negative: decResourceCount"
    | n == 0    = return ()
    | otherwise =
      do decResourceCount' r
         decResourceCount r (n - 1)

  {-# INLINABLE alterResourceCount #-}
  alterResourceCount r n
    | n < 0  = decResourceCount r (- n)
    | n > 0  = incResourceCount r n
    | n == 0 = return ()

-- | Identifies an acting item that acquired the resource.
data ResourceActingItem m =
  ResourceActingItem { actingItemPriority :: Double,
                       actingItemId :: ProcessId m }

-- | Idenitifies an item that requests for the resource.
data ResourceRequestingItem m =
  ResourceRequestingItem { requestingItemPriority :: Double,
                           requestingItemId :: ProcessId m,
                           requestingItemCont :: FrozenCont m () }

-- | Idenitifies an item that was preempted.
data ResourcePreemptedItem m =
  ResourcePreemptedItem { preemptedItemPriority :: Double,
                          preemptedItemId :: ProcessId m }

-- | Idenitifies an awaiting item that waits for releasing of the resource to take it.
type ResourceAwaitingItem m =
  Either (ResourceRequestingItem m) (ResourcePreemptedItem m)

instance Eq (Resource IO) where
-- instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (Resource m) where

  {-# INLINABLE (==) #-}
  x == y = resourceCountRef x == resourceCountRef y  -- unique references

instance Eq (ResourceActingItem IO) where
-- instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (ResourceActingItem m) where

  {-# INLINABLE (==) #-}
  x == y = actingItemId x == actingItemId y

releaseResource' :: Resource IO -> Event IO ()
-- releaseResource' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m ()
{-# INLINABLE releaseResource' #-}
releaseResource' r =
  Event $ \p ->
  do a <- liftIO $ readIORef (resourceCountRef r)
     let a' = a + 1
     case resourceMaxCount r of
       Just maxCount | a' > maxCount ->
         throwComp $
         SimulationRetry $
         "The resource count cannot be greater than " ++
         "its maximum value: releaseResource'."
       _ ->
         return ()
     f <- liftIO $ PQ.queueNull (resourceWaitQueue r)
     if f 
       then a' `seq` liftIO $ writeIORef (resourceCountRef r) a'
       else do (priority', item) <- liftIO $ PQ.queueFront (resourceWaitQueue r)
               liftIO $ PQ.dequeue (resourceWaitQueue r)
               case item of
                 Left (ResourceRequestingItem priority pid c) ->
                   do c <- invokeEvent p $ unfreezeCont c
                      case c of
                        Nothing ->
                          invokeEvent p $ releaseResource' r
                        Just c ->
                          do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid
                             invokeEvent p $ enqueueEvent (pointTime p) $ reenterCont c ()
                 Right (ResourcePreemptedItem priority pid) ->
                   do f <- invokeEvent p $ processCancelled pid
                      case f of
                        True ->
                          invokeEvent p $ releaseResource' r
                        False ->
                          do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid
                             invokeEvent p $ processPreemptionEnd pid

decResourceCount' :: Resource IO -> Event IO ()
-- decResourceCount' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m ()
{-# INLINABLE decResourceCount' #-}
decResourceCount' r =
  Event $ \p ->
  do a <- liftIO $ readIORef (resourceCountRef r)
     when (a == 0) $
       throwComp $
       SimulationRetry
       "The resource exceeded and its count is zero: decResourceCount'"
     f <- liftIO $ PQ.queueNull (resourceActingQueue r)
     unless f $
       do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r)
          let p0 = - p0'
              pid0 = actingItemId item0
          liftIO $ PQ.dequeue (resourceActingQueue r)
          liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0)
          invokeEvent p $ processPreemptionBegin pid0
     let a' = a - 1
     a' `seq` liftIO $ writeIORef (resourceCountRef r) a'