{-# LANGUAGE BangPatterns #-}

-- |
-- Module     : Simulation.Aivika.Branch.Internal.Ref.Strict
-- Copyright  : Copyright (c) 2016-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 7.10.3
--
-- The implementation of strict mutable references.
--
module Simulation.Aivika.Branch.Internal.Ref.Strict
       (Ref,
        newEmptyRef,
        newEmptyRef0,
        newRef,
        newRef0,
        readRef,
        writeRef,
        modifyRef) where

-- import Debug.Trace

import Data.IORef
import qualified Data.IntMap as M

import System.Mem.Weak

import Control.Monad
import Control.Monad.Trans

import Simulation.Aivika.Trans.Internal.Types

import Simulation.Aivika.Branch.Internal.BR

-- | A strict reference map.
type RefMap a = IORef (M.IntMap (IORef a, Weak (IORef ())))

-- | A mutable reference.
data Ref a = Ref { forall a. Ref a -> RefMap a
refMap :: RefMap a,
                   -- ^ the map of actual references
                   forall a. Ref a -> Weak (RefMap a)
refWeakMap :: Weak (RefMap a)
                   -- ^ a weak reference to the map itself
                 }

instance Eq (Ref a) where
  Ref a
r1 == :: Ref a -> Ref a -> Bool
== Ref a
r2 = (forall a. Ref a -> RefMap a
refMap Ref a
r1) forall a. Eq a => a -> a -> Bool
== (forall a. Ref a -> RefMap a
refMap Ref a
r2)

-- | Create an empty reference.
newEmptyRef :: Simulation (BR IO) (Ref a)
newEmptyRef :: forall a. Simulation (BR IO) (Ref a)
newEmptyRef = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. BR IO (Ref a)
newEmptyRef0

-- | Create an empty reference.
newEmptyRef0 :: BR IO (Ref a)
newEmptyRef0 :: forall a. BR IO (Ref a)
newEmptyRef0 =
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IORef (IntMap (IORef a, Weak (IORef ())))
rm <- forall a. a -> IO (IORef a)
newIORef forall a. IntMap a
M.empty
     Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
wm <- forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef (IntMap (IORef a, Weak (IORef ())))
rm forall a b. (a -> b) -> a -> b
$
           -- trace ("fin newEmptyRef0: " ++ show (brId ps)) $
           forall a. RefMap a -> IO ()
finalizeRef IORef (IntMap (IORef a, Weak (IORef ())))
rm
     forall (m :: * -> *) a. Monad m => a -> m a
return Ref { refMap :: IORef (IntMap (IORef a, Weak (IORef ())))
refMap = IORef (IntMap (IORef a, Weak (IORef ())))
rm,
                  refWeakMap :: Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
refWeakMap = Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
wm }

-- | Create a new reference.
newRef :: a -> Simulation (BR IO) (Ref a)
newRef :: forall a. a -> Simulation (BR IO) (Ref a)
newRef = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> BR IO (Ref a)
newRef0

-- | Create a new reference.
newRef0 :: a -> BR IO (Ref a)
newRef0 :: forall a. a -> BR IO (Ref a)
newRef0 a
a =
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do Ref a
r  <- forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps forall a. BR IO (Ref a)
newEmptyRef0
     IORef a
ra <- forall a. a -> IO (IORef a)
newIORef a
a
     let !i :: Int
i  = BRParams -> Int
brId BRParams
ps
         !wm :: Weak (RefMap a)
wm = forall a. Ref a -> Weak (RefMap a)
refWeakMap Ref a
r
     -- mkWeakIORef (brUniqueRef ps) (trace ("fin newIORef0: " ++ show i) $ finalizeCell wm i)
     Weak (IORef ())
wa <- forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef (BRParams -> IORef ()
brUniqueRef BRParams
ps) (forall a. Weak (RefMap a) -> Int -> IO ()
finalizeCell Weak (RefMap a)
wm Int
i)
     forall a. IORef a -> a -> IO ()
writeIORef (forall a. Ref a -> RefMap a
refMap Ref a
r) forall a b. (a -> b) -> a -> b
$
       forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i (IORef a
ra, Weak (IORef ())
wa) forall a. IntMap a
M.empty
     forall (m :: * -> *) a. Monad m => a -> m a
return Ref a
r
     
-- | Read the value of a reference.
readRef :: Ref a -> Event (BR IO) a
readRef :: forall a. Ref a -> Event (BR IO) a
readRef Ref a
r =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IntMap (IORef a, Weak (IORef ()))
m <- forall a. IORef a -> IO a
readIORef (forall a. Ref a -> RefMap a
refMap Ref a
r)
     let loop :: BRParams -> IO a
loop BRParams
ps =
           case forall a. Int -> IntMap a -> Maybe a
M.lookup (BRParams -> Int
brId BRParams
ps) IntMap (IORef a, Weak (IORef ()))
m of
             Just (IORef a
ra, Weak (IORef ())
wa) -> forall a. IORef a -> IO a
readIORef IORef a
ra
             Maybe (IORef a, Weak (IORef ()))
Nothing ->
               case BRParams -> Maybe BRParams
brParent BRParams
ps of
                 Just BRParams
ps' -> BRParams -> IO a
loop BRParams
ps'
                 Maybe BRParams
Nothing  -> forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot find branch: readRef"
     BRParams -> IO a
loop BRParams
ps

-- | Write a new value into the reference.
writeRef :: Ref a -> a -> Event (BR IO) ()
writeRef :: forall a. Ref a -> a -> Event (BR IO) ()
writeRef Ref a
r a
a =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IntMap (IORef a, Weak (IORef ()))
m <- forall a. IORef a -> IO a
readIORef (forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = BRParams -> Int
brId BRParams
ps
     case forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a, Weak (IORef ()))
m of
       Just (IORef a
ra, Weak (IORef ())
wa) -> a
a seq :: forall a b. a -> b -> b
`seq` forall a. IORef a -> a -> IO ()
writeIORef IORef a
ra a
a
       Maybe (IORef a, Weak (IORef ()))
Nothing ->
         do IORef a
ra <- a
a seq :: forall a b. a -> b -> b
`seq` forall a. a -> IO (IORef a)
newIORef a
a
            let !wm :: Weak (RefMap a)
wm = forall a. Ref a -> Weak (RefMap a)
refWeakMap Ref a
r
            -- mkWeakIORef (brUniqueRef ps) (trace ("fin writeRef: " ++ show i) $ finalizeCell wm i)
            Weak (IORef ())
wa <- forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef (BRParams -> IORef ()
brUniqueRef BRParams
ps) (forall a. Weak (RefMap a) -> Int -> IO ()
finalizeCell Weak (RefMap a)
wm Int
i)
            forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (forall a. Ref a -> RefMap a
refMap Ref a
r) forall a b. (a -> b) -> a -> b
$ \IntMap (IORef a, Weak (IORef ()))
m ->
              let m' :: IntMap (IORef a, Weak (IORef ()))
m' = forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i (IORef a
ra, Weak (IORef ())
wa) IntMap (IORef a, Weak (IORef ()))
m in (IntMap (IORef a, Weak (IORef ()))
m', ())

-- | Mutate the contents of the reference.
modifyRef :: Ref a -> (a -> a) -> Event (BR IO) ()
modifyRef :: forall a. Ref a -> (a -> a) -> Event (BR IO) ()
modifyRef Ref a
r a -> a
f =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IntMap (IORef a, Weak (IORef ()))
m <- forall a. IORef a -> IO a
readIORef (forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = BRParams -> Int
brId BRParams
ps
     case forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a, Weak (IORef ()))
m of
       Just (IORef a
ra, Weak (IORef ())
wa) ->
         do a
a <- forall a. IORef a -> IO a
readIORef IORef a
ra
            let b :: a
b = a -> a
f a
a
            a
b seq :: forall a b. a -> b -> b
`seq` forall a. IORef a -> a -> IO ()
writeIORef IORef a
ra a
b
       Maybe (IORef a, Weak (IORef ()))
Nothing ->
         do a
a <- forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (BR IO)
p forall a b. (a -> b) -> a -> b
$ forall a. Ref a -> Event (BR IO) a
readRef Ref a
r
            forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (BR IO)
p forall a b. (a -> b) -> a -> b
$ forall a. Ref a -> a -> Event (BR IO) ()
writeRef Ref a
r (a -> a
f a
a)

-- | Finalize the reference.
finalizeRef :: RefMap a -> IO ()
finalizeRef :: forall a. RefMap a -> IO ()
finalizeRef RefMap a
r =
  do IntMap (IORef a, Weak (IORef ()))
m <- forall a. IORef a -> IO a
readIORef RefMap a
r
     forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. IntMap a -> [a]
M.elems IntMap (IORef a, Weak (IORef ()))
m) forall a b. (a -> b) -> a -> b
$ \(IORef a
ra, Weak (IORef ())
wa) ->
       forall v. Weak v -> IO ()
