-- | Interaction hooks shared by widgets: 1D drags, drag reordering, arrow-key
-- navigation, click-outside and Escape dismissal, and the keyboard focus
-- check. Their state lives in the widget store.
module NanoUI.Widgets.Behavior
  ( DragAxis (..)
  , keyedDragHeld
  , useDrag1D
  , useReorder
  , useKeyNav
  , keyboardFocused
  , keyActivated
  , KeyNav (..)
  , useDismissable
  , dragThresholdPx
  )
where

import Control.Monad (when)
import Data.Hashable (Hashable, hash)
import Data.IORef (readIORef)
import Data.List (find)
import Effectful (Eff, type (:>))
import qualified Data.IntMap.Strict as IM
import NanoUI.Context
  ( Context (..)
  , getFocusId
  , getStore
  , intKey
  , isDisabled
  , markEscapeConsumed
  , getMenuPointerGesture
  , pointerBlockedByModal
  , Slot (..)
  , slotKey
  , modifyStore
  )
import NanoUI.Id (WidgetId (..), enterKeyed, hashWidgetId, idContextWidgetId)
import NanoUI.Input
  ( Input (..)
  , Key (..)
  , inputChars
  , inputKeys
  , inputKeysElem
  , inputKeysNull
  , inputMouseDown
  , inputMousePos
  , inputMousePressed
  , inputMouseReleased
  , inputMouseRightPressed
  )
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)
import NanoUI.Store (WidgetStore (..))
import NanoUI.Types (Rect (..), clamp01, rectHit, v2X, v2Y)
import qualified Data.Text as T

-- | Pointer slop in pixels before a held press counts as a drag.
dragThresholdPx :: Float
dragThresholdPx :: Float
dragThresholdPx = Float
8

data DragAxis = DragAxisX | DragAxisY
  deriving (DragAxis -> DragAxis -> Bool
(DragAxis -> DragAxis -> Bool)
-> (DragAxis -> DragAxis -> Bool) -> Eq DragAxis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DragAxis -> DragAxis -> Bool
== :: DragAxis -> DragAxis -> Bool
$c/= :: DragAxis -> DragAxis -> Bool
/= :: DragAxis -> DragAxis -> Bool
Eq, Int -> DragAxis -> ShowS
[DragAxis] -> ShowS
DragAxis -> String
(Int -> DragAxis -> ShowS)
-> (DragAxis -> String) -> ([DragAxis] -> ShowS) -> Show DragAxis
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DragAxis -> ShowS
showsPrec :: Int -> DragAxis -> ShowS
$cshow :: DragAxis -> String
show :: DragAxis -> String
$cshowList :: [DragAxis] -> ShowS
showList :: [DragAxis] -> ShowS
Show)

-- | True when a prior keyed useDrag1D on this path is still held.
-- Peeks the keyed first-id without enterKeyed bumping parent siblingId.
keyedDragHeld :: (Hashable k, Ui :> es) => k -> Eff es Bool
keyedDragHeld :: forall k (es :: [Effect]).
(Hashable k, Ui :> es) =>
k -> Eff es Bool
keyedDragHeld k
k = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO $ do
    old <- readIORef (ctxIdContext ctx)
    let wid = IdContext -> WidgetId
idContextWidgetId ((IdContext, IdContext) -> IdContext
forall a b. (a, b) -> b
snd (Word64 -> IdContext -> (IdContext, IdContext)
enterKeyed (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (k -> Int
forall a. Hashable a => a -> Int
hash k
k)) IdContext
old))
        dragK = Slot -> Int -> Int
slotKey Slot
SlotDrag (WidgetId -> Int
intKey WidgetId
wid)
    store <- getStore ctx
    pure (IM.findWithDefault 0 dragK (storeInt store) /= 0)

-- | Clamped 1D drag. Maps pointer position on 'track' into [lo, hi].
useDrag1D ::
  (Ui :> es) =>
  DragAxis ->
  Float ->
  Float ->
  Float ->
  Rect ->
  Eff es (Float, Bool)
useDrag1D :: forall (es :: [Effect]).
(Ui :> es) =>
DragAxis -> Float -> Float -> Float -> Rect -> Eff es (Float, Bool)
useDrag1D DragAxis
axis Float
lo Float
hi Float
current Rect
track = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  inp <- askInput
  let key = WidgetId -> Int
intKey WidgetId
wid
      dragK = Slot -> Int -> Int
slotKey Slot
SlotDrag Int
key
      trackLen = case DragAxis
axis of
        DragAxis
DragAxisX -> Rect -> Float
rectW Rect
track
        DragAxis
DragAxisY -> Rect -> Float
rectH Rect
track
      origin = case DragAxis
axis of
        DragAxis
DragAxisX -> Rect -> Float
rectX Rect
track
        DragAxis
