{-# LANGUAGE DataKinds #-}

module NanoUI.Frame
  ( runFrame
  , runFrameEff
  , runFrameReduce
  , runFrameReduceEff
  , needsRedraw
  , pointerDragActive
  , textFieldActive
  , floatingPanelActive
  , debugPanelOpen
  , collectTextSpans
  , collectOverlayTextSpans
  , collectRasterSpans
  , widgetNodeCount
  , pointerCursorWanted
  , cursorKindIs
  , uiCursorKind
  , UiCursorKind (..)
  )
where

import Control.Monad (unless, when)
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.IntMap.Strict qualified as IM
import Data.Typeable (Typeable)
import Effectful (Eff, IOE, runEff, type (:>))
import NanoUI.Context
  ( Context (..)
  , armMenuPointerCapture
  , beginThemeScopes
  , damageFull
  , themeScopesChanged
  , FrameMsg (..)
  , clearDirty
  , decodeMessages
  , drainMessages
  , getLiveAnimations
  , getPrevRect
  , getStore
  , isDirty
  , lookupPopupConfig
  , markDirty
  , pruneDrawOpCache
  , resetDrawingScopeCache
  , setMenuPointerGesture
  , stepScrollGlides
  , takeDamage
  , tickAnimations
  , hasCustomLayoutInputs
  , ensureMetricCaches
  , InteractionState (..)
  , getsOverlay
  , OverlayState (..)
  , getsDamage
  , DamageState (..)
  , modifyInteraction
  )
import NanoUI.Context (beginFrameModal)
import NanoUI.Damage (FrameSnapshot (..), updatePrevRects, writeDamage)
import NanoUI.Draw
  ( DrawData
  , Layer (..)
  , beginLayer
  , finishDraw
  , pushRect
  , resetDrawArena
  , setClip
  )
import NanoUI.Frame.Cursor
  ( UiCursorKind (..)
  , cursorKindIs
  , pointerCursorWanted
  , uiCursorKind
  )
import NanoUI.Frame.Input
  ( armPointerPress
  , disarmPointerPress
  , finalizePointerPress
  , finalizePointerRelease
  , finalizeSelectFocus
  , finalizeTabFocus
  , finalizeTextInputFocus
  , refreshHover
  )
import NanoUI.Frame.Focus (constrainFocusToModal, syncWidgetLabels)
import NanoUI.Frame.Paint (lowerShapes)
import NanoUI.Frame.Redraw
  ( debugPanelOpen
  , floatingPanelActive
  , needsRedraw
  , overlayMenuOpen
  , pointerDragActive
  , textFieldActive
  )
import NanoUI.Frame.Scroll
  ( applyScrollOffsets
  , updateScrollDrag
  , updateScrollWheel
  )
import NanoUI.Frame.Select
  ( cacheOpenSelectDrop
  , closeSelectOnOutsideClick
  , drawSelectOverlays
  , finalizeSelectKeyboard
  , finalizeSelectPick
  , markSelectDropPress
  )
import NanoUI.Frame.Spans
  ( collectOverlayTextSpans
  , collectRasterSpans
  , collectTextSpans
  , widgetNodeCount
  )
import NanoUI.Frame.Overlay (drawModalOverlays, drawPopupOverlays, drawWindowOverlays)
import NanoUI.Frame.TextEdit (finalizeTextFieldMouse)
import NanoUI.Frame.TextEdit.Menu
  ( closeTextEditMenuOnEscape
  , closeTextEditMenuOnOutsideClick
  , drawTextEditMenuOverlays
  , finalizeTextEditMenuPick
  , openTextEditMenu
  )
import NanoUI.Frame.Window
  ( contextMeasurers
  , lookupWindowPos
  , lookupWindowSize
  , persistWindowPositions
  , updateWindowDrag
  , updateWindowResize
  )
import NanoUI.Id (WidgetId (..), initialIdContext)
import NanoUI.Input (Input (..), inputMouseDown, stripInteractionInput)
import NanoUI.Layout.Arena
  ( captureLayoutCache
  , layoutCacheEligible
  , layoutInputsMatch
  , newLayoutCache
  , resetNodeArena
  , restoreLayoutCache
  )
import NanoUI.Layout.Solve (placeModals, placePopups, placeWindows, solveLayout)
import NanoUI.Monad (NanoUI, Ui, runUi, whenM)
import NanoUI.Store (mirrorStoresChanged)
import NanoUI.Style (Theme (..))
import NanoUI.Types (Damage (..), Size (..), rectInflate, rectNonEmpty)

runFrame :: Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame :: forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame = (forall x. Eff '[IOE] x -> IO x)
-> Context
-> Input
-> Eff '[Ui, IOE] a
-> IO (a, [FrameMsg], DrawData, Bool)
forall (es :: [(* -> *) -> * -> *]) a.
(IOE :> es) =>
(forall x. Eff es x -> IO x)
-> Context
-> Input
-> Eff (Ui : es) a
-> IO (a, [FrameMsg], DrawData, Bool)
runFrameEff Eff '[IOE] x -> IO x
forall a. HasCallStack => Eff '[IOE] a -> IO a
forall x. Eff '[IOE] x -> IO x
runEff

-- View this model, then apply decoded messages at frame end.
-- DrawData is from the pre-reduce model (one-frame lag). The idle
-- loop redraws when the reduced model differs.
runFrameReduce ::
  (Typeable msg, Eq model) =>
  (msg -> model -> model)
  -> Context
  -> Input
  -> model
  -> (model -> NanoUI a)
  -> IO (a, model, [msg], DrawData, Bool)
runFrameReduce :: forall msg model a.
(Typeable msg, Eq model) =>
(msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> NanoUI a)
-> IO (a, model, [msg], DrawData, Bool)
runFrameReduce = (forall x. Eff '[IOE] x -> IO x)
-> (msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> Eff '[Ui, IOE] a)
-> IO (a, model, [msg], DrawData, Bool)
forall (es :: [(* -> *) -> * -> *]) msg model a.
(IOE :> es, Typeable msg, Eq model) =>
(forall x. Eff es x -> IO x)
-> (msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> Eff (Ui : es) a)
-> IO (a, model, [msg], DrawData, Bool)
runFrameReduceEff Eff '[IOE] x -> IO x
forall a. HasCallStack => Eff '[IOE] a -> IO a
forall x. Eff '[IOE] x -> IO x
runEff

runFrameReduceEff ::
  (IOE :> es, Typeable msg, Eq model) =>
  (forall x. Eff es x -> IO x)
  -> (msg -> model -> model)
  -> Context
  -> Input
  -> model
  -> (model -> Eff (Ui : es) a)
  -> IO (a, model, [msg], DrawData, Bool)
runFrameReduceEff :: forall (es :: [(* -> *) -> * -> *]) msg model a.
(IOE :> es, Typeable msg, Eq model) =>
(forall x. Eff es x -> IO x)
-> (msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> Eff (Ui : es) a)
-> IO (a, model, [msg], DrawData, Bool)
runFrameReduceEff forall x. Eff es x -> IO x
unlift msg -> model -> model
update Context
ctx Input
inp model
model model -> Eff (Ui : es) a
view = do
  (a, msgs, draw, dirty) <- (forall x. Eff es x -> IO x)
-> Context
-> Input
-> Eff (Ui : es) a
-> IO (a, [FrameMsg], DrawData, Bool)
forall (es :: [(* -> *) -> * -> *]) a.
(IOE :> es) =>
(forall x. Eff es x -> IO x)
-> Context
-> Input
-> Eff (Ui : es) a
-> IO (a, [FrameMsg], DrawData, Bool)
runFrameEff Eff es x -> IO x
forall x. Eff es x -> IO x
unlift Context
ctx Input
inp (model -> Eff (Ui : es) a
view model
model)
  let
    typed = [FrameMsg] -> [msg]
forall (f :: * -> *) a.
(Foldable f, Typeable a) =>
f FrameMsg -> [a]
decodeMessages [FrameMsg]
msgs
    model' = (model -> msg -> model) -> model -> [msg] -> model
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((msg -> model -> model) -> model -> msg -> model
forall a b c. (a -> b -> c) -> b -> a -> c
flip msg -> model -> model
update) model
model [msg]
typed
  when (model' /= model) (markDirty ctx)
  dirty' <- isDirty ctx
  pure (a, model', typed, draw, dirty || dirty')

runFrameEff ::
  IOE :> es =>
  (forall x. Eff es x -> IO x)
  -> Context
  -> Input
  -> Eff (Ui : es) a
  -> IO (a, [FrameMsg], DrawData, Bool)
runFrameEff :: forall (es :: [(* -> *) -> * -> *]) a.
(IOE :> es) =>
(forall x. Eff es x -> IO x)
-> Context
-> Input
-> Eff (Ui : es) a
-> IO (a, [FrameMsg], DrawData, Bool)
runFrameEff forall x. Eff es x -> IO x
unlift Context
ctx Input
inp Eff (Ui : es) a
ui = do
  Context -> IO ()
ensureMetricCaches Context
ctx
  oldHot <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxLastHotId Context
ctx)
  oldActive <- readIORef (ctxActiveId ctx)
  oldFocus <- readIORef (ctxFocusId ctx)
  oldHotRect <- getPrevRect ctx oldHot
  oldActiveRect <- getPrevRect ctx oldActive
  oldFocusRect <- getPrevRect ctx oldFocus
  oldFloatingRects <- getsOverlay ctx osPrevFloatingRects
  oldRects <- getsDamage ctx dsPrevRects
  oldTexts <- getsDamage ctx dsPrevNodeTexts
  oldSize <- getsDamage ctx dsLastWindowSize
  oldStore <- getStore ctx
  wasDirty <- isDirty ctx
  clearDirty ctx
  animKeys <- IM.keysSet <$> getLiveAnimations ctx
  -- Wheel and thumb-drag input targets the previous frame's layout, so apply
  -- it while that arena is still intact, before it is reset for the new
  -- build. Settling offsets before the UI pass keeps build-time
  -- virtualization (table body rows) materialized for the range that will
  -- actually be visible, without a second build pass.
  updateScrollWheel ctx inp
  -- A glide advances with the wheel, before the build, for the same reason:
  -- the offset this frame renders at is the one virtualization must see.
  stepScrollGlides ctx (inputDeltaTime inp)
  updateScrollDrag ctx inp
  beginThemeScopes ctx True
  resetNodeArena (ctxNodeArena ctx)
  resetDrawArena (ctxDrawArena ctx)
  resetUiBuildScopes ctx
  unless (inputMouseDown inp) $
    modifyInteraction ctx (\InteractionState
s -> InteractionState
s {isSelectDropPress = False})
  when (not (inputMouseDown inp) && not (inputMouseReleased inp)) $
    setMenuPointerGesture ctx False
  beginFrameModal ctx
  writeIORef (ctxReleaseClickedId ctx) (WidgetId 0)
  armMenuPointerCapture ctx inp
  armPointerPress ctx inp
  result0 <- unlift (runUi ctx inp ui)
  -- Pending click is one-shot. Clear before a mirror rebuild so toggles do not fire twice.
  writeIORef (ctxClickedId ctx) (WidgetId 0)
  storeMid <- getStore ctx
  result <-
    if mirrorStoresChanged oldStore storeMid
      then do
        resetUiBuild ctx
        unlift (runUi ctx (stripInteractionInput inp) ui)
      else pure result0
  -- Scopes only change how nodes look, which the rect and text diffs below
  -- cannot see, and custom widgets' cached ops hold the old theme's colours.
  whenM (themeScopesChanged ctx) $ do
    damageFull ctx
    modifyIORef' (ctxMetricGen ctx) (+ 1)
  -- Sync widget node values (checkbox/radio/tree) from the store before measure
  -- so labels and layout reflect the current state.
  syncWidgetLabels ctx
  let
    Size w h = inputWindowSize inp
  reused <- tryReuseLayout ctx (Size w h)
  unless reused $ do
    solvePlaceWindows ctx w h
    captureLayout ctx (Size w h)
  movedResize <- updateWindowResize ctx inp w h
  movedWindow <- updateWindowDrag ctx inp
  when (movedResize || movedWindow) $
    placeWindows
      (ctxNodeArena ctx)
      (contextMeasurers ctx)
      w
      h
      (lookupWindowPos ctx)
      (lookupWindowSize ctx)
  persistWindowPositions ctx
  applyScrollOffsets ctx
  finalizePointerPress ctx inp
  finalizePointerRelease ctx inp
  disarmPointerPress ctx inp
  finalizeTextInputFocus ctx inp
  finalizeSelectFocus ctx inp
  finalizeTextFieldMouse ctx inp
  closeTextEditMenuOnOutsideClick ctx inp
  openTextEditMenu ctx inp
  finalizeTextEditMenuPick ctx inp
  closeTextEditMenuOnEscape ctx inp
  constrainFocusToModal ctx
  finalizeTabFocus ctx inp
  finalizeSelectKeyboard ctx inp
  markSelectDropPress ctx inp
  finalizeSelectPick ctx inp
  closeSelectOnOutsideClick ctx inp
  storeAfter <- getStore ctx
  let storeChanged = WidgetStore -> WidgetStore -> Bool
mirrorStoresChanged WidgetStore
storeMid WidgetStore
storeAfter
  when storeChanged $ syncWidgetLabels ctx
  let layoutDirty = Bool
storeChanged Bool -> Bool -> Bool
|| Bool
movedResize Bool -> Bool -> Bool
|| Bool
movedWindow
  when layoutDirty $ do
    solvePlaceWindows ctx w h
    captureLayout ctx (Size w h)
    applyScrollOffsets ctx
  cacheOpenSelectDrop ctx
  updatePrevRects ctx
  refreshHover ctx inp
  tickAnimations ctx (inputDeltaTime inp)
  pruneDrawOpCache ctx
  overlayOpen <- overlayMenuOpen ctx
  writeDamage ctx inp overlayOpen
    FrameSnapshot
      { fsWasDirty = wasDirty
      , fsSize = oldSize
      , fsStore = oldStore
      , fsHot = oldHot
      , fsActive = oldActive
      , fsFocus = oldFocus
      , fsHotRect = oldHotRect
      , fsActiveRect = oldActiveRect
      , fsFocusRect = oldFocusRect
      , fsFloatingRects = oldFloatingRects
      , fsRects = oldRects
      , fsTexts = oldTexts
      , fsAnimKeys = animKeys
      }
  -- Clip frames only repaint the damaged region: the retain texture already
  -- holds every other pixel, and the runner scissors the present to the same
  -- damage. The region repaints from the window backdrop, inflated by one
  -- logical pixel to cover the runner's outward pixel snap. Full-present
  -- frames (fresh retain, forced full, continuous) paint everything.
  paintFull <- readIORef (ctxPaintFull ctx)
  beginLayer (ctxDrawArena ctx) LayerBackground
  unless paintFull $
    paintDamageClip ctx =<< takeDamage ctx
  lowerShapes ctx
  beginLayer (ctxDrawArena ctx) LayerOverlay
  drawWindowOverlays ctx
  drawModalOverlays ctx (inputWindowSize inp)
  drawPopupOverlays ctx
  drawSelectOverlays ctx inp
  drawTextEditMenuOverlays ctx inp
  drawData <- finishDraw (ctxDrawArena ctx)
  msgs <- drainMessages ctx
  dirtyAfterUi <- isDirty ctx
  pure (result, msgs, drawData, dirtyAfterUi)

-- Second UI pass after mirror store write. Keeps ctxStore, animations, and
-- prev rects; only rebuilds node arena and id scopes.
resetUiBuild :: Context -> IO ()
resetUiBuild :: Context -> IO ()
resetUiBuild Context
ctx = do
  Context -> Bool -> IO ()
beginThemeScopes Context
ctx Bool
False
  NodeArena -> IO ()
resetNodeArena (Context -> NodeArena
ctxNodeArena Context
ctx)
  Context -> IO ()
resetUiBuildScopes Context
ctx

-- | Start a clip frame from the window backdrop, as a full frame starts from a
-- window-coloured clear. Widgets with a transparent fill, such as an idle
-- menu-bar title, draw nothing over the pixels they covered, so without the
-- backdrop a hover that just ended would stay in the retain texture.
paintDamageClip :: Context -> Damage -> IO ()
paintDamageClip :: Context -> Damage -> IO ()
paintDamageClip Context
_ Damage
DamageFull = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
paintDamageClip Context
ctx (DamageClip Rect
r) = do
  let da :: DrawArena
da = Context -> DrawArena
ctxDrawArena Context
ctx
      clip :: Rect
clip = Float -> Rect -> Rect
rectInflate Float
1 Rect
r
  DrawArena -> Rect -> IO ()
setClip DrawArena
da Rect
clip
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rect -> Bool
rectNonEmpty Rect
r) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    theme <- IORef Theme -> IO Theme
forall a. IORef a -> IO a
readIORef (Context -> IORef Theme
ctxTheme Context
ctx)
    pushRect da clip (themeWindow theme)

resetUiBuildScopes :: Context -> IO ()
resetUiBuildScopes :: Context -> IO ()
resetUiBuildScopes Context
ctx = do
  IORef [Int] -> [Int] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef [Int]
ctxContainerStack Context
ctx) []
  IORef IdContext -> IdContext -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef IdContext
ctxIdContext Context
ctx) IdContext
initialIdContext
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef Int
ctxFocusablesCount Context
ctx) Int
0
  IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxHotId Context
