{-# LANGUAGE StrictData #-}

-- | Operating-system drag and drop.
--
-- 'useDrop' turns the frame's 'NanoUI.Input.DropEvent's into a 'DropTarget'
-- for one rectangle. 'dropZone' wraps a panel and does the same for its rect.
--
-- @
-- (_, _, target) <- dropZone fillW (label "Drop files here")
-- when (dropReceived target) (mapM_ openFile (dropFiles target))
-- @
module NanoUI.Widgets.Drop
  ( DropTarget (..)
  , useDrop
  , dropZone
  ) where

import Control.Applicative ((<|>))
import Control.Monad (when)
import Data.IntMap.Strict qualified as IM
import Data.Text (Text)
import Data.Foldable (toList)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( getStore
  , intKey
  , modifyStore
  )
import NanoUI.Input
  ( DropEvent (..)
  , DropType (..)
  , inputDrops
  )
import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, uiIO)
import NanoUI.Store
  ( WidgetStore (..)
  , Slot (..)
  , slotKey
  )
import NanoUI.Style (Layout)
import NanoUI.Types (Rect, V2 (..), rectContains)
import NanoUI.Layout.Arena (NodeType (..))
import NanoUI.Widgets.Node (Response, containerResponse, respRect)

-- | Per-frame drop state for a single rectangular drop target.
data DropTarget = DropTarget
  { DropTarget -> Bool
dropHovered :: !Bool
    -- ^ A drag is currently positioned over the target rect.
  , DropTarget -> Bool
dropReceived :: !Bool
    -- ^ One or more payloads landed on the target this frame.
  , DropTarget -> [Text]
dropFiles :: ![Text]
    -- ^ File paths dropped on the target this frame.
  , DropTarget -> [Text]
dropTexts :: ![Text]
    -- ^ Text snippets dropped on the target this frame.
  , DropTarget -> Maybe V2
dropPosition :: !(Maybe V2)
    -- ^ Last known drop position in window coordinates, if any.
  }
  deriving (DropTarget -> DropTarget -> Bool
(DropTarget -> DropTarget -> Bool)
-> (DropTarget -> DropTarget -> Bool) -> Eq DropTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DropTarget -> DropTarget -> Bool
== :: DropTarget -> DropTarget -> Bool
$c/= :: DropTarget -> DropTarget -> Bool
/= :: DropTarget -> DropTarget -> Bool
Eq, Int -> DropTarget -> ShowS
[DropTarget] -> ShowS
DropTarget -> String
(Int -> DropTarget -> ShowS)
-> (DropTarget -> String)
-> ([DropTarget] -> ShowS)
-> Show DropTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DropTarget -> ShowS
showsPrec :: Int -> DropTarget -> ShowS
$cshow :: DropTarget -> String
show :: DropTarget -> String
$cshowList :: [DropTarget] -> ShowS
showList :: [DropTarget] -> ShowS
Show)

-- | Compute the drop state for a rectangle from the current frame's drop events.
--
-- Active/hover state persists across frames in the widget store, so a target
-- keeps highlighting while the OS drag is stationary. Payload events
-- ('DropFile'/'DropText') are one-shot: they are reported exactly on the frame
-- they arrive.
--
-- Attribution uses the tracked drag position (the coordinates of the most
-- recent 'DropPosition') rather than a payload's own coordinates. SDL
-- synthesizes file/text events at the last drag position and reports (0,0)
-- when it never observed one, so the position stream is the only reliable
-- signal for "which target is this drop over".
useDrop :: Ui :> es => Rect -> Eff es DropTarget
useDrop :: forall (es :: [Effect]). (Ui :> es) => Rect -> Eff es DropTarget
useDrop Rect
bounds = 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
      activeK = Slot -> Int -> Int
slotKey Slot
SlotDrop Int
key
      posK = Slot -> Int -> Int
slotKey Slot
SlotDropPos Int
key
  store <- uiIO (getStore ctx)
  let active0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
activeK (WidgetStore -> IntMap Int
storeInt WidgetStore
store) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      lastPos0 = ((Float, Float) -> V2) -> Maybe (Float, Float) -> Maybe V2
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Float
x, Float
y) -> Float -> Float -> V2
V2 Float
x Float
y) (Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
posK (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store))
      events = SmallArray DropEvent -> [DropEvent]
