{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | A very naive propagator library.
--
-- This propagator implementation keeps updating the values accoring to their
-- definitions as other values change, until a fixed-point is reached.
--
-- It is a naive implementation and not very clever. Much more efficient
-- propagator implementations are possible, and may be used by this library in
-- the future.
module Data.Propagator.Naive
    ( Prop
    , newProp
    , newConstProp
    , freezeProp
    , readProp
    , watchProp
    , setProp
    , lift1
    , lift2
    , liftList
    )
    where

import Control.Monad
import Data.POrder
import Data.Maybe

import qualified Data.Propagator.Class as Class

-- I want to test this code with dejafu, without carrying it as a dependency
-- of the main library. So here is a bit of CPP to care for that.

#ifdef DEJAFU

#define Ctxt   MonadConc m =>
#define Prop_  Prop m
#define IORef_ IORef m
#define MVar_  MVar m
#define M      m

import Control.Concurrent.Classy

#else

#define Ctxt
#define Prop_  Prop
#define IORef_ IORef
#define MVar_  MVar
#define M      IO

import Control.Exception
import Control.Concurrent.MVar
import Data.IORef

#endif

-- | A cell in a propagator network
data Prop_ a = Prop
    { forall a. Prop a -> IORef a
_val :: IORef_ a
    , forall a. Prop a -> MVar ()
_lock :: MVar_ ()
    , forall a. Prop a -> IORef (Maybe (IO ()))
_onChange :: IORef_ (Maybe (M ()))
    }

-- | Creates a cell, initialized to bottom
newProp :: Ctxt a -> M (Prop_ a)
newProp :: forall a. a -> IO (Prop a)
newProp a
x = do
    IORef a
m <- forall a. a -> IO (IORef a)
newIORef a
x
    MVar ()
l <- forall a. a -> IO (MVar a)
newMVar ()
    IORef (Maybe (IO ()))
notify <- forall a. a -> IO (IORef a)
newIORef (forall a. a -> Maybe a
Just (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> MVar () -> IORef (Maybe (IO ())) -> Prop a
Prop IORef a
m MVar ()
l IORef (Maybe (IO ()))
notify

-- | Creates a constant cell, given an initial value
newConstProp :: Ctxt a -> M (Prop_ a)
newConstProp :: forall a. a -> IO (Prop a)
newConstProp a
x = do
    IORef a
m <- forall a. a -> IO (IORef a)
newIORef a
x
    MVar ()
l <- forall a. a -> IO (MVar a)
newMVar ()
    IORef (Maybe (IO ()))
notify <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> MVar () -> IORef (Maybe (IO ())) -> Prop a
Prop IORef a
m MVar ()
l IORef (Maybe (IO ()))
notify

-- | Reads the current value of the cell
readProp :: Ctxt Prop_ a -> M a
readProp :: forall a. Prop a -> IO a
readProp (Prop IORef a
m MVar ()
_ IORef (Maybe (IO ()))
_ ) = forall a. IORef a -> IO a
readIORef IORef a
m

-- | Is the current propagator already frozen?
isFrozen :: Ctxt Prop_ a -> M Bool
isFrozen :: forall a. Prop a -> IO Bool
isFrozen (Prop IORef a
_ MVar ()
_ IORef (Maybe (IO ()))
notify) = do
    forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Maybe (IO ()))
notify

-- | Marks the propagator as frozen.
--
-- Will prevent further calls to setProp and clears the list of watchers (to
-- allow GC).
freezeProp :: Ctxt Prop_ a -> M ()
freezeProp :: forall a. Prop a -> IO ()
freezeProp (Prop IORef a
_ MVar ()
_ IORef (Maybe (IO ()))
notify) = do
    forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (IO ()))
notify forall a. Maybe a
Nothing

-- | Sets a new value calculated from the given action. The action is executed atomically.
--
-- Throws if the propagator is already frozen
--
-- If the value has changed, all watchers are notified afterwards (not atomically).
setProp :: Ctxt POrder a => Prop_ a -> M a -> M ()
setProp :: forall a. POrder a => Prop a -> IO a -> IO ()
setProp p :: Prop a
p@(Prop IORef a
m MVar ()
l IORef (Maybe (IO ()))
notify) IO a
getX = do
    Bool
frozen <- forall a. Prop a -> IO Bool
isFrozen Prop a
p
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
frozen forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw WriteToFrozenPropagatorException
Class.WriteToFrozenPropagatorException
    () <- forall a. MVar a -> IO a
takeMVar MVar ()
l
    a
old <- forall a. IORef a -> IO a
readIORef IORef a
m
    a
new <- IO a
getX
    forall a. IORef a -> a -> IO ()
writeIORef IORef a
m a
new
    forall a. MVar a -> a -> IO ()
putMVar MVar ()
l ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
old forall a. POrder a => a -> a -> Bool
`eqOfLe` a
new) forall a b. (a -> b) -> a -> b
$
        forall a. IORef a -> IO a
