{-# LANGUAGE BangPatterns #-}

-- |
-- Module     : Simulation.Aivika.Lattice.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.Lattice.Internal.Ref.Strict
       (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 strict mutable reference.
newtype Ref a = Ref { forall a. 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 = (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)

-- | Return the map index.
lioMapIndex :: LIOParams -> Int
lioMapIndex :: LIOParams -> Int
lioMapIndex LIOParams
ps = ((Int
i forall a. Num a => a -> a -> a
* (Int
i forall a. Num a => a -> a -> a
+ Int
1)) forall a. Integral a => a -> a -> a
`div` Int
2) 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 :: forall a. Simulation LIO (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. LIO (Ref a)
newEmptyRef0

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

-- | Create a new reference.
newRef :: a -> Simulation LIO (Ref a)
newRef :: forall a. a -> Simulation LIO (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 -> LIO (Ref a)
newRef0

-- | Create a new reference.
newRef0 :: a -> LIO (Ref a)
newRef0 :: forall a. a -> LIO (Ref a)
newRef0 a
a =
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do Ref a
r  <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a. LIO (Ref a)
newEmptyRef0
     IORef a
ra <- forall a. a -> IO (IORef a)
newIORef a
a
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     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 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 LIO a
readRef :: forall a. Ref a -> Event LIO a
readRef = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event 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. Ref a -> LIO a
readRef0
     
-- | Read the value of a reference.
readRef0 :: Ref a -> LIO a
readRef0 :: forall a. Ref a -> LIO a
readRef0 Ref a
r =
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- forall a. IORef a -> IO a
readIORef (forall a. Ref a -> RefMap a
refMap Ref a
r)
     let loop :: LIOParams -> IO a
loop LIOParams
ps =
           case forall a. Int -> IntMap a -> Maybe a
M.lookup (LIOParams -> Int
lioMapIndex LIOParams
ps) IntMap (IORef a)
m of
             Just IORef a
ra -> 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  -> 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 :: forall a. Ref a -> a -> Event LIO ()
writeRef Ref a
r a
a = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 :: forall a. Ref a -> a -> LIO ()
writeRef0 Ref a
r a
a =
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do IntMap (IORef a)
m <- forall a. IORef a -> IO a
readIORef (forall a. Ref a -> RefMap a
refMap Ref a
r)
     let !i :: Int
i = LIOParams -> Int
lioMapIndex LIOParams
ps
     case forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (IORef a)
m of
       Just IORef a
ra -> 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)
Nothing ->
         do IORef a
ra <- a
a seq :: forall a b. a -> b -> b
`seq` forall a. a -> IO (IORef a)
newIORef a
a
            forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (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

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

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

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