{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Aztecs.Asset.AssetServer
  ( AssetId (..),
    AssetServer (..),
    assetServer,
    Handle (..),
    setup,
    loadAssets,
    lookupAsset,
  )
where

import Aztecs.ECS
import qualified Aztecs.ECS.Access as A
import qualified Aztecs.ECS.Query as Q
import qualified Aztecs.ECS.System as S
import Control.Arrow (returnA)
import Control.DeepSeq
import Control.Monad.IO.Class (MonadIO (..))
import Data.Data (Typeable)
import Data.Foldable (foldrM)
import Data.IORef (IORef, readIORef)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import GHC.Generics (Generic)

newtype AssetId = AssetId {AssetId -> Int
unAssetId :: Int}
  deriving (AssetId -> AssetId -> Bool
(AssetId -> AssetId -> Bool)
-> (AssetId -> AssetId -> Bool) -> Eq AssetId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AssetId -> AssetId -> Bool
== :: AssetId -> AssetId -> Bool
$c/= :: AssetId -> AssetId -> Bool
/= :: AssetId -> AssetId -> Bool
Eq, Eq AssetId
Eq AssetId =>
(AssetId -> AssetId -> Ordering)
-> (AssetId -> AssetId -> Bool)
-> (AssetId -> AssetId -> Bool)
-> (AssetId -> AssetId -> Bool)
-> (AssetId -> AssetId -> Bool)
-> (AssetId -> AssetId -> AssetId)
-> (AssetId -> AssetId -> AssetId)
-> Ord AssetId
AssetId -> AssetId -> Bool
AssetId -> AssetId -> Ordering
AssetId -> AssetId -> AssetId
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 :: AssetId -> AssetId -> Ordering
compare :: AssetId -> AssetId -> Ordering
$c< :: AssetId -> AssetId -> Bool
< :: AssetId -> AssetId -> Bool
$c<= :: AssetId -> AssetId -> Bool
<= :: AssetId -> AssetId -> Bool
$c> :: AssetId -> AssetId -> Bool
> :: AssetId -> AssetId -> Bool
$c>= :: AssetId -> AssetId -> Bool
>= :: AssetId -> AssetId -> Bool
$cmax :: AssetId -> AssetId -> AssetId
max :: AssetId -> AssetId -> AssetId
$cmin :: AssetId -> AssetId -> AssetId
min :: AssetId -> AssetId -> AssetId
Ord, Int -> AssetId -> ShowS
[AssetId] -> ShowS
AssetId -> String
(Int -> AssetId -> ShowS)
-> (AssetId -> String) -> ([AssetId] -> ShowS) -> Show AssetId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AssetId -> ShowS
showsPrec :: Int -> AssetId -> ShowS
$cshow :: AssetId -> String
show :: AssetId -> String
$cshowList :: [AssetId] -> ShowS
showList :: [AssetId] -> ShowS
Show)

data AssetServer a = AssetServer
  { forall a. AssetServer a -> Map AssetId a
assetServerAssets :: !(Map AssetId a),
    forall a.
AssetServer a
-> Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
loadingAssets :: !(Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))),
    forall a. AssetServer a -> AssetId