ctx) (Word64 -> WidgetId
WidgetId Word64
0)
  Context -> IO ()
resetDrawingScopeCache Context
ctx

solvePlaceWindows :: Context -> Float -> Float -> IO ()
solvePlaceWindows :: Context -> Float -> Float -> IO ()
solvePlaceWindows Context
ctx Float
w Float
h = do
  let ms :: Measurers
ms = Context -> Measurers
contextMeasurers Context
ctx
  NodeArena -> Measurers -> Float -> Float -> IO ()
solveLayout (Context -> NodeArena
ctxNodeArena Context
ctx) Measurers
ms Float
w Float
h
  NodeArena -> Measurers -> Float -> Float -> IO ()
placeModals (Context -> NodeArena
ctxNodeArena Context
ctx) Measurers
ms Float
w Float
h
  NodeArena
-> Measurers
-> Float
-> Float
-> (WidgetId -> IO (Maybe (Float, Float)))
-> (WidgetId -> IO (Maybe (Float, Float)))
-> IO ()
placeWindows
    (Context -> NodeArena
ctxNodeArena Context
ctx)
    Measurers
ms
    Float
w
    Float
h
    (Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowPos Context
ctx)
    (Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowSize Context
ctx)
  NodeArena
-> Measurers
-> Float
-> Float
-> (WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float)))
-> IO ()
placePopups
    (Context -> NodeArena
ctxNodeArena Context
ctx)
    Measurers
