module Mischief.Render.Core where

import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString qualified as BS
import Data.Default (Default)
import Data.Maybe (isNothing)
import Data.Primitive (Ptr)
import Data.Primitive.Ptr (nullPtr)
import Foreign (Storable (peek, poke), alloca, castPtr, free, malloc, with)
import Foreign.C (peekCString)
import Foreign.C.ConstPtr
import Mischief.ECS
import Mischief.ECS.Events
import Mischief.ECS.Hooks
import Mischief.ECS.Systems qualified as Systems
import Mischief.Render.TextureFormat
import Mischief.SDL (SDLPlugin (..), SDLWindow (SDLWindow))
import Mischief.SDL.Window
import Mischief.WGPU
import Mischief.WGPU.Opaque
import Mischief.WGPU.Types.Enums
import Mischief.WGPU.Types.General
import SDL3.Sys qualified as SDL3
import SDL3.Sys.Bindgen.Metal.FunPtr qualified as SDL3

type CameraEntity = Entity

type MeshEntity = Entity

newtype RenderInstance = RenderInstance (Ptr WGPUInstance) deriving anyclass (Typeable RenderInstance
[HookRel RenderInstance]
[Hook RenderInstance]
Set DefaultComponentType
IsExclusive (IsExclusiveRel RenderInstance)
(Typeable RenderInstance,
 IsExclusive (IsExclusiveRel RenderInstance)) =>
Set DefaultComponentType
-> [Hook RenderInstance]
-> [Hook RenderInstance]
-> [Hook RenderInstance]
-> [HookRel RenderInstance]
-> [HookRel RenderInstance]
-> [HookRel RenderInstance]
-> Component RenderInstance
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook RenderInstance]
onAdd :: [Hook RenderInstance]
$conSet :: [Hook RenderInstance]
onSet :: [Hook RenderInstance]
$conRemove :: [Hook RenderInstance]
onRemove :: [Hook RenderInstance]
$conAddRel :: [HookRel RenderInstance]
onAddRel :: [HookRel RenderInstance]
$conSetRel :: [HookRel RenderInstance]
onSetRel :: [HookRel RenderInstance]
$conRemoveRel :: [HookRel RenderInstance]
onRemoveRel :: [HookRel RenderInstance]
Component)

newtype RenderSurface = RenderSurface (Ptr WGPUSurface)

newtype DefaultSampler = DefaultSampler Sampler deriving anyclass (Typeable DefaultSampler
[HookRel DefaultSampler]
[Hook DefaultSampler]
Set DefaultComponentType
IsExclusive (IsExclusiveRel DefaultSampler)
(Typeable DefaultSampler,
 IsExclusive (IsExclusiveRel DefaultSampler)) =>
Set DefaultComponentType
-> [Hook DefaultSampler]
-> [Hook DefaultSampler]
-> [Hook DefaultSampler]
-> [HookRel DefaultSampler]
-> [HookRel DefaultSampler]
-> [HookRel DefaultSampler]
-> Component DefaultSampler
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook DefaultSampler]
onAdd :: [Hook DefaultSampler]
$conSet :: [Hook DefaultSampler]
onSet :: [Hook DefaultSampler]
$conRemove :: [Hook DefaultSampler]
onRemove :: [Hook DefaultSampler]
$conAddRel :: [HookRel DefaultSampler]
onAddRel :: [HookRel DefaultSampler]
$conSetRel :: [HookRel DefaultSampler]
onSetRel :: [HookRel DefaultSampler]
$conRemoveRel :: [HookRel DefaultSampler]
onRemoveRel :: [HookRel DefaultSampler]
Component)

instance Component RenderSurface where
  onRemove :: [Hook RenderSurface]
onRemove =
    [ (HookContext -> System ()) -> Hook RenderSurface
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook ((HookContext -> System ()) -> Hook RenderSurface)
-> (HookContext -> System ()) -> Hook RenderSurface
forall a b. (a -> b) -> a -> b
$ \(HookContext Entity
entity) -> do
        Just (RenderSurface surface) <- Query System RenderSurface -> System (Maybe RenderSurface)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. RenderSurface|]
        liftIO $ wgpuSurfaceRelease surface
    ]

