{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Interactive pane grid with resizable dividers, modelled on iced's
-- @PaneGrid@.
--
-- The grid is a binary split tree ('NanoUI.Widgets.SplitPane.GridNode')
-- persisted per widget as a "Data.Dynamic" value in the widget store.
--
-- Panes are rendered through the user-provided 'pgViewPane', which receives a
-- 'PaneGridCtx' with immediate-mode actions to split, close, maximize, or
-- restore the pane. Dividers can be dragged to resize; panes can be grabbed by
-- their pick rect and dropped onto another pane (center = swap, edge = split)
-- or onto the grid's outer edge to restructure the whole grid at top level;
-- arrow keys navigate between panes; @m@/@x@ maximize/close and @Escape@
-- restores while the grid is focused.
module NanoUI.Widgets.PaneGrid
  ( GridAxis (..)
  , PaneGridConfig (..)
  , defaultPaneGridConfig
  , PaneGridCtx (..)
  , PaneView (..)
  , PaneGridResponse (..)
  , paneGrid
  ) where

import Control.Monad (forM_, unless, void, when)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Dynamic (fromDynamic, toDyn)
import Data.Hashable (hash)
import Data.IntMap.Strict qualified as IM
import Data.List (find, minimumBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Primitive.SmallArray (SmallArray)
import Data.Word (Word64)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , bumpMirror
  , damageWidget
  , getFocusId
  , getFocusVisible
  , getPrevRect
  , getStore
  , intKey
  , markDirty
  , markEscapeConsumed
  , getMenuPointerGesture
  , overlayConsumesQuit
  , registerCustomDrawing
  , registerFocusable
  , setStore
  , modifyStore
  )
import NanoUI.Draw (DrawOp)
import NanoUI.Input
  ( Input (..)
  , Key (..)
  , UiCursorKind (..)
  , inputChars
  , inputKeys
  , inputKeysElem
  , inputMouseDown
  , inputMousePos
  , inputMousePressed
  )
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withIdFrame, withKey)
import NanoUI.Id (IdContext (..), WidgetId, hashWidgetId)
import NanoUI.Frame.Hit (nodeInteractionHit, scrollHitRect)
import NanoUI.Frame.Input (isInteractiveNode)
import NanoUI.Store
  ( WidgetStore (..)
  , slotKey
  , Slot (..)
  )
import NanoUI.Style
  ( AlignX (..)
  , AlignY (..)
  , Direction (..)
  , Layout (..)
  , Padding (..)
  , Sizing (..)
  , Style (..)
  , Theme (..)
  , defaultLayout
  , fadeAlpha
  , separatorTrackColor
  )
import NanoUI.Types
  ( DamageBounds (..)
  , Rect (..)
  , V2 (..)
  , lerpColor
  , rectHit
  , rectH
  , rectInflate
  , rectNonEmpty
  , rectW
  , rectX
  , rectY
  , v2X
  , v2Y
  )
import NanoUI.Widgets.Behavior (KeyNav (..), dragThresholdPx, useKeyNav)
import NanoUI.Widgets.Custom
  ( CustomWidgetSpec (..)
  , CustomDrawContext (..)
  , contentKey
  , defaultCustomWidgetSpec
  , customWidget
  , drawRect
  , drawRoundedRect
  , drawStroke
  , drawStrokeRoundedRect
  , drawText
  , runCanvas
  )
import NanoUI.Widgets.Layout (column', row')
import NanoUI.Layout.Arena (NodeType (..), arenaCount, getNodeType, getWidgetId)
import NanoUI.Widgets.Node
  ( container
  , containerResponse
  , tagContainer
  )
import NanoUI.Widgets.SplitPane
  ( DividerInfo (..)
  , GridAxis (..)
  , GridNode (..)
  , clampTreeRatio
  , dropPreview
  , dropTargetForPane
  , layoutNode
  , mainLen
  , mainMins
  , PaneDrop (..)
  , paneExist
  , splitLength
  , subtreeMin
  , topLevelDropTarget
  , treeMovePane
  , treePanes
  , treeRemovePane
  , treeSetRatio
  , treeSize
  , treeSplit
  )

-- -----------------------------------------------------------------------------
-- Public API
-- -----------------------------------------------------------------------------

-- | Configuration for a pane grid. 'pgViewPane' can run arbitrary widget code,
-- so the config carries the caller's effect row.
data PaneGridConfig es = PaneGridConfig
  { forall (es :: [Effect]). PaneGridConfig es -> Layout -> Layout
pgLayout :: !(Layout -> Layout)
    -- ^ Layout modifier for the grid container (default 'id'); pass
    -- @fillW . fillH@ to fill the parent area.
  , forall (es :: [Effect]). PaneGridConfig es -> Float
pgSpacing :: !Float
    -- ^ Gutter between panes per split level (default 4).
  , forall (es :: [Effect]). PaneGridConfig es -> Float
pgMinSize :: !Float
    -- ^ Minimum physical size any pane may shrink to (default 40).
  , forall (es :: [Effect]). PaneGridConfig es -> Float
pgLeeway :: !Float
    -- ^ Extra grab margin on each side of a divider, added to 'pgSpacing' to
    -- form the divider's real layout gutter. The resize cursor and grab work
    -- anywhere in that gutter while only 'pgSpacing' is drawn crisp, so the
    -- interaction space is far wider than the visible line (default 6).
  , forall (es :: [Effect]). PaneGridConfig es -> Float
pgEdgeBand :: !Float
    -- ^ Thickness of the grid's outer edge that acts as a top-level drop zone
    -- (default 20). Dragging a pane into this band restructures the whole grid
    -- instead of a single pane: the tree is wrapped in a new top-level split
    -- with the dragged pane on that side.
  , forall (es :: [Effect]).
PaneGridConfig es -> Word64 -> PaneGridCtx es -> Eff es PaneView
pgViewPane :: !(Word64 -> PaneGridCtx es -> Eff es PaneView)
    -- ^ Renders the content of one pane.
  }

defaultPaneGridConfig :: PaneGridConfig es
defaultPaneGridConfig :: forall (es :: [Effect]). PaneGridConfig es
defaultPaneGridConfig =
  PaneGridConfig
    { pgLayout :: Layout -> Layout
pgLayout = Layout -> Layout
forall a. a -> a
id
    , pgSpacing :: Float
pgSpacing = Float
4
    , pgMinSize :: Float
pgMinSize = Float
40
    , pgLeeway :: Float
pgLeeway = Float
6
    , pgEdgeBand :: Float
pgEdgeBand = Float
20
    , pgViewPane :: Word64 -> PaneGridCtx es -> Eff es PaneView
pgViewPane = \Word64
_ PaneGridCtx es
_ -> PaneView -> Eff es PaneView
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Bool -> Maybe Rect -> PaneView
PaneView Text
"" Bool
False Maybe Rect
forall a. Maybe a
Nothing)
    }

-- | Actions handed to a pane so it can mutate the grid immediately.
data PaneGridCtx es = PaneGridCtx
  { forall (es :: [Effect]). PaneGridCtx es -> Word64
pgcPaneId :: !Word64
  , forall (es :: [Effect]). PaneGridCtx es -> Rect
pgcRect :: !Rect
    -- ^ Prev-frame screen rect of this pane (zero until it has been laid
    -- out once; the whole grid rect while maximized). Use it to build
    -- 'pvDragPick' handles such as a title-bar sub-rect.
  , forall (es :: [Effect]). PaneGridCtx es -> Bool
pgcMaximized :: !Bool
    -- ^ True when this pane currently fills the whole grid.
  , forall (es :: [Effect]). PaneGridCtx es -> Bool
pgcDragging :: !Bool
    -- ^ True while this pane's drag is armed. Once the drag threshold is
    -- crossed, the pane is omitted from the visible layout until release.
  , forall (es :: [Effect]). PaneGridCtx es -> Bool
pgcDndActive :: !Bool
    -- ^ True while any pane drag-and-drop gesture is in progress.
  , forall (es :: [Effect]).
PaneGridCtx es -> GridAxis -> Eff es Word64
pgcSplit :: !(GridAxis -> Eff es Word64)
    -- ^ Split this pane along the axis; returns the new pane id.
  , forall (es :: [Effect]). PaneGridCtx es -> Eff es ()
pgcClose :: !(Eff es ())
  , forall (es :: [Effect]). PaneGridCtx es -> Eff es ()
pgcMaximize :: !(Eff es ())
  , forall (es :: [Effect]). PaneGridCtx es -> Eff es ()
pgcRestore :: !(Eff es ())
  }

-- | What a pane renders to this frame. The pane's content (including any title
-- bar / header) is drawn entirely by the caller in 'pgViewPane'; a header is
-- purely optional and nothing here depends on one existing.
data PaneView = PaneView
  { PaneView -> Text
pvTitle :: !Text
    -- ^ Label shown (abbreviated to fit) on the compact drag indicator.
  , PaneView -> Bool
pvDraggable :: !Bool
    -- ^ Grab the pane anywhere inside its own region to drag-and-drop it. This
    -- is the easy way to reorder panes without drawing a dedicated handle.
    -- Interactive children keep their pointer presses. Pane still needs a
    -- drag only on a sub-region? see 'pvDragPick'.
  , PaneView -> Maybe Rect
pvDragPick :: !(Maybe Rect)
    -- ^ Optional absolute sub-region (e.g. just a title bar; position it via
    -- 'pgcRect') that also starts a drag. Both handles combine: the pane drags
    -- if the press lands in this rect or (when 'pvDraggable') anywhere in the
    -- pane. 'Nothing' here and 'pvDraggable' 'False' makes the pane immovable.
  }
  deriving (PaneView -> PaneView -> Bool
(PaneView -> PaneView -> Bool)
-> (PaneView -> PaneView -> Bool) -> Eq PaneView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PaneView -> PaneView -> Bool
== :: PaneView -> PaneView -> Bool
$c/= :: PaneView -> PaneView -> Bool
/= :: PaneView -> PaneView -> Bool
Eq, Int -> PaneView -> ShowS
[PaneView] -> ShowS
PaneView -> String
(Int -> PaneView -> ShowS)
-> (PaneView -> String) -> ([PaneView] -> ShowS) -> Show PaneView
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PaneView -> ShowS
showsPrec :: Int -> PaneView -> ShowS
$cshow :: PaneView -> String
show :: PaneView -> String
$cshowList :: [PaneView] -> ShowS
showList :: [PaneView] -> ShowS
Show)

