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 RIO.App (appEnv)
import UnliftIO.Resource (ReleaseKey)
import UnliftIO.Resource qualified as Resource
import Resource.Collection (Generic1, Generically1(..))

import Engine.Types (GlobalHandles(..), StageRIO)

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

callback :: Callback st -> StageRIO st 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 (StageRIO st) -> Callback st -> 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