-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Native.MainThread
-- 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
--
-- = Main-thread (MTS) imperative element manipulation
--
-- Helpers for /main-thread events/ on the Lynx dual-thread runtime. A handler
-- registered for a 'Miso.Event.Types.MTS' event (see
-- 'Miso.Event.Types.mainThreadEvents') runs synchronously on the main thread and
-- receives the target 'DOMRef' via a @*With@ combinator
-- (e.g. 'Miso.Native.Element.View.Event.onTapWith'). Such a handler must be
-- __imperative__: it mutates the element directly with the functions below.
--
-- It does __not__ go through the VDOM diff — no re-render, no patches, no
-- background-thread round-trip. This is the low-latency path for gestures and
-- scroll-linked animation.
--
-- @
-- -- move an element with the finger, entirely on the main thread:
-- view _ _ _ = view_ [ onTouchMoveWith Drag ] []
--
-- update (Drag touch domRef) = io_ $
--   setStyleProperty domRef \"transform\"
--     (\"translateY(\" <> ms (touchY touch) <> \"px)\")
-- @
--
-- __Conflict caveat.__ A property you drive imperatively here must /not/ also be
-- set declaratively by the background-thread @view@ for the same element: both
-- threads write the shared element tree through the same PAPI, with no
-- arbitration, so the next background re-render would clobber it (and vice
-- versa). Keep a single owner per @(element, property)@ — typically compositor
-- properties like @transform@ / @opacity@ that the @view@ leaves alone. This is
-- the same discipline Lynx itself requires; it is not enforced.
--
-- These call Lynx element PAPI globals and are only meaningful on the native
-- runtime's main thread.
----------------------------------------------------------------------------
module Miso.Native.MainThread
  ( -- *** Imperative element mutation (main thread only)
    setStyleProperty
  , setStyleProperties
  , setStylePropertyTransform
  , setAttribute
  , getAttribute
  , flushElementTree
    -- *** Element-tree navigation (main thread only)
  , firstElementChild
  , nextElementSibling
  , parentElement
    -- *** Frame-driven animation (main thread only)
  , eachFrame
    -- *** Platform info (main thread only)
  , SystemInfo(..)
  , getSystemInfo
    -- *** Main-thread-local mutable state
  , MainThreadRef
  , mainThreadRef
  , readMainThreadRef
  , writeMainThreadRef
  , modifyMainThreadRef
  , modifyMainThreadRef_
  ) where
-----------------------------------------------------------------------------
import           Control.Monad (void, forM_)
import           Control.Monad.State (State, execState)
import           Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef')
import           System.IO.Unsafe (unsafePerformIO)
-----------------------------------------------------------------------------
import           Miso.CSS (transforms, TransformFn)
import           Miso.DSL
  ( jsg, jsg0, jsg1, jsg2, jsg3, (!), isUndefined, FromJSVal(..)
  , requestAnimationFrame, syncCallback1, freeFunction, Function(..), jsNull )
import           GHC.Generics (Generic)
import           Miso.Effect (DOMRef)
import           Miso.JSON (ToJSON(..), FromJSON(..), Value(Null))
import           Miso.String (MisoString)
-----------------------------------------------------------------------------
-- | Lets a target 'DOMRef' ride inside a @*With@ handler's action. Native
-- component actions must be @ToJSON@\/@FromJSON@, but a raw 'DOMRef' (a
-- @JSVal@) has no meaningful serialization — and main-thread actions never
-- cross the thread boundary anyway, so these are __inert placeholders__:
-- 'toJSON' is @Null@ and 'parseJSON' fails. Only import "Miso.Native.MainThread"
-- where you actually dispatch main-thread events.
--
-- ⚠ These are global orphan instances for @JSVal@; do not rely on round-tripping
-- a 'DOMRef' through JSON anywhere.
instance ToJSON DOMRef where
  toJSON :: JSVal -> Value
toJSON JSVal
_ = Value
Null
instance FromJSON DOMRef where
  parseJSON :: Value -> Parser JSVal
parseJSON Value
_ = String -> Parser JSVal
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"DOMRef: main-thread-only, never deserialized"
-----------------------------------------------------------------------------
-- | Set a single inline style property on the element, then flush.
--
-- > setStyleProperty domRef "transform" "translateX(20px)"
setStyleProperty :: DOMRef -> MisoString -> MisoString -> IO ()
setStyleProperty :: JSVal -> MisoString -> MisoString -> IO ()
setStyleProperty JSVal
node MisoString
name MisoString
value = do
  IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> JSVal -> MisoString -> MisoString -> IO JSVal
forall arg1 arg2 arg3.
(ToJSVal arg1, ToJSVal arg2, ToJSVal arg3) =>
MisoString -> arg1 -> arg2 -> arg3 -> IO JSVal
jsg3 MisoString
"__AddInlineStyle" JSVal
node MisoString
name MisoString
value)
  IO ()