newtype RenderDevice = RenderDevice (Ptr WGPUDevice)

instance Component RenderDevice where
  onRemove :: [Hook RenderDevice]
onRemove =
    [ (HookContext -> System ()) -> Hook RenderDevice
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook ((HookContext -> System ()) -> Hook RenderDevice)
-> (HookContext -> System ()) -> Hook RenderDevice
forall a b. (a -> b) -> a -> b
$ \(HookContext Entity
entity) -> do
        Just (RenderDevice device) <- Query System RenderDevice -> System (Maybe RenderDevice)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. RenderDevice|]
        liftIO $ wgpuDeviceRelease device
    ]

newtype RenderAdapter = RenderAdapter (Ptr WGPUAdapter)

instance Component RenderAdapter where
  onRemove :: [Hook RenderAdapter]
onRemove =
    [ (HookContext -> System ()) -> Hook RenderAdapter
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook ((HookContext -> System ()) -> Hook RenderAdapter)
-> (HookContext -> System ()) -> Hook RenderAdapter
forall a b. (a -> b) -> a -> b
$ \(HookContext Entity
entity) -> do
        Just (RenderAdapter adapter) <- Query System RenderAdapter -> System (Maybe RenderAdapter)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. RenderAdapter|]
        liftIO $ wgpuAdapterRelease adapter
    ]

newtype RenderQueue = RenderQueue (Ptr WGPUQueue)

instance Component RenderQueue where
  onRemove :: [Hook RenderQueue]
onRemove =
    [ (HookContext -> System ()) -> Hook RenderQueue
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook ((HookContext -> System ()) -> Hook RenderQueue)
-> (HookContext -> System ()) -> Hook RenderQueue
forall a b. (a -> b) -> a -> b
$ \(HookContext Entity
entity) -> do
        Just (RenderQueue queue) <- Query System RenderQueue -> System (Maybe RenderQueue)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. RenderQueue|]
        liftIO $ wgpuQueueRelease queue
    ]

newtype WindowFormat = WindowFormat WGPUTextureFormat deriving anyclass (Typeable WindowFormat
[HookRel WindowFormat]
[Hook WindowFormat]
Set DefaultComponentType
IsExclusive (IsExclusiveRel WindowFormat)
(Typeable WindowFormat,
 IsExclusive (IsExclusiveRel WindowFormat)) =>
Set DefaultComponentType
-> [Hook WindowFormat]
-> [Hook WindowFormat]
-> [Hook WindowFormat]
-> [HookRel WindowFormat]
-> [HookRel WindowFormat]
-> [HookRel WindowFormat]
-> Component WindowFormat
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook WindowFormat]
onAdd :: [Hook WindowFormat]
$conSet :: [Hook WindowFormat]
onSet :: [Hook WindowFormat]
$conRemove :: [Hook WindowFormat]
onRemove :: [Hook WindowFormat]
$conAddRel :: [HookRel WindowFormat]
onAddRel :: [HookRel WindowFormat]
$conSetRel :: [HookRel WindowFormat]
onSetRel :: [HookRel WindowFormat]
$conRemoveRel :: [HookRel WindowFormat]
onRemoveRel :: [HookRel WindowFormat]
Component)

newtype WindowAlphaMode = WindowAlphaMode WGPUCompositeAlphaMode deriving anyclass (Typeable WindowAlphaMode
[HookRel WindowAlphaMode]
[Hook WindowAlphaMode]
Set DefaultComponentType
IsExclusive (IsExclusiveRel WindowAlphaMode)
(Typeable WindowAlphaMode,
 IsExclusive (IsExclusiveRel WindowAlphaMode)) =>
Set DefaultComponentType
-> [Hook WindowAlphaMode]
-> [Hook WindowAlphaMode]
-> [Hook WindowAlphaMode]
-> [HookRel WindowAlphaMode]
-> [HookRel WindowAlphaMode]
-> [HookRel WindowAlphaMode]
-> Component WindowAlphaMode
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook WindowAlphaMode]
onAdd :: [Hook WindowAlphaMode]
$conSet :: [Hook WindowAlphaMode]
onSet :: [Hook WindowAlphaMode]
$conRemove :: [Hook WindowAlphaMode]
onRemove :: [Hook WindowAlphaMode]
$conAddRel :: [HookRel WindowAlphaMode]
onAddRel :: [HookRel WindowAlphaMode]
$conSetRel :: [HookRel WindowAlphaMode]
onSetRel :: [HookRel WindowAlphaMode]
$conRemoveRel :: [HookRel WindowAlphaMode]
onRemoveRel :: [HookRel WindowAlphaMode]
Component)

