{-# 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 { Ref a -> RefMap a
refMap :: RefMap a,
                   -- ^ the map of actual references
                   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 = (Ref a -> RefMap a
forall a. Ref a -> RefMap a
refMap Ref a
r1) RefMap a -> RefMap a -> Bool
forall a. Eq a => a -> a -> Bool
== (Ref a -> RefMap a
forall a. Ref a -> RefMap a
refMap Ref a
r2)

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

-- | Create an empty reference.
newEmptyRef0 :: BR IO (Ref a)
newEmptyRef0 :: BR IO (Ref a)
newEmptyRef0 =
  (BRParams -> IO (Ref a)) -> BR IO (Ref a)
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO (Ref a)) -> BR IO (Ref a))
-> (BRParams -> IO (Ref a)) -> BR IO (Ref a)
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IORef (IntMap (IORef a, Weak (IORef ())))
rm <- IntMap (IORef a, Weak (IORef ()))
-> IO (IORef (IntMap (IORef a, Weak (IORef ()))))
forall a. a -> IO (IORef a)
newIORef IntMap (IORef a, Weak (IORef ()))
forall a. IntMap a
M.empty
     Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
wm <- IORef (IntMap (IORef a, Weak (IORef ())))
-> IO () -> IO (Weak (IORef (IntMap (IORef a, Weak (IORef ())))))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef (IntMap (IORef a, Weak (IORef ())))
rm (IO () -> IO (Weak (IORef (IntMap (IORef a, Weak (IORef ()))))))
-> IO () -> IO (Weak (IORef (IntMap (IORef a, Weak (IORef ())))))
forall a b. (a -> b) -> a -> b
$
           -- trace ("fin newEmptyRef0: " ++ show (brId ps)) $
           IORef (IntMap (IORef a, Weak (IORef ()))) -> IO ()
forall a. RefMap a -> IO ()
finalizeRef IORef (IntMap (IORef a, Weak (IORef ())))
rm
     Ref a -> IO (Ref a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ref :: forall a. RefMap a -> Weak (RefMap a) -> Ref a
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 :: a -> Simulation (BR IO) (Ref a)
newRef = (Run (BR IO) -> BR IO (Ref a)) -> Simulation (BR IO) (Ref a)
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run (BR IO) -> BR IO (Ref a)) -> Simulation (BR IO) (Ref a))
-> (a -> Run (BR IO) -> BR IO (Ref a))
-> a
-> Simulation (BR IO) (Ref a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BR IO (Ref a) -> Run (BR IO) -> BR IO (Ref a)
forall a b. a -> b -> a
const (BR IO (Ref a) -> Run (BR IO) -> BR IO (Ref a))
-> (a -> BR IO (Ref a)) -> a -> Run (BR IO) -> BR IO (Ref a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BR IO (Ref a)
forall a. a -> BR IO (Ref a)
newRef0

-- | Create a new reference.
newRef0 :: a -> BR IO (Ref a)
newRef0 :: a -> BR IO (Ref a)
newRef0 a
a =
  (BRParams -> IO (Ref a)) -> BR IO (Ref a)
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO (Ref a)) -> BR IO (Ref a))
-> (BRParams -> IO (Ref a)) -> BR IO (Ref a)
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do Ref a
r  <- BRParams -> BR IO (Ref a) -> IO (Ref a)
forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps BR IO (Ref a)
forall a. BR IO (Ref a)
newEmptyRef0
     IORef a
ra <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
     let !i :: Int
i  = BRParams -> Int
brId BRParams
ps
         !wm :: Weak (RefMap a)
wm = Ref a -> Weak (RefMap a)
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 <- IORef () -> IO () -> IO (Weak (IORef ()))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef (BRParams -> IORef ()
brUniqueRef BRParams
ps) (Weak (RefMap a) -> Int -> IO ()
forall a. Weak (RefMap a) -> Int -> IO ()
finalizeCell Weak (RefMap a)
wm Int
i)
     RefMap a -> IntMap (IORef a, Weak (IORef ())) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Ref a -> RefMap a