nextAssetId :: !AssetId
  }
  deriving ((forall x. AssetServer a -> Rep (AssetServer a) x)
-> (forall x. Rep (AssetServer a) x -> AssetServer a)
-> Generic (AssetServer a)
forall x. Rep (AssetServer a) x -> AssetServer a
forall x. AssetServer a -> Rep (AssetServer a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (AssetServer a) x -> AssetServer a
forall a x. AssetServer a -> Rep (AssetServer a) x
$cfrom :: forall a x. AssetServer a -> Rep (AssetServer a) x
from :: forall x. AssetServer a -> Rep (AssetServer a) x
$cto :: forall a x. Rep (AssetServer a) x -> AssetServer a
to :: forall x. Rep (AssetServer a) x -> AssetServer a
Generic)

instance (Typeable a) => Component (AssetServer a)

instance NFData (AssetServer a) where
  rnf :: AssetServer a -> ()
rnf = AssetServer a -> ()
forall a. a -> ()
rwhnf

assetServer :: AssetServer a
assetServer :: forall a. AssetServer a
assetServer =
  AssetServer
    { assetServerAssets :: Map AssetId a
assetServerAssets = Map AssetId a
forall k a. Map k a
Map.empty,
      loadingAssets :: Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
loadingAssets = Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
forall k a. Map k a
Map.empty,
      nextAssetId :: AssetId
nextAssetId = Int -> AssetId
AssetId Int
0
    }

newtype Handle a = Handle {forall a. Handle a -> AssetId
handleId :: AssetId}
  deriving (Handle a -> Handle a -> Bool
(Handle a -> Handle a -> Bool)
-> (Handle a -> Handle a -> Bool) -> Eq (Handle a)
forall a. Handle a -> Handle a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Handle a -> Handle a -> Bool
== :: Handle a -> Handle a -> Bool
$c/= :: forall a. Handle a -> Handle a -> Bool
/= :: Handle a -> Handle a -> Bool
Eq, Eq (Handle a)
Eq (Handle a) =>
(Handle a -> Handle a -> Ordering)
-> (Handle a -> Handle a -> Bool)
-> (Handle a -> Handle a -> Bool)
-> (Handle a -> Handle a -> Bool)
-> (Handle a -> Handle a -> Bool)
-> (Handle a -> Handle a -> Handle a)
-> (Handle a -> Handle a -> Handle a)
-> Ord (Handle a)
Handle a -> Handle a -> Bool
Handle a -> Handle a -> Ordering
Handle a -> Handle a -> Handle a
forall a. Eq (Handle a)
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
forall a. Handle a -> Handle a -> Bool
forall a. Handle a -> Handle a -> Ordering
forall a. Handle a -> Handle a -> Handle a
$ccompare :: forall a. Handle a -> Handle a -> Ordering
compare :: Handle a -> Handle a -> Ordering
$c< :: forall a. Handle a -> Handle a -> Bool
< :: Handle a -> Handle a -> Bool
$c<= :: forall a. Handle a -> Handle a -> Bool
<= :: Handle a -> Handle a -> Bool
$c> :: forall a. Handle a -> Handle a -> Bool
> :: Handle a -> Handle a -> Bool
$c>= :: forall a. Handle a -> Handle a -> Bool
>= :: Handle a -> Handle a -> Bool
$cmax :: forall a. Handle a -> Handle a -> Handle a
max :: Handle a -> Handle a -> Handle a
$cmin :: forall a. Handle a -> Handle a -> Handle a
min :: Handle a -> Handle a -> Handle a
Ord, Int -> Handle a -> ShowS
[Handle a] -> ShowS
Handle a -> String
(Int -> Handle a -> ShowS)
-> (Handle a -> String) -> ([Handle a] -> ShowS) -> Show (Handle a)
forall a. Int -> Handle a -> ShowS
forall a. [Handle a] -> ShowS
forall a. Handle a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Handle a -> ShowS
showsPrec :: Int -> Handle a -> ShowS
$cshow :: forall a. Handle a -> String
show :: Handle a -> String
$cshowList :: forall a. [Handle a] -> ShowS
showList :: [Handle a] -> ShowS
Show)

instance NFData (Handle a) where
  rnf :: Handle a -> ()
rnf = Handle a -> ()
forall a. a -> ()
rwhnf

lookupAsset :: Handle a -> AssetServer a -> Maybe a
lookupAsset :: forall a. Handle a -> AssetServer a -> Maybe a
lookupAsset Handle a
h AssetServer a
server = AssetId -> Map AssetId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Handle a -> AssetId
forall a. Handle a -> AssetId
handleId Handle a
h) (AssetServer a -> Map AssetId a
forall a. AssetServer a -> Map AssetId a
assetServerAssets AssetServer a
server)

loadAssets ::
  forall a qr rs q s b m arr.
  ( Typeable a,
    ArrowQueryReader qr,
    ArrowReaderSystem qr rs,
    ArrowReaderSchedule rs arr,
    ArrowQuery q,
    ArrowSystem q s,
    ArrowSchedule s arr,
    MonadIO m,
    ArrowAccessSchedule b m arr
  ) =>
  arr () ()
loadAssets :: forall a (qr :: * -> * -> *) (rs :: * -> * -> *) (q :: * -> * -> *)
       (s :: * -> * -> *) b (m :: * -> *) (arr :: * -> * -> *).
(Typeable a, ArrowQueryReader qr, ArrowReaderSystem qr rs,
 ArrowReaderSchedule rs arr, ArrowQuery q, ArrowSystem q s,
 ArrowSchedule s arr, MonadIO m, ArrowAccessSchedule b m arr) =>
arr () ()
loadAssets = proc () -> do
  AssetServer a
server <- rs () (AssetServer a) -> arr () (AssetServer a)
forall i o. rs i o -> arr i o
forall (s :: * -> * -> *) (arr :: * -> * -> *) i o.
ArrowReaderSchedule s arr =>
s i o -> arr i o
reader (rs () (AssetServer a) -> arr () (AssetServer a))
-> rs () (AssetServer a) -> arr () (AssetServer a)
forall a b. (a -> b) -> a -> b
$ qr () (AssetServer a) -> rs () (AssetServer a)
forall i a. qr i a -> rs i a
forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
ArrowReaderSystem q arr =>
q i a -> arr i a
S.single (forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () a
Q.fetch @_ @(AssetServer a)) -< ()
  AssetServer a
server' <-
    (AssetServer a -> m (AssetServer a))