DragAxisY -> Rect -> Float
rectY Rect
track
      mouse = case DragAxis
axis of
        DragAxis
DragAxisX -> V2 -> Float
v2X (Input -> V2
inputMousePos Input
inp)
        DragAxis
DragAxisY -> V2 -> Float
v2Y (Input -> V2
inputMousePos Input
inp)
      down = Input -> Bool
inputMouseDown Input
inp
  store <- uiIO (getStore ctx)
  gesture <- uiIO (getMenuPointerGesture ctx)
  let active0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
dragK (WidgetStore -> IntMap Int
storeInt WidgetStore
store) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      hit = Rect -> V2 -> Bool
rectHit Rect
track (Input -> V2
inputMousePos Input
inp) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
gesture
      active = Bool
down Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
gesture Bool -> Bool -> Bool
&& (Bool
active0 Bool -> Bool -> Bool
|| Bool
hit)
      frac =
        if Float
trackLen Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0
          then Float
0
          else Float -> Float
clamp01 ((Float
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
origin) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
trackLen)
      next =
        if Bool
active
          then Float
lo Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
frac Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
hi Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
lo)
          else Float
current
  when (active /= active0) $
    uiIO $
      modifyStore ctx $ \WidgetStore
st ->
        WidgetStore
st
          { storeInt =
              if active
                then IM.insert dragK 1 (storeInt st)
                else IM.delete dragK (storeInt st)
          }
  pure (next, active)

-- | Drag-and-drop reorder of a visible index list.
useReorder ::
  (Ui :> es) =>
  [Int] ->
  [(Int, Rect)] ->
  Eff es ([Int], Maybe Int)
useReorder :: forall (es :: [Effect]).
(Ui :> es) =>
[Int] -> [(Int, Rect)] -> Eff es ([Int], Maybe Int)
useReorder [Int]
order [(Int, Rect)]
items = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  inp <- askInput
  let key = WidgetId -> Int
intKey WidgetId
wid
      dragK = Slot -> Int -> Int
slotKey Slot
SlotDrag Int
key
      mouse = Input -> V2
inputMousePos Input
inp
      down = Input -> Bool
inputMouseDown Input
inp
      press = Input -> Bool
inputMousePressed Input
inp
      release = Input -> Bool
inputMouseReleased Input
inp
      hit =
        ((Int, Rect) -> Bool) -> [(Int, Rect)] -> Maybe (Int, Rect)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
          (\(Int
_, Rect
r) -> Rect -> V2 -> Bool
rectHit Rect
r V2
mouse)
          [(Int, Rect)]
items
  store <- uiIO (getStore ctx)
  let from0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (-Int
1) Int
dragK (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      startX = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 (Slot -> Int -> Int
slotKey Slot
SlotDragW Int
key) (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
      dragging = if Bool
press then Int -> ((Int, Rect) -> Int) -> Maybe (Int, Rect) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) (Int, Rect) -> Int
forall a b. (a, b) -> a
fst Maybe (Int, Rect)
hit else Int
from0
      nextDrag =
        if Bool
release Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
down
          then -Int
1
          else Int
dragging
      -- Resolve the drop using the held source before clearing it on release.
      moved =
        Bool -> Bool
not Bool
press Bool -> Bool -> Bool
&& Int
dragging Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Float -> Float
forall a. Num a => a -> a
abs (V2 -> Float
v2X V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
startX) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
dragThresholdPx
      dropTo = if Bool
moved then ((Int, Rect) -> Int) -> Maybe (Int, Rect) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Rect) -> Int
forall a b. (a, b) -> a
fst Maybe (Int, Rect)
hit else Maybe Int
forall a. Maybe a
Nothing
      nextOrder =
        case Maybe Int
dropTo of
          Just Int
toCol | Bool
release -> [Int] -> Int -> Int -> [Int]
moveItem [Int]
order Int
dragging Int
toCol
          Maybe Int
_ -> [Int]
order
  when (nextDrag /= from0 || (press && nextDrag >= 0)) $
    uiIO $
      modifyStore ctx $ \WidgetStore
st ->
        WidgetStore
st
          { storeInt = IM.insert dragK nextDrag (storeInt st)
          , storeFloat =
              IM.insert
                (slotKey SlotDragW key)
                (if press then v2X mouse else startX)
                (storeFloat st)
          }
  pure (nextOrder, if nextDrag >= 0 then Just nextDrag else Nothing)

moveItem :: [Int] -> Int -> Int -> [Int]
moveItem :: [Int] -> Int -> Int -> [Int]
moveItem [Int]
xs Int
from Int
to
  | Int
from Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to = [Int]
xs
  | Bool
otherwise =
      let without :: [Int]
without = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
from) [Int]
xs
          ([Int]
pre, [Int]
post) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to) [Int]
without
       in [Int]