-- | Outcome of one frame of the grid. The pane list, focus, and maximize
-- fields report the state after this pass: actions run by pane content
-- ('pgcSplit', 'pgcClose', ...) and the keyboard handling below take effect
-- in these values and from the next frame's layout onward.
data PaneGridResponse = PaneGridResponse
  { PaneGridResponse -> Bool
pgrChanged :: !Bool
    -- ^ Any structural or maximize change happened this frame.
  , PaneGridResponse -> Int
pgrPaneCount :: !Int
    -- ^ Number of panes (0 once the last pane has been closed).
  , PaneGridResponse -> [Word64]
pgrPanes :: ![Word64]
    -- ^ Live pane ids, depth-first.
  , PaneGridResponse -> Word64
pgrFocusedPane :: !Word64
    -- ^ Focused pane id, 0 when the grid has no panes.
  , PaneGridResponse -> Word64
pgrMaximizedPane :: !Word64
    -- ^ Maximized pane id, 0 when none.
  }
  deriving (PaneGridResponse -> PaneGridResponse -> Bool
(PaneGridResponse -> PaneGridResponse -> Bool)
-> (PaneGridResponse -> PaneGridResponse -> Bool)
-> Eq PaneGridResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PaneGridResponse -> PaneGridResponse -> Bool
== :: PaneGridResponse -> PaneGridResponse -> Bool
$c/= :: PaneGridResponse -> PaneGridResponse -> Bool
/= :: PaneGridResponse -> PaneGridResponse -> Bool
Eq, Int -> PaneGridResponse -> ShowS
[PaneGridResponse] -> ShowS
PaneGridResponse -> String
(Int -> PaneGridResponse -> ShowS)
-> (PaneGridResponse -> String)
-> ([PaneGridResponse] -> ShowS)
-> Show PaneGridResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PaneGridResponse -> ShowS
showsPrec :: Int -> PaneGridResponse -> ShowS
$cshow :: PaneGridResponse -> String
show :: PaneGridResponse -> String
$cshowList :: [PaneGridResponse] -> ShowS
showList :: [PaneGridResponse] -> ShowS
Show)

-- -----------------------------------------------------------------------------
-- Internal state
-- -----------------------------------------------------------------------------

data RenderedPane = RenderedPane
  { RenderedPane -> Word64
rpPaneId :: !Word64
  , RenderedPane -> PaneView
rpView :: !PaneView
  , RenderedPane -> Bool
rpControlHit :: !Bool
  }

-- | Per-frame shared environment.
data GridEnv es = GridEnv
  { forall (es :: [Effect]). GridEnv es -> Context
geCtx :: !Context
  , forall (es :: [Effect]). GridEnv es -> Int
geKey :: !Int
  , forall (es :: [Effect]). GridEnv es -> IdContext
gePaneScope :: !IdContext
    -- ^ Pane identity is rooted at the grid widget, independent of split
    -- ancestry so rearranging or temporarily collapsing splits preserves state.
  , forall (es :: [Effect]). GridEnv es -> PaneGridConfig es
geCfg :: !(PaneGridConfig es)
  , forall (es :: [Effect]). GridEnv es -> Float
geGutter :: !Float
  , forall (es :: [Effect]). GridEnv es -> Float
geThickness :: !Float
  , forall (es :: [Effect]). GridEnv es -> Float
geMinSize :: !Float
  , forall (es :: [Effect]). GridEnv es -> Float
geLeeway :: !Float
  , forall (es :: [Effect]). GridEnv es -> Map Word64 Rect
geRegions :: !(Map Word64 Rect)
    -- ^ Prev-frame pane regions; drives hit testing and 'pgcRect'.
  , forall (es :: [Effect]). GridEnv es -> Rect
geBaseRect :: !Rect
    -- ^ Prev-frame rect of the grid's root container.
  , forall (es :: [Effect]). GridEnv es -> GridNode
geTree :: !GridNode
  , forall (es :: [Effect]). GridEnv es -> Word64
geSeed :: !Word64
    -- ^ Next fresh split / pane id ('SlotPaneNext'); strictly monotonic per
    -- grid, so ids are never reused and state keyed by pane id cannot
    -- collide with a closed pane's state.
  , forall (es :: [Effect]). GridEnv es -> Int
geDrag0 :: !Int
  , forall (es :: [Effect]). GridEnv es -> Word64
geMax :: !Word64
  , forall (es :: [Effect]). GridEnv es -> IORef Bool
geChangedRef :: !(IORef Bool)
  , forall (es :: [Effect]).
GridEnv es -> Word64 -> Rect -> Bool -> PaneGridCtx es
geMakeCtx :: Word64 -> Rect -> Bool -> PaneGridCtx es
  }

-- | Computed drag-and-drop interaction state for one frame.
data DragInfo = DragInfo
  { DragInfo -> Bool
dgiActive :: !Bool
  , DragInfo -> Bool
dgiMoved :: !Bool
  , DragInfo -> Maybe Rect
dgiGhost :: !(Maybe Rect)
  , DragInfo -> Maybe (Rect, PaneDrop)
dgiZone :: !(Maybe (Rect, PaneDrop))
  }

-- -----------------------------------------------------------------------------
-- Tree + focus state
-- -----------------------------------------------------------------------------

-- | The grid's split tree persisted in the widget store, if seeded.
lookupTree :: Int -> WidgetStore -> Maybe GridNode
lookupTree :: Int -> WidgetStore -> Maybe GridNode
lookupTree Int
k WidgetStore
st = Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
st) Maybe Dynamic -> (Dynamic -> Maybe GridNode) -> Maybe GridNode
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe GridNode
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic

-- | A stored pane id that still exists in the tree, else 0.
validPane :: GridNode -> Int -> Word64
validPane :: GridNode -> Int -> Word64
validPane GridNode
t Int
n =
  let p :: Word64
p = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
   in if GridNode -> Word64 -> Bool
paneExist GridNode
t Word64
p then Word64
p else Word64
0

-- | Focused pane: a maximized pane wins, then the stored focus if the pane
-- still exists, then the first pane in the tree.
resolveFocus :: GridNode -> Word64 -> Word64 -> Word64
resolveFocus :: GridNode -> Word64 -> Word64 -> Word64
resolveFocus GridNode
tree Word64
maxPane Word64
focus0
  | Word64
maxPane Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0 = Word64
maxPane
  | GridNode -> Word64 -> Bool
paneExist GridNode
tree Word64
focus0 = Word64
focus0
  | Bool
otherwise = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
1 ([Word64] -> Maybe Word64
forall a. [a] -> Maybe a
listToMaybe (GridNode -> [Word64]
treePanes GridNode
tree))

-- -----------------------------------------------------------------------------
-- Entry point
-- -----------------------------------------------------------------------------

paneGrid :: (Ui :> es) => PaneGridConfig es -> Eff es PaneGridResponse
paneGrid :: forall (es :: [Effect]).
(Ui :> es) =>
PaneGridConfig es -> Eff es PaneGridResponse
paneGrid PaneGridConfig es
cfg = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  inp <- askInput
  uiIO (registerFocusable ctx wid)
  let key = WidgetId -> Int
intKey WidgetId
wid
      gestK = Slot -> Int -> Int
slotKey Slot
SlotPaneGest Int
key
      grabK = Slot -> Int -> Int
slotKey Slot
SlotPaneGrab Int
key
      focusK = Slot -> Int -> Int
slotKey Slot
SlotPaneFocus Int
key
      maxK = Slot -> Int -> Int
slotKey Slot
SlotPaneMax Int
key
      seedK = Slot -> Int -> Int
slotKey Slot
SlotPaneNext Int
key
      spacing = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (PaneGridConfig es -> Float
forall (es :: [Effect]). PaneGridConfig es -> Float
pgSpacing PaneGridConfig es
cfg)
      minSize = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (PaneGridConfig es -> Float
forall (es :: [Effect]). PaneGridConfig es -> Float
pgMinSize PaneGridConfig es
cfg)
      leeway = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (PaneGridConfig es -> Float
forall (es :: [Effect]). PaneGridConfig es -> Float
pgLeeway PaneGridConfig es
cfg)
      edgeBand = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (PaneGridConfig es -> Float
forall (es :: [Effect]). PaneGridConfig es -> Float
pgEdgeBand PaneGridConfig es
cfg)
      gutter = Float
spacing Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
leeway
  st <- uiIO (getStore ctx)
  (tree0, seed1) <- case lookupTree key st of
    Just GridNode
t ->
      -- Init seeded the store before the tree existed, so the stored seed
      -- is already above every id in the tree.
      (GridNode, Word64) -> Eff es (GridNode, Word64)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GridNode
t, Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
1 Int
seedK (WidgetStore -> IntMap Int
storeInt WidgetStore
st)))
    Maybe GridNode
Nothing -> do
      let seed :: Word64
seed = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
1 (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
1 Int
seedK (WidgetStore -> IntMap Int
storeInt WidgetStore
st)))
          start :: GridNode
start = Word64 -> GridNode
Pane Word64
seed
      IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$
        Context -> WidgetStore -> IO ()
setStore
          Context
ctx
          ( WidgetStore -> WidgetStore
bumpMirror
              ( WidgetStore
st
                  { storeInt = IM.insert seedK (fromIntegral (seed + 1)) (storeInt st)
                  , storeDyn = IM.insert key (toDyn start) (storeDyn st)
                  }
              )
          )
      (GridNode, Word64) -> Eff es (GridNode, Word64)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GridNode
start, Word64
seed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
  mPrev <- uiIO (getPrevRect ctx wid)
  let baseRect = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0) Maybe Rect
