-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.Canvas
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Miso.Subscription.Canvas
  ( -- ** Subscriptions
    canvasSub
  ) where
-----------------------------------------------------------------------------
import Control.Monad.Reader (runReaderT)
import Control.Monad (void)
import Data.IORef
-----------------------------------------------------------------------------
import Miso.Canvas
import Miso.DSL
import Miso.Effect
import Miso.String
import Miso.Subscription.Util
-----------------------------------------------------------------------------
-- | 'Sub' for canvas operations, meant to be used with 'onCreated' / 'onDestroyed'
--
-- Example usage below
--
-- @
-- import Miso.Canvas
--
-- data Action = InitCanvas DOMRef | StopCanvas
--
-- canvasComponent :: 'Component' context props model action
-- canvasComponent = 'component' m u v
--   where
--     m = ()
--     u = \case
--       InitCanvas domRef ->
--         startSub "galaxy" $ canvasSub domRef "2d" $ \_timeStamp currentModel -> do
--           drawScene currentModel
--       StopCanvas ->
--         stopSub "galaxy"
--     v _context _props () =
--       'canvas_' [ onCreatedWith InitCanvas, onDestroyed StopCanvas ] []
--
-- drawScene :: Model -> 'Canvas' ()
-- drawScene m = do
--   'clearRect' (0, 0, 800, 480)
--   'fillStyle' ('color' Color.'Miso.CSS.Color.cornflowerblue')
--   'fillRect'  (0, 0, 800, 480)
--   'fillStyle' ('color' Color.'Miso.CSS.Color.white')
--   'font'      \"24px sans-serif\"
--   'fillText'  (\"Hello, miso!\", 32, 48)
-- @
--
-- 'canvasSub' is meant to bypass virtual DOM creation, creating a more efficient canvas
-- draw. This works by calling requestAnimationFrame in a tight loop around a freshly
-- initialized canvas (per 'onCreated').
--
-- The difference between 'canvasSub' and "Miso.Canvas" is that this operates in a tight
-- rAF loop. The latter operates on a discrete event basis and the draw is called during
-- the diffing process.
--
canvasSub
  :: DOMRef
  -- ^ The canvas 'JSVal' (meant to be consumed from 'onCreatedWith')
  -> MisoString
  -- ^ "2d", "webgpu", "webgl2"
  -> (Double -> model -> Canvas state)
  -- ^ Canvas callback in 60fps, high precision timestamp, model snapshot
  -- as args to Canvas DSL templating
  -> Sub model action
canvasSub :: forall model state action.
DOMRef
-> MisoString
-> (Double -> model -> Canvas state)
-> Sub model action
canvasSub DOMRef
canvasRef MisoString
dim Double -> model -> Canvas state
builder Sink action
snk IO model
getModel = do
  IO (DOMRef, IORef Int)
-> ((DOMRef, IORef Int) -> IO ()) -> Sub model action
forall a b model action. IO a -> (a -> IO b) -> Sub model action
createSub IO (DOMRef, IORef Int)
acquire (DOMRef, IORef Int) -> IO ()
release Sink action
snk IO model
getModel
    where
      acquire :: IO (DOMRef, IORef Int)
acquire = do
        DOMRef
ctx <- DOMRef
canvasRef DOMRef -> MisoString -> MisoString -> IO DOMRef
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO DOMRef
# MisoString
"getContext" (MisoString -> IO DOMRef) -> MisoString -> IO DOMRef
forall a b. (a -> b) -> a -> b
$ MisoString
dim
        IORef DOMRef
cbRef <- DOMRef -> IO (IORef DOMRef)
forall a. a -> IO (IORef a)
newIORef ([Char] -> DOMRef
forall a. HasCallStack => [Char] -> a
error [Char]
"canvasSub: uninitialized, impossible")
        IORef Int
idRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        DOMRef
callback <-
          (DOMRef -> IO ()) -> IO DOMRef
syncCallback1 ((DOMRef -> IO ()) -> IO DOMRef) -> (DOMRef -> IO ()) -> IO DOMRef
forall a b. (a -> b) -> a -> b
$ \DOMRef
jsval -> do
            IO state -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO state -> IO ())
-> (Canvas state -> IO state) -> Canvas state -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Canvas state -> DOMRef -> IO state)
-> DOMRef -> Canvas state -> IO state
forall a b c. (a -> b -> c) -> b -> a -> c
flip Canvas state -> DOMRef -> IO state
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DOMRef
ctx (Canvas state -> IO ()) -> IO (Canvas state) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
              Double -> model -> Canvas state
builder (Double -> model -> Canvas state)
-> IO Double -> IO (model -> Canvas state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DOMRef -> IO Double
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
jsval IO (model -> Canvas state) -> IO model -> IO (Canvas state)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO model
getModel
            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
idRef (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DOMRef -> IO Int
requestAnimationFrame (DOMRef -> IO Int) -> IO DOMRef -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef DOMRef -> IO DOMRef
forall a. IORef a -> IO a
readIORef IORef DOMRef
cbRef
        IORef DOMRef -> DOMRef -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef DOMRef
cbRef DOMRef
callback
        IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
idRef (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DOMRef -> IO Int
requestAnimationFrame DOMRef
callback
        (DOMRef, IORef Int) -> IO (DOMRef, IORef Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DOMRef
callback, IORef Int
idRef)
  
      -- N.B. the queued frame must be cancelled before the callback is
      -- freed: the browser holds a reference to it, and invoking a freed
      -- callback on the next frame crashes the runtime.
      release :: (DOMRef, IORef Int) -> IO ()
release (DOMRef
callback, IORef Int
idRef) = do
        Int -> IO ()
cancelAnimationFrame (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
idRef
        Function -> IO ()
freeFunction (DOMRef -> Function
Function DOMRef
callback)
-----------------------------------------------------------------------------