ms
    Float
w
    Float
h
    (Context
-> WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))
lookupPopupConfig Context
ctx)

-- | Reuse solved geometry for unchanged layout inputs. Floating placement and
-- custom measurement have dependencies outside the arena and must be solved.
tryReuseLayout :: Context -> Size -> IO Bool
tryReuseLayout :: Context -> Size -> IO Bool
tryReuseLayout Context
ctx Size
size = do
  custom <- Context -> IO Bool
hasCustomLayoutInputs Context
ctx
  if custom
    then pure False
    else do
      gen <- readIORef (ctxMetricGen ctx)
      mc <- readIORef (ctxLayoutCache ctx)
      case mc of
        Just (LayoutCache
c, Size
cachedSize, Int
cachedGen)
          | Size
cachedSize Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
size Bool -> Bool -> Bool
&& Int
cachedGen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
gen -> do
              ok <- NodeArena -> LayoutCache -> IO Bool
layoutInputsMatch (Context -> NodeArena
ctxNodeArena Context
ctx) LayoutCache
c
              if ok
                then restoreLayoutCache (ctxNodeArena ctx) c >> pure True
                else pure False
        Maybe (LayoutCache, Size, Int)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Snapshot the solved layout so the next frame can reuse it.
captureLayout :: Context -> Size -> IO ()
captureLayout :: Context -> Size -> IO ()
captureLayout Context
ctx Size
size = do
  custom <- Context -> IO Bool
hasCustomLayoutInputs Context
ctx
  eligible <- if custom then pure False else layoutCacheEligible (ctxNodeArena ctx)
  if not eligible
    then writeIORef (ctxLayoutCache ctx) Nothing
    else do
      gen <- readIORef (ctxMetricGen ctx)
      mc <- readIORef (ctxLayoutCache ctx)
      c0 <- case mc of
        Just (LayoutCache
c, Size
_, Int
_) -> LayoutCache -> IO LayoutCache
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LayoutCache
c
        Maybe (LayoutCache, Size, Int)
Nothing -> Int -> IO LayoutCache
newLayoutCache Int
64
      c <- captureLayoutCache (ctxNodeArena ctx) c0
      writeIORef (ctxLayoutCache ctx) (Just (c, size, gen))