mPrev
      drag0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
gestK (WidgetStore -> IntMap Int
storeInt WidgetStore
st)
      maxPane = GridNode -> Int -> Word64
validPane GridNode
tree0 (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
maxK (WidgetStore -> IntMap Int
storeInt WidgetStore
st))
      focus0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
focusK (WidgetStore -> IntMap Int
storeInt WidgetStore
st)
      focusedInit = GridNode -> Word64 -> Word64 -> Word64
resolveFocus GridNode
tree0 Word64
maxPane (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
focus0)
      mouse = Input -> V2
inputMousePos Input
inp
      (regions, dividers) = layoutNode minSize gutter tree0 baseRect
  changedRef <- uiIO (newIORef False)
  let mGrab = Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
grabK (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
st)
      dgi =
        Int -> Bool -> DragGeom -> Maybe (Float, Float) -> V2 -> DragInfo
computeDragInfo
          Int
drag0
          (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
grabK (WidgetStore -> IntMap Int
storeInt WidgetStore
st) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
          DragGeom
            { dgMinSize :: Float
dgMinSize = Float
minSize
            , dgGutter :: Float
dgGutter = Float
gutter
            , dgTree :: GridNode
dgTree = GridNode
tree0
            , dgBaseRect :: Rect
dgBaseRect = Rect
baseRect
            , dgBand :: Float
dgBand = Float
edgeBand
            , dgRegions :: Map Word64 Rect
dgRegions = Map Word64 Rect
regions
            }
          Maybe (Float, Float)
mGrab
          V2
mouse
      dgiShown = DragInfo -> Bool
dgiActive DragInfo
dgi Bool -> Bool -> Bool
&& DragInfo -> Bool
dgiMoved DragInfo
dgi Bool -> Bool -> Bool
&& Input -> Bool
inputMouseDown Input
inp
      -- Keep the committed tree for cancellation and exact drop previews,
      -- but close up the dragged pane's space in the live layout.
      visibleTree = if Bool
dgiShown then Word64 -> GridNode -> Maybe GridNode
treeRemovePane (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
drag0) GridNode
tree0 else GridNode -> Maybe GridNode
forall a. a -> Maybe a
Just GridNode
tree0
      (visibleRegions, visibleDividers)
        | dgiShown = maybe (M.empty, []) (\GridNode
t -> Float
-> Float -> GridNode -> Rect -> (Map Word64 Rect, [DividerInfo])
layoutNode Float
minSize Float
gutter GridNode
t Rect
baseRect) visibleTree
        | otherwise = (regions, dividers)
      divMap = [(Word64, DividerInfo)] -> Map Word64 DividerInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(DividerInfo -> Word64
diSplitId DividerInfo
d, DividerInfo
d) | DividerInfo
d <- [DividerInfo]
visibleDividers]
      env =
        GridEnv
          { geCtx :: Context
geCtx = Context
ctx
          , geKey :: Int
geKey = Int
key
          , gePaneScope :: IdContext
gePaneScope = Word64 -> Word64 -> IdContext
IdContext (WidgetId -> Word64
hashWidgetId WidgetId
wid) Word64
0
          , geCfg :: PaneGridConfig es
geCfg = PaneGridConfig es
cfg
          , geGutter :: Float
geGutter = Float
gutter
          , geThickness :: Float
geThickness = Float
spacing
          , geMinSize :: Float
geMinSize = Float
minSize
          , geLeeway :: Float
geLeeway = Float
leeway
          , geRegions :: Map Word64 Rect
geRegions = Map Word64 Rect
visibleRegions
          , geBaseRect :: Rect
geBaseRect = Rect
baseRect
          , geTree :: GridNode
geTree = GridNode
tree0
          , geSeed :: Word64
geSeed = Word64
seed1
          , geDrag0 :: Int
geDrag0 = Int
drag0
          , geMax :: Word64
geMax = Word64
maxPane
          , geChangedRef :: IORef Bool
geChangedRef = IORef Bool
changedRef
          , geMakeCtx :: Word64 -> Rect -> Bool -> PaneGridCtx es
geMakeCtx = \Word64
pid Rect
rect Bool
dragging ->
              PaneGridCtx
                { pgcPaneId :: Word64
pgcPaneId = Word64
pid
                , pgcRect :: Rect
pgcRect = Rect
rect
                , pgcMaximized :: Bool
pgcMaximized = Word64
maxPane Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
pid
                , pgcDragging :: Bool
pgcDragging = Bool
dragging
                , pgcDndActive :: Bool
pgcDndActive = DragInfo -> Bool
dgiMoved DragInfo
dgi
                , pgcSplit :: GridAxis -> Eff es Word64
pgcSplit = \GridAxis
axis -> GridEnv es -> Word64 -> GridAxis -> Eff es Word64
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> GridAxis -> Eff es Word64
splitPane GridEnv es
env Word64
pid GridAxis
axis
                , pgcClose :: Eff es ()
pgcClose = GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es ()
closePane GridEnv es
env Word64
pid
                , pgcMaximize :: Eff es ()
pgcMaximize = GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es ()
maximizePane GridEnv es
env Word64
pid
                , pgcRestore :: Eff es ()
pgcRestore = GridEnv es -> Eff es ()
forall (es :: [Effect]). (Ui :> es) => GridEnv es -> Eff es ()
restorePane GridEnv es
env
                }
          }

  -- Root container. Tagged so its solved rect resolves via getPrevRect for
  -- next frame's geometry.
  container NodeContainer (gridRootLayout minSize (pgLayout cfg)) $ do
    tagContainer wid
    if maxPane /= 0
      then void (renderMaxPane env maxPane)
      else do
        rendered <- maybe (pure []) (renderNode env divMap) visibleTree
        runGestures env dividers rendered dgi
        when (dgiShown && rectNonEmpty baseRect) $
          drawDragOverlay env wid rendered (dgiGhost dgi) (fmap fst (dgiZone dgi))
        -- Keyboard focus also rings the focused pane, so the arrow keys show
        -- where they moved; the grid's own ring says the grid holds focus.
        ringPane <- uiIO ((&&) <$> getFocusVisible ctx <*> ((== wid) <$> getFocusId ctx))
        when (ringPane && not dgiShown) $
          forM_ (M.lookup focusedInit visibleRegions) $ \Rect
r ->
            IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Context -> WidgetId -> Int -> CustomDrawBuild -> IO ()
registerCustomDrawing Context
ctx WidgetId
wid ([Float] -> Int
contentKey [Float
1, Rect -> Float
rectX Rect
r, Rect -> Float
rectY Rect
r, Rect -> Float
rectW Rect
r, Rect -> Float
rectH Rect
r]) (CustomDrawBuild -> IO ()) -> CustomDrawBuild -> IO ()
forall a b. (a -> b) -> a -> b
$ \CustomDrawContext
cdc Rect
_ ->
              CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect (Float -> Rect -> Rect
rectInflate (-Float
2) Rect
r) Float
2 Float
1.5 (Theme -> Color
themeAccent (CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc)))

  -- Keyboard navigation for the focused grid. Escape restores a maximized
  -- pane unless something earlier in the pass already consumed it (e.g. a
  -- dismissable popup inside a pane); the grid then claims the key so
  -- neither a nested overlay nor the app also acts on it.
  focusedNow <- uiIO (getFocusId ctx)
  when (focusedNow == wid) $ do
    nav <- useKeyNav wid
    let ch = Input -> Text
inputChars Input
inp
        cur = Word64
focusedInit
    when (knLeft nav) $ moveFocus env cur (-1, 0)
    when (knRight nav) $ moveFocus env cur (1, 0)
    when (knUp nav) $ moveFocus env cur (0, -1)
    when (knDown nav) $ moveFocus env cur (0, 1)
    when (knLeft nav || knRight nav || knUp nav || knDown nav) $
      uiIO (damageWidget ctx wid (DamageInflated 0))
    when (T.any (== 'm') ch) $ maximizePane env cur
    when (T.any (== 'x') ch) $ closePane env cur
    when (inputKeysElem KeyEscape (inputKeys inp)) $ do
      taken <- uiIO (overlayConsumesQuit ctx inp)
      unless taken $ do
        restorePane env
        uiIO (markEscapeConsumed ctx)

  changed <- uiIO (readIORef changedRef)
  stEnd <- uiIO (getStore ctx)
  let treeEnd = Int -> WidgetStore -> Maybe GridNode
lookupTree Int
key WidgetStore
stEnd
      maxEnd = Word64 -> (GridNode -> Word64) -> Maybe GridNode -> Word64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word64
0 (\GridNode
t -> GridNode -> Int -> Word64
validPane GridNode
t (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
maxK (WidgetStore -> IntMap Int
storeInt WidgetStore
stEnd))) Maybe GridNode
treeEnd
      focusEnd =
        Word64 -> (GridNode -> Word64) -> Maybe GridNode -> Word64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          Word64
0
          (\GridNode
t -> GridNode -> Word64 -> Word64 -> Word64
resolveFocus GridNode
t Word64
maxEnd (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
focusK (WidgetStore -> IntMap Int
storeInt WidgetStore
stEnd))))
          Maybe GridNode
treeEnd
  pure
    PaneGridResponse
      { pgrChanged = changed
      , pgrPaneCount = maybe 0 treeSize treeEnd
      , pgrPanes = maybe [] treePanes treeEnd
      , pgrFocusedPane = focusEnd
      , pgrMaximizedPane = maxEnd
      }

-- -----------------------------------------------------------------------------
-- Layout helpers
-- -----------------------------------------------------------------------------

gridRootLayout :: Float -> (Layout -> Layout) -> Layout
gridRootLayout :: Float -> (Layout -> Layout) -> Layout
gridRootLayout Float
minSize Layout -> Layout
f =
  Layout -> Layout
f
    Layout
defaultLayout
      { layoutDirection = Column
      , layoutGap = 0
      , layoutPadding = Padding 0 0 0 0
      , layoutWidth = Grow 1
      , layoutHeight = Grow 1
      , layoutMinW = minSize
      , layoutMinH = minSize
      }

