{-# LANGUAGE DataKinds #-}

-- | Focus traversal and modal focus constraints.
module NanoUI.Frame.Focus
  ( filterModalFocusables
  , constrainFocusToModal
  , syncWidgetLabels
  , tabNext
  , tabNextFocusables
  ) where

import Control.Monad (filterM, unless, when)
import Data.IORef (readIORef, writeIORef)
import Data.Primitive.PrimArray (readPrimArray)
import qualified Data.IntMap.Strict as IM
import NanoUI.Context (Context (..), WidgetStore (..), getStore, intBool, intKey)
import NanoUI.Frame.Hit (widgetIdInSubtree)
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Layout.Arena
  ( NodeType (NodeCheckbox, NodeRadio, NodeTree)
  , forNodes_
  , getNodeType
  , getParent
  , getStyleIdx
  , getWidgetId
  , setNodeValue
  , topModalNode
  )
import NanoUI.WidgetText (treeDecodeStyle)

tabNext :: WidgetId -> [WidgetId] -> Bool -> WidgetId
tabNext :: WidgetId -> [WidgetId] -> Bool -> WidgetId
tabNext WidgetId
cur [WidgetId]
ids Bool
shift =
  case [WidgetId]
ids of
    [] -> Word64 -> WidgetId
WidgetId Word64
0
    WidgetId
first : [WidgetId]
rest ->
      let lastId :: t -> [t] -> t
lastId !t
prev [] = t
prev
          lastId t
_ (t
x : [t]
xs) = t -> [t] -> t
lastId t
x [t]
xs
          search :: WidgetId -> [WidgetId] -> WidgetId
search WidgetId
_ [] = WidgetId
first
          search WidgetId
prev (WidgetId
x : [WidgetId]
xs)
            | WidgetId
x WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
cur = if Bool
shift then WidgetId
prev else case [WidgetId]
xs of
                WidgetId
next : [WidgetId]
_ -> WidgetId
next
                [] -> WidgetId
first
            | Bool
otherwise = WidgetId -> [WidgetId] -> WidgetId
search WidgetId
x [WidgetId]
xs
       in if WidgetId
cur WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
first Bool -> Bool -> Bool
&& Bool
shift
            then WidgetId -> [WidgetId] -> WidgetId
forall {t}. t -> [t] -> t
lastId WidgetId
first [WidgetId]
rest
            else WidgetId -> [WidgetId] -> WidgetId
search WidgetId
first [WidgetId]
ids

-- | Scan the live focus buffer. Skip zero ids. No freeze or list copy.
tabNextFocusables :: Context -> WidgetId -> Bool -> IO WidgetId
tabNextFocusables :: Context -> WidgetId -> Bool -> IO WidgetId
tabNextFocusables Context
ctx WidgetId
cur Bool
shift = do
  n <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Context -> IORef Int
ctxFocusablesCount Context
ctx)
  arr <- readIORef (ctxFocusables ctx)
  let at Int
i = MutablePrimArray (PrimState IO) WidgetId -> Int -> IO WidgetId
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld WidgetId
MutablePrimArray (PrimState IO) WidgetId
arr Int
i
      findCur !Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            w <- Int -> IO WidgetId
at Int
i
            if w == cur && hashWidgetId w /= 0 then pure (Just i) else findCur (i + 1)
      firstLive !Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = WidgetId -> IO WidgetId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> WidgetId
WidgetId Word64
0)
        | Bool
otherwise = do
            w <- Int -> IO WidgetId
at Int
i
            if hashWidgetId w /= 0 then pure w else firstLive (i + 1)
      step !Int
i !Int
left
        | Int
left Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> IO WidgetId
firstLive Int
0
        | Bool
otherwise = do
            let j :: Int
j = if Bool
shift then (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n else (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n
            w <- Int -> IO WidgetId
at Int
j
            if hashWidgetId w /= 0 then pure w else step j (left - 1)
  if n <= 0
    then pure (WidgetId 0)
    else do
      found <- findCur 0
      case found of
        Maybe Int
Nothing -> Int -> IO WidgetId
firstLive Int
0
        Just Int
i -> Int -> Int -> IO WidgetId
step Int
i Int
n

filterModalFocusables :: Context -> [WidgetId] -> IO [WidgetId]
filterModalFocusables :: Context -> [WidgetId] -> IO [WidgetId]
filterModalFocusables Context
ctx [WidgetId]
ids = do
  -- Searching the arena once per focusable makes a large modal's Tab traversal
  -- quadratic. Resolve its root once, then test ancestry for each widget.
  top <- NodeArena -> IO (Maybe Int)
topModalNode (Context -> NodeArena
ctxNodeArena Context
ctx)
  case top of
    Maybe Int
Nothing -> [WidgetId] -> IO [WidgetId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [WidgetId]
ids
    Just Int
modal -> (WidgetId -> IO Bool) -> [WidgetId] -> IO [WidgetId]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Context -> Int -> WidgetId -> IO Bool
widgetIdInSubtree Context
ctx Int
modal) [WidgetId]
ids

constrainFocusToModal :: Context -> IO ()
constrainFocusToModal :: Context -> IO ()
constrainFocusToModal Context
ctx = do
  top <- NodeArena -> IO (Maybe Int)
topModalNode (Context -> NodeArena
ctxNodeArena Context
ctx)
  case top of
    Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Int
modal -> do
      focus <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx)
      when (hashWidgetId focus /= 0) $ do
        ok <- widgetIdInSubtree ctx modal focus
        unless ok $ writeIORef (ctxFocusId ctx) (WidgetId 0)

syncWidgetLabels :: Context -> IO ()
syncWidgetLabels :: Context -> IO ()
syncWidgetLabels Context
ctx = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let na = Context -> NodeArena
ctxNodeArena Context
ctx
  forNodes_ na $ \Int
idx -> do
    nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
    wid <- getWidgetId na idx
    let key = WidgetId -> Int
intKey WidgetId
wid
    case nt of
      NodeType
NodeCheckbox ->
        -- Only sync when the widget owns stored state; otherwise keep the
        -- value set from the initial argument during the UI pass.
        case Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
key (WidgetStore -> IntMap Int
storeInt WidgetStore
store) of
          Just Int
v -> NodeArena -> Int -> Float -> IO ()
setNodeValue NodeArena
na Int
idx (if Int -> Bool
intBool Int
v then Float
1 else Float
0)
          Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      NodeType
_
        -- A radio's option index is its style; a tree row packs its node
        -- index there. Either is selected when its group's stored value names it.
        | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeRadio Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTree -> do
            parent <- NodeArena -> Int -> IO Int
getParent NodeArena
na Int
idx
            si <- getStyleIdx na idx
            groupWid <- getWidgetId na parent
            let own
                  | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTree, (Int
nodeIdx, Int
_, Bool
_, Bool
_) <- Int -> (Int, Int, Bool, Bool)
treeDecodeStyle Int
si = Int
nodeIdx
                  | Bool
otherwise = Int
si
                selected = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
own (WidgetId -> Int
intKey WidgetId
groupWid) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
            setNodeValue na idx (if selected == own then 1 else 0)
      NodeType
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()