forall a. Ref a -> RefMap a
refMap Ref a
r) (IntMap (IORef a, Weak (IORef ())) -> IO ())
-> IntMap (IORef a, Weak (IORef ())) -> IO ()
forall a b. (a -> b) -> a -> b
$
       Int
-> (IORef a, Weak (IORef ()))
-> IntMap (IORef a, Weak (IORef ()))
-> IntMap (IORef a, Weak (IORef ()))
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i (IORef a
ra, Weak (IORef ())
wa) IntMap (IORef a, Weak (IORef ()))
forall a. IntMap a
M.empty
     Ref a -> IO (Ref a)
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 :: Ref a -> Event (BR IO) a
readRef Ref a
r =
  (Point (BR IO) -> BR IO a) -> Event (BR IO) a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (BR IO) -> BR IO a) -> Event (BR IO) a)
-> (Point (BR IO) -> BR IO a) -> Event (BR IO) a
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  (BRParams -> IO a) -> BR IO a
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO a) -> BR IO a) -> (BRParams -> IO a) -> BR IO a
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IntMap (IORef a, Weak (IORef ()))
m <- IORef (IntMap (IORef a, Weak (IORef ())))
-> IO (IntMap (IORef a, Weak (IORef ())))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a, Weak (IORef ())))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let loop :: BRParams -> IO a
loop BRParams
ps =
           case Int
-> IntMap (IORef a, Weak (IORef ()))
-> Maybe (IORef a, Weak (IORef ()))
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) -> IORef a -> IO a
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  -> [Char] -> IO a
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 :: Ref a -> a -> Event (BR IO) ()
writeRef Ref a
r a
a =
  (Point (BR IO) -> BR IO ()) -> Event (BR IO) ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (BR IO) -> BR IO ()) -> Event (BR IO) ())
-> (Point (BR IO) -> BR IO ()) -> Event (BR IO) ()
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  (BRParams -> IO ()) -> BR IO ()
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO ()) -> BR IO ())
-> (BRParams -> IO ()) -> BR IO ()
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IntMap (IORef a, Weak (IORef ()))
m <- IORef (IntMap (IORef a, Weak (IORef ())))
-> IO (IntMap (IORef a, Weak (IORef ())))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a, Weak (IORef ())))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = BRParams -> Int
brId BRParams
ps
     case Int
-> IntMap (IORef a, Weak (IORef ()))
-> Maybe (IORef a, Weak (IORef ()))
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 a -> IO () -> IO ()
`seq` IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ra a
a
       Maybe (IORef a, Weak (IORef ()))
Nothing ->
         do IORef a
ra <- a
a a -> IO (IORef a) -> IO (IORef a)
`seq` a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
            let !wm :: Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
wm = Ref a -> Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
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 <- IORef () -> IO () -> IO (Weak (IORef ()))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef (BRParams -> IORef ()
brUniqueRef BRParams
ps) (Weak (IORef (IntMap (IORef a, Weak (IORef ())))) -> Int -> IO ()
forall a. Weak (RefMap a) -> Int -> IO ()
finalizeCell Weak (IORef (IntMap (IORef a, Weak (IORef ()))))
wm Int
i)
            IORef (IntMap (IORef a, Weak (IORef ())))
-> (IntMap (IORef a, Weak (IORef ()))
    -> (IntMap (IORef a, Weak (IORef ())), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Ref a -> IORef (IntMap (IORef a, Weak (IORef ())))
forall a. Ref a -> RefMap a
refMap Ref a
r) ((IntMap (IORef a, Weak (IORef ()))
  -> (IntMap (IORef a, Weak (IORef ())), ()))
 -> IO ())
-> (IntMap (IORef a, Weak (IORef ()))
    -> (IntMap (IORef a, Weak (IORef ())), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (IORef a, Weak (IORef ()))
m ->
              let m' :: IntMap (IORef a, Weak (IORef ()))
m' = Int
-> (IORef a, Weak (IORef ()))
-> IntMap (IORef a, Weak (IORef ()))
-> IntMap (IORef a, Weak (IORef ()))
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 :: Ref a -> (a -> a) -> Event (BR IO) ()
modifyRef Ref a
r a -> a
f =
  (Point (BR IO) -> BR IO ()) -> Event (BR IO) ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (BR IO) -> BR IO ()) -> Event (BR IO) ())
-> (Point (BR IO) -> BR IO ()) -> Event (BR IO) ()
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  (BRParams -> IO ()) -> BR IO ()
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO ()) -> BR IO ())
-> (BRParams -> IO ()) -> BR IO ()
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do IntMap (IORef a, Weak (IORef ()))
m <- IORef (IntMap (IORef a, Weak (IORef ())))
-> IO (IntMap (IORef a, Weak (IORef ())))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a, Weak (IORef ())))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = BRParams -> Int
brId BRParams
ps
     case Int