sizingLay :: Sizing -> Sizing -> Layout
sizingLay :: Sizing -> Sizing -> Layout
sizingLay Sizing
wSiz Sizing
hSiz =
  Layout
defaultLayout
    { layoutDirection = Column
    , layoutPadding = Padding 0 0 0 0
    , layoutGap = 0
    , layoutWidth = wSiz
    , layoutHeight = hSiz
    }

-- | Zero-gap, zero-padding, grow-to-fill layout.
fillLay :: Layout
fillLay :: Layout
fillLay = Sizing -> Sizing -> Layout
sizingLay (Float -> Sizing
Grow Float
1) (Float -> Sizing
Grow Float
1)

-- | A-side sizing for a split: fixed percent along the main axis. The B side
-- grows into the remainder.
splitSideLay :: GridAxis -> Float -> Layout
splitSideLay :: GridAxis -> Float -> Layout
splitSideLay GridAxis
AxisV Float
p = Sizing -> Sizing -> Layout
sizingLay (Float -> Sizing
Percent Float
p) (Float -> Sizing
Grow Float
1)
splitSideLay GridAxis
AxisH Float
p = Sizing -> Sizing -> Layout
sizingLay (Float -> Sizing
Grow Float
1) (Float -> Sizing
Percent Float
p)

minSized :: Layout -> Float -> Float -> Layout
minSized :: Layout -> Float -> Float -> Layout
minSized Layout
l Float
minW_ Float
minH_ = Layout
l {layoutMinW = minW_, layoutMinH = minH_}

-- | The pane content wrapper: fills its cell, never below one minimum pane.
paneLay :: Float -> Layout
paneLay :: Float -> Layout
paneLay Float
m = Layout -> Float -> Float -> Layout
minSized Layout
fillLay Float
m Float
m

-- Percent of the main-axis extent for side A, after min clamping.
splitPct :: Float -> Float -> Float -> Float -> Float -> Float
splitPct :: Float -> Float -> Float -> Float -> Float -> Float
splitPct Float
spacing Float
avail Float
minA Float
minB Float
ratio
  | Float
avail Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Float
50
  | Bool
otherwise = Float -> Float -> Float -> Float -> Float -> Float
splitLength Float
spacing Float
avail Float
minA Float
minB Float
ratio Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
avail Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
100

-- -----------------------------------------------------------------------------
-- Rendering
-- -----------------------------------------------------------------------------

renderMaxPane :: (Ui :> es) => GridEnv es -> Word64 -> Eff es [RenderedPane]
renderMaxPane :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es [RenderedPane]
renderMaxPane GridEnv es
env Word64
pid =
  GridEnv es
-> Word64 -> Rect -> Layout -> Bool -> Eff es [RenderedPane]
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> Word64 -> Rect -> Layout -> Bool -> Eff es [RenderedPane]
renderPane GridEnv es
env Word64
pid (GridEnv es -> Rect
forall (es :: [Effect]). GridEnv es -> Rect
geBaseRect GridEnv es
env) (Float -> Layout
paneLay (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geMinSize GridEnv es
env)) Bool
False

-- | Enter a pane's grid-relative identity scope while leaving the split tree's
-- layout scopes intact. Consume one sibling just as 'withKey' does.
withPaneKey :: (Ui :> es) => GridEnv es -> Word64 -> Eff es a -> Eff es a
withPaneKey :: forall (es :: [Effect]) a.
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es a -> Eff es a
withPaneKey GridEnv es
env Word64
pid =
  (IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
(IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
withIdFrame (\IdContext
parent -> (IdContext
parent {siblingId = siblingId parent + 1}, GridEnv es -> IdContext
forall (es :: [Effect]). GridEnv es -> IdContext
gePaneScope GridEnv es
env)) (Eff es a -> Eff es a)
-> (Eff es a -> Eff es a) -> Eff es a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Eff es a -> Eff es a
forall k (es :: [Effect]) a.
(Hashable k, Ui :> es) =>
k -> Eff es a -> Eff es a
withKey Word64
pid

-- | Render one pane's content via 'pgViewPane' under the pane's stable key.
renderPane ::
  (Ui :> es) =>
  GridEnv es ->
  Word64 ->
  Rect ->
  Layout ->
  Bool ->
  Eff es [RenderedPane]
renderPane :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> Word64 -> Rect -> Layout -> Bool -> Eff es [RenderedPane]
renderPane GridEnv es
env Word64
pid Rect
rect Layout
lay Bool
dragging =
  GridEnv es
-> Word64 -> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall (es :: [Effect]) a.
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es a -> Eff es a
withPaneKey GridEnv es
env Word64
pid (Eff es [RenderedPane] -> Eff es [RenderedPane])
-> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall a b. (a -> b) -> a -> b
$ do
    inp <- Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput
    let ctx = GridEnv es -> Context
forall (es :: [Effect]). GridEnv es -> Context
geCtx GridEnv es
env
        arena = Context -> NodeArena
ctxNodeArena Context
ctx
    start <- uiIO (arenaCount arena)
    let ctxt = GridEnv es -> Word64 -> Rect -> Bool -> PaneGridCtx es
forall (es :: [Effect]).
GridEnv es -> Word64 -> Rect -> Bool -> PaneGridCtx es
geMakeCtx GridEnv es
env Word64
pid Rect
rect Bool
dragging
    (view, _) <- containerResponse NodeContainer lay (pgViewPane (geCfg env) pid ctxt)
    -- Press ownership must be checked against previous solved child rects:
    -- ctxActiveId is only finalized after this frame's UI has been built.
    controlHit <-
      if not (inputMousePressed inp)
        then pure False
        else uiIO $ do
          end <- arenaCount arena
          let hitFrom Int
idx
                | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                | Bool
otherwise = do
                    nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
arena Int
idx
                    hit <-
                      if isInteractiveNode nt
                        then do
                          child <- getWidgetId arena idx
                          r <- scrollHitRect ctx child
                          maybe (pure False) (\Rect
childRect -> Context -> Int -> Rect -> V2 -> IO Bool
nodeInteractionHit Context
ctx Int
idx Rect
childRect (Input -> V2
inputMousePos Input
inp)) r
                        else pure False
                    if hit then pure True else hitFrom (idx + 1)
          hitFrom start
    pure [RenderedPane pid view controlHit]

renderNode ::
  (Ui :> es) =>
  GridEnv es ->
  Map Word64 DividerInfo ->
  GridNode ->
  Eff es [RenderedPane]
renderNode :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> Map Word64 DividerInfo -> GridNode -> Eff es [RenderedPane]
renderNode GridEnv es
env Map Word64 DividerInfo
dividers = \case
  Pane Word64
pid ->
    GridEnv es
-> Word64 -> Rect -> Layout -> Bool -> Eff es [RenderedPane]
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> Word64 -> Rect -> Layout -> Bool -> Eff es [RenderedPane]
renderPane GridEnv es
env Word64
pid (GridEnv es -> Word64 -> Rect
forall (es :: [Effect]). GridEnv es -> Word64 -> Rect
paneRect GridEnv es
env Word64
pid) (Float -> Layout
paneLay (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geMinSize GridEnv es
env)) (GridEnv es -> Word64 -> Bool
forall (es :: [Effect]). GridEnv es -> Word64 -> Bool
draggingPane GridEnv es
env Word64
pid)
  Split Word64
sid0 GridAxis
ax Float
_ GridNode
a GridNode
b ->
    Word64 -> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall k (es :: [Effect]) a.
(Hashable k, Ui :> es) =>
k -> Eff es a -> Eff es a
withKey Word64
sid0 (Eff es [RenderedPane] -> Eff es [RenderedPane])
-> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall a b. (a -> b) -> a -> b
$ do
      let (Float
wa, Float
ha) = Float -> Float -> GridNode -> (Float, Float)
subtreeMin (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geMinSize GridEnv es
env) (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env) GridNode
a
          (Float
wb, Float
hb) = Float -> Float -> GridNode -> (Float, Float)
subtreeMin (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geMinSize GridEnv es
env) (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env) GridNode
b
          mDiv :: Maybe DividerInfo
mDiv = Word64 -> Map Word64 DividerInfo -> Maybe DividerInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
sid0 Map Word64 DividerInfo
dividers
          avail :: Float
avail = Float -> (DividerInfo -> Float) -> Maybe DividerInfo -> Float
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Float
0 (GridAxis -> Rect -> Float
mainLen GridAxis
ax (Rect -> Float) -> (DividerInfo -> Rect) -> DividerInfo -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DividerInfo -> Rect
diRegion) Maybe DividerInfo
mDiv
          (Float
mA, Float
mB) = GridAxis -> (Float, Float) -> (Float, Float) -> (Float, Float)
mainMins GridAxis
ax (Float
wa, Float
ha) (Float
wb, Float
hb)
          pct :: Float
pct = Float -> Float -> Float -> Float -> Float -> Float
splitPct (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env) Float
avail Float
mA Float
mB (Float -> (DividerInfo -> Float) -> Maybe DividerInfo -> Float
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Float
0.5 DividerInfo -> Float
diRatio Maybe DividerInfo
mDiv)
          aLay :: Layout
aLay = Layout -> Float -> Float -> Layout
minSized (GridAxis -> Float -> Layout
splitSideLay GridAxis
ax Float
pct) Float
wa Float
ha
          bLay :: Layout
bLay = Layout -> Float -> Float -> Layout
minSized Layout
fillLay Float
wb Float
hb
          inner :: Eff es [RenderedPane]
inner = do
            a' <- NodeType
-> Layout -> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall (es :: [Effect]) a.
(Ui :> es) =>
NodeType -> Layout -> Eff es a -> Eff es a
container NodeType
NodeContainer Layout
aLay (GridEnv es
-> Map Word64 DividerInfo -> GridNode -> Eff es [RenderedPane]
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> Map Word64 DividerInfo -> GridNode -> Eff es [RenderedPane]
renderNode GridEnv es
env Map Word64 DividerInfo
dividers GridNode
a)
            dividerWidget env ax
            b' <- container NodeContainer bLay (renderNode env dividers b)
            pure (a' <> b')
      case GridAxis
ax of
        GridAxis
AxisV -> Layout -> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall (es :: [Effect]) a.
(Ui :> es) =>
Layout -> Eff es a -> Eff es a
row' Layout
fillLay Eff es [RenderedPane]
inner
        GridAxis
AxisH -> Layout -> Eff es [RenderedPane] -> Eff es [RenderedPane]
forall (es :: [Effect]) a.
(Ui :> es) =>
Layout -> Eff es a -> Eff es a
column' Layout
fillLay Eff es [RenderedPane]
inner

-- | Prev-frame rect of a pane; zero until the pane has been laid out once.
paneRect :: GridEnv es -> Word64 -> Rect
paneRect :: forall (es :: [Effect]). GridEnv es -> Word64 -> Rect
paneRect GridEnv es
env Word64
pid = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0) (Word64 -> Map Word64 Rect -> Maybe Rect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
pid (GridEnv es -> Map Word64 Rect
forall (es :: [Effect]). GridEnv es -> Map Word64 Rect
geRegions GridEnv es
env))

-- | Is this the pane being drag-and-dropped? A resize gesture (negative id)
-- wraps to a huge 'Word64' and never matches a pane id.
draggingPane :: GridEnv es -> Word64 -> Bool
draggingPane :: forall (es :: [Effect]). GridEnv es -> Word64 -> Bool
draggingPane GridEnv es
env Word64
pid = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geDrag0 GridEnv es
env) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
pid