readIORef IORef (Maybe (IO ()))
notify forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (IO ())
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just IO ()
act -> IO ()
act

-- | Watch a cell: If the value changes, the given action is executed
watchProp :: Ctxt Prop_ a -> M () -> M ()
watchProp :: forall a. Prop a -> IO () -> IO ()
watchProp (Prop IORef a
_ MVar ()
_ IORef (Maybe (IO ()))
notify) IO ()
f =
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (IO ()))
notify forall a b. (a -> b) -> a -> b
$ \case
        Maybe (IO ())
Nothing -> (forall a. Maybe a
Nothing, ())
        Just IO ()
a -> (forall a. a -> Maybe a
Just (IO ()
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
a), ())

-- | Whenever the first cell changes, update the second, using the given function
lift1 :: Ctxt POrder b => (a -> b) -> Prop_ a -> Prop_ b -> M ()
lift1 :: forall b a. POrder b => (a -> b) -> Prop a -> Prop b -> IO ()
lift1 a -> b
f Prop a
p1 Prop b
p = do
    let update :: IO ()
update = forall a. POrder a => Prop a -> IO a -> IO ()
setProp Prop b
p forall a b. (a -> b) -> a -> b
$ a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Prop a -> IO a
readProp Prop a
p1
    forall a. Prop a -> IO () -> IO ()
watchProp Prop a
p1 IO ()
update
    IO ()
update

-- | Whenever any of the first two cells change, update the third, using the given function
lift2 :: Ctxt POrder c => (a -> b -> c) -> Prop_ a -> Prop_ b -> Prop_ c -> M ()
lift2 :: forall c a b.
POrder c =>
(a -> b -> c) -> Prop a -> Prop b -> Prop c -> IO ()
lift2 a -> b -> c
f Prop a
p1 Prop b
p2 Prop c
p = do
    let update :: IO ()
update = forall a. POrder a => Prop a -> IO a -> IO ()
setProp Prop c
p forall a b. (a -> b) -> a -> b
$ a -> b -> c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Prop a -> IO a
readProp Prop a
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Prop a -> IO a
readProp Prop b
p2
    forall a. Prop a -> IO () -> IO ()
watchProp Prop a
p1 IO ()
update
    forall a. Prop a -> IO () -> IO ()
watchProp Prop b
p2 IO ()
update
    IO ()
update

-- | Whenever any of the cells in the list change, update the other, using the given function
liftList :: Ctxt POrder b => ([a] -> b) -> [Prop_ a] -> Prop_ b -> M ()
liftList :: forall b a. POrder b => ([a] -> b) -> [Prop a] -> Prop b -> IO ()
liftList [a] -> b
f [Prop a]
ps Prop b
p = do
    let update :: IO ()
update = forall a. POrder a => Prop a -> IO a -> IO ()
setProp Prop b
p forall a b. (a -> b) -> a -> b
$ [a] -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Prop a -> IO a
readProp [Prop a]
ps
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Prop a
p' -> forall a. Prop a -> IO () -> IO ()
watchProp Prop a
p' IO ()
update) [Prop a]
ps
    IO ()
update

#ifndef DEJAFU
instance Bottom a => Class.Propagator (Prop_ a) a where
    newProp :: IO (Prop a)
newProp = forall a. a -> IO (Prop a)
newProp forall a. Bottom a => a
bottom
    newConstProp :: a -> IO (Prop a)
newConstProp = forall a. a -> IO (Prop a)
newConstProp
    freezeProp :: Prop a -> IO ()
freezeProp = forall a. Prop a -> IO ()
freezeProp
    readProp :: Prop a -> IO a
readProp = forall a. Prop a -> IO a
readProp
#endif