-> IntMap (IORef a, Weak (IORef ()))
-> Maybe (IORef a, Weak (IORef ()))
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 <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ra
            let b :: a
b = a -> a
f a
a
            a
b a -> IO () -> IO ()
`seq` IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ra a
b
       Maybe (IORef a, Weak (IORef ()))
Nothing ->
         do a
a <- BRParams -> BR IO a -> IO a
forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps (BR IO a -> IO a) -> BR IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Point (BR IO) -> Event (BR IO) a -> BR IO a
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (BR IO)
p (Event (BR IO) a -> BR IO a) -> Event (BR IO) a -> BR IO a
forall a b. (a -> b) -> a -> b
$ Ref a -> Event (BR IO) a
forall a. Ref a -> Event (BR IO) a
readRef Ref a
r
            BRParams -> BR IO () -> IO ()
forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps (BR IO () -> IO ()) -> BR IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Point (BR IO) -> Event (BR IO) () -> BR IO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (BR IO)
p (Event (BR IO) () -> BR IO ()) -> Event (BR IO) () -> BR IO ()
forall a b. (a -> b) -> a -> b
$ Ref a -> a -> Event (BR IO) ()
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 :: RefMap a -> IO ()
finalizeRef RefMap a
r =
  do IntMap (IORef a, Weak (IORef ()))
m <- RefMap a -> IO (IntMap (IORef a, Weak (IORef ())))
forall a. IORef a -> IO a
readIORef RefMap a
r
     [(IORef a, Weak (IORef ()))]
-> ((IORef a, Weak (IORef ())) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (IORef a, Weak (IORef ())) -> [(IORef a, Weak (IORef ()))]
forall a. IntMap a -> [a]
M.elems IntMap (IORef a, Weak (IORef ()))
m) (((IORef a, Weak (IORef ())) -> IO ()) -> IO ())
-> ((IORef a, Weak (IORef ())) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(IORef a
ra, Weak (IORef ())
wa) ->
       Weak (IORef ()) -> IO ()
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 :: Weak (RefMap a) -> Int -> IO ()
finalizeCell Weak (RefMap a)
wm Int
i =
  do Maybe (RefMap a)
rm <- Weak (RefMap a) -> IO (Maybe (RefMap a))
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 ->
         () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just RefMap a
rm ->
         do IntMap (IORef a, Weak (IORef ()))
m <- RefMap a -> IO (IntMap (IORef a, Weak (IORef ())))
forall a. IORef a -> IO a
readIORef RefMap a
rm
            case Int
-> IntMap (IORef a, Weak (IORef ()))
-> Maybe (IORef a, Weak (IORef ()))
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) ->
                RefMap a
-> (IntMap (IORef a, Weak (IORef ()))
    -> (IntMap (IORef a, Weak (IORef ())), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef RefMap a
rm ((IntMap (IORef a, Weak (IORef ()))
  -> (IntMap (IORef a, Weak (IORef ())), ()))
 -> IO ())
-> (IntMap (IORef a, Weak (IORef ()))
    -> (IntMap (IORef a, Weak (IORef ())), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (IORef a, Weak (IORef ()))
m ->
                let m' :: IntMap (IORef a, Weak (IORef ()))
m' = Int
-> IntMap (IORef a, Weak (IORef ()))
-> IntMap (IORef a, Weak (IORef ()))
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 ->
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()