    {-# 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 = Dependencies -> IO Int
    forall v. GraphGC v -> IO Int
    GraphGC.getSize (Dependencies -> IO Int)
    -> (Network -> Dependencies) -> Network -> IO Int
    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 (DependencyChanges, [Output], Action, Maybe (Build ()))
    -> (DependencyChanges, [Output], Action, Maybe (Build ()))
    -> (DependencyChanges, [Output], Action, Maybe (Build ()))
    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 (DependencyChanges, [Output], Action, Maybe (Build ()))
    forall a. Monoid a => a
    mempty
        mappend :: BuildW -> BuildW -> BuildW
    mappend = BuildW -> BuildW -> BuildW
    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 IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO ()
    y)
    instance Monoid Action where
        mempty :: Action
    mempty = IO () -> Action
    Action (IO () -> Action) -> IO () -> Action
    forall a b. (a -> b) -> a -> b
    $ () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        mappend :: Action -> Action -> Action
    mappend = Action -> Action -> Action
    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 String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> String
    " " String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> Int -> String
    forall a. Show a => a -> String
    show (Int -> Output -> Int
    forall a. Hashable a => Int -> a -> Int
    hashWithSalt Int
    0 (Output -> Int) -> Output -> Int
    forall a b. (a -> b) -> a -> b
    $ Pulse a -> Output
    forall a. Pulse a -> Output
    _nodeP Pulse a
    p)
          where
            name :: String
    name = case IO SomeNodeD -> SomeNodeD
    forall a. IO a -> a
    unsafePerformIO (IO SomeNodeD -> SomeNodeD) -> IO SomeNodeD -> SomeNodeD
    forall a b. (a -> b) -> a -> b
    $ Output -> IO SomeNodeD
    forall (m :: * -> *) a. MonadIO m => Ref a -> m a
    Ref.read (Output -> IO SomeNodeD) -> Output -> IO SomeNodeD
    forall a b. (a -> b) -> a -> b
    $ Pulse a -> Output
    forall a. Pulse a -> Output
    _nodeP Pulse a
    p of
                  P PulseD a
    pulseD -> PulseD a -> String
    forall a. PulseD a -> String
    _nameP PulseD a
    pulseD
                  SomeNodeD
    _ -> String
    ""

    showUnique :: Unique -> String
    showUnique :: Unique -> String
    showUnique = Int -> String
    forall a. Show a => a -> String
    show (Int -> String) -> (Unique -> Int) -> Unique -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Unique -> Int
    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 = Output -> v -> Maybe (IO ()) -> IO (Weak v)
    forall k v. Ref k -> v -> Maybe (IO ()) -> IO (Weak v)
    Ref.mkWeak Output
    x v
    v Maybe (IO ())
    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
        someNode <- Output -> IO SomeNodeD
    forall (m :: * -> *) a. MonadIO m => Ref a -> m a
    Ref.read Output
    node
        pure $ case someNode of
            P PulseD a
    p -> PulseD a -> String
    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 = (Unique -> WeakRef SomeNodeD -> IO String)
    -> Dependencies -> IO String
    forall v.
    (Unique -> WeakRef v -> IO String) -> GraphGC v -> IO String
    GraphGC.printDot Unique -> WeakRef SomeNodeD -> IO String
    format (Dependencies -> IO String)
    -> (Network -> Dependencies) -> Network -> IO String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Network -> Dependencies
    nGraphGC
      where
        format :: Unique -> WeakRef SomeNodeD -> IO String
    format Unique
    u WeakRef SomeNodeD
    weakref = do
             mnode <- WeakRef SomeNodeD -> IO (Maybe Output)
    forall v. Weak v -> IO (Maybe v)
    Ref.deRefWeak WeakRef SomeNodeD
    weakref
             ((showUnique u <> ": ") <>) <$> case mnode of
                 Maybe Output
    Nothing -> String -> IO String
    forall a. a -> IO a
    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
    (Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Time -> Time -> Bool
    == :: Time -> Time -> Bool
    $c/= :: Time -> Time -> Bool
    /= :: Time -> Time -> Bool
    Eq, Eq Time
    Eq Time =>
    (Time -> Time -> Ordering)
    -> (Time -> Time -> Bool)
    -> (Time -> Time -> Bool)
    -> (Time -> Time -> Bool)
    -> (Time -> Time -> Bool)
    -> (Time -> Time -> Time)
    -> (Time -> Time -> Time)
    -> Ord 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
    $ccompare :: Time -> Time -> Ordering
    compare :: Time -> Time -> Ordering
    $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
    >= :: Time -> Time -> Bool
    $cmax :: Time -> Time -> Time
    max :: Time -> Time -> Time
    $cmin :: Time -> Time -> Time
    min :: Time -> Time -> Time
    Ord, Int -> Time -> ShowS
    [Time] -> ShowS
    Time -> String
    (Int -> Time -> ShowS)
    -> (Time -> String) -> ([Time] -> ShowS) -> Show Time
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Time -> ShowS
    showsPrec :: Int -> Time -> ShowS
    $cshow :: Time -> String
    show :: Time -> String
    $cshowList :: [Time] -> ShowS
    showList :: [Time] -> ShowS
    Show, ReadPrec [Time]
    ReadPrec Time
    Int -> ReadS Time
    ReadS [Time]
    (Int -> ReadS Time)
    -> ReadS [Time] -> ReadPrec Time -> ReadPrec [Time] -> Read Time
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS Time
    readsPrec :: Int -> ReadS Time
    $creadList :: ReadS [Time]
    readList :: ReadS [Time]
    $creadPrec :: ReadPrec Time
    readPrec :: ReadPrec Time
    $creadListPrec :: ReadPrec [Time]
    readListPrec :: ReadPrec [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
    nInteger -> Integer -> Integer
    forall a. Num a => a -> a -> a
    +Integer
    1)

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

    instance Monoid Time where
        mappend :: Time -> Time -> Time
    mappend = Time -> Time -> Time
    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`.

    -}