flushElementTree
-----------------------------------------------------------------------------
-- | Set several inline style properties, then flush once.
setStyleProperties :: DOMRef -> [(MisoString, MisoString)] -> IO ()
setStyleProperties :: JSVal -> [(MisoString, MisoString)] -> IO ()
setStyleProperties JSVal
node [(MisoString, MisoString)]
styles = do
  [(MisoString, MisoString)]
-> ((MisoString, MisoString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(MisoString, MisoString)]
styles (((MisoString, MisoString) -> IO ()) -> IO ())
-> ((MisoString, MisoString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(MisoString
name, MisoString
value) ->
    IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> JSVal -> MisoString -> MisoString -> IO JSVal
forall arg1 arg2 arg3.
(ToJSVal arg1, ToJSVal arg2, ToJSVal arg3) =>
MisoString -> arg1 -> arg2 -> arg3 -> IO JSVal
jsg3 MisoString
"__AddInlineStyle" JSVal
node MisoString
name MisoString
value)
  IO ()
flushElementTree
-----------------------------------------------------------------------------
-- | Set the element's @transform@ from a list of typed t'Miso.CSS.TransformFn's
-- (from "Miso.CSS"), then flush — a typed alternative to writing the
-- @transform@ string by hand.
--
-- > setStylePropertyTransform ref [ CSS.translateX (CSS.px 20) ]
setStylePropertyTransform :: DOMRef -> [TransformFn] -> IO ()
setStylePropertyTransform :: JSVal -> [TransformFn] -> IO ()
setStylePropertyTransform JSVal
node [TransformFn]
fns = JSVal -> [(MisoString, MisoString)] -> IO ()
setStyleProperties JSVal
node [ [TransformFn] -> (MisoString, MisoString)
transforms [TransformFn]
fns ]
-----------------------------------------------------------------------------
-- | Set an attribute on the element, then flush.
setAttribute :: DOMRef -> MisoString -> MisoString -> IO ()
setAttribute :: JSVal -> MisoString -> MisoString -> IO ()
setAttribute JSVal
node MisoString
key MisoString
value = do
  IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> JSVal -> MisoString -> MisoString -> IO JSVal
forall arg1 arg2 arg3.
(ToJSVal arg1, ToJSVal arg2, ToJSVal arg3) =>
MisoString -> arg1 -> arg2 -> arg3 -> IO JSVal
jsg3 MisoString
"__SetAttribute" JSVal
node MisoString
key MisoString
value)
  IO ()
flushElementTree
-----------------------------------------------------------------------------
-- | Read an attribute's current value from the element.
getAttribute :: DOMRef -> MisoString -> IO MisoString
getAttribute :: JSVal -> MisoString -> IO MisoString
getAttribute JSVal
node MisoString
key =
  JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked (JSVal -> IO MisoString) -> IO JSVal -> IO MisoString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> JSVal -> MisoString -> IO JSVal
forall arg1 arg2.
(ToJSVal arg1, ToJSVal arg2) =>
MisoString -> arg1 -> arg2 -> IO JSVal
jsg2 MisoString
"__GetAttributeByName" JSVal
node MisoString
key
-----------------------------------------------------------------------------
-- | Commit pending element-tree mutations to the screen. The @set*@ helpers
-- above already flush; call this directly only when batching lower-level calls.
flushElementTree :: IO ()
flushElementTree :: IO ()
flushElementTree = IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> IO JSVal
jsg0 MisoString
"__FlushElementTree")
-----------------------------------------------------------------------------
-- | First element child of a node (Lynx @__FirstElement@). Lets a main-thread
-- handler reach a /different/ element than the event target by walking the
-- tree — e.g. from a scroll handler's list ref to a sibling scrollbar thumb.
firstElementChild :: DOMRef -> IO DOMRef
firstElementChild :: JSVal -> IO JSVal
firstElementChild = MisoString -> JSVal -> IO JSVal
forall arg. ToJSVal arg => MisoString -> arg -> IO JSVal
jsg1 MisoString
"__FirstElement"
-----------------------------------------------------------------------------
-- | Next element sibling of a node (Lynx @__NextElement@).
nextElementSibling :: DOMRef -> IO DOMRef
nextElementSibling :: JSVal -> IO JSVal
nextElementSibling = MisoString -> JSVal -> IO JSVal
forall arg. ToJSVal arg => MisoString -> arg -> IO JSVal
jsg1 MisoString
"__NextElement"
-----------------------------------------------------------------------------
-- | Parent element of a node (Lynx @__GetParent@).
parentElement :: DOMRef -> IO DOMRef
parentElement :: JSVal -> IO JSVal
parentElement = MisoString -> JSVal -> IO JSVal
forall arg. ToJSVal arg => MisoString -> arg -> IO JSVal
jsg1 MisoString
"__GetParent"
-----------------------------------------------------------------------------
-- | Drive @step@ once per animation frame until it returns 'False', then release
-- the underlying callback. @step@ receives the frame timestamp in milliseconds.
--
-- This is the vsync-coalesced loop primitive for main-thread, scroll-linked
-- animation: read the latest gesture state, imperatively paint at most once per
-- frame (via 'setStyleProperty' \/ 'setStylePropertyTransform'), and stop by
-- returning 'False' when the gesture ends.
--
-- @
-- startFollow ref = 'eachFrame' $ \\_ts -> do
--   d <- readDrag
--   if not (active d) then pure False else do
--     setStylePropertyTransform ref [ CSS.translateX (CSS.px (offset d)) ]
--     pure True
-- @
eachFrame :: (Double -> IO Bool) -> IO ()
eachFrame :: (Double -> IO Bool) -> IO ()
eachFrame Double -> IO Bool
step = do
  cbRef <- JSVal -> IO (IORef JSVal)
