dear-imgui-impl-sdl2-1.0.0: src/DearImGui/Impl/SDL2.hs

{-| "DearImGui.Raw.Impl.SDL2" over the @sdl2@ 'SDL.Window', 'SDL.GLContext'
and 'SDL.Renderer' handles. 'pollEvent' / 'pollEvents' stand in for
@SDL.pollEvent@ / @SDL.pollEvents@: each event reaches ImGui before it is
decoded.
-}
module DearImGui.Impl.SDL2
  ( windowPtr
  , glContextPtr
  , rendererPtr
  , initForOpenGL
  , initForVulkan
  , initForOther
  , initForSDLRenderer
  , withInitForOpenGL
  , withInitForVulkan
  , withInitForOther
  , withInitForSDLRenderer
  , getContentScaleForWindow
  , processEvent
  , pollEvent
  , pollEvents
  , Raw.getContentScaleForDisplay
  , Raw.newFrame
  , Raw.setGamepadMode
  , Raw.setMouseCaptureMode
  , Raw.shutdown
  ) where

import Control.Monad (void)
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (toBool)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (peek)
import SDL qualified
import SDL.Internal.Types (Renderer (..), Window (..))
import SDL.Raw qualified as SDLRaw
import Unsafe.Coerce (unsafeCoerce)

import DearImGui.Impl.Init (withInitOrFail)
import DearImGui.Raw.Impl.SDL2 (SDL_Renderer, SDL_Window)
import DearImGui.Raw.Impl.SDL2 qualified as Raw

windowPtr :: SDL.Window -> Ptr SDL_Window
windowPtr (Window raw) = castPtr raw

{- | @sdl2@ keeps the 'SDL.GLContext' constructor private, so the coercion
mirrors its newtype representation over the raw @SDL_GLContext@ pointer.
-}
glContextPtr :: SDL.GLContext -> Ptr ()
glContextPtr = unsafeCoerce

rendererPtr :: SDL.Renderer -> Ptr SDL_Renderer
rendererPtr (Renderer raw) = castPtr raw

initForOpenGL :: SDL.Window -> SDL.GLContext -> IO Bool
initForOpenGL window context =
  toBool <$> Raw.initForOpenGL (windowPtr window) (glContextPtr context)

initForVulkan :: SDL.Window -> IO Bool
initForVulkan window =
  toBool <$> Raw.initForVulkan (windowPtr window)

initForOther :: SDL.Window -> IO Bool
initForOther window =
  toBool <$> Raw.initForOther (windowPtr window)

initForSDLRenderer :: SDL.Window -> SDL.Renderer -> IO Bool
initForSDLRenderer window renderer =
  toBool <$> Raw.initForSDLRenderer (windowPtr window) (rendererPtr renderer)

withInitForOpenGL :: (MonadUnliftIO m) => SDL.Window -> SDL.GLContext -> m a -> m a
withInitForOpenGL window context =
  withInitOrFail "ImGui_ImplSDL2_InitForOpenGL" (initForOpenGL window context) Raw.shutdown

withInitForVulkan :: (MonadUnliftIO m) => SDL.Window -> m a -> m a
withInitForVulkan window =
  withInitOrFail "ImGui_ImplSDL2_InitForVulkan" (initForVulkan window) Raw.shutdown

withInitForOther :: (MonadUnliftIO m) => SDL.Window -> m a -> m a
withInitForOther window =
  withInitOrFail "ImGui_ImplSDL2_InitForOther" (initForOther window) Raw.shutdown

withInitForSDLRenderer :: (MonadUnliftIO m) => SDL.Window -> SDL.Renderer -> m a -> m a
withInitForSDLRenderer window renderer =
  withInitOrFail "ImGui_ImplSDL2_InitForSDLRenderer" (initForSDLRenderer window renderer) Raw.shutdown

getContentScaleForWindow :: SDL.Window -> IO Float
getContentScaleForWindow = Raw.getContentScaleForWindow . windowPtr

processEvent :: Ptr SDLRaw.Event -> IO Bool
processEvent event =
  toBool <$> Raw.processEvent (castPtr event)

pollEvent :: IO (Maybe SDL.Event)
pollEvent = alloca pollEventInto

pollEvents :: IO [SDL.Event]
pollEvents = alloca drain
  where
    drain event =
      pollEventInto event >>= \case
        Nothing ->
          pure []
        Just decoded ->
          (decoded :) <$> drain event

pollEventInto :: Ptr SDLRaw.Event -> IO (Maybe SDL.Event)
pollEventInto event = do
  pending <- SDLRaw.pollEvent event
  if pending == 0 then
    pure Nothing
  else do
    void (processEvent event)
    decoded <- peek event >>= SDL.convertRaw
    pure (Just decoded)