{-# LANGUAGE BangPatterns #-}

-- |
-- Module     : Simulation.Aivika.Lattice.Internal.Ref.Lazy
-- 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 lazy mutable references.
--
module Simulation.Aivika.Lattice.Internal.Ref.Lazy
       (Ref,
        newEmptyRef,
        newEmptyRef0,
        newRef,
        newRef0,
        readRef,
        readRef0,
        writeRef,
        writeRef0,
        modifyRef,
        modifyRef0,
        topRefDefined0,
        defineTopRef0,
        defineTopRef0_) where

-- import Debug.Trace

import Data.IORef
import qualified Data.IntMap as M

import Control.Monad
import Control.Monad.Trans

import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Lattice.Internal.LIO

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

-- | A lazy mutable reference.
newtype Ref a = Ref { Ref a -> RefMap a
refMap :: RefMap a
                      -- ^ the map of actual references
                    }

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)

-- | Return the map index.
lioMapIndex :: LIOParams -> Int
lioMapIndex :: LIOParams -> Int
lioMapIndex LIOParams
ps = ((Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k
  where i :: Int
i = LIOParams -> Int
lioTimeIndex LIOParams
ps
        k :: Int
k = LIOParams -> Int
lioMemberIndex LIOParams
ps

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

-- | Create an empty reference.
newEmptyRef0 :: LIO (Ref a)
newEmptyRef0 :: LIO (Ref a)
newEmptyRef0 =
  (LIOParams -> IO (Ref a)) -> LIO (Ref a)
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO (Ref a)) -> LIO (Ref a))
-> (LIOParams -> IO (Ref a)) -> LIO (Ref a)
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IORef (IntMap (IORef a))
rm <- IntMap (IORef a) -> IO (IORef (IntMap (IORef a)))
forall a. a -> IO (IORef a)
newIORef IntMap (IORef a)
forall a. IntMap a
M.empty
     Ref a -> IO (Ref a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ref :: forall a. RefMap a -> Ref a
Ref { refMap :: IORef (IntMap (IORef a))
refMap = IORef (IntMap (IORef a))
rm }

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

-- | Create a new reference.
newRef0 :: a -> LIO (Ref a)
newRef0 :: a -> LIO (Ref a)
newRef0 a
a =
  (LIOParams -> IO (Ref a)) -> LIO (Ref a)
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO (Ref a)) -> LIO (Ref a))
-> (LIOParams -> IO (Ref a)) -> LIO (Ref a)
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do Ref a
r  <- LIOParams -> LIO (Ref a) -> IO (Ref a)
forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps LIO (Ref a)
forall a. LIO (Ref a)
newEmptyRef0
     IORef a
ra <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     IORef (IntMap (IORef a)) -> IntMap (IORef a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r) (IntMap (IORef a) -> IO ()) -> IntMap (IORef a) -> IO ()
forall a b. (a -> b) -> a -> b
$
       Int -> IORef a -> IntMap (IORef a) -> IntMap (IORef a)
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i IORef a
ra IntMap (IORef a)
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 LIO a
readRef :: Ref a -> Event LIO a
readRef = (Point LIO -> LIO a) -> Event LIO a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point LIO -> LIO a) -> Event LIO a)
-> (Ref a -> Point LIO -> LIO a) -> Ref a -> Event LIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LIO a -> Point LIO -> LIO a
forall a b. a -> b -> a
const (LIO a -> Point LIO -> LIO a)
-> (Ref a -> LIO a) -> Ref a -> Point LIO -> LIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref a -> LIO a
forall a. Ref a -> LIO a
readRef0
     
-- | Read the value of a reference.
readRef0 :: Ref a -> LIO a
readRef0 :: Ref a -> LIO a
readRef0 Ref a
r =
  (LIOParams -> IO a) -> LIO a
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO a) -> LIO a) -> (LIOParams -> IO a) -> LIO a
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- IORef (IntMap (IORef a)) -> IO (IntMap (IORef a))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let loop :: LIOParams -> IO a
loop LIOParams
ps =
           case Int -> IntMap (IORef a) -> Maybe (IORef a)
forall a. Int -> IntMap a -> Maybe a
M.lookup (LIOParams -> Int
lioMapIndex LIOParams
ps) IntMap (IORef a)
m of
             Just IORef a
ra -> IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ra
             Maybe (IORef a)
Nothing ->
               case LIOParams -> Maybe LIOParams
parentLIOParams LIOParams
ps of
                 Just LIOParams
ps' -> LIOParams -> IO a
loop LIOParams
ps'
                 Maybe LIOParams
Nothing  -> [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot find lattice node: readRef0"
     LIOParams -> IO a
loop LIOParams
ps

-- | Write a new value into the reference.
writeRef :: Ref a -> a -> Event LIO ()
writeRef :: Ref a -> a -> Event LIO ()
writeRef Ref a
r a
a = (Point LIO -> LIO ()) -> Event LIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point LIO -> LIO ()) -> Event LIO ())
-> (Point LIO -> LIO ()) -> Event LIO ()
forall a b. (a -> b) -> a -> b
$ LIO () -> Point LIO -> LIO ()
forall a b. a -> b -> a
const (LIO () -> Point LIO -> LIO ()) -> LIO () -> Point LIO -> LIO ()
forall a b. (a -> b) -> a -> b
$ Ref a -> a -> LIO ()
forall a. Ref a -> a -> LIO ()
writeRef0 Ref a
r a
a 

