{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
module Reactive.Banana.Prim.Mid.Types where

import Data.Hashable
    ( hashWithSalt )
import Data.Unique.Really
    ( Unique )
import Control.Monad.Trans.RWSIO
    ( RWSIOT )
import Control.Monad.Trans.ReaderWriterIO
    ( ReaderWriterIOT )
import Reactive.Banana.Prim.Low.OrderedBag
    ( OrderedBag )
import System.IO.Unsafe
    ( unsafePerformIO )
import System.Mem.Weak
    ( Weak )

import qualified Data.Vault.Lazy as Lazy
import qualified Reactive.Banana.Prim.Low.Ref as Ref
import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC

{-----------------------------------------------------------------------------
    Network
------------------------------------------------------------------------------}
-- | A 'Network' represents the state of a pulse/latch network,
data Network = Network
    { Network -> Time
nTime           :: !Time                 -- Current time.
    , Network -> OrderedBag Output
nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.
    , Network -> Pulse ()
nAlwaysP        :: !(Pulse ())   -- Pulse that always fires.
    , Network -> Dependencies
nGraphGC        :: Dependencies
    }

getSize :: Network -> IO Int
getSize :: Network -> IO Int
getSize = forall v. GraphGC v -> IO Int
GraphGC.getSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Dependencies
nGraphGC

type Dependencies  = GraphGC.GraphGC SomeNodeD
type Inputs        = ([SomeNode], Lazy.Vault)
type EvalNetwork a = Network -> IO (a, Network)
type Step          = EvalNetwork (IO ())

type Build  = ReaderWriterIOT BuildR BuildW IO
type BuildR = (Time, Pulse ())
    -- ( current time
    -- , pulse that always fires)
newtype BuildW = BuildW (DependencyChanges, [Output], Action, Maybe (Build ()))
    -- reader : current timestamp
    -- writer : ( actions that change the network topology
    --          , outputs to be added to the network
    --          , late IO actions
    --          , late build actions
    --          )

instance Semigroup BuildW where
    BuildW (DependencyChanges, [Output], Action, Maybe (Build ()))
x <> :: BuildW -> BuildW -> BuildW
<> BuildW (DependencyChanges, [Output], Action, Maybe (Build ()))
y = (DependencyChanges, [Output], Action, Maybe (Build ())) -> BuildW
BuildW ((DependencyChanges, [Output], Action, Maybe (Build ()))
x forall a. Semigroup a => a -> a -> a
<> (DependencyChanges, [Output], Action, Maybe (Build ()))
y)

instance Monoid BuildW where
    mempty :: BuildW
mempty  = (DependencyChanges, [Output], Action, Maybe (Build ())) -> BuildW
BuildW forall a. Monoid a => a
mempty
    mappend :: BuildW -> BuildW -> BuildW
mappend = forall a. Semigroup a => a -> a -> a
(<>)

type BuildIO = Build

data DependencyChange parent child
    = InsertEdge parent child
    | ChangeParentTo child parent
type DependencyChanges = [DependencyChange SomeNode SomeNode]

{-----------------------------------------------------------------------------
    Synonyms
------------------------------------------------------------------------------}
-- | 'IO' actions as a monoid with respect to sequencing.
newtype Action = Action { Action -> IO ()
doit :: IO () }
instance Semigroup Action where
    Action IO ()
x <> :: Action -> Action -> Action
<> Action IO ()
y = IO () -> Action
Action (IO ()
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
y)
instance Monoid Action where
    mempty :: Action
mempty = IO () -> Action
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
    mappend :: Action -> Action -> Action
mappend = forall a. Semigroup a => a -> a -> a
(<>)

{-----------------------------------------------------------------------------
    Pulse and Latch
------------------------------------------------------------------------------}
data Pulse a = Pulse
    { forall a. Pulse a -> Key (Maybe a)
_key :: Lazy.Key (Maybe a) -- Key to retrieve pulse value from cache.
    , forall a. Pulse a -> Output
_nodeP :: SomeNode         -- Reference to its own node
    }

data PulseD a = PulseD
    { forall a. PulseD a -> Key (Maybe a)
_keyP      :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache.
    , forall a. PulseD a -> Time
_seenP     :: !Time              -- See note [Timestamp].
    , forall a. PulseD a -> EvalP (Maybe a)
_evalP     :: EvalP (Maybe a)    -- Calculate current value.
    , forall a. PulseD a -> String
_nameP     :: String             -- Name for debugging.
    }

instance Show (Pulse a) where
    show :: Pulse a -> String
show Pulse a
p = String
name forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Pulse a -> Output
_nodeP Pulse a
p)
      where
        name :: String
name = case forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Ref a -> m a
Ref.read forall a b. (a -> b) -> a -> b
$ forall a. Pulse a -> Output
_nodeP Pulse a
p of
              P PulseD a
pulseD -> forall a. PulseD a -> String
_nameP PulseD a
pulseD
              SomeNodeD
_ -> String
""

showUnique :: Unique -> String
showUnique :: Unique -> String
showUnique = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
0

type Latch  a = Ref.Ref (LatchD a)
data LatchD a = Latch
    { forall a. LatchD a -> Time
_seenL  :: !Time               -- Timestamp for the current value.
    , forall a. LatchD a -> a
_valueL :: a                   -- Current value.
    , forall a. LatchD a -> EvalL a
_evalL  :: EvalL a             -- Recalculate current latch value.
    }

