{-# 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 <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
x
    MVar ()
l <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    IORef (Maybe (IO ()))
notify <- Maybe (IO ()) -> IO (IORef (Maybe (IO ())))
forall a. a -> IO (IORef a)
newIORef (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
    Prop a -> IO (Prop a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prop a -> IO (Prop a)) -> Prop a -> IO (Prop a)
forall a b. (a -> b) -> a -> b
$ IORef a -> MVar () -> IORef (Maybe (IO ())) -> Prop a
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 <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
x
    MVar ()
l <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    IORef (Maybe (IO ()))
notify <- Maybe (IO ()) -> IO (IORef (Maybe (IO ())))
forall a. a -> IO (IORef a)
newIORef Maybe (IO ())
forall a. Maybe a
Nothing
    Prop a -> IO (Prop a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prop a -> IO (Prop a)) -> Prop a -> IO (Prop a)
forall a b. (a -> b) -> a -> b
$ IORef a -> MVar () -> IORef (Maybe (IO ())) -> Prop a
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 ()))
_ ) = IORef a -> IO a
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
    Maybe (IO ()) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (IO ()) -> Bool) -> IO (Maybe (IO ())) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe (IO ())) -> IO (Maybe (IO ()))
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
    IORef (Maybe (IO ())) -> Maybe (IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (IO ()))
notify Maybe (IO ())
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 <- Prop a -> IO Bool
forall a. Prop a -> IO Bool
isFrozen Prop a
p
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
frozen (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WriteToFrozenPropagatorException -> IO ()
forall a e. Exception e => e -> a
throw WriteToFrozenPropagatorException
Class.WriteToFrozenPropagatorException
    () <- MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
l
    a
old <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
m
    a
new <- IO a
getX
    IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
m a
new
    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
l ()
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
old a -> a -> Bool
forall a. POrder a => a -> a -> Bool
`eqOfLe` a
new) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IORef (Maybe (IO ())) -> IO (Maybe (IO ()))
forall a. IORef a -> IO a
readIORef IORef (Maybe (IO ()))
notify IO (Maybe (IO ())) -> (Maybe (IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (IO ())
Nothing -> () -> IO ()
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 =
    IORef (Maybe (IO ()))
-> (Maybe (IO ()) -> (Maybe (IO ()), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (IO ()))
notify ((Maybe (IO ()) -> (Maybe (IO ()), ())) -> IO ())
-> (Maybe (IO ()) -> (Maybe (IO ()), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        Maybe (IO ())
Nothing -> (Maybe (IO ())
forall a. Maybe a
Nothing, ())
        Just IO ()
a -> (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO ()
f IO () -> IO () -> IO ()
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 = Prop b -> IO b -> IO ()
forall a. POrder a => Prop a -> IO a -> IO ()
setProp Prop b
p (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Prop a -> IO a
forall a. Prop a -> IO a
readProp Prop a
p1
    Prop a -> IO () -> IO ()
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 = Prop c -> IO c -> IO ()
forall a. POrder a => Prop a -> IO a -> IO ()
setProp Prop c
p (IO c -> IO ()) -> IO c -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> b -> c
f (a -> b -> c) -> IO a -> IO (b -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Prop a -> IO a
forall a. Prop a -> IO a
readProp Prop a
p1 IO (b -> c) -> IO b -> IO c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Prop b -> IO b
forall a. Prop a -> IO a
readProp Prop b
p2
    Prop a -> IO () -> IO ()
forall a. Prop a -> IO () -> IO ()
watchProp Prop a
p1 IO ()
update
    Prop b -> IO () -> IO ()
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 = Prop b -> IO b -> IO ()
forall a. POrder a => Prop a -> IO a -> IO ()
setProp Prop b
p (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ [a] -> b
f ([a] -> b) -> IO [a] -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Prop a -> IO a) -> [Prop a] -> IO [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Prop a -> IO a
forall a. Prop a -> IO a
readProp [Prop a]
ps
    (Prop a -> IO ()) -> [Prop a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Prop a
p' -> Prop a -> IO () -> IO ()
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 = a -> IO (Prop a)
forall a. a -> IO (Prop a)
newProp a
forall a. Bottom a => a
bottom
    newConstProp :: a -> IO (Prop a)
newConstProp = a -> IO (Prop a)
forall a. a -> IO (Prop a)
newConstProp
    freezeProp :: Prop a -> IO ()
freezeProp = Prop a -> IO ()
forall a. Prop a -> IO ()
freezeProp
    readProp :: Prop a -> IO a
readProp = Prop a -> IO a
forall a. Prop a -> IO a
readProp
#endif