{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
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
data Network = Network
{ Network -> Time
nTime :: !Time
, Network -> OrderedBag Output
nOutputs :: !(OrderedBag Output)
, Network -> Pulse ()
nAlwaysP :: !(Pulse ())
, 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 ())
newtype BuildW = BuildW (DependencyChanges, [Output], Action, Maybe (Build ()))
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]
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
(<>)
data Pulse a = Pulse
{ forall a. Pulse a -> Key (Maybe a)
_key :: Lazy.Key (Maybe a)
, forall a. Pulse a -> Output
_nodeP :: SomeNode
}
data PulseD a = PulseD
{ forall a. PulseD a -> Key (Maybe a)
_keyP :: Lazy.Key (Maybe a)
, forall a. PulseD a -> Time
_seenP :: !Time
, forall a. PulseD a -> EvalP (Maybe a)
_evalP :: EvalP (Maybe a)
, forall a. PulseD a -> String
_nameP :: String
}
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
, forall a. LatchD a -> a
_valueL :: a
, forall a. LatchD a -> EvalL a
_evalL :: EvalL a
}
type LatchWrite = SomeNode
data LatchWriteD = forall a. LatchWriteD
{ ()
_evalLW :: EvalP a
, ()
_latchLW :: Weak (Latch a)
}
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
type EvalPW = (EvalLW, [(Output, EvalO)])
type EvalLW = Action
type EvalO = Future (IO ())
type Future = IO
type EvalP = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO
type EvalL = ReaderWriterIOT () Time IO
printNode :: SomeNode -> IO String
printNode :: Output -> IO String
printNode Output
node = do
SomeNodeD
someNode <- Output -> IO SomeNodeD
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
Ref.read Output
node
String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ case SomeNodeD
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"
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
Maybe Output
mnode <- WeakRef SomeNodeD -> IO (Maybe Output)
forall v. Weak v -> IO (Maybe v)
Ref.deRefWeak WeakRef SomeNodeD
weakref
((Unique -> String
showUnique Unique
u String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": ") String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe Output
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
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)
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