-- | The event loop the backends share: event waiting and frame pacing, click
-- counting, the redraw decision, quit handling, and the drawing lock. A
-- backend supplies a 'SessionDriver' for event translation and presentation.
module NanoUI.Runner
  ( -- * Drawing Lock
    DrawingLock (..)
  , newDrawingLock
  , tryWithDrawingLock
    -- * Redraw Decision
  , shouldRedrawFrame
    -- * Session loop
  , SessionDriver (..)
  , runSessionLoop
  ) where

import Control.Concurrent (threadDelay)
import Control.Exception (finally, mask)
import Control.Monad (when)
import Data.IORef
  ( IORef
  , atomicModifyIORef'
  , newIORef
  , readIORef
  , writeIORef
  )
import GHC.Clock (getMonotonicTime)
import NanoUI.Context
  ( Context
  , anyAnimating
  , isDirty
  , overlayConsumesQuit
  , textInputEditActive
  )
import NanoUI.Debug
  ( DebugSamplerRef
  , debugRefreshDue
  , debugRefreshSec
  , isDebugActive
  , noteDebugLoop
  , noteDebugSkip
  )
import NanoUI.Frame.Redraw (needsRedraw, textFieldActive)
import NanoUI.Input
  ( Input (..)
  , clearEphemeral
  , inputDeltaTime
  , inputMouseClicks
  , inputMousePos
  , inputMousePressed
  , isHardQuitInput
  , splitFrame
  )
import NanoUI.Types (V2 (..))

-- | Standard upper bound for single-frame delta-time (50ms).
maxFrameDt :: Float
maxFrameDt :: Float
maxFrameDt = Float
0.05

-- | Wind forward to the next frame boundary after a timed-out event wait.
-- When pacing is active the backend requests a wait of ~period, but a one-shot
-- sleep lets frame starts drift by the scheduler's timer granularity (and land
-- late whenever the event waiter overruns), which reads as choppy animation on
-- uneven frame times. Sleep the bulk, then busy-wind the ≤1ms tail so frame
-- starts fall on uniform slices of the pacing period. The spin only runs when
-- an animation is actively presenting without vsync, and is bounded to about a
-- millisecond.
alignFrameStart :: Double -> Double -> IO ()
alignFrameStart :: Double -> Double -> IO ()
alignFrameStart Double
periodSec Double
lastT = do
  t0 <- IO Double
getMonotonicTime
  let target = Double
lastT Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
periodSec
      remain = Double
target Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0
      bulkUs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round ((Double
remain Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tailSlack) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e6))
  when (bulkUs > 0) (threadDelay bulkUs)
  fullSpin target
  where
    tailSlack :: Double
tailSlack = Double
2.5e-4
    fullSpin :: Double -> IO ()
fullSpin Double
target = do
      now <- IO Double
getMonotonicTime
      when (now < target) (fullSpin target)

-- | State for multi-click detection (double/triple click).
data ClickTrack = ClickTrack
  { ClickTrack -> Double
ctTime :: !Double
  , ClickTrack -> V2
ctPos :: !V2
  , ClickTrack -> Int
ctCount :: !Int
  }

-- | Stamp multi-click counts into an 'Input' record: presses within 5 pixels
-- and 0.4 seconds of the previous one count up to a triple click.
stampClicks :: IORef ClickTrack -> Input -> IO Input
stampClicks :: IORef ClickTrack -> Input -> IO Input
stampClicks IORef ClickTrack
ref Input
inp
  | Bool -> Bool
not (Input -> Bool
inputMousePressed Input
inp) = Input -> IO Input
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Input
inp
  | Bool
otherwise = do
      now <- IO Double
getMonotonicTime
      prev <- readIORef ref
      let t = ClickTrack -> Double
ctTime ClickTrack
prev
          n = ClickTrack -> Int
ctCount ClickTrack
prev
          V2 x y = inputMousePos inp
          V2 px py = ctPos prev
          dx = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
px
          dy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
py
          distSq = Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy
          close = Float
