-- | Modal, floating-panel and menu pointer-capture state.
module NanoUI.Context.Overlay
  ( textInputEditActive
  , modalActive
  , overlayConsumesQuit
  , markEscapeConsumed
  , pointerBlockedByModal
  , pointerBlockedByOverlay
  , armMenuPointerCapture
  , seedFloatingPanel
  , beginModal
  , endModal
  , beginFrameModal
  , modalDamageFlip
  ) where

import Control.Monad (when)
import Data.IORef (readIORef)
import Data.IntMap.Strict qualified as IM

import NanoUI.Context.Core
  ( getMenuPointerGesture
  , getTextInputMenu
  , getsOverlay
  , modifyOverlay
  , setMenuPointerGesture
  , getsInteraction
  )
import NanoUI.Context.Types (Context (..), OverlayState (..), TextInputMenu (..), intKey, InteractionState (..))
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input (Input, Key (KeyEscape), inputKeys, inputKeysElem, inputMousePos, inputMousePressed)
import NanoUI.Types (Rect, V2, rectContains, rectHit, rectNonEmpty)

textInputEditActive :: Context -> IO Bool
textInputEditActive :: Context -> IO Bool
textInputEditActive Context
ctx = do
  focus <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx)
  menu <- getTextInputMenu ctx
  pure (hashWidgetId focus /= 0 || menu /= Nothing)

modalActive :: Context -> IO Bool
modalActive :: Context -> IO Bool
modalActive Context
ctx = Context -> (OverlayState -> Bool) -> IO Bool
forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx (\OverlayState
os -> OverlayState -> Bool
osModalWasActive OverlayState
os Bool -> Bool -> Bool
|| OverlayState -> Bool
osModalActive OverlayState
os)

overlayConsumesQuit :: Context -> Input -> IO Bool
overlayConsumesQuit :: Context -> Input -> IO Bool
overlayConsumesQuit Context
ctx Input
inp = do
  consumed <- Context -> (OverlayState -> Bool) -> IO Bool
forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx OverlayState -> Bool
osEscapeConsumed
  pure (inputKeysElem KeyEscape (inputKeys inp) && consumed)

markEscapeConsumed :: Context -> IO ()
markEscapeConsumed :: Context -> IO ()
markEscapeConsumed Context
ctx = Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay Context
ctx (\OverlayState
os -> OverlayState
os {osEscapeConsumed = True})

pointerBlockedByModal :: Context -> IO Bool
pointerBlockedByModal :: Context -> IO Bool
pointerBlockedByModal Context
ctx =
  Context -> (OverlayState -> Bool) -> IO Bool
forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx (\OverlayState
os -> OverlayState -> Int
osModalDepth OverlayState
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& (OverlayState -> Bool
osModalWasActive OverlayState
os Bool -> Bool -> Bool
|| OverlayState -> Bool
osModalActive OverlayState
os))

pointerBlockedByOverlay :: Context -> V2 -> IO Bool
pointerBlockedByOverlay :: Context -> V2 -> IO Bool
pointerBlockedByOverlay Context
ctx V2
mouse = do
  gesture <- Context -> IO Bool
getMenuPointerGesture Context
ctx
  blocked <-
    if gesture
      then pure True
      else do
        menuBlocked <- overlayMenuBlocksPointer ctx mouse
        if menuBlocked
          then pure True
          else do
            modalBlocked <- pointerBlockedByModal ctx
            if modalBlocked
              then pure True
              else do
                mTop <- cachedTopmost ctx mouse
                case mTop of
                  Maybe WidgetId
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                  Just WidgetId
top -> do
                    mCur <- Context -> (OverlayState -> Maybe WidgetId) -> IO (Maybe WidgetId)
forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx OverlayState -> Maybe WidgetId
osCurrentFloatingId
                    pure (mCur /= Just top)
  modifyOverlay ctx (\OverlayState
os -> OverlayState
os {osLastPointerBlocked = blocked})
  pure blocked

armMenuPointerCapture :: Context -> Input -> IO ()
armMenuPointerCapture :: Context -> Input -> IO ()
armMenuPointerCapture Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    blocked <- Context -> V2 -> IO Bool
overlayMenuBlocksPointer Context
ctx (Input -> V2
inputMousePos Input
inp)
    setMenuPointerGesture ctx blocked

overlayMenuBlocksPointer :: Context -> V2 -> IO Bool
overlayMenuBlocksPointer :: Context -> V2 -> IO Bool
overlayMenuBlocksPointer Context
ctx V2
mouse = do
  mMenu <- Context -> IO (Maybe TextInputMenu)
getTextInputMenu Context
ctx
  let textMenu =
        case Maybe TextInputMenu
mMenu of
          Just TextInputMenu
m | Rect -> V2 -> Bool
rectContains (TextInputMenu -> Rect
textInputMenuRect TextInputMenu
m) V2
mouse -> Bool
True
          Maybe TextInputMenu
