module Mischief.ECS.World.Defer where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Foldable
import Data.Functor
import Data.IORef
import Mischief.ECS.Hidden
import Mischief.ECS.World

-- class Defer s where
--   -- | Defer a command to be ran after the current 'System' is finished,
--   -- or when 'flush' is called.
--   defer :: System a -> s

-- instance Defer (System ()) where
--   defer :: System a -> System ()
--   defer !system = do
--     world <- ask
--     liftIO $ modifyIORef' world.deferred (++ [system $> ()])

-- instance Defer (ParSystem ()) where
--   defer :: System a -> ParSystem ()
--   defer !system = do
--     ParWorld {deferred} <- ask
--     liftIO $ modifyIORef' deferred (++ [system $> ()])

class Defer m where
  defer :: System a -> m ()

instance Defer System where
  defer :: System a -> System ()
  defer :: forall a. System a -> System ()
defer !System a
s = do
    world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
    liftIO $ modifyIORef' world.deferred (++ [s $> ()])

instance Defer ParSystem where
  defer :: System a -> ParSystem ()
  defer :: forall a. System a -> ParSystem ()
defer !System a
s = do
    ParWorld {parDeferred} <- ParSystem ParWorld
forall r (m :: * -> *). MonadReader r m => m r
ask
    liftIO $ modifyIORef' parDeferred (++ [s $> ()])

-- | Flush the current list of deferred commands.
flush :: System ()
flush :: System ()
flush = do
  world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  systems <- liftIO $ readIORef world.deferred

  for_ systems $ \System ()
s -> do
    System () -> System ()
forall a. System a -> System a
forkDefer (System () -> System ()) -> System () -> System ()
forall a b. (a -> b) -> a -> b
$ do
      System ()
s
      System ()
flush

  liftIO $ writeIORef world.deferred []

flushAsync :: System ()
flushAsync :: System ()
flushAsync = do
  world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld

  systems <- liftIO $ atomically $ do
    systems <- readTVar world.deferredAsync
    writeTVar world.deferredAsync []
    return systems

  for_ systems $ \System ()
s -> do
    System () -> System ()
forall a. System a -> System a
forkDefer (System () -> System ()) -> System () -> System ()
forall a b. (a -> b) -> a -> b
$ do
      System ()
s
      System ()
flush

forkDefer :: System a -> System a
forkDefer :: forall a. System a -> System a
forkDefer System a
s = do
  world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  deferred <- liftIO $ newIORef []

  let world' = IORef [System ()] -> World -> World
setDeferred IORef [System ()]
deferred World
world
  a <- liftIO $ runSystem s world'

  deferred <- liftIO $ readIORef deferred
  liftIO $ modifyIORef' world.deferred (++ deferred)
  return a

-- let world' =

-- forkSystem :: ParSystem () -> System ()
-- forkSystem (ParSystem !x) = do
--   world <- ask
--   _ <- liftIO $ forkIO $ do
--     deferred <- newIORef []
--     runReaderT x ParWorld {world, deferred}
--     deferred' <- readIORef deferred

--     atomically $ modifyTVar' world.deferredAsync (++ deferred')

--   return ()

runAfter :: (MonadSystem w m) => IO a -> (a -> System ()) -> m ()
runAfter :: forall w (m :: * -> *) a.
MonadSystem w m =>
IO a -> (a -> System ()) -> m ()
runAfter !IO a
function !a -> System ()
system = do
  world <- m World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  _ <- liftIO $ forkIO $ do
    a <- function
    atomically $ modifyTVar' world.deferredAsync (++ [system a])

  return ()

delay :: (MonadSystem w m) => Int -> System () -> m ()
delay :: forall w (m :: * -> *). MonadSystem w m => Int -> System () -> m ()
delay !Int
d System ()
system = IO () -> (() -> System ()) -> m ()
forall w (m :: * -> *) a.
MonadSystem w m =>
IO a -> (a -> System ()) -> m ()
runAfter (Int -> IO ()
threadDelay Int
d) (System () -> () -> System ()
forall a b. a -> b -> a
const System ()
system)