module Mischief.Assets.Internal.Watcher where

import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, modifyTVar')
import Control.Monad (forever, void)
import Control.Monad.IO.Class
import Data.Data
import Data.Foldable
import Data.HashTable.IO qualified as H
import Data.Text qualified as T
import Mischief.Assets.Internal.Asset
import Mischief.Assets.Internal.Path
import Mischief.ECS
import Mischief.ECS.Utils (fromMaybeM)
import Mischief.ECS.World
import Path (Path)
import Path qualified
import System.Directory
import System.FSNotify

-- | Listens to changes in your asset folder and reloads assets when they have been changed.
--
-- On Windows running with @-fthreaded@ might be required.
data FileWatcherPlugin

instance Plugin FileWatcherPlugin where
  init :: System ()
init = do
    System () -> SystemConfig
forall a. ToSystems a => a -> SystemConfig
systems System ()
managerSystem SystemConfig -> (SystemConfig -> System ()) -> System ()
forall a b. a -> (a -> b) -> b
& forall sc. Schedule sc => SystemConfig -> System ()
forall {k} (sc :: k). Schedule sc => SystemConfig -> System ()
schedule @Startup
    System Entity -> System ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (System Entity -> System ()) -> System Entity -> System ()
forall a b. (a -> b) -> a -> b
$ Observer OnFileAdded -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn (Observer OnFileAdded -> System Entity)
-> Observer OnFileAdded -> System Entity
forall a b. (a -> b) -> a -> b
$ (OnFileAdded -> System ()) -> Observer OnFileAdded
forall e. (e -> System ()) -> Observer e
Observer OnFileAdded -> System ()
onFileAdd
    System Entity -> System ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (System Entity -> System ()) -> System Entity -> System ()
forall a b. (a -> b) -> a -> b
$ Observer OnFileModified -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn (Observer OnFileModified -> System Entity)
-> Observer OnFileModified -> System Entity
forall a b. (a -> b) -> a -> b
$ (OnFileModified -> System ()) -> Observer OnFileModified
forall e. (e -> System ()) -> Observer e
Observer OnFileModified -> System ()
onFileModified

managerSystem :: System ()
managerSystem :: System ()
managerSystem = do
  (AssetSource source) <- System AssetSource -> Maybe AssetSource -> System AssetSource
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
fromMaybeM System AssetSource
forall w (m :: * -> *). MonadSystem w m => m AssetSource
defAbsAssetSource (Maybe AssetSource -> System AssetSource)
-> System (Maybe AssetSource) -> System AssetSource
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @AssetSource
  dir <- liftIO $ makeAbsolute $ Path.toFilePath source
  dir <- Path.parseAbsDir dir
  world <- unsafeGetWorld
  void $ liftIO $ forkIO $ do
    withManager $ watcher world dir

watcher :: World -> Path Path.Abs Path.Dir -> WatchManager -> IO ()
watcher :: World -> Path Abs Dir -> WatchManager -> IO ()
watcher World
world Path Abs Dir
dir WatchManager
mgr = do
  IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchTree WatchManager
mgr (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
Path.toFilePath Path Abs Dir
dir) (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) (World -> Action
action World
world)
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000000000000

action :: World -> System.FSNotify.Event -> IO ()
action :: World -> Action
action World
world (System.FSNotify.Added FilePath
path UTCTime
_ EventIsDirectory
IsFile) = do
  file <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
Path.parseAbsFile FilePath
path
  triggerEvent world (OnFileAdded file)
action World
world (System.FSNotify.Modified FilePath
path UTCTime
_ EventIsDirectory
IsFile) = do
  file <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
Path.parseAbsFile FilePath
path
  triggerEvent world (OnFileModified file)
action World
world (System.FSNotify.Removed FilePath
path UTCTime
_ EventIsDirectory
IsFile) = do
  file <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
Path.parseAbsFile FilePath
path
  triggerEvent world (OnFileRemoved file)
action World
_ Event
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