-- | Creates a WGPU Surface, Adapter, and Device for each new window. Inserts them as components.
onAddWindow :: OnAdd SDLWindow -> System ()
onAddWindow :: OnAdd SDLWindow -> System ()
onAddWindow (OnAdd Entity
entity) = do
  Just (SDLWindow window, WindowSize w h) <- Query System (SDLWindow, WindowSize)
-> System (Maybe (SDLWindow, WindowSize))
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. SDLWindow, WindowSize|]

  windowProps <- liftIO $ SDL3.getWindowProperties window
  driver <- liftIO (peekCString . unConstPtr =<< SDL3.getCurrentVideoDriver)

  Just (RenderInstance wgpuInstance) <- res @RenderInstance

  surface <- liftIO $ getSurfaceDescriptor wgpuInstance driver windowProps window

  when (surface == nullPtr) $ error "Couldn't create WGPU surface."

  tryAdapter <- res @RenderAdapter
  (adapter, device, _) <- case tryAdapter of
    Just (RenderAdapter Ptr WGPUAdapter
adapter) -> do
      Just (RenderDevice device) <- forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @RenderDevice
      Just (RenderQueue queue) <- res @RenderQueue
      pure (adapter, device, queue)
    Maybe RenderAdapter
Nothing -> do
      adapter <- IO (Ptr WGPUAdapter) -> System (Ptr WGPUAdapter)
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr WGPUAdapter) -> System (Ptr WGPUAdapter))
-> IO (Ptr WGPUAdapter) -> System (Ptr WGPUAdapter)
forall a b. (a -> b) -> a -> b
$ Ptr WGPUInstance -> Ptr WGPUSurface -> IO (Ptr WGPUAdapter)
wgpuInstanceRequestAdapter Ptr WGPUInstance
wgpuInstance Ptr WGPUSurface
surface
      device <- liftIO $ wgpuAdapterRequestDevice adapter
      queue <- liftIO $ wgpuDeviceGetQueue device

      insertRes (RenderAdapter adapter)
      insertRes (RenderDevice device)
      insertRes (RenderQueue queue)
      pure (adapter, device, queue)

  surfaceCapabilities <- liftIO $ malloc @WGPUSurfaceCapabilities
  liftIO $ wgpuSurfaceGetCapabilities surface adapter surfaceCapabilities

  cap <- liftIO $ peek surfaceCapabilities
  liftIO $ free surfaceCapabilities
  let (ConstPtr formats) = cap.formats
  let (ConstPtr alphaModes) = cap.alphaModes
  format <- liftIO $ peek formats
  alphaMode <- liftIO $ peek alphaModes

  let config =
        WGPUSurfaceConfiguration
newWGPUSurfaceConfiguration
          { device,
            usage = wGPUTextureUsage_RenderAttachment,
            format,
            presentMode = wGPUPresentMode_Fifo,
            alphaMode,
            width = fromIntegral w,
            height = fromIntegral h
          }

  liftIO $ with config $ \Ptr WGPUSurfaceConfiguration
config -> do
    Ptr WGPUSurface -> ConstPtr WGPUSurfaceConfiguration -> IO ()
wgpuSurfaceConfigure Ptr WGPUSurface
surface (Ptr WGPUSurfaceConfiguration -> ConstPtr WGPUSurfaceConfiguration
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUSurfaceConfiguration
config)

  insert (RenderSurface surface, WindowFormat format, WindowAlphaMode alphaMode) entity

  sampler <- newSampler (RenderDevice device)
  insertRes $ DefaultSampler sampler

onSetWindowSize :: OnSet WindowSize -> System ()
onSetWindowSize :: OnSet WindowSize -> System ()
onSetWindowSize (OnSet Entity
window) = Query System () -> System ()
forall w (m :: * -> *) out. MonadSystem w m => Query m out -> m ()
query_ (Query System () -> System ()) -> Query System () -> System ()
forall a b. (a -> b) -> a -> b
$ do
  (WindowSize w h, RenderSurface surface, WindowAlphaMode alphaMode, WindowFormat format) <- [q|window. WindowSize, RenderSurface, WindowAlphaMode, WindowFormat|]
  (RenderDevice device) <- qres

  let config =
        WGPUSurfaceConfiguration
newWGPUSurfaceConfiguration
          { device,
            usage = wGPUTextureUsage_RenderAttachment,
            format,
            presentMode = wGPUPresentMode_Fifo,
            alphaMode,
            width = fromIntegral w,
            height = fromIntegral h
          }

  qlift $ do
    liftIO $ with config $ \Ptr WGPUSurfaceConfiguration
config -> do
      Ptr WGPUSurface -> ConstPtr WGPUSurfaceConfiguration -> IO ()
wgpuSurfaceConfigure Ptr WGPUSurface
surface (Ptr WGPUSurfaceConfiguration -> ConstPtr WGPUSurfaceConfiguration
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUSurfaceConfiguration
config)

-- | Maps a SDL driver name and window to the correct surface texture for WGPU.
--
-- TODO: implement the rest of the drivers.
getSurfaceDescriptor :: Ptr WGPUInstance -> String -> SDL3.SDL_PropertiesID -> Ptr SDL3.SDL_Window -> IO (Ptr WGPUSurface)
getSurfaceDescriptor :: Ptr WGPUInstance
-> String
-> SDL_PropertiesID
-> Ptr SDL_Window
-> IO (Ptr WGPUSurface)
getSurfaceDescriptor Ptr WGPUInstance
inst String
"x11" SDL_PropertiesID
props Ptr SDL_Window
_ = do
  display <- ByteString -> (CString -> IO (Ptr Void)) -> IO (Ptr Void)
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
SDL3.sDL_PROP_WINDOW_X11_DISPLAY_POINTER ((CString -> IO (Ptr Void)) -> IO (Ptr Void))
-> (CString -> IO (Ptr Void)) -> IO (Ptr Void)
forall a b. (a -> b) -> a -> b
$ \CString
b -> SDL_PropertiesID -> ConstPtr CChar -> Ptr Void -> IO (Ptr Void)
SDL3.getPointerProperty SDL_PropertiesID
props (CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
b) Ptr Void
forall a. Ptr a
nullPtr
  window <- BS.useAsCString SDL3.sDL_PROP_WINDOW_X11_WINDOW_NUMBER $ \CString
b -> SDL_PropertiesID -> ConstPtr CChar -> Int64 -> IO Int64
SDL3.getNumberProperty SDL_PropertiesID
props (CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
b) (-Int64
1)

  when (display == nullPtr || window == -1) $ error "Can't obtain x11 window."

  let chain = WGPUChainedStruct {next :: Ptr WGPUChainedStruct
next = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr, sType :: WGPUSType
sType = WGPUSType
wGPUSType_SurfaceSourceXlibWindow}
  let xlib = WGPUSurfaceSourceXlibWindow {WGPUChainedStruct
chain :: WGPUChainedStruct
chain :: WGPUChainedStruct
chain, Ptr Void
display :: Ptr Void
display :: Ptr Void
display, Int64
window :: Int64
window :: Int64
window}

  with xlib $ \Ptr WGPUSurfaceSourceXlibWindow
xlib ->
    WGPUSurfaceDescriptor
