{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : WGPU.Internal.Instance
-- Description : Instance.
--
-- Instance of the WGPU API Haskell bindings.
module WGPU.Internal.Instance
  ( -- * Instance

    --
    -- $instance
    Instance (..),
    withInstance,

    -- * Logging
    LogCallback,
    LogLevel (..),
    setLogLevel,
    logLevelToText,
    logStdout,

    -- * Version
    Version (..),
    getVersion,
    versionToText,
  )
where

import Data.Bits (shiftR, (.&.))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import Data.Word (Word32, Word8)
import Foreign (Ptr, freeHaskellFunPtr, nullFunPtr)
import Foreign.C (CChar, peekCString)
import WGPU.Internal.Memory (ToRaw, raw)
import WGPU.Raw.Dynamic (withWGPU)
import WGPU.Raw.Generated.Enum.WGPULogLevel (WGPULogLevel (WGPULogLevel))
import qualified WGPU.Raw.Generated.Enum.WGPULogLevel as WGPULogLevel
import WGPU.Raw.Generated.Fun (WGPUHsInstance)
import qualified WGPU.Raw.Generated.Fun as RawFun
import WGPU.Raw.Types (WGPULogCallback)

-- $instance
--
-- The Haskell bindings to WGPU use a value of type 'Instance' as a handle to
-- the rest of the API. An 'Instance' value is obtained by loading a dynamic
-- library at runtime, using the 'withInstance' function. A typical invocation
-- might look like this:
--
-- @
-- 'withInstance' "libwgpu_native.dylib" (Just 'logStdOut') $ \inst -> do
--   -- set the logging level for the instance
--   'setLogLevel' inst 'Warn'
--   -- run the rest of the program ...
-- @
--
-- The dynamic library @libwgpu_native.dylib@ is obtained by compiling the
-- Rust project <https://github.com/gfx-rs/wgpu-native wgpu-native>. Care
-- should be take to compile a version of @libwgpu_native.dylib@ which is
-- compatible with the API in these bindings.

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

-- | Instance of the WGPU API.
--
-- An instance is loaded from a dynamic library using the 'withInstance'
-- function.
newtype Instance = Instance {Instance -> WGPUHsInstance
wgpuHsInstance :: WGPUHsInstance}

instance Show Instance where show :: Instance -> String
show Instance
_ = String
"<Instance>"

instance ToRaw Instance WGPUHsInstance where
  raw :: Instance -> ContT c IO WGPUHsInstance
raw = WGPUHsInstance -> ContT c IO WGPUHsInstance
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUHsInstance -> ContT c IO WGPUHsInstance)
-> (Instance -> WGPUHsInstance)
-> Instance
-> ContT c IO WGPUHsInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instance -> WGPUHsInstance
wgpuHsInstance

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

-- | Logging level.
data LogLevel
  = Trace
  | Debug
  | Info
  | Warn
  | Error
  deriving (LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show)

-- | Logging callback function.
type LogCallback = LogLevel -> Text -> IO ()

-- | Load the WGPU API from a dynamic library and supply an 'Instance' to a
-- program.
withInstance ::
  -- | Name of the @wgpu-native@ dynamic library, or a complete path to it.
  FilePath ->
  -- | Optional logging callback. @'Just' 'logStdout'@ can be supplied here to
  --   print log messages to @stdout@ for debugging purposes.
  Maybe LogCallback ->
  -- | The Program. A function which takes an 'Instance' and returns an IO
  --   action that uses the instance.
  (Instance -> IO a) ->
  -- | IO action which loads the WGPU 'Instance', passes it to the program, and
  --   returns the result of running the program.
  IO a
withInstance :: String -> Maybe LogCallback -> (Instance -> IO a) -> IO a
withInstance String
dylibPath Maybe LogCallback
mLog Instance -> IO a
program =
  String -> (WGPUHsInstance -> IO a) -> IO a