-- | The divider: a 'NodeDrawing' spanning the full gutter (visible thickness
-- plus the invisible grab halo on each side). Its widget rect covers the whole
-- gutter, so the resize cursor and grab apply across the halo; the gutter is
-- drawn as a faint rail with the crisp 'geThickness' strip in the middle, so
-- the whole interaction space reads as one divider.
dividerWidget :: (Ui :> es) => GridEnv es -> GridAxis -> Eff es ()
dividerWidget :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> GridAxis -> Eff es ()
dividerWidget GridEnv es
env GridAxis
axis = do
  Eff es (Response, ()) -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff es (Response, ()) -> Eff es ())
-> Eff es (Response, ()) -> Eff es ()
forall a b. (a -> b) -> a -> b
$
    CustomWidgetSpec () -> Eff es (Response, ())
forall (es :: [Effect]) a.
(Ui :> es) =>
CustomWidgetSpec a -> Eff es (Response, a)
customWidget
      CustomWidgetSpec ()
defaultCustomWidgetSpec
        { widgetLayout = dLay
        , widgetContent = contentKey [if axis == AxisV then 1 else 2, geThickness env, geLeeway env]
        , widgetDraw = \CustomDrawContext
cdc Rect
rect -> CustomDrawContext
-> Rect -> GridAxis -> Float -> Float -> SmallArray DrawOp
drawDivider CustomDrawContext
cdc Rect
rect GridAxis
axis (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geThickness GridEnv es
env) (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geLeeway GridEnv es
env)
        , widgetCursor = Just (const (if axis == AxisV then UiCursorEwResize else UiCursorNsResize))
        }
  where
    dLay :: Layout
dLay = case GridAxis
axis of
      GridAxis
AxisV -> Sizing -> Sizing -> Layout
sizingLay (Float -> Sizing
Fixed (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env)) (Float -> Sizing
Grow Float
1)
      GridAxis
AxisH -> Sizing -> Sizing -> Layout
sizingLay (Float -> Sizing
Grow Float
1) (Float -> Sizing
Fixed (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env))

drawDivider :: CustomDrawContext -> Rect -> GridAxis -> Float -> Float -> SmallArray DrawOp
drawDivider :: CustomDrawContext
-> Rect -> GridAxis -> Float -> Float -> SmallArray DrawOp
drawDivider CustomDrawContext
cdc Rect
rect GridAxis
axis Float
thickness Float
leeway =
  CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
    let theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
        panel :: Style
panel = Theme -> Style
themePanel Theme
theme
        rail :: Color
rail = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBg Style
panel) (Theme -> Color
themeSeparator Theme
theme) Float
0.12
        track :: Color
track = Style -> Theme -> Color
separatorTrackColor Style
panel Theme
theme
        trackRect :: Rect
trackRect = case GridAxis
axis of
          GridAxis
AxisV -> Float -> Float -> Float -> Float -> Rect
Rect (Rect -> Float
rectX Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
leeway) (Rect -> Float
rectY Rect
rect) Float
thickness (Rect -> Float
rectH Rect
rect)
          GridAxis
AxisH -> Float -> Float -> Float -> Float -> Rect
Rect (Rect -> Float
rectX Rect
rect) (Rect -> Float
rectY Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
leeway) (Rect -> Float
rectW Rect
rect) Float
thickness
    Rect -> Color -> CanvasM ()
drawRect Rect
rect Color
rail
    Rect -> Color -> CanvasM ()
drawRect Rect
trackRect Color
track
    Bool -> CanvasM () -> CanvasM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CustomDrawContext -> Bool
cdcHovered CustomDrawContext
cdc Bool -> Bool -> Bool
|| CustomDrawContext -> Bool
cdcPressed CustomDrawContext
cdc) (CanvasM () -> CanvasM ()) -> CanvasM () -> CanvasM ()
forall a b. (a -> b) -> a -> b
$ do
      -- Full accent while grabbed; a calmer tint while merely hovering.
      let line :: Color
line
            | CustomDrawContext -> Bool
cdcPressed CustomDrawContext
cdc = Theme -> Color
themeAccent Theme
theme
            | Bool
otherwise = Color -> Color -> Float -> Color
lerpColor (Theme -> Color
themeAccent Theme
theme) (Style -> Color
styleBg Style
panel) Float
0.45
      case GridAxis
axis of
        GridAxis
AxisV ->
          let cx :: Float
cx = Rect -> Float
rectX Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectW Rect
rect Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
           in V2 -> V2 -> Float -> Color -> CanvasM ()
drawStroke (Float -> Float -> V2
V2 Float
cx (Rect -> Float
rectY Rect
rect)) (Float -> Float -> V2
V2 Float
cx (Rect -> Float
rectY Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectH Rect
rect)) Float
2 Color
line
        GridAxis
AxisH ->
          let cy :: Float
cy = Rect -> Float
rectY Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectH Rect
rect Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
           in V2 -> V2 -> Float -> Color -> CanvasM ()
drawStroke (Float -> Float -> V2
V2 (Rect -> Float
rectX Rect
rect) Float
cy) (Float -> Float -> V2
V2 (Rect -> Float
rectX Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectW Rect
rect) Float
cy) Float
2 Color
line

-- | Drag ghost + drop-zone highlight, drawn on top of the grid via a custom
-- drawing registered on the grid's root container. Registering on the
-- container (instead of adding a flex sibling) keeps the overlay out of the
-- layout, so it never squeezes the panes and is clipped to the full grid rect.
drawDragOverlay ::
  (Ui :> es) =>
  GridEnv es ->
  WidgetId ->
  [RenderedPane] ->
  Maybe Rect ->
  Maybe Rect ->
  Eff es ()
drawDragOverlay :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> WidgetId
-> [RenderedPane]
-> Maybe Rect
-> Maybe Rect
-> Eff es ()
drawDragOverlay GridEnv es
env WidgetId
wid [RenderedPane]
rendered Maybe Rect
ghost Maybe Rect
zone = do
  st <- IO WidgetStore -> Eff es WidgetStore
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (Context -> IO WidgetStore
getStore (GridEnv es -> Context
forall (es :: [Effect]). GridEnv es -> Context
geCtx GridEnv es
env))
  let ctx = GridEnv es -> Context
forall (es :: [Effect]). GridEnv es -> Context
geCtx GridEnv es
env
      dragPane = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geDrag0 GridEnv es
env)
      cached = Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
SlotPaneGrab (GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geKey GridEnv es
env)) (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
st) Maybe Dynamic -> (Dynamic -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe Text
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
      title = Text -> (PaneView -> Text) -> Maybe PaneView -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
cached) PaneView -> Text
pvTitle ((RenderedPane -> PaneView) -> Maybe RenderedPane -> Maybe PaneView
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RenderedPane -> PaneView
rpView ((RenderedPane -> Bool) -> [RenderedPane] -> Maybe RenderedPane
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
dragPane) (Word64 -> Bool)
-> (RenderedPane -> Word64) -> RenderedPane -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedPane -> Word64
rpPaneId) [RenderedPane]
rendered))
      rectKey = [Float] -> (Rect -> [Float]) -> Maybe Rect -> [Float]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Float
0, Float
0, Float
0, Float
0, Float
0] (\(Rect Float
x Float
y Float
w Float
h) -> [Float
1, Float
x, Float
y, Float
w, Float
h])
      key = [Float] -> Int
contentKey (Float
2 Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
forall a. Hashable a => a -> Int
hash Text
title) Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: Maybe Rect -> [Float]
rectKey Maybe Rect
ghost [Float] -> [Float] -> [Float]
forall a. [a] -> [a] -> [a]
++ Maybe Rect -> [Float]
rectKey Maybe Rect
zone)
  uiIO $
    registerCustomDrawing ctx wid key (\CustomDrawContext
cdc Rect
_ -> Theme -> Text -> Maybe Rect -> Maybe Rect -> SmallArray DrawOp
drawOverlay (CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc) Text
title Maybe Rect
ghost Maybe Rect
zone)

-- | A compact, translucent drag indicator leaves the full-size drop preview
-- visible. The indicator is offset from the pointer so it cannot obscure aim.
drawOverlay :: Theme -> Text -> Maybe Rect -> Maybe Rect -> SmallArray DrawOp
drawOverlay :: Theme -> Text -> Maybe Rect -> Maybe Rect -> SmallArray DrawOp
drawOverlay Theme
theme Text
title Maybe Rect
ghost Maybe Rect
zone =
  CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
    let accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
        win :: Style