triggerEvent :: (Mischief.ECS.Event e) => World -> e -> IO ()
triggerEvent :: forall e. Event e => World -> e -> IO ()
triggerEvent World {TVar [System ()]
deferredAsync :: TVar [System ()]
deferredAsync :: World -> TVar [System ()]
deferredAsync} e
m = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  TVar [System ()] -> ([System ()] -> [System ()]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [System ()]
deferredAsync ([System ()] -> [System ()] -> [System ()]
forall a. [a] -> [a] -> [a]
++ [e -> System ()
forall e. Event e => e -> System ()
trigger e
m])

newtype OnFileAdded = OnFileAdded (Path Path.Abs Path.File) deriving anyclass (Typeable OnFileAdded
Typeable OnFileAdded =>
(OnFileAdded -> ErasedEvent) -> Event OnFileAdded
OnFileAdded -> ErasedEvent
forall e. Typeable e => (e -> ErasedEvent) -> Event e
$ceraseEvent :: OnFileAdded -> ErasedEvent
eraseEvent :: OnFileAdded -> ErasedEvent
Mischief.ECS.Event)

newtype OnFileModified = OnFileModified (Path Path.Abs Path.File) deriving anyclass (Typeable OnFileModified
Typeable OnFileModified =>
(OnFileModified -> ErasedEvent) -> Event OnFileModified
OnFileModified -> ErasedEvent
forall e. Typeable e => (e -> ErasedEvent) -> Event e
$ceraseEvent :: OnFileModified -> ErasedEvent
eraseEvent :: OnFileModified -> ErasedEvent
Mischief.ECS.Event)

newtype OnFileRemoved = OnFileRemoved (Path Path.Abs Path.File) deriving anyclass (Typeable OnFileRemoved
Typeable OnFileRemoved =>
(OnFileRemoved -> ErasedEvent) -> Event OnFileRemoved
OnFileRemoved -> ErasedEvent
forall e. Typeable e => (e -> ErasedEvent) -> Event e
$ceraseEvent :: OnFileRemoved -> ErasedEvent
eraseEvent :: OnFileRemoved -> ErasedEvent
Mischief.ECS.Event)

onFileAdd :: OnFileAdded -> System ()
onFileAdd :: OnFileAdded -> System ()
onFileAdd (OnFileAdded Path Abs File
path) = Path Abs File -> System ()
triggerReload Path Abs File
path

onFileModified :: OnFileModified -> System ()
onFileModified :: OnFileModified -> System ()
onFileModified (OnFileModified Path Abs File
path) = Path Abs File -> System ()
triggerReload Path Abs File
path

triggerReload :: Path Path.Abs Path.File -> System ()
triggerReload :: Path Abs File -> System ()
triggerReload Path Abs File
path = do
  AssetSource s <- System AssetSource -> Maybe AssetSource -> System AssetSource
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
fromMaybeM System AssetSource
forall w (m :: * -> *). MonadSystem w m => m AssetSource
defAbsAssetSource (Maybe AssetSource -> System AssetSource)
-> System (Maybe AssetSource) -> System AssetSource
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @AssetSource
  rel <- Path.stripProperPrefix s path

  typeRegistry <- res @AssetTypeRegistry
  case typeRegistry of
    Maybe AssetTypeRegistry
Nothing -> () -> System ()
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (AssetTypeRegistry HashMap (Path Abs File) (Set AssetType)
typeRegistry) -> do
      types <- IO (Maybe (Set AssetType)) -> System (Maybe (Set AssetType))
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Set AssetType)) -> System (Maybe (Set AssetType)))
-> IO (Maybe (Set AssetType)) -> System (Maybe (Set AssetType))
forall a b. (a -> b) -> a -> b
$ HashMap (Path Abs File) (Set AssetType)
-> Path Abs File -> IO (Maybe (Set AssetType))
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashMap (Path Abs File) (Set AssetType)
typeRegistry Path Abs File
path
      case types of
        Maybe (Set AssetType)
Nothing -> () -> System ()
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Set AssetType
types -> do
          Set AssetType -> (AssetType -> System Entity) -> System ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set AssetType
types ((AssetType -> System Entity) -> System ())
-> (AssetType -> System Entity) -> System ()
forall a b. (a -> b) -> a -> b
$ \(AssetType (Proxy a
_ :: Proxy a)) -> do
            forall a.
(Asset a, Bundle a) =>
Path Abs File -> Text -> System Entity
reloadByAbsPath @a Path Abs File
path (Text -> System Entity) -> Text -> System Entity
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
Path.toFilePath Path Rel File
rel)