finalize Weak (IORef ())
wa

-- | Finalize the reference cell by the specified branch identifier.
finalizeCell :: Weak (RefMap a) -> Int -> IO ()
finalizeCell :: forall a. Weak (RefMap a) -> Int -> IO ()
finalizeCell Weak (RefMap a)
wm Int
i =
  do Maybe (RefMap a)
rm <- forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (RefMap a)
wm
     -- trace ("finalizeRef: " ++ show i) $ return ()
     case Maybe (RefMap a)
rm of
       Maybe (RefMap a)
Nothing ->
         forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just RefMap a
rm ->
         do IntMap (IORef a, Weak (IORef ()))
m <- forall a. IORef a -> IO a
readIORef RefMap a
rm
            case forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a, Weak (IORef ()))
m of
              Just (IORef a
ra, Weak (IORef ())
wa) ->
                forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef RefMap a
rm forall a b. (a -> b) -> a -> b
$ \IntMap (IORef a, Weak (IORef ()))
m ->
                let m' :: IntMap (IORef a, Weak (IORef ()))
m' = forall a. Int -> IntMap a -> IntMap a
M.delete Int
i IntMap (IORef a, Weak (IORef ()))
m in (IntMap (IORef a, Weak (IORef ()))
m', ())
              Maybe (IORef a, Weak (IORef ()))
Nothing ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ()