{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : WGPU.Internal.Adapter
-- Description : Adapter (physical device).
module WGPU.Internal.Adapter
  ( -- * Types
    Adapter (..),

    -- * Functions
    requestAdapter,
  )
where

import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Cont (evalContT)
import Foreign (freeHaskellFunPtr, nullPtr)
import Foreign.Ptr (Ptr)
import WGPU.Internal.Instance (Instance, wgpuHsInstance)
import WGPU.Internal.Memory (ToRaw, raw, rawPtr, showWithPtr)
import WGPU.Internal.Surface (Surface, surfaceInst)
import qualified WGPU.Raw.Generated.Fun as RawFun
import WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions
  ( WGPURequestAdapterOptions,
  )
import qualified WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions as WGPURequestAdapterOptions
import WGPU.Raw.Types
  ( WGPUAdapter (WGPUAdapter),
    WGPUInstance (WGPUInstance),
    WGPURequestAdapterCallback,
  )

-------------------------------------------------------------------------------

-- | Handle to a physical graphics and/or compute device.
--
-- Request an 'Adapter' for a 'Surface' using the 'requestAdapter' function.
data Adapter = Adapter
  { Adapter -> Instance
adapterInst :: !Instance,
    Adapter -> WGPUAdapter
wgpuAdapter :: !WGPUAdapter
  }

instance Show Adapter where
  show :: Adapter -> String
show Adapter
a =
    let Adapter Instance
_ (WGPUAdapter Ptr ()
ptr) = Adapter
a
     in String -> Ptr () -> String
forall a. String -> Ptr a -> String
showWithPtr String
"Adapter" Ptr ()
ptr

instance Eq Adapter where
  == :: Adapter -> Adapter -> Bool
(==) Adapter
a1 Adapter
a2 =
    let Adapter Instance
_ (WGPUAdapter Ptr ()
a1_ptr) = Adapter
a1
        Adapter Instance
_ (WGPUAdapter Ptr ()
a2_ptr) = Adapter
a2
     in Ptr ()
a1_ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
a2_ptr

instance ToRaw Adapter WGPUAdapter where
  raw :: Adapter -> ContT c IO WGPUAdapter
raw = WGPUAdapter -> ContT c IO WGPUAdapter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUAdapter -> ContT c IO WGPUAdapter)
-> (Adapter -> WGPUAdapter) -> Adapter -> ContT c IO WGPUAdapter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Adapter -> WGPUAdapter
wgpuAdapter

-------------------------------------------------------------------------------

-- | Request an 'Adapter' that is compatible with a given 'Surface'.
--
-- This action blocks until an available adapter is returned.
requestAdapter ::
  -- | Existing surface for which to request an @Adapter@.
  Surface ->
  -- | The returned @Adapter@, if it could be retrieved.
  IO (Maybe Adapter)
requestAdapter :: Surface -> IO (Maybe Adapter)
requestAdapter Surface
surface = ContT (Maybe Adapter) IO (Maybe Adapter) -> IO (Maybe Adapter)
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT (ContT (Maybe Adapter) IO (Maybe Adapter) -> IO (Maybe Adapter))
-> ContT (Maybe Adapter) IO (Maybe Adapter) -> IO (Maybe Adapter)
forall a b. (a -> b) -> a -> b
$ do
  let inst :: Instance
inst = Surface -> Instance
surfaceInst Surface
surface

  MVar WGPUAdapter
adapterMVar :: MVar WGPUAdapter <- IO (MVar WGPUAdapter)
-> ContT (Maybe Adapter) IO (MVar WGPUAdapter)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar WGPUAdapter)
forall a. IO (MVar a)
newEmptyMVar

  let adapterCallback :: WGPUAdapter -> Ptr () -> IO ()
      adapterCallback :: WGPUAdapter -> Ptr () -> IO ()
adapterCallback WGPUAdapter
adapter Ptr ()
_ = MVar WGPUAdapter -> WGPUAdapter -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar WGPUAdapter
adapterMVar WGPUAdapter
adapter
  WGPURequestAdapterCallback
adapterCallback_c <- IO WGPURequestAdapterCallback
-> ContT (Maybe Adapter) IO WGPURequestAdapterCallback
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WGPURequestAdapterCallback
 -> ContT (Maybe Adapter) IO WGPURequestAdapterCallback)
-> IO WGPURequestAdapterCallback
-> ContT (Maybe Adapter) IO WGPURequestAdapterCallback
forall a b. (a -> b) -> a -> b
$ (WGPUAdapter -> Ptr () -> IO ()) -> IO WGPURequestAdapterCallback
mkAdapterCallback WGPUAdapter -> Ptr () -> IO ()
adapterCallback

  Ptr WGPURequestAdapterOptions
requestAdapterOptions_ptr <- RequestAdapterOptions
-> ContT (Maybe Adapter) IO (Ptr WGPURequestAdapterOptions)
forall a b c. ToRawPtr a b => a -> ContT c IO (Ptr b)
rawPtr (Surface -> RequestAdapterOptions
RequestAdapterOptions Surface
surface)
  IO () -> ContT (Maybe Adapter) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT (Maybe Adapter) IO ())
-> IO () -> ContT (Maybe Adapter) IO ()
forall a b. (a -> b) -> a -> b
$
    WGPUHsInstance
-> WGPUInstance
-> Ptr WGPURequestAdapterOptions
-> WGPURequestAdapterCallback
-> Ptr ()
-> IO ()
RawFun.wgpuInstanceRequestAdapter
      (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
      (Ptr () -> WGPUInstance
WGPUInstance Ptr ()
forall a. Ptr a
nullPtr)
      Ptr WGPURequestAdapterOptions
requestAdapterOptions_ptr
      WGPURequestAdapterCallback
adapterCallback_c
      Ptr ()
forall a. Ptr a
nullPtr

  WGPUAdapter
adapter <- IO WGPUAdapter -> ContT (Maybe Adapter) IO WGPUAdapter
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WGPUAdapter -> ContT (Maybe Adapter) IO WGPUAdapter)
-> IO WGPUAdapter -> ContT (Maybe Adapter) IO WGPUAdapter
forall a b. (a -> b) -> a -> b
$ MVar WGPUAdapter -> IO WGPUAdapter
forall a. MVar a -> IO a
takeMVar MVar WGPUAdapter
adapterMVar
  IO () -> ContT (Maybe Adapter) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT (Maybe Adapter) IO ())
-> IO () -> ContT (Maybe Adapter) IO ()
forall a b. (a -> b) -> a -> b
$ WGPURequestAdapterCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr WGPURequestAdapterCallback
adapterCallback_c

  Maybe Adapter -> ContT (Maybe Adapter) IO (Maybe Adapter)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Adapter -> ContT (Maybe Adapter) IO (Maybe Adapter))
-> Maybe Adapter -> ContT (Maybe Adapter) IO (Maybe Adapter)
forall a b. (a -> b) -> a -> b
$ case WGPUAdapter
adapter of
    WGPUAdapter Ptr ()
ptr | Ptr ()
ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr -> Maybe Adapter
forall a. Maybe a
Nothing
    WGPUAdapter Ptr ()
_ -> Adapter -> Maybe Adapter
forall a. a -> Maybe a
Just (Instance -> WGPUAdapter -> Adapter
Adapter Instance
inst WGPUAdapter
adapter)

foreign import ccall "wrapper"
  mkAdapterCallback ::
    (WGPUAdapter -> Ptr () -> IO ()) -> IO WGPURequestAdapterCallback

newtype RequestAdapterOptions = RequestAdapterOptions {RequestAdapterOptions -> Surface
compatibleSurface :: Surface}

instance ToRaw RequestAdapterOptions WGPURequestAdapterOptions where
  raw :: RequestAdapterOptions -> ContT c IO WGPURequestAdapterOptions
raw RequestAdapterOptions {Surface
compatibleSurface :: Surface
compatibleSurface :: RequestAdapterOptions -> Surface
..} = do
    WGPUSurface
n_surface <- Surface -> ContT c IO WGPUSurface
forall a b c. ToRaw a b => a -> ContT c IO b
raw Surface
compatibleSurface
    WGPURequestAdapterOptions -> ContT c IO WGPURequestAdapterOptions
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      WGPURequestAdapterOptions :: Ptr WGPUChainedStruct -> WGPUSurface -> WGPURequestAdapterOptions
WGPURequestAdapterOptions.WGPURequestAdapterOptions
        { nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr,
          compatibleSurface :: WGPUSurface
compatibleSurface = WGPUSurface
n_surface
        }