{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.Aztecs.Schedule
  ( Node (..),
    Schedule (..),
    ScheduleNode (..),
    runSchedule,
    Startup,
    Update,
    Constraint (..),
    before,
    after,
    Scheduler (..),
    schedule,
    SchedulerGraph (..),
    buildScheduler,
    runSchedulerGraph,
    runScheduler,
  )
where

import Control.Concurrent.Async (mapConcurrently)
import Control.Monad.State (StateT (runStateT))
import Data.Aztecs.Command
import Data.Aztecs.System
import Data.Aztecs.World
  ( World,
    newWorld,
    union,
  )
import Data.Foldable (foldrM)
import Data.Functor ((<&>))
import Data.List (groupBy, sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable
import Prelude hiding (all, read)

data Constraint = Before TypeRep | After TypeRep

before :: forall m a. (System m a) => Constraint
before :: forall (m :: * -> *) a. System m a => Constraint
before = TypeRep -> Constraint
Before (TypeRep -> Constraint) -> TypeRep -> Constraint
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

after :: forall m a. (System m a) => Constraint
after :: forall (m :: * -> *) a. System m a => Constraint
after = TypeRep -> Constraint
After (TypeRep -> Constraint) -> TypeRep -> Constraint
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

data Node m where
  Node :: (System m a) => Proxy a -> Cache -> Node m

data ScheduleNode m = ScheduleNode (Node m) [Constraint]

data Schedule m = Schedule (Map TypeRep (ScheduleNode m))

instance Semigroup (Schedule m) where
  Schedule Map TypeRep (ScheduleNode m)
a <> :: Schedule m -> Schedule m -> Schedule m
<> Schedule Map TypeRep (ScheduleNode m)
b = Map TypeRep (ScheduleNode m) -> Schedule m
forall (m :: * -> *). Map TypeRep (ScheduleNode m) -> Schedule m
Schedule (Map TypeRep (ScheduleNode m) -> Schedule m)
-> Map TypeRep (ScheduleNode m) -> Schedule m
forall a b. (a -> b) -> a -> b
$ Map TypeRep (ScheduleNode m)
a Map TypeRep (ScheduleNode m)
-> Map TypeRep (ScheduleNode m) -> Map TypeRep (ScheduleNode m)
forall a. Semigroup a => a -> a -> a
<> Map TypeRep (ScheduleNode m)
b

instance Monoid (Schedule m) where
  mempty :: Schedule m
mempty = Map TypeRep (ScheduleNode m) -> Schedule m
forall (m :: * -> *). Map TypeRep (ScheduleNode m) -> Schedule m
Schedule Map TypeRep (ScheduleNode m)
forall a. Monoid a => a
mempty

data GraphNode m = GraphNode (Node m) (Set TypeRep) (Set TypeRep)

build :: (Monad m) => Schedule m -> [[GraphNode m]]
build :: forall (m :: * -> *). Monad m => Schedule m -> [[GraphNode m]]
build (Schedule Map TypeRep (ScheduleNode m)
s) =
  let graph :: Map TypeRep (GraphNode m)
graph =
        (ScheduleNode m -> GraphNode m)
-> Map TypeRep (ScheduleNode m) -> Map TypeRep (GraphNode m)
forall a b. (a -> b) -> Map TypeRep a -> Map TypeRep b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( \(ScheduleNode Node m
node [Constraint]
constraints) ->
              let ([TypeRep]
deps, [TypeRep]
befores) =
                    (Constraint -> ([TypeRep], [TypeRep]) -> ([TypeRep], [TypeRep]))
-> ([TypeRep], [TypeRep]) -> [Constraint] -> ([TypeRep], [TypeRep])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                      ( \Constraint
c ([TypeRep]
depAcc, [TypeRep]
afterAcc) -> case Constraint
c of
                          Before TypeRep
i -> ([TypeRep]
depAcc, [TypeRep
i])
                          After TypeRep
i -> ([TypeRep]
depAcc [TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++ [TypeRep
i], [TypeRep]
afterAcc)
                      )
                      ([], [])
                      [Constraint]
constraints
               in Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
forall (m :: * -> *).
Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
GraphNode Node m
node ([TypeRep] -> Set TypeRep
forall a. Ord a => [a] -> Set a
Set.fromList [TypeRep]
deps) ([TypeRep] -> Set TypeRep
forall a. Ord a => [a] -> Set a
Set.fromList [TypeRep]
befores)
          )
          Map TypeRep (ScheduleNode m)
s
      graph' :: Map TypeRep (GraphNode m)
graph' =
        (GraphNode m
 -> Map TypeRep (GraphNode m) -> Map TypeRep (GraphNode m))
-> Map TypeRep (GraphNode m)
-> Map TypeRep (GraphNode m)
-> Map TypeRep (GraphNode m)
forall a b. (a -> b -> b) -> b -> Map TypeRep a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          ( \(GraphNode Node m
_ Set TypeRep
_ Set TypeRep
befores) Map TypeRep (GraphNode m)
acc ->
              (TypeRep -> Map TypeRep (GraphNode m) -> Map TypeRep (GraphNode m))
-> Map TypeRep (GraphNode m)
-> Set TypeRep
-> Map TypeRep (GraphNode m)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( \TypeRep
i Map TypeRep (GraphNode m)
acc' ->
                    (GraphNode m -> GraphNode m)
-> TypeRep
-> Map TypeRep (GraphNode m)
-> Map TypeRep (GraphNode m)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
                      ( \(GraphNode Node m
n Set TypeRep
deps Set TypeRep
bs) ->
                          Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
forall (m :: * -> *).
Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
GraphNode Node m
n (TypeRep -> Set TypeRep
forall a. a -> Set a
Set.singleton TypeRep
i Set TypeRep -> Set TypeRep -> Set TypeRep
forall a. Semigroup a => a -> a -> a
<> Set TypeRep
deps) Set TypeRep
bs
                      )
                      TypeRep
i
                      Map TypeRep (GraphNode m)
acc'
                )
                Map TypeRep (GraphNode m)
acc
                Set TypeRep
befores
          )
          Map TypeRep (GraphNode m)
graph
          Map TypeRep (GraphNode m)
graph
      nodes :: [GraphNode m]
nodes =
        (GraphNode m -> GraphNode m -> Ordering)
-> [GraphNode m] -> [GraphNode m]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy
          ( \(GraphNode Node m
_ Set TypeRep
deps Set TypeRep
_) (GraphNode Node m
_ Set TypeRep
deps' Set TypeRep
_) ->
              Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Set TypeRep -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set TypeRep
deps') (Set TypeRep -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set TypeRep
deps)
          )
          (Map TypeRep (GraphNode m) -> [GraphNode m]
forall k a. Map k a -> [a]
Map.elems Map TypeRep (GraphNode m)
graph')
   in (GraphNode m -> GraphNode m -> Bool)
-> [GraphNode m] -> [[GraphNode m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy
        ( \(GraphNode Node m
a Set TypeRep
deps Set TypeRep
aBefores) (GraphNode Node m
b Set TypeRep
deps' Set TypeRep
bBefores) ->
            (Set TypeRep -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set TypeRep
deps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set TypeRep -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set TypeRep
deps')
            -- TODO || hasConflict (GraphNode a deps aBefores) (GraphNode b deps' bBefores)
        )
        [GraphNode m]
nodes

runNode :: Node IO -> World -> IO (Node IO, Maybe (Access IO ()), [Command IO ()], World)
runNode :: Node IO
-> World
-> IO (Node IO, Maybe (Access IO ()), [Command IO ()], World)
runNode (Node Proxy a
p Cache
cache) World
w =
  Proxy a
-> Cache
-> World
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
forall a.
System IO a =>
Proxy a
-> Cache
-> World
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystemProxy Proxy a
p Cache
cache World
w IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
-> ((Maybe (Access IO ()), Cache, [Command IO ()], World)
    -> (Node IO, Maybe (Access IO ()), [Command IO ()], World))
-> IO (Node IO, Maybe (Access IO ()), [Command IO ()], World)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(Maybe (Access IO ())
next, Cache
a', [Command IO ()]
cmds, World
w') -> (Proxy a -> Cache -> Node IO
forall (m :: * -> *) a. System m a => Proxy a -> Cache -> Node m
Node Proxy a
p Cache
a', Maybe (Access IO ())
next, [Command IO ()]
cmds, World
w'))

runSystemProxy :: forall a. (System IO a) => Proxy a -> Cache -> World -> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystemProxy :: forall a.
System IO a =>
Proxy a
-> Cache
-> World
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystemProxy Proxy a
_ = forall a.
System IO a =>
Cache
-> World
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystem' @a

-- | Run a `Command`, returning any temporary `Entity`s and the updated `World`.
runCommand :: Command IO () -> World -> IO (World)
runCommand :: Command IO () -> World -> IO World
runCommand (Command StateT World IO ()
cmd) World
w = ((), World) -> World
forall a b. (a, b) -> b
snd (((), World) -> World) -> IO ((), World) -> IO World
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT World IO () -> World -> IO ((), World)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT World IO ()
cmd World
w

runSchedule :: [[GraphNode IO]] -> World -> IO ([[GraphNode IO]], World)
runSchedule :: [[GraphNode IO]] -> World -> IO ([[GraphNode IO]], World)
runSchedule [[GraphNode IO]]
nodes World
w =
  ([GraphNode IO]
 -> ([[GraphNode IO]], World) -> IO ([[GraphNode IO]], World))
-> ([[GraphNode IO]], World)
-> [[GraphNode IO]]
-> IO ([[GraphNode IO]], World)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
    ( \[GraphNode IO]
nodeGroup ([[GraphNode IO]]
nodeAcc, World
w') -> do
        [((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)]
results <-
          (GraphNode IO
 -> IO
      ((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World))
-> [GraphNode IO]
-> IO
     [((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently
            ( \(GraphNode Node IO
n Set TypeRep
as Set TypeRep
bs) -> do
                (Node IO
n', Maybe (Access IO ())
next, [Command IO ()]
cmds, World
w'') <- Node IO
-> World
-> IO (Node IO, Maybe (Access IO ()), [Command IO ()], World)
runNode Node IO
n World
w
                ((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)
-> IO
     ((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (Access IO ())
next, (Node IO -> Set TypeRep -> Set TypeRep -> GraphNode IO
forall (m :: * -> *).
Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
GraphNode Node IO
n' Set TypeRep
as Set TypeRep
bs)), [Command IO ()]
cmds, World
w'')
            )
            [GraphNode IO]
nodeGroup
        let ([(Maybe (Access IO ()), GraphNode IO)]
nexts, [[Command IO ()]]
cmdLists, [World]
worlds) =
              (((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)
 -> ([(Maybe (Access IO ()), GraphNode IO)], [[Command IO ()]],
     [World])
 -> ([(Maybe (Access IO ()), GraphNode IO)], [[Command IO ()]],
     [World]))
-> ([(Maybe (Access IO ()), GraphNode IO)], [[Command IO ()]],
    [World])
-> [((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)]
-> ([(Maybe (Access IO ()), GraphNode IO)], [[Command IO ()]],
    [World])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( \((Maybe (Access IO ()), GraphNode IO)
n, [Command IO ()]
b, World
c) ([(Maybe (Access IO ()), GraphNode IO)]
ns, [[Command IO ()]]
bs, [World]
cs) ->
                    ((Maybe (Access IO ()), GraphNode IO)
n (Maybe (Access IO ()), GraphNode IO)
-> [(Maybe (Access IO ()), GraphNode IO)]
-> [(Maybe (Access IO ()), GraphNode IO)]
forall a. a -> [a] -> [a]
: [(Maybe (Access IO ()), GraphNode IO)]
ns, [Command IO ()]
b [Command IO ()] -> [[Command IO ()]] -> [[Command IO ()]]
forall a. a -> [a] -> [a]
: [[Command IO ()]]
bs, World
c World -> [World] -> [World]
forall a. a -> [a] -> [a]
: [World]
cs)
                )
                ([], [], [])
                [((Maybe (Access IO ()), GraphNode IO), [Command IO ()], World)]
results
            finalWorld :: World
finalWorld = (World -> World -> World) -> World -> [World] -> World
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr World -> World -> World
union World
w' [World]
worlds
            ([Command IO ()]
cmds, World
w'') = ([[Command IO ()]] -> [Command IO ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Command IO ()]]
cmdLists, World
finalWorld)

        (World
w''', [GraphNode IO]
nodes', [Command IO ()]
cmds') <-
          ((Maybe (Access IO ()), GraphNode IO)
 -> (World, [GraphNode IO], [Command IO ()])
 -> IO (World, [GraphNode IO], [Command IO ()]))
-> (World, [GraphNode IO], [Command IO ()])
-> [(Maybe (Access IO ()), GraphNode IO)]
-> IO (World, [GraphNode IO], [Command IO ()])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
            ( \(Maybe (Access IO ())
a, (GraphNode (Node Proxy a
p Cache
cache) Set TypeRep
as Set TypeRep
bs)) (World
wAcc, [GraphNode IO]
nodeAcc', [Command IO ()]
cmdAcc) -> case Maybe (Access IO ())
a of
                Just Access IO ()
a' -> do
                  ((), World
wAcc', Cache
cache', [Command IO ()]
cmdAcc') <- Access IO ()
-> World -> Cache -> IO ((), World, Cache, [Command IO ()])
forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' Access IO ()
a' World
wAcc Cache
cache
                  (World, [GraphNode IO], [Command IO ()])
-> IO (World, [GraphNode IO], [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (World
wAcc', (Node IO -> Set TypeRep -> Set TypeRep -> GraphNode IO
forall (m :: * -> *).
Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
GraphNode (Proxy a -> Cache -> Node IO
forall (m :: * -> *) a. System m a => Proxy a -> Cache -> Node m
Node Proxy a
p Cache
cache') Set TypeRep
as Set TypeRep
bs) GraphNode IO -> [GraphNode IO] -> [GraphNode IO]
forall a. a -> [a] -> [a]
: [GraphNode IO]
nodeAcc', [Command IO ()]
cmdAcc' [Command IO ()] -> [Command IO ()] -> [Command IO ()]
forall a. [a] -> [a] -> [a]
++ [Command IO ()]
cmdAcc)
                Maybe (Access IO ())
Nothing -> (World, [GraphNode IO], [Command IO ()])
-> IO (World, [GraphNode IO], [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (World
w, (Node IO -> Set TypeRep -> Set TypeRep -> GraphNode IO
forall (m :: * -> *).
Node m -> Set TypeRep -> Set TypeRep -> GraphNode m
GraphNode (Proxy a -> Cache -> Node IO
forall (m :: * -> *) a. System m a => Proxy a -> Cache -> Node m
Node Proxy a
p Cache
cache) Set TypeRep
as Set TypeRep
bs) GraphNode IO -> [GraphNode IO] -> [GraphNode IO]
forall a. a -> [a] -> [a]
: [GraphNode IO]
nodeAcc', [Command IO ()]
cmdAcc)
            )
            (World
w'', [], [])
            [(Maybe (Access IO ()), GraphNode IO)]
nexts

        World
w'''' <- (Command IO () -> World -> IO World)
-> World -> [Command IO ()] -> IO World
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\Command IO ()
cmd World
wAcc -> Command IO () -> World -> IO World
runCommand Command IO ()
cmd World
wAcc) World
w''' ([Command IO ()]
cmds [Command IO ()] -> [Command IO ()] -> [Command IO ()]
forall a. [a] -> [a] -> [a]
++ [Command IO ()]
cmds')
        ([[GraphNode IO]], World) -> IO ([[GraphNode IO]], World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GraphNode IO]
nodes' [GraphNode IO] -> [[GraphNode IO]] -> [[GraphNode IO]]
forall a. a -> [a] -> [a]
: [[GraphNode IO]]
nodeAcc, World
w'''')
    )
    ([], World
w)
    [[GraphNode IO]]
nodes

newtype Scheduler m = Scheduler (Map TypeRep (Schedule m))
  deriving (Semigroup (Scheduler m)
Scheduler m
Semigroup (Scheduler m) =>
Scheduler m
-> (Scheduler m -> Scheduler m -> Scheduler m)
-> ([Scheduler m] -> Scheduler m)
-> Monoid (Scheduler m)
[Scheduler m] -> Scheduler m
Scheduler m -> Scheduler m -> Scheduler m
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (m :: * -> *). Semigroup (Scheduler m)
forall (m :: * -> *). Scheduler m
forall (m :: * -> *). [Scheduler m] -> Scheduler m
forall (m :: * -> *). Scheduler m -> Scheduler m -> Scheduler m
$cmempty :: forall (m :: * -> *). Scheduler m
mempty :: Scheduler m
$cmappend :: forall (m :: * -> *). Scheduler m -> Scheduler m -> Scheduler m
mappend :: Scheduler m -> Scheduler m -> Scheduler m
$cmconcat :: forall (m :: * -> *). [Scheduler m] -> Scheduler m
mconcat :: [Scheduler m] -> Scheduler m
Monoid)

instance Semigroup (Scheduler m) where
  Scheduler Map TypeRep (Schedule m)
a <> :: Scheduler m -> Scheduler m -> Scheduler m
<> Scheduler Map TypeRep (Schedule m)
b = Map TypeRep (Schedule m) -> Scheduler m
forall (m :: * -> *). Map TypeRep (Schedule m) -> Scheduler m
Scheduler (Map TypeRep (Schedule m) -> Scheduler m)
-> Map TypeRep (Schedule m) -> Scheduler m
forall a b. (a -> b) -> a -> b
$ (Schedule m -> Schedule m -> Schedule m)
-> Map TypeRep (Schedule m)
-> Map TypeRep (Schedule m)
-> Map TypeRep (Schedule m)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Schedule m -> Schedule m -> Schedule m
forall a. Semigroup a => a -> a -> a
(<>) Map TypeRep (Schedule m)
a Map TypeRep (Schedule m)
b

data Startup

data Update

schedule :: forall l m s. (Typeable l, System m s) => [Constraint] -> Scheduler m
schedule :: forall l (m :: * -> *) s.
(Typeable l, System m s) =>
[Constraint] -> Scheduler m
schedule [Constraint]
cs =
  Map TypeRep (Schedule m) -> Scheduler m
forall (m :: * -> *). Map TypeRep (Schedule m) -> Scheduler m
Scheduler (Map TypeRep (Schedule m) -> Scheduler m)
-> Map TypeRep (Schedule m) -> Scheduler m
forall a b. (a -> b) -> a -> b
$
    TypeRep -> Schedule m -> Map TypeRep (Schedule m)
forall k a. k -> a -> Map k a
Map.singleton
      (Proxy l -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l))
      ( Map TypeRep (ScheduleNode m) -> Schedule m
forall (m :: * -> *). Map TypeRep (ScheduleNode m) -> Schedule m
Schedule (Map TypeRep (ScheduleNode m) -> Schedule m)
-> Map TypeRep (ScheduleNode m) -> Schedule m
forall a b. (a -> b) -> a -> b
$
          TypeRep -> ScheduleNode m -> Map TypeRep (ScheduleNode m)
forall k a. k -> a -> Map k a
Map.singleton
            (Proxy s -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s))
            (Node m -> [Constraint] -> ScheduleNode m
forall (m :: * -> *). Node m -> [Constraint] -> ScheduleNode m
ScheduleNode (Proxy s -> Cache -> Node m
forall (m :: * -> *) a. System m a => Proxy a -> Cache -> Node m
Node (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s) Cache
forall a. Monoid a => a
mempty) [Constraint]
cs)
      )

newtype SchedulerGraph m = SchedulerGraph (Map TypeRep [[GraphNode m]])

buildScheduler :: (Monad m) => Scheduler m -> SchedulerGraph m
buildScheduler :: forall (m :: * -> *). Monad m => Scheduler m -> SchedulerGraph m
buildScheduler (Scheduler Map TypeRep (Schedule m)
s) = Map TypeRep [[GraphNode m]] -> SchedulerGraph m
forall (m :: * -> *).
Map TypeRep [[GraphNode m]] -> SchedulerGraph m
SchedulerGraph (Map TypeRep [[GraphNode m]] -> SchedulerGraph m)
-> Map TypeRep [[GraphNode m]] -> SchedulerGraph m
forall a b. (a -> b) -> a -> b
$ (Schedule m -> [[GraphNode m]])
-> Map TypeRep (Schedule m) -> Map TypeRep [[GraphNode m]]
forall a b. (a -> b) -> Map TypeRep a -> Map TypeRep b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schedule m -> [[GraphNode m]]
forall (m :: * -> *). Monad m => Schedule m -> [[GraphNode m]]
build Map TypeRep (Schedule m)
s

runSchedulerGraph :: forall l. (Typeable l) => SchedulerGraph IO -> World -> IO (SchedulerGraph IO, World)
runSchedulerGraph :: forall l.
Typeable l =>
SchedulerGraph IO -> World -> IO (SchedulerGraph IO, World)
runSchedulerGraph (SchedulerGraph Map TypeRep [[GraphNode IO]]
g) World
w = case TypeRep -> Map TypeRep [[GraphNode IO]] -> Maybe [[GraphNode IO]]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Proxy l -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l)) Map TypeRep [[GraphNode IO]]
g of
  Just [[GraphNode IO]]
s -> do
    ([[GraphNode IO]]
nodes, World
w') <- [[GraphNode IO]] -> World -> IO ([[GraphNode IO]], World)
runSchedule [[GraphNode IO]]
s World
w
    let g' :: Map TypeRep [[GraphNode IO]]
g' = TypeRep
-> [[GraphNode IO]]
-> Map TypeRep [[GraphNode IO]]
-> Map TypeRep [[GraphNode IO]]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Proxy l -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l)) [[GraphNode IO]]
nodes Map TypeRep [[GraphNode IO]]
g
    (SchedulerGraph IO, World) -> IO (SchedulerGraph IO, World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map TypeRep [[GraphNode IO]] -> SchedulerGraph IO
forall (m :: * -> *).
Map TypeRep [[GraphNode m]] -> SchedulerGraph m
SchedulerGraph Map TypeRep [[GraphNode IO]]
g', World
w')
  Maybe [[GraphNode IO]]
Nothing -> (SchedulerGraph IO, World) -> IO (SchedulerGraph IO, World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map TypeRep [[GraphNode IO]] -> SchedulerGraph IO
forall (m :: * -> *).
Map TypeRep [[GraphNode m]] -> SchedulerGraph m
SchedulerGraph Map TypeRep [[GraphNode IO]]
g, World
w)

runScheduler :: Scheduler IO -> IO ()
runScheduler :: Scheduler IO -> IO ()
runScheduler Scheduler IO
s = do
  let g :: SchedulerGraph IO
g = Scheduler IO -> SchedulerGraph IO
forall (m :: * -> *). Monad m => Scheduler m -> SchedulerGraph m
buildScheduler Scheduler IO
s
  (SchedulerGraph IO
g', World
w) <- forall l.
Typeable l =>
SchedulerGraph IO -> World -> IO (SchedulerGraph IO, World)
runSchedulerGraph @Startup SchedulerGraph IO
g World
newWorld
  let go :: SchedulerGraph IO -> World -> IO b
go SchedulerGraph IO
gAcc World
wAcc = do
        (SchedulerGraph IO
gAcc', World
wAcc') <- forall l.
Typeable l =>
SchedulerGraph IO -> World -> IO (SchedulerGraph IO, World)
runSchedulerGraph @Update SchedulerGraph IO
gAcc World
wAcc
        SchedulerGraph IO -> World -> IO b
go SchedulerGraph IO
gAcc' World
wAcc'
  SchedulerGraph IO -> World -> IO ()
forall {b}. SchedulerGraph IO -> World -> IO b
go SchedulerGraph IO
g' World
w