-> arr (AssetServer a) (AssetServer a)
forall i o. (i -> m o) -> arr i o
forall b (m :: * -> *) (arr :: * -> * -> *) i o.
ArrowAccessSchedule b m arr =>
(i -> m o) -> arr i o
access
      ( \AssetServer a
server ->
          IO (AssetServer a) -> m (AssetServer a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AssetServer a) -> m (AssetServer a))
-> IO (AssetServer a) -> m (AssetServer a)
forall a b. (a -> b) -> a -> b
$
            ((AssetId, Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
 -> AssetServer a -> IO (AssetServer a))
-> AssetServer a
-> [(AssetId, Either (IO (IORef (Maybe a))) (IORef (Maybe a)))]
-> IO (AssetServer a)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
              ( \(AssetId
aId, Either (IO (IORef (Maybe a))) (IORef (Maybe a))
v) AssetServer a
acc -> do
                  case Either (IO (IORef (Maybe a))) (IORef (Maybe a))
v of
                    Right IORef (Maybe a)
r -> do
                      Maybe a
maybeSurface <- IORef (Maybe a) -> IO (Maybe a)
forall a. IORef a -> IO a
readIORef IORef (Maybe a)
r
                      case Maybe a
maybeSurface of
                        Just a
surface ->
                          AssetServer a -> IO (AssetServer a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                            AssetServer a
acc
                              { assetServerAssets = Map.insert aId surface (assetServerAssets acc),
                                loadingAssets = Map.delete aId (loadingAssets acc)
                              }
                        Maybe a
Nothing -> AssetServer a -> IO (AssetServer a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AssetServer a
acc
                    Left IO (IORef (Maybe a))
f -> do
                      IORef (Maybe a)
v' <- IO (IORef (Maybe a))
f
                      AssetServer a -> IO (AssetServer a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AssetServer a -> IO (AssetServer a))
-> AssetServer a -> IO (AssetServer a)
forall a b. (a -> b) -> a -> b
$ AssetServer a
acc {loadingAssets = Map.insert aId (Right v') (loadingAssets server)}
              )
              AssetServer a
server
              (Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
-> [(AssetId, Either (IO (IORef (Maybe a))) (IORef (Maybe a)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
 -> [(AssetId, Either (IO (IORef (Maybe a))) (IORef (Maybe a)))])
-> Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
-> [(AssetId, Either (IO (IORef (Maybe a))) (IORef (Maybe a)))]
forall a b. (a -> b) -> a -> b
$ AssetServer a
-> Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
forall a.
AssetServer a
-> Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))
loadingAssets AssetServer a
server)
      )
      -<
        AssetServer a
server
  s (AssetServer a) (AssetServer a)
-> arr (AssetServer a) (AssetServer a)
forall i o. s i o -> arr i o
forall (s :: * -> * -> *) (arr :: * -> * -> *) i o.
ArrowSchedule s arr =>
s i o -> arr i o
system (s (AssetServer a) (AssetServer a)
 -> arr (AssetServer a) (AssetServer a))
-> s (AssetServer a) (AssetServer a)
-> arr (AssetServer a) (AssetServer a)
forall a b. (a -> b) -> a -> b
$ q (AssetServer a) (AssetServer a)
-> s (AssetServer a) (AssetServer a)
forall i a. q i a -> s i a
forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
ArrowSystem q arr =>
q i a -> arr i a
S.mapSingle q (AssetServer a) (AssetServer a)
forall a. Component a => q a a
forall (arr :: * -> * -> *) a.
(ArrowQuery arr, Component a) =>
arr a a
Q.set -< AssetServer a
server'
  arr () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()

setup :: forall a. (Typeable a) => System () ()
setup :: forall a. Typeable a => System () ()
setup = (() -> AccessT Identity ()) -> System () ()
forall i. (i -> AccessT Identity ()) -> SystemT Identity i ()
forall b (m :: * -> *) (arr :: * -> * -> *) i.
ArrowQueueSystem b m arr =>
(i -> m ()) -> arr i ()
S.queue ((() -> AccessT Identity ()) -> System () ())
-> (AssetServer a -> () -> AccessT Identity ())
-> AssetServer a
-> System () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessT Identity () -> () -> AccessT Identity ()
forall a b. a -> b -> a
const (AccessT Identity () -> () -> AccessT Identity ())
-> (AssetServer a -> AccessT Identity ())
-> AssetServer a
-> ()
-> AccessT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bundle -> AccessT Identity ()
forall b (m :: * -> *). MonadAccess b m => b -> m ()
A.spawn_ (Bundle -> AccessT Identity ())
-> (AssetServer a -> Bundle)
-> AssetServer a
-> AccessT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetServer a -> Bundle
forall c. Component c => c -> Bundle
forall a c. (MonoidBundle a, Component c) => c -> a
bundle (AssetServer a -> System () ()) -> AssetServer a -> System () ()
forall a b. (a -> b) -> a -> b
$ forall a. AssetServer a
assetServer @a