pre [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int
from Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
post

data KeyNav = KeyNav
  { KeyNav -> Bool
knUp :: !Bool
  , KeyNav -> Bool
knDown :: !Bool
  , KeyNav -> Bool
knLeft :: !Bool
  , KeyNav -> Bool
knRight :: !Bool
  , KeyNav -> Bool
knEnter :: !Bool
  , KeyNav -> Bool
knSpace :: !Bool
  }
  deriving (KeyNav -> KeyNav -> Bool
(KeyNav -> KeyNav -> Bool)
-> (KeyNav -> KeyNav -> Bool) -> Eq KeyNav
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyNav -> KeyNav -> Bool
== :: KeyNav -> KeyNav -> Bool
$c/= :: KeyNav -> KeyNav -> Bool
/= :: KeyNav -> KeyNav -> Bool
Eq, Int -> KeyNav -> ShowS
[KeyNav] -> ShowS
KeyNav -> String
(Int -> KeyNav -> ShowS)
-> (KeyNav -> String) -> ([KeyNav] -> ShowS) -> Show KeyNav
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyNav -> ShowS
showsPrec :: Int -> KeyNav -> ShowS
$cshow :: KeyNav -> String
show :: KeyNav -> String
$cshowList :: [KeyNav] -> ShowS
showList :: [KeyNav] -> ShowS
Show)

-- | Focus alone does not grant keyboard input. A retained focus ID must still
-- respect disabled state and the modal currently being declared. Unfocused
-- controls avoid the store and modal checks entirely.
{-# INLINE keyboardFocused #-}
keyboardFocused :: Ui :> es => WidgetId -> Eff es Bool
keyboardFocused :: forall (es :: [Effect]). (Ui :> es) => WidgetId -> Eff es Bool
keyboardFocused WidgetId
wid
  | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Bool -> Eff es Bool
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  | Bool
otherwise = do
      ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
      focus <- uiIO (getFocusId ctx)
      if focus /= wid
        then pure False
        else uiIO $ do
          disabled <- isDisabled ctx wid
          if disabled then pure False else not <$> pointerBlockedByModal ctx

-- | Arrow / Enter / Space while 'wid' is focused and eligible for input.
useKeyNav :: (Ui :> es) => WidgetId -> Eff es KeyNav
useKeyNav :: forall (es :: [Effect]). (Ui :> es) => WidgetId -> Eff es KeyNav
useKeyNav WidgetId
wid = do
  inp <- Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput
  let keys = Input -> SmallArray Key
inputKeys Input
inp
      none = Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> KeyNav
KeyNav Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False
  if hashWidgetId wid == 0 || (inputKeysNull keys && T.null (inputChars inp))
    then pure none
    else do
      eligible <- keyboardFocused wid
      if not eligible
        then pure none
        else pure KeyNav
          { knUp = inputKeysElem KeyUp keys
          , knDown = inputKeysElem KeyDown keys
          , knLeft = inputKeysElem KeyLeft keys
          , knRight = inputKeysElem KeyRight keys
          , knEnter = inputKeysElem KeyEnter keys
          , knSpace = T.any (== ' ') (inputChars inp)
          }

-- | True when Enter or Space was pressed while @wid@ holds focus. Buttons,
-- checkboxes, and toggle switches treat this as a click.
{-# INLINE keyActivated #-}
keyActivated :: (Ui :> es) => WidgetId -> Eff es Bool
keyActivated :: forall (es :: [Effect]). (Ui :> es) => WidgetId -> Eff es Bool
keyActivated WidgetId
wid = do
  nav <- WidgetId -> Eff es KeyNav
forall (es :: [Effect]). (Ui :> es) => WidgetId -> Eff es KeyNav
useKeyNav WidgetId
wid
  pure (knEnter nav || knSpace nav)

-- | Escape and click-outside-rect dismiss. Consumes Escape when it fires.
useDismissable :: (Ui :> es) => Rect -> Eff es Bool
useDismissable :: forall (es :: [Effect]). (Ui :> es) => Rect -> Eff es Bool
useDismissable Rect
panel = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  let mouse = Input -> V2
inputMousePos Input
inp
      inside = Rect -> V2 -> Bool
rectHit Rect
panel V2
mouse
      esc = Key -> SmallArray Key -> Bool
inputKeysElem Key
KeyEscape (Input -> SmallArray Key
inputKeys Input
inp)
      backdrop = (Input -> Bool
inputMousePressed Input
inp Bool -> Bool -> Bool
|| Input -> Bool
inputMouseRightPressed Input
inp) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inside
      dismissed = Bool
esc Bool -> Bool -> Bool
|| Bool
backdrop
  when esc $ uiIO (markEscapeConsumed ctx)
  pure dismissed