win = Theme -> Style
themeFloatingWindow Theme
theme
        panelFill :: Color
panelFill = Color -> Word8 -> Color
fadeAlpha Color
accent Word8
48
        panelBorder :: Color
panelBorder = Color -> Word8 -> Color
fadeAlpha Color
accent Word8
128
        previewFill :: Color
previewFill = Color -> Word8 -> Color
fadeAlpha Color
accent Word8
32
        shortTitle :: Text
shortTitle = if Text -> Int
T.length Text
title Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
12 then Int -> Text -> Text
T.take Int
11 Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…" else Text
title
    Maybe Rect -> (Rect -> CanvasM ()) -> CanvasM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Rect
ghost ((Rect -> CanvasM ()) -> CanvasM ())
-> (Rect -> CanvasM ()) -> CanvasM ()
forall a b. (a -> b) -> a -> b
$ \Rect
gr -> do
      Rect -> Float -> Color -> CanvasM ()
drawRoundedRect Rect
gr Float
2 Color
panelFill
      Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect Rect
gr Float
2 Float
2 Color
panelBorder
      Bool -> CanvasM () -> CanvasM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Text -> Bool
T.null Text
title)) (CanvasM () -> CanvasM ()) -> CanvasM () -> CanvasM ()
forall a b. (a -> b) -> a -> b
$
        V2 -> AlignX -> AlignY -> Text -> Color -> CanvasM ()
drawText (Float -> Float -> V2
V2 (Rect -> Float
rectX Rect
gr Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
6) (Rect -> Float
rectY Rect
gr Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
6)) AlignX
AlignStart AlignY
AlignTop Text
shortTitle (Color -> Word8 -> Color
fadeAlpha (Style -> Color
styleFg Style
win) Word8
160)
    Maybe Rect -> (Rect -> CanvasM ()) -> CanvasM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Rect
zone ((Rect -> CanvasM ()) -> CanvasM ())
-> (Rect -> CanvasM ()) -> CanvasM ()
forall a b. (a -> b) -> a -> b
$ \Rect
zr -> do
      Rect -> Float -> Color -> CanvasM ()
drawRoundedRect Rect
zr Float
2 Color
previewFill
      Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect (Float -> Rect -> Rect
rectInflate (-Float
1) Rect
zr) Float
2 Float
2 Color
accent

-- -----------------------------------------------------------------------------
-- Gestures
-- -----------------------------------------------------------------------------

-- | Grid geometry 'computeDragInfo' needs for the current frame.
data DragGeom = DragGeom
  { DragGeom -> Float
dgMinSize :: !Float
    -- ^ Per-pane size floor used by the preview layout.
  , DragGeom -> Float
dgGutter :: !Float
    -- ^ Layout gutter between panes ('pgSpacing' + 2 * 'pgLeeway').
  , DragGeom -> GridNode
dgTree :: !GridNode
    -- ^ Current split tree.
  , DragGeom -> Rect
dgBaseRect :: !Rect
    -- ^ Prev-frame rect of the grid's root container.
  , DragGeom -> Float
dgBand :: !Float
    -- ^ Thickness of the grid's outer top-level drop band.
  , DragGeom -> Map Word64 Rect
dgRegions :: !(Map Word64 Rect)
    -- ^ Prev-frame pane regions.
  }

-- | Pure drag-and-drop geometry for the current frame. Geometry is computed
-- for as long as the gesture id is armed (not just while the button is held),
-- so the drop zone is still resolvable on the frame the button is released.
-- 'dgBaseRect' is the grid's own rect: its outer band (thickness 'dgBand') is
-- a top-level drop zone, and the pointer there restructures the whole grid;
-- otherwise the pane under the pointer is the target. Every candidate is
-- resolved through 'dropPreview', which simulates the drop and lays the tree
-- back out with the grid's real 'dgGutter' and 'dgMinSize', so the
-- highlighted rect is the exact region the pane lands in even when removing
-- it reshapes the rest of a mixed-split grid.
computeDragInfo :: Int -> Bool -> DragGeom -> Maybe (Float, Float) -> V2 -> DragInfo
computeDragInfo :: Int -> Bool -> DragGeom -> Maybe (Float, Float) -> V2 -> DragInfo
computeDragInfo Int
drag0 Bool
latched DragGeom
geom Maybe (Float, Float)
mGrab V2
mouse
  | Int
drag0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Bool -> Bool -> Maybe Rect -> Maybe (Rect, PaneDrop) -> DragInfo
DragInfo Bool
False Bool
False Maybe Rect
forall a. Maybe a
Nothing Maybe (Rect, PaneDrop)
forall a. Maybe a
Nothing
  | Bool
otherwise =
      let DragGeom{dgMinSize :: DragGeom -> Float
dgMinSize = Float
minSize, dgGutter :: DragGeom -> Float
dgGutter = Float
gutter, dgTree :: DragGeom -> GridNode
dgTree = GridNode
tree, dgBaseRect :: DragGeom -> Rect
dgBaseRect = Rect
baseRect, dgBand :: DragGeom -> Float
dgBand = Float
band, dgRegions :: DragGeom -> Map Word64 Rect
dgRegions = Map Word64 Rect
regions} = DragGeom
geom
          pid :: Word64
pid = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
drag0
          mFrom :: Maybe Rect
mFrom = Word64 -> Map Word64 Rect -> Maybe Rect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
pid Map Word64 Rect
regions
          (Float
gx, Float
gy) = (Float, Float) -> Maybe (Float, Float) -> (Float, Float)
forall a. a -> Maybe a -> a
fromMaybe (Float
0, Float
0) Maybe (Float, Float)
mGrab
          moved :: Bool
moved = Bool
latched Bool -> Bool -> Bool
|| case Maybe Rect
mFrom of
            Just (Rect Float
px Float
py Float
_ Float
_) ->
              let vx :: Float
vx = V2 -> Float
v2X V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gx)
                  vy :: Float
vy = V2 -> Float
v2Y V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gy)
               in Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
vy Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
dragThresholdPx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dragThresholdPx
            Maybe Rect
Nothing -> Bool
False
          ghost :: Maybe Rect
ghost = case Maybe Rect
mFrom of
            Just Rect
_
              | Bool
moved -> Rect -> Maybe Rect
forall a. a -> Maybe a
Just (Float -> Float -> Float -> Float -> Rect
Rect (V2 -> Float
v2X V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
12) (V2 -> Float
v2Y V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
12) Float
112 Float
28)
            Maybe Rect
_ -> Maybe Rect
forall a. Maybe a
Nothing
          targetRegions :: Map Word64 Rect
targetRegions = Map Word64 Rect
-> (GridNode -> Map Word64 Rect)
-> Maybe GridNode
-> Map Word64 Rect
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Word64 Rect
forall k a. Map k a
M.empty (\GridNode
t -> (Map Word64 Rect, [DividerInfo]) -> Map Word64 Rect
forall a b. (a, b) -> a
fst (Float
-> Float -> GridNode -> Rect -> (Map Word64 Rect, [DividerInfo])
layoutNode Float
minSize Float
gutter GridNode
t Rect
baseRect)) (Word64 -> GridNode -> Maybe GridNode
treeRemovePane Word64
pid GridNode
tree)
          under :: [(Word64, Rect)]
under =
            [ (Word64
q, Rect
r)
            | (Word64
q, Rect
r) <- Map Word64 Rect -> [(Word64, Rect)]
forall k a. Map k a -> [(k, a)]
M.toList Map Word64 Rect
targetRegions
            , Word64
q Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
pid
            , Rect -> V2 -> Bool
rectHit Rect
r V2
mouse
            ]
          zone :: Maybe (Rect, PaneDrop)
zone = case Float -> Rect -> V2 -> Maybe PaneDrop
topLevelDropTarget Float
band Rect
baseRect V2
mouse of
            Just PaneDrop
dt -> Float
-> Float
-> GridNode
-> Word64
-> Rect
-> PaneDrop
-> Maybe (Rect, PaneDrop)
dropPreview Float
minSize Float
gutter GridNode
tree Word64
pid Rect
baseRect PaneDrop
dt
            Maybe PaneDrop
Nothing -> case [(Word64, Rect)]
under of
              (Word64
q, Rect
r) : [(Word64, Rect)]
_ ->
                let dt :: PaneDrop
dt = Rect -> V2 -> Word64 -> PaneDrop
dropTargetForPane Rect
r V2
mouse Word64
q
                 in Float
-> Float
-> GridNode
-> Word64
-> Rect
-> PaneDrop
-> Maybe (Rect, PaneDrop)
dropPreview Float
minSize Float
gutter GridNode
tree Word64
pid Rect
baseRect PaneDrop
dt
              [] -> Maybe (Rect, PaneDrop)
forall a. Maybe a
Nothing
       in Bool -> Bool -> Maybe Rect -> Maybe (Rect, PaneDrop) -> DragInfo
DragInfo Bool
True Bool
moved Maybe Rect
ghost Maybe (Rect, PaneDrop)
zone

-- | Apply resize / drag transitions, writing to the widget store.
runGestures ::
  (Ui :> es) =>
  GridEnv es ->
  [DividerInfo] ->
  [RenderedPane] ->
  DragInfo ->
  Eff es ()
runGestures :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es
-> [DividerInfo] -> [RenderedPane] -> DragInfo -> Eff es ()
runGestures GridEnv es
env [DividerInfo]
dividers [RenderedPane]
rendered DragInfo
dgi = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  let regions = GridEnv es -> Map Word64 Rect
forall (es :: [Effect]). GridEnv es -> Map Word64 Rect
geRegions GridEnv es
env
      mouse = Input -> V2
inputMousePos Input
inp
      press = Input -> Bool
inputMousePressed Input
inp
      down = Input -> Bool
inputMouseDown Input
inp
      drag0 = GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geDrag0 GridEnv es
env
      busy = Int