forall a. a -> IO (IORef a)
newIORef JSVal
jsNull
  let frame JSVal
tsVal = do
        keep <- Double -> IO Bool
step (Double -> IO Bool) -> IO Double -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO Double
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
tsVal
        cb   <- readIORef cbRef
        if keep
          then void (requestAnimationFrame cb)
          else freeFunction (Function cb)
  cb <- syncCallback1 frame
  writeIORef cbRef cb
  void (requestAnimationFrame cb)
-----------------------------------------------------------------------------
-- | Lynx's @lynx.SystemInfo@: device pixel geometry and platform metadata. The
-- field names match the Lynx @SystemInfo@ object, so it decodes directly. Fields
-- that Lynx omits on some realms are 'Maybe' — notably 'runtimeType', which is
-- unavailable in the lepus (main-thread) runtime.
data SystemInfo = SystemInfo
  { SystemInfo -> Double
pixelWidth     :: Double
    -- ^ Physical pixel width of the device.
  , SystemInfo -> Double
pixelHeight    :: Double
    -- ^ Physical pixel height of the device.
  , SystemInfo -> Double
pixelRatio     :: Double
    -- ^ Physical pixel ratio (device pixels per logical pixel).
  , SystemInfo -> MisoString
osVersion      :: MisoString
    -- ^ Operating-system version.
  , SystemInfo -> MisoString
platform       :: MisoString
    -- ^ Device platform, e.g. @\"Android\"@, @\"iOS\"@, @\"macOS\"@.
  , SystemInfo -> Maybe MisoString
lynxSdkVersion :: Maybe MisoString
    -- ^ Lynx SDK version (deprecated upstream; may be absent).
  , SystemInfo -> Maybe MisoString
engineVersion  :: Maybe MisoString
    -- ^ Lynx Engine version (absent on older engines).
  , SystemInfo -> Maybe MisoString
runtimeType    :: Maybe MisoString
    -- ^ JS engine (@\"v8\"@ \/ @\"jsc\"@ \/ @\"quickjs\"@); not available in lepus.
  , SystemInfo -> Maybe Value
theme          :: Maybe Value
    -- ^ Opaque theme object, when present.
  } deriving (Int -> SystemInfo -> ShowS
[SystemInfo] -> ShowS
SystemInfo -> String
(Int -> SystemInfo -> ShowS)
-> (SystemInfo -> String)
-> ([SystemInfo] -> ShowS)
-> Show SystemInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SystemInfo -> ShowS
showsPrec :: Int -> SystemInfo -> ShowS
$cshow :: SystemInfo -> String
show :: SystemInfo -> String
$cshowList :: [SystemInfo] -> ShowS
showList :: [SystemInfo] -> ShowS
Show, SystemInfo -> SystemInfo -> Bool
(SystemInfo -> SystemInfo -> Bool)
-> (SystemInfo -> SystemInfo -> Bool) -> Eq SystemInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SystemInfo -> SystemInfo -> Bool
== :: SystemInfo -> SystemInfo -> Bool
$c/= :: SystemInfo -> SystemInfo -> Bool
/= :: SystemInfo -> SystemInfo -> Bool
Eq, (forall x. SystemInfo -> Rep SystemInfo x)
-> (forall x. Rep SystemInfo x -> SystemInfo) -> Generic SystemInfo
forall x. Rep SystemInfo x -> SystemInfo
forall x. SystemInfo -> Rep SystemInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SystemInfo -> Rep SystemInfo x
from :: forall x. SystemInfo -> Rep SystemInfo x
$cto :: forall x. Rep SystemInfo x -> SystemInfo
to :: forall x. Rep SystemInfo x -> SystemInfo
Generic)

instance FromJSVal SystemInfo

-- | Read Lynx's @lynx.SystemInfo@, decoded into 'SystemInfo'. This global is
-- main-thread-only: present on the MTS realm and absent on the BTS realm, so
-- this returns 'Just' on the main thread and 'Nothing' on the background thread.
-- The @undefined@ guard makes the background-thread read a safe 'Nothing' rather
-- than a throw; a decode failure (e.g. a required field missing) is also
-- 'Nothing'.
getSystemInfo :: IO (Maybe SystemInfo)
getSystemInfo :: IO (Maybe SystemInfo)
getSystemInfo = do
  si <- MisoString -> IO JSVal
jsg MisoString
"lynx" IO JSVal -> (JSVal -> IO JSVal) -> IO JSVal
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"SystemInfo")
  u  <- isUndefined si
  if u then pure Nothing else fromJSVal si