forall a. SmallArray a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Input -> SmallArray DropEvent
inputDrops Input
inp)
      -- A drag is active from 'DropBegin' until 'DropComplete'.
      active1 =
        (Bool -> DropEvent -> Bool) -> Bool -> [DropEvent] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
          ( \Bool
active DropEvent
ev -> case DropEvent -> DropType
dropEventType DropEvent
ev of
              DropType
DropBegin -> Bool
True
              DropType
DropComplete -> Bool
False
              DropType
_ -> Bool
active
          )
          Bool
active0
          [DropEvent]
events
      -- Tracked position after each event: only 'DropPosition' moves it and
      -- 'DropComplete' clears it. Payload events leave it unchanged, so a
      -- payload is attributed to the position at that point in the sequence,
      -- not to the frame's final position.
      positions =
        Int -> [Maybe V2] -> [Maybe V2]
forall a. Int -> [a] -> [a]
drop Int
1 ([Maybe V2] -> [Maybe V2]) -> [Maybe V2] -> [Maybe V2]
forall a b. (a -> b) -> a -> b
$ (Maybe V2 -> DropEvent -> Maybe V2)
-> Maybe V2 -> [DropEvent] -> [Maybe V2]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl
          ( \Maybe V2
pos DropEvent
ev -> case DropEvent -> DropType
dropEventType DropEvent
ev of
              DropType
DropPosition -> DropEvent -> Maybe V2
dropEventPos DropEvent
ev Maybe V2 -> Maybe V2 -> Maybe V2
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe V2
pos
              DropType
DropComplete -> Maybe V2
forall a. Maybe a
Nothing
              DropType
_ -> Maybe V2
pos
          )
          Maybe V2
lastPos0
          [DropEvent]
events
      lastPos1 = [Maybe V2] -> Maybe V2
forall a. HasCallStack => [a] -> a
last (Maybe V2
lastPos0 Maybe V2 -> [Maybe V2] -> [Maybe V2]
forall a. a -> [a] -> [a]
: [Maybe V2]
positions)
      payloads DropType
ty =
        [DropEvent -> Text
dropEventData DropEvent
ev | (DropEvent
ev, Maybe V2
pos) <- [DropEvent] -> [Maybe V2] -> [(DropEvent, Maybe V2)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DropEvent]
events [Maybe V2]
positions, DropEvent -> DropType
dropEventType DropEvent
ev DropType -> DropType -> Bool
forall a. Eq a => a -> a -> Bool
== DropType
ty, Rect -> Maybe V2 -> Bool
posInside Rect
bounds Maybe V2
pos]
      files = DropType -> [Text]
payloads DropType
DropFile
      texts = DropType -> [Text]
payloads DropType
DropText
      hovered = Bool
active1 Bool -> Bool -> Bool
&& Rect -> Maybe V2 -> Bool
posInside Rect
bounds Maybe V2
lastPos1
  when (active1 /= active0 || lastPos1 /= lastPos0) $
    uiIO $
      modifyStore ctx $ \WidgetStore
st ->
        WidgetStore
st
          { storeInt =
              if active1
                then IM.insert activeK 1 (storeInt st)
                else IM.delete activeK (storeInt st)
          , storePoint =
              maybe
                (IM.delete posK (storePoint st))
                (\(V2 Float
x Float
y) -> Int
-> (Float, Float) -> IntMap (Float, Float) -> IntMap (Float, Float)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
posK (Float
x, Float
y) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
st))
                lastPos1
          }
  pure
    DropTarget
      { dropHovered = hovered
      , dropReceived = not (null files) || not (null texts)
      , dropFiles = files
      , dropTexts = texts
      , dropPosition = lastPos1
      }

posInside :: Rect -> Maybe V2 -> Bool
posInside :: Rect -> Maybe V2 -> Bool
posInside Rect
bounds = Bool -> (V2 -> Bool) -> Maybe V2 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Rect -> V2 -> Bool
rectContains Rect
bounds)

-- | A panel that is also a drop target. Returns the body's result, the
-- panel's 'Response', and the 'DropTarget' for its rect.
dropZone :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es (a, Response, DropTarget)
dropZone :: forall (es :: [Effect]) a.
(Ui :> es) =>
(Layout -> Layout) -> Eff es a -> Eff es (a, Response, DropTarget)
dropZone Layout -> Layout
f Eff es a
child = do
  base <- Eff es Layout
forall (es :: [Effect]). (Ui :> es) => Eff es Layout
askDefaultLayout
  (a, resp) <- containerResponse NodePanel (f base) child
  target <- useDrop (respRect resp)
  pure (a, resp, target)