type LatchWrite = SomeNode
data LatchWriteD = forall a. LatchWriteD
    { ()
_evalLW  :: EvalP a            -- Calculate value to write.
    , ()
_latchLW :: Weak (Latch a)     -- Destination 'Latch' to write to.
    }

type Output  = SomeNode
data OutputD = Output
    { OutputD -> EvalP EvalO
_evalO     :: EvalP EvalO
    }

type SomeNode = Ref.Ref SomeNodeD
data SomeNodeD
    = forall a. P (PulseD a)
    | L LatchWriteD
    | O OutputD

{-# INLINE mkWeakNodeValue #-}
mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)
mkWeakNodeValue :: forall v. Output -> v -> IO (Weak v)
mkWeakNodeValue Output
x v
v = forall k v. Ref k -> v -> Maybe (IO ()) -> IO (Weak v)
Ref.mkWeak Output
x v
v forall a. Maybe a
Nothing

-- | Evaluation monads.
type EvalPW   = (EvalLW, [(Output, EvalO)])
type EvalLW   = Action

type EvalO    = Future (IO ())
type Future   = IO

-- Note: For efficiency reasons, we unroll the monad transformer stack.
-- type EvalP = RWST () Lazy.Vault EvalPW Build
type EvalP    = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO
    -- writer : (latch updates, IO action)
    -- state  : current pulse values

-- Computation with a timestamp that indicates the last time it was performed.
type EvalL    = ReaderWriterIOT () Time IO

{-----------------------------------------------------------------------------
    Show functions for debugging
------------------------------------------------------------------------------}
printNode :: SomeNode -> IO String
printNode :: Output -> IO String
printNode Output
node = do
    SomeNodeD
someNode <- forall (m :: * -> *) a. MonadIO m => Ref a -> m a
Ref.read Output
node
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case SomeNodeD
someNode of
        P PulseD a
p -> forall a. PulseD a -> String
_nameP PulseD a
p
        L LatchWriteD
_ -> String
"L"
        O OutputD
_ -> String
"O"

-- | Show the graph of the 'Network' in @graphviz@ dot file format.
printDot :: Network -> IO String
printDot :: Network -> IO String
printDot = forall v.
(Unique -> WeakRef v -> IO String) -> GraphGC v -> IO String
GraphGC.printDot Unique -> Weak Output -> IO String
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Dependencies
nGraphGC
  where
    format :: Unique -> Weak Output -> IO String
format Unique
u Weak Output
weakref = do
         Maybe Output
mnode <- forall v. Weak v -> IO (Maybe v)
Ref.deRefWeak Weak Output
weakref
         ((Unique -> String
showUnique Unique
u forall a. Semigroup a => a -> a -> a
<> String
": ") forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe Output
mnode of
             Maybe Output
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"(x_x)"
             Just Output
node -> Output -> IO String
printNode Output
node

{-----------------------------------------------------------------------------
    Time monoid
------------------------------------------------------------------------------}
-- | A timestamp local to this program run.
--
-- Useful e.g. for controlling cache validity.
newtype Time = T Integer deriving (Time -> Time -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq, Eq Time
Time -> Time -> Bool
Time -> Time -> Ordering
Time -> Time -> Time
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmax :: Time -> Time -> Time
>= :: Time -> Time -> Bool
$c>= :: Time -> Time -> Bool
> :: Time -> Time -> Bool
$c> :: Time -> Time -> Bool
<= :: Time -> Time -> Bool
$c<= :: Time -> Time -> Bool
< :: Time -> Time -> Bool
$c< :: Time -> Time -> Bool
compare :: Time -> Time -> Ordering
$ccompare :: Time -> Time -> Ordering
Ord, Int -> Time -> ShowS
[Time] -> ShowS
Time -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Time] -> ShowS
$cshowList :: [Time] -> ShowS
show :: Time -> String
$cshow :: Time -> String
showsPrec :: Int -> Time -> ShowS
$cshowsPrec :: Int -> Time -> ShowS
Show, ReadPrec [Time]
ReadPrec Time
Int -> ReadS Time
ReadS [Time]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Time]
$creadListPrec :: ReadPrec [Time]
readPrec :: ReadPrec Time
$creadPrec :: ReadPrec Time
readList :: ReadS [Time]
$creadList :: ReadS [Time]
readsPrec :: Int -> ReadS Time
$creadsPrec :: Int -> ReadS Time
Read)

-- | Before the beginning of time. See Note [TimeStamp]
agesAgo :: Time
agesAgo :: Time
agesAgo = Integer -> Time
T (-Integer
1)

beginning :: Time
beginning :: Time
beginning = Integer -> Time
T Integer
0

next :: Time -> Time
next :: Time -> Time
next (T Integer
n) = Integer -> Time
T (Integer
nforall a. Num a => a -> a -> a
+Integer
1)

instance Semigroup Time where
    T Integer
x <> :: Time -> Time -> Time
<> T Integer
y = Integer -> Time
T (forall a. Ord a => a -> a -> a
max Integer
x Integer
y)

instance Monoid Time where
    mappend :: Time -> Time -> Time
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: Time
mempty  = Time
beginning

{-----------------------------------------------------------------------------
    Notes
------------------------------------------------------------------------------}
{- Note [Timestamp]

The time stamp indicates how recent the current value is.

For Pulse:
During pulse evaluation, a time stamp equal to the current
time indicates that the pulse has already been evaluated in this phase.

For Latch:
The timestamp indicates the last time at which the latch has been written to.

    agesAgo   = The latch has never been written to.
    beginning = The latch has been written to before everything starts.

The second description is ensured by the fact that the network
writes timestamps that begin at time `next beginning`.

-}