-----------------------------------------------------------------------------
-- | A thin wrapper over 'IORef' for state that lives __only__ on the main
-- thread and must never reach the background thread's shared @model@ (which the
-- BTS solely owns — see "Miso.Runtime"). Use it for transient, main-thread-local
-- gesture\/animation state: the current drag offset, a fling velocity, whether a
-- follow loop is active, etc.
--
-- Reads and writes are ordinary 'IORef' operations, safe here because the MTS is
-- single-threaded; no atomics are needed.
newtype MainThreadRef a = MainThreadRef (IORef a)
-----------------------------------------------------------------------------
-- | Create a top-level 'MainThreadRef' with an initial value.
--
-- This uses 'unsafePerformIO' to allocate the underlying 'IORef' as a CAF, so
-- the ref is shared across all uses of the binding. __You must give every
-- top-level 'MainThreadRef' binding a @{-\# NOINLINE \#-}@ pragma__ — otherwise
-- GHC may inline the CAF and allocate a fresh, independent 'IORef' at each use
-- site, silently splitting your state into multiple copies.
--
-- @
-- dragRef :: 'MainThreadRef' Double
-- dragRef = 'mainThreadRef' 0
-- {-\# NOINLINE dragRef \#-}
-- @
mainThreadRef :: a -> MainThreadRef a
mainThreadRef :: forall a. a -> MainThreadRef a
mainThreadRef a
x = IORef a -> MainThreadRef a
forall a. IORef a -> MainThreadRef a
MainThreadRef (IO (IORef a) -> IORef a
forall a. IO a -> a
unsafePerformIO (a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
x))
{-# NOINLINE mainThreadRef #-}
-----------------------------------------------------------------------------
-- | Read the current value of a 'MainThreadRef'.
readMainThreadRef :: MainThreadRef a -> IO a
readMainThreadRef :: forall a. MainThreadRef a -> IO a
readMainThreadRef (MainThreadRef IORef a
ref) = IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref
-----------------------------------------------------------------------------
-- | Overwrite the value of a 'MainThreadRef'.
writeMainThreadRef :: MainThreadRef a -> a -> IO ()
writeMainThreadRef :: forall a. MainThreadRef a -> a -> IO ()
writeMainThreadRef (MainThreadRef IORef a
ref) = IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref
-----------------------------------------------------------------------------
-- | Strictly modify the value of a 'MainThreadRef'.
modifyMainThreadRef :: MainThreadRef a -> (a -> a) -> IO ()
modifyMainThreadRef :: forall a. MainThreadRef a -> (a -> a) -> IO ()
modifyMainThreadRef (MainThreadRef IORef a
ref) = IORef a -> (a -> a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef a
ref
-----------------------------------------------------------------------------
-- | Strictly modify a 'MainThreadRef' with a @'State' a ()@ computation, letting
-- you drive the update with the "Miso.Lens" operators (@.=@, @%=@, @+=@, …).
--
-- @
-- modifyMainThreadRef_ dragRef $ do
--   offset '.=' newX
--   active '.=' True
-- @
modifyMainThreadRef_ :: MainThreadRef a -> State a () -> IO ()
modifyMainThreadRef_ :: forall a. MainThreadRef a -> State a () -> IO ()
modifyMainThreadRef_ MainThreadRef a
ref State a ()
go = MainThreadRef a -> (a -> a) -> IO ()
forall a. MainThreadRef a -> (a -> a) -> IO ()
modifyMainThreadRef MainThreadRef a
ref (State a () -> a -> a
forall s a. State s a -> s -> s
execState State a ()
go)
-----------------------------------------------------------------------------