drag0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      -- diBand already spans spacing + both leeway margins. Inflating it
      -- again steals presses from the neighboring pane, especially headers.
      hitDiv =
        (DividerInfo -> Bool) -> [DividerInfo] -> Maybe DividerInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
          (\DividerInfo
d -> Rect -> V2 -> Bool
rectHit (DividerInfo -> Rect
diBand DividerInfo
d) V2
mouse)
          [DividerInfo]
dividers
      -- The pane whose pick rect (or, when 'pvDraggable', whole region) is
      -- under the pointer.
      pickHit =
        [Word64] -> Maybe Word64
forall a. [a] -> Maybe a
listToMaybe
          [ Word64
p
          | RenderedPane
pane <- [RenderedPane]
rendered
          , let p :: Word64
p = RenderedPane -> Word64
rpPaneId RenderedPane
pane
                v :: PaneView
v = RenderedPane -> PaneView
rpView RenderedPane
pane
          , Bool -> (Rect -> Bool) -> Maybe Rect -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Rect -> V2 -> Bool
`rectHit` V2
mouse) (PaneView -> Maybe Rect
pvDragPick PaneView
v)
              Bool -> Bool -> Bool
|| (PaneView -> Bool
pvDraggable PaneView
v Bool -> Bool -> Bool
&& Bool -> (Rect -> Bool) -> Maybe Rect -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Rect -> V2 -> Bool
`rectHit` V2
mouse) (Word64 -> Map Word64 Rect -> Maybe Rect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
p Map Word64 Rect
regions))
          ]
      gestK = Slot -> Int -> Int
slotKey Slot
SlotPaneGest (GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geKey GridEnv es
env)
      grabK = Slot -> Int -> Int
slotKey Slot
SlotPaneGrab (GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geKey GridEnv es
env)
  menu <- uiIO (getMenuPointerGesture ctx)
  -- A press arms the gesture slot (negative split id for a resize, pane id
  -- for a drag) together with its start state in one store write. The resize
  -- start keeps the divider's ratio and the pointer's main-axis coordinate so
  -- drag frames move the divider by delta instead of snapping it to the
  -- pointer; the drag start keeps the title and the grab offset (mouse - pane
  -- origin) for the drag threshold.
  when (press && not busy && not menu && not (any rpControlHit rendered)) $ do
    case hitDiv of
      Just DividerInfo
d ->
        GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
storeWrite GridEnv es
env Bool
True ((WidgetStore -> WidgetStore) -> Eff es ())
-> (WidgetStore -> WidgetStore) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st -> WidgetStore
st
          { storeInt = IM.insert gestK (negate (fromIntegral (diSplitId d))) (storeInt st)
          , storePoint = IM.insert (slotKey SlotPaneResize (geKey env)) (diRatio d, mouseMain d mouse) (storePoint st)
          }
      Maybe DividerInfo
Nothing ->
        Maybe Word64 -> (Word64 -> Eff es ()) -> Eff es ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Word64
pickHit ((Word64 -> Eff es ()) -> Eff es ())
-> (Word64 -> Eff es ()) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \Word64
pid -> do
          let title :: Text
title = Text -> (RenderedPane -> Text) -> Maybe RenderedPane -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (PaneView -> Text
pvTitle (PaneView -> Text)
-> (RenderedPane -> PaneView) -> RenderedPane -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedPane -> PaneView
rpView) ((RenderedPane -> Bool) -> [RenderedPane] -> Maybe RenderedPane
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
pid) (Word64 -> Bool)
-> (RenderedPane -> Word64) -> RenderedPane -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedPane -> Word64
rpPaneId) [RenderedPane]
rendered)
              (Float
gx, Float
gy) = (Float, Float)
-> (Rect -> (Float, Float)) -> Maybe Rect -> (Float, Float)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Float
0, Float
0) (\(Rect Float
px Float
py Float
_ Float
_) -> (V2 -> Float
v2X V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
px, V2 -> Float
v2Y V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
py)) (Word64 -> Map Word64 Rect -> Maybe Rect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
pid Map Word64 Rect
regions)
          GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
storeWrite GridEnv es
env Bool
True ((WidgetStore -> WidgetStore) -> Eff es ())
-> (WidgetStore -> WidgetStore) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st -> WidgetStore
st
            { storeDyn = IM.insert grabK (toDyn title) (storeDyn st)
            , storeInt = IM.insert gestK (fromIntegral pid) (IM.delete grabK (storeInt st))
            , storePoint = IM.insert grabK (gx, gy) (storePoint st)
            }
  when (drag0 < 0 && down) $ do
    let sid = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int
forall a. Num a => a -> a
negate Int
drag0)
    forM_ (find ((== sid) . diSplitId) dividers) $ \DividerInfo
d -> do
      st <- IO WidgetStore -> Eff es WidgetStore
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (Context -> IO WidgetStore
getStore Context
ctx)
      let (ratio0, main0) =
            IM.findWithDefault (diRatio d, mouseMain d mouse) (slotKey SlotPaneResize (geKey env)) (storePoint st)
          -- The ratio shares out the region minus the divider gutter.
          usable = GridAxis -> Rect -> Float
mainLen (DividerInfo -> GridAxis
diAxis DividerInfo
d) (DividerInfo -> Rect
diRegion DividerInfo
d) Float -> Float -> Float
forall a. Num a => a -> a -> a
- GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env
          r0 =
            if Float
usable Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0
              then Float
ratio0
              else Float
ratio0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (DividerInfo -> V2 -> Float
mouseMain DividerInfo
d V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
main0) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
usable
          r' = GridNode -> Word64 -> Rect -> Float -> Float -> Float -> Float
clampTreeRatio (GridEnv es -> GridNode
forall (es :: [Effect]). GridEnv es -> GridNode
geTree GridEnv es
env) Word64
sid (DividerInfo -> Rect
diRegion DividerInfo
d) (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geGutter GridEnv es
env) (GridEnv es -> Float
forall (es :: [Effect]). GridEnv es -> Float
geMinSize GridEnv es
env) Float
r0
       in putTree env (Just (treeSetRatio sid r' (geTree env)))
  when (drag0 < 0 && not down) $ writeGest env 0
  -- Keep the loop at the display cadence while a pane is being dragged: the
  -- ghost follows the pointer, and without a dirty flag the debug HUD's slow
  -- refresh paces the whole frame (4 fps). Window / scroll / resize drags mark
  -- dirty every frame for the same reason.
  when (drag0 > 0 && down) $ uiIO (markDirty ctx)
  when (drag0 > 0 && down && dgiMoved dgi) $
    storeWrite env False $ \WidgetStore
st -> WidgetStore
st {storeInt = IM.insert (slotKey SlotPaneGrab (geKey env)) 1 (storeInt st)}
  -- A drop clears the gesture and, when it moved the pane, stores the new
  -- tree, seed and focus in the same write.
  when (drag0 > 0 && not down) $ do
    let moved = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
drag0
        dropped
          | DragInfo -> Bool
dgiMoved DragInfo
dgi = DragInfo -> Maybe (Rect, PaneDrop)
dgiZone DragInfo
dgi Maybe (Rect, PaneDrop)
-> ((Rect, PaneDrop) -> Maybe GridNode) -> Maybe GridNode
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Rect
_, PaneDrop
dt) -> Word64 -> Word64 -> PaneDrop -> GridNode -> Maybe GridNode
treeMovePane Word64
moved (GridEnv es -> Word64
forall (es :: [Effect]). GridEnv es -> Word64
geSeed GridEnv es
env) PaneDrop
dt (GridEnv es -> GridNode
forall (es :: [Effect]). GridEnv es -> GridNode
geTree GridEnv es
env)
          | Bool
otherwise = Maybe GridNode
forall a. Maybe a
Nothing
    storeWrite env True $ \WidgetStore
st -> case Maybe GridNode
dropped of
      Maybe GridNode
Nothing -> WidgetStore
st {storeInt = IM.delete gestK (storeInt st)}
      Just GridNode
t' ->
        WidgetStore
st
          { storeDyn = IM.insert (geKey env) (toDyn t') (storeDyn st)
          , storeInt =
              IM.insert (slotKey SlotPaneNext (geKey env)) (fromIntegral (geSeed env + 1)) $
                IM.insert (slotKey SlotPaneFocus (geKey env)) (fromIntegral moved) $
                  IM.delete gestK (storeInt st)
          }
    when (isJust dropped) (markChanged env)

mouseMain :: DividerInfo -> V2 -> Float
mouseMain :: DividerInfo -> V2 -> Float
mouseMain DividerInfo
d V2
mouse = case DividerInfo -> GridAxis
diAxis DividerInfo
d of
  GridAxis
AxisV -> V2 -> Float
v2X V2
mouse
  GridAxis
AxisH -> V2 -> Float
v2Y V2
mouse

-- -----------------------------------------------------------------------------
-- Keyboard navigation
-- -----------------------------------------------------------------------------

moveFocus ::
  (Ui :> es) =>
  GridEnv es ->
  Word64 ->
  (Float, Float) ->
  Eff es ()
moveFocus :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> (Float, Float) -> Eff es ()
moveFocus GridEnv es
env Word64
cur (Float, Float)
dir =
  case Map Word64 Rect -> Word64 -> (Float, Float) -> Maybe Word64
neighborPane (GridEnv es -> Map Word64 Rect
forall (es :: [Effect]). GridEnv es -> Map Word64 Rect
geRegions GridEnv es
env) Word64
cur (Float, Float)
dir of
    Just Word64
pid -> Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot Bool
False Slot
SlotPaneFocus GridEnv es
env Word64
pid
    Maybe Word64
Nothing -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

neighborPane :: Map Word64 Rect -> Word64 -> (Float, Float) -> Maybe Word64
neighborPane :: Map Word64 Rect -> Word64 -> (Float, Float) -> Maybe Word64
neighborPane Map Word64 Rect
regions Word64
cur (Float
dx, Float
dy) =
  case Word64 -> Map Word64 Rect -> Maybe Rect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
cur Map Word64 Rect
regions of
    Maybe Rect
Nothing -> Maybe Word64
forall a. Maybe a
Nothing
    Just Rect
curR ->
      let (Float
cx, Float
cy) = Rect -> (Float, Float)
centerOf Rect
curR
          scored :: [(Word64, Float)]
scored =
            [ (Word64
pid, Float
s)
            | (Word64
pid, Rect
r) <- Map Word64 Rect -> [(Word64, Rect)]
forall k a. Map k a -> [(k, a)]
M.toList Map Word64 Rect
regions
            , Word64
pid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
cur
            , Rect -> Bool
rectNonEmpty Rect
r
            , let (Float
px, Float
py) = Rect -> (Float, Float)
centerOf Rect
r
                  vx :: Float
vx = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx
                  vy :: Float
vy = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy
                  dotv :: Float
dotv = Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy
            , Float
dotv Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0
            , let s :: Float
s = Float -> Float
forall a. Num a => a -> a
abs (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
dotv
            ]
       in case [(Word64, Float)]
scored of
            [] -> Maybe Word64
forall a. Maybe a
Nothing
            [(Word64, Float)]
_ -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just ((Word64, Float) -> Word64
forall a b. (a, b) -> a
fst (((Word64, Float) -> (Word64, Float) -> Ordering)
-> [(Word64, Float)] -> (Word64, Float)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((Word64, Float) -> Float)
-> (Word64, Float) -> (Word64, Float) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Word64, Float) -> Float
forall a b. (a, b) -> b
snd) [(Word64, Float)]
scored))

centerOf :: Rect -> (Float, Float)
centerOf :: Rect -> (Float, Float)
centerOf Rect
r = (Rect -> Float
rectX Rect
r Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectW Rect
r Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2, Rect -> Float
rectY Rect
r Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectH Rect
r Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)

-- -----------------------------------------------------------------------------
-- Store mutation helpers
-- -----------------------------------------------------------------------------

splitPane :: (Ui :> es) => GridEnv es -> Word64 -> GridAxis -> Eff es Word64
splitPane :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> GridAxis -> Eff es Word64
splitPane GridEnv es
env Word64
pid GridAxis
axis = do
  let splitId :: Word64
splitId = GridEnv es -> Word64
forall (es :: [Effect]). GridEnv es -> Word64
geSeed GridEnv es
env
      newPane :: Word64
newPane = GridEnv es -> Word64
forall (es :: [Effect]). GridEnv es -> Word64
geSeed GridEnv es
env Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
  GridEnv es -> Maybe GridNode -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Maybe GridNode -> Eff es ()
putTree GridEnv es
env (GridNode -> Maybe GridNode
forall a. a -> Maybe a
Just (Word64
-> Word64 -> GridAxis -> Bool -> Word64 -> GridNode -> GridNode
treeSplit Word64
pid Word64
splitId GridAxis
axis Bool
False Word64
newPane (GridEnv es -> GridNode
forall (es :: [Effect]). GridEnv es -> GridNode
geTree GridEnv es
env)))
  GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es ()
putSeed GridEnv es
env (GridEnv es -> Word64
forall (es :: [Effect]). GridEnv es -> Word64
geSeed GridEnv es
env Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2)
  Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot Bool
False Slot
SlotPaneFocus GridEnv es
env Word64
newPane
  Word64 -> Eff es Word64
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
newPane

closePane :: (Ui :> es) => GridEnv es -> Word64 -> Eff es ()
closePane :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es ()
closePane GridEnv es
env Word64
pid =
  case Word64 -> GridNode -> Maybe GridNode
treeRemovePane Word64
pid (GridEnv es -> GridNode
forall (es :: [Effect]). GridEnv es -> GridNode
geTree GridEnv es
env) of
    Maybe GridNode
Nothing -> GridEnv es -> Maybe GridNode -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Maybe GridNode -> Eff es ()
putTree GridEnv es
env Maybe GridNode
forall a. Maybe a
Nothing
    Just GridNode
t' -> do
      GridEnv es -> Maybe GridNode -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Maybe GridNode -> Eff es ()
putTree GridEnv es
env (GridNode -> Maybe GridNode
forall a. a -> Maybe a
Just GridNode
t')
      Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GridEnv es -> Word64
forall (es :: [Effect]). GridEnv es -> Word64
geMax GridEnv es
env Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
pid) (Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot Bool
True Slot
SlotPaneMax GridEnv es
env Word64
0)

maximizePane :: (Ui :> es) => GridEnv es -> Word64 -> Eff es ()
maximizePane :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es ()
maximizePane GridEnv es
env Word64
pid = do
  let v :: Word64
v = if GridEnv es -> Word64
forall (es :: [Effect]). GridEnv es -> Word64
geMax GridEnv es
env Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
pid then Word64
0 else Word64
pid
  Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot Bool
True Slot
SlotPaneMax GridEnv es
env Word64
v
  -- Maximizing hides the dividers and every other pane, so an armed drag or
  -- resize gesture could never complete; cancel it instead of leaking it.
  Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
v Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0) (GridEnv es -> Int -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Int -> Eff es ()
writeGest GridEnv es
env Int
0)

restorePane :: (Ui :> es) => GridEnv es -> Eff es ()
restorePane :: forall (es :: [Effect]). (Ui :> es) => GridEnv es -> Eff es ()
restorePane GridEnv es
env = Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot Bool
True Slot
SlotPaneMax GridEnv es
env Word64
0

-- | One store round-trip. @mirror@ bumps the mirror generation so the
-- running frame rebuilds its UI and layout with the new value (see
-- 'NanoUI.Frame'); the store write itself wakes the renderer.
storeWrite ::
  (Ui :> es) =>
  GridEnv es ->
  Bool ->
  (WidgetStore -> WidgetStore) ->
  Eff es ()
storeWrite :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
storeWrite GridEnv es
env Bool
mirror WidgetStore -> WidgetStore
f =
  IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore (GridEnv es -> Context
forall (es :: [Effect]). GridEnv es -> Context
geCtx GridEnv es
env) ((if Bool
mirror then WidgetStore -> WidgetStore
bumpMirror else WidgetStore -> WidgetStore
forall a. a -> a
id) (WidgetStore -> WidgetStore)
-> (WidgetStore -> WidgetStore) -> WidgetStore -> WidgetStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetStore -> WidgetStore
f)

-- | Flag 'pgrChanged' for this frame.
markChanged :: (Ui :> es) => GridEnv es -> Eff es ()
markChanged :: forall (es :: [Effect]). (Ui :> es) => GridEnv es -> Eff es ()
markChanged GridEnv es
env = IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GridEnv es -> IORef Bool
forall (es :: [Effect]). GridEnv es -> IORef Bool
geChangedRef GridEnv es
env) Bool
True)

-- | Structural change (mirror + 'pgrChanged'): store the tree, or remove it
-- entirely when the last pane was closed. The pane-id seed keeps counting
-- across a removal, so the re-seeded pane gets a fresh id and state keyed by
-- pane id never collides with a closed pane's state.
putTree :: (Ui :> es) => GridEnv es -> Maybe GridNode -> Eff es ()
putTree :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Maybe GridNode -> Eff es ()
putTree GridEnv es
env Maybe GridNode
mTree = do
  GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
storeWrite GridEnv es
env Bool
True ((WidgetStore -> WidgetStore) -> Eff es ())
-> (WidgetStore -> WidgetStore) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st ->
    WidgetStore
st {storeDyn = maybe (IM.delete k) (IM.insert k . toDyn) mTree (storeDyn st)}
  GridEnv es -> Eff es ()
forall (es :: [Effect]). (Ui :> es) => GridEnv es -> Eff es ()
markChanged GridEnv es
env
  where
    k :: Int
k = GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geKey GridEnv es
env

-- | Gesture slot: 0 none, positive = dragged pane id, negative = resized
-- split id.
writeGest :: (Ui :> es) => GridEnv es -> Int -> Eff es ()
writeGest :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Int -> Eff es ()
writeGest GridEnv es
env Int
n =
  GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
storeWrite GridEnv es
env Bool
True ((WidgetStore -> WidgetStore) -> Eff es ())
-> (WidgetStore -> WidgetStore) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st ->
    WidgetStore
st
      { storeInt =
          if n == 0
            then IM.delete (slotKey SlotPaneGest (geKey env)) (storeInt st)
            else IM.insert (slotKey SlotPaneGest (geKey env)) n (storeInt st)
      }

-- | Write a pane-id slot (maximized or focused pane) when it differs,
-- bumping the mirror; @structural@ also flags 'pgrChanged'.
putPaneSlot :: (Ui :> es) => Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot :: forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Slot -> GridEnv es -> Word64 -> Eff es ()
putPaneSlot Bool
structural Slot
slot GridEnv es
env Word64
v = do
  let k :: Int
k = Slot -> Int -> Int
slotKey Slot
slot (GridEnv es -> Int
forall (es :: [Effect]). GridEnv es -> Int
geKey GridEnv es
env)
      n :: Int
n = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v
  st <- IO WidgetStore -> Eff es WidgetStore
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (Context -> IO WidgetStore
getStore (GridEnv es -> Context
forall (es :: [Effect]). GridEnv es -> Context
geCtx GridEnv es
env))
  when (IM.findWithDefault 0 k (storeInt st) /= n) $ do
    storeWrite env True (\WidgetStore
st' -> WidgetStore
st' {storeInt = IM.insert k n (storeInt st')})
    when structural (markChanged env)

-- | Advance the next-id seed ('SlotPaneNext').
putSeed :: (Ui :> es) => GridEnv es -> Word64 -> Eff es ()
putSeed :: forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Word64 -> Eff es ()
putSeed GridEnv es
env Word64
v =
  GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
forall (es :: [Effect]).
(Ui :> es) =>
GridEnv es -> Bool -> (WidgetStore -> WidgetStore) -> Eff es ()
storeWrite GridEnv es
env Bool
False ((WidgetStore -> WidgetStore) -> Eff es ())
-> (WidgetStore -> WidgetStore) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st ->
    WidgetStore
st {storeInt = IM.insert (slotKey SlotPaneNext (geKey env)) (fromIntegral v) (storeInt st)}