-> (Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> IO (Ptr WGPUSurface)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with
      ( WGPUSurfaceDescriptor
          { nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUSurfaceSourceXlibWindow -> Ptr WGPUChainedStruct
forall a b. Ptr a -> Ptr b
castPtr Ptr WGPUSurfaceSourceXlibWindow
xlib,
            label :: WGPUStringView
label = WGPUStringView {_data :: ConstPtr CChar
_data = CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
forall a. Ptr a
nullPtr, length :: Int
length = Int
0}
          }
      )
      ((Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
 -> IO (Ptr WGPUSurface))
-> (Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> IO (Ptr WGPUSurface)
forall a b. (a -> b) -> a -> b
$ Ptr WGPUInstance
-> ConstPtr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface)
wgpuInstanceCreateSurface Ptr WGPUInstance
inst (ConstPtr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> (Ptr WGPUSurfaceDescriptor -> ConstPtr WGPUSurfaceDescriptor)
-> Ptr WGPUSurfaceDescriptor
-> IO (Ptr WGPUSurface)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr WGPUSurfaceDescriptor -> ConstPtr WGPUSurfaceDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr
getSurfaceDescriptor Ptr WGPUInstance
inst String
"windows" SDL_PropertiesID
props Ptr SDL_Window
_ = do
  hwnd <- ByteString -> (CString -> IO (Ptr Void)) -> IO (Ptr Void)
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
SDL3.sDL_PROP_WINDOW_WIN32_HWND_POINTER ((CString -> IO (Ptr Void)) -> IO (Ptr Void))
-> (CString -> IO (Ptr Void)) -> IO (Ptr Void)
forall a b. (a -> b) -> a -> b
$ \CString
b -> SDL_PropertiesID -> ConstPtr CChar -> Ptr Void -> IO (Ptr Void)
SDL3.getPointerProperty SDL_PropertiesID
props (CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
b) Ptr Void
forall a. Ptr a
nullPtr
  hinstance <- BS.useAsCString SDL3.sDL_PROP_WINDOW_WIN32_INSTANCE_POINTER $ \CString
b -> SDL_PropertiesID -> ConstPtr CChar -> Ptr Void -> IO (Ptr Void)
SDL3.getPointerProperty SDL_PropertiesID
props (CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
b) Ptr Void
forall a. Ptr a
nullPtr

  let chain = WGPUChainedStruct {next :: Ptr WGPUChainedStruct
next = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr, sType :: WGPUSType
sType = WGPUSType
wGPUSType_SurfaceSourceWindowsHWND}
  let win = WGPUSurfaceSourceWindowsHWND {WGPUChainedStruct
chain :: WGPUChainedStruct
chain :: WGPUChainedStruct
chain, Ptr Void
hinstance :: Ptr Void
hinstance :: Ptr Void
hinstance, Ptr Void
hwnd :: Ptr Void
hwnd :: Ptr Void
hwnd}

  with win $ \Ptr WGPUSurfaceSourceWindowsHWND
win ->
    WGPUSurfaceDescriptor
-> (Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> IO (Ptr WGPUSurface)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with
      ( WGPUSurfaceDescriptor
          { nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUSurfaceSourceWindowsHWND -> Ptr WGPUChainedStruct
forall a b. Ptr a -> Ptr b
castPtr Ptr WGPUSurfaceSourceWindowsHWND
win,
            label :: WGPUStringView
label = WGPUStringView {_data :: ConstPtr CChar
_data = CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
forall a. Ptr a
nullPtr, length :: Int
length = Int
0}
          }
      )
      ((Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
 -> IO (Ptr WGPUSurface))
-> (Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> IO (Ptr WGPUSurface)
forall a b. (a -> b) -> a -> b
$ Ptr WGPUInstance
-> ConstPtr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface)
wgpuInstanceCreateSurface Ptr WGPUInstance
inst (ConstPtr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> (Ptr WGPUSurfaceDescriptor -> ConstPtr WGPUSurfaceDescriptor)
-> Ptr WGPUSurfaceDescriptor
-> IO (Ptr WGPUSurface)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr WGPUSurfaceDescriptor -> ConstPtr WGPUSurfaceDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr
getSurfaceDescriptor Ptr WGPUInstance
inst String
"cocoa" SDL_PropertiesID
_ Ptr SDL_Window
window = do
  x <- Ptr SDL_Window -> IO SDL_MetalView
SDL3.metalCreateView Ptr SDL_Window
window
  layer <- SDL3.metalGetLayer x

  when (layer == nullPtr) $ error "Couldn't obtain metal layer!"

  let chain = WGPUChainedStruct {next :: Ptr WGPUChainedStruct
next = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr, sType :: WGPUSType
sType = WGPUSType
wGPUSType_SurfaceSourceMetalLayer}
  let cocoa = WGPUSurfaceSourceMetalLayer {WGPUChainedStruct
chain :: WGPUChainedStruct
chain :: WGPUChainedStruct
chain, Ptr Void
layer :: Ptr Void
layer :: Ptr Void
layer}

  with cocoa $ \Ptr WGPUSurfaceSourceMetalLayer
cocoa ->
    WGPUSurfaceDescriptor
-> (Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> IO (Ptr WGPUSurface)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with
      ( WGPUSurfaceDescriptor
          { nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUSurfaceSourceMetalLayer -> Ptr WGPUChainedStruct
forall a b. Ptr a -> Ptr b
castPtr Ptr WGPUSurfaceSourceMetalLayer
cocoa,
            label :: WGPUStringView
label = WGPUStringView {_data :: ConstPtr CChar
_data = CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
forall a. Ptr a
nullPtr, length :: Int
length = Int
0}
          }
      )
      ((Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
 -> IO (Ptr WGPUSurface))
-> (Ptr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> IO (Ptr WGPUSurface)
forall a b. (a -> b) -> a -> b
$ Ptr WGPUInstance
-> ConstPtr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface)
wgpuInstanceCreateSurface Ptr WGPUInstance
inst (ConstPtr WGPUSurfaceDescriptor -> IO (Ptr WGPUSurface))
-> (Ptr WGPUSurfaceDescriptor -> ConstPtr WGPUSurfaceDescriptor)
-> Ptr WGPUSurfaceDescriptor
-> IO (Ptr WGPUSurface)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr WGPUSurfaceDescriptor -> ConstPtr WGPUSurfaceDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr
getSurfaceDescriptor Ptr WGPUInstance
_ String
s SDL_PropertiesID
_ Ptr SDL_Window
_ = String -> IO (Ptr WGPUSurface)
forall a. HasCallStack => String -> a
error (String -> IO (Ptr WGPUSurface)) -> String -> IO (Ptr WGPUSurface)
forall a b. (a -> b) -> a -> b
$ String
"Incompatible driver: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

newtype BindLayout = BindLayout (Ptr WGPUBindGroupLayout)

newtype RenderPipeline = RenderPipeline (Ptr WGPURenderPipeline)

-- newtype TextureFormat = TextureFormat WGPUTextureFormat

newtype Sampler = Sampler (Ptr WGPUSampler)

getRenderingResources :: System (Maybe (RenderAdapter, RenderDevice, RenderQueue))
getRenderingResources :: System (Maybe (RenderAdapter, RenderDevice, RenderQueue))
getRenderingResources = do
  adapter <- forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @RenderAdapter
  device <- res @RenderDevice
  queue <- res @RenderQueue
  pure $ (,,) <$> adapter <*> device <*> queue

data RenderFirst = RenderFirst deriving (Typeable RenderFirst
Typeable RenderFirst => Schedule RenderFirst
forall {k} (s :: k). Typeable s => Schedule s
Schedule)

data RenderPrepare = RenderPrepare deriving (Typeable RenderPrepare
Typeable RenderPrepare => Schedule RenderPrepare
forall {k} (s :: k). Typeable s => Schedule s
Schedule)

data RenderUpdate = RenderUpdate deriving (Typeable RenderUpdate
Typeable RenderUpdate => Schedule RenderUpdate
forall {k} (s :: k). Typeable s => Schedule s
Schedule)

data RenderTransparent = RenderTransparent deriving (Typeable RenderTransparent
Typeable RenderTransparent => Schedule RenderTransparent
forall {k} (s :: k). Typeable s => Schedule s
Schedule)

data RenderPostprocess = RenderPostprocess deriving (Typeable RenderPostprocess
Typeable RenderPostprocess => Schedule RenderPostprocess
forall {k} (s :: k). Typeable s => Schedule s
Schedule)

data RenderLast = RenderLast deriving (Typeable RenderLast
Typeable RenderLast => Schedule RenderLast
forall {k} (s :: k). Typeable s => Schedule s
Schedule)

getFormat :: RenderSurface -> RenderAdapter -> System TextureFormat
getFormat :: RenderSurface -> RenderAdapter -> System TextureFormat
getFormat (RenderSurface Ptr WGPUSurface
surface) (RenderAdapter Ptr WGPUAdapter
adapter) = IO TextureFormat -> System TextureFormat
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TextureFormat -> System TextureFormat)
-> IO TextureFormat -> System TextureFormat
forall a b. (a -> b) -> a -> b
$ do
  surfaceCapabilities <- forall a. Storable a => IO (Ptr a)
malloc @WGPUSurfaceCapabilities
  wgpuSurfaceGetCapabilities surface adapter surfaceCapabilities

  cap <- peek surfaceCapabilities
  free surfaceCapabilities
  let (ConstPtr formats) = cap.formats
  format <- peek formats

  pure $ fromWGPUFormat format

newSampler :: RenderDevice -> System Sampler
newSampler :: RenderDevice -> System Sampler
newSampler (RenderDevice Ptr WGPUDevice
device) = IO Sampler -> System Sampler
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sampler -> System Sampler) -> IO Sampler -> System Sampler
forall a b. (a -> b) -> a -> b
$ do
  let samplerDesc :: WGPUSamplerDescriptor
samplerDesc =
        WGPUSamplerDescriptor
          { addressModeU :: WGPUAddressMode
addressModeU = WGPUAddressMode
wGPUAddressMode_ClampToEdge,
            addressModeV :: WGPUAddressMode
addressModeV = WGPUAddressMode
wGPUAddressMode_ClampToEdge,
            addressModeW :: WGPUAddressMode
addressModeW = WGPUAddressMode
wGPUAddressMode_ClampToEdge,
            magFilter :: WGPUFilterMode
magFilter = WGPUFilterMode
wGPUFilterMode_Linear,
            minFilter :: WGPUFilterMode
minFilter = WGPUFilterMode
wGPUFilterMode_Linear,
            mipmapFilter :: WGPUMipmapFilterMode
mipmapFilter = WGPUMipmapFilterMode
wGPUMipmapFilterMode_Nearest,
            nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr,
            label :: WGPUStringView
label = ConstPtr CChar -> Int -> WGPUStringView
WGPUStringView (CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
forall a. Ptr a
nullPtr) Int
0,
            lodMinClamp :: Float
lodMinClamp = Float
0,
            lodMaxClamp :: Float
lodMaxClamp = Float
32,
            compare :: WGPUCompareFunction
compare = WGPUCompareFunction
wGPUCompareFunction_Undefined,
            maxAnisotropy :: Word16
maxAnisotropy = Word16
1
          }
  Ptr WGPUSampler -> Sampler
Sampler (Ptr WGPUSampler -> Sampler) -> IO (Ptr WGPUSampler) -> IO Sampler
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WGPUSamplerDescriptor
-> (Ptr WGPUSamplerDescriptor -> IO (Ptr WGPUSampler))
-> IO (Ptr WGPUSampler)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUSamplerDescriptor
samplerDesc (Ptr WGPUDevice
-> ConstPtr WGPUSamplerDescriptor -> IO (Ptr WGPUSampler)
wgpuDeviceCreateSampler Ptr WGPUDevice
device (ConstPtr WGPUSamplerDescriptor -> IO (Ptr WGPUSampler))
-> (Ptr WGPUSamplerDescriptor -> ConstPtr WGPUSamplerDescriptor)
-> Ptr WGPUSamplerDescriptor
-> IO (Ptr WGPUSampler)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr WGPUSamplerDescriptor -> ConstPtr WGPUSamplerDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr)