MouseButton.hs

module Engine.Window.MouseButton
  ( Callback
  , callback

  , GLFW.MouseButton(..)
  , GLFW.MouseButtonState(..)
  , GLFW.ModifierKeys(..)

  , mkCallback

  , mouseButtonState
  , whenPressed
  , whenReleased

  , Collection(..)
  , collectionGlfw
  , atGlfw
  ) where

import RIO

import Graphics.UI.GLFW qualified as GLFW
import Resource.Collection (Generic1, Generically1(..))
import RIO.App (appEnv)
import UnliftIO.Resource (ReleaseKey)
import UnliftIO.Resource qualified as Resource

import Engine.Events.Sink (MonadSink)
import Engine.Types (GlobalHandles(..))

type Callback m = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> m ()

callback
  :: MonadSink rs m
  => Callback m
  -> m ReleaseKey
callback handler = do
  window <- asks $ ghWindow . appEnv
  withUnliftIO \ul ->
    GLFW.setMouseButtonCallback window . Just $ mkCallback ul handler
  Resource.register $
    GLFW.setMouseButtonCallback window Nothing

mkCallback :: UnliftIO m -> Callback m -> GLFW.MouseButtonCallback
mkCallback (UnliftIO ul) action =
  \_window button buttonState mods ->
    ul $ action (mods, buttonState, button)

{-# INLINE mouseButtonState #-}
mouseButtonState :: a -> a -> GLFW.MouseButtonState -> a
mouseButtonState pressed released = \case
  GLFW.MouseButtonState'Pressed  -> pressed
  GLFW.MouseButtonState'Released -> released

{-# INLINE whenPressed #-}
whenPressed :: Applicative f => GLFW.MouseButtonState -> f () -> f ()
whenPressed mbs action = mouseButtonState action (pure ()) mbs

{-# INLINE whenReleased #-}
whenReleased :: Applicative f => GLFW.MouseButtonState -> f () -> f ()
whenReleased mbs action = mouseButtonState (pure ()) action mbs

data Collection a = Collection
  { mb1, mb2, mb3, mb4, mb5, mb6, mb7, mb8 :: a }
  deriving (Eq, Ord, Show, Generic1, Functor, Foldable, Traversable)
  deriving Applicative via Generically1 Collection

collectionGlfw :: Collection GLFW.MouseButton
collectionGlfw = Collection
  GLFW.MouseButton'1
  GLFW.MouseButton'2
  GLFW.MouseButton'3
  GLFW.MouseButton'4
  GLFW.MouseButton'5
  GLFW.MouseButton'6
  GLFW.MouseButton'7
  GLFW.MouseButton'8

{-# INLINE atGlfw #-}
atGlfw :: Collection a -> GLFW.MouseButton -> a
atGlfw Collection{..} = \case
  GLFW.MouseButton'1 -> mb1
  GLFW.MouseButton'2 -> mb2
  GLFW.MouseButton'3 -> mb3
  GLFW.MouseButton'4 -> mb4
  GLFW.MouseButton'5 -> mb5
  GLFW.MouseButton'6 -> mb6
  GLFW.MouseButton'7 -> mb7
  GLFW.MouseButton'8 -> mb8