distSq Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
25
          quick = (Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0.4
          n' = if Bool
close Bool -> Bool -> Bool
&& Bool
quick then Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
3 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) else Int
1
      writeIORef ref ClickTrack {ctTime = now, ctPos = inputMousePos inp, ctCount = n'}
      pure (inp {inputMouseClicks = n'})

-- | Concurrency lock for drawing vs async callbacks (e.g. resize watchers).
newtype DrawingLock = DrawingLock (IORef Bool)

-- | Create a new unacquired drawing lock.
newDrawingLock :: IO DrawingLock
newDrawingLock :: IO DrawingLock
newDrawingLock = IORef Bool -> DrawingLock
DrawingLock (IORef Bool -> DrawingLock) -> IO (IORef Bool) -> IO DrawingLock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

-- | Attempt to execute an action under the drawing lock without blocking.
tryWithDrawingLock :: DrawingLock -> IO a -> IO (Maybe a)
tryWithDrawingLock :: forall a. DrawingLock -> IO a -> IO (Maybe a)
tryWithDrawingLock (DrawingLock IORef Bool
ref) IO a
act = ((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a))
-> ((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  ok <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
ref ((Bool -> (Bool, Bool)) -> IO Bool)
-> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Bool
busy -> if Bool
busy then (Bool
True, Bool
False) else (Bool
True, Bool
True)
  if ok
    then Just <$> (restore act `finally` writeIORef ref False)
    else pure Nothing

-- | Centralized decision predicate: should the host backend redraw this frame?
shouldRedrawFrame ::
  Context ->
  Input ->       -- ^ Previous input
  Input ->       -- ^ Current input
  Bool ->        -- ^ Was animating on previous frame?
  Bool ->        -- ^ Continuous redraw requested?
  Bool ->        -- ^ Debug live refresh requested?
  IO Bool
shouldRedrawFrame :: Context -> Input -> Input -> Bool -> Bool -> Bool -> IO Bool
shouldRedrawFrame Context
ctx Input
prevInp Input
curInp Bool
wasAnim Bool
continuous Bool
wantDebug = do
  if Bool
continuous Bool -> Bool -> Bool
|| Bool
wantDebug
    then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    else do
      -- 'needsRedraw' already covers a dirty context, running animations and
      -- an active text field, so an animation that just ended is the only
      -- animation case left: it needs one final frame.
      need <- Context -> Input -> Input -> IO Bool
needsRedraw Context
ctx Input
prevInp Input
curInp
      let pointerEdge =
            Input -> Bool
inputMousePressed Input
curInp
              Bool -> Bool -> Bool
|| Input -> Bool
inputMouseReleased Input
curInp
              Bool -> Bool -> Bool
|| Input -> Bool
inputMouseRightPressed Input
curInp
              Bool -> Bool -> Bool
|| Input -> Bool
inputMouseRightReleased Input
curInp
          scrollEdge = Input -> V2
inputScroll Input
curInp V2 -> V2 -> Bool
forall a. Eq a => a -> a -> Bool
/= Float -> Float -> V2
V2 Float
0 Float
0
      pure (need || wasAnim || pointerEdge || scrollEdge)

-- | What a backend provides to 'runSessionLoop'.
data SessionDriver ev = SessionDriver
  { forall ev. SessionDriver ev -> IO [ev]
sdPollEvents    :: IO [ev]
    -- ^ Non-blocking poll for pending backend events.
  , forall ev. SessionDriver ev -> Int -> IO [ev]
sdWaitEvents    :: Int -> IO [ev]
    -- ^ Wait for events with a timeout in milliseconds (-1 indicates blocking wait).
  , forall ev. SessionDriver ev -> Input -> ev -> Input
sdApplyEvent    :: Input -> ev -> Input
    -- ^ Fold an event into the 'Input' state.
  , forall ev. SessionDriver ev -> ev -> Bool
sdIsButtonEdge  :: ev -> Bool
    -- ^ Predicate identifying click/press boundaries where the event stream should be split.
  , forall ev. SessionDriver ev -> ev -> Bool
sdIsHardQuit    :: ev -> Bool
    -- ^ Predicate for immediate OS/SIGINT hard-quit signals (e.g. Ctrl+C).
  , forall ev. SessionDriver ev -> ev -> Bool
sdIsSessionQuit :: ev -> Bool
    -- ^ Predicate for window close requests.
  , forall ev.
SessionDriver ev -> Context -> Input -> IO (Context, Input)
sdSyncDisplay   :: Context -> Input -> IO (Context, Input)
    -- ^ Backend-specific display synchronization (window dimensions, DPI scale).
  , forall ev. SessionDriver ev -> DebugSamplerRef
sdDebug         :: DebugSamplerRef
    -- ^ The session's debug sampler: loop timing, skips, and the 4 Hz
    -- readout refresh.
  , forall ev. SessionDriver ev -> Bool
sdContinuous    :: !Bool
    -- ^ Redraw every pass without waiting for events.
  , forall ev. SessionDriver ev -> Int
sdPacingMs      :: !Int
    -- ^ Event wait in milliseconds while something animates or a text field
    -- is being edited.
  , forall ev. SessionDriver ev -> IO Bool
sdPresentPaces  :: IO Bool
    -- ^ Whether the last present waited for the display (vsync), so a running
    -- animation can loop without waiting and still be frame-locked.
  , forall ev. SessionDriver ev -> Double
sdAlignSec      :: Double
    -- ^ Frame pacing period in seconds for the timed-out wait path. Frame
    -- starts are wound onto a uniform grid of this period so animation
    -- cadence matches the host, instead of drifting with the event waiter's
    -- timer granularity.
  , forall ev.
SessionDriver ev
-> Context -> Input -> Input -> Bool -> Bool -> IO Bool
sdShouldDraw    :: Context -> Input -> Input -> Bool -> Bool -> IO Bool
    -- ^ Decision predicate: (ctx, prevInp, curInp, wasAnimating, debugDue) ->
    -- should this frame be rendered? Usually 'shouldRedrawFrame'.
  , forall ev.
SessionDriver ev -> Context -> Input -> Bool -> IO (Bool, Input)
sdDraw          :: Context -> Input -> Bool -> IO (Bool, Input)
    -- ^ Render frame: (ctx, curInp, forceFull) -> (dirtyAfterRender, syncedInput).
  , forall ev. SessionDriver ev -> Context -> Input -> IO ()
sdOnCursor      :: Context -> Input -> IO ()
    -- ^ Sync the host cursor icon after every pass.
  , forall ev. SessionDriver ev -> Input -> Bool
sdShouldQuit    :: Input -> Bool
    -- ^ Application-level quit predicate.
  }

-- | Event wait while only the debug readout needs frames: its refresh period.
debugHudTimeout :: Int
debugHudTimeout :: Int
debugHudTimeout = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
debugRefreshSec Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000)

-- | Run an event-driven session loop until a termination event or user quit condition.
runSessionLoop ::
  SessionDriver ev ->
  Context ->
  Input ->
  IO ()
runSessionLoop :: forall ev. SessionDriver ev -> Context -> Input -> IO ()
runSessionLoop SessionDriver ev
drv Context
ctx0 Input
inp0 = do
  clickTracker <- ClickTrack -> IO (IORef ClickTrack)
forall a. a -> IO (IORef a)
newIORef ClickTrack {ctTime :: Double
ctTime = Double
0, ctPos :: V2
ctPos = Float -> Float -> V2
V2 (-Float
999) (-Float
999), ctCount :: Int
ctCount = Int
0}
  startT <- getMonotonicTime

  let waitForEvents Int
timeout Double
lastT
        | Int
timeout Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SessionDriver ev -> Int -> IO [ev]
forall ev. SessionDriver ev -> Int -> IO [ev]
sdWaitEvents SessionDriver ev
drv (-Int
1)
        | Bool
otherwise = do
            polled <- SessionDriver ev -> IO [ev]
forall ev. SessionDriver ev -> IO [ev]
sdPollEvents SessionDriver ev
drv
            if not (null polled)
              then pure polled
              else do
                events <- sdWaitEvents drv timeout
                -- Only a timed-out paced wait needs frame alignment.
                when (timeout > 0 && null events) $
                  alignFrameStart (sdAlignSec drv) lastT
                pure events

      loop Context
ctx Input
inp [ev]
queued Double
lastT Bool
pendingDirty Bool
wasAnim = do
        (pending, debugDue) <-
          if Bool -> Bool
not ([ev] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ev]
queued)
            then ([ev], Bool) -> IO ([ev], Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ev]
queued, Bool
False)
            else if Bool
pendingDirty
              then (,Bool
False) ([ev] -> ([ev], Bool)) -> IO [ev] -> IO ([ev], Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Double -> IO [ev]
waitForEvents Int
0 Double
lastT
              else do
                debugActive <- DebugSamplerRef -> IO Bool
isDebugActive (SessionDriver ev -> DebugSamplerRef
forall ev. SessionDriver ev -> DebugSamplerRef
sdDebug SessionDriver ev
drv)
                refreshDue <- debugRefreshDue (sdDebug drv)
                animating <- anyAnimating ctx
                editing <- textFieldActive ctx
                dirty <- isDirty ctx
                presentPaces <- sdPresentPaces drv
                let dueNow = Bool
debugActive Bool -> Bool -> Bool
&& Bool
refreshDue
                    timeout
                      | SessionDriver ev -> Bool
forall ev. SessionDriver ev -> Bool
sdContinuous SessionDriver ev
drv Bool -> Bool -> Bool
|| Bool
dueNow Bool -> Bool -> Bool
|| Bool
dirty Bool -> Bool -> Bool
|| (Bool
animating Bool -> Bool -> Bool
&& Bool
presentPaces) = Int
0
                      | Bool
wasAnim Bool -> Bool -> Bool
|| Bool
animating Bool -> Bool -> Bool
|| Bool
editing = SessionDriver ev -> Int
forall ev. SessionDriver ev -> Int
sdPacingMs SessionDriver ev
drv
                      | Bool
debugActive = Int
debugHudTimeout
                      | Bool
otherwise = -Int
1
                events <- waitForEvents timeout lastT
                -- A readout wait that timed out ends on its refresh.
                pure (events, dueNow || (timeout == debugHudTimeout && debugActive && null events))

        let (group, rest) = splitFrame (sdIsButtonEdge drv) pending
        editActive <- textInputEditActive ctx
        let hardQuitEv = (ev -> Bool) -> [ev] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SessionDriver ev -> ev -> Bool
forall ev. SessionDriver ev -> ev -> Bool
sdIsHardQuit SessionDriver ev
drv) [ev]
group Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
editActive
            sessionQuitEv = (ev -> Bool) -> [ev] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SessionDriver ev -> ev -> Bool
forall ev. SessionDriver ev -> ev -> Bool
sdIsSessionQuit SessionDriver ev
drv) [ev]
group
        if hardQuitEv || sessionQuitEv
          then pure ()
          else do
            now <- getMonotonicTime
            let !dt = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxFrameDt (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lastT))
            noteDebugLoop (sdDebug drv) dt
            let inpFolded = (Input -> ev -> Input) -> Input -> [ev] -> Input
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SessionDriver ev -> Input -> ev -> Input
forall ev. SessionDriver ev -> Input -> ev -> Input
sdApplyEvent SessionDriver ev
drv) (Input -> Input
clearEphemeral Input
inp {inputDeltaTime = dt}) [ev]
group
            inpStamped <- stampClicks clickTracker inpFolded
            (ctx', inpSynced) <- sdSyncDisplay drv ctx inpStamped
            -- Hard quit (e.g. Ctrl+C) is ignored while a text editor is active.
            editActiveSynced <- textInputEditActive ctx'
            if isHardQuitInput inpSynced && not editActiveSynced
              then pure ()
              else do
                shouldDraw <- if pendingDirty
                  then pure True
                  else sdShouldDraw drv ctx' inp inpSynced wasAnim debugDue
                -- Force a full present only on the settle frame where an
                -- animation just finished (wasAnim && not animNow), so running
                -- animations keep clip damage.
                animNow <- anyAnimating ctx'
                (dirtyOut, synced) <- if shouldDraw
                  then sdDraw drv ctx' inpSynced (wasAnim && not animNow)
                  else do
                    noteDebugSkip (sdDebug drv)
                    pure (pendingDirty, inpSynced)
                sdOnCursor drv ctx' synced
                animAfter <- anyAnimating ctx'
                -- Open modals/overlays consume Escape/Quit before the app sees it.
                overlayQuit <- overlayConsumesQuit ctx' synced
                if sdShouldQuit drv synced && not overlayQuit
                  then pure ()
                  else loop ctx' synced rest now dirtyOut animAfter

  loop ctx0 inp0 [] startT False False