forall a. String -> (WGPUHsInstance -> IO a) -> IO a
withWGPU String
dylibPath ((WGPUHsInstance -> IO a) -> IO a)
-> (WGPUHsInstance -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    \WGPUHsInstance
winst -> do
      -- create the logging callback if necessary
      FunPtr (WGPULogLevel -> Ptr CChar -> IO ())
logCallback_c <- case Maybe LogCallback
mLog of
        Maybe LogCallback
Nothing -> FunPtr (WGPULogLevel -> Ptr CChar -> IO ())
-> IO (FunPtr (WGPULogLevel -> Ptr CChar -> IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunPtr (WGPULogLevel -> Ptr CChar -> IO ())
forall a. FunPtr a
nullFunPtr
        Just LogCallback
logFn -> (WGPULogLevel -> Ptr CChar -> IO ())
-> IO (FunPtr (WGPULogLevel -> Ptr CChar -> IO ()))
mkLogCallback ((WGPULogLevel -> Ptr CChar -> IO ())
 -> IO (FunPtr (WGPULogLevel -> Ptr CChar -> IO ())))
-> (LogCallback -> WGPULogLevel -> Ptr CChar -> IO ())
-> LogCallback
-> IO (FunPtr (WGPULogLevel -> Ptr CChar -> IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogCallback -> WGPULogLevel -> Ptr CChar -> IO ()
toRawLogCallback (LogCallback -> IO (FunPtr (WGPULogLevel -> Ptr CChar -> IO ())))
-> LogCallback -> IO (FunPtr (WGPULogLevel -> Ptr CChar -> IO ()))
forall a b. (a -> b) -> a -> b
$ LogCallback
logFn
      WGPUHsInstance
-> FunPtr (WGPULogLevel -> Ptr CChar -> IO ()) -> IO ()
RawFun.wgpuSetLogCallback WGPUHsInstance
winst FunPtr (WGPULogLevel -> Ptr CChar -> IO ())
logCallback_c

      -- run the program
      a
result <- Instance -> IO a
program (WGPUHsInstance -> Instance
Instance WGPUHsInstance
winst)

      -- free the logging callback
      case Maybe LogCallback
mLog of
        Maybe LogCallback
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just LogCallback
_ -> do
          WGPUHsInstance
-> FunPtr (WGPULogLevel -> Ptr CChar -> IO ()) -> IO ()
RawFun.wgpuSetLogCallback WGPUHsInstance
winst FunPtr (WGPULogLevel -> Ptr CChar -> IO ())
forall a. FunPtr a
nullFunPtr
          FunPtr (WGPULogLevel -> Ptr CChar -> IO ()) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (WGPULogLevel -> Ptr CChar -> IO ())
logCallback_c

      a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- | Set the current logging level for the instance.
setLogLevel :: Instance -> LogLevel -> IO ()
setLogLevel :: Instance -> LogLevel -> IO ()
setLogLevel Instance
inst LogLevel
lvl =
  WGPUHsInstance -> WGPULogLevel -> IO ()
RawFun.wgpuSetLogLevel (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst) (LogLevel -> WGPULogLevel
logLevelToWLogLevel LogLevel
lvl)

-- | Create a C callback from a Haskell logging function.
foreign import ccall "wrapper"
  mkLogCallback ::
    (WGPULogLevel -> Ptr CChar -> IO ()) ->
    IO WGPULogCallback

-- | Convert a logging callback function to the form required by the Raw API.
toRawLogCallback :: LogCallback -> (WGPULogLevel -> Ptr CChar -> IO ())
toRawLogCallback :: LogCallback -> WGPULogLevel -> Ptr CChar -> IO ()
toRawLogCallback LogCallback
logFn WGPULogLevel
wLogLevel Ptr CChar
cMsg = do
  Text
msg <- String -> Text
Text.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CChar -> IO String
peekCString Ptr CChar
cMsg
  LogCallback
logFn (WGPULogLevel -> LogLevel
wLogLevelToLogLevel WGPULogLevel
wLogLevel) Text
msg

-- | Convert a raw API logging level into a 'LogLevel'.
--
-- Any unknown log levels become an 'Error'.
wLogLevelToLogLevel :: WGPULogLevel -> LogLevel
wLogLevelToLogLevel :: WGPULogLevel -> LogLevel
wLogLevelToLogLevel WGPULogLevel
wLvl =
  case WGPULogLevel
wLvl of
    WGPULogLevel
WGPULogLevel.Trace -> LogLevel
Trace
    WGPULogLevel
WGPULogLevel.Debug -> LogLevel
Debug
    WGPULogLevel
WGPULogLevel.Info -> LogLevel
Info
    WGPULogLevel
WGPULogLevel.Warn -> LogLevel
Warn
    WGPULogLevel
WGPULogLevel.Error -> LogLevel
Error
    WGPULogLevel
_ -> LogLevel
Error

-- | Convert a 'LogLevel' value into the type required by the raw API.
logLevelToWLogLevel :: LogLevel -> WGPULogLevel
logLevelToWLogLevel :: LogLevel -> WGPULogLevel
logLevelToWLogLevel LogLevel
lvl =
  case LogLevel
lvl of
    LogLevel
Trace -> WGPULogLevel
forall a. (Eq a, Num a) => a
WGPULogLevel.Trace
    LogLevel
Debug -> WGPULogLevel
forall a. (Eq a, Num a) => a
WGPULogLevel.Debug
    LogLevel
Info -> WGPULogLevel
forall a. (Eq a, Num a) => a
WGPULogLevel.Info
    LogLevel
Warn -> WGPULogLevel
forall a. (Eq a, Num a) => a
WGPULogLevel.Warn
    LogLevel
Error -> WGPULogLevel
forall a. (Eq a, Num a) => a
WGPULogLevel.Error

-- | Convert a 'LogLevel' to a text string.
logLevelToText :: LogLevel -> Text
logLevelToText :: LogLevel -> Text
logLevelToText LogLevel
lvl =
  case LogLevel
lvl of
    LogLevel
Trace -> Text
"Trace"
    LogLevel
Debug -> Text
"Debug"
    LogLevel
Info -> Text
"Info"
    LogLevel
Warn -> Text
"Warn"
    LogLevel
Error -> Text
"Error"

-- | A logging function which prints to @stdout@.
--
-- This logging function can be supplied to 'withInstance' to print logging
-- messages to @stdout@ for debugging purposes.
logStdout :: LogLevel -> Text -> IO ()
logStdout :: LogCallback
logStdout LogLevel
lvl Text
msg = Text -> IO ()
TextIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LogLevel -> Text
logLevelToText LogLevel
lvl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

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

-- | Version of WGPU native.
data Version = Version
  { Version -> Word8
major :: !Word8,
    Version -> Word8
minor :: !Word8,
    Version -> Word8
patch :: !Word8,
    Version -> Word8
subPatch :: !Word8
  }
  deriving (Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c== :: Version -> Version -> Bool
Eq, Int -> Version -> ShowS
[Version] -> ShowS
Version -> String
(Int -> Version -> ShowS)
-> (Version -> String) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Version] -> ShowS
$cshowList :: [Version] -> ShowS
show :: Version -> String
$cshow :: Version -> String
showsPrec :: Int -> Version -> ShowS
$cshowsPrec :: Int -> Version -> ShowS
Show)

-- | Return the exact version of the WGPU native instance.
getVersion :: Instance -> IO Version
getVersion :: Instance -> IO Version
getVersion Instance
inst = Word32 -> Version
w32ToVersion (Word32 -> Version) -> IO Word32 -> IO Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WGPUHsInstance -> IO Word32
RawFun.wgpuGetVersion (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
  where
    w32ToVersion :: Word32 -> Version
    w32ToVersion :: Word32 -> Version
w32ToVersion Word32
w =
      let major :: Word8
major = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
          minor :: Word8
minor = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
          patch :: Word8
patch = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
          subPatch :: Word8
subPatch = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
       in Version :: Word8 -> Word8 -> Word8 -> Word8 -> Version
Version {Word8
subPatch :: Word8
patch :: Word8
minor :: Word8
major :: Word8
subPatch :: Word8
patch :: Word8
minor :: Word8
major :: Word8
..}

-- | Convert a 'Version' value to a text string.
--
-- >>> versionToText (Version 0 9 2 2)
-- "v0.9.2.2"
versionToText :: Version -> Text
versionToText :: Version -> Text
versionToText Version
ver =
  Text
"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a. Show a => a -> Text
showt (Version -> Word8
major Version
ver)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a. Show a => a -> Text
showt (Version -> Word8
minor Version
ver)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a. Show a => a -> Text
showt (Version -> Word8
patch Version
ver)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a. Show a => a -> Text
showt (Version -> Word8
subPatch Version
ver)

-- | Show a value as a 'Text' string.
showt :: Show a => a -> Text
showt :: a -> Text
showt = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show