Interact.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use camelCase" #-}

module Brillo.Internals.Interface.Interact (interactWithBackend)
where

import Brillo.Data.Color
import Brillo.Data.Controller
import Brillo.Data.Picture
import Brillo.Data.ViewPort
import Brillo.Data.ViewState
import Brillo.Internals.Interface.Backend
import Brillo.Internals.Interface.Callback qualified as Callback
import Brillo.Internals.Interface.Event
import Brillo.Internals.Interface.ViewState.Reshape
import Brillo.Internals.Interface.Window
import Brillo.Rendering
import Data.IORef
import System.Mem


interactWithBackend ::
  (Backend a) =>
  -- | Initial state of the backend.
  a ->
  -- | Display config.
  Display ->
  -- | Background color.
  Color ->
  -- | The initial world.
  world ->
  -- | A function to produce the current picture.
  (world -> IO Picture) ->
  -- | A function to handle input events.
  (Event -> world -> IO world) ->
  -- | Eat the controller
  (Controller -> IO ()) ->
  IO ()
interactWithBackend
  backend
  displayMode
  background
  worldStart
  worldToPicture
  worldHandleEvent
  eatController =
    do
      viewSR <- newIORef viewStateInit
      worldSR <- newIORef worldStart
      renderS <- initState
      renderSR <- newIORef renderS

      let displayFun backendRef = do
            world <- readIORef worldSR
            picture <- worldToPicture world

            renderS' <- readIORef renderSR
            viewState <- readIORef viewSR
            let viewPort = viewStateViewPort viewState

            windowSize <- getWindowDimensions backendRef

            displayPicture
              windowSize
              background
              renderS'
              (viewPortScale viewPort)
              (applyViewPortToPicture viewPort picture)

            -- perform GC every frame to try and avoid long pauses
            performGC

      let callbacks =
            [ Callback.Display displayFun
            , -- Viewport control with mouse
              callback_keyMouse worldSR viewSR worldHandleEvent
            , callback_motion worldSR worldHandleEvent
            , callback_drop worldSR worldHandleEvent
            , callback_reshape worldSR worldHandleEvent
            ]

      -- When we create the window we can pass a function to get a
      -- reference to the backend state. Using this we make a controller
      -- so the client can control the window asynchronously.
      createWindow backend displayMode background callbacks $
        \backendRef ->
          eatController $
            Controller
              { controllerSetRedraw =
                  do postRedisplay backendRef
              , controllerModifyViewPort =
                  \modViewPort ->
                    do
                      viewState <- readIORef viewSR
                      port' <- modViewPort $ viewStateViewPort viewState
                      let viewState' = viewState{viewStateViewPort = port'}
                      writeIORef viewSR viewState'
                      postRedisplay backendRef
              , controllerSetCursor =
                  \cursorShape ->
                    setCursor backendRef cursorShape
              }


-- | Callback for KeyMouse events.
callback_keyMouse ::
  -- | ref to world state
  IORef world ->
  IORef ViewState ->
  -- | fn to handle input events
  (Event -> world -> IO world) ->
  Callback
callback_keyMouse worldRef viewRef eventFn =
  KeyMouse (handle_keyMouse worldRef viewRef eventFn)


handle_keyMouse ::
  IORef a ->
  t ->
  (Event -> a -> IO a) ->
  KeyboardMouseCallback
handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos =
  do
    ev <- keyMouseEvent backendRef key keyState keyMods pos
    world <- readIORef worldRef
    world' <- eventFn ev world
    writeIORef worldRef world'
    postRedisplay backendRef


-- | Callback for Motion events.
callback_motion ::
  -- | ref to world state
  IORef world ->
  -- | fn to handle input events
  (Event -> world -> IO world) ->
  Callback
callback_motion worldRef eventFn =
  Motion (handle_motion worldRef eventFn)


handle_motion ::
  IORef a ->
  (Event -> a -> IO a) ->
  MotionCallback
handle_motion worldRef eventFn backendRef pos =
  do
    ev <- motionEvent backendRef pos
    world <- readIORef worldRef
    world' <- eventFn ev world
    writeIORef worldRef world'
    postRedisplay backendRef


callback_drop ::
  IORef world ->
  (Event -> world -> IO world) ->
  Callback
callback_drop worldRef eventFn =
  Drop (handle_drop worldRef eventFn)


handle_drop ::
  IORef a ->
  (Event -> a -> IO a) ->
  DropCallback
handle_drop worldRef eventFn backendRef paths = do
  ev <- dropEvent backendRef paths
  world <- readIORef worldRef
  world' <- eventFn ev world
  writeIORef worldRef world'


-- | Callback for Handle reshape event.
callback_reshape ::
  IORef world ->
  (Event -> world -> IO world) ->
  Callback
callback_reshape worldRef eventFN =
  Reshape (handle_reshape worldRef eventFN)


handle_reshape ::
  IORef world ->
  (Event -> world -> IO world) ->
  ReshapeCallback
handle_reshape worldRef eventFn backendRef (width, height) =
  do
    world <- readIORef worldRef
    world' <- eventFn (EventResize (width, height)) world
    writeIORef worldRef world'
    viewState_reshape backendRef (width, height)
    postRedisplay backendRef