_ -> Bool
False
  if textMenu
    then pure True
    else do
      mDrop <- getsInteraction ctx isOpenSelectDrop
      pure
        ( case mDrop of
            Just (WidgetId
_, Rect
r) -> Rect -> V2 -> Bool
rectContains Rect
r V2
mouse
            Maybe (WidgetId, Rect)
Nothing -> Bool
False
        )

cachedTopmost :: Context -> V2 -> IO (Maybe WidgetId)
cachedTopmost :: Context -> V2 -> IO (Maybe WidgetId)
cachedTopmost Context
ctx V2
mouse = do
  cache <- Context
-> (OverlayState -> Maybe (V2, Maybe WidgetId))
-> IO (Maybe (V2, Maybe WidgetId))
forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx OverlayState -> Maybe (V2, Maybe WidgetId)
osTopmostCache
  case cache of
    Just (V2
p, Maybe WidgetId
t) | V2
p V2 -> V2 -> Bool
forall a. Eq a => a -> a -> Bool
== V2
mouse -> Maybe WidgetId -> IO (Maybe WidgetId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WidgetId
t
    Maybe (V2, Maybe WidgetId)
_ -> do
      t <- Context -> V2 -> IO (Maybe WidgetId)
topmostFloatingAtMouse Context
ctx V2
mouse
      modifyOverlay ctx (\OverlayState
os -> OverlayState
os {osTopmostCache = Just (mouse, t)})
      pure t

topmostFloatingAtMouse :: Context -> V2 -> IO (Maybe WidgetId)
topmostFloatingAtMouse :: Context -> V2 -> IO (Maybe WidgetId)
topmostFloatingAtMouse Context
ctx V2
mouse = do
  os <- IORef OverlayState -> IO OverlayState
forall a. IORef a -> IO a
readIORef (Context -> IORef OverlayState
ctxOverlayState Context
ctx)
  let rects = OverlayState -> IntMap Rect
osPrevFloatingRects OverlayState
os
      order = OverlayState -> [Int]
osPrevFloatingOrder OverlayState
os
      hit Int
k = Bool -> (Rect -> Bool) -> Maybe Rect -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Rect -> V2 -> Bool
`rectHit` V2
mouse) (Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
rects)
      picked = (Maybe Int -> Int -> Maybe Int) -> Maybe Int -> [Int] -> Maybe Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Maybe Int
acc Int
k -> if Int -> Bool
hit Int
k then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k else Maybe Int
acc) Maybe Int
forall a. Maybe a
Nothing [Int]
order
  pure (WidgetId . fromIntegral <$> picked)

seedFloatingPanel :: Context -> WidgetId -> Rect -> IO ()
seedFloatingPanel :: Context -> WidgetId -> Rect -> IO ()
seedFloatingPanel Context
ctx WidgetId
wid Rect
rect
  | Bool -> Bool
not (Rect -> Bool
rectNonEmpty Rect
rect) = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      let k :: Int
k = WidgetId -> Int
intKey WidgetId
wid
      Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay Context
ctx ((OverlayState -> OverlayState) -> IO ())
-> (OverlayState -> OverlayState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \OverlayState
os ->
        let rects :: IntMap Rect
rects = Int -> Rect -> IntMap Rect -> IntMap Rect
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k Rect
rect (OverlayState -> IntMap Rect
osPrevFloatingRects OverlayState
os)
            order :: [Int]
order = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
k) (OverlayState -> [Int]
osPrevFloatingOrder OverlayState
os) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
k]
         in OverlayState
os
              { osPrevFloatingRects = rects
              , osPrevFloatingOrder = order
              , osTopmostCache = Nothing
              }

beginModal :: Context -> IO ()
beginModal :: Context -> IO ()
beginModal Context
ctx =
  Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay Context
ctx (\OverlayState
os -> OverlayState
os {osModalActive = True, osModalDepth = osModalDepth os + 1})

endModal :: Context -> IO ()
endModal :: Context -> IO ()
endModal Context
ctx =
  Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay Context
ctx (\OverlayState
os -> OverlayState
os {osModalDepth = max 0 (osModalDepth os - 1)})

beginFrameModal :: Context -> IO ()
beginFrameModal :: Context -> IO ()
beginFrameModal Context
ctx =
  Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay Context
ctx ((OverlayState -> OverlayState) -> IO ())
-> (OverlayState -> OverlayState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \OverlayState
os ->
    OverlayState
os
      { osModalWasActive = osModalActive os
      , osModalActive = False
      , osModalDepth = 0
      , osTopmostCache = Nothing
      , osCurrentFloatingId = Nothing
      , osLastPointerBlocked = False
      , osEscapeConsumed = False
      }

modalDamageFlip :: Context -> IO Bool
modalDamageFlip :: Context -> IO Bool
modalDamageFlip Context
ctx = Context -> (OverlayState -> Bool) -> IO Bool
forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx (\OverlayState
os -> OverlayState -> Bool
osModalWasActive OverlayState
os Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= OverlayState -> Bool
osModalActive OverlayState
os)