-- | Write a new value into the reference.
writeRef0 :: Ref a -> a -> LIO ()
writeRef0 :: Ref a -> a -> LIO ()
writeRef0 Ref a
r a
a =
  (LIOParams -> IO ()) -> LIO ()
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO ()) -> LIO ()) -> (LIOParams -> IO ()) -> LIO ()
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- IORef (IntMap (IORef a)) -> IO (IntMap (IORef a))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     case Int -> IntMap (IORef a) -> Maybe (IORef a)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a)
m of
       Just IORef a
ra -> IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ra a
a
       Maybe (IORef a)
Nothing ->
         do IORef a
ra <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
            IORef (IntMap (IORef a))
-> (IntMap (IORef a) -> IntMap (IORef a)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r) ((IntMap (IORef a) -> IntMap (IORef a)) -> IO ())
-> (IntMap (IORef a) -> IntMap (IORef a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IORef a -> IntMap (IORef a) -> IntMap (IORef a)
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i IORef a
ra

-- | Mutate the contents of the reference.
modifyRef :: Ref a -> (a -> a) -> Event LIO ()
modifyRef :: Ref a -> (a -> a) -> Event LIO ()
modifyRef Ref a
r a -> a
f = (Point LIO -> LIO ()) -> Event LIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point LIO -> LIO ()) -> Event LIO ())
-> (Point LIO -> LIO ()) -> Event LIO ()
forall a b. (a -> b) -> a -> b
$ LIO () -> Point LIO -> LIO ()
forall a b. a -> b -> a
const (LIO () -> Point LIO -> LIO ()) -> LIO () -> Point LIO -> LIO ()
forall a b. (a -> b) -> a -> b
$ Ref a -> (a -> a) -> LIO ()
forall a. Ref a -> (a -> a) -> LIO ()
modifyRef0 Ref a
r a -> a
f

-- | Mutate the contents of the reference.
modifyRef0 :: Ref a -> (a -> a) -> LIO ()
modifyRef0 :: Ref a -> (a -> a) -> LIO ()
modifyRef0 Ref a
r a -> a
f =
  (LIOParams -> IO ()) -> LIO ()
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO ()) -> LIO ()) -> (LIOParams -> IO ()) -> LIO ()
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- IORef (IntMap (IORef a)) -> IO (IntMap (IORef a))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     case Int -> IntMap (IORef a) -> Maybe (IORef a)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a)
m of
       Just IORef a
ra ->
         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
            IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ra a
b
       Maybe (IORef a)
Nothing ->
         do a
a <- LIOParams -> LIO a -> IO a
forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps (LIO a -> IO a) -> LIO a -> IO a
forall a b. (a -> b) -> a -> b
$ Ref a -> LIO a
forall a. Ref a -> LIO a
readRef0 Ref a
r
            LIOParams -> LIO () -> IO ()
forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps (LIO () -> IO ()) -> LIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ref a -> a -> LIO ()
forall a. Ref a -> a -> LIO ()
writeRef0 Ref a
r (a -> a
f a
a)

-- | Whether the top reference value is defined.
topRefDefined0 :: Ref a -> LIO Bool
topRefDefined0 :: Ref a -> LIO Bool
topRefDefined0 Ref a
r =
  (LIOParams -> IO Bool) -> LIO Bool
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO Bool) -> LIO Bool)
-> (LIOParams -> IO Bool) -> LIO Bool
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- IORef (IntMap (IORef a)) -> IO (IntMap (IORef a))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     case Int -> IntMap (IORef a) -> Maybe (IORef a)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a)
m of
       Just IORef a
ra -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       Maybe (IORef a)
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Define the top reference value.
defineTopRef0 :: Ref a -> LIO a
defineTopRef0 :: Ref a -> LIO a
defineTopRef0 Ref a
r =
  (LIOParams -> IO a) -> LIO a
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO a) -> LIO a) -> (LIOParams -> IO a) -> LIO a
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- IORef (IntMap (IORef a)) -> IO (IntMap (IORef a))
forall a. IORef a -> IO a
readIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     case Int -> IntMap (IORef a) -> Maybe (IORef a)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a)
m of
       Just IORef a
ra -> IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ra
       Maybe (IORef a)
Nothing ->
         case LIOParams -> Maybe LIOParams
parentLIOParams LIOParams
ps of
           Maybe LIOParams
Nothing  -> [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot find parent: defineTopRef0"
           Just LIOParams
ps' ->
             do a
a  <- LIOParams -> LIO a -> IO a
forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps' (LIO a -> IO a) -> LIO a -> IO a
forall a b. (a -> b) -> a -> b
$ Ref a -> LIO a
forall a. Ref a -> LIO a
defineTopRef0 Ref a
r
                IORef a
ra <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
                IORef (IntMap (IORef a))
-> (IntMap (IORef a) -> IntMap (IORef a)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Ref a -> IORef (IntMap (IORef a))
forall a. Ref a -> RefMap a
refMap Ref a
r) ((IntMap (IORef a) -> IntMap (IORef a)) -> IO ())
-> (IntMap (IORef a) -> IntMap (IORef a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IORef a -> IntMap (IORef a) -> IntMap (IORef a)
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i IORef a
ra
                a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Ensure that the top reference value is defined.
defineTopRef0_ :: Ref a -> LIO ()
defineTopRef0_ :: Ref a -> LIO ()
defineTopRef0_ Ref a
r =
  do a
a <- Ref a -> LIO a
forall a. Ref a -> LIO a
defineTopRef0 Ref a
r
     () -> LIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()