packages feed

nano-ui (empty) → 0.1.0.0

raw patch · 136 files changed

+41977/−0 lines, 136 filesdep +basedep +bytestringdep +colonnade

Dependencies added: base, bytestring, colonnade, containers, effectful, effectful-core, ghc-compact, hashable, hashtables, hexml, hspec, inspection-testing, nano-ui, nothunks, primitive, tasty-bench, text, text-short, unordered-containers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,28 @@+# Changelog++## 0.1.0.0++First release.++- Immediate-mode views in `Eff '[Ui, IOE]`: widgets add layout nodes, read+  the frame's input, and return results. State lives in hooks (`useInt`,+  `useText`, `useState`), in a model passed through the view, or in a+  reducer with `NanoUI.Emit`.+- Widgets: buttons, checkboxes, radios, text inputs, a multi-line text area,+  numeric fields, sliders, knobs, selects, combo boxes, sortable tables,+  trees, tabs, menus, context menus, modals, floating windows, split panes,+  pane grids, colour pickers, progress bars, sparklines, spinners, rich text+  with links, SVG icons, and drag and drop. `customWidget` and a canvas API+  draw anything else.+- Row, column and grid layout with `Layout -> Layout` modifiers, and+  scrollers with tunable wheel steps, smooth scrolling, and scroll commands.+- Keyboard focus and navigation for every control.+- Text fields with undo and redo, driven by `TextCommand` values. Shaped+  text and mixed left-to-right and right-to-left lines when the backend+  provides shaping.+- Themes, including Base16 schemes, changed for part of a view with `styled`+  and composable style modifiers. `disabledWhen` switches widgets off.+- Eased and spring animation.+- Frames run only when something needs redrawing, and each frame computes+  its damage against the previous one.+- `NanoUI.Testing` runs frames headlessly on scripted input.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2026 goolord++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,166 @@+# nano-ui++An immediate-mode GUI toolkit for Haskell.++A view is a function that runs every frame. Each widget is an ordinary effect+that adds a layout node, reads this frame's input, and returns a result: `Bool`+for a button, the new value for an input. There are no widget objects to keep+and no callbacks to register. Widget state lives in a store keyed by each+widget's position among its siblings (or by a key you give it with `withKey`),+or in a model you pass through the view.++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Data.Text qualified as T+import NanoUI+import NanoUI.Backend.Sdl (defaultSdlOptions, runSdlApp)++main :: IO ()+main = runSdlApp defaultSdlOptions counter++counter :: NanoUI ()+counter = do+  (n, setN) <- useInt 0+  row $ do+    whenM (button "-") (setN (n - 1))+    label (T.pack (show n))+    whenM (button "+") (setN (n + 1))+```++## Features++- Text inputs and a multi-line text area, numeric fields, sliders, knobs,+  selects, combo boxes, sortable tables, trees, tabs, menus, context menus,+  modals, floating windows, pane grids, colour pickers, progress bars,+  sparklines, and drag and drop. `customWidget` and a canvas API cover+  anything else.+- Row, column, and grid layout with scrolling. Layout options are+  `Layout -> Layout` modifiers, as in `columnWith (gap 8 . padAll 12)`.+- Scrollers take a wheel step and a glide time (`setScrollTuning`,+  `setScrollStep`), and move from code: `scrollTo`, `scrollBy`, `scrollPages`,+  and `scrollIntoView`. `getScrollMetrics` gives a virtualized list the+  viewport and offset it needs to pick its rows.+- Keyboard focus and navigation for every control.+- Shaped text in the SDL backend, with fallback fonts for other scripts and+  mixed left-to-right and right-to-left lines. `richText` wraps a paragraph+  of mixed styles and links, as in+  `richText ["Read ", strong "the guide", " or ", hyperlink "faq" "the FAQ"]`.+- Text fields with undo and redo, driven by `TextCommand` values that code+  can run too.+- SVG icons (`loadSvg`, `svgIcon`) and a `spinner`.+- Backends block on input and run a frame only when something needs+  redrawing. Each frame computes its damage against the previous one.+- State in local hooks (`useInt`, `useText`, `useState`), in your own model,+  or in a reducer with `NanoUI.Emit`.+- Eased and spring animation.+- Themes, including ones built from Base16 schemes, changed for part of a+  view with `styled` and composable modifiers, as in+  `styled (primary . buttonStyle (cornerRadius 6)) (button "Save")`.+  `disabledWhen` switches widgets off.+- `NanoUI.Testing` runs frames headlessly on scripted input, for tests.++## Examples++Inputs are controlled: pass the current value and keep the result. A change you+don't store is undone on the next frame.++```haskell+greeter :: NanoUI ()+greeter = columnWith (gap 8 . padAll 16) $ do+  (name, setName) <- useText "world"+  (size, setSize) <- useFloat 16+  (shout, setShout) <- useFlag False++  heading "Greeter"+  setName =<< textInput name+  setSize =<< slider 10 48 size+  setShout =<< checkbox "Shout" shout++  let greeting = "Hello, " <> name <> "!"+  labelWith (fontSize size) (if shout then T.toUpper greeting else greeting)+```++For an Elm-style update function, the widgets in `NanoUI.Emit` emit messages+instead of returning values, and `runSdlAppReduce` folds them into the model:++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Data.Text qualified as T+import NanoUI+import NanoUI.Backend.Sdl (defaultSdlOptions, runSdlAppReduce)+import NanoUI.Emit qualified as Emit++data Msg = Increment | Decrement++main :: IO ()+main = runSdlAppReduce defaultSdlOptions update 0 view++update :: Msg -> Int -> Int+update Increment n = n + 1+update Decrement n = n - 1++view :: Int -> NanoUI ()+view n = row $ do+  Emit.button "-" Decrement+  label (T.pack (show n))+  Emit.button "+" Increment+```++## How it works++`NanoUI` is `Eff '[Ui, IOE]` from+[effectful](https://hackage.haskell.org/package/effectful), and widgets have+types like `Ui :> es => Eff es Bool`, so a view can run in a larger effect+stack. A frame:++1. Resets the node and vertex arenas and runs the view. Widgets add layout+   nodes and read and write the widget store.+2. Solves layout.+3. Resolves pointer, keyboard, and focus against the new geometry.+4. Paints into pinned vertex and index buffers, in background, content,+   overlay, and chrome layers.+5. Computes damage against the previous frame and hands the draw list to the+   backend.++[docs/rendering-pipeline.svg](https://github.com/goolord/nano-ui/blob/main/docs/rendering-pipeline.svg) has the diagram.+Per-frame code is profiled for allocation, and an+[inspection-testing](https://hackage.haskell.org/package/inspection-testing)+suite checks that the vertex writers compile without dictionaries or tuples.++## Packages++| Package | What it is |+| --- | --- |+| `nano-ui` | Widgets, layout, input handling, and the draw list |+| `nano-ui-sdl` | Window backend on SDL3, with TrueType fonts, installed-font lookup, and native file dialogs |+| `nano-ui-rgfw` | Window backend on RGFW and OpenGL 3.2, with a bundled bitmap font and no system dependencies beyond windowing |+| `nano-ui-rgfw-bindings` | Haskell bindings to RGFW |+| `nano-ui-diagrams` | Line, bar, scatter, and area charts, and drawing with [diagrams](https://diagrams.github.io/) |+| `nano-ui-form` | Validated forms built on [ditto](https://hackage.haskell.org/package/ditto) |+| `nano-ui-demo` | Example applications |++## Running the demos++You need GHC 9.10 or later and Cabal. The SDL backend also needs SDL3,+SDL3_ttf, and pkg-config. `nix develop` sets these up.++```sh+cabal run nano-ui-sdl-demo       # widget and chart tour+cabal run nano-ui-sdl-notepad    # text editor with menus and file dialogs+cabal run nano-ui-sdl-logs       # streaming log viewer+cabal run nano-ui-sdl-terminal   # terminal on /bin/sh (Linux and macOS)+cabal run nano-ui-rgfw-demo      # the RGFW backend+```++## Documentation++Start with the `NanoUI` module documentation: it explains how widgets return+values, how inputs keep their state, and how layout modifiers compose.+[docs/development.md](https://github.com/goolord/nano-ui/blob/main/docs/development.md) covers building, testing,+profiling, and the layout of this repository.++## License++MIT
+ benchmark/IdBench.hs view
@@ -0,0 +1,51 @@+module Main (main) where++import Control.Monad (forM_, replicateM_, void, when)+import GHC.Stats (RTSStats (..), getRTSStats)+import NanoUI+import NanoUI.Testing (newContext, runFrame)+import System.Exit (exitFailure)+import System.Mem (performGC)+import Test.Tasty.Bench++benchInput :: Input+benchInput = emptyInput {inputWindowSize = Size 100 100}++-- A layout root is required or runFrame overflows.+idBurst :: NanoUI ()+idBurst = column (burstNextIds 4096)++scopedWidgets :: NanoUI ()+scopedWidgets =+  columnWith (gap 2)+    $ replicateM_ 32+    $ rowWith (gap 2)+    $ replicateM_ 32 (void nextId)++measureFrameAlloc :: NanoUI a -> IO Integer+measureFrameAlloc ui = do+  ctx <- newContext+  _ <- runFrame ctx benchInput (column (void nextId))+  performGC+  before <- getRTSStats+  _ <- runFrame ctx benchInput ui+  after <- getRTSStats+  pure (fromIntegral (allocated_bytes after - allocated_bytes before) :: Integer)++main :: IO ()+main = do+  let scenes = [("burst4096", idBurst), ("scopedWidgets", scopedWidgets)]+  forM_ scenes $ \(name, ui) -> do+    alloc <- measureFrameAlloc ui+    when (alloc > 0) $ do+      putStrLn ("FAIL: " ++ name ++ " allocated " ++ show alloc ++ " bytes during runFrame")+      exitFailure+  defaultMain+    [ bgroup+        "id/nextId"+        [ bench name $ whnfIO $ do+            ctx <- newContext+            void (runFrame ctx benchInput ui)+        | (name, ui) <- scenes+        ]+    ]
+ examples/Profile.hs view
@@ -0,0 +1,132 @@+module Main (main) where++import Control.Exception (evaluate)+import Control.Monad (forM_, replicateM_, void)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Primitive.SmallArray (SmallArray)+import NanoUI+import NanoUI.Svg (rasterizeSvg)+import NanoUI.Testing (newContext, runFrame)+import System.Environment (getArgs)+import System.IO.Unsafe (unsafePerformIO)++-- Enough frames for a stable time profile without an interactive window.+iterations :: Int+iterations = 3000++-- | A grid of buttons and labels: the ordinary widget path.+widgetScene :: NanoUI ()+widgetScene =+  columnWith+    (grow . gap 8)+    ( do+        replicateM_ 12 $+          gridWith 8 (gap 8) $+            replicateM_ 8 (void (button "OK"))+        label "nano-ui profile loop"+    )++-- | A thousand rects: enough ops that building them costs more than replaying+-- them, which is the case a content key is for.+canvasOps :: CustomDrawContext -> Rect -> SmallArray DrawOp+canvasOps cdc (Rect x y w h) = runCanvas $ do+  let side = 32 :: Int+      cw = w / fromIntegral side+      ch = h / fromIntegral side+      accent = themeAccent (cdcTheme cdc)+  forM_ [0 .. side - 1] $ \i ->+    forM_ [0 .. side - 1] $ \j -> do+      let fx = x + fromIntegral i * cw+          fy = y + fromIntegral j * ch+          tint = fromIntegral ((i * side + j) `mod` 255) / 255+      drawRect (Rect fx fy (cw - 1) (ch - 1)) (lerpColor accent (colorRGBA 255 255 255 255) tint)++-- | 'canvasOps', counting the frames that actually build the ops. The count+-- says which path a scene took: one build for a keyed widget the frames reuse,+-- one per frame for an unkeyed one.+{-# NOINLINE countedCanvasOps #-}+countedCanvasOps :: CustomDrawContext -> Rect -> SmallArray DrawOp+countedCanvasOps cdc rect = unsafePerformIO $ do+  modifyIORef' buildCount (+ 1)+  pure (canvasOps cdc rect)++{-# NOINLINE buildCount #-}+buildCount :: IORef Int+buildCount = unsafePerformIO (newIORef 0)++-- | An op-heavy custom widget. Pass 0 for the unkeyed path, which rebuilds and+-- compares its ops every frame, or a content key, which reuses them while it+-- is unchanged.+canvasScene :: Int -> NanoUI ()+canvasScene key =+  void $+    customWidget+      defaultCustomWidgetSpec+        { widgetLayout = fixedWH 512 512 defaultLayout+        , widgetContent = key+        , widgetDraw = countedCanvasOps+        }++-- | A focused text area over a long document, typing into its middle: the+-- editor path, whose per-frame cost must not grow with the document.+textAreaScene :: IORef Text -> NanoUI ()+textAreaScene ref = column $ do+  txt <- textAreaWith grow =<< uiIO (readIORef ref)+  uiIO (writeIORef ref txt)++clockIcon :: Text+clockIcon =+  "<svg viewBox='0 0 24 24' fill='none' stroke='currentColor' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'>\+  \<circle cx='12' cy='12' r='10'/><path d='M12 6v6l4 2'/></svg>"++starIcon :: Text+starIcon =+  "<svg viewBox='0 0 24 24'><path fill='#e0a030' d='M12 2l3.09 6.26L22 9.27l-5 4.87 1.18 6.88L12 17.77l-6.18 3.25L7 14.14 2 9.27l6.91-1.01L12 2z'/></svg>"++longDocument :: Text+longDocument = T.intercalate "\n" [T.pack ("line " ++ show i ++ " of a long document") | i <- [1 .. 100000 :: Int]]++main :: IO ()+main = do+  args <- getArgs+  ctx <- newContext+  case args of+    ("svg" : _) -> do+      -- A stroked icon with round caps and joins and a filled one, at a small+      -- and a large size; a varying size keeps each raster from being shared.+      let parsed = mapM parseSvg [clockIcon, starIcon]+      case parsed of+        Left err -> fail err+        Right docs ->+          forM_ [1 .. 500 :: Int] $ \i ->+            forM_ docs $ \doc -> do+              let white = colorRGBA 255 255 255 255+              void (evaluate (rasterizeSvg (16 + i `mod` 2) 16 white doc))+              void (evaluate (rasterizeSvg (128 + i `mod` 2) 128 white doc))+      putStrLn "profiled 1000 rasterizations of two icons at 16 and 128 px"+    ("textarea" : _) -> do+      ref <- newIORef longDocument+      let inp = emptyInput {inputWindowSize = Size 800 600}+          frame i = void (runFrame ctx i (textAreaScene ref))+      frame inp+      frame inp {inputKeys = inputKeysFromList [KeyTab]}+      replicateM_ 50 (frame inp {inputKeys = inputKeysFromList (replicate 100 KeyDown)})+      forM_ (take 1000 (cycle "typing into the middle ")) $ \c ->+        frame inp {inputChars = T.singleton c}+      putStrLn "profiled 1000 textarea keystroke frames"+    _ -> do+      let inp =+            emptyInput+              { inputWindowSize = Size 800 600+              , inputMousePos = V2 400 300+              , inputMouseDown = True+              }+          (name, ui) = case args of+            ("canvas" : _) -> ("canvas", canvasScene 0)+            ("canvas-keyed" : _) -> ("canvas-keyed", canvasScene 1)+            _ -> ("widgets", widgetScene)+      replicateM_ iterations (void (runFrame ctx inp ui))+      builds <- readIORef buildCount+      putStrLn ("profiled " ++ show iterations ++ " " ++ name ++ " frames, op builds: " ++ show builds)
+ lib/NanoUI.hs view
@@ -0,0 +1,1193 @@+-- |+-- Module      : NanoUI+-- Description : Immediate-mode GUI toolkit+-- Copyright   : (c) 2026 Zachary Churchill+-- License     : MIT+-- Maintainer  : zacharyachurchill@gmail.com+--+-- A view is a function that runs every frame. Widgets are ordinary calls:+-- each one lays itself out, reads this frame's input, and returns what the+-- user did. There are no widget objects to keep and no callbacks to register.+--+-- @+-- counter :: NanoUI ()+-- counter = do+--   (n, setN) <- useInt 0+--   row $ do+--     whenM (button "-") (setN (n - 1))+--     label (T.pack (show n))+--     whenM (button "+") (setN (n + 1))+-- @+--+-- Run a view with a backend: @runSdlApp@ from @nano-ui-sdl@ or @runRgfwApp@+-- from @nano-ui-rgfw@.+--+-- = Conventions+--+-- * Widgets return what you usually need: 'Bool' for buttons and menu items,+--   the new value for inputs, and @()@ for text and decoration.+-- * A primed name also returns the widget's 'Response', for hover state,+--   geometry, tooltips, and change or submit flags: @button'@, @slider'@.+-- * Inputs are controlled. Pass the current value and keep the result; a+--   change you do not store is undone on the next frame. Editing state such+--   as the caret, a drag in progress, or an open dropdown stays inside the+--   widget.+-- * Layout arguments are modifiers, as in @buttonWith (fixedW 120)@ or+--   @columnWith (gap 8 . padAll 12)@. Widgets with more options take a+--   configuration record: 'textInputConfigured', 'tabsConfigured'.+--+-- = State+--+-- Keep state in local hooks ('useInt', 'useText', 'useState'), in a model you+-- pass down through the view, or in a reducer: "NanoUI.Emit" has widgets that+-- emit messages, and the backends' reducer runners fold them into the model.+module NanoUI+  ( -- * Views+    NanoUI+  , Ui+  , runUi+  , runNanoUI+  , uiIO+  , whenM+  , unlessM+  , ifM+  , windowSize+  , windowWidth+  , windowHeight+  , uiMousePos++    -- * Widget identity++    -- | Every widget and hook takes the next 'WidgetId' in its container:+    -- ids count up in call order among siblings, and a container starts a+    -- new count for its children. Widget state is stored under that id, so+    -- the same widgets and hooks must run in the same order every frame.+    --+    -- A widget that runs on some frames and not others moves the ids of the+    -- siblings after it. Put the conditional part inside 'scope', which takes+    -- one id whether or not its body adds anything. For a list whose items+    -- are added, removed or reordered, run each item under 'withKey' (or+    -- 'keyed') with a key unique among its siblings, so the item's state+    -- follows its key instead of its position.+  , scope+  , keyed+  , keyedTag+  , withKey+  , nextId+  , currentId+  , burstNextIds+  , WidgetId (..)+  , IdContext+  , initialIdContext+  , widgetId+  , hashWidgetId+  , mix64+  , mixFnv++    -- * Responses+  , Response (..)+  , HasResponse (..)+  , respId+  , respRect+  , respHovered+  , respPressed+  , respClicked+  , respChanged+  , respSubmitted+  , respRightPressed+  , respRightClicked+  , setChanged+  , setClicked+  , setSubmitted++    -- * Containers+  , row+  , rowWith+  , column+  , columnWith+  , hstack+  , vstack+  , grid+  , gridWith+  , panel+  , panelWith+  , card+  , callout+  , calloutWith+  , toolbar+  , center+  , responsive+  , responsiveRowCol+  , scroll+  , scrollWith+  , scroll2D+  , scroll2DWith+  , scrollArea+  , scrollArea2D+  , separator+  , spacer+  , flex++    -- * Text+  , label+  , label'+  , labelWith+  , labelWith'+  , heading+  , muted+  , mono+  , danger+  , bold+  , italic+  , underline+  , kv+  , kvMono+  , kvBlock+  , selectableText+  , selectableText'+  , selectableTextWith+  , selectableTextWith'++    -- * Buttons and menus+  , button+  , button'+  , buttonWith+  , buttonWith'+  , menuButton+  , menuButton'+  , menuItem+  , menuItem'+  , menuItemShortcut+  , menuItemDisabled+  , menuSeparator+  , menuHeader+  , contextMenu+  , contextMenuArea+  , useContextMenu++    -- * Inputs+  , checkbox+  , checkbox'+  , toggleSwitch+  , toggleSwitch'+  , toggleSwitchWith+  , toggleSwitchWith'+  , radio+  , radio'+  , boundedRadio+  , boundedRadio'+  , enumRadio+  , enumRadio'+  , select+  , select'+  , selectWith+  , selectWith'+  , boundedSelect+  , boundedSelect'+  , enumSelect+  , enumSelect'+  , slider+  , slider'+  , sliderWith+  , sliderWith'+  , knob+  , knob'+  , knobWith+  , knobWith'+  , TextInputConfig (..)+  , defaultTextInputConfig+  , textInput+  , textInput'+  , textInputConfigured+  , textInputConfigured'+  , NumericInputConfig (..)+  , defaultNumericInputConfig+  , numericInput+  , numericInput'+  , numericInputConfigured+  , numericInputConfigured'+  , SearchFieldConfig (..)+  , defaultSearchFieldConfig+  , searchField+  , searchField'+  , searchFieldConfigured+  , searchFieldConfigured'+  , comboBox+  , comboBox'+  , textArea+  , textArea'+  , textAreaWith+  , textAreaWith'+  , colorPicker+  , colorPicker'+  , colorPickerRGBA+  , colorPickerRGBA'+  , colorToHex+  , colorToHexA+  , colorFromHex++    -- * Text editing+    -- | Text fields change their text only through 'TextCommand's. Keys run+    -- them (Backspace is @'Delete' 'CharLeft'@, Ctrl+Z is 'Undo'), the+    -- right-click menu runs them, and an app can run them on a field by its+    -- id:+    --+    -- @+    -- (resp, body') <- 'textArea'' body+    -- canUndo <- 'textCanUndo' ('respId' resp)+    -- 'whenM' ('menuItem' \"Undo\") ('runTextCommand' ('respId' resp) 'Undo')+    -- 'whenM' ('menuItem' \"Insert date\") ('runTextCommand' ('respId' resp) ('InsertText' today))+    -- @+    --+    -- Every command that changes text is recorded for undo. Typing joins one+    -- undo step per word and deleting one per run; the steps keep the edits+    -- themselves, not copies of the document, so a long history of a large+    -- document stays small. Replacing the value a field is passed clears its+    -- history.+  , TextCommand (..)+  , TextMotion (..)+  , Cursor (..)+  , runTextCommand+  , textCanUndo+  , textCanRedo++    -- * Tabs, trees, and tables+  , Tab (..)+  , TabStyle (..)+  , TabOrientation (..)+  , TabResponse (..)+  , TabsConfig (..)+  , defaultTabsConfig+  , tab+  , closableTab+  , tabs+  , tabs'+  , tabsConfigured+  , tabsConfigured'+  , tabBar+  , tabBar'+  , tabBarConfigured+  , tabBarConfigured'+  , TreeItem (..)+  , tree+  , tree'+  , SortDir (..)+  , SortCol (..)+  , ColSize (..)+  , TableConfig (..)+  , TableResponse (..)+  , defaultTableConfig+  , table+  , tableWith+  , tableConfigured+  , simpleTable+  , useTableSort+  , tableHiddenIndices+  , sortRows+  , Colonnade+  , Headed (..)+  , headed+  , headless++    -- * Overlays+  , modal+  , window+  , PopupAnchor (..)+  , PopupPlacement (..)+  , PopupConfig (..)+  , defaultPopupConfig+  , popup+  , popupWith+  , tooltip+  , tooltipAt+  , tooltipWidget+  , withTooltip++    -- * Pane grids+  , PaneGridConfig (..)+  , defaultPaneGridConfig+  , PaneGridCtx (..)+  , PaneView (..)+  , PaneGridResponse (..)+  , GridAxis (..)+  , paneGrid++    -- * Progress and sparklines+  , progressBar+  , progressBar'+  , progressBarWith+  , progressBarWith'+  , circularProgress+  , circularProgress'+  , circularProgressWith+  , circularProgressWith'+  , spinner+  , spinner'+  , spinnerWith+  , spinnerWith'+  , Inline+  , inlineText+  , inlineWith+  , restyle+  , strong+  , emphasis+  , inlineCode+  , hyperlink+  , richText+  , richText'+  , richTextWith+  , richTextWith'+  , sparkline+  , sparkline'+  , sparklineWith+  , sparklineWith'++    -- * Images and drawing+  , ImageId (..)+  , image+  , image'+  , freshImageId+  , registerImageRgba+  , Svg+  , parseSvg+  , loadSvg+  , svgIcon+  , svgIconWith+  , svgIconWith'+  , svgSize+  , box+  , drawing+  , drawingVersioned+  , drawingCached+  , DrawOp (..)+  , TextFont (..)+  , defaultTextFont+  , DrawingBuild+  , drawTextBox+  , shiftDrawOp++    -- * Custom widgets+  , CustomWidgetSpec (..)+  , defaultCustomWidgetSpec+  , customWidget+  , customWidgetWithId+  , contentKey+  , CustomDrawContext (..)+  , CustomMeasureFn+  , CustomDrawBuild+  , CanvasM+  , runCanvas+  , canvas+  , drawRect+  , drawRoundedRect+  , drawCircle+  , drawStroke+  , drawStrokeRoundedRect+  , drawStrokeCircle+  , drawStrokeAA+  , drawQuadGradient+  , drawLinearGradientH+  , drawLinearGradientV+  , drawImage+  , drawImageUV+  , drawText+  , useDrag2D+  , Drag2D (..)+  , useWheelDelta++    -- * Drag and drop+  , DropType (..)+  , DropEvent (..)+  , emptyDropEvents+  , DropTarget (..)+  , useDrop+  , dropZone++    -- * Local state+  , useState+  , useFlag+  , useToggle+  , useInt+  , useFloat+  , useEnum+  , useText++    -- * Scrolling++    -- | A scroll container ('scroll', 'scroll2D') handles the wheel and its+    -- own scrollbars. These move one from the outside, keyed by the+    -- 'WidgetId' that 'scrollArea' and 'scrollArea2D' hand back.+    --+    -- How far the wheel goes, and whether a scroll glides onto its target+    -- instead of jumping, is one setting for the whole app:+    --+    -- @+    -- 'setScrollTuning' ctx 'defaultScrollTuning'+    --   { 'scrollWheelStep' = 3 * rowHeight  -- three rows a notch+    --   , 'scrollSmoothTime' = 0.12          -- glide onto it+    --   }+    -- @+    --+    -- 'setScrollStep' gives one list a step of its own. With a glide time+    -- set, every wheel notch and every 'ScrollSmooth' command eases onto its+    -- target over that many seconds, and the frame loop keeps drawing until+    -- it lands.+    --+    -- 'scrollIntoView' brings a widget inside the scroller into view: the row+    -- a keyboard selection just moved to, say. A list that only builds the+    -- rows it shows has no widget to point at for the rest, so scroll to+    -- where the row would be with 'scrollRectIntoView', whose rectangle is in+    -- content coordinates. 'getScrollMetrics' reports the viewport, range and+    -- offset such a list needs to pick its visible rows in the first place.+  , ScrollTuning (..)+  , defaultScrollTuning+  , getScrollTuning+  , setScrollTuning+  , getScrollStep+  , setScrollStep+  , ScrollMetrics (..)+  , ScrollAxes (..)+  , getScrollMetrics+  , ScrollBehavior (..)+  , ScrollAlign (..)+  , scrollTo+  , scrollBy+  , scrollPages+  , scrollToStart+  , scrollToEnd+  , scrollIntoView+  , scrollRectIntoView+  , scrollGliding+  , getScrollOffset+  , setScrollOffset+  , getScrollOffset2D+  , setScrollOffset2D++    -- * Animation+  , Transition (..)+  , animate+  , animateTo+  , animateToA+  , pulse+  , keepAnimating+  , Animatable (..)+  , Ease (..)+  , applyEase+  , SpringParams (..)+  , presetBouncy+  , presetSmooth+  , presetStiff++    -- * Layout+  , Layout (..)+  , LayoutModifier+  , Sizing (..)+  , Direction (..)+  , AlignX (..)+  , AlignY (..)+  , Padding (..)+  , defaultLayout+  , askDefaultLayout+  , withDefaultLayout+  , padAll+  , padXY+  , gap+  , fillW+  , fillH+  , grow+  , minW+  , maxW+  , fixedW+  , minH+  , maxH+  , fixedH+  , fixedWH+  , alignMid+  , alignEnd+  , alignStart+  , alignCenter+  , alignTop+  , alignBottom+  , tight+  , percent+  , gridMinColW+  , gridCols+  , fixedAspectW+  , fixedAspectH++    -- * Text style+  , FontVariant (..)+  , FontWeight (..)+  , FontStyle (..)+  , TextDecoration (..)+  , fontRegular+  , fontHeading+  , fontMuted+  , fontMono+  , fontDanger+  , fontSize+  , fontSizeScale+  , fontColor+  , fontWeight+  , fontBold+  , fontLight+  , fontMedium+  , fontSemiBold+  , fontExtraBold+  , fontBlack+  , fontStyle+  , fontItalic+  , fontOblique+  , textDecoration+  , fontUnderline+  , fontStrike++    -- * Styling+    -- | A 'Theme' says how every kind of widget looks: a 'Style' for each+    -- surface (buttons, inputs, panels, floating windows) and colours for+    -- accents, text selection, links and so on. The context holds one theme+    -- for the whole app ('setTheme'); 'styled' changes it for part of the+    -- view. Style and theme modifiers compose with @(.)@ like layout+    -- modifiers do:+    --+    -- @+    -- toolbar = 'styled' ('subtle' . 'buttonStyle' ('cornerRadius' 6)) $ 'row' $ do+    --   'whenM' ('button' \"Open\") openFile+    --   'styled' 'primary' ('whenM' ('button' \"Save\") save)+    -- @+    --+    -- Scopes nest, and each one modifies the theme around it, so a modifier+    -- written once ('primary', 'destructive', or one of your own) works in any+    -- theme. 'uiTheme' reads the theme where it is called.+    --+    -- 'disabledWhen' switches the widgets inside it off: they keep their+    -- layout and state, take no input, and fade toward the window colour.+  , styled+  , themed+  , disabledWhen+  , uiTheme+    -- ** Style modifiers+  , background+  , foreground+  , borderColor+  , borderWidth+  , cornerRadius+  , hoverBackground+  , pressBackground+  , fillColor+    -- ** Theme modifiers+  , buttonStyle+  , inputStyle+  , panelStyle+  , windowStyle+  , everyStyle+  , accentColor+  , textColor+  , mutedColor+  , linkColor+  , selectionColor+  , windowColor+  , rounded+  , primary+  , destructive+  , success+  , subtle+  , tinted+  , readableOn+  , disabledTheme++    -- * Themes+  , Theme (..)+  , Style (..)+  , defaultTheme+  , tomorrowNightMinDarkTheme+  , tomorrowMinLightTheme+  , tomorrowMidnightMinDarkTheme+  , Base16 (..)+  , themeFromBase16+  , themeFromBase16Dark+  , themeFromBase16Light+  , base16TomorrowNight+  , base16TomorrowLight+  , withTheme+  , setTheme+  , getTheme+  , setUiTheme+  , themeSeries+  , scrollBarTrackColor+  , scrollBarThumbColor++    -- * Geometry and colour+  , V2 (..)+  , Rect (..)+  , Size (..)+  , Color (..)+  , colorRGBA+  , colorToWord32+  , colorLuminance+  , colorR+  , colorG+  , colorB+  , colorA+  , lerpColor+  , contrastRatio+  , rectContains+  , rectInflate+  , rectIntersect+  , rectUnion+  , v2Add+  , v2Sub++    -- * Input+  , Input (..)+  , Key (..)+  , Modifiers (..)+  , emptyInput+  , inputInteracted+  , inputPointerHeld+  , appendInputKey+  , appendDropEvent+  , emptyInputKeys+  , inputKeysElem+  , inputKeysFromList+  , inputKeysNull+  , foldInputKeys++    -- * Damage+  , Damage (..)+  , DamageBounds (..)+  , defaultDamageSlop+  , sliderDamageSlop+  , haloDamageSlop+  , resolveDamageRect+  , damageWidgetNow+  , damageKeyNow+  , damageRectNow+  , damageGroupNow+  , damageFullNow++    -- * Backend support+  , FontMetrics (..)+  , FontBackend (..)+  , prepareFontMetrics+  , prepareFontMetricsMany+  , measureTextIO+  , lineWidthIO+  , lineWidth+  , drawShaped+  , drawGlyph+  , GlyphQuad (..)+  , ShapedText (..)+  , ShapedGlyphs (..)+  , scaleFontMetrics+  , monospaceMetrics+  , uiFontMetrics+  , widgetContentInset+  , widgetPadding+  , treeItemPadding+  , ScrollBarSlot (..)+  , scrollBarGutter+  , scrollBarWidth+  , windowPad+  , windowMargin+  , Compact+  , compactHost+  , askCompact+  )+where++import NanoUI.Animatable (Animatable (..))+import NanoUI.Animation+  ( SpringParams (..)+  , presetBouncy+  , presetSmooth+  , presetStiff+  )+import NanoUI.Compact (Compact, askCompact, compactHost)+import NanoUI.Context+  ( Ease (..)+  , ScrollAlign (..)+  , ScrollAxes (..)+  , ScrollBehavior (..)+  , ScrollMetrics (..)+  , ScrollTuning (..)+  , applyEase+  , defaultScrollTuning+  , getScrollMetrics+  , getScrollOffset+  , getScrollOffset2D+  , getScrollStep+  , getScrollTuning+  , getTheme+  , scrollBy+  , scrollGliding+  , scrollIntoView+  , scrollPages+  , scrollRectIntoView+  , scrollTo+  , scrollToEnd+  , scrollToStart+  , setScrollOffset+  , setScrollOffset2D+  , setScrollStep+  , setScrollTuning+  , setTheme+  , withTheme+  )+import NanoUI.Draw (TextFont (..), defaultTextFont, drawTextBox, shiftDrawOp)+import NanoUI.Font+  ( FontBackend (..)+  , FontMetrics (..)+  , GlyphQuad (..)+  , ShapedText (..)+  , ShapedGlyphs (..)+  , ScrollBarSlot (..)+  , drawGlyph+  , drawShaped+  , lineWidth+  , lineWidthIO+  , measureTextIO+  , monospaceMetrics+  , prepareFontMetrics+  , prepareFontMetricsMany+  , scaleFontMetrics+  , scrollBarGutter+  , scrollBarWidth+  , treeItemPadding+  , widgetContentInset+  , widgetPadding+  )+import NanoUI.Hooks (useEnum, useFlag, useFloat, useInt, useState, useText, useToggle)+import NanoUI.Id+  ( IdContext+  , WidgetId (..)+  , hashWidgetId+  , initialIdContext+  , mix64+  , mixFnv+  , widgetId+  )+import NanoUI.Input+  ( DropEvent (..)+  , DropType (..)+  , Input (..)+  , Key (..)+  , Modifiers (..)+  , appendInputKey+  , appendDropEvent+  , emptyDropEvents+  , emptyInput+  , emptyInputKeys+  , foldInputKeys+  , inputInteracted+  , inputKeysElem+  , inputKeysFromList+  , inputKeysNull+  , inputPointerHeld+  )+import NanoUI.Monad+  ( NanoUI+  , Ui+  , askDefaultLayout+  , burstNextIds+  , currentId+  , damageFullNow+  , disabledWhen+  , styled+  , themed+  , damageGroupNow+  , damageKeyNow+  , damageRectNow+  , damageWidgetNow+  , ifM+  , keyed+  , keyedTag+  , nextId+  , runNanoUI+  , runUi+  , scope+  , setUiTheme+  , uiFontMetrics+  , uiIO+  , uiMousePos+  , uiTheme+  , unlessM+  , whenM+  , windowHeight+  , windowSize+  , windowWidth+  , withDefaultLayout+  , withKey+  )+import NanoUI.Style+  ( AlignX (..)+  , AlignY (..)+  , Base16 (..)+  , Direction (..)+  , FontStyle (..)+  , FontVariant (..)+  , FontWeight (..)+  , Layout (..)+  , LayoutModifier+  , Padding (..)+  , Sizing (..)+  , Style (..)+  , TextDecoration (..)+  , Theme (..)+  , accentColor+  , background+  , borderColor+  , borderWidth+  , buttonStyle+  , cornerRadius+  , destructive+  , disabledTheme+  , everyStyle+  , fillColor+  , foreground+  , hoverBackground+  , inputStyle+  , linkColor+  , mutedColor+  , panelStyle+  , pressBackground+  , primary+  , readableOn+  , rounded+  , selectionColor+  , subtle+  , success+  , textColor+  , tinted+  , windowColor+  , windowStyle+  , alignBottom+  , alignCenter+  , alignEnd+  , alignMid+  , alignStart+  , alignTop+  , base16TomorrowLight+  , base16TomorrowNight+  , defaultLayout+  , defaultTheme+  , fillH+  , fillW+  , fixedAspectH+  , fixedAspectW+  , fixedH+  , fixedW+  , fixedWH+  , fontBlack+  , fontBold+  , fontColor+  , fontDanger+  , fontExtraBold+  , fontHeading+  , fontItalic+  , fontLight+  , fontMedium+  , fontMono+  , fontMuted+  , fontOblique+  , fontRegular+  , fontSemiBold+  , fontSize+  , fontSizeScale+  , fontStrike+  , fontStyle+  , fontUnderline+  , fontWeight+  , gap+  , gridCols+  , gridMinColW+  , grow+  , maxH+  , maxW+  , minH+  , minW+  , padAll+  , padXY+  , percent+  , scrollBarThumbColor+  , scrollBarTrackColor+  , textDecoration+  , themeFromBase16+  , themeFromBase16Dark+  , themeFromBase16Light+  , themeSeries+  , tight+  , tomorrowMidnightMinDarkTheme+  , tomorrowMinLightTheme+  , tomorrowNightMinDarkTheme+  , windowMargin+  , windowPad+  )+import NanoUI.Svg (Svg, parseSvg, svgSize)+import NanoUI.Types+  ( Color (..)+  , Damage (..)+  , DamageBounds (..)+  , ImageId (..)+  , Rect (..)+  , Size (..)+  , V2 (..)+  , colorA+  , colorB+  , colorG+  , colorLuminance+  , colorR+  , colorRGBA+  , colorToWord32+  , contrastRatio+  , defaultDamageSlop+  , haloDamageSlop+  , lerpColor+  , rectContains+  , rectInflate+  , rectIntersect+  , rectUnion+  , resolveDamageRect+  , sliderDamageSlop+  , v2Add+  , v2Sub+  )+import NanoUI.WidgetText (colorFromHex, colorToHex, colorToHexA)+import NanoUI.Widgets.Animate (Transition (..), animate, animateTo, animateToA, keepAnimating, pulse)+import NanoUI.Widgets.Button (button, button', buttonWith, buttonWith')+import NanoUI.Widgets.Checkbox (checkbox, checkbox')+import NanoUI.Widgets.ColorPicker (colorPicker, colorPicker', colorPickerRGBA, colorPickerRGBA')+import NanoUI.Widgets.Combo (comboBox, comboBox')+import NanoUI.Widgets.Custom+  ( CanvasM+  , CustomDrawBuild+  , CustomDrawContext (..)+  , CustomMeasureFn+  , CustomWidgetSpec (..)+  , Drag2D (..)+  , canvas+  , circularProgress+  , circularProgress'+  , circularProgressWith+  , circularProgressWith'+  , spinner+  , spinner'+  , spinnerWith+  , spinnerWith'+  , customWidget+  , customWidgetWithId+  , contentKey+  , defaultCustomWidgetSpec+  , drawCircle+  , drawImage+  , drawImageUV+  , drawLinearGradientH+  , drawLinearGradientV+  , drawQuadGradient+  , drawRect+  , drawRoundedRect+  , drawStroke+  , drawStrokeAA+  , drawStrokeCircle+  , drawStrokeRoundedRect+  , drawText+  , knob+  , knob'+  , knobWith+  , knobWith'+  , progressBar+  , progressBar'+  , progressBarWith+  , progressBarWith'+  , runCanvas+  , sparkline+  , sparkline'+  , sparklineWith+  , sparklineWith'+  , toggleSwitch+  , toggleSwitch'+  , toggleSwitchWith+  , toggleSwitchWith'+  , useDrag2D+  , useWheelDelta+  )+import NanoUI.Widgets.Display+  ( bold+  , box+  , card+  , danger+  , freshImageId+  , heading+  , image+  , image'+  , italic+  , kv+  , kvBlock+  , kvMono+  , mono+  , muted+  , registerImageRgba+  , loadSvg+  , svgIcon+  , svgIconWith+  , svgIconWith'+  , toolbar+  , underline+  )+import NanoUI.Widgets.Drawing (DrawOp (..), DrawingBuild, drawing, drawingCached, drawingVersioned)+import NanoUI.Widgets.Drop (DropTarget (..), dropZone, useDrop)+import NanoUI.Widgets.Layout+  ( callout+  , calloutWith+  , center+  , column+  , columnWith+  , flex+  , grid+  , gridWith+  , hstack+  , label+  , label'+  , vstack+  , labelWith+  , labelWith'+  , panel+  , panelWith+  , responsive+  , responsiveRowCol+  , row+  , rowWith+  , scroll+  , scroll2D+  , scroll2DWith+  , scrollArea+  , scrollArea2D+  , scrollWith+  , separator+  , spacer+  )+import NanoUI.Widgets.Menu+  ( contextMenu+  , contextMenuArea+  , menuButton+  , menuButton'+  , menuHeader+  , menuItem+  , menuItem'+  , menuItemDisabled+  , menuItemShortcut+  , menuSeparator+  , useContextMenu+  )+import NanoUI.Widgets.Node+  ( HasResponse (..)+  , Response (..)+  , respChanged+  , respClicked+  , respHovered+  , respId+  , respPressed+  , respRect+  , respRightClicked+  , respRightPressed+  , respSubmitted+  , setChanged+  , setClicked+  , setSubmitted+  )+import NanoUI.Widgets.NumericInput (NumericInputConfig (..), defaultNumericInputConfig, numericInput, numericInput', numericInputConfigured, numericInputConfigured')+import NanoUI.Widgets.Overlay (modal, window)+import NanoUI.Widgets.PaneGrid+  ( GridAxis (..)+  , PaneGridConfig (..)+  , PaneGridCtx (..)+  , PaneGridResponse (..)+  , PaneView (..)+  , defaultPaneGridConfig+  , paneGrid+  )+import NanoUI.Widgets.Popup+  ( PopupAnchor (..)+  , PopupConfig (..)+  , PopupPlacement (..)+  , defaultPopupConfig+  , popup+  , popupWith+  , tooltip+  , tooltipAt+  , tooltipWidget+  , withTooltip+  )+import NanoUI.Widgets.Radio (boundedRadio, boundedRadio', enumRadio, enumRadio', radio, radio')+import NanoUI.Widgets.RichText (Inline, emphasis, hyperlink, inlineCode, inlineText, inlineWith, restyle, richText, richText', richTextWith, richTextWith', strong)+import NanoUI.Widgets.Select+  ( boundedSelect+  , boundedSelect'+  , enumSelect+  , enumSelect'+  , select+  , select'+  , selectWith+  , selectWith'+  )+import NanoUI.Widgets.Slider (slider, slider', sliderWith, sliderWith')+import NanoUI.Widgets.Table+  ( ColSize (..)+  , Colonnade+  , Headed (..)+  , SortCol (..)+  , SortDir (..)+  , TableConfig (..)+  , TableResponse (..)+  , defaultTableConfig+  , headed+  , headless+  , simpleTable+  , sortRows+  , table+  , tableConfigured+  , tableHiddenIndices+  , tableWith+  , useTableSort+  )+import NanoUI.Widgets.Tabs+  ( Tab (..)+  , TabOrientation (..)+  , TabResponse (..)+  , TabStyle (..)+  , TabsConfig (..)+  , closableTab+  , defaultTabsConfig+  , tab+  , tabBar+  , tabBar'+  , tabBarConfigured+  , tabBarConfigured'+  , tabs+  , tabs'+  , tabsConfigured+  , tabsConfigured'+  )+import NanoUI.Widgets.TextArea (textArea, textArea', textAreaWith, textAreaWith')+import NanoUI.Widgets.TextBuffer (Cursor (..))+import NanoUI.Widgets.TextCommand (TextCommand (..), TextMotion (..))+import NanoUI.Widgets.TextField (runTextCommand, textCanRedo, textCanUndo)+import NanoUI.Widgets.TextInput+  ( SearchFieldConfig (..)+  , TextInputConfig (..)+  , defaultSearchFieldConfig+  , defaultTextInputConfig+  , searchField+  , searchField'+  , searchFieldConfigured+  , searchFieldConfigured'+  , selectableText+  , selectableText'+  , selectableTextWith+  , selectableTextWith'+  , textInput+  , textInput'+  , textInputConfigured+  , textInputConfigured'+  )+import NanoUI.Widgets.Tree (TreeItem (..), tree, tree')
+ lib/NanoUI/Animatable.hs view
@@ -0,0 +1,41 @@+module NanoUI.Animatable+  ( Animatable (..)+  ) where++import Data.Word (Word8)+import NanoUI.Types (Color, V2 (..), clamp01, colorA, colorB, colorG, colorR, colorRGBA)++-- Float components for multi-component tweens. Extra components are dropped.+-- Short Color lists pad RGB with 0 and alpha with 1. Other types pad with 0.+class Animatable a where+  toComponents :: a -> [Float]+  fromComponents :: [Float] -> a++instance Animatable Float where+  toComponents v = [v]+  fromComponents (v : _) = v+  fromComponents [] = 0++instance Animatable Double where+  toComponents v = [realToFrac v]+  fromComponents (v : _) = realToFrac v+  fromComponents [] = 0++instance Animatable V2 where+  toComponents (V2 x y) = [x, y]+  fromComponents (x : y : _) = V2 x y+  fromComponents [x] = V2 x 0+  fromComponents [] = V2 0 0++instance Animatable Color where+  toComponents c =+    [chan (colorR c), chan (colorG c), chan (colorB c), chan (colorA c)]+  fromComponents (r : g : b : a : _) =+    colorRGBA (byte r) (byte g) (byte b) (byte a)+  fromComponents xs = fromComponents (take 3 (xs ++ repeat 0) ++ [1])++chan :: Word8 -> Float+chan w = fromIntegral w / 255++byte :: Float -> Word8+byte x = fromIntegral (round (clamp01 x * 255) :: Int)
+ lib/NanoUI/Animation.hs view
@@ -0,0 +1,236 @@+module NanoUI.Animation+  ( Ease (..)+  , Animation (..)+  , SpringParams (..)+  , presetBouncy+  , presetSmooth+  , presetStiff+  , springEps+  , applyEase+  , approxEq+  , animInProgress+  , animationValue+  , easeSameSpec+  , stepAnim+  , writeRest+  ) where++import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IM+import NanoUI.Types (clamp01)++-- Cubic Bezier easing. X control points are clamped to [0, 1] (CSS-style).+-- t=0 and t=1 return the endpoints so Newton cannot pop the first/last frame.+evaluateBezier :: Float -> Float -> Float -> Float -> Float -> Float+evaluateBezier x1 y1 x2 y2 t0+  | t0 <= 0 = 0+  | t0 >= 1 = 1+  | otherwise =+      let p1 = clamp01 x1+          p2 = clamp01 x2+          tau = solveBezierX p1 p2 t0 0.5 0+       in sampleBezier y1 y2 tau++sampleBezier :: Float -> Float -> Float -> Float+sampleBezier p1 p2 u =+  let one = 1 - u+   in 3 * one * one * u * p1 + 3 * one * u * u * p2 + u * u * u++bezierDeriv :: Float -> Float -> Float -> Float+bezierDeriv p1 p2 u =+  let one = 1 - u+   in 3 * one * one * p1 + 6 * one * u * (p2 - p1) + 3 * u * u * (1 - p2)++solveBezierX :: Float -> Float -> Float -> Float -> Int -> Float+solveBezierX p1 p2 targetT estimate iter+  | iter >= 8 = estimate+  | otherwise =+      let currentX = sampleBezier p1 p2 estimate+          errorVal = currentX - targetT+       in if abs errorVal < 1e-4+            then estimate+            else+              let deriv = bezierDeriv p1 p2 estimate+                  safeDeriv =+                    if abs deriv < 1e-6+                      then if deriv >= 0 then 1e-6 else -1e-6+                      else deriv+                  nextEst = clamp01 (estimate - errorVal / safeDeriv)+               in solveBezierX p1 p2 targetT nextEst (iter + 1)++data SpringParams = SpringParams+  { springStiffness :: {-# UNPACK #-} !Float+  , springDamping :: {-# UNPACK #-} !Float+  , springMass :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++presetBouncy :: SpringParams+presetBouncy = SpringParams {springStiffness = 180, springDamping = 12, springMass = 1}++presetSmooth :: SpringParams+presetSmooth = SpringParams {springStiffness = 120, springDamping = 20, springMass = 1}++presetStiff :: SpringParams+presetStiff = SpringParams {springStiffness = 300, springDamping = 30, springMass = 1}++springEps :: Float+springEps = 1e-3++maxSubstep :: Float+maxSubstep = 1 / 30++maxSubsteps :: Int+maxSubsteps = 32++stepSpring :: SpringParams -> Float -> Float -> Float -> Float -> (Float, Float)+stepSpring params x v target dt+  | dt <= 0 = (x, v)+  | otherwise = go x v dt 0+  where+    go !pos !vel remain n+      | remain <= 1e-8 || n >= maxSubsteps = (pos, vel)+      | otherwise =+          let h = min maxSubstep remain+              (pos', vel') = rk4 params pos vel target h+           in go pos' vel' (remain - h) (n + 1)++rk4 :: SpringParams -> Float -> Float -> Float -> Float -> (Float, Float)+rk4 params x v xTarget dt =+  let k1v = accel x v+      k1x = v+      k2v = accel (x + 0.5 * dt * k1x) (v + 0.5 * dt * k1v)+      k2x = v + 0.5 * dt * k1v+      k3v = accel (x + 0.5 * dt * k2x) (v + 0.5 * dt * k2v)+      k3x = v + 0.5 * dt * k2v+      k4v = accel (x + dt * k3x) (v + dt * k3v)+      k4x = v + dt * k3v+      xNext = x + (dt / 6) * (k1x + 2 * k2x + 2 * k3x + k4x)+      vNext = v + (dt / 6) * (k1v + 2 * k2v + 2 * k3v + k4v)+   in (xNext, vNext)+  where+    k = max 0 (springStiffness params)+    c = max 0 (springDamping params)+    m = max 1e-6 (springMass params)+    accel pos vel = (-k * (pos - xTarget) - c * vel) / m++data Ease+  = EaseLinear+  | EaseInQuad+  | EaseOutQuad+  | EaseInOutQuad+  | EaseInCubic+  | EaseOutCubic+  | EaseInOutCubic+  | EaseOutBack+  | EaseCubicBezier+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+  deriving (Eq, Show)++-- EaseAnim start end duration elapsed ease delay delayReq+-- SpringAnim pos vel target params+data Animation+  = EaseAnim+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Ease+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+  | SpringAnim+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !SpringParams+  deriving (Eq, Show)++-- True when this ease slot matches the call-site spec and target.+easeSameSpec :: Animation -> Ease -> Float -> Float -> Float -> Bool+easeSameSpec (EaseAnim _ end dur _ ease _ delayReq) wantEase wantDur delay target =+  ease == wantEase+    && approxEq dur wantDur+    && approxEq delay delayReq+    && approxEq end target+easeSameSpec _ _ _ _ _ = False++-- Map unit progress through an easing curve. Input is clamped to [0, 1].+-- EaseOutBack may return a value outside that range (overshoot).+applyEase :: Ease -> Float -> Float+applyEase ease t0 =+  let t = clamp01 t0+   in case ease of+        EaseLinear -> t+        EaseInQuad -> t * t+        EaseOutQuad -> t * (2 - t)+        EaseInOutQuad+          | t < 0.5 -> 2 * t * t+          | otherwise -> -1 + (4 - 2 * t) * t+        EaseInCubic -> t * t * t+        EaseOutCubic ->+          let u = 1 - t+           in 1 - u * u * u+        EaseInOutCubic+          | t < 0.5 -> 4 * t * t * t+          | otherwise ->+              let u = -2 * t + 2+               in 1 - (u * u * u) / 2+        EaseOutBack ->+          let c1 = 1.70158+              c3 = c1 + 1+              u = t - 1+           in 1 + c3 * u * u * u + c1 * u * u+        EaseCubicBezier x1 y1 x2 y2 -> evaluateBezier x1 y1 x2 y2 t++approxEq :: Float -> Float -> Bool+approxEq a b = abs (a - b) <= 1e-4++{-# INLINE animInProgress #-}+animInProgress :: Animation -> Bool+animInProgress (EaseAnim start end dur elapsed _ delay _) =+  not (approxEq start end)+    && dur > 0+    && (delay > 0 || elapsed < dur)+animInProgress (SpringAnim pos vel target _) =+  abs (pos - target) > springEps || abs vel > springEps++{-# INLINE animationValue #-}+animationValue :: Animation -> Float+animationValue a@(EaseAnim start end dur elapsed ease delay _)+  | not (animInProgress a) = end+  | delay > 0 = start+  | otherwise =+      let t = min 1 (elapsed / max 0.001 dur)+       in start + (end - start) * applyEase ease t+animationValue (SpringAnim pos _ _ _) = pos++stepAnim :: Float -> Animation -> Animation+stepAnim dt a@(EaseAnim start end dur elapsed ease delay delayReq)+  | not (animInProgress a) = a+  | delay > 0 =+      let remain = delay - dt+       in if remain > 0+            then EaseAnim start end dur elapsed ease remain delayReq+            else stepAnim (negate remain) (EaseAnim start end dur elapsed ease 0 delayReq)+  | otherwise =+      let next = elapsed + dt+       in if next >= dur+            then EaseAnim end end 0 0 ease 0 0+            else EaseAnim start end dur next ease 0 delayReq+stepAnim dt (SpringAnim pos vel target params) =+  let (pos', vel') = stepSpring params pos vel target dt+   in if abs (pos' - target) <= springEps && abs vel' <= springEps+        then SpringAnim target 0 target params+        else SpringAnim pos' vel' target params++writeRest :: IntMap Float -> Int -> Animation -> IntMap Float+writeRest rest key a =+  let end = case a of+        EaseAnim _ e _ _ _ _ _ -> e+        SpringAnim _ _ t _ -> t+   in if approxEq end 0+        then IM.delete key rest+        else IM.insert key end rest
+ lib/NanoUI/Atlas.hs view
@@ -0,0 +1,216 @@+module NanoUI.Atlas+  ( ImageAtlas+  , newImageAtlas+  , atlasTextureId+  , registerImage+  , freshImageId+  , lookupImageUv+  , atlasSnapshot+  )+where++import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)+import Foreign.Marshal.Utils (copyBytes, fillBytes)+import Foreign.Ptr (plusPtr)+import NanoUI.Types (ImageId (..))++-- | GPU texture id shared by every packed image so draw cmds batch.+atlasTextureId :: Int+atlasTextureId = 1++atlasPad :: Int+atlasPad = 1++atlasStart :: Int+atlasStart = 256++atlasMax :: Int+atlasMax = 4096++data AtlasSlot = AtlasSlot+  { slotX :: {-# UNPACK #-} !Int+  , slotY :: {-# UNPACK #-} !Int+  , slotW :: {-# UNPACK #-} !Int+  , slotH :: {-# UNPACK #-} !Int+  }++data AtlasState = AtlasState+  { asW :: {-# UNPACK #-} !Int+  , asH :: {-# UNPACK #-} !Int+  , asPtr :: ForeignPtr Word8+  , asSlots :: IM.IntMap AtlasSlot+  , asX :: {-# UNPACK #-} !Int+  , asY :: {-# UNPACK #-} !Int+  , asRowH :: {-# UNPACK #-} !Int+  , asGen :: {-# UNPACK #-} !Int+  , asLastFresh :: {-# UNPACK #-} !Int+  -- ^ The last id 'freshImageId' returned.+  }++newtype ImageAtlas = ImageAtlas (IORef AtlasState)++newImageAtlas :: IO ImageAtlas+newImageAtlas = do+  fp <- allocPixels atlasStart atlasStart+  ImageAtlas+    <$> newIORef+      AtlasState+        { asW = atlasStart+        , asH = atlasStart+        , asPtr = fp+        , asSlots = IM.empty+        , asX = atlasPad+        , asY = atlasPad+        , asRowH = 0+        , asGen = 0+        , asLastFresh = 0+        }++registerImage :: ImageAtlas -> ImageId -> Int -> Int -> ByteString -> IO Bool+registerImage (ImageAtlas ref) (ImageId tid) w h pixels+  | tid <= 0 || w <= 0 || h <= 0 = pure False+  | w > atlasMax - 2 * atlasPad || h > atlasMax - 2 * atlasPad = pure False+  | BS.length pixels < w * h * 4 = pure False+  | otherwise = do+      st0 <- readIORef ref+      case IM.lookup tid (asSlots st0) of+        Just slot+          | slotW slot == w && slotH slot == h -> do+              blitPixels (asPtr st0) (asW st0) (slotX slot) (slotY slot) w h pixels+              writeIORef ref st0 {asGen = asGen st0 + 1}+              pure True+          | otherwise -> pure False+        Nothing -> do+          mSt <- fitImage st0 tid w h pixels+          case mSt of+            Nothing -> pure False+            Just st1 -> do+              writeIORef ref st1+              pure True++-- | An id above every registered image's and every id this returned before.+-- An id the app picks itself can still collide with one returned and not yet+-- registered, so register those first.+freshImageId :: ImageAtlas -> IO ImageId+freshImageId (ImageAtlas ref) = do+  st <- readIORef ref+  let tid = 1 + maybe (asLastFresh st) (max (asLastFresh st) . fst) (IM.lookupMax (asSlots st))+  writeIORef ref st {asLastFresh = tid}+  pure (ImageId tid)++lookupImageUv ::+  ImageAtlas -> ImageId -> IO (Maybe (Float, Float, Float, Float))+lookupImageUv (ImageAtlas ref) (ImageId tid) = do+  st <- readIORef ref+  pure $+    case IM.lookup tid (asSlots st) of+      Nothing -> Nothing+      Just (AtlasSlot x y w h) ->+        let+          fw = fromIntegral (asW st)+          fh = fromIntegral (asH st)+         in+          Just+            ( fromIntegral x / fw+            , fromIntegral y / fh+            , fromIntegral (x + w) / fw+            , fromIntegral (y + h) / fh+            )++-- Pinned pixel buffer. SDL uploads this pointer; do not copy to ByteString first.+atlasSnapshot :: ImageAtlas -> IO (Maybe (Int, Int, ForeignPtr Word8, Int))+atlasSnapshot (ImageAtlas ref) = do+  st <- readIORef ref+  if asGen st == 0+    then pure Nothing+    else pure (Just (asW st, asH st, asPtr st, asGen st))++fitImage ::+  AtlasState -> Int -> Int -> Int -> ByteString -> IO (Maybe AtlasState)+fitImage st0 tid w h pixels =+  -- Plan the shelf position before allocating or copying the atlas. A full+  -- atlas must reject an image without repeatedly allocating doomed growth.+  case cursorFor st0 w h <|> cursorFor grown w h of+    Nothing -> pure Nothing+    Just (x, y, placed) -> do+      fp <-+        if asW placed == asW st0 && asH placed == asH st0+          then pure (asPtr st0)+          else do+            resized <- allocPixels (asW placed) (asH placed)+            copyAtlas (asPtr st0) (asW st0) (asH st0) resized (asW placed)+            pure resized+      blitPixels fp (asW placed) x y w h pixels+      pure $+        Just+          placed+            { asPtr = fp+            , asSlots = IM.insert tid (AtlasSlot x y w h) (asSlots placed)+            , asX = x + w + atlasPad+            , asY = y+            , asRowH = max (asRowH placed) h+            , asGen = asGen placed + 1+            }+ where+  grown =+    st0+      { asW = growDim (asW st0) (w + 2 * atlasPad)+      , asH = growDim (asH st0) (asY st0 + asRowH st0 + h + 2 * atlasPad)+      }++cursorFor :: AtlasState -> Int -> Int -> Maybe (Int, Int, AtlasState)+cursorFor st w h+  | asX st + w + atlasPad <= asW st && asY st + h + atlasPad <= asH st =+      Just (asX st, asY st, st)+  | asY st + asRowH st + atlasPad + h + atlasPad <= asH st+      && w + 2 * atlasPad <= asW st =+      let+        y = asY st + asRowH st + atlasPad+       in+        Just (atlasPad, y, st {asX = atlasPad, asY = y, asRowH = 0})+  | otherwise = Nothing++growDim :: Int -> Int -> Int+growDim cur need+  | need <= cur = cur+  | otherwise = min atlasMax (max need (cur * 2))++allocPixels :: Int -> Int -> IO (ForeignPtr Word8)+allocPixels w h = do+  let+    n = w * h * 4+  fp <- mallocForeignPtrBytes n+  withForeignPtr fp $ \p -> fillBytes p 0 n+  pure fp++copyAtlas :: ForeignPtr Word8 -> Int -> Int -> ForeignPtr Word8 -> Int -> IO ()+copyAtlas src oldW oldH dst newW =+  withForeignPtr src $ \sp ->+    withForeignPtr dst $ \dp ->+      mapM_ (copyRow sp dp) [0 .. oldH - 1]+ where+  rowBytes = oldW * 4+  copyRow sp dp row =+    copyBytes+      (dp `plusPtr` (row * newW * 4))+      (sp `plusPtr` (row * oldW * 4))+      rowBytes++blitPixels ::+  ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> ByteString -> IO ()+blitPixels dest destW destX destY w h pixels =+  withForeignPtr dest $ \dp ->+    BS.useAsCStringLen pixels $ \(sp, _) ->+      mapM_ (copyRow dp sp) [0 .. h - 1]+ where+  copyRow dp sp row =+    copyBytes+      (dp `plusPtr` (((destY + row) * destW + destX) * 4))+      (sp `plusPtr` (row * w * 4))+      (w * 4)
+ lib/NanoUI/Bidi.hs view
@@ -0,0 +1,153 @@+-- | Direction runs of a line of mixed left-to-right and right-to-left text,+-- for hosts that shape one direction at a time.+--+-- This is the implicit part of the Unicode bidirectional algorithm (UAX #9)+-- for a single line: the paragraph direction from the first strong+-- character, European and Arabic numbers, neutrals between runs, and+-- reordering by level. Explicit embeddings, overrides, isolates and bracket+-- pairs are not handled; text using them lays out as if they were absent.+module NanoUI.Bidi+  ( BidiRun (..)+  , bidiRuns+  , needsBidi+  ) where++import Control.Applicative ((<|>))+import Data.Char (ord)+import Data.List.NonEmpty qualified as NE+import Data.Text (Text)+import Data.Text qualified as T++-- | Characters @runStart@ up to @runEnd@ (exclusive) shaped in one direction.+data BidiRun = BidiRun+  { runStart :: !Int+  , runEnd :: !Int+  , runRightToLeft :: !Bool+  }+  deriving (Eq, Show)++data Class = L | R | AL | EN | AN | NSM | WS | ON+  deriving (Eq, Show)++-- | Whether a line has characters that can flow right to left. A line+-- without them is one left-to-right run.+needsBidi :: Text -> Bool+needsBidi = T.any (\c -> ord c >= 0x0590 && rtlOrArabic (classify c))+  where+    rtlOrArabic k = k == R || k == AL || k == AN++-- | The runs of a line in visual order, left to right.+bidiRuns :: Text -> [BidiRun]+bidiRuns txt+  | T.null txt = []+  | not (needsBidi txt) = [BidiRun 0 (T.length txt) False]+  | otherwise =+      let classes0 = map classify (T.unpack txt)+          paragraphRtl = case [k | k <- classes0, k == L || k == R || k == AL] of+            k : _ -> k /= L+            [] -> False+          base = if paragraphRtl then 1 else 0 :: Int+          classes = resolveNeutrals paragraphRtl (resolveWeak paragraphRtl classes0)+          levels = map (implicitLevel base) classes+          indexed = zip [0 :: Int ..] levels+          runs =+            [ (start, fst (NE.last grp) + 1, lvl)+            | grp <- NE.groupBy (\a b -> snd a == snd b) indexed+            , let (start, lvl) = NE.head grp+            ]+       in [BidiRun s e (odd lvl) | (s, e, lvl) <- reorder runs]++classify :: Char -> Class+classify c+  | n < 0x0590 = latin+  | n <= 0x05FF = if n >= 0x0591 && n <= 0x05C7 && n /= 0x05BE && n /= 0x05C0 && n /= 0x05C3 && n /= 0x05C6 then NSM else R+  | n >= 0x0660 && n <= 0x0669 = AN+  | n >= 0x06F0 && n <= 0x06F9 = EN+  | n >= 0x064B && n <= 0x065F || n == 0x0670 || n >= 0x06D6 && n <= 0x06ED = NSM+  | n <= 0x06FF = AL+  | n <= 0x07BF = if n >= 0x0730 && n <= 0x074A || n >= 0x07A6 && n <= 0x07B0 then NSM else AL+  | n <= 0x085F = R+  | n <= 0x08FF = if n >= 0x08D3 then NSM else AL+  | n >= 0x200E && n <= 0x200F = if n == 0x200E then L else R+  | n >= 0xFB1D && n <= 0xFB4F = R+  | n >= 0xFB50 && n <= 0xFDFF = AL+  | n >= 0xFE70 && n <= 0xFEFF = AL+  | n >= 0x2000 && n <= 0x206F = if n <= 0x200A || n == 0x2028 || n == 0x2029 then WS else ON+  | n >= 0x10800 && n <= 0x10FFF = R+  | n >= 0x1E800 && n <= 0x1EFFF = AL+  | otherwise = L+  where+    n = ord c+    latin+      | c >= '0' && c <= '9' = EN+      | c == ' ' || c == '\t' = WS+      | n < 0x80 && not (isAsciiLetter c) = ON+      | n >= 0x80 && n <= 0xBF = ON+      | n == 0xD7 || n == 0xF7 = ON+      | n >= 0x0300 && n <= 0x036F = NSM+      | otherwise = L+    isAsciiLetter ch = (ch >= 'a' && ch <= 'z') || (ch >= 'A' && ch <= 'Z')++-- | Weak types: a mark takes the class before it, a European number after+-- Arabic letters reads as an Arabic number and one after Latin letters (or+-- at the start of a left-to-right line) as Latin.+resolveWeak :: Bool -> [Class] -> [Class]+resolveWeak paragraphRtl = go ON (if paragraphRtl then R else L)+  where+    go _ _ [] = []+    go prev lastStrong (k : ks) =+      let k1 = if k == NSM then prev else k+          k2+            | k1 == EN && lastStrong == AL = AN+            | k1 == EN && lastStrong == L = L+            | otherwise = k1+          k3 = if k2 == AL then R else k2+          lastStrong' = if k1 == L || k1 == R || k1 == AL then k1 else lastStrong+       in k3 : go k1 lastStrong' ks++-- | Neutrals between two characters of the same direction take it (numbers+-- count as right to left here); other neutrals take the paragraph's.+resolveNeutrals :: Bool -> [Class] -> [Class]+resolveNeutrals paragraphRtl classes =+  let direction k+        | k == L = Just False+        | k == R || k == AN || k == EN = Just True+        | otherwise = Nothing+      directions = map direction classes+      before = scanl (\acc d -> d <|> acc) Nothing directions+      after = drop 1 (scanr (<|>) Nothing directions)+      resolve k b a+        | k == WS || k == ON = case (b, a) of+            (Just x, Just y) | x == y -> if x then R else L+            _ -> if paragraphRtl then R else L+        | otherwise = k+   in zipWith3 resolve classes before after++-- | The embedding level of a resolved class at paragraph level @base@.+implicitLevel :: Int -> Class -> Int+implicitLevel base k+  | even base = case k of+      R -> base + 1+      AL -> base + 1+      AN -> base + 2+      EN -> base + 2+      _ -> base+  | otherwise = case k of+      L -> base + 1+      EN -> base + 1+      AN -> base + 1+      _ -> base++-- | Reverse every maximal sequence of runs at or above each odd level, from+-- the highest level down.+reorder :: [(Int, Int, Int)] -> [(Int, Int, Int)]+reorder runs =+  let maxLevel = maximum (0 : [l | (_, _, l) <- runs])+      lowestOdd = minimum (maxLevel + 1 : [l | (_, _, l) <- runs, odd l])+      pass lvl rs =+        concatMap+          (\grp -> if atLeast (NE.head grp) then reverse (NE.toList grp) else NE.toList grp)+          (NE.groupBy (\a b -> atLeast a == atLeast b) rs)+        where+          atLeast (_, _, l) = l >= lvl+   in foldl (flip pass) runs [maxLevel, maxLevel - 1 .. lowestOdd]
+ lib/NanoUI/Compact.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeApplications #-}++module NanoUI.Compact+  ( Compact+  , compactHost+  , askCompact+  ) where++import Data.Typeable (Typeable)+import Effectful (Eff, type (:>))+import GHC.Compact (Compact, compact, getCompact)+import NanoUI.Context (Context, setHost)+import NanoUI.Monad (Ui, askHost)++-- Pin read-heavy app state so GC treats it as one block.+compactHost :: Typeable a => Context -> a -> IO (Compact a)+compactHost ctx a = do+  region <- compact a+  setHost ctx region+  pure region++askCompact :: forall a es. (Typeable a, Ui :> es) => Eff es (Maybe a)+askCompact = do+  region <- askHost @(Compact a)+  pure (fmap getCompact region)
+ lib/NanoUI/Context.hs view
@@ -0,0 +1,700 @@+-- | The 'Context' a view runs against, and the operations on its state:+-- focus, dirty flags and damage, the widget store, drawing and measure+-- caches, overlays, and host hooks. Backends and advanced widgets use this+-- module; views normally only need "NanoUI".+module NanoUI.Context+  ( Context (..)+  , MeasureCacheKey+  , TextInputMenu (..)+  , TextInputDrag (..)+  , TextFieldClickCell (..)+  , WindowResizeEdge (..)+  , WindowResizeDrag (..)+  , DamageState (..)+  , OverlayState (..)+  , AnimationState (..)+  , DrawingCacheState (..)+  , DrawingEntry (..)+  , DrawFitCache (..)+  , SpanCacheEntry (..)+  , WidgetTextCacheEntry (..)+  , WidgetTextPlacement (..)+  , InteractionState (..)+  , initialInteractionState+  , initialDamageState+  , initialOverlayState+  , initialAnimationState+  , initialScrollState+  , initialDrawingCacheState+  , getsInteraction+  , modifyInteraction+  , getsOverlay+  , modifyOverlay+  , getsDamage+  , modifyDamage+  , getScrollDrag+  , setTextInputDrag+  , getTextInputMenu+  , setTextInputMenu+  , takeTextEditLastAction+  , getMenuPointerGesture+  , setMenuPointerGesture+  , getWindowDrag+  , getWindowResize+  , intKey+  , markDirty+  , clearDirty+  , isDirty+  , setWakeLoop+  , takeDamage+  , DamageRequest (..)+  , requestDamage+  , damageWidget+  , damageKey+  , damageRect+  , damagePeers+  , damageFull+  , registerPopupConfig+  , lookupPopupConfig+  , registerDrawing+  , lookupDrawing+  , cachedDrawingOps+  , cachedWidgetLayout+  , lookupDrawFitEnvelope+  , pruneDrawOpCache+  , CustomMeasureFn+  , CustomDrawContext (..)+  , CustomDrawBuild+  , registerCustomDrawing+  , lookupCustomDrawing+  , cachedCustomDrawingOps+  , refreshCustomDrawingOps+  , drawingOpsStale+  , CustomDrawingEntry (..)+  , registerCustomMeasure+  , lookupCustomMeasure+  , registerCustomCursor+  , lookupCustomCursor+  , registerCustomDamageSlop+  , lookupCustomDamageSlop+  , resetDrawingScopeCache+  , getStore+  , setStore+  , modifyStore+  , getStoreBool+  , writeStoreInt+  , writeStoreFloat+  , writeStoreBool+  , adoptStoreInt+  , adoptStoreFloat+  , adoptStoreText+  , recordStoreInt+  , recordStoreFloat+  , recordStoreText+  , isDisabled+  , newThemeScopes+  , beginThemeScopes+  , pushThemeScope+  , themeScopesChanged+  , scopeTheme+  , scopeRawTheme+  , currentTheme+  , nodeTheme+  , widgetTheme+  , getScrollOffset+  , setScrollOffset+  , getScrollOffset2D+  , setScrollOffset2D+  , setScrollConfig+  , defaultScrollConfig+  , linkScrollAxes+  , ScrollTuning (..)+  , defaultScrollTuning+  , getScrollTuning+  , setScrollTuning+  , getScrollStep+  , setScrollStep+  , resolveScrollStep+  , ScrollAxes (..)+  , ScrollMetrics (..)+  , getScrollMetrics+  , cacheScrollMetrics+  , beginScrollMetrics+  , getScrollOffsetIn+  , setScrollOffsetIn+  , ScrollBehavior (..)+  , ScrollAlign (..)+  , scrollTo+  , scrollBy+  , scrollPages+  , scrollToStart+  , scrollToEnd+  , scrollIntoView+  , scrollRectIntoView+  , applyScrollTarget+  , scrollTargetOffset+  , scrollGliding+  , clampScrollOffset+  , cancelScrollGlide+  , stepScrollGlides+  , getPrevRect+  , getPrevClipRect+  , atlasTextureId+  , registerImage+  , registerImages+  , lookupImageUv+  , atlasSnapshot+  , withFontMetrics+  , withMonoFontMetrics+  , withMeasureText+  , withFontResolver+  , wrapMeasureCache+  , clearMeasureCache+  , ensureMetricCaches+  , hasCustomLayoutInputs+  , withExternalText+  , withTheme+  , setTheme+  , getTheme+  , withClipboard+  , enableMeasureCache+  , setHost+  , setDrawSnapScale+  , setDrawSquareGeometry+  , setDrawExternalText+  , askHostIO+  , pushMessage+  , drainMessages+  -- Constructors+  , newContext+  , newPixelHostContext+  -- Focus+  , getFocusId+  , getFocusVisible+  , getHotId+  , registerFocusable+  , getFocusables+  -- Modal & Overlay+  , textInputEditActive+  , modalActive+  , overlayConsumesQuit+  , markEscapeConsumed+  , pointerBlockedByModal+  , pointerBlockedByOverlay+  , armMenuPointerCapture+  , seedFloatingPanel+  , beginModal+  , endModal+  , beginFrameModal+  , modalDamageFlip+  -- Animation+  , anyAnimating+  , getLiveAnimations+  , takeAnimSettled+  , lookupAnimation+  , getAnimRectless+  , setAnimRectless+  , startAnimation+  , startAnimationEase+  , startAnimationEaseDelay+  , startSpring+  , setAnimationValue+  , tickAnimations+  , getAnimationValue+  , getAnimRest+  , pruneAnimRest+  , FrameMsg (..)+  , decodeMessages+  , reduceMessages+  , reduceUpdates+  , WidgetStore (..)+  , bumpMirror+  , slotKey+  , Slot (..)+  , boolInt+  , intBool+  , anySelectOpen+  , isSelectOpen+  , setSelectOpen+  , closeSelects+  , Ease (..)+  , Animation (..)+  , SpringParams (..)+  , presetBouncy+  , presetSmooth+  , presetStiff+  , applyEase+  , easeSameSpec+  , approxEq+  , animInProgress+  ) where++import Control.Monad (foldM, forM, when)+import Data.Bits ((.&.))+import Data.ByteString (ByteString)+import Data.Dynamic (fromDynamic, toDyn)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Map.Strict qualified as Map+import Data.Primitive.PrimArray+  ( newPrimArray+  , readPrimArray+  , writePrimArray+  , getSizeofMutablePrimArray+  , resizeMutablePrimArray+  )+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Typeable (Typeable, typeOf, typeRep)+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr)++import NanoUI.Animation+  ( Animation (..)+  , Ease (..)+  , SpringParams (..)+  , animInProgress+  , applyEase+  , approxEq+  , easeSameSpec+  , presetBouncy+  , presetSmooth+  , presetStiff+  )+import NanoUI.Atlas (atlasTextureId)+import NanoUI.Atlas qualified as Atlas+import NanoUI.Context.Animation+import NanoUI.Context.Core+import NanoUI.Context.Drawing+import NanoUI.Context.Overlay+import NanoUI.Context.Scroll+import NanoUI.Context.Types+  ( AnimationState (..)+  , Context (..)+  , CustomDrawBuild+  , CustomDrawContext (..)+  , CustomDrawingEntry (..)+  , CustomMeasureFn+  , DamageRequest (..)+  , DamageState (..)+  , DrawFitCache (..)+  , DrawingCacheState (..)+  , DrawingEntry (..)+  , FrameMsg (..)+  , InteractionState (..)+  , MeasureCacheKey+  , MetricSource (..)+  , OverlayState (..)+  , SpanCacheEntry (..)+  , TextFieldClickCell (..)+  , TextInputDrag (..)+  , TextInputMenu (..)+  , WidgetTextCacheEntry (..)+  , WidgetTextPlacement (..)+  , WindowResizeDrag (..)+  , WindowResizeEdge (..)+  , decodeMessages+  , initialAnimationState+  , initialScrollState+  , initialDamageState+  , initialDrawingCacheState+  , initialInteractionState+  , initialOverlayState+  , intKey+  , reduceMessages+  , reduceUpdates+  )+import NanoUI.Draw (newDrawArena)+import NanoUI.Draw qualified as Draw+import NanoUI.Font (FontMetrics, fmLineHeight, measureTextIO, monospaceMetrics, scaleFontMetrics)+import NanoUI.Frame.SpanArena (newSpanArena)+import NanoUI.Frame.Scroll.Geometry (defaultScrollConfig)+import NanoUI.Id (WidgetId (..), initialIdContext)+import NanoUI.Layout.Arena (getArenaScope, newNodeArena)+import NanoUI.Store+  ( WidgetStore (..)+  , anySelectOpen+  , boolInt+  , bumpMirror+  , closeSelects+  , emptyWidgetStore+  , intBool+  , isSelectOpen+  , ptrEq+  , setSelectOpen+  , Slot (..)+  , slotKey+  )+import NanoUI.Style (FontStyle, FontVariant (..), FontWeight, Theme, defaultLayout, defaultTheme)+import NanoUI.Types (ImageId)++{-# INLINE registerImage #-}+registerImage :: Context -> ImageId -> Int -> Int -> ByteString -> IO Bool+registerImage ctx iid w h px = do+  ok <- Atlas.registerImage (ctxImageAtlas ctx) iid w h px+  when ok (markDirty ctx)+  pure ok++registerImages :: Foldable f => Context -> f (ImageId, Int, Int, ByteString) -> IO Bool+registerImages ctx = foldM register True+  where+    register ok (iid, w, h, px) = do+      result <- registerImage ctx iid w h px+      pure (ok && result)++{-# INLINE lookupImageUv #-}+lookupImageUv :: Context -> ImageId -> IO (Maybe (Float, Float, Float, Float))+lookupImageUv ctx = Atlas.lookupImageUv (ctxImageAtlas ctx)++{-# INLINE atlasSnapshot #-}+atlasSnapshot :: Context -> IO (Maybe (Int, Int, ForeignPtr Word8, Int))+atlasSnapshot ctx = Atlas.atlasSnapshot (ctxImageAtlas ctx)++-- | Metrics for a font variant scaled to line height @sz@, and the scale+-- factor applied (1 when @sz@ or the base line height is not positive).+{-# INLINE resolveScale #-}+resolveScale :: Context -> Float -> FontVariant -> (FontMetrics, Float)+resolveScale ctx sz var =+  let baseFm = if var == FontMono then ctxMonoFontMetrics ctx else ctxFontMetrics ctx+      scale =+        if sz > 0 && fmLineHeight baseFm > 0+          then sz / fmLineHeight baseFm+          else 1.0+   in (if scale /= 1.0 then scaleFontMetrics scale baseFm else baseFm, scale)++defaultResolveFont :: Context -> Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool)+defaultResolveFont ctx sz _w _st var = pure (fst (resolveScale ctx sz var), False)++defaultResolveMeasure :: Context -> Float -> FontWeight -> FontStyle -> FontVariant -> Text -> IO (Float, Float)+defaultResolveMeasure ctx sz _w _st var txt+  | var == FontMono = measureTextIO textFm txt+  | scale /= 1.0 = (\(w, h) -> (w * scale, h * scale)) <$> ctxMeasureText ctx txt+  | otherwise = ctxMeasureText ctx txt+  where+    (textFm, scale) = resolveScale ctx sz var++{-# INLINE withFontResolver #-}+withFontResolver ::+  Context ->+  (Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool)) ->+  (Float -> FontWeight -> FontStyle -> FontVariant -> Text -> IO (Float, Float)) ->+  Context+withFontResolver ctx rf rm = trackMetricSource ctx {ctxResolveFont = rf, ctxResolveMeasure = rm}++withFontMetrics :: Context -> FontMetrics -> Context+withFontMetrics ctx fm =+  let ctx' =+        ctx+          { ctxFontMetrics = fm+          , ctxMeasureText = measureTextIO fm+          }+   in trackMetricSource ctx'+        { ctxResolveFont = defaultResolveFont ctx'+        , ctxResolveMeasure = defaultResolveMeasure ctx'+        }++withMonoFontMetrics :: Context -> FontMetrics -> Context+withMonoFontMetrics ctx mono =+  let ctx' = ctx {ctxMonoFontMetrics = mono}+   in trackMetricSource ctx'+        { ctxResolveFont = defaultResolveFont ctx'+        , ctxResolveMeasure = defaultResolveMeasure ctx'+        }++withMeasureText :: Context -> (Text -> IO (Float, Float)) -> Context+withMeasureText ctx fn =+  let ctx' = ctx {ctxMeasureText = fn}+   in trackMetricSource ctx'+        { ctxResolveMeasure = defaultResolveMeasure ctx'+        }++-- Keep the identity boxed. No structural callback comparison or unsafe pure+-- mutation is needed, and repeated frames with the same Context do no work.+trackMetricSource :: Context -> Context+trackMetricSource ctx =+  ctx {ctxMetricSource = MetricSource+    (ctxFontMetrics ctx) (ctxMonoFontMetrics ctx) (ctxMeasureText ctx)+    (ctxResolveFont ctx) (ctxResolveMeasure ctx)}++-- | Called once before building a frame. Context configuration remains pure;+-- cache invalidation happens at the IO boundary, including when alternating+-- between differently configured Contexts that share their backing stores.+ensureMetricCaches :: Context -> IO ()+ensureMetricCaches ctx = do+  -- Compare evaluated identities: passed unevaluated, the selector application+  -- is a fresh thunk without optimisation, so the check would miss every+  -- frame and force full damage with cleared caches.+  let !current = ctxMetricSource ctx+  previous <- readIORef (ctxLastMetricSource ctx)+  case previous of+    Just source | ptrEq source current -> pure ()+    _ -> do+      clearMeasureCache ctx+      damageFull ctx+      markDirty ctx++cacheMeasureText ::+  IORef (HashMap MeasureCacheKey (Float, Float)) ->+  Float ->+  (Text -> IO (Float, Float)) ->+  Text ->+  IO (Float, Float)+cacheMeasureText ref scale base txt = do+  let key = (txt, scale)+  m <- readIORef ref+  case HashMap.lookup key m of+    Just sz -> pure sz+    Nothing -> do+      sz <- base txt+      modifyIORef' ref (HashMap.insert key sz)+      pure sz++wrapMeasureCache :: Float -> Context -> (Text -> IO (Float, Float)) -> Context+wrapMeasureCache scale ctx measure =+  case ctxMeasureCache ctx of+    Nothing -> trackMetricSource ctx {ctxMeasureText = measure}+    Just ref -> trackMetricSource ctx {ctxMeasureText = cacheMeasureText ref scale measure}++-- | Drop text span, widget text and whole-layout caches and bump the metric+-- generation, for changes that alter how text lays out.+invalidateTextCaches :: Context -> IO ()+invalidateTextCaches ctx = do+  writeIORef (ctxSpanCache ctx) IM.empty+  writeIORef (ctxWidgetTextCache ctx) IM.empty+  writeIORef (ctxLayoutCache ctx) Nothing+  modifyIORef' (ctxMetricGen ctx) (+ 1)++clearMeasureCache :: Context -> IO ()+clearMeasureCache ctx = do+  -- Store the evaluated source so 'ensureMetricCaches' can match its identity.+  let !source = ctxMetricSource ctx+  writeIORef (ctxLastMetricSource ctx) (Just source)+  invalidateTextCaches ctx+  case ctxMeasureCache ctx of+    Just ref -> writeIORef ref HashMap.empty+    Nothing -> pure ()++withExternalText :: Context -> Bool -> Context+withExternalText ctx ext = ctx {ctxExternalText = ext}++-- | Configure a context's theme. Goes through 'setTheme' so a theme swapped+-- between frames invalidates the caches keyed on it, drawing-op caches+-- included, instead of leaving widgets painting the previous theme.+withTheme :: Context -> Theme -> IO Context+withTheme ctx theme = do+  setTheme ctx theme+  pure ctx++setTheme :: Context -> Theme -> IO ()+setTheme ctx th = do+  cur <- readIORef (ctxTheme ctx)+  when (cur /= th) $ do+    writeIORef (ctxTheme ctx) th+    invalidateTextCaches ctx+    damageFull ctx+    markDirty ctx++getTheme :: Context -> IO Theme+getTheme ctx = readIORef (ctxTheme ctx)++withClipboard :: Context -> IO (Maybe Text) -> (Text -> IO Bool) -> Context+withClipboard ctx getter setter = ctx {ctxClipboardGet = getter, ctxClipboardSet = setter}++enableMeasureCache :: Context -> IO Context+enableMeasureCache ctx =+  case ctxMeasureCache ctx of+    Just _ -> pure ctx+    Nothing -> do+      ref <- newIORef HashMap.empty+      pure ctx {ctxMeasureCache = Just ref, ctxMeasureText = cacheMeasureText ref 0 (ctxMeasureText ctx)}++{-# INLINE setHost #-}+setHost :: forall a. (Typeable a) => Context -> a -> IO ()+setHost ctx val = do+  m <- readIORef (ctxHost ctx)+  let k = typeOf val+  writeIORef (ctxHost ctx) (Map.insert k (toDyn val) m)++-- | Set the device pixel scale used to snap geometry origins/endpoints to+-- whole pixels. The SDL backend calls this when the display scale is synced.+{-# INLINE setDrawSnapScale #-}+setDrawSnapScale :: Context -> Float -> IO ()+setDrawSnapScale ctx s = Draw.setDrawSnapScale (ctxDrawArena ctx) s++-- | Emit rounded shapes and AA strokes as flat, axis-aligned fills. Software+-- framebuffer hosts enable this so every primitive is a solid quad.+{-# INLINE setDrawSquareGeometry #-}+setDrawSquareGeometry :: Context -> Bool -> IO ()+setDrawSquareGeometry ctx = Draw.setDrawSquareGeometry (ctxDrawArena ctx)++-- | Skip text quads in the draw buffer. Hosts that rasterize text from the+-- collected text spans enable this.+{-# INLINE setDrawExternalText #-}+setDrawExternalText :: Context -> Bool -> IO ()+setDrawExternalText ctx = Draw.setDrawExternalText (ctxDrawArena ctx)++{-# INLINE askHostIO #-}+askHostIO :: forall a. (Typeable a) => Context -> IO (Maybe a)+askHostIO ctx = do+  m <- readIORef (ctxHost ctx)+  let k = typeRep (Proxy :: Proxy a)+  pure (Map.lookup k m >>= fromDynamic)++{-# INLINE pushMessage #-}+pushMessage :: Context -> FrameMsg -> IO ()+pushMessage ctx msg = modifyIORef' (ctxMessages ctx) (msg :)++{-# INLINE drainMessages #-}+drainMessages :: Context -> IO [FrameMsg]+drainMessages ctx = do+  msgs <- readIORef (ctxMessages ctx)+  writeIORef (ctxMessages ctx) []+  pure (reverse msgs)++-- =============================================================================+-- Constructors+-- =============================================================================++newContext :: IO Context+newContext = do+  nodeArena <- newNodeArena+  drawArena <- newDrawArena+  ctxHotId <- newIORef (WidgetId 0)+  ctxLastHotId <- newIORef (WidgetId 0)+  ctxActiveId <- newIORef (WidgetId 0)+  ctxClickedId <- newIORef (WidgetId 0)+  ctxReleaseClickedId <- newIORef (WidgetId 0)+  ctxPressPos <- newIORef Nothing+  ctxRightPressPos <- newIORef Nothing+  ctxFocusId <- newIORef (WidgetId 0)+  ctxFocusVisible <- newIORef False+  ctxStore <- newIORef emptyWidgetStore+  ctxDamageState <- newIORef initialDamageState+  ctxOverlayState <- newIORef initialOverlayState+  ctxAnimationState <- newIORef initialAnimationState+  ctxScrollState <- newIORef initialScrollState+  ctxDrawingCache <- newIORef initialDrawingCacheState+  ctxIdContext <- newIORef initialIdContext+  ctxContainerStack <- newIORef []+  ctxMessages <- newIORef []+  let initCap = 64+  ctxFocusables <- newIORef =<< newPrimArray initCap+  ctxFocusablesCount <- newIORef 0+  ctxSpanBase <- newSpanArena 64+  ctxSpanOverlay <- newSpanArena 64+  ctxInteractionState <- newIORef initialInteractionState+  ctxImageAtlas <- Atlas.newImageAtlas+  ctxWakeLoop <- newIORef Nothing+  ctxHost <- newIORef Map.empty+  ctxDefaultLayout <- newIORef defaultLayout+  ctxTheme <- newIORef defaultTheme+  ctxThemeScopes <- newIORef =<< newThemeScopes+  ctxSpanCache <- newIORef IM.empty+  ctxWidgetTextCache <- newIORef IM.empty+  ctxLayoutCache <- newIORef Nothing+  ctxMetricGen <- newIORef 0+  ctxLastMetricSource <- newIORef Nothing+  ctxPaintFull <- newIORef True+  let fm0 = monospaceMetrics 12+      ctx = Context+        { ctxNodeArena = nodeArena+        , ctxDrawArena = drawArena+        , ctxHotId+        , ctxLastHotId+        , ctxActiveId+        , ctxClickedId+        , ctxReleaseClickedId+        , ctxPressPos+        , ctxRightPressPos+        , ctxFocusId+        , ctxFocusVisible+        , ctxStore+        , ctxDamageState+        , ctxOverlayState+        , ctxAnimationState+        , ctxScrollState+        , ctxDrawingCache+        , ctxIdContext+        , ctxFontMetrics = fm0+        , ctxMonoFontMetrics = fm0+        , ctxMeasureText = measureTextIO fm0+        , ctxResolveFont = defaultResolveFont ctx+        , ctxResolveMeasure = defaultResolveMeasure ctx+        , ctxMeasureCache = Nothing+        , ctxSpanCache+        , ctxWidgetTextCache+        , ctxLayoutCache+        , ctxMetricGen+        , ctxMetricSource = InitialMetricSource+        , ctxLastMetricSource+        , ctxPaintFull+        , ctxExternalText = False+        , ctxTheme+        , ctxThemeScopes+        , ctxContainerStack+        , ctxMessages+        , ctxFocusables+        , ctxFocusablesCount+        , ctxSpanBase+        , ctxSpanOverlay+        , ctxInteractionState+        , ctxClipboardGet = pure Nothing+        , ctxClipboardSet = \_ -> pure False+        , ctxImageAtlas+        , ctxWakeLoop+        , ctxHost+        , ctxDefaultLayout+        }+  pure ctx++newPixelHostContext :: IO Context+newPixelHostContext = do+  ctx0 <- newContext+  ctx <- enableMeasureCache ctx0+  withTheme (withExternalText (withFontMetrics ctx (monospaceMetrics 16)) True) defaultTheme++-- =============================================================================+-- Focus+-- =============================================================================++{-# INLINE getFocusId #-}+getFocusId :: Context -> IO WidgetId+getFocusId ctx = readIORef (ctxFocusId ctx)++-- | Whether the focused widget shows its focus ring: focus moved by keyboard+-- since the last pointer press.+{-# INLINE getFocusVisible #-}+getFocusVisible :: Context -> IO Bool+getFocusVisible ctx = readIORef (ctxFocusVisible ctx)++{-# INLINE getHotId #-}+getHotId :: Context -> IO WidgetId+getHotId ctx = readIORef (ctxHotId ctx)++-- | Add @wid@ to this frame's keyboard focus order, unless it is declared in a+-- disabled scope.+registerFocusable :: Context -> WidgetId -> IO ()+registerFocusable ctx wid = do+  scope <- getArenaScope (ctxNodeArena ctx)+  when (scope .&. 1 == 0) $ do+    idx <- readIORef (ctxFocusablesCount ctx)+    arr <- readIORef (ctxFocusables ctx)+    cap <- getSizeofMutablePrimArray arr+    arr' <-+      if idx >= cap+        then do+          grown <- resizeMutablePrimArray arr (max 16 (cap * 2))+          writeIORef (ctxFocusables ctx) grown+          pure grown+        else pure arr+    writePrimArray arr' idx wid+    writeIORef (ctxFocusablesCount ctx) (idx + 1)++{-# INLINE getFocusables #-}+getFocusables :: Context -> IO [WidgetId]+getFocusables ctx = do+  count <- readIORef (ctxFocusablesCount ctx)+  arr <- readIORef (ctxFocusables ctx)+  forM [0 .. count - 1] (readPrimArray arr)
+ lib/NanoUI/Context/Animation.hs view
@@ -0,0 +1,217 @@+-- | Per-widget animations: starting, ticking, settling and reading values.+module NanoUI.Context.Animation+  ( anyAnimating+  , getLiveAnimations+  , isAnimatingKey+  , takeAnimSettled+  , lookupAnimation+  , getAnimRectless+  , setAnimRectless+  , startAnimation+  , startAnimationEase+  , startAnimationEaseDelay+  , startSpring+  , setAnimationValue+  , tickAnimations+  , getAnimationValue+  , getAnimRest+  , pruneAnimRest+  ) where++import Control.Monad (unless, when)+import Data.IORef (modifyIORef', readIORef, writeIORef)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM++import NanoUI.Animation+  ( Animation (..)+  , Ease (..)+  , SpringParams+  , animInProgress+  , animationValue+  , approxEq+  , easeSameSpec+  , springEps+  , stepAnim+  , writeRest+  )+import NanoUI.Context.Core (damageKey, getsDamage, markDirty)+import NanoUI.Context.Types (AnimationState (..), Context (..), DamageState (..), ScrollState (..), intKey)+import NanoUI.Id (WidgetId)+import NanoUI.Layout.Arena (getRect, lookupNodeByKey)+import NanoUI.Types (DamageBounds (..), defaultDamageSlop)++-- | Whether the frame loop has to keep drawing: an animation is running, or a+-- scroller is still gliding onto its target.+{-# INLINE anyAnimating #-}+anyAnimating :: Context -> IO Bool+anyAnimating ctx = do+  anim <- asAnyAnimating <$> readIORef (ctxAnimationState ctx)+  if anim+    then pure True+    else not . IM.null . ssGlides <$> readIORef (ctxScrollState ctx)++{-# INLINE getLiveAnimations #-}+getLiveAnimations :: Context -> IO (IntMap Animation)+getLiveAnimations ctx = IM.filter animInProgress . asAnimations <$> readIORef (ctxAnimationState ctx)++-- | Whether the widget key has an animation in progress. Unlike+-- 'getLiveAnimations' this does not rebuild the animation map.+{-# INLINE isAnimatingKey #-}+isAnimatingKey :: Context -> Int -> IO Bool+isAnimatingKey ctx key =+  maybe False animInProgress . IM.lookup key . asAnimations <$> readIORef (ctxAnimationState ctx)++-- Consecutive frames each live animation has had no nonzero widget rect in the+-- arena. Maintained by 'NanoUI.Damage.updatePrevRects'; used by 'writeDamage'+-- to bound the DamageFull escalation for rect-less animations so a perpetual+-- animation whose widget left the arena (e.g. `keepAnimating` on a widget+-- hidden by a tab switch) stops repainting the whole window after a frame or+-- two, instead of forever.+{-# INLINE getAnimRectless #-}+getAnimRectless :: Context -> IO (IntMap Int)+getAnimRectless ctx = asRectless <$> readIORef (ctxAnimationState ctx)++{-# INLINE setAnimRectless #-}+setAnimRectless :: Context -> IntMap Int -> IO ()+setAnimRectless ctx m =+  modifyIORef' (ctxAnimationState ctx) $ \as -> as {asRectless = m}++takeAnimSettled :: Context -> IO Bool+takeAnimSettled ctx = do+  as <- readIORef (ctxAnimationState ctx)+  if asAnimSettled as+    then do+      writeIORef (ctxAnimationState ctx) $! as {asAnimSettled = False}+      pure True+    else pure False++{-# INLINE lookupAnimation #-}+lookupAnimation :: Context -> WidgetId -> IO (Maybe Animation)+lookupAnimation ctx wid = IM.lookup (intKey wid) . asAnimations <$> readIORef (ctxAnimationState ctx)++{-# INLINE startAnimation #-}+startAnimation :: Context -> WidgetId -> Float -> Float -> Float -> IO ()+startAnimation ctx wid start end dur = startAnimationEase ctx wid start end dur EaseLinear++{-# INLINE startAnimationEase #-}+startAnimationEase :: Context -> WidgetId -> Float -> Float -> Float -> Ease -> IO ()+startAnimationEase ctx wid start end dur ease = startAnimationEaseDelay ctx wid start end dur ease 0++startAnimationEaseDelay :: Context -> WidgetId -> Float -> Float -> Float -> Ease -> Float -> IO ()+startAnimationEaseDelay ctx wid start end dur ease delay+  | dur <= 0 || approxEq start end = settleKey ctx key end+  | otherwise = do+      as <- readIORef (ctxAnimationState ctx)+      let req = max 0 delay+      case IM.lookup key (asAnimations as) of+        Just a@(EaseAnim aStart _ _ _ _ _ _) | approxEq aStart start && easeSameSpec a ease dur req end -> pure ()+        _ ->+          writeIORef (ctxAnimationState ctx) $!+            as+              { asAnimRest = IM.delete key (asAnimRest as)+              , asAnimations = IM.insert key (EaseAnim start end dur 0 ease req req) (asAnimations as)+              , asAnyAnimating = True+              }+      markDirtyIfOrphan ctx key+  where+    key = intKey wid++startSpring :: Context -> WidgetId -> SpringParams -> Float -> IO ()+startSpring ctx wid params target = do+  let key = intKey wid+  as <- readIORef (ctxAnimationState ctx)+  case IM.lookup key (asAnimations as) of+    Just (SpringAnim _ _ t p) | t == target && p == params -> markDirtyIfOrphan ctx key+    running -> do+      let (pos, vel) = case running of+            Just (SpringAnim p v _ _) -> (p, v)+            Just a -> (animationValue a, 0)+            Nothing -> (IM.findWithDefault 0 key (asAnimRest as), 0)+      if abs (pos - target) <= springEps && abs vel <= springEps+        then settleKey ctx key target+        else do+          writeIORef (ctxAnimationState ctx) $!+            as+              { asAnimRest = IM.delete key (asAnimRest as)+              , asAnimations = IM.insert key (SpringAnim pos vel target params) (asAnimations as)+              , asAnyAnimating = True+              }+          markDirtyIfOrphan ctx key++{-# INLINE setAnimationValue #-}+setAnimationValue :: Context -> WidgetId -> Float -> IO ()+setAnimationValue ctx wid val = settleKey ctx (intKey wid) val++tickAnimations :: Context -> Float -> IO ()+tickAnimations ctx dt =+  modifyIORef' (ctxAnimationState ctx) $ \as ->+    if IM.null (asAnimations as)+      then as {asAnyAnimating = False, asAnimSettled = False}+      else+        let stepped = IM.map (stepAnim dt) (asAnimations as)+            (live, done) = IM.partition animInProgress stepped+            rest' = IM.foldlWithKey' writeRest (asAnimRest as) done+         in as+              { asAnimations = live+              , asAnimRest = rest'+              , asAnyAnimating = not (IM.null live)+              , asAnimSettled = not (IM.null done)+              }++markDirtyIfOrphan :: Context -> Int -> IO ()+markDirtyIfOrphan ctx key = do+  hadRect <- IM.member key <$> getsDamage ctx dsPrevRects+  hasNow <- nodeHasKey ctx key+  unless (hadRect || hasNow) (markDirty ctx)++nodeHasKey :: Context -> Int -> IO Bool+nodeHasKey ctx key = do+  mIdx <- lookupNodeByKey (ctxNodeArena ctx) key+  case mIdx of+    Nothing -> pure False+    Just idx -> do+      (_, _, w, h) <- getRect (ctxNodeArena ctx) idx+      pure (w > 0 && h > 0)++settleKey :: Context -> Int -> Float -> IO ()+settleKey ctx key val = do+  as <- readIORef (ctxAnimationState ctx)+  let rest = asAnimRest as+      prevRest = IM.findWithDefault 0 key rest+      prevLive = IM.lookup key (asAnimations as)+      restChanged+        | approxEq val 0 = IM.member key rest+        | otherwise = prevRest /= val+      rest'+        | not restChanged = rest+        | approxEq val 0 = IM.delete key rest+        | otherwise = IM.insert key val rest+  -- A spring at rest settles every frame; write only what changes.+  case prevLive of+    Just _ -> do+      let anims' = IM.delete key (asAnimations as)+      writeIORef (ctxAnimationState ctx) $!+        as {asAnimations = anims', asAnimRest = rest', asAnyAnimating = not (IM.null anims')}+    Nothing -> when restChanged $ writeIORef (ctxAnimationState ctx) $! as {asAnimRest = rest'}+  when (maybe (not (approxEq prevRest val)) (not . approxEq val . animationValue) prevLive) $ do+    damageKey ctx key (DamageInflated defaultDamageSlop)+    markDirty ctx++getAnimationValue :: Context -> WidgetId -> IO Float+getAnimationValue ctx wid = do+  let key = intKey wid+  as <- readIORef (ctxAnimationState ctx)+  case IM.lookup key (asAnimations as) of+    Just a -> pure $! animationValue a+    Nothing -> pure $! IM.findWithDefault 0 key (asAnimRest as)++{-# INLINE getAnimRest #-}+getAnimRest :: Context -> IO (IntMap Float)+getAnimRest ctx = asAnimRest <$> readIORef (ctxAnimationState ctx)++{-# INLINE pruneAnimRest #-}+pruneAnimRest :: Context -> (Int -> Bool) -> IO ()+pruneAnimRest ctx shouldKeep =+  modifyIORef' (ctxAnimationState ctx) $ \as ->+    as {asAnimRest = IM.filterWithKey (\k _ -> shouldKeep k) (asAnimRest as)}
+ lib/NanoUI/Context/Core.hs view
@@ -0,0 +1,528 @@+-- | Accessors the other Context modules build on: interaction, overlay and+-- damage state, damage requests, the dirty flag, and widget store writes.+module NanoUI.Context.Core+  ( getsInteraction+  , modifyInteraction+  , getsOverlay+  , modifyOverlay+  , getsDamage+  , modifyDamage+  -- Interaction+  , getScrollDrag+  , setTextInputDrag+  , getTextInputMenu+  , setTextInputMenu+  , takeTextEditLastAction+  , getMenuPointerGesture+  , setMenuPointerGesture+  , getWindowDrag+  , getWindowResize+  -- Damage+  , markDirty+  , clearDirty+  , isDirty+  , setWakeLoop+  , takeDamage+  , requestDamage+  , damageWidget+  , damageKey+  , damageRect+  , damagePeers+  , damageFull+  , getPrevRect+  , getPrevClipRect+  -- Store+  , getStore+  , setStore+  , modifyStore+  , getStoreBool+  , writeStoreInt+  , writeStoreFloat+  , writeStoreBool+  , adoptStoreInt+  , adoptStoreFloat+  , adoptStoreText+  , recordStoreInt+  , recordStoreFloat+  , recordStoreText+  , isDisabled+  -- Theme scopes+  , newThemeScopes+  , beginThemeScopes+  , pushThemeScope+  , themeScopesChanged+  , scopeTheme+  , scopeRawTheme+  , currentTheme+  , nodeTheme+  , widgetTheme+  ) where++import Control.Monad (forM_, when)+import Data.Bits (shiftR, (.&.))+import Data.IORef (modifyIORef', readIORef, writeIORef)+import Data.Primitive.SmallArray (copySmallMutableArray, newSmallArray, readSmallArray, getSizeofSmallMutableArray, writeSmallArray)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)++import NanoUI.Context.Types+  ( Context (..)+  , DamageRequest (..)+  , DamageState (..)+  , InteractionState (..)+  , OverlayState+  , TextInputDrag+  , TextInputMenu+  , ThemeScopes (..)+  , WindowResizeDrag+  , intKey+  )+import NanoUI.Id (WidgetId, hashWidgetId)+import NanoUI.Layout.Arena (DirTag, NodeIdx, getArenaScope, getNodeScope, getScopeSignature, lookupNodeByWidgetId)+import NanoUI.Store+  ( WidgetStore (..)+  , boolInt+  , intBool+  , ptrEq+  , slotKey+  , Slot (..)+  )+import NanoUI.Style (Theme)+import NanoUI.Types (Damage, DamageBounds (..), Rect, defaultDamageSlop, rectH, rectW)+import NanoUI.Widgets.TextCommand (TextCommand)++-- =============================================================================+-- State records+-- =============================================================================++{-# INLINE getsInteraction #-}+getsInteraction :: Context -> (InteractionState -> a) -> IO a+getsInteraction ctx f = f <$> readIORef (ctxInteractionState ctx)++{-# INLINE modifyInteraction #-}+modifyInteraction :: Context -> (InteractionState -> InteractionState) -> IO ()+modifyInteraction ctx = modifyIORef' (ctxInteractionState ctx)++{-# INLINE getsOverlay #-}+getsOverlay :: Context -> (OverlayState -> a) -> IO a+getsOverlay ctx f = f <$> readIORef (ctxOverlayState ctx)++{-# INLINE modifyOverlay #-}+modifyOverlay :: Context -> (OverlayState -> OverlayState) -> IO ()+modifyOverlay ctx = modifyIORef' (ctxOverlayState ctx)++{-# INLINE getsDamage #-}+getsDamage :: Context -> (DamageState -> a) -> IO a+getsDamage ctx f = f <$> readIORef (ctxDamageState ctx)++{-# INLINE modifyDamage #-}+modifyDamage :: Context -> (DamageState -> DamageState) -> IO ()+modifyDamage ctx = modifyIORef' (ctxDamageState ctx)++-- =============================================================================+-- Interaction+-- =============================================================================++{-# INLINE getScrollDrag #-}+getScrollDrag :: Context -> IO (Maybe (WidgetId, DirTag, Float))+getScrollDrag ctx = getsInteraction ctx isScrollDrag++{-# INLINE setTextInputDrag #-}+setTextInputDrag :: Context -> Maybe TextInputDrag -> IO ()+setTextInputDrag ctx v = modifyInteraction ctx (\s -> s {isTextInputDrag = v})++{-# INLINE getTextInputMenu #-}+getTextInputMenu :: Context -> IO (Maybe TextInputMenu)+getTextInputMenu ctx = getsInteraction ctx isTextInputMenu++{-# INLINE setTextInputMenu #-}+setTextInputMenu :: Context -> Maybe TextInputMenu -> IO ()+setTextInputMenu ctx v = modifyInteraction ctx (\s -> s {isTextInputMenu = v})++takeTextEditLastAction :: Context -> IO (Maybe (WidgetId, TextCommand))+takeTextEditLastAction ctx = do+  act <- getsInteraction ctx isTextEditLastAction+  modifyInteraction ctx (\s -> s {isTextEditLastAction = Nothing})+  pure act++{-# INLINE getMenuPointerGesture #-}+getMenuPointerGesture :: Context -> IO Bool+getMenuPointerGesture ctx = getsInteraction ctx isMenuPointerGesture++{-# INLINE setMenuPointerGesture #-}+setMenuPointerGesture :: Context -> Bool -> IO ()+setMenuPointerGesture ctx v = modifyInteraction ctx (\s -> s {isMenuPointerGesture = v})++{-# INLINE getWindowDrag #-}+getWindowDrag :: Context -> IO (Maybe (WidgetId, Float, Float))+getWindowDrag ctx = getsInteraction ctx isWindowDrag++{-# INLINE getWindowResize #-}+getWindowResize :: Context -> IO (Maybe WindowResizeDrag)+getWindowResize ctx = getsInteraction ctx isWindowResize++-- =============================================================================+-- Damage+-- =============================================================================++{-# INLINE requestDamage #-}+requestDamage :: Context -> DamageRequest -> IO ()+requestDamage ctx req = modifyDamage ctx (\ds -> ds {dsRequests = req : dsRequests ds})++{-# INLINE damageWidget #-}+damageWidget :: Context -> WidgetId -> DamageBounds -> IO ()+damageWidget ctx wid bounds+  | hashWidgetId wid == 0 = pure ()+  | otherwise = requestDamage ctx (ReqWidget wid bounds)++{-# INLINE damageKey #-}+damageKey :: Context -> Int -> DamageBounds -> IO ()+damageKey ctx k bounds+  | k == 0 = pure ()+  | otherwise = requestDamage ctx (ReqKey k bounds)++{-# INLINE damageRect #-}+damageRect :: Context -> Rect -> IO ()+damageRect ctx r+  | rectW r <= 0 || rectH r <= 0 = pure ()+  | otherwise = requestDamage ctx (ReqRect r)++{-# INLINE damagePeers #-}+damagePeers :: Context -> [WidgetId] -> DamageBounds -> IO ()+damagePeers ctx wids bounds =+  case filter (\w -> hashWidgetId w /= 0) wids of+    [] -> pure ()+    valid -> requestDamage ctx (ReqPeers valid bounds)++{-# INLINE damageFull #-}+damageFull :: Context -> IO ()+damageFull ctx = requestDamage ctx ReqFull++{-# INLINE markDirty #-}+markDirty :: Context -> IO ()+markDirty ctx = do+  modifyDamage ctx (\ds -> ds {dsDirty = True})+  readIORef (ctxWakeLoop ctx) >>= sequence_++{-# INLINE clearDirty #-}+clearDirty :: Context -> IO ()+clearDirty ctx = modifyDamage ctx (\ds -> ds {dsDirty = False})++{-# INLINE isDirty #-}+isDirty :: Context -> IO Bool+isDirty ctx = getsDamage ctx dsDirty++{-# INLINE setWakeLoop #-}+setWakeLoop :: Context -> IO () -> IO ()+setWakeLoop ctx wake = writeIORef (ctxWakeLoop ctx) (Just wake)++{-# INLINE takeDamage #-}+takeDamage :: Context -> IO Damage+takeDamage ctx = getsDamage ctx dsDamage++{-# INLINE getPrevRect #-}+getPrevRect :: Context -> WidgetId -> IO (Maybe Rect)+getPrevRect ctx wid = getsDamage ctx (IM.lookup (intKey wid) . dsPrevRects)++{-# INLINE getPrevClipRect #-}+getPrevClipRect :: Context -> WidgetId -> IO (Maybe Rect)+getPrevClipRect ctx wid = getsDamage ctx (IM.lookup (intKey wid) . dsPrevClips)++-- =============================================================================+-- Store+-- =============================================================================++{-# INLINE getStore #-}+getStore :: Context -> IO WidgetStore+getStore ctx = readIORef (ctxStore ctx)++setStore :: Context -> WidgetStore -> IO ()+setStore ctx store = modifyStore ctx (const store)++-- | Replace the store with @f@ of it, damaging the keys whose values changed+-- and waking the loop when anything did.+modifyStore :: Context -> (WidgetStore -> WidgetStore) -> IO ()+modifyStore ctx f = do+  prev <- readIORef (ctxStore ctx)+  -- WHNF-force the new record: record-update arguments are unevaluated+  -- thunks, and writeIORef would otherwise park one in the long-lived store+  -- every frame.+  let !store = f prev+  writeIORef (ctxStore ctx) store+  let changedKeys =+        diffKeys (storeInt prev) (storeInt store)+          ++ diffKeys (storeFloat prev) (storeFloat store)+          ++ diffKeys (storeDouble prev) (storeDouble store)+          ++ diffKeys (storePoint prev) (storePoint store)+          ++ diffKeys (storeText prev) (storeText store)+          ++ diffKeys (storeFloatList prev) (storeFloatList store)+          ++ diffKeys (storeIntList prev) (storeIntList store)+          ++ diffKeys (storeIntSet prev) (storeIntSet store)+          ++ diffKeysBy ptrEq (storeDyn prev) (storeDyn store)+  -- The key diff doubles as the store comparison: checking 'prev /= store'+  -- first would walk every changed map twice. Its lazy concatenation stops at+  -- the first changed key and allocates less than a list per map.+  when+    ( storeMirrorGen prev /= storeMirrorGen store+        || storeOpenSelect prev /= storeOpenSelect store+        || not (null changedKeys)+    )+    $ do+      forM_ changedKeys $ \k -> damageKey ctx k (DamageInflated defaultDamageSlop)+      markDirty ctx++diffKeysBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> [Int]+diffKeysBy eq old new+  -- Unchanged maps keep their identity through a record update; skip the+  -- whole merge when the caller only rebuilt a different field.+  | ptrEq old new = []+  | otherwise =+      IM.keys+        ( IM.mergeWithKey+            (\_ a b -> if eq a b then Nothing else Just ())+            (IM.map (const ()))+            (IM.map (const ()))+            old+            new+        )++diffKeys :: Eq a => IntMap a -> IntMap a -> [Int]+diffKeys = diffKeysBy (==)++-- | Targeted single-slot write: compares only the target slot, updates one map+-- field, damages the owning widget and wakes the loop. Unlike 'setStore' it+-- never diffs the whole store, and an equal write is a no-op.+{-# INLINE writeSlot #-}+writeSlot ::+  Eq a =>+  (WidgetStore -> IntMap a) ->+  (IntMap a -> WidgetStore -> WidgetStore) ->+  Context ->+  WidgetId ->+  Int ->+  a ->+  IO ()+writeSlot field setField ctx owner k v = do+  st <- readIORef (ctxStore ctx)+  case IM.lookup k (field st) of+    Just old | old == v -> pure ()+    _ -> do+      writeIORef (ctxStore ctx) $! setField (IM.insert k v (field st)) st+      damageWidget ctx owner DamageSelf+      markDirty ctx++writeStoreInt :: Context -> WidgetId -> Int -> Int -> IO ()+writeStoreInt = writeSlot storeInt (\m st -> st {storeInt = m})++writeStoreFloat :: Context -> WidgetId -> Int -> Float -> IO ()+writeStoreFloat = writeSlot storeFloat (\m st -> st {storeFloat = m})++{-# INLINE writeStoreBool #-}+writeStoreBool :: Context -> WidgetId -> Bool -> IO ()+writeStoreBool ctx owner v = writeStoreInt ctx owner (intKey owner) (boolInt v)++-- | Controlled widgets take their value from the caller every frame. The+-- caller's value replaces the stored one only when it differs from the value+-- the widget last returned ('recordSlot'). An edit applied between frames,+-- such as a menu cut, then survives a caller that passes the previous result+-- back, while a value changed by the application still wins. Returns the+-- slot's value after adopting.+{-# INLINE adoptSlot #-}+adoptSlot ::+  Eq a =>+  (WidgetStore -> IntMap a) ->+  (IntMap a -> WidgetStore -> WidgetStore) ->+  Context ->+  WidgetId ->+  Int ->+  a ->+  IO a+adoptSlot field setField ctx owner k v = do+  st <- readIORef (ctxStore ctx)+  let+    m = field st+    seenK = slotKey SlotSeen k+  if IM.lookup seenK m == Just v+    then pure $! IM.findWithDefault v k m+    else do+      writeIORef (ctxStore ctx) $! setField (IM.insert seenK v (IM.insert k v m)) st+      when (IM.lookup k m /= Just v) $ do+        damageWidget ctx owner DamageSelf+        markDirty ctx+      pure v++-- | Remember the value a controlled widget returned this frame.+{-# INLINE recordSlot #-}+recordSlot ::+  Eq a =>+  (WidgetStore -> IntMap a) ->+  (IntMap a -> WidgetStore -> WidgetStore) ->+  Context ->+  Int ->+  a ->+  IO ()+recordSlot field setField ctx k v = do+  st <- readIORef (ctxStore ctx)+  let seenK = slotKey SlotSeen k+  when (IM.lookup seenK (field st) /= Just v) $+    writeIORef (ctxStore ctx) $! setField (IM.insert seenK v (field st)) st++adoptStoreInt :: Context -> WidgetId -> Int -> Int -> IO Int+adoptStoreInt = adoptSlot storeInt (\m st -> st {storeInt = m})++adoptStoreFloat :: Context -> WidgetId -> Int -> Float -> IO Float+adoptStoreFloat = adoptSlot storeFloat (\m st -> st {storeFloat = m})++adoptStoreText :: Context -> WidgetId -> Int -> Text -> IO Text+adoptStoreText = adoptSlot storeText (\m st -> st {storeText = m})++recordStoreInt :: Context -> Int -> Int -> IO ()+recordStoreInt = recordSlot storeInt (\m st -> st {storeInt = m})++recordStoreFloat :: Context -> Int -> Float -> IO ()+recordStoreFloat = recordSlot storeFloat (\m st -> st {storeFloat = m})++recordStoreText :: Context -> Int -> Text -> IO ()+recordStoreText = recordSlot storeText (\m st -> st {storeText = m})++{-# INLINE getStoreBool #-}+getStoreBool :: Context -> WidgetId -> Bool -> IO Bool+getStoreBool ctx wid def =+  intBool . IM.findWithDefault (boolInt def) (intKey wid) . storeInt <$> getStore ctx++-- | Whether @wid@ was declared inside a disabled scope. A widget asks before+-- its node exists, while the scope it is declared in is still the arena's.+{-# INLINE isDisabled #-}+isDisabled :: Context -> WidgetId -> IO Bool+isDisabled ctx wid = do+  ts <- readIORef (ctxThemeScopes ctx)+  if tsDisabled ts then scopeDisabled ctx wid else pure False++{-# NOINLINE scopeDisabled #-}+scopeDisabled :: Context -> WidgetId -> IO Bool+scopeDisabled ctx wid = do+  let na = ctxNodeArena ctx+  mIdx <- lookupNodeByWidgetId na wid+  scope <- maybe (getArenaScope na) (getNodeScope na) mIdx+  pure (scope .&. 1 /= 0)++-- =============================================================================+-- Theme scopes+-- =============================================================================++newThemeScopes :: IO ThemeScopes+newThemeScopes = do+  let unset = error "theme scope: unset"+  cur <- newSmallArray 8 unset+  raw <- newSmallArray 8 unset+  prev <- newSmallArray 8 unset+  prevRaw <- newSmallArray 8 unset+  pure+    ThemeScopes+      { tsCount = 0+      , tsThemes = cur+      , tsRaw = raw+      , tsPrevCount = 0+      , tsPrev = prev+      , tsPrevRaw = prevRaw+      , tsDisabled = False+      , tsChanged = False+      , tsPrevSig = 0+      }++-- | Start a view pass with no pushed themes. The first pass of a frame keeps+-- last frame's themes to compare against; a rebuild pass keeps comparing+-- against the same ones.+beginThemeScopes :: Context -> Bool -> IO ()+beginThemeScopes ctx newFrame = do+  ts <- readIORef (ctxThemeScopes ctx)+  if newFrame+    then do+      sig <- getScopeSignature (ctxNodeArena ctx)+      writeIORef (ctxThemeScopes ctx) $!+        ts+          { tsCount = 0+          , tsThemes = tsPrev ts+          , tsRaw = tsPrevRaw ts+          , tsPrevCount = tsCount ts+          , tsPrev = tsThemes ts+          , tsPrevRaw = tsRaw ts+          , tsDisabled = False+          , tsChanged = False+          , tsPrevSig = sig+          }+    else writeIORef (ctxThemeScopes ctx) $! ts {tsCount = 0, tsDisabled = False, tsChanged = False}++-- | Add a scope drawn with @theme@, whose nested scopes modify @raw@ and which+-- is disabled or not, and+-- return its theme index. A theme equal to last frame's at the same index+-- keeps last frame's value.+pushThemeScope :: Context -> Bool -> Theme -> Theme -> IO Int+pushThemeScope ctx disabled raw theme = do+  ts <- readIORef (ctxThemeScopes ctx)+  let !i = tsCount ts+  cap <- getSizeofSmallMutableArray (tsThemes ts)+  (themes, raws) <-+    if i < cap+      then pure (tsThemes ts, tsRaw ts)+      else do+        grown <- newSmallArray (cap * 2) theme+        copySmallMutableArray grown 0 (tsThemes ts) 0 i+        grownRaw <- newSmallArray (cap * 2) raw+        copySmallMutableArray grownRaw 0 (tsRaw ts) 0 i+        pure (grown, grownRaw)+  same <-+    if i < tsPrevCount ts+      then (== theme) <$> readSmallArray (tsPrev ts) i+      else pure False+  writeSmallArray themes i theme+  writeSmallArray raws i raw+  writeIORef (ctxThemeScopes ctx) $!+    ts {tsCount = i + 1, tsThemes = themes, tsRaw = raws, tsDisabled = tsDisabled ts || disabled, tsChanged = tsChanged ts || not same}+  pure (i + 1)++-- | Whether this frame's scopes look different from last frame's: a theme+-- changed, scopes were added or dropped, or nodes moved between scopes.+themeScopesChanged :: Context -> IO Bool+themeScopesChanged ctx = do+  ts <- readIORef (ctxThemeScopes ctx)+  sig <- getScopeSignature (ctxNodeArena ctx)+  pure (tsChanged ts || tsCount ts /= tsPrevCount ts || sig /= tsPrevSig ts)++{-# INLINE scopeTheme #-}+scopeTheme :: Context -> Int -> IO Theme+scopeTheme ctx scope+  | ti == 0 = readIORef (ctxTheme ctx)+  | otherwise = do+      ts <- readIORef (ctxThemeScopes ctx)+      readSmallArray (tsThemes ts) (ti - 1)+  where+    !ti = scope `shiftR` 1++-- | A scope's theme before any disabled scope faded it.+scopeRawTheme :: Context -> Int -> IO Theme+scopeRawTheme ctx scope+  | ti == 0 = readIORef (ctxTheme ctx)+  | otherwise = do+      ts <- readIORef (ctxThemeScopes ctx)+      readSmallArray (tsRaw ts) (ti - 1)+  where+    !ti = scope `shiftR` 1++-- | The theme of the scope the view is declaring in.+{-# INLINE currentTheme #-}+currentTheme :: Context -> IO Theme+currentTheme ctx = getArenaScope (ctxNodeArena ctx) >>= scopeTheme ctx++{-# INLINE nodeTheme #-}+nodeTheme :: Context -> NodeIdx -> IO Theme+nodeTheme ctx idx = getNodeScope (ctxNodeArena ctx) idx >>= scopeTheme ctx++-- | The theme of @wid@'s node, or of the current scope before it has one.+widgetTheme :: Context -> WidgetId -> IO Theme+widgetTheme ctx wid = do+  ts <- readIORef (ctxThemeScopes ctx)+  if tsCount ts == 0+    then readIORef (ctxTheme ctx)+    else lookupNodeByWidgetId (ctxNodeArena ctx) wid >>= maybe (currentTheme ctx) (nodeTheme ctx)
+ lib/NanoUI/Context/Drawing.hs view
@@ -0,0 +1,340 @@+-- | Per-widget drawing registrations and the caches derived from them.+module NanoUI.Context.Drawing+  ( registerPopupConfig+  , lookupPopupConfig+  , registerDrawing+  , lookupDrawing+  , cachedDrawingOps+  , cachedWidgetLayout+  , lookupDrawFitEnvelope+  , pruneDrawOpCache+  , registerCustomDrawing+  , lookupCustomDrawing+  , cachedCustomDrawingOps+  , refreshCustomDrawingOps+  , drawingOpsStale+  , registerCustomMeasure+  , lookupCustomMeasure+  , registerCustomCursor+  , lookupCustomCursor+  , registerCustomDamageSlop+  , lookupCustomDamageSlop+  , resetDrawingScopeCache+  , hasCustomLayoutInputs+  ) where++import Data.IORef (modifyIORef', readIORef)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.Primitive.SmallArray (SmallArray, mapSmallArray')++import NanoUI.Context.Animation (isAnimatingKey)+import NanoUI.Context.Types+  ( Context (..)+  , CustomDrawBuild+  , CustomDrawContext (..)+  , CustomDrawOpCacheEntry (..)+  , CustomDrawingEntry (..)+  , CustomMeasureFn+  , DrawFitCache (..)+  , DrawOpCacheEntry (..)+  , DrawingCacheState (..)+  , DrawingEntry (..)+  , PopupConfig (..)+  , intKey+  )+import NanoUI.Draw (DrawOp, DrawingBuild, shiftDrawOp)+import NanoUI.Id (WidgetId)+import NanoUI.Input (UiCursorKind)+import NanoUI.Style (Layout)+import NanoUI.Types (PopupAnchor, PopupPlacement, Rect (..), rectH, rectW)++{-# INLINE lookupIn #-}+lookupIn :: (DrawingCacheState -> IntMap a) -> Context -> WidgetId -> IO (Maybe a)+lookupIn field ctx wid = IM.lookup (intKey wid) . field <$> readIORef (ctxDrawingCache ctx)++{-# INLINE registerIn #-}+registerIn ::+  (DrawingCacheState -> IntMap a) ->+  (IntMap a -> DrawingCacheState -> DrawingCacheState) ->+  Context ->+  WidgetId ->+  a ->+  IO ()+registerIn field setField ctx wid v =+  modifyIORef' (ctxDrawingCache ctx) $ \dc ->+    setField (IM.insert (intKey wid) v (field dc)) dc++{-# INLINE registerPopupConfig #-}+registerPopupConfig :: Context -> WidgetId -> PopupAnchor -> PopupPlacement -> Float -> IO ()+registerPopupConfig ctx wid anchor placement offset =+  registerIn dcsPopupConfigs (\m dc -> dc {dcsPopupConfigs = m}) ctx wid (PopupConfig anchor placement offset)++{-# INLINE lookupPopupConfig #-}+lookupPopupConfig :: Context -> WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))+lookupPopupConfig ctx wid =+  fmap (\(PopupConfig anchor placement offset) -> (anchor, placement, offset))+    <$> lookupIn dcsPopupConfigs ctx wid++{-# INLINE registerDrawing #-}+registerDrawing :: Context -> WidgetId -> Int -> DrawingBuild -> IO ()+registerDrawing ctx wid content build =+  registerIn dcsDrawings (\m dc -> dc {dcsDrawings = m}) ctx wid (DrawingEntry content build)++{-# INLINE lookupDrawing #-}+lookupDrawing :: Context -> WidgetId -> IO (Maybe DrawingEntry)+lookupDrawing = lookupIn dcsDrawings++-- | One draw-op cache step. @hit@ holds the bounds and ops of an entry whose+-- key still matches. A same-size hit is reused, translated if the widget+-- moved; a miss or a resize uses @rebuilt@. Ops that differ from the entry are+-- written back with @store@.+serveOps ::+  Maybe (Rect, SmallArray DrawOp) ->+  Rect ->+  SmallArray DrawOp ->+  (SmallArray DrawOp -> IO ()) ->+  IO (SmallArray DrawOp)+serveOps hit rect rebuilt store =+  case hit of+    Just (r, ops)+      | rectW r == rectW rect && rectH r == rectH rect ->+          if rectX r == rectX rect && rectY r == rectY rect+            then pure ops+            else keep (mapSmallArray' (shiftDrawOp (rectX rect - rectX r) (rectY rect - rectY r)) ops)+    _ -> keep rebuilt+  where+    keep ops = store ops >> pure ops++-- | Rebuild draw ops when the content version or width/height change. A move+-- only translates. An unversioned drawing (content 0) additionally drops its+-- cache while the widget is animating, since it has no other invalidation+-- signal; versioned drawings are invalidated by their content key alone.+cachedDrawingOps :: Context -> WidgetId -> Int -> Rect -> DrawingBuild -> IO (SmallArray DrawOp)+cachedDrawingOps ctx wid content rect build = do+  let k = intKey wid+  animated <-+    if content == 0+      then isAnimatingKey ctx k+      else pure False+  cached <- IM.lookup k . dcsDrawOpCache <$> readIORef (ctxDrawingCache ctx)+  let hit = case cached of+        Just DrawOpCacheEntry {doeContent = c, doeBounds = r, doeOps = ops}+          | c == content && not animated -> Just (r, ops)+        _ -> Nothing+  serveOps hit rect (build rect) $ \ops ->+    modifyIORef' (ctxDrawingCache ctx) $ \s ->+      s {dcsDrawOpCache = IM.insert k (DrawOpCacheEntry content rect ops) (dcsDrawOpCache s)}++-- | Reuse a derived layout while envelope, font, content key, and caller layout match.+cachedWidgetLayout ::+  Context ->+  WidgetId ->+  Double ->+  Double ->+  Float ->+  Int ->+  Layout ->+  IO Layout ->+  IO Layout+cachedWidgetLayout ctx wid dw dh lh content incoming compute = do+  let k = intKey wid+  dc <- readIORef (ctxDrawingCache ctx)+  case IM.lookup k (dcsDrawFitCache dc) of+    Just e+      | dfcDw e == dw+          && dfcDh e == dh+          && dfcLh e == lh+          && dfcContent e == content+          && dfcIn e == incoming ->+          pure (dfcOut e)+    _ -> do+      out <- compute+      modifyIORef' (ctxDrawingCache ctx) $ \s ->+        s { dcsDrawFitCache = IM.insert k (DrawFitCache dw dh lh content incoming out) (dcsDrawFitCache s)+          , dcsDrawOpCache = IM.delete k (dcsDrawOpCache s)+          }+      pure out++lookupDrawFitEnvelope ::+  Context ->+  WidgetId ->+  Float ->+  Int ->+  Layout ->+  IO (Maybe (Double, Double))+lookupDrawFitEnvelope ctx wid lh content incoming = do+  cached <- lookupIn dcsDrawFitCache ctx wid+  pure $ case cached of+    Just e+      | dfcLh e == lh+          && dfcContent e == content+          && dfcIn e == incoming ->+          Just (dfcDw e, dfcDh e)+    _ -> Nothing++-- | Drop cached ops for drawings that did not rebuild this frame.+pruneDrawOpCache :: Context -> IO ()+pruneDrawOpCache ctx =+  modifyIORef' (ctxDrawingCache ctx) $ \dc ->+    let live = dcsDrawings dc+        customLive = dcsCustomDrawings dc+     in dc+          { dcsDrawOpCache = dcsDrawOpCache dc `IM.intersection` live+          , dcsCustomDrawOpCache = dcsCustomDrawOpCache dc `IM.intersection` customLive+          , dcsDrawFitCache = dcsDrawFitCache dc `IM.intersection` live+          }++{-# INLINE registerCustomDrawing #-}+registerCustomDrawing :: Context -> WidgetId -> Int -> CustomDrawBuild -> IO ()+registerCustomDrawing ctx wid content build =+  registerIn dcsCustomDrawings (\m dc -> dc {dcsCustomDrawings = m}) ctx wid (CustomDrawingEntry content build)++{-# INLINE lookupCustomDrawing #-}+lookupCustomDrawing :: Context -> WidgetId -> IO (Maybe CustomDrawingEntry)+lookupCustomDrawing = lookupIn dcsCustomDrawings++-- | Whether a cache entry was built from these inputs, leaving aside where the+-- widget sits: ops built at another origin translate rather than rebuild.+{-# INLINE customEntryMatches #-}+customEntryMatches :: CustomDrawOpCacheEntry -> Int -> Rect -> CustomDrawContext -> Int -> Bool+customEntryMatches e content rect cdc gen =+  cdeContent e == content+    && rectW (cdeBounds e) == rectW rect+    && rectH (cdeBounds e) == rectH rect+    && cdeHovered e == cdcHovered cdc+    && cdePressed e == cdcPressed cdc+    && cdeFocused e == cdcFocused cdc+    && cdeDisabled e == cdcDisabled cdc+    && cdeGen e == gen++-- | Draw ops for a custom widget's paint: the ops 'refreshCustomDrawingOps'+-- settled on this frame while every input still matches, translated if the+-- widget only moved, else a fresh build.+cachedCustomDrawingOps ::+  Context ->+  WidgetId ->+  Int ->+  Rect ->+  CustomDrawContext ->+  CustomDrawBuild ->+  IO (SmallArray DrawOp)+cachedCustomDrawingOps ctx wid content rect cdc build = do+  let k = intKey wid+  gen <- readIORef (ctxMetricGen ctx)+  cached <- IM.lookup k . dcsCustomDrawOpCache <$> readIORef (ctxDrawingCache ctx)+  let hit = case cached of+        Just e | customEntryMatches e content rect cdc gen -> Just (cdeBounds e, cdeOps e)+        _ -> Nothing+  serveOps hit rect (build cdc rect) (storeCustomDrawingOps ctx k content rect cdc gen)++-- | Settle a custom widget's ops for this frame and cache them for paint,+-- returning whether what it draws changed at an unchanged rect.+--+-- A widget that declares a content key is taken at its word, as a versioned+-- drawing is: an unchanged key with unchanged size, interaction state and+-- metrics neither rebuilds the ops nor repaints them, animating or not, so a+-- drawing that reads an animated value has to fold it into its key. One that+-- only moved keeps its ops too; paint translates them. Without a key (0) the+-- build can read anything (a sort flag, a fraction), and nothing but building+-- it shows that its output changed, so it is rebuilt and compared.+--+-- Whatever forced a rebuild, the ops it produced decide the damage, so a key+-- bumped without a visible change repaints nothing and a rebuild the key never+-- mentioned still repaints. A new, moved or resized widget reports no change:+-- rect damage covers it.+refreshCustomDrawingOps ::+  Context ->+  WidgetId ->+  Int ->+  Rect ->+  CustomDrawContext ->+  CustomDrawBuild ->+  IO Bool+refreshCustomDrawingOps ctx wid content rect cdc build = do+  let k = intKey wid+  gen <- readIORef (ctxMetricGen ctx)+  cached <- IM.lookup k . dcsCustomDrawOpCache <$> readIORef (ctxDrawingCache ctx)+  let keyed = content /= 0+  case cached of+    -- A keyed widget that only moved keeps its ops: paint translates them, and+    -- the move is damaged by the rect delta.+    Just e | keyed && customEntryMatches e content rect cdc gen -> pure False+    _ -> do+      let ops = build cdc rect+          -- Whatever made this frame rebuild - the key, the interaction state,+          -- a theme or font change - the ops are built now, so ask them+          -- directly rather than trusting the key for damage as well.+          changed = case cached of+            Just e | cdeBounds e == rect -> cdeOps e /= ops+            _ -> False+      storeCustomDrawingOps ctx k content rect cdc gen ops+      pure changed++storeCustomDrawingOps :: Context -> Int -> Int -> Rect -> CustomDrawContext -> Int -> SmallArray DrawOp -> IO ()+storeCustomDrawingOps ctx k content rect cdc gen ops =+  modifyIORef' (ctxDrawingCache ctx) $ \s ->+    let entry =+          CustomDrawOpCacheEntry+            content+            rect+            (cdcHovered cdc)+            (cdcPressed cdc)+            (cdcFocused cdc)+            (cdcDisabled cdc)+            gen+            ops+     in s {dcsCustomDrawOpCache = IM.insert k entry (dcsCustomDrawOpCache s)}++-- | Whether a versioned drawing's cached ops are for another version at the+-- same rect. Paint rebuilds them; the pixels they covered must repaint too,+-- and checking the version costs nothing next to building the ops here.+drawingOpsStale :: Context -> WidgetId -> Int -> Rect -> IO Bool+drawingOpsStale ctx wid content rect = do+  cached <- IM.lookup (intKey wid) . dcsDrawOpCache <$> readIORef (ctxDrawingCache ctx)+  pure $ case cached of+    Just DrawOpCacheEntry {doeContent = c, doeBounds = r} -> c /= content && r == rect+    Nothing -> False++{-# INLINE registerCustomMeasure #-}+registerCustomMeasure :: Context -> WidgetId -> CustomMeasureFn -> IO ()+registerCustomMeasure = registerIn dcsCustomMeasures (\m dc -> dc {dcsCustomMeasures = m})++{-# INLINE lookupCustomMeasure #-}+lookupCustomMeasure :: Context -> WidgetId -> IO (Maybe CustomMeasureFn)+lookupCustomMeasure = lookupIn dcsCustomMeasures++{-# INLINE registerCustomCursor #-}+registerCustomCursor :: Context -> WidgetId -> (CustomDrawContext -> UiCursorKind) -> IO ()+registerCustomCursor = registerIn dcsCustomCursors (\m dc -> dc {dcsCustomCursors = m})++{-# INLINE lookupCustomCursor #-}+lookupCustomCursor :: Context -> WidgetId -> IO (Maybe (CustomDrawContext -> UiCursorKind))+lookupCustomCursor = lookupIn dcsCustomCursors++{-# INLINE registerCustomDamageSlop #-}+registerCustomDamageSlop :: Context -> WidgetId -> Float -> IO ()+registerCustomDamageSlop = registerIn dcsCustomDamageSlop (\m dc -> dc {dcsCustomDamageSlop = m})++{-# INLINE lookupCustomDamageSlop #-}+lookupCustomDamageSlop :: Context -> WidgetId -> IO (Maybe Float)+lookupCustomDamageSlop = lookupIn dcsCustomDamageSlop++resetDrawingScopeCache :: Context -> IO ()+resetDrawingScopeCache ctx =+  modifyIORef' (ctxDrawingCache ctx) $ \dc ->+    dc+      { dcsDrawings = IM.empty+      , dcsPopupConfigs = IM.empty+      , dcsCustomMeasures = IM.empty+      , dcsCustomCursors = IM.empty+      , dcsCustomDrawings = IM.empty+      , dcsCustomDamageSlop = IM.empty+      }++-- | True when any node has a custom measure function, whose output is not+-- captured by the arena descriptor comparison, so whole-layout reuse must be+-- disabled for the frame.+hasCustomLayoutInputs :: Context -> IO Bool+hasCustomLayoutInputs ctx =+  not . IM.null . dcsCustomMeasures <$> readIORef (ctxDrawingCache ctx)
+ lib/NanoUI/Context/Overlay.hs view
@@ -0,0 +1,157 @@+-- | Modal, floating-panel and menu pointer-capture state.+module NanoUI.Context.Overlay+  ( textInputEditActive+  , modalActive+  , overlayConsumesQuit+  , markEscapeConsumed+  , pointerBlockedByModal+  , pointerBlockedByOverlay+  , armMenuPointerCapture+  , seedFloatingPanel+  , beginModal+  , endModal+  , beginFrameModal+  , modalDamageFlip+  ) where++import Control.Monad (when)+import Data.IORef (readIORef)+import Data.IntMap.Strict qualified as IM++import NanoUI.Context.Core+  ( getMenuPointerGesture+  , getTextInputMenu+  , getsOverlay+  , modifyOverlay+  , setMenuPointerGesture+  , getsInteraction+  )+import NanoUI.Context.Types (Context (..), OverlayState (..), TextInputMenu (..), intKey, InteractionState (..))+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (Input, Key (KeyEscape), inputKeys, inputKeysElem, inputMousePos, inputMousePressed)+import NanoUI.Types (Rect, V2, rectContains, rectHit, rectNonEmpty)++textInputEditActive :: Context -> IO Bool+textInputEditActive ctx = do+  focus <- readIORef (ctxFocusId ctx)+  menu <- getTextInputMenu ctx+  pure (hashWidgetId focus /= 0 || menu /= Nothing)++modalActive :: Context -> IO Bool+modalActive ctx = getsOverlay ctx (\os -> osModalWasActive os || osModalActive os)++overlayConsumesQuit :: Context -> Input -> IO Bool+overlayConsumesQuit ctx inp = do+  consumed <- getsOverlay ctx osEscapeConsumed+  pure (inputKeysElem KeyEscape (inputKeys inp) && consumed)++markEscapeConsumed :: Context -> IO ()+markEscapeConsumed ctx = modifyOverlay ctx (\os -> os {osEscapeConsumed = True})++pointerBlockedByModal :: Context -> IO Bool+pointerBlockedByModal ctx =+  getsOverlay ctx (\os -> osModalDepth os <= 0 && (osModalWasActive os || osModalActive os))++pointerBlockedByOverlay :: Context -> V2 -> IO Bool+pointerBlockedByOverlay ctx mouse = do+  gesture <- getMenuPointerGesture ctx+  blocked <-+    if gesture+      then pure True+      else do+        menuBlocked <- overlayMenuBlocksPointer ctx mouse+        if menuBlocked+          then pure True+          else do+            modalBlocked <- pointerBlockedByModal ctx+            if modalBlocked+              then pure True+              else do+                mTop <- cachedTopmost ctx mouse+                case mTop of+                  Nothing -> pure False+                  Just top -> do+                    mCur <- getsOverlay ctx osCurrentFloatingId+                    pure (mCur /= Just top)+  modifyOverlay ctx (\os -> os {osLastPointerBlocked = blocked})+  pure blocked++armMenuPointerCapture :: Context -> Input -> IO ()+armMenuPointerCapture ctx inp =+  when (inputMousePressed inp) $ do+    blocked <- overlayMenuBlocksPointer ctx (inputMousePos inp)+    setMenuPointerGesture ctx blocked++overlayMenuBlocksPointer :: Context -> V2 -> IO Bool+overlayMenuBlocksPointer ctx mouse = do+  mMenu <- getTextInputMenu ctx+  let textMenu =+        case mMenu of+          Just m | rectContains (textInputMenuRect m) mouse -> True+          _ -> False+  if textMenu+    then pure True+    else do+      mDrop <- getsInteraction ctx isOpenSelectDrop+      pure+        ( case mDrop of+            Just (_, r) -> rectContains r mouse+            Nothing -> False+        )++cachedTopmost :: Context -> V2 -> IO (Maybe WidgetId)+cachedTopmost ctx mouse = do+  cache <- getsOverlay ctx osTopmostCache+  case cache of+    Just (p, t) | p == mouse -> pure t+    _ -> do+      t <- topmostFloatingAtMouse ctx mouse+      modifyOverlay ctx (\os -> os {osTopmostCache = Just (mouse, t)})+      pure t++topmostFloatingAtMouse :: Context -> V2 -> IO (Maybe WidgetId)+topmostFloatingAtMouse ctx mouse = do+  os <- readIORef (ctxOverlayState ctx)+  let rects = osPrevFloatingRects os+      order = osPrevFloatingOrder os+      hit k = maybe False (`rectHit` mouse) (IM.lookup k rects)+      picked = foldl' (\acc k -> if hit k then Just k else acc) Nothing order+  pure (WidgetId . fromIntegral <$> picked)++seedFloatingPanel :: Context -> WidgetId -> Rect -> IO ()+seedFloatingPanel ctx wid rect+  | not (rectNonEmpty rect) = pure ()+  | otherwise = do+      let k = intKey wid+      modifyOverlay ctx $ \os ->+        let rects = IM.insert k rect (osPrevFloatingRects os)+            order = filter (/= k) (osPrevFloatingOrder os) ++ [k]+         in os+              { osPrevFloatingRects = rects+              , osPrevFloatingOrder = order+              , osTopmostCache = Nothing+              }++beginModal :: Context -> IO ()+beginModal ctx =+  modifyOverlay ctx (\os -> os {osModalActive = True, osModalDepth = osModalDepth os + 1})++endModal :: Context -> IO ()+endModal ctx =+  modifyOverlay ctx (\os -> os {osModalDepth = max 0 (osModalDepth os - 1)})++beginFrameModal :: Context -> IO ()+beginFrameModal ctx =+  modifyOverlay ctx $ \os ->+    os+      { osModalWasActive = osModalActive os+      , osModalActive = False+      , osModalDepth = 0+      , osTopmostCache = Nothing+      , osCurrentFloatingId = Nothing+      , osLastPointerBlocked = False+      , osEscapeConsumed = False+      }++modalDamageFlip :: Context -> IO Bool+modalDamageFlip ctx = getsOverlay ctx (\os -> osModalWasActive os /= osModalActive os)
+ lib/NanoUI/Context/Scroll.hs view
@@ -0,0 +1,623 @@+-- | Scroll offsets, links and configuration kept in the widget store, the+-- wheel and glide tuning kept in the context, and the commands that move a+-- scroller: to an offset, by a delta or page, or onto a widget.+module NanoUI.Context.Scroll+  ( getScrollOffset+  , setScrollOffset+  , getScrollOffset2D+  , setScrollOffset2D+  , setScrollConfig+  , linkScrollAxes+    -- * Tuning+  , ScrollTuning (..)+  , defaultScrollTuning+  , getScrollTuning+  , setScrollTuning+  , getScrollStep+  , setScrollStep+  , resolveScrollStep+    -- * Geometry+  , ScrollAxes (..)+  , ScrollMetrics (..)+  , getScrollMetrics+  , cacheScrollMetrics+  , beginScrollMetrics+  , getScrollOffsetIn+  , setScrollOffsetIn+    -- * Commands+  , ScrollBehavior (..)+  , ScrollAlign (..)+  , scrollTo+  , scrollBy+  , scrollPages+  , scrollToStart+  , scrollToEnd+  , scrollIntoView+  , scrollRectIntoView+    -- * Glide+  , applyScrollTarget+  , scrollTargetOffset+  , scrollGliding+  , clampScrollOffset+  , cancelScrollGlide+  , stepScrollGlides+  ) where++import Control.Monad (unless, when)+import Data.IORef (modifyIORef', readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS++import NanoUI.Context.Core (damageWidget, getPrevRect, getStore, setStore)+import NanoUI.Context.Types+  ( Context (..)+  , ScrollAxes (..)+  , ScrollGlide (..)+  , ScrollState (..)+  , ScrollTuning (..)+  , defaultScrollTuning+  , intKey+  )+import NanoUI.Draw qualified as Draw+import NanoUI.Frame.Scroll.Geometry+  ( ScrollConfig+  , decodeScrollConfig+  , defaultScrollConfig+  , encodeScrollConfig+  , scrollConfigNative2D+  )+import NanoUI.Id (WidgetId)+import NanoUI.Store+  ( WidgetStore (..)+  , slotKey+  , Slot (..)+  )+import NanoUI.Types (DamageBounds (..), Rect (..), V2 (..), clamp, onGrid, v2X, v2Y)++{-# INLINE snapScrollOffset #-}+snapScrollOffset :: Context -> Float -> IO Float+snapScrollOffset ctx v = do+  s <- Draw.getDrawSnapScale (ctxDrawArena ctx)+  pure (onGrid s v)++getScrollOffset :: Context -> WidgetId -> IO Float+getScrollOffset ctx wid = do+  s <- getStore ctx+  let key = intKey wid+      points = storePoint s+      cfgBits = IM.findWithDefault (encodeScrollConfig defaultScrollConfig) (slotKey SlotScrollCfg key) (storeInt s)+      -- Text areas keep both axes in their own slot; native 2D scrollers keep+      -- them in the offset slot, falling back to the main-axis float as+      -- 'getScrollOffset2D' does.+      off = case IM.lookup (slotKey SlotTextAreaScroll key) points of+        Just (_, sy) -> sy+        Nothing+          | scrollConfigNative2D (decodeScrollConfig cfgBits)+          , Just (_, y) <- IM.lookup (slotKey SlotScrollOff key) points ->+              y+          | otherwise -> IM.findWithDefault 0 key (storeFloat s)+  snapScrollOffset ctx off++-- | Move a scroller to an offset along its main axis. Cancels a glide in+-- flight: whoever sets an offset outright owns it.+setScrollOffset :: Context -> WidgetId -> Float -> IO ()+setScrollOffset ctx wid off = do+  cancelScrollGlide ctx wid+  writeScrollOffset ctx wid off++writeScrollOffset :: Context -> WidgetId -> Float -> IO ()+writeScrollOffset ctx wid off = do+  store <- getStore ctx+  let key = intKey wid+      sKey = slotKey SlotTextAreaScroll key+  case IM.lookup sKey (storePoint store) of+    Just (sx, sy) ->+      when (sy /= off) $ do+        setStore ctx (store {storePoint = IM.insert sKey (sx, off) (storePoint store)})+        damageWidget ctx wid DamageSelf+    Nothing -> do+      cfg <- getScrollConfig ctx wid+      if scrollConfigNative2D cfg+        then do+          cur <- getScrollOffset2D ctx wid+          writeScrollOffset2D ctx wid (V2 (v2X cur) off)+        else do+          let prev = IM.findWithDefault 0 key (storeFloat store)+          when (prev /= off) $ do+            let floats0 = IM.insert key off (storeFloat store)+                yKey = IM.findWithDefault 0 (slotKey SlotScrollLinkY key) (storeInt store)+            if yKey == 0+              then setStore ctx (store {storeFloat = floats0})+              else do+                let offKey = slotKey SlotScrollOff yKey+                    crossKey = slotKey SlotScrollCross yKey+                    prevY = IM.findWithDefault 0 yKey floats0+                    floats1 = IM.insert yKey prevY $ IM.insert crossKey off floats0+                    points = IM.insert offKey (off, prevY) (storePoint store)+                setStore ctx (store {storeFloat = floats1, storePoint = points})++getScrollOffset2D :: Context -> WidgetId -> IO V2+getScrollOffset2D ctx wid = do+  s <- getStore ctx+  let widKey = intKey wid+      sKey = slotKey SlotTextAreaScroll widKey+  v <-+    case IM.lookup sKey (storePoint s) of+      Just (sx, sy) -> pure (V2 sx sy)+      Nothing -> do+        let offKey = slotKey SlotScrollOff widKey+            crossKey = slotKey SlotScrollCross widKey+        case IM.lookup offKey (storePoint s) of+          Just (x, y) -> pure (V2 x y)+          Nothing ->+            pure+              ( V2+                  (IM.findWithDefault 0 crossKey (storeFloat s))+                  (IM.findWithDefault 0 widKey (storeFloat s))+              )+  sx <- snapScrollOffset ctx (v2X v)+  sy <- snapScrollOffset ctx (v2Y v)+  pure (V2 sx sy)++-- | Move a scroller to an offset on both axes. Cancels a glide in flight.+setScrollOffset2D :: Context -> WidgetId -> V2 -> IO ()+setScrollOffset2D ctx wid off = do+  cancelScrollGlide ctx wid+  writeScrollOffset2D ctx wid off++writeScrollOffset2D :: Context -> WidgetId -> V2 -> IO ()+writeScrollOffset2D ctx wid off = do+  store <- getStore ctx+  let widKey = intKey wid+      sKey = slotKey SlotTextAreaScroll widKey+  -- Text areas only reach the first branch because `textAreaWith` seeds this+  -- slot at init; without the seed a freshly mounted editor falls through to+  -- the container slots below and its offsets are never rendered.+  case IM.lookup sKey (storePoint store) of+    Just (sx, sy) -> do+      let sx' = v2X off+          sy' = v2Y off+      when (sx /= sx' || sy /= sy') $ do+        setStore ctx (store {storePoint = IM.insert sKey (sx', sy') (storePoint store)})+        damageWidget ctx wid DamageSelf+    Nothing -> do+      let offKey = slotKey SlotScrollOff widKey+          crossKey = slotKey SlotScrollCross widKey+          prev = IM.lookup offKey (storePoint store)+          next = (v2X off, v2Y off)+          prevY = IM.findWithDefault 0 widKey (storeFloat store)+          prevX = IM.findWithDefault 0 crossKey (storeFloat store)+          xLink = IM.findWithDefault 0 (slotKey SlotScrollLinkX widKey) (storeInt store)+      when (prev /= Just next || prevY /= v2Y off || prevX /= v2X off) $ do+        let floats0 =+              IM.insert widKey (v2Y off) $+                IM.insert crossKey (v2X off) (storeFloat store)+            floats1 =+              if xLink == 0 then floats0 else IM.insert xLink (v2X off) floats0+        setStore ctx+          ( store+              { storePoint = IM.insert offKey next (storePoint store)+              , storeFloat = floats1+              }+          )++linkScrollAxes :: Context -> WidgetId -> WidgetId -> IO ()+linkScrollAxes ctx yWid xWid = do+  store <- getStore ctx+  let yKey = intKey yWid+      xKey = intKey xWid+      ints =+        IM.insert (slotKey SlotScrollLinkX yKey) xKey $+          IM.insert (slotKey SlotScrollLinkY xKey) yKey (storeInt store)+  setStore ctx (store {storeInt = ints})+  V2 x2 y <- getScrollOffset2D ctx yWid+  x1 <- do+    s <- getStore ctx+    pure (IM.findWithDefault 0 xKey (storeFloat s))+  let x = if x2 == 0 && x1 /= 0 then x1 else x2+  when (x /= x2 || x /= x1) $+    setScrollOffset2D ctx yWid (V2 x y)++getScrollConfig :: Context -> WidgetId -> IO ScrollConfig+getScrollConfig ctx wid = do+  s <- getStore ctx+  let cfgKey = slotKey SlotScrollCfg (intKey wid)+      bits = IM.findWithDefault (encodeScrollConfig defaultScrollConfig) cfgKey (storeInt s)+  pure (decodeScrollConfig bits)++setScrollConfig :: Context -> WidgetId -> ScrollConfig -> IO ()+setScrollConfig ctx wid cfg = do+  store <- getStore ctx+  let cfgKey = slotKey SlotScrollCfg (intKey wid)+      bits = encodeScrollConfig cfg+      prev = IM.findWithDefault (encodeScrollConfig defaultScrollConfig) cfgKey (storeInt store)+  when (prev /= bits) $+    setStore ctx (store {storeInt = IM.insert cfgKey bits (storeInt store)})++-- =============================================================================+-- Tuning+-- =============================================================================++-- | Wheel step and glide time for every scroller in this context.+getScrollTuning :: Context -> IO ScrollTuning+getScrollTuning ctx = ssTuning <$> readIORef (ctxScrollState ctx)++-- | Set the wheel step and glide time. Raising 'scrollWheelStep' makes the+-- wheel cover more ground per notch; a nonzero 'scrollSmoothTime' turns every+-- wheel notch and every 'ScrollSmooth' command into a glide.+setScrollTuning :: Context -> ScrollTuning -> IO ()+setScrollTuning ctx tuning =+  modifyIORef' (ctxScrollState ctx) $ \st -> st {ssTuning = tuning}++-- | This scroller's own wheel step, or @0@ when it follows the context's.+getScrollStep :: Context -> WidgetId -> IO Float+getScrollStep ctx wid = do+  s <- getStore ctx+  pure (IM.findWithDefault 0 (slotKey SlotScrollStep (intKey wid)) (storeFloat s))++-- | Give one scroller its own wheel step, in pixels per notch. @0@ puts it+-- back on the context's step. A list whose rows are a fixed height reads best+-- at a whole number of rows per notch.+setScrollStep :: Context -> WidgetId -> Float -> IO ()+setScrollStep ctx wid px = do+  store <- getStore ctx+  let key = slotKey SlotScrollStep (intKey wid)+      prev = IM.findWithDefault 0 key (storeFloat store)+  when (prev /= px) $+    setStore ctx (store {storeFloat = IM.insert key px (storeFloat store)})++-- | Pixels one wheel notch scrolls this scroller.+resolveScrollStep :: Context -> WidgetId -> IO Float+resolveScrollStep ctx wid = do+  own <- getScrollStep ctx wid+  if own > 0+    then pure own+    else max 1 . scrollWheelStep <$> getScrollTuning ctx++-- =============================================================================+-- Geometry+-- =============================================================================++-- | What a scroller looked like on the frame it was last laid out on.+-- Offsets and ranges are in window axes: @x@ rightwards, @y@ downwards,+-- whichever way the scroller itself is built.+data ScrollMetrics = ScrollMetrics+  { scrollViewport :: !Rect+  -- ^ The visible content, in window coordinates, inside padding and clear of+  -- the scrollbars.+  , scrollRange :: !V2+  -- ^ Largest offset each axis reaches. @0@ on an axis that does not scroll.+  , scrollOffset :: !V2+  -- ^ Where the scroller is now.+  , scrollAxes :: !ScrollAxes+  }+  deriving (Eq, Show)++-- | Geometry of the scroller @wid@, or 'Nothing' before it has been laid out.+-- Reads the last frame's layout, so it is safe to call while building the+-- next one.+getScrollMetrics :: Context -> WidgetId -> IO (Maybe ScrollMetrics)+getScrollMetrics ctx wid = do+  s <- getStore ctx+  let key = intKey wid+      point slot = IM.lookup (slotKey slot key) (storePoint s)+  case (point SlotScrollViewPos, point SlotScrollViewSize, point SlotScrollRange) of+    (Just (vx, vy), Just (vw, vh), Just (mx, my)) -> do+      let axes = decodeScrollAxes (IM.findWithDefault 0 (slotKey SlotScrollAxes key) (storeInt s))+      off <- getScrollOffsetIn ctx wid axes+      pure $+        Just+          ScrollMetrics+            { scrollViewport = Rect vx vy vw vh+            , scrollRange = V2 mx my+            , scrollOffset = off+            , scrollAxes = axes+            }+    _ -> pure Nothing++-- | Start a frame's geometry pass: the first scroll node to publish under a+-- widget id wins for that frame.+beginScrollMetrics :: Context -> IO ()+beginScrollMetrics ctx =+  modifyIORef' (ctxScrollState ctx) $ \st ->+    if IS.null (ssCached st) then st else st {ssCached = IS.empty}++-- | Record what the scroll pass measured, so the commands and the app can+-- read it between frames. Writes nothing when nothing moved, and nothing at+-- all for a second node sharing this one's widget id. A table's frozen pane+-- and its body share theirs, and letting both publish would rewrite the store+-- every frame and hand the commands a viewport that alternates between panes.+cacheScrollMetrics :: Context -> WidgetId -> ScrollAxes -> Rect -> V2 -> IO ()+cacheScrollMetrics ctx wid axes viewport range = do+  taken <- claimScrollMetrics ctx (intKey wid)+  unless taken (writeScrollMetrics ctx wid axes viewport range)++-- | Whether this widget id has already published geometry this frame; marks+-- it published if not.+claimScrollMetrics :: Context -> Int -> IO Bool+claimScrollMetrics ctx key = do+  st <- readIORef (ctxScrollState ctx)+  if IS.member key (ssCached st)+    then pure True+    else do+      writeIORef (ctxScrollState ctx) $! st {ssCached = IS.insert key (ssCached st)}+      pure False++writeScrollMetrics :: Context -> WidgetId -> ScrollAxes -> Rect -> V2 -> IO ()+writeScrollMetrics ctx wid axes (Rect vx vy vw vh) range@(V2 mx my) = do+  -- A range that just shrank (a filtered list, a narrower window) would leave+  -- a glide heading past the new end.+  clampScrollGlide ctx wid range+  store <- getStore ctx+  let key = intKey wid+      axesKey = slotKey SlotScrollAxes key+      posKey = slotKey SlotScrollViewPos key+      sizeKey = slotKey SlotScrollViewSize key+      rangeKey = slotKey SlotScrollRange key+      code = encodeScrollAxes axes+      points = storePoint store+      ints = storeInt store+      samePoint k v = IM.lookup k points == Just v+  unless+    ( samePoint posKey (vx, vy)+        && samePoint sizeKey (vw, vh)+        && samePoint rangeKey (mx, my)+        && IM.lookup axesKey ints == Just code+    )+    $ setStore ctx+      ( store+          { storePoint =+              IM.insert posKey (vx, vy) $+                IM.insert sizeKey (vw, vh) $+                  IM.insert rangeKey (mx, my) points+          , storeInt = IM.insert axesKey code ints+          }+      )++encodeScrollAxes :: ScrollAxes -> Int+encodeScrollAxes = \case+  ScrollAxisY -> 0+  ScrollAxisX -> 1+  ScrollAxisXY -> 2++decodeScrollAxes :: Int -> ScrollAxes+decodeScrollAxes = \case+  1 -> ScrollAxisX+  2 -> ScrollAxisXY+  _ -> ScrollAxisY++-- | A 1D row scroller keeps its offset in the main-axis slot, so window and+-- stored axes are swapped for it and identical for everything else. The swap+-- is its own inverse.+{-# INLINE swapAxes #-}+swapAxes :: ScrollAxes -> V2 -> V2+swapAxes ScrollAxisX (V2 x y) = V2 y x+swapAxes _ v = v++-- | This scroller's offset in window axes.+getScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> IO V2+getScrollOffsetIn ctx wid axes = swapAxes axes <$> getScrollOffset2D ctx wid++-- | Move a scroller to an offset in window axes, cancelling any glide. A 1D+-- scroller ignores the axis it does not scroll on.+setScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> V2 -> IO ()+setScrollOffsetIn ctx wid axes off = do+  cancelScrollGlide ctx wid+  writeScrollOffsetIn ctx wid axes off++writeScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> V2 -> IO ()+writeScrollOffsetIn ctx wid axes off =+  case axes of+    ScrollAxisXY -> writeScrollOffset2D ctx wid off+    ScrollAxisY -> writeScrollOffset ctx wid (v2Y off)+    ScrollAxisX -> writeScrollOffset ctx wid (v2X off)++-- =============================================================================+-- Commands+-- =============================================================================++-- | Whether a scroll lands on its target at once or glides onto it.+-- 'ScrollSmooth' still lands at once when the context's 'scrollSmoothTime' is+-- @0@, so one setting turns smooth scrolling on for the whole app.+data ScrollBehavior = ScrollInstant | ScrollSmooth+  deriving (Eq, Show)++-- | Where a widget ends up in the viewport once it is scrolled into view.+data ScrollAlign+  = -- | Move as little as possible: nothing at all when it is already whole.+    ScrollNearest+  | -- | Against the leading edge, at the top or left.+    ScrollStart+  | ScrollCenter+  | -- | Against the trailing edge, at the bottom or right.+    ScrollEnd+  deriving (Eq, Show)++-- | Scroll to an absolute offset, clamped to the scroller's range.+scrollTo :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()+scrollTo ctx wid off behavior =+  withScrollMetrics ctx wid $ \m ->+    applyScrollTarget ctx wid (scrollAxes m) (clampScrollOffset (scrollRange m) off) behavior++-- | Scroll by a delta in pixels. Deltas accumulate onto a glide already in+-- flight, so repeated calls keep up rather than fighting each other.+scrollBy :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()+scrollBy ctx wid delta behavior =+  withScrollMetrics ctx wid $ \m -> scrollMetricsBy ctx wid m delta behavior++-- | Scroll by whole viewports: @V2 0 1@ is one page down, @V2 0 (-0.5)@ half+-- a page up.+scrollPages :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()+scrollPages ctx wid (V2 px py) behavior =+  withScrollMetrics ctx wid $ \m -> do+    let Rect _ _ vw vh = scrollViewport m+    scrollMetricsBy ctx wid m (V2 (px * vw) (py * vh)) behavior++scrollMetricsBy :: Context -> WidgetId -> ScrollMetrics -> V2 -> ScrollBehavior -> IO ()+scrollMetricsBy ctx wid m (V2 dx dy) behavior = do+  V2 bx by <- scrollTargetOffset ctx wid (scrollOffset m)+  applyScrollTarget ctx wid (scrollAxes m) (clampScrollOffset (scrollRange m) (V2 (bx + dx) (by + dy))) behavior++-- | Scroll back to the top (and left).+scrollToStart :: Context -> WidgetId -> ScrollBehavior -> IO ()+scrollToStart ctx wid = scrollTo ctx wid (V2 0 0)++-- | Scroll to the end of the content.+scrollToEnd :: Context -> WidgetId -> ScrollBehavior -> IO ()+scrollToEnd ctx wid behavior =+  withScrollMetrics ctx wid $ \m ->+    applyScrollTarget ctx wid (scrollAxes m) (scrollRange m) behavior++-- | Scroll @target@ into the viewport of the scroller @wid@ it is built+-- inside. Both widgets are read from the last frame's layout, so a widget+-- that was not built then, such as a row a virtualized list left out, cannot+-- be found; scroll to its content rectangle with 'scrollRectIntoView' instead.+scrollIntoView :: Context -> WidgetId -> WidgetId -> ScrollAlign -> ScrollBehavior -> IO ()+scrollIntoView ctx wid target align behavior = do+  mMetrics <- getScrollMetrics ctx wid+  mRect <- getPrevRect ctx target+  case (mMetrics, mRect) of+    (Just m, Just (Rect rx ry rw rh)) -> do+      let Rect vx vy _ _ = scrollViewport m+          V2 ox oy = scrollOffset m+      scrollRectIntoView ctx wid (Rect (rx - vx + ox) (ry - vy + oy) rw rh) align behavior+    _ -> pure ()++-- | Scroll a rectangle of the content into view. The rectangle is in content+-- coordinates: the origin is where the content starts, which is where the+-- viewport shows it at offset @0@.+scrollRectIntoView :: Context -> WidgetId -> Rect -> ScrollAlign -> ScrollBehavior -> IO ()+scrollRectIntoView ctx wid (Rect rx ry rw rh) align behavior =+  withScrollMetrics ctx wid $ \m -> do+    let Rect _ _ vw vh = scrollViewport m+        V2 ox oy = scrollOffset m+        V2 mx my = scrollRange m+        target =+          V2+            (clamp 0 mx (alignAxis align vw rx rw ox))+            (clamp 0 my (alignAxis align vh ry rh oy))+    applyScrollTarget ctx wid (scrollAxes m) target behavior++-- | Offset that puts a span of the content where @align@ asks for it.+alignAxis :: ScrollAlign -> Float -> Float -> Float -> Float -> Float+alignAxis align viewSize start size cur =+  case align of+    ScrollStart -> start+    ScrollEnd -> start + size - viewSize+    ScrollCenter -> start + (size - viewSize) / 2+    ScrollNearest+      | start < cur -> start+      | start + size > cur + viewSize -> min start (start + size - viewSize)+      | otherwise -> cur++-- | Hold an offset inside @0@ and the scroller's range on each axis.+{-# INLINE clampScrollOffset #-}+clampScrollOffset :: V2 -> V2 -> V2+clampScrollOffset (V2 mx my) (V2 x y) = V2 (clamp 0 mx x) (clamp 0 my y)++-- | Drop the axis a 1D scroller does not move on. A table's paired panes link+-- their cross offsets, so a vertical scroller can carry a horizontal offset it+-- does not own; a glide that watched it would never settle.+{-# INLINE projectAxes #-}+projectAxes :: ScrollAxes -> V2 -> V2+projectAxes axes (V2 x y) =+  case axes of+    ScrollAxisY -> V2 0 y+    ScrollAxisX -> V2 x 0+    ScrollAxisXY -> V2 x y++withScrollMetrics :: Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()+withScrollMetrics ctx wid act = getScrollMetrics ctx wid >>= mapM_ act++-- =============================================================================+-- Glide+-- =============================================================================++-- | Send a scroller to an offset in window axes, gliding if the caller asked+-- for it and the context is tuned for it. The target must already be clamped+-- to the scroller's range.+applyScrollTarget :: Context -> WidgetId -> ScrollAxes -> V2 -> ScrollBehavior -> IO ()+applyScrollTarget ctx wid axes target0 behavior = do+  st <- readIORef (ctxScrollState ctx)+  let smooth = scrollSmoothTime (ssTuning st)+      target = projectAxes axes target0+  if behavior == ScrollInstant || smooth <= 0+    then setScrollOffsetIn ctx wid axes target+    else do+      cur <- getScrollOffsetIn ctx wid axes+      if nearOffset (projectAxes axes cur) target+        then setScrollOffsetIn ctx wid axes target+        else+          writeIORef (ctxScrollState ctx) $!+            st {ssGlides = IM.insert (intKey wid) (ScrollGlide wid target axes) (ssGlides st)}++-- | Where the scroller is headed: the glide's target if one is in flight, and+-- @fallback@ (normally the current offset) if not. Deltas add onto this so+-- that notches arriving mid-glide are not swallowed.+scrollTargetOffset :: Context -> WidgetId -> V2 -> IO V2+scrollTargetOffset ctx wid fallback = do+  st <- readIORef (ctxScrollState ctx)+  pure (maybe fallback sgTarget (IM.lookup (intKey wid) (ssGlides st)))++scrollGliding :: Context -> WidgetId -> IO Bool+scrollGliding ctx wid =+  IM.member (intKey wid) . ssGlides <$> readIORef (ctxScrollState ctx)++-- | Hold a glide in flight inside a range that has just been measured again.+-- Without this a list filtered down mid-glide coasts past its new end and+-- stops there, showing nothing, until something else scrolls it.+clampScrollGlide :: Context -> WidgetId -> V2 -> IO ()+clampScrollGlide ctx wid range =+  modifyIORef' (ctxScrollState ctx) $ \st ->+    if IM.null (ssGlides st)+      then st+      else st {ssGlides = IM.adjust clampGlide (intKey wid) (ssGlides st)}+  where+    clampGlide g = g {sgTarget = projectAxes (sgAxes g) (clampScrollOffset range (sgTarget g))}++cancelScrollGlide :: Context -> WidgetId -> IO ()+cancelScrollGlide ctx wid =+  modifyIORef' (ctxScrollState ctx) $ \st ->+    if IM.null (ssGlides st)+      then st+      else st {ssGlides = IM.delete (intKey wid) (ssGlides st)}++-- | Advance every glide by @dt@ seconds. Each one covers the same fraction of+-- what is left every second, so a long throw starts fast and eases in, and at+-- least a pixel a frame so a glide cannot stall on the pixel grid the offsets+-- snap to.+stepScrollGlides :: Context -> Float -> IO ()+stepScrollGlides ctx dt = do+  st <- readIORef (ctxScrollState ctx)+  unless (IM.null (ssGlides st)) $ do+    let alpha = glideAlpha (scrollSmoothTime (ssTuning st)) dt+    done <- mapM (stepGlide ctx alpha) (IM.toList (ssGlides st))+    let settled = [k | (k, True) <- done]+    unless (null settled) $+      modifyIORef' (ctxScrollState ctx) $ \s ->+        s {ssGlides = foldr IM.delete (ssGlides s) settled}++-- | Fraction of the remaining distance a glide covers in @dt@ seconds.+-- 'scrollSmoothTime' is the time to cover all but a twentieth of it.+glideAlpha :: Float -> Float -> Float+glideAlpha smooth dt+  | smooth <= 0 || dt <= 0 = 1+  | otherwise = clamp 0 1 (1 - exp (negate (3 * dt / smooth)))++stepGlide :: Context -> Float -> (Int, ScrollGlide) -> IO (Int, Bool)+stepGlide ctx alpha (key, ScrollGlide wid target axes) = do+  cur <- projectAxes axes <$> getScrollOffsetIn ctx wid axes+  let next = V2 (stepAxis (v2X cur) (v2X target)) (stepAxis (v2Y cur) (v2Y target))+  writeScrollOffsetIn ctx wid axes next+  pure (key, nearOffset next target)+  where+    stepAxis c t+      | abs (t - c) <= 1 = t+      | otherwise =+          let moved = c + (t - c) * alpha+           in if abs (moved - c) < 1+                then c + signum (t - c)+                else moved++nearOffset :: V2 -> V2 -> Bool+nearOffset (V2 ax ay) (V2 bx by) = abs (ax - bx) <= 0.01 && abs (ay - by) <= 0.01
+ lib/NanoUI/Context/Types.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE StrictData #-}++-- | Record types behind 'Context': interaction, damage, overlay, animation,+-- scroll and drawing-cache state, theme scopes, and frame messages.+module NanoUI.Context.Types+  ( Context (..)+  , MeasureCacheKey+  , MetricSource (..)+  , TextInputMenu (..)+  , TextInputDrag (..)+  , TextFieldClickCell (..)+  , WindowResizeEdge (..)+  , WindowResizeDrag (..)+  , DamageRequest (..)+  , DamageState (..)+  , initialDamageState+  , OverlayState (..)+  , initialOverlayState+  , AnimationState (..)+  , initialAnimationState+  , ScrollTuning (..)+  , defaultScrollTuning+  , ScrollAxes (..)+  , ScrollGlide (..)+  , ScrollState (..)+  , initialScrollState+  , DrawFitCache (..)+  , DrawingEntry (..)+  , DrawingCacheState (..)+  , PopupConfig (..)+  , DrawOpCacheEntry (..)+  , CustomDrawingEntry (..)+  , CustomDrawOpCacheEntry (..)+  , SpanCacheEntry (..)+  , WidgetTextCacheEntry (..)+  , WidgetTextPlacement (..)+  , initialDrawingCacheState+  , InteractionState (..)+  , initialInteractionState+  , CustomMeasureFn+  , CustomDrawContext (..)+  , CustomDrawBuild+  , ThemeScopes (..)+  , FrameMsg (..)+  , decodeMessages+  , reduceMessages+  , reduceUpdates+  , intKey+  ) where++import Data.Dynamic (Dynamic)+import Data.HashMap.Strict (HashMap)+import Data.IORef (IORef)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.IntSet (IntSet)+import Data.IntSet qualified as IS+import Data.Map.Strict (Map)+import Data.Primitive.PrimArray (MutablePrimArray)+import Data.Primitive.SmallArray (SmallArray, SmallMutableArray)+import Data.Word (Word64)+import Data.Text (Text)+import Data.Typeable (TypeRep, Typeable, cast)+import GHC.Exts (RealWorld)++import NanoUI.Animation (Animation)+import NanoUI.Atlas (ImageAtlas)+import NanoUI.Draw.Types (DrawArena, DrawOp, DrawingBuild)+import NanoUI.Font (CustomMeasureFn, FontMetrics)+import NanoUI.Frame.SpanArena (SpanArena)+import NanoUI.Id (IdContext, WidgetId, hashWidgetId)+import NanoUI.Input (UiCursorKind)+import NanoUI.Layout.Arena (DirTag, LayoutCache, NodeArena)+import NanoUI.Store (WidgetStore)+import NanoUI.Style (FontStyle, FontVariant, FontWeight, Layout, Theme)+import NanoUI.Widgets.TextCommand (TextCommand)+import NanoUI.Types+  ( Color+  , Damage (..)+  , DamageBounds+  , PopupAnchor+  , PopupPlacement+  , Rect+  , Size (..)+  , V2+  )++-- | Themes the view's @styled@ scopes pushed this frame, and last frame's, to+-- tell whether a frame changed only how its scopes look. A node's scope holds+-- an index into 'tsThemes' plus one; index 0 is the context theme.+data ThemeScopes = ThemeScopes+  { tsCount :: {-# UNPACK #-} !Int+  , tsThemes :: !(SmallMutableArray RealWorld Theme)+  -- ^ What each scope is drawn with.+  , tsRaw :: !(SmallMutableArray RealWorld Theme)+  -- ^ Each scope's theme before a disabled scope faded it, which nested+  -- @styled@ scopes modify.+  , tsPrevCount :: {-# UNPACK #-} !Int+  , tsPrev :: !(SmallMutableArray RealWorld Theme)+  , tsPrevRaw :: !(SmallMutableArray RealWorld Theme)+  , tsDisabled :: !Bool+  -- ^ A disabled scope was entered this pass, so some widget may be disabled.+  , tsChanged :: !Bool+  -- ^ A pushed theme differs from the one at its index last frame.+  , tsPrevSig :: {-# UNPACK #-} !Word64+  -- ^ Last frame's scope signature ('NanoUI.Layout.Arena.getScopeSignature').+  }++data FrameMsg where+  FrameMsg :: Typeable a => a -> FrameMsg++decodeMessages :: (Foldable f, Typeable a) => f FrameMsg -> [a]+decodeMessages = foldr (\(FrameMsg x) rest -> maybe rest (: rest) (cast x)) []++reduceMessages :: (Foldable f, Typeable msg) => (msg -> model -> model) -> model -> f FrameMsg -> model+reduceMessages update = foldl' (\model (FrameMsg x) -> maybe model (`update` model) (cast x))++reduceUpdates :: (Foldable f, Typeable model) => model -> f FrameMsg -> model+reduceUpdates = reduceMessages ($)++type MeasureCacheKey = (Text, Float)++-- | Identity of a font/measurement configuration. Pure Context modifiers+-- replace this value; the next frame invalidates shared caches if its identity+-- differs. Holding the current inputs (not a revision counter/history) also+-- distinguishes two differently configured Contexts derived from one parent.+data MetricSource+  = InitialMetricSource+  | MetricSource+      !FontMetrics+      !FontMetrics+      !(Text -> IO (Float, Float))+      !(Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool))+      !(Float -> FontWeight -> FontStyle -> FontVariant -> Text -> IO (Float, Float))++-- | Explicit damage invalidation request queued during frame evaluation.+data DamageRequest+  = ReqWidget !WidgetId !DamageBounds      -- ^ Invalidate widget layout bounds (old & new)+  | ReqKey !Int !DamageBounds              -- ^ Invalidate widget bounds by integer key+  | ReqRect !Rect                          -- ^ Invalidate an explicit window-space rectangle+  | ReqPeers ![WidgetId] !DamageBounds     -- ^ Invalidate a collection of widgets+  | ReqFull                                -- ^ Force full window invalidation+  deriving (Eq, Show)++data TextInputMenu = TextInputMenu+  { textInputMenuWidget :: WidgetId+  , textInputMenuRect :: Rect+  }+  deriving (Eq, Show)++data TextInputDrag = TextInputDrag+  { textInputDragWidget :: WidgetId+  , textInputDragAnchor :: {-# UNPACK #-} !Int+  , textInputDragAnchorRow :: {-# UNPACK #-} !Int+  , textInputDragAnchorCol :: {-# UNPACK #-} !Int+  , textInputDragMultiline :: {-# UNPACK #-} !Bool+  , textInputDragClicks :: {-# UNPACK #-} !Int+  }+  deriving (Eq, Show)++data TextFieldClickCell = TextFieldClickCell+  { textFieldClickWidget :: WidgetId+  , textFieldClickFlat :: {-# UNPACK #-} !Int+  , textFieldClickRow :: {-# UNPACK #-} !Int+  , textFieldClickCol :: {-# UNPACK #-} !Int+  , textFieldClickMultiline :: {-# UNPACK #-} !Bool+  }+  deriving (Eq, Show)++data WindowResizeEdge+  = ResizeN+  | ResizeS+  | ResizeE+  | ResizeW+  | ResizeNE+  | ResizeNW+  | ResizeSE+  | ResizeSW+  deriving (Eq, Show)++data WindowResizeDrag = WindowResizeDrag+  { wrdWidget :: WidgetId+  , wrdEdge :: WindowResizeEdge+  , wrdGrabX :: {-# UNPACK #-} !Float+  , wrdGrabY :: {-# UNPACK #-} !Float+  , wrdStartX :: {-# UNPACK #-} !Float+  , wrdStartY :: {-# UNPACK #-} !Float+  , wrdStartW :: {-# UNPACK #-} !Float+  , wrdStartH :: {-# UNPACK #-} !Float+  , wrdMinW :: {-# UNPACK #-} !Float+  , wrdMinH :: {-# UNPACK #-} !Float+  , wrdMaxW :: {-# UNPACK #-} !Float+  , wrdMaxH :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++data DamageState = DamageState+  { dsDirty :: !Bool+  , dsDamage :: !Damage+  , dsRequests :: ![DamageRequest]+  , dsLastWindowSize :: !Size+  , dsPrevRects :: !(IntMap Rect)+  , dsPrevClips :: !(IntMap Rect)+  , dsPrevNodeTexts :: !(IntMap Text)+  }++initialDamageState :: DamageState+initialDamageState = DamageState+  { dsDirty = True+  , dsDamage = DamageFull+  , dsRequests = []+  , dsLastWindowSize = Size 0 0+  , dsPrevRects = IM.empty+  , dsPrevClips = IM.empty+  , dsPrevNodeTexts = IM.empty+  }++data OverlayState = OverlayState+  { osModalWasActive :: {-# UNPACK #-} !Bool+  , osModalActive :: {-# UNPACK #-} !Bool+  , osModalDepth :: {-# UNPACK #-} !Int+  , osEscapeConsumed :: {-# UNPACK #-} !Bool+  , osPrevFloatingRects :: !(IntMap Rect)+  , osPrevFloatingOrder :: ![Int]+  , osTopmostCache :: !(Maybe (V2, Maybe WidgetId))+  , osCurrentFloatingId :: !(Maybe WidgetId)+  , osLastPointerBlocked :: {-# UNPACK #-} !Bool+  }++initialOverlayState :: OverlayState+initialOverlayState = OverlayState+  { osModalWasActive = False+  , osModalActive = False+  , osModalDepth = 0+  , osEscapeConsumed = False+  , osPrevFloatingRects = IM.empty+  , osPrevFloatingOrder = []+  , osTopmostCache = Nothing+  , osCurrentFloatingId = Nothing+  , osLastPointerBlocked = False+  }++data AnimationState = AnimationState+  { asAnimations :: !(IntMap Animation)+  , asAnimRest :: !(IntMap Float)+  , asAnyAnimating :: {-# UNPACK #-} !Bool+  , asAnimSettled :: {-# UNPACK #-} !Bool+  , asRectless :: !(IntMap Int)+  }++initialAnimationState :: AnimationState+initialAnimationState = AnimationState+  { asAnimations = IM.empty+  , asAnimRest = IM.empty+  , asAnyAnimating = False+  , asAnimSettled = False+  , asRectless = IM.empty+  }++-- | How far one wheel notch scrolls, and how long a scroll takes to settle.+-- One setting for the whole context; a single scroller can take its own step+-- (see @setScrollStep@).+data ScrollTuning = ScrollTuning+  { scrollWheelStep :: Float+  -- ^ Pixels one wheel notch scrolls. The default is three text lines, which+  -- is what Windows and most desktops send a notch as.+  , scrollSmoothTime :: Float+  -- ^ Seconds a scroll takes to cover most of the distance to its target.+  -- @0@ (the default) lands on it in the same frame.+  }+  deriving (Eq, Show)++defaultScrollTuning :: ScrollTuning+defaultScrollTuning =+  ScrollTuning+    { scrollWheelStep = 60+    , scrollSmoothTime = 0+    }++-- | Which axes a scroller moves on, and how an offset in window axes (x+-- rightwards, y downwards) maps onto its stored offset. A 1D row scroller+-- keeps its offset in the main-axis slot, so its horizontal offset is the one+-- that needs swapping.+data ScrollAxes+  = ScrollAxisY+  | ScrollAxisX+  | ScrollAxisXY+  deriving (Eq, Show)++-- | A scroller on its way to an offset it has not reached yet. The target is+-- in window axes and already clamped to the scroller's range.+data ScrollGlide = ScrollGlide+  { sgWidget :: WidgetId+  , sgTarget :: V2+  , sgAxes :: ScrollAxes+  }+  deriving (Eq, Show)++data ScrollState = ScrollState+  { ssTuning :: !ScrollTuning+  , ssGlides :: !(IntMap ScrollGlide)+  , ssCached :: !IntSet+  -- ^ Scrollers whose geometry has been published this frame. Two scroll+  -- nodes can share a widget id (a table's frozen pane and its body), and+  -- without this the second would overwrite the first every frame, churning+  -- the store and flipping the geometry the commands read.+  }++initialScrollState :: ScrollState+initialScrollState =+  ScrollState+    { ssTuning = defaultScrollTuning+    , ssGlides = IM.empty+    , ssCached = IS.empty+    }++data DrawFitCache = DrawFitCache+  { dfcDw :: {-# UNPACK #-} !Double+  , dfcDh :: {-# UNPACK #-} !Double+  , dfcLh :: {-# UNPACK #-} !Float+  , dfcContent :: {-# UNPACK #-} !Int+  , dfcIn :: !Layout+  , dfcOut :: !Layout+  }++-- | Cached text-span layout for one arena node. Key fields are every input+-- that changes the produced spans; 'sceSpans' is the shared result. The whole+-- cache is dropped on theme or font-scale changes.+data SpanCacheEntry = SpanCacheEntry+  { sceText :: !Text+  , sceFg :: {-# UNPACK #-} !Color+  , sceBg :: {-# UNPACK #-} !Color+  , sceStyle :: {-# UNPACK #-} !Int+  , sceFontSize :: {-# UNPACK #-} !Float+  , sceAlign :: {-# UNPACK #-} !Int+  , sceWidthTag :: {-# UNPACK #-} !Int+  , sceRect :: !Rect+  , sceEffMaxW :: {-# UNPACK #-} !Float+  , sceRowChild :: {-# UNPACK #-} !Bool+  , sceSpans :: ![(Rect, Text, Color, Color)]+  }++-- | A cacheable widget label is a single line (or absent for close buttons).+-- Coordinates are relative to the node origin; paint translates them without+-- rebuilding a list or invalidating the cache when a widget scrolls.+data WidgetTextPlacement = WidgetTextPlacement+  !Text+  {-# UNPACK #-} !Float+  {-# UNPACK #-} !Float+  {-# UNPACK #-} !Float+  {-# UNPACK #-} !Float++data WidgetTextCacheEntry = WidgetTextCacheEntry+  { wtcNodeType :: {-# UNPACK #-} !Int+  , wtcStyle :: {-# UNPACK #-} !Int+  , wtcFontSize :: {-# UNPACK #-} !Float+  , wtcText :: !Text+  , wtcWidth :: {-# UNPACK #-} !Float+  , wtcHeight :: {-# UNPACK #-} !Float+  , wtcAlign :: {-# UNPACK #-} !Int+  , wtcPlacement :: {-# NOUNPACK #-} !(Maybe WidgetTextPlacement)+  }++data CustomDrawContext = CustomDrawContext+  { cdcHovered  :: {-# UNPACK #-} !Bool+  , cdcPressed  :: {-# UNPACK #-} !Bool+  , cdcFocused  :: {-# UNPACK #-} !Bool+  , cdcActive   :: {-# UNPACK #-} !Bool+  , cdcDisabled :: {-# UNPACK #-} !Bool+  , cdcTheme    :: !Theme+  , cdcFont     :: !FontMetrics+  }++type CustomDrawBuild = CustomDrawContext -> Rect -> SmallArray DrawOp++-- | A registered custom drawing: its content key plus the op builder. A+-- non-zero key is the author's promise that the ops follow it, so a frame+-- whose key is unchanged neither rebuilds nor repaints them. Key 0 means the+-- drawing carries no key and is rebuilt every frame and compared.+data CustomDrawingEntry = CustomDrawingEntry+  { cdrContent :: {-# UNPACK #-} !Int+  , cdrBuild :: !CustomDrawBuild+  }++-- | A registered drawing: content version plus the op builder. The version+-- participates in the draw-op cache key, so a builder whose output changes+-- without its size changing must bump the version to invalidate.+data DrawingEntry = DrawingEntry+  { deContent :: {-# UNPACK #-} !Int+  , deBuild :: !DrawingBuild+  }++data DrawingCacheState = DrawingCacheState+  { dcsPopupConfigs :: !(IntMap PopupConfig)+  , dcsDrawings :: !(IntMap DrawingEntry)+  , dcsCustomDrawings :: !(IntMap CustomDrawingEntry)+  , dcsCustomMeasures :: !(IntMap CustomMeasureFn)+  , dcsCustomCursors :: !(IntMap (CustomDrawContext -> UiCursorKind))+  , dcsCustomDamageSlop :: !(IntMap Float)+  , dcsDrawOpCache :: !(IntMap DrawOpCacheEntry)+  , dcsCustomDrawOpCache :: !(IntMap CustomDrawOpCacheEntry)+  , dcsDrawFitCache :: !(IntMap DrawFitCache)+  }++-- | Strict cache entry for a popup's anchor configuration.+data PopupConfig = PopupConfig+  { pcAnchor :: !PopupAnchor+  , pcPlacement :: !PopupPlacement+  , pcOffset :: {-# UNPACK #-} !Float+  }++-- | Strict cache entry for a drawing's compiled draw ops.+data DrawOpCacheEntry = DrawOpCacheEntry+  { doeContent :: {-# UNPACK #-} !Int+  , doeBounds :: !Rect+  , doeOps :: !(SmallArray DrawOp)+  }++-- | Strict cache entry for a custom drawing's compiled draw ops. Every input+-- the ops can depend on is part of the key: the content key, the rect, the+-- interaction state the draw context exposes, and the metric generation, which+-- a theme or font change bumps.+data CustomDrawOpCacheEntry = CustomDrawOpCacheEntry+  { cdeContent :: {-# UNPACK #-} !Int+  , cdeBounds :: !Rect+  , cdeHovered :: {-# UNPACK #-} !Bool+  , cdePressed :: {-# UNPACK #-} !Bool+  , cdeFocused :: {-# UNPACK #-} !Bool+  , cdeDisabled :: {-# UNPACK #-} !Bool+  , cdeGen :: {-# UNPACK #-} !Int+  , cdeOps :: !(SmallArray DrawOp)+  }++initialDrawingCacheState :: DrawingCacheState+initialDrawingCacheState = DrawingCacheState+  { dcsPopupConfigs = IM.empty+  , dcsDrawings = IM.empty+  , dcsCustomDrawings = IM.empty+  , dcsCustomMeasures = IM.empty+  , dcsCustomCursors = IM.empty+  , dcsCustomDamageSlop = IM.empty+  , dcsDrawOpCache = IM.empty+  , dcsCustomDrawOpCache = IM.empty+  , dcsDrawFitCache = IM.empty+  }++data InteractionState = InteractionState+  { isScrollDrag :: !(Maybe (WidgetId, DirTag, Float))+  , isTextInputDrag :: !(Maybe TextInputDrag)+  , isTextFieldClickCell :: !(Maybe TextFieldClickCell)+  , isTextInputMenu :: !(Maybe TextInputMenu)+  , isTextEditLastAction :: !(Maybe (WidgetId, TextCommand))+  , isSelectDropPress :: {-# UNPACK #-} !Bool+  , isOpenSelectDrop :: !(Maybe (WidgetId, Rect))+  , isMenuPointerGesture :: {-# UNPACK #-} !Bool+  , isWindowDrag :: !(Maybe (WidgetId, Float, Float))+  , isWindowResize :: !(Maybe WindowResizeDrag)+  }+  deriving (Eq, Show)++initialInteractionState :: InteractionState+initialInteractionState = InteractionState+  { isScrollDrag = Nothing+  , isTextInputDrag = Nothing+  , isTextFieldClickCell = Nothing+  , isTextInputMenu = Nothing+  , isTextEditLastAction = Nothing+  , isSelectDropPress = False+  , isOpenSelectDrop = Nothing+  , isMenuPointerGesture = False+  , isWindowDrag = Nothing+  , isWindowResize = Nothing+  }++data Context = Context+  { ctxNodeArena :: NodeArena+  , ctxDrawArena :: DrawArena+  , ctxHotId :: IORef WidgetId+  , ctxLastHotId :: IORef WidgetId+  , ctxActiveId :: IORef WidgetId+  , ctxClickedId :: IORef WidgetId+  , ctxReleaseClickedId :: IORef WidgetId+  -- | Where the held left and right buttons went down, cleared when they come+  -- up. A click belongs to the widget the press landed on, so a widget+  -- hit-tests this point as well as the release point. 'Nothing' (a release+  -- with no press behind it) lets the release stand on its own.+  , ctxPressPos :: IORef (Maybe V2)+  , ctxRightPressPos :: IORef (Maybe V2)+  , ctxFocusId :: IORef WidgetId+  -- | Focus last moved by keyboard, so the focused widget shows its ring. A+  -- pointer press hides it again.+  , ctxFocusVisible :: IORef Bool+  , ctxStore :: IORef WidgetStore+  , ctxDamageState :: IORef DamageState+  , ctxOverlayState :: IORef OverlayState+  , ctxAnimationState :: IORef AnimationState+  , ctxScrollState :: !(IORef ScrollState)+  , ctxDrawingCache :: IORef DrawingCacheState+  , ctxIdContext :: IORef IdContext+  , ctxFontMetrics :: FontMetrics+  , ctxMonoFontMetrics :: FontMetrics+  , ctxMeasureText :: Text -> IO (Float, Float)+  , ctxResolveFont :: !(Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool))+  , ctxResolveMeasure :: !(Float -> FontWeight -> FontStyle -> FontVariant -> Text -> IO (Float, Float))+  , ctxMeasureCache :: Maybe (IORef (HashMap MeasureCacheKey (Float, Float)))+  , ctxSpanCache :: !(IORef (IntMap SpanCacheEntry))+  , ctxWidgetTextCache :: !(IORef (IntMap WidgetTextCacheEntry))+  -- Whole-layout reuse cache (Phase 5A): cached signature + solved rects,+  -- with the window size and font/theme generation it was captured under.+  , ctxLayoutCache :: !(IORef (Maybe (LayoutCache, Size, Int)))+  , ctxMetricGen :: !(IORef Int)+  , ctxMetricSource :: {-# NOUNPACK #-} !MetricSource+  , ctxLastMetricSource :: !(IORef (Maybe MetricSource))+  -- True when the next present must repaint the whole window (fresh retain+  -- texture, forced full, continuous present, or window expose). When False,+  -- a DamageClip frame culls the paint pass to the damaged region.+  , ctxPaintFull :: !(IORef Bool)+  , ctxExternalText :: Bool+  , ctxTheme :: !(IORef Theme)+  , ctxThemeScopes :: !(IORef ThemeScopes)+  , ctxContainerStack :: IORef [Int]+  , ctxMessages :: IORef [FrameMsg]+  , ctxFocusables :: IORef (MutablePrimArray RealWorld WidgetId)+  , ctxFocusablesCount :: IORef Int+  , ctxSpanBase :: SpanArena+  , ctxSpanOverlay :: SpanArena+  , ctxInteractionState :: !(IORef InteractionState)+  , ctxClipboardGet :: IO (Maybe Text)+  , ctxClipboardSet :: Text -> IO Bool+  , ctxImageAtlas :: ImageAtlas+  , ctxWakeLoop :: IORef (Maybe (IO ()))+  , ctxHost :: IORef (Map TypeRep Dynamic)+  , ctxDefaultLayout :: IORef Layout+  }++{-# INLINE intKey #-}+intKey :: WidgetId -> Int+intKey = fromIntegral . hashWidgetId
+ lib/NanoUI/Damage.hs view
@@ -0,0 +1,704 @@+module NanoUI.Damage+  ( updatePrevRects+  , floatingPanelRects+  , FrameSnapshot (..)+  , writeDamage+  ) where++import Control.Monad (forM_, join, unless, when)+import Data.IORef (readIORef)+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.Maybe (fromMaybe, isJust)+import Data.Primitive.PrimArray (MutablePrimArray, newPrimArray, readPrimArray, writePrimArray)+import Data.Text (Text)+import GHC.Exts (RealWorld)+import NanoUI.Context+  ( Animation+  , Context (..)+  , DamageRequest (..)+  , WidgetStore (..)+  , getHotId+  , getLiveAnimations+  , getAnimRest+  , pruneAnimRest+  , getAnimRectless+  , getPrevRect+  , getStore+  , getWindowDrag+  , getWindowResize+  , intKey+  , markDirty+  , modalDamageFlip+  , setAnimRectless+  , takeAnimSettled+  , lookupCustomDamageSlop+  , lookupCustomDrawing+  , lookupDrawing+  , refreshCustomDrawingOps+  , drawingOpsStale+  , CustomDrawingEntry (..)+  , DrawingEntry (..)+  , DamageState (..)+  , OverlayState (..)+  , getsDamage+  , modifyDamage+  , modifyOverlay+  )+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input+  ( Input (..)+  , inputWindowSize+  )+import NanoUI.Frame.Hit (findNodeByKey)+import NanoUI.Store (eqByPtr, mirrorStoresChanged, ptrEq, slotKey, Slot (..))+import NanoUI.Layout.Arena+  ( NodeArena+  , NodeType (..)+  , SizingTag (..)+  , arenaCount+  , foldNodeRevM+  , getClipRect+  , getHeightSizing+  , getNodeType+  , getParent+  , getRect+  , getStyleIdx+  , getText+  , getWidgetId+  , getWidthSizing+  , isFloatingNode+  , isScrollNode+  )+import NanoUI.Frame.Scroll.Geometry (decodeScrollConfig, scrollBare)+import NanoUI.Widgets.Custom (mkCustomDrawContext)+import NanoUI.Types+  ( Damage (..)+  , Rect (..)+  , Size (..)+  , defaultDamageSlop+  , rectArea+  , rectFullyInside+  , rectInflate+  , rectIntersect+  , rectNonEmpty+  , rectUnion+  , resolveDamageRect+  )++layoutSettleMinArea :: Float+layoutSettleMinArea = 0.25++-- | Bound on how many consecutive rect-less frames a live animation may force a+-- full-window repaint. An animation whose widget is about to be laid out for the+-- first time gets a couple of frames of DamageFull cover; a perpetual animation+-- whose widget has left the arena (e.g. `keepAnimating` behind a tab switch)+-- must stop repainting the whole window once it is clearly gone.+orphanEscalateFrames :: Int+orphanEscalateFrames = 2++-- Partial retain clears with themeWindow. Expand interaction clips to the painted+-- panel/window backdrop so slop pixels get the correct fill, not window color.+backdropRectFromNode :: Context -> Int -> IO (Maybe Rect)+backdropRectFromNode ctx idx = walkAncestors step (ctxNodeArena ctx) idx+  where+    step i = do+      let na = ctxNodeArena ctx+      nt <- getNodeType na i+      if nt == NodePanel || isFloatingNode nt+        then getNonzeroRect na i+        else case nt of+          NodeScrollContainer -> do+            (wTag, _) <- getWidthSizing na i+            (hTag, _) <- getHeightSizing na i+            si <- getStyleIdx na i+            if (wTag == SizingGrow && hTag == SizingGrow) || scrollBare (decodeScrollConfig si)+              then pure Nothing+              else getNonzeroRect na i+          _ -> pure Nothing++{-# INLINE walkAncestors #-}+walkAncestors :: (Int -> IO (Maybe a)) -> NodeArena -> Int -> IO (Maybe a)+walkAncestors step arena idx = loop idx+  where+    loop i+      | i < 0 = pure Nothing+      | otherwise = do+          mr <- step i+          case mr of+            Just x -> pure (Just x)+            Nothing -> getParent arena i >>= loop++{-# INLINE getNonzeroRect #-}+getNonzeroRect :: NodeArena -> Int -> IO (Maybe Rect)+getNonzeroRect arena i = do+  (x, y, w, h) <- getRect arena i+  let r = Rect x y w h+  pure (if rectNonEmpty r then Just r else Nothing)++updatePrevRects :: Context -> IO ()+updatePrevRects ctx = do+  live <- getLiveAnimations ctx+  prevRectless <- getAnimRectless ctx+  oldRects <- getsDamage ctx dsPrevRects+  oldClips <- getsDamage ctx dsPrevClips+  oldTexts <- getsDamage ctx dsPrevNodeTexts+  let na = ctxNodeArena ctx+      bump rects = do+        rest <- getAnimRest ctx+        let rectless' =+              IM.fromSet+                (\k -> if IM.member k rects then 0 else IM.findWithDefault 0 k prevRectless + 1)+                (IM.keysSet live <> IM.keysSet rest)+            deadRest = IM.filterWithKey (\k _ -> IM.findWithDefault 0 k rectless' > 300) rest+        unless (IM.null deadRest) $+          pruneAnimRest ctx (\k -> IM.notMember k deadRest)+        -- Every key is live or resting, so this drops exactly the dead resting+        -- keys that are not live again.+        setAnimRectless ctx (rectless' `IM.difference` (deadRest `IM.difference` live))+  count <- arenaCount na+  if count <= 0+    then do+      modifyDamage ctx (\ds -> ds {dsPrevRects = IM.empty, dsPrevClips = IM.empty, dsPrevNodeTexts = IM.empty})+      bump IM.empty+    else do+      -- Walk the arena from base maps, touching only entries whose value+      -- changed. Seeded with last frame's maps, frames with stable rects+      -- (hover, text churn, animations) allocate nothing. The walk cannot+      -- delete keys that vanished from the arena, so when the key set changed+      -- it reruns from empty maps, where no key counts as old.+      let go olds !i !m !cm !tm !foundOld !dropped+            | i >= count =+                if dropped || foundOld /= IM.size olds+                  then go IM.empty 0 IM.empty IM.empty IM.empty 0 False+                  else do+                    modifyDamage ctx (\ds -> ds {dsPrevRects = m, dsPrevClips = cm, dsPrevNodeTexts = tm})+                    bump m+            | otherwise = do+                wid <- getWidgetId na i+                if hashWidgetId wid == 0+                  then go olds (i + 1) m cm tm foundOld dropped+                  else do+                    let !k = intKey wid+                        isOld = IM.member k olds+                    mRect <- getNonzeroRect na i+                    case mRect of+                      Nothing ->+                        let dropped' = dropped || isOld+                            m' = if isOld then IM.delete k m else m+                            cm' = if IM.member k cm then IM.delete k cm else cm+                            tm' = if IM.member k tm then IM.delete k tm else tm+                         in go olds (i + 1) m' cm' tm' foundOld dropped'+                      Just r -> do+                        mClip <- getClipRect na i+                        nt <- getNodeType na i+                        let !m' = if IM.lookup k m == Just r then m else IM.insert k r m+                            !cm' = case mClip of+                              Just c -> if IM.lookup k cm == Just c then cm else IM.insert k c cm+                              Nothing -> if IM.member k cm then IM.delete k cm else cm+                        -- Text nodes, and images, whose text is their image+                        -- id: switching an image repaints it like new text.+                        tm' <-+                          if nt == NodeText || nt == NodeImage+                            then do+                              txt <- getText na i+                              pure $! if IM.lookup k tm == Just txt then tm else IM.insert k txt tm+                            else pure $! if IM.member k tm then IM.delete k tm else tm+                        go olds (i + 1) m' cm' tm' (foundOld + if isOld then 1 else 0) dropped+      go oldRects 0 oldRects oldClips oldTexts 0 False++floatingPanelsInOrder :: Context -> IO [(Int, Rect)]+floatingPanelsInOrder ctx = foldNodeRevM na step []+  where+    na = ctxNodeArena ctx+    step acc idx = do+      nt <- getNodeType na idx+      if not (isFloatingNode nt)+        then pure acc+        else do+          wid <- getWidgetId na idx+          if hashWidgetId wid == 0+            then pure acc+            else do+              (x, y, w, h) <- getRect na idx+              pure ((intKey wid, Rect x y w h) : acc)++floatingPanelRects :: Context -> IO (IM.IntMap Rect)+floatingPanelRects ctx = IM.fromList <$> floatingPanelsInOrder ctx++-- | State 'NanoUI.Frame' captures before the UI pass; 'writeDamage' compares+-- it against the finished frame.+data FrameSnapshot = FrameSnapshot+  { fsWasDirty :: !Bool+  , fsSize :: !Size+  , fsStore :: !WidgetStore+  , fsHot :: !WidgetId+  , fsActive :: !WidgetId+  , fsFocus :: !WidgetId+  , fsHotRect :: !(Maybe Rect)+  , fsActiveRect :: !(Maybe Rect)+  , fsFocusRect :: !(Maybe Rect)+  , fsFloatingRects :: !(IM.IntMap Rect)+  , fsRects :: !(IM.IntMap Rect)+  , fsTexts :: !(IM.IntMap Text)+  , fsAnimKeys :: !IS.IntSet+  }++-- | What the finished frame looks like and what changed since the snapshot.+-- Derived fields stay lazy: a frame that is already 'DamageFull' for a cheap+-- reason never pays for them.+data FrameDelta = FrameDelta+  { fdWinSize :: !Size+  , fdOverlayOpen :: !Bool+  , fdStore :: !WidgetStore+  , fdRects :: !(IM.IntMap Rect)+  , fdTexts :: !(IM.IntMap Text)+  , fdFloatingRects :: !(IM.IntMap Rect)+  , fdModalFlip :: !Bool+  , fdLiveAnims :: !(IM.IntMap Animation)+  , fdRectless :: !(IM.IntMap Int)+  , fdWindowLive :: !Bool+  , fdRequests :: ![DamageRequest]+  , fdAnimLive :: Bool+  , fdFloatingChanged :: Bool+  , fdScrollChanged :: Bool+  , fdPointsChanged :: Bool+  , fdScrollOnly :: Bool+  -- ^ Only 'storeFloat' changed in the store, e.g. a floating pane scrolled.+  , fdSettledMoved :: !RectGroup+  -- ^ Changed key rects, clipped to their scroll viewports, that cover some+  -- area.+  , fdChurn :: !RectGroup+  -- ^ Rects of keys that left or joined the arena.+  , fdRedrawn :: ![Int]+  -- ^ Keys of drawings whose ops changed at an unchanged rect.+  }++writeDamage :: Context -> Input -> Bool -> FrameSnapshot -> IO ()+writeDamage ctx inp overlayOpen snap = do+  newStore <- getStore ctx+  panels <- floatingPanelsInOrder ctx+  newRects <- getsDamage ctx dsPrevRects+  newTexts <- getsDamage ctx dsPrevNodeTexts+  modalFlip <- modalDamageFlip ctx+  liveAnims <- getLiveAnimations ctx+  settled <- takeAnimSettled ctx+  rectless <- getAnimRectless ctx+  winDragActive <- isJust <$> getWindowDrag ctx+  winResizeActive <- isJust <$> getWindowResize ctx+  requests <- getsDamage ctx dsRequests+  redrawn <- refreshCustomDrawings ctx+  let oldRects = fsRects snap+      oldStore = fsStore snap+      newFloatingRects = IM.fromList panels+  (settledMoved, churn) <- rectDeltas ctx (map snd panels) oldRects newRects+  let scrollChanged = not (eqByPtr (storeFloat oldStore) (storeFloat newStore))+      delta =+        FrameDelta+          { fdWinSize = inputWindowSize inp+          , fdOverlayOpen = overlayOpen+          , fdStore = newStore+          , fdRects = newRects+          , fdTexts = newTexts+          , fdFloatingRects = newFloatingRects+          , fdModalFlip = modalFlip+          , fdLiveAnims = liveAnims+          , fdRectless = rectless+          , fdWindowLive = winDragActive || winResizeActive+          , fdRequests = requests+          , fdAnimLive = not (IM.null liveAnims) || settled+          , fdFloatingChanged = fsFloatingRects snap /= newFloatingRects+          , fdScrollChanged = scrollChanged+          , fdPointsChanged = not (eqByPtr (storePoint oldStore) (storePoint newStore))+          , fdScrollOnly =+              scrollChanged && oldStore == newStore {storeFloat = storeFloat oldStore}+          , fdSettledMoved = settledMoved+          , fdChurn = churn+          , fdRedrawn = redrawn+          }+  dmg <-+    if needsFullDamage snap delta+      then pure DamageFull+      else clipDamage ctx snap delta+  modifyDamage ctx (\ds -> ds {dsDamage = dmg, dsLastWindowSize = inputWindowSize inp, dsRequests = []})+  modifyOverlay ctx (\os -> os {osPrevFloatingRects = newFloatingRects, osPrevFloatingOrder = map fst panels})+  when modalFlip (markDirty ctx)+  when (fdFloatingChanged delta && not (IM.null (fsFloatingRects snap) && not (IM.null newFloatingRects))) $+    markDirty ctx++-- | Settle every drawing's ops for this frame and return the keys of those+-- that now draw something else at an unchanged rect. A drawing follows state+-- the arena does not hold, so nothing else damages it, and paint must not+-- replay the previous frame's ops for it. What this costs per widget is the+-- widget's own choice: see 'refreshCustomDrawingOps'.+refreshCustomDrawings :: Context -> IO [Int]+refreshCustomDrawings ctx = arenaCount na >>= \count -> go count 0 []+  where+    na = ctxNodeArena ctx+    go count !i acc+      | i >= count = pure acc+      | otherwise = do+          nt <- getNodeType na i+          if nt /= NodeDrawing+            then go count (i + 1) acc+            else do+              wid <- getWidgetId na i+              (x, y, w, h) <- getRect na i+              let rect = Rect x y w h+              mCustom <- lookupCustomDrawing ctx wid+              changed <- case mCustom of+                Just (CustomDrawingEntry content build) -> do+                  cdc <- mkCustomDrawContext ctx (ctxFontMetrics ctx) wid+                  refreshCustomDrawingOps ctx wid content rect cdc build+                Nothing -> do+                  -- A versioned drawing rebuilds in paint once its version+                  -- changes, but the pixels it covered still need damage. An+                  -- unversioned one is cached by contract, so it stays put.+                  mDrawing <- lookupDrawing ctx wid+                  case mDrawing of+                    Just (DrawingEntry content _) | content /= 0 -> drawingOpsStale ctx wid content rect+                    _ -> pure False+              go count (i + 1) (if changed then intKey wid : acc else acc)++-- | Whether the frame repaints the whole window rather than a clip.+needsFullDamage :: FrameSnapshot -> FrameDelta -> Bool+needsFullDamage snap d =+  ReqFull `elem` fdRequests d+    || not (fdScrollOnly d)+      && ( fsWasDirty snap+             || mirrorStoresChanged (fsStore snap) (fdStore d)+             || sizeChanged+             || fdOverlayOpen d+             || fdModalFlip d+             || fdFloatingChanged d+             || fdWindowLive d+             || (orphanAnim && fdAnimLive d)+             || keysChanged+             || layoutSettle+         )+    || (missingAnim && fdAnimLive d)+  where+    oldRects = fsRects snap+    newRects = fdRects d+    oldSize = fsSize snap+    sizeChanged = oldSize /= Size 0 0 && oldSize /= fdWinSize d+    recentlyRectless k = IM.findWithDefault 0 k (fdRectless d) < orphanEscalateFrames+    orphanAnim =+      any (\k -> IM.notMember k newRects && recentlyRectless k) (IM.keys (fdLiveAnims d))+    -- A live animation whose key has no rect this frame or last is not+    -- clipped: the retain texture may never have shown it.+    missingAnim =+      any+        (\k -> k /= 0 && IM.notMember k oldRects && IM.notMember k newRects && recentlyRectless k)+        (IS.toList (fsAnimKeys snap <> IM.keysSet (fdLiveAnims d)))+    keysChanged =+      not (IM.null oldRects)+        && rgAny (fdChurn d)+        && not (rgInPanels (fdChurn d))+    layoutSettle =+      not (IM.null oldRects)+        && rgAny (fdSettledMoved d)+        && not (fdAnimLive d)+        && not (fdScrollChanged d)+        && not (rgInPanels (fdSettledMoved d))++-- | The clip covering everything that changed, or 'DamageFull' once that clip+-- exceeds half the window.+clipDamage :: Context -> FrameSnapshot -> FrameDelta -> IO Damage+clipDamage ctx snap d = do+  let oldRects = fsRects snap+      newRects = fdRects d+      Size winW winH = fdWinSize d+      oldOf wid+        | wid == fsHot snap = fsHotRect snap+        | wid == fsActive snap = fsActiveRect snap+        | wid == fsFocus snap = fsFocusRect snap+        | otherwise = Nothing+  acc <- newRectUnion+  resolveDamageRequests ctx acc oldRects newRects (fdRequests d)+  -- Backdrop expansion covers interaction slop (hover/press halos) and+  -- explicit damage requests. Animation keys must not expand to their panel+  -- backdrop: an animated widget inside a large panel would damage the whole+  -- panel every frame, and once that union crosses half the window the frame+  -- degrades to DamageFull. The scissored replay redraws the backdrop fill+  -- inside the anim's own rect+slop, so no stale pixels remain.+  let addBackdrop k =+        unless (k == 0) $+          findNodeByKey ctx k+            >>= maybe (pure Nothing) (backdropRectFromNode ctx)+            >>= mapM_ (addRect acc . clipRectToWindow winW winH)+      addInteraction wid = do+        when (hashWidgetId wid /= 0) $ do+          newR <- getPrevRect ctx wid+          slop <- fromMaybe defaultDamageSlop <$> lookupCustomDamageSlop ctx wid+          let addSide = mapM_ (\r -> clipKeyRect ctx (intKey wid) (rectInflate slop r) >>= mapM_ (addRect acc))+          addSide (oldOf wid)+          addSide newR+        addBackdrop (intKey wid)+      -- A parked pointer must not re-damage its hot widget every frame: only+      -- an id change (hover in/out, press, focus move) or a rect move+      -- repaints. Unchanged interaction rects kept the steady state at+      -- DamageFull whenever the hot widget sat inside a panel whose backdrop+      -- covered over half the window.+      role oldW oldR newW = do+        newR <- getPrevRect ctx newW+        when (oldR /= newR) $ addInteraction oldW >> addInteraction newW+  role (fsHot snap) (fsHotRect snap) =<< getHotId ctx+  role (fsActive snap) (fsActiveRect snap) =<< readIORef (ctxActiveId ctx)+  role (fsFocus snap) (fsFocusRect snap) =<< readIORef (ctxFocusId ctx)+  forM_ (fdRequests d) $ \case+    ReqKey k _ -> addBackdrop k+    _ -> pure ()+  when (fdScrollChanged d || fdPointsChanged d) $+    scrollOffsetDamage ctx acc (fsStore snap) (fdStore d)+  let addAnim k =+        unless (k == 0) $+          forM_ [IM.lookup k oldRects, IM.lookup k newRects] $+            mapM_ (\r -> clipKeyRect ctx k (rectInflate defaultDamageSlop r) >>= mapM_ (addRect acc))+  IS.foldr (\k rest -> addAnim k >> rest) (pure ()) (fsAnimKeys snap)+  IM.foldrWithKey+    (\k _ rest -> unless (IS.member k (fsAnimKeys snap)) (addAnim k) >> rest)+    (pure ())+    (fdLiveAnims d)+  -- Same-key text changes that keep the rect (monospace counters, refreshed+  -- readouts) still repaint: rect-delta damage alone would leave them stale.+  -- New text keys inside floating panels also land here; outside panels the+  -- keysChanged predicate already forces full damage. updatePrevRects keeps+  -- last frame's map when no text changed.+  let addText k =+        forM_ (IM.lookup k newRects) $ \r -> do+          -- An image that switched to another image keeps its size, so only+          -- its own rect repaints. A text change can reflow the enclosing+          -- scroller's content and reactivate/resize its chrome (thumb, caps)+          -- outside the text rect; damage the scroll node's full rect so the+          -- lane repaints.+          addRect acc r+          mIdx <- findNodeByKey ctx k+          isImage <- maybe (pure False) (fmap (== NodeImage) . getNodeType (ctxNodeArena ctx)) mIdx+          unless isImage $ scrollAncestorRect ctx k >>= mapM_ (addRect acc)+  unless (ptrEq (fdTexts d) (fsTexts snap)) $+    IM.foldrWithKey (\k _ rest -> addText k >> rest) (pure ()) $+      IM.mergeWithKey+        (\_ new old -> if new /= old then Just () else Nothing)+        (IM.map (const ()))+        (const IM.empty)+        (fdTexts d)+        (fsTexts snap)+  -- Drawings redrawn in place repaint their own rects, like a text change+  -- that keeps its rect.+  forM_ (fdRedrawn d) $ \k ->+    forM_ (IM.lookup k newRects) $ \r -> clipKeyRect ctx k r >>= mapM_ (addRect acc)+  unless (fdScrollOnly d) $ addGroup acc (fdSettledMoved d)+  -- Keys that left repaint as the current backdrop over their old rects. Keys+  -- that arrived must repaint inside their new rects too: the retain texture+  -- has never shown that content, and nothing else covers it (mirror writes+  -- escalate these frames to DamageFull, but layout-driven churn inside+  -- floating panels does not).+  addGroup acc (fdChurn d)+  -- Floating panels that moved, opened or closed repaint where they were and+  -- where they are.+  let addFloating other k r rest = unless (IM.lookup k other == Just r) (addRect acc r) >> rest+  IM.foldrWithKey (addFloating (fdFloatingRects d)) (pure ()) (fsFloatingRects snap)+  IM.foldrWithKey (addFloating (fsFloatingRects snap)) (pure ()) (fdFloatingRects d)+  base <- readRectUnion acc+  let clip = clipRectToWindow winW winH base+      winArea = winW * winH+  -- A live animation with an empty clip is not DamageFull: its+  -- key was either scroll-clipped out of view (nothing visible+  -- changes; scrolling back in damages via the scroll delta) or+  -- rect-less, which missingAnim already promoted to full.+  pure $+    if winArea > 0 && rectArea clip > winArea * 0.5+      then DamageFull+      else DamageClip clip++resolveDamageRequests ::+  Context ->+  RectUnion ->+  IM.IntMap Rect ->+  IM.IntMap Rect ->+  [DamageRequest] ->+  IO ()+resolveDamageRequests ctx acc oldRects newRects reqs =+  forM_ reqs $ \case+    ReqFull -> pure ()+    ReqRect r -> addRect acc r+    ReqWidget wid bounds -> resolveKey (intKey wid) bounds+    ReqKey k bounds -> resolveKey k bounds+    ReqPeers wids bounds -> forM_ wids $ \wid -> resolveKey (intKey wid) bounds+  where+    resolveKey k bounds =+      forM_ [IM.lookup k oldRects, IM.lookup k newRects] $+        mapM_ $ \r -> do+          clipped <- clipDeltaToScrollViewport ctx k (resolveDamageRect bounds r)+          when (rectNonEmpty clipped) $ addRect acc clipped++-- | A running union of rects, as @x0, y0, x1, y1@ followed by how many of+-- them lie outside every floating panel. The bounds start inverted, so the+-- first rect sets them and an empty union reads back as the zero rect.+newtype RectUnion = RectUnion (MutablePrimArray RealWorld Float)++newRectUnion :: IO RectUnion+newRectUnion = do+  a <- newPrimArray 5+  writePrimArray a 0 infinity+  writePrimArray a 1 infinity+  writePrimArray a 2 (-infinity)+  writePrimArray a 3 (-infinity)+  writePrimArray a 4 0+  pure (RectUnion a)+  where+    infinity = 1 / 0++{-# INLINE addRect #-}+addRect :: RectUnion -> Rect -> IO ()+addRect (RectUnion a) (Rect x y w h) = do+  x0 <- readPrimArray a 0+  y0 <- readPrimArray a 1+  x1 <- readPrimArray a 2+  y1 <- readPrimArray a 3+  writePrimArray a 0 (min x0 x)+  writePrimArray a 1 (min y0 y)+  writePrimArray a 2 (max x1 (x + w))+  writePrimArray a 3 (max y1 (y + h))++readRectUnion :: RectUnion -> IO Rect+readRectUnion (RectUnion a) = do+  x0 <- readPrimArray a 0+  y0 <- readPrimArray a 1+  x1 <- readPrimArray a 2+  y1 <- readPrimArray a 3+  pure $! if x0 > x1 then Rect 0 0 0 0 else Rect x0 y0 (x1 - x0) (y1 - y0)++-- | A set of rects reduced to what damage needs from it.+data RectGroup = RectGroup+  { rgAny :: !Bool+  , rgInPanels :: !Bool+  -- ^ Some floating panel fully contains each rect; False for an empty group.+  , rgBounds :: !Rect+  }++addGroup :: RectUnion -> RectGroup -> IO ()+addGroup acc g = when (rgAny g) $ addRect acc (rgBounds g)++-- | One pass over the keys whose rect changed, reduced to the settled moves+-- (clipped to scroll viewports, above 'layoutSettleMinArea') and the keys+-- that left or joined the arena.+rectDeltas :: Context -> [Rect] -> IM.IntMap Rect -> IM.IntMap Rect -> IO (RectGroup, RectGroup)+rectDeltas ctx panelRects old new+  | ptrEq old new = pure (emptyGroup, emptyGroup)+  | otherwise = do+      settled <- newRectUnion+      churn <- newRectUnion+      let note acc@(RectUnion a) r = do+            addRect acc r+            unless (any (rectFullyInside r) panelRects) $+              readPrimArray a 4 >>= writePrimArray a 4 . (+ 1)+      IM.foldrWithKey+        ( \k r rest -> do+            when (rectNonEmpty r) $ do+              when (IM.notMember k new || IM.notMember k old) $ note churn r+              clipped <- clipDeltaToScrollViewport ctx k r+              when (rectArea clipped >= layoutSettleMinArea) $ note settled clipped+            rest+        )+        (pure ())+        (IM.mergeWithKey (\_ a b -> if a /= b then Just (rectUnion a b) else Nothing) id id old new)+      (,) <$> freeze settled <*> freeze churn+  where+    emptyGroup = RectGroup False False (Rect 0 0 0 0)+    freeze acc@(RectUnion a) = do+      bounds <- readRectUnion acc+      x0 <- readPrimArray a 0+      x1 <- readPrimArray a 2+      outside <- readPrimArray a 4+      let !present = x0 <= x1+      pure (RectGroup present (present && not (null panelRects) && outside == 0) bounds)++clipDeltaToScrollViewport :: Context -> Int -> Rect -> IO Rect+clipDeltaToScrollViewport ctx k r = do+  findNodeByKey ctx k >>= \case+    Nothing -> pure r+    Just idx -> do+      mClip <- getClipRect (ctxNodeArena ctx) idx+      pure $+        case mClip of+          Nothing -> r+          Just clip -> fromMaybe (Rect 0 0 0 0) (rectIntersect r clip)++clipRectToWindow :: Float -> Float -> Rect -> Rect+clipRectToWindow winW winH r =+  fromMaybe (Rect 0 0 0 0) (rectIntersect r (Rect 0 0 winW winH))++clipKeyRect :: Context -> Int -> Rect -> IO (Maybe Rect)+clipKeyRect ctx k r+  | k == 0 = pure (Just r)+  | otherwise = do+      clipped <- clipDeltaToScrollViewport ctx k r+      pure (if rectNonEmpty clipped then Just clipped else Nothing)++-- | Rect of the nearest scroll-container ancestor of a keyed node, covering+-- the content viewport and the scrollbar lane its chrome paints in. The walk+-- stops at the first scroll node even when its rect is empty.+scrollAncestorRect :: Context -> Int -> IO (Maybe Rect)+scrollAncestorRect ctx k =+  findNodeByKey ctx k >>= maybe (pure Nothing) (fmap join . walkAncestors step na)+  where+    na = ctxNodeArena ctx+    step i = do+      nt <- getNodeType na i+      if isScrollNode nt+        then Just <$> getNonzeroRect na i+        else pure Nothing++scrollOffsetDamage :: Context -> RectUnion -> WidgetStore -> WidgetStore -> IO ()+scrollOffsetDamage ctx acc oldStore newStore =+  unless (IM.null changedKeys) $ do+    -- Every store key that holds a scroll node's offset, mapped to the first+    -- such node. Built once, only on frames where an offset changed.+    owners <- foldNodeRevM na addOwner IM.empty+    IM.foldrWithKey+      ( \k _ rest -> do+          forM_ (IM.lookup k owners) $ \idx -> do+            -- The scroll node's rect covers the content viewport AND the+            -- scrollbar lane: offset changes move the thumb, which paints+            -- outside the content clip.+            getNonzeroRect na idx >>= mapM_ (addRect acc)+            floatingAncestorRect ctx idx >>= mapM_ (addRect acc)+          rest+      )+      (pure ())+      changedKeys+  where+    na = ctxNodeArena ctx+    -- Floating-pane offsets live in storeFloat; wheel/keyboard offsets+    -- live under the SlotTextAreaScroll slot in storePoint. Both move the+    -- scroller's content and its chrome. New or removed float offsets only+    -- count when nonzero.+    changedKeys =+      changedKeysWith (fmap (const ()) . IM.filter (/= 0)) (storeFloat oldStore) (storeFloat newStore)+        `IM.union` changedKeysWith (fmap (const ())) (storePoint oldStore) (storePoint newStore)+    changedKeysWith :: Eq a => (IM.IntMap a -> IM.IntMap ()) -> IM.IntMap a -> IM.IntMap a -> IM.IntMap ()+    changedKeysWith oneSided old new =+      IM.mergeWithKey (\_ a b -> if a /= b then Just () else Nothing) oneSided oneSided old new+    addOwner m idx = do+      nt <- getNodeType na idx+      if not (isScrollNode nt)+        then pure m+        else do+          wid <- getWidgetId na idx+          let widKey = intKey wid+          pure $+            IM.insert widKey idx $+              IM.insert (slotKey SlotScrollCross widKey) idx $+                IM.insert (slotKey SlotTextAreaScroll widKey) idx m++floatingAncestorRect :: Context -> Int -> IO (Maybe Rect)+floatingAncestorRect ctx idx =+  walkAncestors check (ctxNodeArena ctx) idx+  where+    check i = do+      nt <- getNodeType (ctxNodeArena ctx) i+      if isFloatingNode nt+        then getNonzeroRect (ctxNodeArena ctx) i+        else pure Nothing
+ lib/NanoUI/Debug.hs view
@@ -0,0 +1,338 @@+-- | Debug readout sampling shared by the backends: frame timing and skip+-- counts, RTS statistics, draw counts, and the rows the debug windows show.+module NanoUI.Debug+  ( debugRefreshSec+  , blend+  , RtsStatsSnapshot (..)+  , readRtsSnapshot+  , CoreDebugSnapshot (..)+  , emptyCoreDebugSnapshot+  , DebugSampler (..)+  , DebugSamplerRef+  , newDebugSampler+  , noteDebugLoop+  , noteDebugSkip+  , isDebugActive+  , debugRefreshDue+  , noteDebugPresent+  , refreshDebugSnapshot+  , formatFpsRows+  , formatDrawRows+  , formatCoreRtsRows+  ) where++import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word (Word32, Word64)+import GHC.Clock (getMonotonicTime)+import GHC.Conc (getNumCapabilities, getNumProcessors)+import GHC.Stats (GCDetails (..), RTSStats (..), getRTSStats, getRTSStatsEnabled)+import Text.Printf (printf)++debugRefreshSec :: Double+debugRefreshSec = 0.25++blend :: Double -> Double -> Double+blend prev sample+  | prev <= 0 = sample+  | otherwise = prev * 0.85 + sample * 0.15++data RtsStatsSnapshot = RtsStatsSnapshot+  { rtsEnabled :: !Bool+  , rtsGcs :: !Word32+  , rtsMajorGcs :: !Word32+  , rtsAllocMb :: !Double+  , rtsLiveMb :: !Double+  , rtsMaxMemMb :: !Double+  , rtsCopiedMb :: !Double+  , rtsGcPct :: !Double+  , rtsLastGcGen :: !Word32+  , rtsLastGcMs :: !Double+  , rtsCaps :: !Int+  , rtsCpus :: !Int+  }+  deriving (Eq, Show)++emptyRtsSnapshot :: RtsStatsSnapshot+emptyRtsSnapshot =+  RtsStatsSnapshot+    { rtsEnabled = False+    , rtsGcs = 0+    , rtsMajorGcs = 0+    , rtsAllocMb = 0+    , rtsLiveMb = 0+    , rtsMaxMemMb = 0+    , rtsCopiedMb = 0+    , rtsGcPct = 0+    , rtsLastGcGen = 0+    , rtsLastGcMs = 0+    , rtsCaps = 0+    , rtsCpus = 0+    }++readRtsSnapshot :: IO RtsStatsSnapshot+readRtsSnapshot = do+  caps <- getNumCapabilities+  cpus <- getNumProcessors+  rtsOn <- getRTSStatsEnabled+  if not rtsOn+    then pure emptyRtsSnapshot {rtsCaps = caps, rtsCpus = cpus}+    else do+      st <- getRTSStats+      let tot = elapsed_ns st+          lastGc = gc st+          bytesMb n = fromIntegral n / (1024 * 1024)+      pure+        RtsStatsSnapshot+          { rtsEnabled = True+          , rtsGcs = gcs st+          , rtsMajorGcs = major_gcs st+          , rtsAllocMb = bytesMb (allocated_bytes st)+          , rtsLiveMb = bytesMb (gcdetails_live_bytes lastGc)+          , rtsMaxMemMb = bytesMb (max_mem_in_use_bytes st)+          , rtsCopiedMb = bytesMb (copied_bytes st)+          , rtsGcPct =+              if tot > 0 then 100 * fromIntegral (gc_elapsed_ns st) / fromIntegral tot else 0+          , rtsLastGcGen = gcdetails_gen lastGc+          , rtsLastGcMs = fromIntegral (gcdetails_elapsed_ns lastGc) / 1.0e6+          , rtsCaps = caps+          , rtsCpus = cpus+          }++data CoreDebugSnapshot = CoreDebugSnapshot+  { dbgPresentFps :: !Double+  , dbgLoopFps    :: !Double+  , dbgFrameMs    :: !Double+  , dbgUiMs       :: !Double+  , dbgRenderMs   :: !Double+  , dbgPresentMs  :: !Double+  , dbgPresents   :: !Word64+  , dbgSkips      :: !Word64+  , dbgVerts      :: !Int+  , dbgIndices    :: !Int+  , dbgCmds       :: !Int+  , dbgWinW       :: !Float+  , dbgWinH       :: !Float+  , dbgMouseX     :: !Float+  , dbgMouseY     :: !Float+  , dbgRts        :: !RtsStatsSnapshot+  }+  deriving (Eq, Show)++emptyCoreDebugSnapshot :: CoreDebugSnapshot+emptyCoreDebugSnapshot =+  CoreDebugSnapshot+    { dbgPresentFps = 0+    , dbgLoopFps = 0+    , dbgFrameMs = 0+    , dbgUiMs = 0+    , dbgRenderMs = 0+    , dbgPresentMs = 0+    , dbgPresents = 0+    , dbgSkips = 0+    , dbgVerts = 0+    , dbgIndices = 0+    , dbgCmds = 0+    , dbgWinW = 0+    , dbgWinH = 0+    , dbgMouseX = 0+    , dbgMouseY = 0+    , dbgRts = emptyRtsSnapshot+    }++data DebugSampler = DebugSampler+  { smPresentEma   :: {-# UNPACK #-} !Double+  , smLoopEma      :: {-# UNPACK #-} !Double+  , smLastPresentT :: {-# UNPACK #-} !Double+  , smLastDebugT   :: {-# UNPACK #-} !Double+  , smLastQueryT   :: {-# UNPACK #-} !Double+  , smPresents     :: {-# UNPACK #-} !Word64+  , smSkips        :: {-# UNPACK #-} !Word64+  , smUiMs         :: {-# UNPACK #-} !Double+  , smRenderMs     :: {-# UNPACK #-} !Double+  , smPresentMs    :: {-# UNPACK #-} !Double+  , smFrameMs      :: {-# UNPACK #-} !Double+  , smVerts        :: {-# UNPACK #-} !Int+  , smIndices      :: {-# UNPACK #-} !Int+  , smCmds         :: {-# UNPACK #-} !Int+  , smRatePresents :: {-# UNPACK #-} !Word64+  , smRateT        :: {-# UNPACK #-} !Double+  }++type DebugSamplerRef = IORef DebugSampler++newDebugSampler :: IO DebugSamplerRef+newDebugSampler = do+  now <- getMonotonicTime+  newIORef+    DebugSampler+      { smPresentEma = 0+      , smLoopEma = 0+      , smLastPresentT = now+      , smLastDebugT = 0+      , smLastQueryT = 0+      , smPresents = 0+      , smSkips = 0+      , smUiMs = 0+      , smRenderMs = 0+      , smPresentMs = 0+      , smFrameMs = 0+      , smVerts = 0+      , smIndices = 0+      , smCmds = 0+      , smRatePresents = 0+      , smRateT = now+      }++noteDebugLoop :: DebugSamplerRef -> Float -> IO ()+noteDebugLoop ref dt =+  atomicModifyIORef' ref $ \s ->+    let dtD = realToFrac dt :: Double+        fps = if dtD > 1e-4 && dtD < 0.25 then 1 / dtD else 0+        ema' =+          if fps > 0+            then blend (smLoopEma s) fps+            else smLoopEma s+     in (s {smLoopEma = ema'}, ())++noteDebugSkip :: DebugSamplerRef -> IO ()+noteDebugSkip ref =+  atomicModifyIORef' ref $ \s -> (s {smSkips = smSkips s + 1}, ())++-- | Debug HUD cadence is driven by actual snapshot consumption: a snapshot+-- query ('refreshDebugSnapshot') refreshes 'smLastQueryT', so the 4 Hz refresh+-- loop only runs while a stats window is being built. An open window alone+-- does not count as activity, or the event loop would wake every refresh+-- period while any floating window is open.+isDebugActive :: DebugSamplerRef -> IO Bool+isDebugActive ref = do+  now <- getMonotonicTime+  s <- readIORef ref+  pure (now - smLastQueryT s < 1.0)++-- | Whether the published snapshot is older than 'debugRefreshSec'.+debugRefreshDue :: DebugSamplerRef -> IO Bool+debugRefreshDue ref = do+  now <- getMonotonicTime+  s <- readIORef ref+  pure (snapshotDue now s)++snapshotDue :: Double -> DebugSampler -> Bool+snapshotDue now s = smLastDebugT s <= 0 || now - smLastDebugT s >= debugRefreshSec++noteDebugPresent :: DebugSamplerRef -> Double -> Double -> Double -> Double -> Int -> Int -> Int -> IO ()+noteDebugPresent ref uiMs renderMs presentMs frameMs verts indices cmds = do+  now <- getMonotonicTime+  atomicModifyIORef' ref $ \s ->+    let dt = now - smLastPresentT s+        instantFps =+          if dt > 1e-4 && dt < 0.25+            then 1 / dt+            else 0+        ema' =+          if instantFps > 0+            then blend (smPresentEma s) instantFps+            else smPresentEma s+     in ( s+             { smPresentEma = ema'+             , smLastPresentT = now+             , smPresents = smPresents s + 1+             , smUiMs = uiMs+             , smRenderMs = renderMs+             , smPresentMs = presentMs+             , smFrameMs = frameMs+             , smVerts = verts+             , smIndices = indices+             , smCmds = cmds+             }+        , ()+        )++-- | The published snapshot, rebuilt at most every 'debugRefreshSec' and cached+-- in between. A due query samples the core stats and hands them to @build@,+-- which adds the backend's fields: window size and mouse position are left 0+-- for it to fill. Every query marks the readout active ('isDebugActive').+refreshDebugSnapshot :: DebugSamplerRef -> IORef s -> (CoreDebugSnapshot -> IO s) -> IO s+refreshDebugSnapshot ref cache build = do+  now <- getMonotonicTime+  due <- atomicModifyIORef' ref $ \cur -> (cur {smLastQueryT = now}, snapshotDue now cur)+  if not due+    then readIORef cache+    else do+      rts <- readRtsSnapshot+      core <- atomicModifyIORef' ref $ \cur ->+        -- Actual presents per second since the previous refresh. Unlike the+        -- per-present EMA this stays truthful when presents are sparse (idle+        -- app: ~4/s with the HUD open, not the theoretical fps of one fast+        -- frame).+        let elapsed = now - smRateT cur+            rate+              | elapsed > 1e-3 = fromIntegral (smPresents cur - smRatePresents cur) / elapsed+              | otherwise = 0+            cur' = cur {smLastDebugT = now, smRatePresents = smPresents cur, smRateT = now}+         in (cur', (coreDebugSnapshot cur' rts) {dbgPresentFps = rate})+      snap <- build core+      writeIORef cache snap+      pure snap++coreDebugSnapshot :: DebugSampler -> RtsStatsSnapshot -> CoreDebugSnapshot+coreDebugSnapshot s rts =+  CoreDebugSnapshot+    { dbgPresentFps = smPresentEma s+    , dbgLoopFps = smLoopEma s+    , dbgFrameMs = smFrameMs s+    , dbgUiMs = smUiMs s+    , dbgRenderMs = smRenderMs s+    , dbgPresentMs = smPresentMs s+    , dbgPresents = smPresents s+    , dbgSkips = smSkips s+    , dbgVerts = smVerts s+    , dbgIndices = smIndices s+    , dbgCmds = smCmds s+    , dbgWinW = 0+    , dbgWinH = 0+    , dbgMouseX = 0+    , dbgMouseY = 0+    , dbgRts = rts+    }++formatFpsRows :: CoreDebugSnapshot -> [(Text, Text)]+formatFpsRows s =+  [ ("fps present", T.pack (printf "%6.1f" (dbgPresentFps s)))+  , ("fps loop", T.pack (printf "%6.1f" (dbgLoopFps s)))+  , ("frame ms", T.pack (printf "%6.2f" (dbgFrameMs s)))+  , ("ui ms", T.pack (printf "%6.2f" (dbgUiMs s)))+  , ("render ms", T.pack (printf "%6.2f" (dbgRenderMs s)))+  , ("present ms", T.pack (printf "%6.2f" (dbgPresentMs s)))+  , ("presents", T.pack (printf "%10d" (dbgPresents s)))+  , ("skips", T.pack (printf "%10d" (dbgSkips s)))+  ]++formatDrawRows :: CoreDebugSnapshot -> [(Text, Text)]+formatDrawRows s =+  [ ("vertices", T.pack (printf "%10d" (dbgVerts s)))+  , ("indices", T.pack (printf "%10d" (dbgIndices s)))+  , ("commands", T.pack (printf "%10d" (dbgCmds s)))+  ]++formatCoreRtsRows :: CoreDebugSnapshot -> [(Text, Text)]+formatCoreRtsRows core+  | not (rtsEnabled s) =+      [ ("rts", "stats off (need +RTS -T)")+      , ("haskell", T.pack (printf "%2d cap / %2d cpu" (rtsCaps s) (rtsCpus s)))+      ]+  | otherwise =+      [ ("haskell", T.pack (printf "%2d cap / %2d cpu" (rtsCaps s) (rtsCpus s)))+      , ("gc total", T.pack (printf "%10d" (rtsGcs s)))+      , ("gc major", T.pack (printf "%10d" (rtsMajorGcs s)))+      , ("last gen", T.pack (printf "%10d" (rtsLastGcGen s)))+      , ("last gc", T.pack (printf "%7.2f ms" (rtsLastGcMs s)))+      , ("heap live", T.pack (printf "%6.1f MiB" (rtsLiveMb s)))+      , ("heap alloc", T.pack (printf "%6.1f MiB" (rtsAllocMb s)))+      , ("copied", T.pack (printf "%6.1f MiB" (rtsCopiedMb s)))+      , ("rss max", T.pack (printf "%6.1f MiB" (rtsMaxMemMb s)))+      , ("gc time", T.pack (printf "%9.1f%%" (rtsGcPct s)))+      ]+  where+    s = dbgRts core
+ lib/NanoUI/Draw.hs view
@@ -0,0 +1,52 @@+-- | Draw layer facade: data types, arena, geometry and text emitters.+module NanoUI.Draw+  ( Layer (..)+  , DrawCmd (..)+  , LayerSlice (..)+  , DrawData (..)+  , DrawArena (..)+  , DrawOp (..)+  , TextFont (..)+  , defaultTextFont+  , DrawingBuild+  , shiftDrawOp+  , newDrawArena+  , resetDrawArena+  , setDrawSnapScale+  , getDrawSnapScale+  , setDrawSquareGeometry+  , setDrawExternalText+  , beginLayer+  , currentLayer+  , currentClip+  , setClip+  , withClip+  , finishDraw+  , drawCmdCount+  , drawCmdNull+  , forDrawCmdsInLayer_+  , drawCmdElems+  , vertexSize+  , indexSize+  , backdropDimTextureId+  , glyphAtlasTextureId+  , pushRect+  , pushQuadGradient+  , pushImage+  , pushRoundedRect+  , pushRoundedRectRaw+  , pushRoundedStroke+  , pushLine+  , pushStrokeAA+  , pushStroke+  , pushFilledTriangle+  , drawTextBox+  , pushText+  , pushTextStyled+  , emitDrawOps+  ) where++import NanoUI.Draw.Arena+import NanoUI.Draw.Shapes+import NanoUI.Draw.Text+import NanoUI.Draw.Types
+ lib/NanoUI/Draw/Arena.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++-- | Draw arena lifecycle, command batching and vertex reservation. The shape+-- and text emitters reserve room here and poke vertices straight into the+-- pinned buffers.+module NanoUI.Draw.Arena+  ( newDrawArena+  , resetDrawArena+  , setDrawSnapScale+  , getDrawSnapScale+  , setDrawSquareGeometry+  , setDrawExternalText+  , beginLayer+  , currentLayer+  , currentClip+  , setClip+  , withClip+  , setTexture+  , finishDraw+  , withVerts+  , withVertsRaw+  , withVertsReserve+  , pushQuad+  , snapRectOrigin+  , unpackColorF+  , pokeQuadIndices+  , loopIO+  , whitePixelU+  , whitePixelV+  ) where++import Control.Monad (unless, when)+import Data.Bits (shiftR, (.&.))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import Data.Primitive.PrimArray+  ( MutablePrimArray+  , PrimArray+  , newPrimArray+  , readPrimArray+  , setPrimArray+  , unsafeFreezePrimArray+  , writePrimArray+  , resizeMutablePrimArray+  )+import Data.Word (Word32, Word8)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Marshal.Array (copyArray)+import Foreign.Ptr (Ptr)+import Foreign.Storable (pokeByteOff)+import GHC.Exts (RealWorld)+import NanoUI.Draw.Types+import NanoUI.SIMD (pokeQuadSIMD)+import NanoUI.Types (Color (..), Rect (..), onGrid, rectIntersect)++vertexCapacity :: Int+vertexCapacity = 4096++indexCapacity :: Int+indexCapacity = 8192++bufferPoolLimit :: Int+bufferPoolLimit = 4++cmdInitialCapacity :: Int+cmdInitialCapacity = 64++newDrawArena :: IO DrawArena+newDrawArena = do+  vFPtr <- mallocForeignPtrBytes (vertexCapacity * vertexSize)+  iFPtr <- mallocForeignPtrBytes (indexCapacity * indexSize)+  daVertexFPtr <- newIORef vFPtr+  daVertexPtr <- newIORef (unsafeForeignPtrToPtr vFPtr)+  daVertexCap <- newIORef vertexCapacity+  daVertexCount <- newIORef 0+  daVertexPool <- newIORef []+  daIndexFPtr <- newIORef iFPtr+  daIndexPtr <- newIORef (unsafeForeignPtrToPtr iFPtr)+  daIndexCap <- newIORef indexCapacity+  daIndexCount <- newIORef 0+  daIndexPool <- newIORef []+  daCmdStore <- newIORef =<< newPrimArray cmdInitialCapacity+  daCmdCount <- newIORef 0+  daCmdCapacity <- newIORef cmdInitialCapacity+  daCurrentLayer <- newIORef LayerContent+  daCurrentClip <- newPrimArray 4+  daCurrentTexture <- newIORef glyphAtlasTextureId+  daCmdStartIndex <- newIORef 0+  daSnapScale <- newIORef 0.0+  daSquareGeometry <- newIORef False+  daExternalText <- newIORef False+  let da = DrawArena {..}+  resetDrawArena da+  pure da++resetDrawArena :: DrawArena -> IO ()+resetDrawArena da = do+  writeIORef (daVertexCount da) 0+  writeIORef (daIndexCount da) 0+  writeIORef (daCmdCount da) 0+  writeIORef (daCurrentLayer da) LayerContent+  setClip da (Rect 0 0 1e9 1e9)+  writeIORef (daCurrentTexture da) glyphAtlasTextureId+  writeIORef (daCmdStartIndex da) 0++-- | Device pixel scale used to snap primitive origins/endpoints to whole+-- device pixels. A non-positive value disables snapping. The SDL backend keeps+-- this in sync with the display scale. Headless contexts and the RGFW backend+-- leave it disabled.+{-# INLINE setDrawSnapScale #-}+setDrawSnapScale :: DrawArena -> Float -> IO ()+setDrawSnapScale da s = writeIORef (daSnapScale da) (if s > 0 then s else 0)++{-# INLINE getDrawSnapScale #-}+getDrawSnapScale :: DrawArena -> IO Float+getDrawSnapScale da = readIORef (daSnapScale da)++-- | Square geometry for hosts that draw flat, axis-aligned fills, such as the+-- RGFW backend. Rounded rects, circles and their strokes lower to+-- plain rects, and coverage-AA strips lower to solid quads with no+-- transparent fringe vertices. Persists across 'resetDrawArena'.+{-# INLINE setDrawSquareGeometry #-}+setDrawSquareGeometry :: DrawArena -> Bool -> IO ()+setDrawSquareGeometry da = writeIORef (daSquareGeometry da)++-- | External text for hosts that rasterize text themselves from the collected+-- text spans. Text emitters push no quads, so fonts without a glyph atlas do+-- not leave per-character advance boxes in the buffer. Persists across+-- 'resetDrawArena'.+{-# INLINE setDrawExternalText #-}+setDrawExternalText :: DrawArena -> Bool -> IO ()+setDrawExternalText da = writeIORef (daExternalText da)++{-# NOINLINE poolTake #-}+poolTake :: BufferPool -> Int -> Int -> IO (ForeignPtr Word8)+poolTake pool bytes minCap = do+  entries <- readIORef pool+  case break (\(_, cap) -> cap >= minCap) entries of+    (before, (ptr, _) : after) -> do+      writeIORef pool (before ++ after)+      pure ptr+    _ -> mallocForeignPtrBytes bytes++{-# NOINLINE poolGive #-}+poolGive :: BufferPool -> ForeignPtr Word8 -> Int -> IO ()+poolGive pool ptr cap = do+  entries <- readIORef pool+  writeIORef pool (take bufferPoolLimit ((ptr, cap) : entries))++{-# NOINLINE growBuffer #-}+growBuffer ::+  Int ->+  IORef (ForeignPtr Word8) ->+  IORef (Ptr Word8) ->+  IORef Int ->+  BufferPool ->+  Int ->+  Int ->+  IO ()+growBuffer count fptrRef ptrRef capRef pool elemBytes needElems = do+  cap <- readIORef capRef+  let required = count + needElems+  when (required > cap) $ do+    oldFPtr <- readIORef fptrRef+    let newCap = max (cap * 2) required+    newFPtr <- poolTake pool (newCap * elemBytes) newCap+    withForeignPtr newFPtr $ \newP ->+      withForeignPtr oldFPtr $ \oldP ->+        copyArray newP oldP (count * elemBytes)+    poolGive pool oldFPtr cap+    writeIORef fptrRef newFPtr+    writeIORef ptrRef (unsafeForeignPtrToPtr newFPtr)+    writeIORef capRef newCap++ensureCapacity :: DrawArena -> Int -> Int -> IO ()+ensureCapacity da needVerts needIndices = do+  vCount <- readIORef (daVertexCount da)+  growBuffer vCount (daVertexFPtr da) (daVertexPtr da) (daVertexCap da) (daVertexPool da) vertexSize needVerts+  iCount <- readIORef (daIndexCount da)+  growBuffer iCount (daIndexFPtr da) (daIndexPtr da) (daIndexCap da) (daIndexPool da) indexSize needIndices++{-# INLINE ensureAndAlloc #-}+ensureAndAlloc :: DrawArena -> Int -> Int -> IO (Ptr Word8, Ptr Word8, Int, Int)+ensureAndAlloc da needV needI = do+  vCount <- readIORef (daVertexCount da)+  iCount <- readIORef (daIndexCount da)+  vCap <- readIORef (daVertexCap da)+  iCap <- readIORef (daIndexCap da)+  unless (vCount + needV <= vCap && iCount + needI <= iCap) $+    ensureCapacity da needV needI+  vp <- readIORef (daVertexPtr da)+  ip <- readIORef (daIndexPtr da)+  pure (vp, ip, vCount, iCount)++{-# NOINLINE growCmdStore #-}+growCmdStore :: DrawArena -> Int -> IO ()+growCmdStore da oldCap = do+  let newCap = oldCap * 2+  arr <- readIORef (daCmdStore da)+  newArr <- resizeMutablePrimArray arr newCap+  writeIORef (daCmdStore da) newArr+  writeIORef (daCmdCapacity da) newCap++-- | Close the pending index run as a command. A run that continues the last+-- command's state and index range extends that command instead. Only reached+-- when the layer, clip or texture changes and from 'finishDraw', so it stays+-- out of the emitters.+{-# NOINLINE flushCmd #-}+flushCmd :: DrawArena -> IO ()+flushCmd da = do+  start <- readIORef (daCmdStartIndex da)+  end <- readIORef (daIndexCount da)+  when (end > start) $ do+    Rect cx cy cw ch <- currentClip da+    tex <- readIORef (daCurrentTexture da)+    layer <- readIORef (daCurrentLayer da)+    n <- readIORef (daCmdCount da)+    arr <- readIORef (daCmdStore da)+    let off = fromIntegral start :: Word32+        cnt = fromIntegral (end - start) :: Word32+    extended <-+      if n <= 0+        then pure False+        else do+          prev <- readPrimArray arr (n - 1)+          let same =+                cmdClipX prev == cx+                  && cmdClipY prev == cy+                  && cmdClipW prev == cw+                  && cmdClipH prev == ch+                  && cmdTextureId prev == tex+                  && cmdLayer prev == layer+                  && cmdIndexOffset prev + cmdIndexCount prev == off+          when same $+            writePrimArray arr (n - 1) prev {cmdIndexCount = cmdIndexCount prev + cnt}+          pure same+    unless extended $ do+      cap <- readIORef (daCmdCapacity da)+      when (n >= cap) $ growCmdStore da cap+      arr' <- readIORef (daCmdStore da)+      writePrimArray arr' n (DrawCmd cx cy cw ch tex off cnt layer)+      writeIORef (daCmdCount da) (n + 1)+    writeIORef (daCmdStartIndex da) end++{-# INLINE currentLayer #-}+currentLayer :: DrawArena -> IO Layer+currentLayer = readIORef . daCurrentLayer++beginLayer :: DrawArena -> Layer -> IO ()+beginLayer da layer = do+  cur <- readIORef (daCurrentLayer da)+  when (cur /= layer) $ do+    flushCmd da+    writeIORef (daCurrentLayer da) layer+    readIORef (daIndexCount da) >>= writeIORef (daCmdStartIndex da)++setClip :: DrawArena -> Rect -> IO ()+setClip da (Rect x y w h) = do+  flushCmd da+  let clip = daCurrentClip da+  writePrimArray clip 0 x+  writePrimArray clip 1 y+  writePrimArray clip 2 w+  writePrimArray clip 3 h++{-# INLINE currentClip #-}+currentClip :: DrawArena -> IO Rect+currentClip da = do+  let clip = daCurrentClip da+  x <- readPrimArray clip 0+  y <- readPrimArray clip 1+  w <- readPrimArray clip 2+  h <- readPrimArray clip 3+  pure $! Rect x y w h+++-- | Run @act@ clipped to the intersection with the current clip. Not+-- exception-safe: the frame resets the clip before the next paint anyway.+{-# INLINE withClip #-}+withClip :: DrawArena -> Rect -> IO a -> IO a+withClip da rect act = do+  prev <- currentClip da+  setClip da (fromMaybe (Rect 0 0 0 0) (rectIntersect prev rect))+  act <* setClip da prev++-- | Bind a texture. The unchanged case is the common one and stays inline; a+-- real switch closes the pending command out of line.+{-# INLINE setTexture #-}+setTexture :: DrawArena -> Int -> IO ()+setTexture da tex = do+  cur <- readIORef (daCurrentTexture da)+  when (cur /= tex) $ switchTexture da tex++{-# NOINLINE switchTexture #-}+switchTexture :: DrawArena -> Int -> IO ()+switchTexture da tex = do+  flushCmd da+  writeIORef (daCurrentTexture da) tex++finishDraw :: DrawArena -> IO DrawData+finishDraw da = do+  flushCmd da+  vFPtr <- readIORef (daVertexFPtr da)+  iFPtr <- readIORef (daIndexFPtr da)+  vCount <- readIORef (daVertexCount da)+  iCount <- readIORef (daIndexCount da)+  count <- readIORef (daCmdCount da)+  arr <- readIORef (daCmdStore da)+  (cmds, slices) <- groupCmdsByLayer arr count+  pure+    DrawData+      { drawVertices = vFPtr+      , drawVertexCount = vCount+      , drawIndices = iFPtr+      , drawIndexCount = iCount+      , drawCommands = cmds+      , drawLayerSlices = slices+      }++-- | Stable counting sort of the recorded commands by layer, plus one slice per+-- layer into the sorted array.+groupCmdsByLayer :: MutablePrimArray RealWorld DrawCmd -> Int -> IO (PrimArray DrawCmd, PrimArray LayerSlice)+groupCmdsByLayer src n = do+  let layers = fromEnum (maxBound :: Layer) + 1+      layerAt i = fromEnum . cmdLayer <$> readPrimArray src i+  counts <- newPrimArray layers+  setPrimArray counts 0 layers (0 :: Int)+  loopIO 0 (n - 1) $ \i -> do+    l <- layerAt i+    readPrimArray counts l >>= writePrimArray counts l . (+ 1)+  cursors <- newPrimArray layers+  slices <- newPrimArray layers+  let offsets !l !off =+        when (l < layers) $ do+          c <- readPrimArray counts l+          writePrimArray cursors l off+          writePrimArray slices l (LayerSlice off c)+          offsets (l + 1) (off + c)+  offsets 0 0+  dest <- newPrimArray n+  loopIO 0 (n - 1) $ \i -> do+    cmd <- readPrimArray src i+    let l = fromEnum (cmdLayer cmd)+    j <- readPrimArray cursors l+    writePrimArray dest j cmd+    writePrimArray cursors l (j + 1)+  (,) <$> unsafeFreezePrimArray dest <*> unsafeFreezePrimArray slices++{-# INLINE unpackColorF #-}+unpackColorF :: Color -> (Float, Float, Float, Float)+unpackColorF (Color w) =+  let !inv255 = 1.0 / 255.0+      !r = fromIntegral ((w `shiftR` 24) .&. 0xFF) * inv255+      !g = fromIntegral ((w `shiftR` 16) .&. 0xFF) * inv255+      !b = fromIntegral ((w `shiftR` 8) .&. 0xFF) * inv255+      !a = fromIntegral (w .&. 0xFF) * inv255+   in (r, g, b, a)++-- Allocate room for a primitive, hand the derived offsets to the body, and+-- commit the vertex/index counts afterwards. INLINE: erased at -O.+{-# INLINE withVerts #-}+withVerts :: DrawArena -> Int -> Int -> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ()) -> IO ()+withVerts da needV needI f = do+  (vp, ip, base, baseIdx) <- ensureAndAlloc da needV needI+  let !vOff = base * vertexSize+      !iOff = baseIdx * indexSize+      !baseIdxWord = fromIntegral base :: Word32+  f vp ip vOff iOff baseIdxWord+  writeIORef (daVertexCount da) (base + needV)+  writeIORef (daIndexCount da) (baseIdx + needI)++-- Like 'withVerts' but for primitives that index vertices relative to 'base'+-- themselves instead of using one contiguous offset.+{-# INLINE withVertsRaw #-}+withVertsRaw :: DrawArena -> Int -> Int -> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO ()) -> IO ()+withVertsRaw da needV needI f = do+  (vp, ip, base, baseIdx) <- ensureAndAlloc da needV needI+  f vp ip base baseIdx+  writeIORef (daVertexCount da) (base + needV)+  writeIORef (daIndexCount da) (baseIdx + needI)++-- | Reserve room for up to @maxV@ vertices / @maxI@ indices, hand the body a+-- commit action, then record only the counts the body reports. Batches many+-- small quads (text glyphs) into one arena reservation instead of one+-- @withVerts@ closure + capacity check per quad.+{-# INLINE withVertsReserve #-}+withVertsReserve ::+  DrawArena ->+  Int ->+  Int ->+  (Ptr Word8 -> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ()) ->+  IO ()+withVertsReserve da maxV maxI f = do+  (vp, ip, base, baseIdx) <- ensureAndAlloc da maxV maxI+  f vp ip base baseIdx $ \nv ni -> do+    writeIORef (daVertexCount da) (base + nv)+    writeIORef (daIndexCount da) (baseIdx + ni)++-- | Strict numeric loop. Replaces @forM_ [lo .. hi]@ on the rounded-geometry+-- hot path, where the intermediate range list was a measurable allocation and+-- prevented the body from fusing into a straight-line loop.+{-# INLINE loopIO #-}+loopIO :: Int -> Int -> (Int -> IO ()) -> IO ()+loopIO !lo !hi f = go lo+  where+    go !i+      | i > hi = pure ()+      | otherwise = f i >> go (i + 1)++{-# INLINE pushQuad #-}+pushQuad :: DrawArena -> Rect -> Float -> Float -> Float -> Float -> Color -> IO ()+pushQuad da (Rect x y w h) u0 v0 u1 v1 col = do+  let !(r, g, b, a) = unpackColorF col+  withVerts da 4 6 $ \vp ip vOff iOff baseIdxWord ->+    pokeQuadSIMD vp vOff ip iOff x y w h u0 v0 u1 v1 r g b a baseIdxWord++{-# INLINE snapRectOrigin #-}+snapRectOrigin :: DrawArena -> Rect -> IO Rect+snapRectOrigin da (Rect x y w h) = do+  s <- readIORef (daSnapScale da)+  pure (Rect (onGrid s x) (onGrid s y) w h)++{-# INLINE pokeQuadIndices #-}+pokeQuadIndices :: Ptr Word8 -> Int -> Word32 -> Word32 -> Word32 -> Word32 -> IO ()+pokeQuadIndices ip off a b c d = do+  pokeByteOff ip off a+  pokeByteOff ip (off + 4) b+  pokeByteOff ip (off + 8) c+  pokeByteOff ip (off + 12) a+  pokeByteOff ip (off + 16) c+  pokeByteOff ip (off + 20) d++-- | Center of the 4x4 white pixel patch in the 1024x1024 font atlas.+whitePixelU :: Float+whitePixelU = 1.5 / 1024.0++whitePixelV :: Float+whitePixelV = 1.5 / 1024.0
+ lib/NanoUI/Draw/Shapes.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE StrictData #-}++-- | Solid geometry emitters: rects, gradients, images, rounded fills and+-- borders, coverage-AA strokes, lines and triangles.+module NanoUI.Draw.Shapes+  ( pushRect+  , pushQuadGradient+  , pushImage+  , pushRoundedRect+  , pushRoundedRectRaw+  , pushRoundedStroke+  , pushLine+  , pushStrokeAA+  , pushStroke+  , pushFilledTriangle+  ) where++import Control.Monad (when)+import Data.IORef (readIORef)+import Data.Word (Word32, Word8)+import Foreign.Ptr (Ptr)+import Foreign.Storable (pokeByteOff)+import NanoUI.Draw.Arena+import NanoUI.Draw.Types (DrawArena (..), glyphAtlasTextureId, indexSize, vertexSize)+import NanoUI.SIMD+  ( concentricOffsetsSIMD+  , pokeQuadGradientSIMD+  , pokeQuadSIMD+  , pokeVertexSIMD+  )+import NanoUI.Types (Color (..), Rect (..), onGrid)++{-# INLINE pushRect #-}+pushRect :: DrawArena -> Rect -> Color -> IO ()+pushRect da rect col = do+  r <- snapRectOrigin da rect+  setTexture da glyphAtlasTextureId+  pushQuad da r whitePixelU whitePixelV whitePixelU whitePixelV col++-- Quad with a color per corner. GPU interpolates across the two triangles.+-- Corners: top-left, top-right, bottom-right, bottom-left.+pushQuadGradient :: DrawArena -> Rect -> Color -> Color -> Color -> Color -> IO ()+pushQuadGradient da (Rect x y w h) tl tr br bl+  | w <= 0 || h <= 0 = pure ()+  | otherwise = do+      s <- readIORef (daSnapScale da)+      setTexture da glyphAtlasTextureId+      let !px = onGrid s x+          !py = onGrid s y+          !c0 = unpackColorF tl+          !c1 = unpackColorF tr+          !c2 = unpackColorF br+          !c3 = unpackColorF bl+      withVerts da 4 6 $ \vp ip vOff iOff baseIdxWord ->+        pokeQuadGradientSIMD vp vOff ip iOff px py w h whitePixelU whitePixelV c0 c1 c2 c3 baseIdxWord++{-# INLINE pushImage #-}+pushImage :: DrawArena -> Rect -> Int -> Float -> Float -> Float -> Float -> Color -> IO ()+pushImage da rect tex u0 v0 u1 v1 col+  | tex <= 0 = pushRect da rect col+  | otherwise = do+      r <- snapRectOrigin da rect+      setTexture da tex+      pushQuad da r u0 v0 u1 v1 col++-- 4 segments per 90° arc. Lookup table in cornerCosSin has 5 points per quadrant.+cornerSegments :: Int+cornerSegments = 4++-- Precomputed unit-circle cos/sin for rounded-rect corners (4 segments per 90° arc).+{-# INLINE cornerCosSin #-}+cornerCosSin :: Int -> Int -> (Float, Float)+cornerCosSin q seg =+  case q * 5 + seg of+    0 -> (-1.0, 0.0)+    1 -> (-0.9238795325, -0.3826834324)+    2 -> (-0.7071067812, -0.7071067812)+    3 -> (-0.3826834324, -0.9238795325)+    4 -> (0.0, -1.0)+    5 -> (0.0, -1.0)+    6 -> (0.3826834324, -0.9238795325)+    7 -> (0.7071067812, -0.7071067812)+    8 -> (0.9238795325, -0.3826834324)+    9 -> (1.0, 0.0)+    10 -> (1.0, 0.0)+    11 -> (0.9238795325, 0.3826834324)+    12 -> (0.7071067812, 0.7071067812)+    13 -> (0.3826834324, 0.9238795325)+    14 -> (0.0, 1.0)+    15 -> (0.0, 1.0)+    16 -> (-0.3826834324, 0.9238795325)+    17 -> (-0.7071067812, 0.7071067812)+    18 -> (-0.9238795325, 0.3826834324)+    19 -> (-1.0, 0.0)+    _ -> (0.0, 0.0)++-- | Poke one coverage-AA strip into a reservation at vertex offset @vi@ and+-- index offset @ii@ (both relative to @base@/@baseIdx@). Callers guarantee+-- @(x0,y0) /= (x1,y1)@. Shared by straight strokes and the fused+-- rounded-stroke paths, so a whole border shares one arena reservation.+{-# INLINE pokeStripAt #-}+pokeStripAt ::+  Ptr Word8 ->+  Ptr Word8 ->+  Int ->+  Int ->+  Int ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+pokeStripAt vp ip base baseIdx vi ii x0 y0 x1 y1 bw r g b a = do+  let !dx = x1 - x0+      !dy = y1 - y0+      !len = sqrt (dx * dx + dy * dy)+      !nx = (-dy) / len+      !ny = dx / len+      !half = bw * 0.5+      !core = max 0 (half - 0.5)+      !outer = half + 0.5+      pokeEnd !ev !ex !ey = do+        let ((p0x, p0y), (p1x, p1y), (p2x, p2y), (p3x, p3y)) =+              concentricOffsetsSIMD ex ey nx ny (-outer) (-core) core outer+            !vBase = (base + vi + ev) * vertexSize+        pokeVertexSIMD vp vBase p0x p0y r g b 0 whitePixelU whitePixelV+        pokeVertexSIMD vp (vBase + 32) p1x p1y r g b a whitePixelU whitePixelV+        pokeVertexSIMD vp (vBase + 64) p2x p2y r g b a whitePixelU whitePixelV+        pokeVertexSIMD vp (vBase + 96) p3x p3y r g b 0 whitePixelU whitePixelV+  pokeEnd 0 x0 y0+  pokeEnd 4 x1 y1+  let !va = fromIntegral (base + vi) :: Word32+      !vb = va + 4+  pokeQuadIndices ip ((baseIdx + ii) * indexSize) va (va + 1) (vb + 1) vb+  pokeQuadIndices ip ((baseIdx + ii + 6) * indexSize) (va + 1) (va + 2) (vb + 2) (vb + 1)+  pokeQuadIndices ip ((baseIdx + ii + 12) * indexSize) (va + 2) (va + 3) (vb + 3) (vb + 2)++{-# INLINE pushRoundedRect #-}+pushRoundedRect :: DrawArena -> Rect -> Float -> Color -> IO ()+pushRoundedRect da (Rect x y w h) radius col = do+  s <- readIORef (daSnapScale da)+  pushRoundedRectRaw da (Rect (onGrid s x) (onGrid s y) w h) radius col++-- | Unsnapped variant used when the rect is already anchored to the snapped+-- device pixel grid, e.g. a mark that must stay concentric with a border that+-- has already snapped its own origin. Re-snapping here would round the+-- off-origin inset (delta = (box - mark)/2) away, and since absolute snapping+-- rides on the fractional part of the widget position the mark would drift+-- off-center by up to a pixel as the widget scrolls.+-- Keep the fused emitter out of its many paint callers: inlining it duplicates+-- the corner loops and increases instruction-cache pressure substantially.+{-# NOINLINE pushRoundedRectRaw #-}+pushRoundedRectRaw :: DrawArena -> Rect -> Float -> Color -> IO ()+pushRoundedRectRaw da (Rect x y w h) radius col+  | w <= 0 || h <= 0 = pure ()+  | radius <= 0.5 = pushRect da (Rect x y w h) col+  | otherwise = do+      square <- readIORef (daSquareGeometry da)+      let !rad = min radius (min (w * 0.5) (h * 0.5))+      if square || rad <= 0.5+        then pushRect da (Rect x y w h) col+        else do+          setTexture da glyphAtlasTextureId+          let !segs = cornerSegments+              !ring = segs + 1+              !midW = max 0 (w - 2 * rad)+              !midH = max 0 (h - 2 * rad)+              !hasCenter = midW > 0 && midH > 0+              !hasTB = midW > 0+              !hasLR = midH > 0+              !quadCount =+                (if hasCenter then 1 else 0)+                  + (if hasTB then 2 else 0)+                  + (if hasLR then 2 else 0)+              !cornerV = 1 + 2 * ring+              !cornerI = segs * 9+              !needV = quadCount * 4 + 4 * cornerV+              !needI = quadCount * 6 + 4 * cornerI+          withVertsRaw da needV needI $ \vp ip base baseIdx -> do+            let !(cr, cg, cb, ca) = unpackColorF col+                !u = whitePixelU+                !v = whitePixelV+                pokeQuadAt !vi !ii !qx !qy !qw !qh =+                  pokeQuadSIMD+                    vp+                    ((base + vi) * vertexSize)+                    ip+                    ((baseIdx + ii) * indexSize)+                    qx+                    qy+                    qw+                    qh+                    u+                    v+                    u+                    v+                    cr+                    cg+                    cb+                    ca+                    (fromIntegral (base + vi))+                pokeCorner !vi !ii !ccx !ccy !q = do+                  let !vBase = (base + vi) * vertexSize+                      !centerIdx = fromIntegral (base + vi) :: Word32+                      !inRad = max 0 (rad - 1.0)+                  pokeVertexSIMD vp vBase ccx ccy cr cg cb ca u v+                  loopIO 0 segs $ \i -> do+                    let !(ct, st) = cornerCosSin q i+                        !rimI = base + vi + 1 + i+                        !outI = base + vi + 1 + ring + i+                    pokeVertexSIMD vp (rimI * vertexSize) (ccx + inRad * ct) (ccy + inRad * st) cr cg cb ca u v+                    pokeVertexSIMD vp (outI * vertexSize) (ccx + rad * ct) (ccy + rad * st) cr cg cb 0 u v+                    when (i > 0) $ do+                      let !k = i - 1+                          !rim0 = fromIntegral (base + vi + i) :: Word32+                          !rim1 = fromIntegral (base + vi + 1 + i) :: Word32+                          !out0 = fromIntegral (base + vi + 1 + ring + k) :: Word32+                          !out1 = fromIntegral (base + vi + 1 + ring + i) :: Word32+                          !fillOff = (baseIdx + ii + k * 3) * indexSize+                          !fringeOff = (baseIdx + ii + segs * 3 + k * 6) * indexSize+                      pokeByteOff ip fillOff centerIdx+                      pokeByteOff ip (fillOff + 4) rim0+                      pokeByteOff ip (fillOff + 8) rim1+                      pokeQuadIndices ip fringeOff rim0 out0 out1 rim1+                !vi1 = if hasCenter then 4 else 0+                !ii1 = if hasCenter then 6 else 0+                !vi2 = vi1 + (if hasTB then 8 else 0)+                !ii2 = ii1 + (if hasTB then 12 else 0)+                !vi3 = vi2 + (if hasLR then 8 else 0)+                !ii3 = ii2 + (if hasLR then 12 else 0)+            when hasCenter $ pokeQuadAt 0 0 (x + rad) (y + rad) midW midH+            when hasTB $ do+              pokeQuadAt vi1 ii1 (x + rad) y midW rad+              pokeQuadAt (vi1 + 4) (ii1 + 6) (x + rad) (y + h - rad) midW rad+            when hasLR $ do+              pokeQuadAt vi2 ii2 x (y + rad) rad midH+              pokeQuadAt (vi2 + 4) (ii2 + 6) (x + w - rad) (y + rad) rad midH+            pokeCorner vi3 ii3 (x + rad) (y + rad) 0+            pokeCorner (vi3 + cornerV) (ii3 + cornerI) (x + w - rad) (y + rad) 1+            pokeCorner (vi3 + 2 * cornerV) (ii3 + 2 * cornerI) (x + w - rad) (y + h - rad) 2+            pokeCorner (vi3 + 3 * cornerV) (ii3 + 3 * cornerI) (x + rad) (y + h - rad) 3++{-# NOINLINE pushRoundedStroke #-}+pushRoundedStroke :: DrawArena -> Rect -> Float -> Float -> Color -> IO ()+pushRoundedStroke da (Rect x y w h) radius bw col+  | w <= 0 || h <= 0 || bw <= 0 = pure ()+  | otherwise = do+      s <- readIORef (daSnapScale da)+      let !px = onGrid s x+          !py = onGrid s y+      setTexture da glyphAtlasTextureId+      square <- readIORef (daSquareGeometry da)+      let !rad = min (max 0 radius) (min (w * 0.5) (h * 0.5))+          !ibw = min bw (min (w * 0.5) (h * 0.5))+      if square+        then pushSquareStroke da px py w h ibw col+        else if rad <= 0.5+        then do+          let !t = ibw+              !ox = px + t / 2+              !oy = py + t / 2+              !ow = max 0 (w - t)+              !oh = max 0 (h - t)+              !doTB = ow >= 0.001+              !doLR = oh >= 0.001+              !stripCount = (if doTB then 2 else 0) + (if doLR then 2 else 0)+          withVertsRaw da (stripCount * 8) (stripCount * 18) $ \vp ip base baseIdx -> do+            let !(r, g, b, a) = unpackColorF col+                !viLR = if doTB then 16 else 0+                !iiLR = if doTB then 36 else 0+            when doTB $ do+              pokeStripAt vp ip base baseIdx 0 0 ox oy (ox + ow) oy t r g b a+              pokeStripAt vp ip base baseIdx 8 18 ox (oy + oh) (ox + ow) (oy + oh) t r g b a+            when doLR $ do+              pokeStripAt vp ip base baseIdx viLR iiLR ox oy ox (oy + oh) t r g b a+              pokeStripAt vp ip base baseIdx (viLR + 8) (iiLR + 18) (ox + ow) oy (ox + ow) (oy + oh) t r g b a+        else do+          let !n = cornerSegments+          let !midW = max 0 (w - 2 * rad)+              !midH = max 0 (h - 2 * rad)+              !topY = py + ibw / 2+              !botY = py + h - ibw / 2+              !leftX = px + ibw / 2+              !rightX = px + w - ibw / 2+              !cr = max 0.25 (rad - ibw / 2)+              !doTB = midW >= 0.001+              !doLR = midH >= 0.001+              !stripCount = (if doTB then 2 else 0) + (if doLR then 2 else 0)+              -- Hairlines have coincident inner/outer core rings. Share that+              -- ring and omit its zero-area triangles instead of submitting+              -- a fourth vertex and a third quad for every arc segment.+              !core = max 0 (ibw * 0.5 - 0.5)+              !hasCore = core > 0+              !arcStride = if hasCore then 4 else 3+              !arcIndices = if hasCore then 18 else 12+              !arcV = (n + 1) * arcStride+              !arcI = n * arcIndices+              !needV = stripCount * 8 + 4 * arcV+              !needI = stripCount * 18 + 4 * arcI+          withVertsRaw da needV needI $ \vp ip base baseIdx -> do+            let !(r, g, b, a) = unpackColorF col+                pokeArc !vi !ii !ccx !ccy !q = do+                  let !inner = max 0 (cr - core)+                      !outerR = cr + core+                      !innerAA = max 0 (inner - 1.0)+                      !outerAA = outerR + 1.0+                  loopIO 0 n $ \i -> do+                    let !(ct, st) = cornerCosSin q i+                        !v0 = base + vi + i * arcStride+                        !vBase = v0 * vertexSize+                        ((p0x, p0y), (p1x, p1y), (p2x, p2y), (p3x, p3y)) =+                          concentricOffsetsSIMD ccx ccy ct st innerAA inner outerR outerAA+                    pokeVertexSIMD vp vBase p0x p0y r g b 0 whitePixelU whitePixelV+                    pokeVertexSIMD vp (vBase + 32) p1x p1y r g b a whitePixelU whitePixelV+                    when hasCore $+                      pokeVertexSIMD vp (vBase + 64) p2x p2y r g b a whitePixelU whitePixelV+                    pokeVertexSIMD vp (vBase + (arcStride - 1) * vertexSize) p3x p3y r g b 0 whitePixelU whitePixelV+                  loopIO 0 (n - 1) $ \i -> do+                    let !va = fromIntegral (base + vi + i * arcStride) :: Word32+                        !vb = va + fromIntegral arcStride+                        !iOff = (baseIdx + ii + i * arcIndices) * indexSize+                    pokeQuadIndices ip iOff va (va + 1) (vb + 1) vb+                    pokeQuadIndices ip (iOff + 24) (va + 1) (va + 2) (vb + 2) (vb + 1)+                    when hasCore $+                      pokeQuadIndices ip (iOff + 48) (va + 2) (va + 3) (vb + 3) (vb + 2)+                !viLR = if doTB then 16 else 0+                !iiLR = if doTB then 36 else 0+                !viC = stripCount * 8+                !iiC = stripCount * 18+            when doTB $ do+              pokeStripAt vp ip base baseIdx 0 0 (px + rad) topY (px + rad + midW) topY ibw r g b a+              pokeStripAt vp ip base baseIdx 8 18 (px + rad) botY (px + rad + midW) botY ibw r g b a+            when doLR $ do+              pokeStripAt vp ip base baseIdx viLR iiLR leftX (py + rad) leftX (py + rad + midH) ibw r g b a+              pokeStripAt vp ip base baseIdx (viLR + 8) (iiLR + 18) rightX (py + rad) rightX (py + rad + midH) ibw r g b a+            pokeArc viC iiC (px + rad) (py + rad) 0+            pokeArc (viC + arcV) (iiC + arcI) (px + w - rad) (py + rad) 1+            pokeArc (viC + 2 * arcV) (iiC + 2 * arcI) (px + w - rad) (py + h - rad) 2+            pokeArc (viC + 3 * arcV) (iiC + 3 * arcI) (px + rad) (py + h - rad) 3++-- | Border of four flat rects inside @(x, y, w, h)@, @t@ thick. The origin is+-- already snapped by the caller; the texture is already selected.+pushSquareStroke :: DrawArena -> Float -> Float -> Float -> Float -> Float -> Color -> IO ()+pushSquareStroke da x y w h t col = do+  let edge qx qy qw qh =+        when (qw > 0 && qh > 0) $+          pushQuad da (Rect qx qy qw qh) whitePixelU whitePixelV whitePixelU whitePixelV col+      !innerH = h - 2 * t+  edge x y w t+  edge x (y + h - t) w t+  edge x (y + t) t innerH+  edge (x + w - t) (y + t) t innerH++-- | A line @thickness@ wide with round caps: a coverage-AA strip with a+-- round cap on each end. An axis-aligned line is a plain rect spanning its+-- caps.+{-# INLINE pushLine #-}+pushLine :: DrawArena -> Float -> Float -> Float -> Float -> Float -> Color -> IO ()+pushLine da x1 y1 x2 y2 thickness col = do+  square <- readIORef (daSquareGeometry da)+  let !r = thickness / 2+      cap cx cy = pushRoundedRect da (Rect (cx - r) (cy - r) thickness thickness) r col+  if square+    then pushStroke da x1 y1 x2 y2 thickness col+    else+      if x1 == x2 || y1 == y2+        then pushRect da (Rect (min x1 x2 - r) (min y1 y2 - r) (abs (x2 - x1) + thickness) (abs (y2 - y1) + thickness)) col+        else when (thickness > 0) $ do+          pushStrokeAA da x1 y1 x2 y2 thickness col+          cap x1 y1+          cap x2 y2++-- Coverage-AA strip for a straight segment. Same weight as pushCornerArcStroke,+-- without round caps that blob at rounded-rect corners.+{-# INLINE pushStrokeAA #-}+pushStrokeAA :: DrawArena -> Float -> Float -> Float -> Float -> Float -> Color -> IO ()+pushStrokeAA da x0 y0 x1 y1 bw col+  | bw <= 0 = pure ()+  | otherwise = do+      s <- readIORef (daSnapScale da)+      pushStrokeAARaw da (onGrid s x0) (onGrid s y0) (onGrid s x1) (onGrid s y1) bw col++-- | Unsnapped variant: the caller already snapped the endpoints.+pushStrokeAARaw :: DrawArena -> Float -> Float -> Float -> Float -> Float -> Color -> IO ()+pushStrokeAARaw da x0 y0 x1 y1 bw col = do+  square <- readIORef (daSquareGeometry da)+  if square+    then pushStroke da x0 y0 x1 y1 bw col+    else case strokeAxes x0 y0 x1 y1 of+      Nothing -> pure ()+      Just _ -> do+        setTexture da glyphAtlasTextureId+        let !(r, g, b, a) = unpackColorF col+        withVertsRaw da 8 18 $ \vp ip base baseIdx ->+          pokeStripAt vp ip base baseIdx 0 0 x0 y0 x1 y1 bw r g b a++strokeAxes :: Float -> Float -> Float -> Float -> Maybe (Float, Float, Float)+strokeAxes x0 y0 x1 y1 =+  let dx = x1 - x0+      dy = y1 - y0+      len = sqrt (dx * dx + dy * dy)+   in if len < 0.001 then Nothing else Just (dx, dy, len)++-- One quad per segment. Plots and diagrams use this; pushLine adds round caps.+pushStroke :: DrawArena -> Float -> Float -> Float -> Float -> Float -> Color -> IO ()+pushStroke da x1 y1 x2 y2 thickness col+  | thickness <= 0 = pure ()+  | otherwise = do+      s <- readIORef (daSnapScale da)+      let !px1 = onGrid s x1+          !py1 = onGrid s y1+          !px2 = onGrid s x2+          !py2 = onGrid s y2+      case strokeAxes px1 py1 px2 py2 of+        Nothing -> pure ()+        Just (dx, dy, len) -> do+          setTexture da glyphAtlasTextureId+          let !invLen = (thickness * 0.5) / len+              !hx = (-dy) * invLen+              !hy = dx * invLen+          withVerts da 4 6 $ \vp ip vOff iOff baseIdxWord -> do+            let !(r, g, b, a) = unpackColorF col+                poke off px py = pokeVertexSIMD vp off px py r g b a whitePixelU whitePixelV+            poke vOff (px1 + hx) (py1 + hy)+            poke (vOff + 32) (px2 + hx) (py2 + hy)+            poke (vOff + 64) (px2 - hx) (py2 - hy)+            poke (vOff + 96) (px1 - hx) (py1 - hy)+            pokeQuadIndices ip iOff baseIdxWord (baseIdxWord + 1) (baseIdxWord + 2) (baseIdxWord + 3)++pushFilledTriangle :: DrawArena -> Float -> Float -> Float -> Float -> Float -> Float -> Color -> IO ()+pushFilledTriangle da x0 y0 x1 y1 x2 y2 col = do+  s <- readIORef (daSnapScale da)+  setTexture da glyphAtlasTextureId+  let !(r, g, b, a) = unpackColorF col+  withVerts da 3 3 $ \vp ip vOff iOff baseIdxWord -> do+    pokeVertexSIMD vp vOff (onGrid s x0) (onGrid s y0) r g b a whitePixelU whitePixelV+    pokeVertexSIMD vp (vOff + 32) (onGrid s x1) (onGrid s y1) r g b a whitePixelU whitePixelV+    pokeVertexSIMD vp (vOff + 64) (onGrid s x2) (onGrid s y2) r g b a whitePixelU whitePixelV+    pokeByteOff ip iOff baseIdxWord+    pokeByteOff ip (iOff + 4) (baseIdxWord + 1)+    pokeByteOff ip (iOff + 8) (baseIdxWord + 2)
+ lib/NanoUI/Draw/Text.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE StrictData #-}++-- | Text emitters (plain and synthetic-styled) and the 'DrawOp' interpreter.+module NanoUI.Draw.Text+  ( drawTextBox+  , pushText+  , pushTextStyled+  , emitDrawOps+  ) where++import Control.Monad (forM_, unless, when)+import Data.IORef (readIORef)+import qualified Data.Text as T+import Data.Primitive.SmallArray (SmallArray, indexSmallArray, sizeofSmallArray)+import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)+import Data.Word (Word32, Word8)+import Foreign.Ptr (Ptr)+import NanoUI.Draw.Arena+import NanoUI.Draw.Shapes+import NanoUI.Draw.Types (DrawArena (..), DrawOp (..), TextFont (..), glyphAtlasTextureId, indexSize, vertexSize)+import NanoUI.Font+  ( FontMetrics (..)+  , GlyphQuad (..)+  , ShapedGlyphs (..)+  , drawGlyph+  , drawShaped+  , kernedAdvance+  , lineWidth+  , prepareFontMetrics+  )+import NanoUI.SIMD (pokeQuadSIMD, pokeVertexSIMD)+import NanoUI.Style (FontStyle (..), FontWeight (..), TextDecoration (..))+import NanoUI.Types (Color (..), Rect (..), onGrid)++-- | Pixel box for a 'DrawText' using host advances. diagrams text has no+-- envelope, so plot sizing uses this instead of `fontSizeL`.+drawTextBox :: FontMetrics -> Float -> Float -> Float -> Float -> T.Text -> Rect+drawTextBox fm x y ax ay t =+  let tw = lineWidth fm t+      th = fmLineHeight fm+      px = x - tw * max 0 ax+      py =+        if ay < 0+          then y - fmAscent fm+          else y - th * (1 - ay)+   in Rect px py tw th++{-# INLINE pushText #-}+pushText :: DrawArena -> FontMetrics -> Float -> Float -> T.Text -> Color -> IO ()+pushText _da _fm _x _y txt _col | T.null txt = pure ()+pushText da fm x y txt col = do+  prepared <- prepareFontMetrics fm txt+  external <- readIORef (daExternalText da)+  unless external $ pushPreparedTextQuads da prepared x y txt col++{-# INLINE pushTextStyled #-}+pushTextStyled ::+  DrawArena ->+  FontMetrics ->+  FontWeight ->+  FontStyle ->+  TextDecoration ->+  Float ->+  Float ->+  T.Text ->+  Color ->+  IO ()+pushTextStyled da fm weight fstyle deco x y txt col = do+  prepared <- prepareFontMetrics fm txt+  external <- readIORef (daExternalText da)+  unless external $ pushPreparedTextStyledQuads da prepared weight fstyle deco x y txt col++-- Snapping the pen to the device pixel grid keeps every glyph quad on a whole+-- pixel. Advances, bearings, and ink sizes are all integer pixel counts divided+-- by the snap scale, so snapping the origin alone aligns the whole line:+-- otherwise fractional layout positions leave glyphs straddling pixel+-- boundaries, which makes nearest-sampled atlas text blurry and jitter as+-- scroll position changes.+pushPreparedTextQuads :: DrawArena -> FontMetrics -> Float -> Float -> T.Text -> Color -> IO ()+pushPreparedTextQuads da fm x y txt col = do+  let !px = onGrid (fmSnapScale fm) x+      !py = onGrid (fmSnapScale fm) y+  -- The host's shaped glyphs when it shapes, otherwise glyphs by character.+  drawShaped fm txt >>= \case+    Just glyphs -> pushShapedQuads da fm 0 px py glyphs col+    Nothing -> pushGlyphQuads da fm 0 px py txt col++-- | A shaped line's glyph quads from pen @(px, py)@, sheared by @slant@+-- around the baseline like 'pushGlyphQuads'.+pushShapedQuads :: DrawArena -> FontMetrics -> Float -> Float -> Float -> ShapedGlyphs -> Color -> IO ()+pushShapedQuads da fm slant px py (ShapedGlyphs quads) col = do+  let !count = sizeofPrimArray quads `div` 8+  when (count > 0) $ do+    setTexture da glyphAtlasTextureId+    withVertsReserve da (count * 4) (count * 6) $ \vp ip base baseIdx commit -> do+      let !(r, g, b, a) = unpackColorF col+          !baselineY = py + fmAscent fm+          at k = indexPrimArray quads k+          go !q+            | q >= count = pure ()+            | otherwise = do+                let !o = q * 8+                    !gx = px + at o+                    !gy = py + at (o + 1)+                    !gw = at (o + 2)+                    !gh = at (o + 3)+                    !u0 = at (o + 4)+                    !v0 = at (o + 5)+                    !u1 = at (o + 6)+                    !v1 = at (o + 7)+                pokeGlyphQuad vp ip base baseIdx slant baselineY r g b a q gx gy gw gh u0 v0 u1 v1+                go (q + 1)+      go 0+      commit (count * 4) (count * 6)++-- | Glyph quad @q@ of a text reservation whose vertices start at @base@ and+-- indices at @baseIdx@. A non-zero @slant@ shears the quad around+-- @baselineY@. INLINE: it runs per glyph and takes more arguments than GHC+-- unboxes for a call.+{-# INLINE pokeGlyphQuad #-}+pokeGlyphQuad ::+  Ptr Word8 ->+  Ptr Word8 ->+  Int ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+pokeGlyphQuad vp ip base baseIdx slant baselineY r g b a q gx gy gw gh u0 v0 u1 v1 = do+  let !vb = (base + q * 4) * vertexSize+      !ib = (baseIdx + q * 6) * indexSize+      !i0 = fromIntegral (base + q * 4) :: Word32+  if slant == 0+    then pokeQuadSIMD vp vb ip ib gx gy gw gh u0 v0 u1 v1 r g b a i0+    else do+      let !gy1 = gy + gh+          !topDx = slant * (baselineY - gy)+          !botDx = slant * (baselineY - gy1)+      pokeVertexSIMD vp vb (gx + topDx) gy r g b a u0 v0+      pokeVertexSIMD vp (vb + 32) (gx + gw + topDx) gy r g b a u1 v0+      pokeVertexSIMD vp (vb + 64) (gx + gw + botDx) gy1 r g b a u1 v1+      pokeVertexSIMD vp (vb + 96) (gx + botDx) gy1 r g b a u0 v1+      pokeQuadIndices ip ib i0 (i0 + 1) (i0 + 2) (i0 + 3)++-- | Glyph quads for one line from pen @(px, py)@, used as given: synthetic bold+-- relies on its sub-pixel pass offsets. Every quad shares one arena+-- reservation. A non-zero @slant@ shears glyphs around the shared baseline for+-- synthetic oblique, so stems stay parallel and descenders lean left. A glyph+-- the font lacks draws an upright advance box on the device grid.+pushGlyphQuads :: DrawArena -> FontMetrics -> Float -> Float -> Float -> T.Text -> Color -> IO ()+pushGlyphQuads da fm slant px py txt col = do+  let !cap = T.length txt+  when (cap > 0) $ do+    scale <- readIORef (daSnapScale da)+    setTexture da glyphAtlasTextureId+    withVertsReserve da (cap * 4) (cap * 6) $ \vp ip base baseIdx commit -> do+      let !(r, g, b, a) = unpackColorF col+          !baselineY = py + fmAscent fm+          walk !q !ox !prev !t =+            case T.uncons t of+              Nothing -> pure q+              Just (c, rest) -> do+                let !adv = kernedAdvance fm prev c+                    next !q' = walk q' (ox + adv) (Just c) rest+                drawGlyph fm c >>= \case+                  Nothing+                    | adv > 0 && c /= ' ' -> do+                        pokeGlyphQuad vp ip base baseIdx 0 baselineY r g b a q (onGrid scale ox) (onGrid scale py) adv (fmLineHeight fm) whitePixelU whitePixelV whitePixelU whitePixelV+                        next (q + 1)+                    | otherwise -> next q+                  Just gq -> do+                    pokeGlyphQuad vp ip base baseIdx slant baselineY r g b a q (ox + gqX gq) (py + gqY gq) (gqW gq) (gqH gq) (gqU0 gq) (gqV0 gq) (gqU1 gq) (gqV1 gq)+                    next (q + 1)+      !k <- walk 0 px Nothing txt+      commit (k * 4) (k * 6)++-- | Synthetic weight, slant and decoration over the plain text path. Upright+-- normal weight keeps the run path; every other pass walks glyphs.+pushPreparedTextStyledQuads :: DrawArena -> FontMetrics -> FontWeight -> FontStyle -> TextDecoration -> Float -> Float -> T.Text -> Color -> IO ()+pushPreparedTextStyledQuads da fm weight fstyle deco x y txt col+  | weight == WeightNormal && fstyle == FontStyleNormal && deco == DecorationNone =+      pushPreparedTextQuads da fm x y txt col+  | otherwise = do+      let !px = onGrid (fmSnapScale fm) x+          !py = onGrid (fmSnapScale fm) y+          !lh = fmLineHeight fm+          !bOff = max 1.0 (0.05 * lh)+          !slant = if fstyle == FontStyleNormal then 0 else 0.18+          -- Pen offsets, in bold steps, of the passes that synthesize a weight.+          passes = case weight of+            WeightNormal -> [0]+            WeightLight -> [0]+            WeightMedium -> [0, 0.5]+            WeightSemiBold -> [0, 0.75]+            WeightBold -> [0, 1]+            WeightExtraBold -> [0, 1, 1.5]+            WeightBlack -> [0, 1, 1.5, 2]+      if slant == 0 && weight == WeightNormal+        then pushPreparedTextQuads da fm px py txt col+        else do+          shaped <- drawShaped fm txt+          forM_ passes $ \k -> case shaped of+            Just glyphs -> pushShapedQuads da fm slant (px + k * bOff) py glyphs col+            Nothing -> pushGlyphQuads da fm slant (px + k * bOff) py txt col+      when (deco /= DecorationNone) $ do+        let !textW = lineWidth fm txt+            !thick = max 1.0 (0.06 * lh)+            underline = pushRect da (Rect px (py + fmAscent fm + max 1.0 (0.1 * lh)) textW thick) col+            strike = pushRect da (Rect px (py + fmAscent fm * 0.65) textW thick) col+        case deco of+          DecorationUnderline -> underline+          DecorationStrikethrough -> strike+          DecorationUnderlineStrike -> underline >> strike+          DecorationNone -> pure ()++-- | Emit ops with @fm@ as the default font and @resolve@ giving the font of+-- styled text, and whether it draws its weight and slant natively.+emitDrawOps :: DrawArena -> FontMetrics -> (TextFont -> IO (FontMetrics, Bool)) -> SmallArray DrawOp -> IO ()+emitDrawOps da fm resolve ops = go 0+  where+    go !i+      | i >= sizeofSmallArray ops = pure ()+      | otherwise = emitOne (indexSmallArray ops i) >> go (i + 1)+    emitOne (FillRect r c) = pushRect da r c+    emitOne (FillRoundedRect r radius c) = pushRoundedRect da r radius c+    emitOne (FillTriangle x0 y0 x1 y1 x2 y2 c) = pushFilledTriangle da x0 y0 x1 y1 x2 y2 c+    emitOne (FillCircle cx cy radius c) =+      pushRoundedRect da (Rect (cx - radius) (cy - radius) (2 * radius) (2 * radius)) radius c+    emitOne (Stroke x0 y0 x1 y1 t c) = pushStroke da x0 y0 x1 y1 t c+    emitOne (StrokeRoundedRect r radius bw c) = pushRoundedStroke da r radius bw c+    emitOne (StrokeCircle cx cy radius bw c) =+      pushRoundedStroke da (Rect (cx - radius) (cy - radius) (2 * radius) (2 * radius)) radius bw c+    emitOne (StrokeLineAA x0 y0 x1 y1 bw c) = pushStrokeAA da x0 y0 x1 y1 bw c+    emitOne (FillQuadGradient r c0 c1 c2 c3) = pushQuadGradient da r c0 c1 c2 c3+    emitOne (DrawImageRect r tex u0 v0 u1 v1 c) = pushImage da r tex u0 v0 u1 v1 c+    emitOne (DrawText x y ax ay t c) = do+      prepared <- prepareFontMetrics fm t+      let Rect px py _ _ = drawTextBox prepared x y ax ay t+      -- Drawing text has no collected text span, so it keeps its quads even+      -- when the host rasterizes widget text externally.+      pushPreparedTextQuads da prepared px py t c+    emitOne (DrawTextStyled x y font t c) = do+      (styledFm, native) <- resolve font+      let weight = if native then WeightNormal else textFontWeight font+          fstyle = if native then FontStyleNormal else textFontStyle font+      prepared <- prepareFontMetrics styledFm t+      pushPreparedTextStyledQuads da prepared weight fstyle (textFontDecoration font) x y t c
+ lib/NanoUI/Draw/Types.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE StrictData #-}++-- | Draw-layer data: immediate vector ops, batched draw commands, the finished+-- per-frame draw data and the arena record. Free of font and emitter code so+-- the context types can name these without depending on the emitters.+module NanoUI.Draw.Types+  ( Layer (..)+  , DrawOp (..)+  , TextFont (..)+  , defaultTextFont+  , DrawingBuild+  , shiftDrawOp+  , DrawCmd (..)+  , LayerSlice (..)+  , DrawData (..)+  , drawCmdCount+  , drawCmdNull+  , forDrawCmdsInLayer_+  , drawCmdElems+  , DrawArena (..)+  , BufferPool+  , vertexSize+  , indexSize+  , backdropDimTextureId+  , glyphAtlasTextureId+  ) where++import Data.IORef (IORef)+import Data.Primitive.PrimArray (MutablePrimArray, PrimArray, indexPrimArray, sizeofPrimArray)+import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#)+import qualified Data.Text as T+import Data.Primitive.SmallArray (SmallArray)+import Data.Word (Word32, Word8)+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr (Ptr)+import GHC.Exts+  ( Float (F#)+  , Int (I#)+  , RealWorld+  , (*#)+  , (+#)+  , indexFloatOffAddr#+  , indexIntOffAddr#+  , indexWord8Array#+  , indexWord8ArrayAsFloat#+  , indexWord8ArrayAsInt#+  , indexWord8ArrayAsWord32#+  , indexWord8OffAddr#+  , indexWord32OffAddr#+  , plusAddr#+  , readFloatOffAddr#+  , readIntOffAddr#+  , readWord8Array#+  , readWord8ArrayAsFloat#+  , readWord8ArrayAsInt#+  , readWord8ArrayAsWord32#+  , readWord8OffAddr#+  , readWord32OffAddr#+  , writeFloatOffAddr#+  , writeIntOffAddr#+  , writeWord8Array#+  , writeWord8ArrayAsFloat#+  , writeWord8ArrayAsInt#+  , writeWord8ArrayAsWord32#+  , writeWord8OffAddr#+  , writeWord32OffAddr#+  )+import GHC.Word (Word8 (W8#), Word32 (W32#))+import NanoUI.Style (FontStyle (..), FontVariant (..), FontWeight (..), TextDecoration (..))+import NanoUI.Types (Color (..), Rect (..))++data Layer = LayerBackground | LayerContent | LayerOverlay | LayerChrome+  deriving (Eq, Show, Enum, Bounded)++-- Immediate vector ops, in widget pixel space. diagrams (and other plotters)+-- flatten into this list; paint emits them after layout.+data DrawOp+  = FillRect !Rect !Color+  | FillRoundedRect !Rect {-# UNPACK #-} !Float !Color+  | FillTriangle+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Color+  | FillCircle+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Color+  | Stroke+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Color+  | StrokeRoundedRect !Rect {-# UNPACK #-} !Float {-# UNPACK #-} !Float !Color+  | StrokeCircle+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Color+  | StrokeLineAA+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Color+  | FillQuadGradient !Rect !Color !Color !Color !Color+  | DrawImageRect+      !Rect+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !Color+  | DrawText+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !T.Text+      !Color+  -- ^ Pen at (x, y) is the alignment point. ax 0..1 is left..right. ay 0..1 is+  -- bottom..top. ay < 0 means baseline (x is left, y is the baseline). Glyph size+  -- is the host font (`drawTextBox`).+  | DrawTextStyled+      {-# UNPACK #-} !Float+      {-# UNPACK #-} !Float+      !TextFont+      !T.Text+      !Color+  -- ^ Text in a font of its own, its line box's top left corner at (x, y).+  deriving (Eq)++-- | The font a 'DrawTextStyled' draws with: the same choices a label's+-- layout makes.+data TextFont = TextFont+  { textFontSize :: {-# UNPACK #-} !Float+  -- ^ Point size, @0@ for the theme's.+  , textFontVariant :: !FontVariant+  , textFontWeight :: !FontWeight+  , textFontStyle :: !FontStyle+  , textFontDecoration :: !TextDecoration+  }+  deriving (Eq, Show)++-- | The theme's regular font.+defaultTextFont :: TextFont+defaultTextFont = TextFont 0 FontRegular WeightNormal FontStyleNormal DecorationNone++-- | Translate every vertex in a 'DrawOp'. Paint reuses ops when only (x, y) moved.+shiftDrawOp :: Float -> Float -> DrawOp -> DrawOp+shiftDrawOp dx dy op =+  case op of+    FillRect (Rect x y w h) c -> FillRect (Rect (x + dx) (y + dy) w h) c+    FillRoundedRect (Rect x y w h) r c -> FillRoundedRect (Rect (x + dx) (y + dy) w h) r c+    FillTriangle x0 y0 x1 y1 x2 y2 c ->+      FillTriangle (x0 + dx) (y0 + dy) (x1 + dx) (y1 + dy) (x2 + dx) (y2 + dy) c+    FillCircle cx cy r c -> FillCircle (cx + dx) (cy + dy) r c+    Stroke x0 y0 x1 y1 t c -> Stroke (x0 + dx) (y0 + dy) (x1 + dx) (y1 + dy) t c+    StrokeRoundedRect (Rect x y w h) r bw c -> StrokeRoundedRect (Rect (x + dx) (y + dy) w h) r bw c+    StrokeCircle cx cy r bw c -> StrokeCircle (cx + dx) (cy + dy) r bw c+    StrokeLineAA x0 y0 x1 y1 bw c -> StrokeLineAA (x0 + dx) (y0 + dy) (x1 + dx) (y1 + dy) bw c+    FillQuadGradient (Rect x y w h) c0 c1 c2 c3 -> FillQuadGradient (Rect (x + dx) (y + dy) w h) c0 c1 c2 c3+    DrawImageRect (Rect x y w h) tex u0 v0 u1 v1 c -> DrawImageRect (Rect (x + dx) (y + dy) w h) tex u0 v0 u1 v1 c+    DrawText x y ax ay t c -> DrawText (x + dx) (y + dy) ax ay t c+    DrawTextStyled x y font t c -> DrawTextStyled (x + dx) (y + dy) font t c++type DrawingBuild = Rect -> SmallArray DrawOp++data DrawCmd = DrawCmd+  { cmdClipX :: {-# UNPACK #-} !Float+  , cmdClipY :: {-# UNPACK #-} !Float+  , cmdClipW :: {-# UNPACK #-} !Float+  , cmdClipH :: {-# UNPACK #-} !Float+  , cmdTextureId :: {-# UNPACK #-} !Int+  , cmdIndexOffset :: {-# UNPACK #-} !Word32+  , cmdIndexCount :: {-# UNPACK #-} !Word32+  , cmdLayer :: !Layer+  }+  deriving (Eq, Show)++data LayerSlice = LayerSlice+  { sliceOffset :: {-# UNPACK #-} !Int+  , sliceCount :: {-# UNPACK #-} !Int+  }+  deriving (Eq, Show)++-- Two packed Ints, 16 bytes, 8-byte aligned.+instance Prim LayerSlice where+  sizeOfType# _ = 16#+  alignmentOfType# _ = 8#+  indexByteArray# arr# i# =+    let o# = i# *# 16#+     in LayerSlice+          (I# (indexWord8ArrayAsInt# arr# o#))+          (I# (indexWord8ArrayAsInt# arr# (o# +# 8#)))+  readByteArray# arr# i# s0 =+    let o# = i# *# 16#+     in case readWord8ArrayAsInt# arr# o# s0 of+          (# s1, off# #) ->+            case readWord8ArrayAsInt# arr# (o# +# 8#) s1 of+              (# s2, cnt# #) -> (# s2, LayerSlice (I# off#) (I# cnt#) #)+  writeByteArray# arr# i# (LayerSlice (I# off#) (I# cnt#)) s0 =+    let o# = i# *# 16#+     in writeWord8ArrayAsInt# arr# (o# +# 8#) cnt# (writeWord8ArrayAsInt# arr# o# off# s0)+  setByteArray# = defaultSetByteArray#+  indexOffAddr# addr# i# =+    let a# = addr# `plusAddr#` (i# *# 16#)+     in LayerSlice (I# (indexIntOffAddr# a# 0#)) (I# (indexIntOffAddr# (a# `plusAddr#` 8#) 0#))+  readOffAddr# addr# i# s0 =+    let a# = addr# `plusAddr#` (i# *# 16#)+     in case readIntOffAddr# a# 0# s0 of+          (# s1, off# #) ->+            case readIntOffAddr# (a# `plusAddr#` 8#) 0# s1 of+              (# s2, cnt# #) -> (# s2, LayerSlice (I# off#) (I# cnt#) #)+  writeOffAddr# addr# i# (LayerSlice (I# off#) (I# cnt#)) s0 =+    let a# = addr# `plusAddr#` (i# *# 16#)+     in writeIntOffAddr# (a# `plusAddr#` 8#) 0# cnt# (writeIntOffAddr# a# 0# off# s0)+  setOffAddr# = defaultSetOffAddr#++{-# INLINE layerToWord8 #-}+layerToWord8 :: Layer -> Word8+layerToWord8 ly = fromIntegral (fromEnum ly)++{-# INLINE layerFromWord8 #-}+layerFromWord8 :: Word8 -> Layer+layerFromWord8 w = toEnum (fromIntegral w)++-- Clip floats (16) + Int tex (8) + two Word32 (8) + Layer Word8 + pad = 40.+instance Prim DrawCmd where+  sizeOfType# _ = 40#+  alignmentOfType# _ = 8#+  indexByteArray# arr# i# =+    let o# = i# *# 40#+     in DrawCmd+          (F# (indexWord8ArrayAsFloat# arr# o#))+          (F# (indexWord8ArrayAsFloat# arr# (o# +# 4#)))+          (F# (indexWord8ArrayAsFloat# arr# (o# +# 8#)))+          (F# (indexWord8ArrayAsFloat# arr# (o# +# 12#)))+          (I# (indexWord8ArrayAsInt# arr# (o# +# 16#)))+          (W32# (indexWord8ArrayAsWord32# arr# (o# +# 24#)))+          (W32# (indexWord8ArrayAsWord32# arr# (o# +# 28#)))+          (layerFromWord8 (W8# (indexWord8Array# arr# (o# +# 32#))))+  readByteArray# arr# i# s0 =+    let o# = i# *# 40#+     in case readWord8ArrayAsFloat# arr# o# s0 of+          (# s1, x# #) ->+            case readWord8ArrayAsFloat# arr# (o# +# 4#) s1 of+              (# s2, y# #) ->+                case readWord8ArrayAsFloat# arr# (o# +# 8#) s2 of+                  (# s3, w# #) ->+                    case readWord8ArrayAsFloat# arr# (o# +# 12#) s3 of+                      (# s4, h# #) ->+                        case readWord8ArrayAsInt# arr# (o# +# 16#) s4 of+                          (# s5, tex# #) ->+                            case readWord8ArrayAsWord32# arr# (o# +# 24#) s5 of+                              (# s6, off# #) ->+                                case readWord8ArrayAsWord32# arr# (o# +# 28#) s6 of+                                  (# s7, cnt# #) ->+                                    case readWord8Array# arr# (o# +# 32#) s7 of+                                      (# s8, ly# #) ->+                                        (# s8+                                         , DrawCmd+                                            (F# x#)+                                            (F# y#)+                                            (F# w#)+                                            (F# h#)+                                            (I# tex#)+                                            (W32# off#)+                                            (W32# cnt#)+                                            (layerFromWord8 (W8# ly#))+                                         #)+  writeByteArray# arr# i# cmd s0 =+    case cmd of+      DrawCmd (F# x#) (F# y#) (F# w#) (F# h#) (I# tex#) (W32# off#) (W32# cnt#) ly ->+        let o# = i# *# 40#+            !(W8# ly#) = layerToWord8 ly+         in writeWord8Array# arr# (o# +# 32#) ly# $+              writeWord8ArrayAsWord32# arr# (o# +# 28#) cnt# $+                writeWord8ArrayAsWord32# arr# (o# +# 24#) off# $+                  writeWord8ArrayAsInt# arr# (o# +# 16#) tex# $+                    writeWord8ArrayAsFloat# arr# (o# +# 12#) h# $+                      writeWord8ArrayAsFloat# arr# (o# +# 8#) w# $+                        writeWord8ArrayAsFloat# arr# (o# +# 4#) y# $+                          writeWord8ArrayAsFloat# arr# o# x# s0+  setByteArray# = defaultSetByteArray#+  indexOffAddr# addr# i# =+    let a# = addr# `plusAddr#` (i# *# 40#)+     in DrawCmd+          (F# (indexFloatOffAddr# a# 0#))+          (F# (indexFloatOffAddr# (a# `plusAddr#` 4#) 0#))+          (F# (indexFloatOffAddr# (a# `plusAddr#` 8#) 0#))+          (F# (indexFloatOffAddr# (a# `plusAddr#` 12#) 0#))+          (I# (indexIntOffAddr# (a# `plusAddr#` 16#) 0#))+          (W32# (indexWord32OffAddr# (a# `plusAddr#` 24#) 0#))+          (W32# (indexWord32OffAddr# (a# `plusAddr#` 28#) 0#))+          (layerFromWord8 (W8# (indexWord8OffAddr# (a# `plusAddr#` 32#) 0#)))+  readOffAddr# addr# i# s0 =+    let a# = addr# `plusAddr#` (i# *# 40#)+     in case readFloatOffAddr# a# 0# s0 of+          (# s1, x# #) ->+            case readFloatOffAddr# (a# `plusAddr#` 4#) 0# s1 of+              (# s2, y# #) ->+                case readFloatOffAddr# (a# `plusAddr#` 8#) 0# s2 of+                  (# s3, w# #) ->+                    case readFloatOffAddr# (a# `plusAddr#` 12#) 0# s3 of+                      (# s4, h# #) ->+                        case readIntOffAddr# (a# `plusAddr#` 16#) 0# s4 of+                          (# s5, tex# #) ->+                            case readWord32OffAddr# (a# `plusAddr#` 24#) 0# s5 of+                              (# s6, off# #) ->+                                case readWord32OffAddr# (a# `plusAddr#` 28#) 0# s6 of+                                  (# s7, cnt# #) ->+                                    case readWord8OffAddr# (a# `plusAddr#` 32#) 0# s7 of+                                      (# s8, ly# #) ->+                                        (# s8+                                         , DrawCmd+                                            (F# x#)+                                            (F# y#)+                                            (F# w#)+                                            (F# h#)+                                            (I# tex#)+                                            (W32# off#)+                                            (W32# cnt#)+                                            (layerFromWord8 (W8# ly#))+                                         #)+  writeOffAddr# addr# i# cmd s0 =+    case cmd of+      DrawCmd (F# x#) (F# y#) (F# w#) (F# h#) (I# tex#) (W32# off#) (W32# cnt#) ly ->+        let a# = addr# `plusAddr#` (i# *# 40#)+            !(W8# ly#) = layerToWord8 ly+         in writeWord8OffAddr# (a# `plusAddr#` 32#) 0# ly# $+              writeWord32OffAddr# (a# `plusAddr#` 28#) 0# cnt# $+                writeWord32OffAddr# (a# `plusAddr#` 24#) 0# off# $+                  writeIntOffAddr# (a# `plusAddr#` 16#) 0# tex# $+                    writeFloatOffAddr# (a# `plusAddr#` 12#) 0# h# $+                      writeFloatOffAddr# (a# `plusAddr#` 8#) 0# w# $+                        writeFloatOffAddr# (a# `plusAddr#` 4#) 0# y# $+                          writeFloatOffAddr# a# 0# x# s0+  setOffAddr# = defaultSetOffAddr#++data DrawData = DrawData+  { drawVertices :: ForeignPtr Word8+  , drawVertexCount :: {-# UNPACK #-} !Int+  , drawIndices :: ForeignPtr Word8+  , drawIndexCount :: {-# UNPACK #-} !Int+  , drawCommands :: !(PrimArray DrawCmd)+  , drawLayerSlices :: !(PrimArray LayerSlice)+  }++{-# INLINE drawCmdCount #-}+drawCmdCount :: DrawData -> Int+drawCmdCount dd = sizeofPrimArray (drawCommands dd)++{-# INLINE drawCmdNull #-}+drawCmdNull :: DrawData -> Bool+drawCmdNull dd = drawCmdCount dd == 0++{-# INLINE forDrawCmdsInLayer_ #-}+forDrawCmdsInLayer_ :: Layer -> DrawData -> (DrawCmd -> IO ()) -> IO ()+forDrawCmdsInLayer_ ly dd f =+  let LayerSlice off cnt = indexPrimArray (drawLayerSlices dd) (fromEnum ly)+      cmds = drawCommands dd+      go !i+        | i >= cnt = pure ()+        | otherwise = f (indexPrimArray cmds (off + i)) >> go (i + 1)+   in go 0++drawCmdElems :: DrawData -> [DrawCmd]+drawCmdElems dd =+  let cmds = drawCommands dd+   in [indexPrimArray cmds i | i <- [0 .. sizeofPrimArray cmds - 1]]++type BufferPool = IORef [(ForeignPtr Word8, Int)]++data DrawArena = DrawArena+  { daVertexFPtr :: !(IORef (ForeignPtr Word8))+  , daVertexPtr :: !(IORef (Ptr Word8))+  , daVertexCap :: !(IORef Int)+  , daVertexCount :: !(IORef Int)+  , daVertexPool :: !BufferPool+  , daIndexFPtr :: !(IORef (ForeignPtr Word8))+  , daIndexPtr :: !(IORef (Ptr Word8))+  , daIndexCap :: !(IORef Int)+  , daIndexCount :: !(IORef Int)+  , daIndexPool :: !BufferPool+  , daCmdStore :: !(IORef (MutablePrimArray RealWorld DrawCmd))+  , daCmdCount :: !(IORef Int)+  , daCmdCapacity :: !(IORef Int)+  , daCurrentLayer :: !(IORef Layer)+  , daCurrentClip :: !(MutablePrimArray RealWorld Float)+  -- ^ The current clip rect: x, y, width and height.+  , daCurrentTexture :: !(IORef Int)+  , daCmdStartIndex :: !(IORef Int)+  , daSnapScale :: !(IORef Float)+  , daSquareGeometry :: !(IORef Bool)+  , daExternalText :: !(IORef Bool)+  }++vertexSize :: Int+vertexSize = 32++indexSize :: Int+indexSize = 4++-- Reserved texture id. These quads act as a backdrop dim, not a solid fill.+-- Mix comes from the vertex color alpha.+backdropDimTextureId :: Int+backdropDimTextureId = 0x7ffffffe++-- Reserved texture id for the per-glyph SDL_ttf atlas. The renderer binds+-- the glyph atlas SDL_Texture when it sees this id. Glyphs are cached as+-- white-on-alpha so vertex color tints them at draw time.+glyphAtlasTextureId :: Int+glyphAtlasTextureId = 0x7ffffffd
+ lib/NanoUI/Emit.hs view
@@ -0,0 +1,91 @@+-- | Widgets for reducer-style applications.+--+-- Each function draws a widget from the model and, when the user changes it,+-- emits a message instead of returning the new value. The backend's reducer+-- runner (@runSdlAppReduce@, @runRgfwAppReduce@) folds the frame's messages+-- into the model with your update function.+--+-- The names match "NanoUI", so import this module qualified:+--+-- @+-- import NanoUI.Emit qualified as Emit+--+-- data Msg = Increment | Decrement+--+-- view :: Int -> NanoUI ()+-- view n = row $ do+--   Emit.button "-" Decrement+--   label (T.pack (show n))+--   Emit.button "+" Increment+-- @+module NanoUI.Emit+  ( emit+  , button+  , checkbox+  , slider+  , select+  , radio+  , textInput+  , textArea+  , tabs+  )+where++import Control.Monad (when)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Effectful (Eff, type (:>))+import NanoUI.Monad (Ui, emit)+import NanoUI.Widgets.Button qualified as W+import NanoUI.Widgets.Checkbox qualified as W+import NanoUI.Widgets.Node (respChanged)+import NanoUI.Widgets.Radio qualified as W+import NanoUI.Widgets.TextArea qualified as W+import NanoUI.Widgets.Select qualified as W+import NanoUI.Widgets.Slider qualified as W+import NanoUI.Widgets.Tabs (Tab)+import NanoUI.Widgets.Tabs qualified as W+import NanoUI.Widgets.TextInput qualified as W++-- | Emit @msg@ when the button is clicked.+button :: (Typeable msg, Ui :> es) => Text -> msg -> Eff es ()+button txt msg = do+  clicked <- W.button txt+  when clicked (emit msg)++checkbox :: (Typeable msg, Ui :> es) => Text -> Bool -> (Bool -> msg) -> Eff es ()+checkbox txt checked toMsg = do+  new <- W.checkbox txt checked+  when (new /= checked) (emit (toMsg new))++slider :: (Typeable msg, Ui :> es) => Float -> Float -> Float -> (Float -> msg) -> Eff es ()+slider minV maxV value toMsg = do+  new <- W.slider minV maxV value+  when (new /= value) (emit (toMsg new))++select :: (Foldable f, Typeable msg, Ui :> es) => f Text -> Int -> (Int -> msg) -> Eff es ()+select options index toMsg = do+  new <- W.select options index+  when (new /= index) (emit (toMsg new))++radio :: (Foldable f, Typeable msg, Ui :> es) => f Text -> Int -> (Int -> msg) -> Eff es ()+radio options index toMsg = do+  new <- W.radio options index+  when (new /= index) (emit (toMsg new))++textInput :: (Typeable msg, Ui :> es) => Text -> (Text -> msg) -> Eff es ()+textInput value toMsg = do+  new <- W.textInput value+  when (new /= value) (emit (toMsg new))++-- | Emit the new text after an edit. Caret and scroll changes emit nothing.+textArea :: (Typeable msg, Ui :> es) => Text -> (Text -> msg) -> Eff es ()+textArea value toMsg = do+  (resp, new) <- W.textArea' value+  when (respChanged resp && new /= value) (emit (toMsg new))++-- | Emit the newly active key when the user switches tabs.+tabs :: (Foldable f, Eq a, Typeable msg, Ui :> es) => a -> f (Tab a (Eff es ())) -> (a -> msg) -> Eff es ()+tabs active ts toMsg = do+  new <- W.tabs active ts+  when (new /= active) (emit (toMsg new))
+ lib/NanoUI/Font.hs view
@@ -0,0 +1,640 @@+{-# LANGUAGE StrictData #-}++module NanoUI.Font+  ( GlyphQuad (..)+  , ShapedText (..)+  , ShapedGlyphs (..)+  , FontMetrics (..)+  , FontBackend (..)+  , CustomMeasureFn+  , prepareFontMetrics+  , prepareFontMetricsMany+  , measureTextIO+  , lineWidthIO+  , drawShaped+  , drawGlyph+  , caretX+  , caretXIO+  , selectionSpans+  , monospaceMetrics+  , scaleFontMetrics+  , measureTextWrappedIO+  , wrapTextLinesIO+  , truncateTextIO+  , lineWidth+  , kernedAdvance+  , textIndexAtX+  , tableCellInset+  , widgetContentInset+  , widgetPadding+  , buttonPadding+  , selectPadding+  , menuOuterPad+  , menuItemPadX+  , menuItemRowH+  , menuSepH+  , menuMinW+  , menuAccentW+  , menuAccentInset+  , centeredTextY+  , alignedTextPen+  , textInkEnd+  , isDefaultNodeFont+  , checkboxBoxSize+  , checkboxLeading+  , treeItemPadding+  , treeRowLeading+  , treeChevronRect+  , scrollBarWidth+  , scrollBarSideGap+  , scrollBarGeomFor+  , scrollBarGap+  , scrollBarGutter+  , ScrollBarSlot (..)+  , classifyScrollBar+  , scrollLayoutGutter+  , sliderTrackBounds+  , sliderTrackHeight+  , sliderHandleDiameter+  , sliderHandleSlack+  ) where++import qualified Data.Map.Strict as Map+import Data.Primitive.PrimArray (PrimArray, imapPrimArray, indexPrimArray, mapPrimArray, sizeofPrimArray)+import Data.Text (Text)+import qualified Data.Text as T+import NanoUI.Types (Rect (..), onGrid)+import NanoUI.Style (AlignX (..), FontStyle (..), FontVariant (..), FontWeight (..))++data GlyphQuad = GlyphQuad+  { gqX :: {-# UNPACK #-} !Float+  , gqY :: {-# UNPACK #-} !Float+  , gqW :: {-# UNPACK #-} !Float+  , gqH :: {-# UNPACK #-} !Float+  , gqU0 :: {-# UNPACK #-} !Float+  , gqV0 :: {-# UNPACK #-} !Float+  , gqU1 :: {-# UNPACK #-} !Float+  , gqV1 :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++-- | A line of text as the host's shaper laid it out: glyphs chosen and placed+-- with the font's kerning, ligatures and contextual forms, in fallback fonts+-- where the font lacks a character, and right-to-left runs reordered.+data ShapedText = ShapedText+  { stAdvance :: {-# UNPACK #-} !Float+  , stInkEnd :: {-# UNPACK #-} !Float+  -- ^ The right edge of the rightmost glyph's ink.+  , stCarets :: !(PrimArray Float)+  -- ^ Where the caret sits before each character, and after the last: one+  -- more entry than the text has characters. A right-to-left run's carets+  -- decrease, and the characters of a cluster share its width.+  }+  deriving (Eq, Show)++-- | The glyph quads that draw a shaped line: eight numbers a glyph (x, y,+-- width and height from the pen, then the atlas UVs u0 v0 u1 v1), in logical+-- pixels. Valid until the host's glyph atlas next resets.+newtype ShapedGlyphs = ShapedGlyphs (PrimArray Float)+  deriving (Eq, Show)++data FontMetrics = FontMetrics+  { fmLineHeight :: {-# UNPACK #-} !Float+  , fmAscent :: {-# UNPACK #-} !Float+  -- | Device pixels per logical unit used to snap glyph quads to the pixel+  -- grid. The SDL backend sets this to the display scale so text lands on+  -- whole device pixels.+  , fmSnapScale :: {-# UNPACK #-} !Float+  , fmAdvance :: Char -> Float+  , fmKerning :: Char -> Char -> Float+  , fmShape :: Text -> Maybe ShapedText+  -- ^ The shaped layout of a text the snapshot was prepared for, when the+  -- host shapes. Other texts fall back to 'fmAdvance' and 'fmKerning'.+  , fmGlyph :: Char -> Maybe GlyphQuad+  -- | Optional effectful backend. Pure callbacks above are immutable metric+  -- snapshots; they must never perform font loading or atlas mutation.+  , fmBackend :: Maybe FontBackend+  }++-- | Text preparation performs font queries in IO and returns an immutable+-- snapshot for pure layout. Rasterisation is separate and occurs during draw.+data FontBackend = FontBackend+  { fbPrepare :: Text -> IO FontMetrics+  , fbDrawShaped :: Text -> IO (Maybe ShapedGlyphs)+  , fbDrawGlyph :: Char -> IO (Maybe GlyphQuad)+  }++-- | Custom node measurement: font metrics and available (width, height) to+-- the node's desired (width, height).+type CustomMeasureFn = FontMetrics -> (Float, Float) -> (Float, Float)++{-# INLINE prepareFontMetrics #-}+prepareFontMetrics :: FontMetrics -> Text -> IO FontMetrics+prepareFontMetrics fm txt = case fmBackend fm of+  Nothing -> pure fm+  Just backend -> fbPrepare backend txt++-- | Prepare a finite text workspace for pure multi-label layout algorithms.+prepareFontMetricsMany :: FontMetrics -> [Text] -> IO FontMetrics+prepareFontMetricsMany fm texts = case fmBackend fm of+  Nothing -> pure fm+  Just _ -> do+    combined <- prepareFontMetrics fm (T.intercalate "\n" texts)+    shapes <- mapM (\t -> do+      prepared <- prepareFontMetrics fm t+      pure (t, fmShape prepared t)) texts+    let !byText = Map.fromList shapes+    pure combined {fmShape = \t -> Map.findWithDefault Nothing t byText}++{-# INLINE lineWidthIO #-}+lineWidthIO :: FontMetrics -> Text -> IO Float+lineWidthIO fm txt = do+  prepared <- prepareFontMetrics fm txt+  pure $! lineWidth prepared txt++{-# INLINE measureTextIO #-}+measureTextIO :: FontMetrics -> Text -> IO (Float, Float)+measureTextIO fm txt = do+  prepared <- prepareFontMetrics fm txt+  pure $! measureText prepared txt++-- | The glyph quads of a shaped line, placing glyphs in the host's atlas as+-- needed; 'Nothing' when the host does not shape.+{-# INLINE drawShaped #-}+drawShaped :: FontMetrics -> Text -> IO (Maybe ShapedGlyphs)+drawShaped fm txt = case fmBackend fm of+  Nothing -> pure Nothing+  Just backend -> fbDrawShaped backend txt++{-# INLINE drawGlyph #-}+drawGlyph :: FontMetrics -> Char -> IO (Maybe GlyphQuad)+drawGlyph fm c = case fmBackend fm of+  Nothing -> pure (fmGlyph fm c)+  Just backend -> fbDrawGlyph backend c++monospaceMetrics :: Float -> FontMetrics+monospaceMetrics cell =+  FontMetrics+    { fmLineHeight = cell+    , fmAscent = cell * 0.8+    , fmSnapScale = 1.0+    , fmAdvance = \_ -> cell+    , fmKerning = \_ _ -> 0+    , fmShape = \_ -> Nothing+    , fmGlyph = \_ -> Nothing+    , fmBackend = Nothing+    }++scaleFontMetrics :: Float -> FontMetrics -> FontMetrics+scaleFontMetrics s fm+  | s == 1.0 = fm+  | otherwise =+      FontMetrics+        { fmLineHeight = fmLineHeight fm * s+        , fmAscent = fmAscent fm * s+        -- Snap scale is a display property, not a font-size property.+        , fmSnapScale = fmSnapScale fm+        , fmAdvance = \c -> fmAdvance fm c * s+        , fmKerning = \a b -> fmKerning fm a b * s+        , fmShape = \t -> fmap scaleShape (fmShape fm t)+        , fmGlyph = fmap scaleGlyph . fmGlyph fm+        , fmBackend = fmap scaleBackend (fmBackend fm)+        }+  where+    scaleBackend backend = FontBackend+      { fbPrepare = \t -> scaleFontMetrics s <$> fbPrepare backend t+      , fbDrawShaped = \t -> fmap (fmap scaleGlyphs) (fbDrawShaped backend t)+      , fbDrawGlyph = \c -> fmap (fmap scaleGlyph) (fbDrawGlyph backend c)+      }+    scaleGlyph gq = gq+      { gqX = gqX gq * s, gqY = gqY gq * s+      , gqW = gqW gq * s, gqH = gqH gq * s+      }+    scaleShape st =+      st+        { stAdvance = stAdvance st * s+        , stInkEnd = stInkEnd st * s+        , stCarets = mapPrimArray (* s) (stCarets st)+        }+    -- UVs stay in normalised atlas space; only positions and sizes scale.+    scaleGlyphs (ShapedGlyphs quads) =+      ShapedGlyphs (imapPrimArray (\i v -> if i `mod` 8 < 4 then v * s else v) quads)++-- | Horizontal text inset of a table cell. Zebra and header fills use the full cell rect.+tableCellInset :: Float+tableCellInset = 6++{-# INLINE widgetContentInset #-}+widgetContentInset :: FontMetrics -> (Float, Float)+widgetContentInset fm =+  let pad = fmAdvance fm ' ' * 1.25+   in (pad, pad)++{-# INLINE buttonPadding #-}+buttonPadding :: FontMetrics -> (Float, Float)+buttonPadding fm =+  let adv = fmAdvance fm ' '+      lh = fmLineHeight fm+   in (adv * 2.0, lh * 0.30)++{-# INLINE selectPadding #-}+selectPadding :: FontMetrics -> (Float, Float)+selectPadding fm =+  let adv = fmAdvance fm ' '+      lh = fmLineHeight fm+   in (adv * 2.0, lh * 0.50)++-- Menu metrics shared by the text-field context menu painter, the generic+-- context-menu widgets, and the layout/paint passes, so both menus render+-- identically by construction.++-- | Blank border between the menu panel edge and its rows.+menuOuterPad :: Float+menuOuterPad = 6++-- | Extra horizontal inset of a menu row's label past 'menuOuterPad'.+menuItemPadX :: Float+menuItemPadX = 10++-- | Fixed height of one menu row.+menuItemRowH :: Float+menuItemRowH = 28++-- | Height of a separator band inside a menu.+menuSepH :: Float+menuSepH = 9++-- | Floor for the menu panel width.+menuMinW :: Float+menuMinW = 148++-- | Width of the hover accent marker painted at a menu row's left edge.+menuAccentW :: Float+menuAccentW = 2++-- | Gap between the hover accent marker and the row's top and bottom edges.+menuAccentInset :: Float+menuAccentInset = 3++{-# INLINE centeredTextY #-}+centeredTextY :: FontMetrics -> Float -> Float -> Float -> Float+centeredTextY fm y h th =+  case fmGlyph fm 'H' of+    Nothing -> y + (h - th) / 2+    Just gq -> y + onGrid (fmSnapScale fm) (h / 2 - (gqY gq + gqH gq / 2))+  where+    -- Snap the (constant) baseline offset to the device grid rather than the+    -- whole pen: pen = snap(y + offset) rounds a fractional offset with ties+    -- to even, so adjacent rows (and the same row across a sub-pixel scroll)+    -- land on alternating device pixels while the geometry beside them stays+    -- rigid. Snapping only the constant offset keeps every row fixed on the+    -- grid no matter where y falls.++-- Origin and used width inside the node box, inset on all AlignX sides.+{-# INLINE alignedTextBox #-}+alignedTextBox :: AlignX -> Float -> Float -> Float -> Float -> (Float, Float)+alignedTextBox ax x w ix tw =+  let contentW = max 0 (w - 2 * ix)+      used = min tw contentW+      tx = case ax of+        AlignEnd -> x + w - ix - used+        AlignCenter -> x + ix + (contentW - used) / 2+        AlignStart -> x + ix+   in (tx, used)++-- Last glyph ink right in the same space as 'pushText' (pen + gqX + gqW).+-- Falls back to advance when 'fmGlyph' is Nothing (tests).+textInkEnd :: FontMetrics -> Text -> Float+textInkEnd fm txt =+  case T.unsnoc txt of+    Nothing -> 0+    Just (prefix, c) ->+      case fmShape fm txt of+        Just st -> stInkEnd st+        Nothing ->+          let pen = lineWidth fm prefix+           in case fmGlyph fm c of+                Just gq -> pen + gqX gq + gqW gq+                Nothing -> pen + fmAdvance fm c++-- Align using per-glyph advances (same as 'pushText'), not TTF_GetStringSize.+-- When the line fits, AlignEnd/Center shift by ink so the visual right edge+-- stays put as the last character's right bearing changes.+alignedTextPen :: AlignX -> Float -> Float -> Float -> FontMetrics -> Text -> (Float, Float)+alignedTextPen ax x w ix fm txt =+  let tw = lineWidth fm txt+      ink = textInkEnd fm txt+      contentW = max 0 (w - 2 * ix)+      used = min tw contentW+      shift =+        if tw > contentW+          then used+          else case ax of+            AlignStart -> used+            _ -> ink+      (tx, _) = alignedTextBox ax x w ix shift+   in (tx, used)++{-# INLINE widgetPadding #-}+widgetPadding :: FontMetrics -> (Float, Float)+widgetPadding fm =+  let (cx, cy) = widgetContentInset fm+   in (2 * cx, 2 * cy)++{-# INLINE checkboxBoxSize #-}+checkboxBoxSize :: FontMetrics -> Float+checkboxBoxSize fm = min 22 (max 18 (fmLineHeight fm * 1.15))++{-# INLINE checkboxLeading #-}+checkboxLeading :: FontMetrics -> Float+checkboxLeading fm = checkboxBoxSize fm + 8++{-# INLINE treeItemPadding #-}+treeItemPadding :: FontMetrics -> (Float, Float)+treeItemPadding fm =+  let lh = fmLineHeight fm+   in (0, max 8 (fromIntegral (round (lh * 0.40) :: Int)))++{-# INLINE treeIndentStep #-}+treeIndentStep :: FontMetrics -> Float+treeIndentStep fm = max 12 (fmLineHeight fm * 0.85)++{-# INLINE treeChevronLeading #-}+treeChevronLeading :: FontMetrics -> Float+treeChevronLeading fm = checkboxBoxSize fm + 6++{-# INLINE treeRowLeading #-}+treeRowLeading :: FontMetrics -> Int -> Float+treeRowLeading fm depth =+  treeIndentStep fm * fromIntegral (max 0 depth) + treeChevronLeading fm++{-# INLINE treeChevronRect #-}+treeChevronRect :: FontMetrics -> Float -> Float -> Float -> Float -> Int -> Rect+treeChevronRect fm x y _w h depth =+  let indent = treeIndentStep fm * fromIntegral (max 0 depth)+      lead = max 1 (treeChevronLeading fm)+   in Rect (x + indent) y lead h++sliderTrackHeight :: Float+sliderTrackHeight = 10++sliderHandleDiameter :: Float+sliderHandleDiameter = 18++sliderHandleSlack :: Float+sliderHandleSlack = (sliderHandleDiameter - sliderTrackHeight) / 2++{-# INLINE sliderTrackBounds #-}+sliderTrackBounds :: Float -> Float -> Float -> Float -> Rect+sliderTrackBounds x y w h =+  let trackY = y + max 0 ((h - sliderTrackHeight) / 2)+   in Rect x trackY (max 0 w) sliderTrackHeight++-- | Thickness of a list or page scrollbar.+scrollBarWidth :: Float+scrollBarWidth = 8++-- Window bodies take a slimmer bar.+scrollBarSlimWidth :: Float+scrollBarSlimWidth = 4++scrollBarMargin :: Float+scrollBarMargin = 3++-- | The sliver between a page or window bar and the outer edge, and the+-- smallest gap on either side of a list bar.+scrollBarSideGap :: Float+scrollBarSideGap = 3++-- | Bar width and end margin for a slot.+scrollBarGeomFor :: ScrollBarSlot -> (Float, Float)+scrollBarGeomFor slot =+  case slot of+    ScrollBarList -> (scrollBarWidth, scrollBarMargin)+    ScrollBarPage -> (scrollBarWidth, scrollBarMargin)+    -- Window bar: side gaps only. No end inset.+    ScrollBarWindow -> (scrollBarSlimWidth, 0)++-- | The layout arena stores a scroller's slot as its 'Enum' value, and every+-- other node reads a zero there, so 'ScrollBarList' comes first.+data ScrollBarSlot = ScrollBarList | ScrollBarPage | ScrollBarWindow+  deriving (Eq, Show, Enum)++classifyScrollBar :: Bool -> Bool -> ScrollBarSlot+classifyScrollBar isWindowBody isPageGrow+  | isWindowBody = ScrollBarWindow+  | isPageGrow = ScrollBarPage+  | otherwise = ScrollBarList++-- | Gap between the content and a bar, given the padding @trailPad@ on the+-- bar's side: the padding itself, never under 'scrollBarSideGap'.+scrollBarGap :: Float -> Float+scrollBarGap trailPad = max scrollBarSideGap trailPad++-- | Space an overflowing scroller takes from its content, beside the padding+-- @trailPad@ on the bar's side, so the content stops one gap before the bar.+-- A list bar keeps a gap to its well's edge as well. A page bar sits a side+-- gap inside the page's edge. A window body's bar sits out in the window's+-- padding, a side gap inside the window's edge, so that padding is the gap+-- and only the bar and the side gap come out of the content.+scrollBarGutter :: ScrollBarSlot -> Float -> Float+scrollBarGutter slot trailPad =+  let (barW, _) = scrollBarGeomFor slot+      gap = scrollBarGap trailPad+   in case slot of+        ScrollBarList -> barW + 2 * gap - trailPad+        ScrollBarPage -> barW + scrollBarSideGap + gap - trailPad+        ScrollBarWindow -> barW + scrollBarSideGap++scrollLayoutGutter :: ScrollBarSlot -> Float -> Float -> Float -> Float+scrollLayoutGutter slot trailPad contentSize innerMain+  | contentSize <= innerMain = 0+  | otherwise = scrollBarGutter slot trailPad++measureText :: FontMetrics -> Text -> (Float, Float)+measureText fm txt =+  let h = fmLineHeight fm+      w = lineWidth fm txt+   in (w, h)++-- | The one policy for "does this node use the ambient base font, or does it+-- need the host resolver?". A zero size with a plain weight/style and the+-- regular or mono variant resolves to the pre-read base metrics; everything+-- else (heading/muted/danger, bold, italic, explicit size) defers to the host.+-- Layout, paint, span placement and hit testing all share this so they cannot+-- pick different faces for the same node.+{-# INLINE isDefaultNodeFont #-}+isDefaultNodeFont :: Float -> FontWeight -> FontStyle -> FontVariant -> Bool+isDefaultNodeFont size weight style variant =+  size <= 0+    && weight == WeightNormal+    && style == FontStyleNormal+    && (variant == FontRegular || variant == FontMono)++-- | Advance of @c@ plus its kerning against the previous character: the one+-- pen step shared by measuring, hit testing and glyph emission.+{-# INLINE kernedAdvance #-}+kernedAdvance :: FontMetrics -> Maybe Char -> Char -> Float+kernedAdvance fm prev c = case prev of+  Nothing -> fmAdvance fm c+  Just p -> fmAdvance fm c + fmKerning fm p c++-- | The character index whose caret is nearest @x@: from the shaped carets+-- when the text was prepared by a shaping host, which handles clusters and+-- right-to-left runs, and otherwise from the same advances and kerning as+-- 'NanoUI.Draw.pushText', so the caret lands where the glyph to its left was+-- drawn.+textIndexAtX :: FontMetrics -> Text -> Float -> Int+textIndexAtX fm txt x+  | T.null txt = 0+  | Just st <- fmShape fm txt =+      let carets = stCarets st+          n = sizeofPrimArray carets+          nearest !best !bestD !i+            | i >= n = best+            | otherwise =+                let d = abs (indexPrimArray carets i - x)+                 in if d < bestD then nearest i d (i + 1) else nearest best bestD (i + 1)+       in nearest 0 (1 / 0) 0+  | x <= 0 = 0+  | otherwise = go 0 0.0 Nothing txt+  where+    go !i !acc prev t =+      case T.uncons t of+        Nothing -> i+        Just (c, rest) ->+          let adv = kernedAdvance fm prev c+              mid = acc + adv * 0.5+           in if x < mid then i else go (i + 1) (acc + adv) (Just c) rest++-- | Where the caret before character @i@ of @txt@ sits: a shaped caret when+-- the snapshot was prepared for @txt@, else the width of the characters+-- before it.+caretX :: FontMetrics -> Text -> Int -> Float+caretX fm txt i = case fmShape fm txt of+  Just st ->+    let carets = stCarets st+     in if sizeofPrimArray carets == 0 then 0 else indexPrimArray carets (max 0 (min (sizeofPrimArray carets - 1) i))+  Nothing -> lineWidth fm (T.take i txt)++caretXIO :: FontMetrics -> Text -> Int -> IO Float+caretXIO fm txt i = do+  prepared <- prepareFontMetrics fm txt+  pure $! caretX prepared txt i++-- | The horizontal extents covering characters @lo@ to @hi@: one span for+-- left-to-right text, and a span per direction run where a selection crosses+-- right-to-left text.+selectionSpans :: FontMetrics -> Text -> Int -> Int -> [(Float, Float)]+selectionSpans fm txt lo hi+  | hi <= lo = []+  | Just st <- fmShape fm txt =+      let carets = stCarets st+          n = sizeofPrimArray carets - 1+          charSpan i =+            let a = indexPrimArray carets i+                b = indexPrimArray carets (i + 1)+             in (min a b, max a b)+          merge [] = []+          merge [one] = [one]+          merge ((a0, a1) : (b0, b1) : rest)+            | b0 <= a1 + 0.5 && b1 >= a0 - 0.5 = merge ((min a0 b0, max a1 b1) : rest)+            | otherwise = (a0, a1) : merge ((b0, b1) : rest)+       in merge [charSpan i | i <- [max 0 lo .. min n hi - 1]]+  | otherwise = [(caretX fm txt lo, caretX fm txt hi)]++lineWidth :: FontMetrics -> Text -> Float+lineWidth fm line+  | T.null line = 0+  | otherwise =+      case fmShape fm line of+        Just st -> stAdvance st+        Nothing ->+          let !spaceAdv = fmAdvance fm ' '+              !xAdv = fmAdvance fm 'x'+              !mAdv = fmAdvance fm 'M'+           in if spaceAdv == xAdv && xAdv == mAdv && fmKerning fm 'x' 'M' == 0+                then fromIntegral (T.length line) * spaceAdv+                else case T.uncons line of+                  Just (c0, rest) ->+                    fst (T.foldl' step (fmAdvance fm c0, c0) rest)+                  Nothing -> 0+  where+    step (!w, !prev) c = (w + kernedAdvance fm (Just prev) c, c)++measureTextWrappedIO :: (Text -> IO Float) -> FontMetrics -> Text -> Float -> IO (Float, Float)+measureTextWrappedIO lineW fm txt maxW = do+  textLines <- wrapTextLinesIO lineW txt maxW+  ws <- mapM lineW textLines+  let lineH = fmLineHeight fm+  pure $ case textLines of+    [] -> (0, lineH)+    _ -> (min maxW (maximum ws), lineH * fromIntegral (length textLines))++-- | Wrap each paragraph to @maxW@ using the host line measure: whole words+-- first, characters for words (or paragraphs) that cannot fit.+wrapTextLinesIO :: (Text -> IO Float) -> Text -> Float -> IO [Text]+wrapTextLinesIO lineW txt maxW = concat <$> mapM wrapParagraph (T.lines txt)+  where+    wrapParagraph para+      | maxW <= 0 = pure []+      | T.null para = pure [""]+      | otherwise = do+          w <- lineW para+          if w <= maxW+            then pure [para]+            else if T.any (== ' ') para+              then wrapWords (T.words para) []+              else reverse <$> charLines para []+    wrapWords [] acc = pure (reverse acc)+    wrapWords (word : wordsLeft) acc = case acc of+      [] -> startLine word wordsLeft acc+      line : rest -> do+        let candidate = line <> " " <> word+        width <- lineW candidate+        if width <= maxW+          then wrapWords wordsLeft (candidate : rest)+          else startLine word wordsLeft acc+    startLine word wordsLeft acc = do+      width <- lineW word+      if width <= maxW+        then wrapWords wordsLeft (word : acc)+        else do+          broken <- charLines word []+          wrapWords wordsLeft (broken ++ acc)+    charLines chunk acc+      | T.null chunk = pure acc+      | otherwise = do+          (line, rest) <- takeWidth lineW maxW chunk+          if T.null line+            then pure acc+            else charLines rest (line : acc)++-- Always consume at least one character from non-empty text, even when a+-- single glyph exceeds the available width, so wrapping makes progress.+takeWidth :: (Text -> IO Float) -> Float -> Text -> IO (Text, Text)+takeWidth lineW maxW txt+  | T.null txt = pure (txt, T.empty)+  | otherwise = (`T.splitAt` txt) <$> maxFit 1 (T.length txt)+  where+    maxFit lo hi+      | lo >= hi = pure lo+      | otherwise = do+          let mid = (lo + hi + 1) `div` 2+          ok <- (<= maxW) <$> lineW (T.take mid txt)+          if ok then maxFit mid hi else maxFit lo (mid - 1)++truncateTextIO :: (Text -> IO Float) -> Float -> Text -> IO Text+truncateTextIO lineW maxW txt+  | maxW <= 0 = pure ""+  | otherwise = do+      w <- lineW txt+      if w <= maxW+        then pure txt+        else do+          ellW <- lineW "..."+          if maxW <= ellW+            then fst <$> takeWidth lineW maxW txt+            else do+              (fit, _) <- takeWidth lineW (maxW - ellW) txt+              pure (T.dropWhileEnd (== '.') fit <> "...")
+ lib/NanoUI/Frame.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE DataKinds #-}++module NanoUI.Frame+  ( runFrame+  , runFrameEff+  , runFrameReduce+  , runFrameReduceEff+  , needsRedraw+  , pointerDragActive+  , textFieldActive+  , floatingPanelActive+  , debugPanelOpen+  , collectTextSpans+  , collectOverlayTextSpans+  , collectRasterSpans+  , widgetNodeCount+  , pointerCursorWanted+  , cursorKindIs+  , uiCursorKind+  , UiCursorKind (..)+  )+where++import Control.Monad (unless, when)+import Data.IORef (modifyIORef', readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Typeable (Typeable)+import Effectful (Eff, IOE, runEff, type (:>))+import NanoUI.Context+  ( Context (..)+  , armMenuPointerCapture+  , beginThemeScopes+  , damageFull+  , themeScopesChanged+  , FrameMsg (..)+  , clearDirty+  , decodeMessages+  , drainMessages+  , getLiveAnimations+  , getPrevRect+  , getStore+  , isDirty+  , lookupPopupConfig+  , markDirty+  , pruneDrawOpCache+  , resetDrawingScopeCache+  , setMenuPointerGesture+  , stepScrollGlides+  , takeDamage+  , tickAnimations+  , lookupCustomMeasure+  , hasCustomLayoutInputs+  , ensureMetricCaches+  , InteractionState (..)+  , getsOverlay+  , OverlayState (..)+  , getsDamage+  , DamageState (..)+  , modifyInteraction+  )+import NanoUI.Context (beginFrameModal)+import NanoUI.Damage (FrameSnapshot (..), updatePrevRects, writeDamage)+import NanoUI.Draw+  ( DrawData+  , Layer (..)+  , beginLayer+  , finishDraw+  , pushRect+  , resetDrawArena+  , setClip+  )+import NanoUI.Frame.Cursor+  ( UiCursorKind (..)+  , cursorKindIs+  , pointerCursorWanted+  , uiCursorKind+  )+import NanoUI.Frame.Input+  ( armPointerPress+  , disarmPointerPress+  , finalizePointerPress+  , finalizePointerRelease+  , finalizeSelectFocus+  , finalizeTabFocus+  , finalizeTextInputFocus+  , refreshHover+  )+import NanoUI.Frame.Focus (constrainFocusToModal, syncWidgetLabels)+import NanoUI.Frame.Paint (lowerShapes)+import NanoUI.Frame.Redraw+  ( debugPanelOpen+  , floatingPanelActive+  , needsRedraw+  , overlayMenuOpen+  , pointerDragActive+  , textFieldActive+  )+import NanoUI.Frame.Scroll+  ( applyScrollOffsets+  , updateScrollDrag+  , updateScrollWheel+  )+import NanoUI.Frame.Select+  ( cacheOpenSelectDrop+  , closeSelectOnOutsideClick+  , drawSelectOverlays+  , finalizeSelectKeyboard+  , finalizeSelectPick+  , markSelectDropPress+  )+import NanoUI.Frame.Spans+  ( collectOverlayTextSpans+  , collectRasterSpans+  , collectTextSpans+  , widgetNodeCount+  )+import NanoUI.Frame.Overlay (drawModalOverlays, drawPopupOverlays, drawWindowOverlays)+import NanoUI.Frame.TextEdit (finalizeTextFieldMouse)+import NanoUI.Frame.TextEdit.Menu+  ( closeTextEditMenuOnEscape+  , closeTextEditMenuOnOutsideClick+  , drawTextEditMenuOverlays+  , finalizeTextEditMenuPick+  , openTextEditMenu+  )+import NanoUI.Frame.Window+  ( lookupWindowPos+  , lookupWindowSize+  , persistWindowPositions+  , updateWindowDrag+  , updateWindowResize+  )+import NanoUI.Id (WidgetId (..), initialIdContext)+import NanoUI.Input (Input (..), inputMouseDown, stripInteractionInput)+import NanoUI.Layout.Arena+  ( captureLayoutCache+  , layoutCacheEligible+  , layoutInputsMatch+  , newLayoutCache+  , resetNodeArena+  , restoreLayoutCache+  )+import NanoUI.Layout.Solve (placeModals, placePopups, placeWindows, solveLayout)+import NanoUI.Monad (NanoUI, Ui, runUi, whenM)+import NanoUI.Store (mirrorStoresChanged)+import NanoUI.Style (Theme (..))+import NanoUI.Types (Damage (..), Size (..), rectInflate, rectNonEmpty)++runFrame :: Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)+runFrame = runFrameEff runEff++-- View this model, then apply decoded messages at frame end.+-- DrawData is from the pre-reduce model (one-frame lag). The idle+-- loop redraws when the reduced model differs.+runFrameReduce ::+  (Typeable msg, Eq model) =>+  (msg -> model -> model)+  -> Context+  -> Input+  -> model+  -> (model -> NanoUI a)+  -> IO (a, model, [msg], DrawData, Bool)+runFrameReduce = runFrameReduceEff runEff++runFrameReduceEff ::+  (IOE :> es, Typeable msg, Eq model) =>+  (forall x. Eff es x -> IO x)+  -> (msg -> model -> model)+  -> Context+  -> Input+  -> model+  -> (model -> Eff (Ui : es) a)+  -> IO (a, model, [msg], DrawData, Bool)+runFrameReduceEff unlift update ctx inp model view = do+  (a, msgs, draw, dirty) <- runFrameEff unlift ctx inp (view model)+  let+    typed = decodeMessages msgs+    model' = foldl' (flip update) model typed+  when (model' /= model) (markDirty ctx)+  dirty' <- isDirty ctx+  pure (a, model', typed, draw, dirty || dirty')++runFrameEff ::+  IOE :> es =>+  (forall x. Eff es x -> IO x)+  -> Context+  -> Input+  -> Eff (Ui : es) a+  -> IO (a, [FrameMsg], DrawData, Bool)+runFrameEff unlift ctx inp ui = do+  ensureMetricCaches ctx+  oldHot <- readIORef (ctxLastHotId ctx)+  oldActive <- readIORef (ctxActiveId ctx)+  oldFocus <- readIORef (ctxFocusId ctx)+  oldHotRect <- getPrevRect ctx oldHot+  oldActiveRect <- getPrevRect ctx oldActive+  oldFocusRect <- getPrevRect ctx oldFocus+  oldFloatingRects <- getsOverlay ctx osPrevFloatingRects+  oldRects <- getsDamage ctx dsPrevRects+  oldTexts <- getsDamage ctx dsPrevNodeTexts+  oldSize <- getsDamage ctx dsLastWindowSize+  oldStore <- getStore ctx+  wasDirty <- isDirty ctx+  clearDirty ctx+  animKeys <- IM.keysSet <$> getLiveAnimations ctx+  -- Wheel and thumb-drag input targets the previous frame's layout, so apply+  -- it while that arena is still intact, before it is reset for the new+  -- build. Settling offsets before the UI pass keeps build-time+  -- virtualization (table body rows) materialized for the range that will+  -- actually be visible, without a second build pass.+  updateScrollWheel ctx inp+  -- A glide advances with the wheel, before the build, for the same reason:+  -- the offset this frame renders at is the one virtualization must see.+  stepScrollGlides ctx (inputDeltaTime inp)+  updateScrollDrag ctx inp+  beginThemeScopes ctx True+  resetNodeArena (ctxNodeArena ctx)+  resetDrawArena (ctxDrawArena ctx)+  resetUiBuildScopes ctx+  unless (inputMouseDown inp) $+    modifyInteraction ctx (\s -> s {isSelectDropPress = False})+  when (not (inputMouseDown inp) && not (inputMouseReleased inp)) $+    setMenuPointerGesture ctx False+  beginFrameModal ctx+  writeIORef (ctxReleaseClickedId ctx) (WidgetId 0)+  armMenuPointerCapture ctx inp+  armPointerPress ctx inp+  result0 <- unlift (runUi ctx inp ui)+  -- Pending click is one-shot. Clear before a mirror rebuild so toggles do not fire twice.+  writeIORef (ctxClickedId ctx) (WidgetId 0)+  storeMid <- getStore ctx+  result <-+    if mirrorStoresChanged oldStore storeMid+      then do+        resetUiBuild ctx+        unlift (runUi ctx (stripInteractionInput inp) ui)+      else pure result0+  -- Scopes only change how nodes look, which the rect and text diffs below+  -- cannot see, and custom widgets' cached ops hold the old theme's colours.+  whenM (themeScopesChanged ctx) $ do+    damageFull ctx+    modifyIORef' (ctxMetricGen ctx) (+ 1)+  -- Sync widget node values (checkbox/radio/tree) from the store before measure+  -- so labels and layout reflect the current state.+  syncWidgetLabels ctx+  let+    Size w h = inputWindowSize inp+  reused <- tryReuseLayout ctx (Size w h)+  unless reused $ do+    solvePlaceWindows ctx w h+    captureLayout ctx (Size w h)+  movedResize <- updateWindowResize ctx inp w h+  movedWindow <- updateWindowDrag ctx inp+  when (movedResize || movedWindow) $+    placeWindows+      (ctxNodeArena ctx)+      (ctxFontMetrics ctx)+      w+      h+      (lookupWindowPos ctx)+      (lookupWindowSize ctx)+  persistWindowPositions ctx+  applyScrollOffsets ctx+  finalizePointerPress ctx inp+  finalizePointerRelease ctx inp+  disarmPointerPress ctx inp+  finalizeTextInputFocus ctx inp+  finalizeSelectFocus ctx inp+  finalizeTextFieldMouse ctx inp+  closeTextEditMenuOnOutsideClick ctx inp+  openTextEditMenu ctx inp+  finalizeTextEditMenuPick ctx inp+  closeTextEditMenuOnEscape ctx inp+  constrainFocusToModal ctx+  finalizeTabFocus ctx inp+  finalizeSelectKeyboard ctx inp+  markSelectDropPress ctx inp+  finalizeSelectPick ctx inp+  closeSelectOnOutsideClick ctx inp+  storeAfter <- getStore ctx+  let storeChanged = mirrorStoresChanged storeMid storeAfter+  when storeChanged $ syncWidgetLabels ctx+  let layoutDirty = storeChanged || movedResize || movedWindow+  when layoutDirty $ do+    solvePlaceWindows ctx w h+    captureLayout ctx (Size w h)+    applyScrollOffsets ctx+  cacheOpenSelectDrop ctx+  updatePrevRects ctx+  refreshHover ctx inp+  tickAnimations ctx (inputDeltaTime inp)+  pruneDrawOpCache ctx+  overlayOpen <- overlayMenuOpen ctx+  writeDamage ctx inp overlayOpen+    FrameSnapshot+      { fsWasDirty = wasDirty+      , fsSize = oldSize+      , fsStore = oldStore+      , fsHot = oldHot+      , fsActive = oldActive+      , fsFocus = oldFocus+      , fsHotRect = oldHotRect+      , fsActiveRect = oldActiveRect+      , fsFocusRect = oldFocusRect+      , fsFloatingRects = oldFloatingRects+      , fsRects = oldRects+      , fsTexts = oldTexts+      , fsAnimKeys = animKeys+      }+  -- Clip frames only repaint the damaged region: the retain texture already+  -- holds every other pixel, and the runner scissors the present to the same+  -- damage. The region repaints from the window backdrop, inflated by one+  -- logical pixel to cover the runner's outward pixel snap. Full-present+  -- frames (fresh retain, forced full, continuous) paint everything.+  paintFull <- readIORef (ctxPaintFull ctx)+  beginLayer (ctxDrawArena ctx) LayerBackground+  unless paintFull $+    paintDamageClip ctx =<< takeDamage ctx+  lowerShapes ctx+  beginLayer (ctxDrawArena ctx) LayerOverlay+  drawWindowOverlays ctx+  drawModalOverlays ctx (inputWindowSize inp)+  drawPopupOverlays ctx+  drawSelectOverlays ctx inp+  drawTextEditMenuOverlays ctx inp+  drawData <- finishDraw (ctxDrawArena ctx)+  msgs <- drainMessages ctx+  dirtyAfterUi <- isDirty ctx+  pure (result, msgs, drawData, dirtyAfterUi)++-- Second UI pass after mirror store write. Keeps ctxStore, animations, and+-- prev rects; only rebuilds node arena and id scopes.+resetUiBuild :: Context -> IO ()+resetUiBuild ctx = do+  beginThemeScopes ctx False+  resetNodeArena (ctxNodeArena ctx)+  resetUiBuildScopes ctx++-- | Start a clip frame from the window backdrop, as a full frame starts from a+-- window-coloured clear. Widgets with a transparent fill, such as an idle+-- menu-bar title, draw nothing over the pixels they covered, so without the+-- backdrop a hover that just ended would stay in the retain texture.+paintDamageClip :: Context -> Damage -> IO ()+paintDamageClip _ DamageFull = pure ()+paintDamageClip ctx (DamageClip r) = do+  let da = ctxDrawArena ctx+      clip = rectInflate 1 r+  setClip da clip+  when (rectNonEmpty r) $ do+    theme <- readIORef (ctxTheme ctx)+    pushRect da clip (themeWindow theme)++resetUiBuildScopes :: Context -> IO ()+resetUiBuildScopes ctx = do+  writeIORef (ctxContainerStack ctx) []+  writeIORef (ctxIdContext ctx) initialIdContext+  writeIORef (ctxFocusablesCount ctx) 0+  writeIORef (ctxHotId ctx) (WidgetId 0)+  resetDrawingScopeCache ctx++solvePlaceWindows :: Context -> Float -> Float -> IO ()+solvePlaceWindows ctx w h = do+  let fontResolver sz weight style var = do+        (fm, _) <- ctxResolveFont ctx sz weight style var+        pure (fm, ctxResolveMeasure ctx sz weight style var)+  solveLayout+    (ctxNodeArena ctx)+    (ctxFontMetrics ctx)+    (ctxMonoFontMetrics ctx)+    (ctxMeasureText ctx)+    fontResolver+    (lookupCustomMeasure ctx)+    w+    h+  placeModals (ctxNodeArena ctx) (ctxFontMetrics ctx) w h+  placeWindows+    (ctxNodeArena ctx)+    (ctxFontMetrics ctx)+    w+    h+    (lookupWindowPos ctx)+    (lookupWindowSize ctx)+  placePopups+    (ctxNodeArena ctx)+    (ctxFontMetrics ctx)+    w+    h+    (lookupPopupConfig ctx)++-- | Reuse solved geometry for unchanged layout inputs. Floating placement and+-- custom measurement have dependencies outside the arena and must be solved.+tryReuseLayout :: Context -> Size -> IO Bool+tryReuseLayout ctx size = do+  custom <- hasCustomLayoutInputs ctx+  if custom+    then pure False+    else do+      gen <- readIORef (ctxMetricGen ctx)+      mc <- readIORef (ctxLayoutCache ctx)+      case mc of+        Just (c, cachedSize, cachedGen)+          | cachedSize == size && cachedGen == gen -> do+              ok <- layoutInputsMatch (ctxNodeArena ctx) c+              if ok+                then restoreLayoutCache (ctxNodeArena ctx) c >> pure True+                else pure False+        _ -> pure False++-- | Snapshot the solved layout so the next frame can reuse it.+captureLayout :: Context -> Size -> IO ()+captureLayout ctx size = do+  custom <- hasCustomLayoutInputs ctx+  eligible <- if custom then pure False else layoutCacheEligible (ctxNodeArena ctx)+  if not eligible+    then writeIORef (ctxLayoutCache ctx) Nothing+    else do+      gen <- readIORef (ctxMetricGen ctx)+      mc <- readIORef (ctxLayoutCache ctx)+      c0 <- case mc of+        Just (c, _, _) -> pure c+        Nothing -> newLayoutCache 64+      c <- captureLayoutCache (ctxNodeArena ctx) c0+      writeIORef (ctxLayoutCache ctx) (Just (c, size, gen))
+ lib/NanoUI/Frame/Chrome.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE DataKinds #-}++-- | Widget paint helpers: labels, styles, rects, menu panels and display text.+module NanoUI.Frame.Chrome+  ( floatingAncestor+  , displayText+  , widgetVisualStyle+  , textInputValue+  , textInputFocused+  , fillStyledRect+  , strokeStyledRect+  , paintStyledRect+  , overlayWindowStyle+  , overlayModalStyle+  , overlayMenuStyle+  , paintMenuPanel+  , paintMenuAccent+  , paintScrollBarLayout+  , imageIdFromText+  , paintTabHeader+  , paintTableHeader+  ) where++import Control.Monad (when)+import Data.IORef (readIORef)+import qualified Data.IntMap.Strict as IM+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import NanoUI.Context+  ( Context (..)+  , WidgetStore (..)+  , getAnimationValue+  , getStore+  , intKey+  , nodeTheme+  )+import NanoUI.Draw (DrawArena, pushRect, pushRoundedRect, pushRoundedStroke)+import NanoUI.Font (menuAccentInset, menuAccentW)+import NanoUI.Frame.Scroll.Geometry (ScrollBarLayout (..))+import NanoUI.Id (hashWidgetId)+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , getNodeType+  , getNodeValue+  , getOptions+  , getParent+  , getStyleIdx+  , getText+  , getWidgetId+  , isFloatingNode+  )+import NanoUI.Style+  ( Style (..)+  , Theme (..)+  , themeAccent+  , themeButton+  , themeFloatingWindow+  , themeInput+  , themeMuted+  , themePanel+  , themeWindow+  , themeOnAccent+  , themeShadow+  )+import NanoUI.Types (Color (..), Rect (..), colorA, colorRGBA, lerpColor)+import NanoUI.WidgetText+  ( buttonFlagsFromStyle+  , buttonVisualStyle+  , isMenuBarStyle+  , isMenuItemStyle+  , isTableHeaderStyle+  , selectDisplayText+  , stripeColor+  , tableHeaderDisplayText+  , textInputFieldText+  , textInputPasswordMode+  , treeDecodeStripe+  )++floatingAncestor :: Context -> NodeIdx -> IO (Maybe NodeType)+floatingAncestor ctx idx = go idx+  where+    go i+      | i < 0 = pure Nothing+      | otherwise = do+          nt <- getNodeType (ctxNodeArena ctx) i+          if isFloatingNode nt+            then pure (Just nt)+            else getParent (ctxNodeArena ctx) i >>= go++displayText :: Context -> NodeType -> NodeIdx -> IO Text+displayText ctx nt idx = do+  txt <- getText (ctxNodeArena ctx) idx+  case nt of+    NodeButton -> do+      si <- getStyleIdx (ctxNodeArena ctx) idx+      pure $! if isTableHeaderStyle si then tableHeaderDisplayText txt else txt+    NodeTextInput -> textInputFieldText txt <$> textInputValue ctx idx <*> textInputFocused ctx idx+    NodeTextArea -> textInputValue ctx idx+    NodeSelect -> selectDisplayText txt <$> selectCurrentOption ctx idx+    _ -> pure txt++selectCurrentOption :: Context -> NodeIdx -> IO Text+selectCurrentOption ctx idx = do+  store <- getStore ctx+  opts <- getOptions (ctxNodeArena ctx) idx+  wid <- getWidgetId (ctxNodeArena ctx) idx+  let picked = IM.findWithDefault 0 (intKey wid) (storeInt store)+  pure $ case drop picked opts of+    (o : _) -> o+    _ -> ""++-- | The text a field displays: its stored value, masked one character per+-- character for password inputs so caret and selection offsets still line up.+textInputValue :: Context -> NodeIdx -> IO Text+textInputValue ctx idx = do+  let na = ctxNodeArena ctx+  wid <- getWidgetId na idx+  nt <- getNodeType na idx+  si <- getStyleIdx na idx+  store <- getStore ctx+  let value = IM.findWithDefault "" (intKey wid) (storeText store)+  pure $+    if nt == NodeTextInput && textInputPasswordMode si+      then T.replicate (T.length value) "*"+      else value++textInputFocused :: Context -> NodeIdx -> IO Bool+textInputFocused ctx idx = do+  wid <- getWidgetId (ctxNodeArena ctx) idx+  focus <- readIORef (ctxFocusId ctx)+  pure (focus == wid)++-- | Transparent fills and no border.+clearStyle :: Style -> Style+clearStyle s = s {styleBg = clear, styleHoverBg = clear, styleActiveBg = clear, styleBorderWidth = 0}+  where+    clear = colorRGBA 0 0 0 0++closeButtonStyle :: Theme -> Bool -> Float -> Style+closeButtonStyle theme isHot animT =+  let btn = themeButton theme+      muted = lerpColor (styleFg btn) (styleBg (themePanel theme)) 0.42+      t = if isHot && not (animT > 0) then 1 else animT+   in (clearStyle btn) {styleFg = lerpColor muted (styleFg btn) t}++tabHeaderVisualStyle :: Theme -> Int -> Bool -> Style+tabHeaderVisualStyle theme styleIdx isActive =+  let panel = themePanel theme+      btn = themeButton theme+      muted = themeMuted theme+      accent = themeAccent theme+      clear = colorRGBA 0 0 0 0+      hoverLift = lerpColor (themeWindow theme) (styleHoverBg btn) 0.55+      (cr, activeBg, activeFg, activeBw, inactFg) = case styleIdx of+        1 -> (6, accent, themeOnAccent theme, 0, muted)+        2 -> (8, styleBg panel, styleFg panel, 1, muted)+        _ -> (6, styleBg panel, styleFg panel, 1, lerpColor muted (styleFg panel) 0.78)+   in if isActive+        then panel+          { styleBg = activeBg+          , styleHoverBg = activeBg+          , styleFg = activeFg+          , styleBorder = activeBg+          , styleBorderWidth = activeBw+          , styleCornerRadius = cr+          }+        else panel+          { styleBg = clear+          , styleHoverBg = hoverLift+          , styleFg = inactFg+          , styleBorder = clear+          , styleBorderWidth = 0+          , styleCornerRadius = cr+          }++-- | Flat menu row / menu-bar entry. Transparent at rest, a hover highlight+-- (matching the text-field context menu), and an accent-tinted fill while it+-- owns an open drop-down (@val > 0.5@, menu-bar titles only).+menuItemVisualStyle :: Theme -> Float -> Style+menuItemVisualStyle theme val =+  let menu = overlayMenuStyle theme+      accent = themeAccent theme+      clear = colorRGBA 0 0 0 0+      openBg = lerpColor (styleBg menu) accent 0.3+      isOpen = val > 0.5+   in menu+        { styleBg = if isOpen then openBg else clear+        , styleHoverBg = if isOpen then openBg else styleHoverBg menu+        , styleActiveBg = lerpColor (styleBg menu) accent 0.4+        , styleBorder = clear+        , styleBorderWidth = 0+        -- The text-field context menu fills hovered rows with a square+        -- pushRect; keep the generic menu identical.+        , styleCornerRadius = 0+        }++tableHeaderVisualStyle :: Theme -> Bool -> Style+tableHeaderVisualStyle theme isSorted =+  let btn = themeButton theme+      accent = themeAccent theme+      headerBg = lerpColor (styleBg (themePanel theme)) (styleBg btn) 0.55+   in btn+        { styleBg = headerBg+        , styleHoverBg = lerpColor headerBg accent 0.18+        , styleActiveBg = lerpColor headerBg accent 0.28+        , styleFg = if isSorted then styleFg btn else themeMuted theme+        , styleBorderWidth = 0+        , styleCornerRadius = 0+        }++paintTabHeader :: DrawArena -> Theme -> Int -> Bool -> Style -> Float -> Float -> Float -> Float -> IO ()+paintTabHeader da theme styleIdx isActive style x y w h = do+  let rect = Rect x y w h+      r = max 0 (styleCornerRadius style)+      bg = styleBg style+  if isActive+    then case styleIdx `mod` 4 of+      1 -> pushRoundedRect da rect r bg+      2 -> do+        pushRoundedRect da rect r bg+        strokeStyledRect da style rect+      _ -> do+        pushRoundedRect da rect r bg+        pushRoundedStroke da (Rect x y w (h + 1)) (min r (min (w / 2) (h / 2))) 1 (styleBorder (themePanel theme))+        pushRect da (Rect x (y + h - 2) w 2) (themeAccent theme)+    else when (bg /= colorRGBA 0 0 0 0) $ pushRoundedRect da rect r bg++paintTableHeader :: DrawArena -> Theme -> Bool -> Style -> Float -> Float -> Float -> Float -> IO ()+paintTableHeader da theme isSorted style x y w h = do+  pushRect da (Rect x y w h) (styleBg style)+  when isSorted $+    pushRect da (Rect x (y + h - 2) w 2) (themeAccent theme)++widgetVisualStyle :: Context -> NodeType -> NodeIdx -> IO Style+widgetVisualStyle ctx nt idx = do+  wid <- getWidgetId (ctxNodeArena ctx) idx+  val <- getNodeValue (ctxNodeArena ctx) idx+  hot <- readIORef (ctxHotId ctx)+  active <- readIORef (ctxActiveId ctx)+  focus <- readIORef (ctxFocusId ctx)+  animT <- getAnimationValue ctx wid+  -- Only these node types consult the floating ancestor; skip the parent+  -- walk for the common panel/text/button path.+  let modalAware = nt == NodeCheckbox || nt == NodeRadio || nt == NodeTree || nt == NodeSlider+  mFloat <- if modalAware then floatingAncestor ctx idx else pure Nothing+  styleIdx <-+    if nt == NodeButton || nt == NodeTree+      then getStyleIdx (ctxNodeArena ctx) idx+      else pure 0+  let (isClose, isTab, isTable) =+        if nt == NodeButton+          then buttonFlagsFromStyle styleIdx+          else (False, False, False)+      isMenu = nt == NodeButton && (isMenuItemStyle styleIdx || isMenuBarStyle styleIdx)+  theme <- nodeTheme ctx idx+  let isFocus = focus == wid+      isHot = wid == hot+      focusBorder s = if isFocus then s {styleBorder = themeAccent theme} else s+      base =+        case nt of+          NodeTextInput -> focusBorder (themeInput theme)+          NodeTextArea -> focusBorder (themeInput theme)+          NodeSelect -> focusBorder (themeButton theme)+          NodeColorPicker -> focusBorder (themeInput theme)+          NodeSlider -> clearStyle (themeInput theme)+          NodeCheckbox -> clearStyle (themeButton theme)+          NodeRadio -> clearStyle (themeButton theme)+          NodeTree ->+            let btn = themeButton theme+                accent = themeAccent theme+                unselectedBg =+                  case stripeColor theme (treeDecodeStripe styleIdx) of+                    Just c -> c+                    Nothing -> styleBg (themePanel theme)+             in if val > 0.5+                  then+                    btn+                      { styleBg = lerpColor unselectedBg accent 0.25+                      , styleHoverBg = lerpColor unselectedBg accent 0.35+                      , styleActiveBg = lerpColor unselectedBg accent 0.45+                      , styleBorderWidth = 0+                      , styleCornerRadius = 0+                      }+                  else+                    btn+                      { styleBg = unselectedBg+                      , styleHoverBg = lerpColor unselectedBg accent 0.12+                      , styleActiveBg = lerpColor unselectedBg accent 0.22+                      , styleBorderWidth = 0+                      , styleCornerRadius = 0+                      }+          NodeButton+            | isMenu -> menuItemVisualStyle theme val+            | isClose -> closeButtonStyle theme isHot animT+            | isTab -> tabHeaderVisualStyle theme (buttonVisualStyle styleIdx `mod` 4) (val > 0.5)+            | isTable -> tableHeaderVisualStyle theme (val > 0.5)+            | val > 0.5 ->+                (themeButton theme)+                  { styleBg = themeAccent theme+                  , styleHoverBg = themeAccent theme+                  , styleFg = themeOnAccent theme+                  , styleBorder = themeAccent theme+                  }+          _ -> themeButton theme+      widgetBase =+        case mFloat of+          Just NodeModal | modalAware -> overlayModalStyle theme+          _ -> base+      bg+        | nt == NodeTextInput, isFocus = styleActiveBg widgetBase+        | nt == NodeTextArea, isFocus = styleActiveBg widgetBase+        | hashWidgetId wid == hashWidgetId active = styleActiveBg widgetBase+        | nt == NodeCheckbox || nt == NodeRadio || nt == NodeSlider || isClose = styleBg widgetBase+        | isMenu = if isHot then styleHoverBg widgetBase else styleBg widgetBase+        | otherwise = hoverBackground widgetBase animT isHot+  -- Idle widgets (no hover/active tint change) reuse the base style record+  -- rather than allocating a fresh Style through a record update.+  pure $! if bg == styleBg widgetBase then widgetBase else widgetBase {styleBg = bg}++hoverBackground :: Style -> Float -> Bool -> Color+hoverBackground base val isHot+  | styleBg base == styleHoverBg base = styleBg base+  | isHot = lerpColor (styleBg base) (styleHoverBg base) (if val > 0 then val else 1)+  | otherwise = lerpColor (styleBg base) (styleHoverBg base) val++{-# INLINE fillStyledRect #-}+fillStyledRect :: DrawArena -> Style -> Rect -> IO ()+fillStyledRect da style rect =+  if styleCornerRadius style <= 0+    then pushRect da rect (styleBg style)+    else pushRoundedRect da rect (styleCornerRadius style) (styleBg style)++{-# INLINE strokeStyledRect #-}+strokeStyledRect :: DrawArena -> Style -> Rect -> IO ()+strokeStyledRect da style rect@(Rect _ _ w h) =+  when (styleBorderWidth style > 0) $ do+    let rr = max 0 (min (styleCornerRadius style) (min (w / 2) (h / 2)))+    pushRoundedStroke da rect rr (max 1 (styleBorderWidth style)) (styleBorder style)++-- | A style's fill, then its border.+{-# INLINE paintStyledRect #-}+paintStyledRect :: DrawArena -> Style -> Rect -> IO ()+paintStyledRect da style rect = do+  fillStyledRect da style rect+  strokeStyledRect da style rect++overlayMenuStyle :: Theme -> Style+overlayMenuStyle theme =+  let panel = themePanel theme+      hover =+        if styleHoverBg panel == styleBg panel+          then styleHoverBg (themeButton theme)+          else styleHoverBg panel+   in panel+        { styleCornerRadius = 2+        , styleBorderWidth = 1+        , styleHoverBg = hover+        , styleActiveBg = lerpColor (styleBg panel) (themeAccent theme) 0.22+        }++overlayWindowStyle :: Theme -> Style+overlayWindowStyle theme = (themeFloatingWindow theme) {styleCornerRadius = 2, styleBorderWidth = 1}++overlayModalStyle :: Theme -> Style+overlayModalStyle theme = (overlayMenuStyle theme) {styleCornerRadius = 2, styleBorderWidth = 1}++-- | Panel behind menus, dropdowns and floating windows: the theme's offset+-- shadow, then the styled fill and border.+paintMenuPanel :: DrawArena -> Theme -> Style -> Rect -> IO ()+paintMenuPanel da theme style rect@(Rect x y w h) = do+  when (colorA (themeShadow theme) > 0) $+    pushRoundedRect da (Rect (x + 3) (y + 3) w h) (styleCornerRadius style) (themeShadow theme)+  paintStyledRect da style rect++-- | Accent marker at a menu row's left edge, inset from its top and bottom.+paintMenuAccent :: DrawArena -> Theme -> Rect -> IO ()+paintMenuAccent da theme (Rect x y _ h) =+  pushRoundedRect+    da+    (Rect x (y + menuAccentInset) menuAccentW (max 0 (h - 2 * menuAccentInset)))+    1+    (themeAccent theme)++-- | Scrollbar track and thumb, each rounded to at most 4px.+paintScrollBarLayout :: DrawArena -> Color -> Color -> ScrollBarLayout -> IO ()+paintScrollBarLayout da trackCol thumbCol layout = do+  pill (sbTrack layout) trackCol+  pill (sbThumb layout) thumbCol+  where+    pill r@(Rect _ _ rw rh) = pushRoundedRect da r (min 4 (min rw rh / 2))++imageIdFromText :: Text -> Int+imageIdFromText txt =+  case TR.decimal txt of+    Right (n, rest) | T.null rest, n > 0 -> n+    _ -> 0
+ lib/NanoUI/Frame/Cursor.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Cursor+  ( UiCursorKind (..)+  , uiCursorKind+  , pointerCursorWanted+  , cursorKindIs+  ) where++import Data.IORef (readIORef)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (fromMaybe, isJust)+import NanoUI.Context+  ( Context (..)+  , CustomDrawContext (..)+  , WidgetStore (..)+  , getFocusId+  , getHotId+  , getScrollDrag+  , getStore+  , intKey+  , isDisabled+  , isSelectOpen+  , lookupCustomCursor+  , widgetTheme+  , getsInteraction+  , InteractionState (..)+  )+import NanoUI.Font (FontMetrics, sliderHandleSlack, sliderTrackBounds)+import NanoUI.Frame.Hit (findNodeByWidgetId, nodePointVisible, scrollHitRect)+import NanoUI.Frame.Scroll (ScrollBarLayout (..), scrollBarsFor)+import NanoUI.Frame.Select (overlayMenuOwnerAt, selectDropRect)+import NanoUI.Frame.TextArea.Content (isMouseOnTextAreaScrollBarAt)+import NanoUI.Frame.TextEdit.Menu (textEditMenuCursorKind, textFieldWidgetAtMouse)+import NanoUI.Frame.TextInput (nodeTextFieldGeom, searchClearHit)+import NanoUI.Frame.Window (windowResizeCursorKind)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input+  ( Input (..)+  , UiCursorKind (..)+  , grabDragKind+  , grabHoverKind+  , inputMouseDown+  , inputMousePos+  )+import NanoUI.Layout.Arena+  ( DirTag (..)+  , NodeIdx+  , NodeType (..)+  , findChildM+  , findNodeM+  , getDirection+  , getNodeType+  , getOptions+  , getParent+  , getRect+  , getStyleIdx+  , getWidgetId+  , isScrollNode+  )+import NanoUI.Types (Rect (..), V2 (..), rectContains)+import NanoUI.WidgetText (numericStepperRects, textInputNumericMode)+import NanoUI.WidgetText (isTableHeaderStyle)++uiCursorKind :: Context -> Input -> IO UiCursorKind+uiCursorKind ctx inp = do+  -- The first query with an opinion wins; later ones do not run.+  mKind <-+    foldr+      (\query rest -> query >>= maybe rest (pure . Just))+      (pure Nothing)+      [ textEditMenuCursorKind ctx inp+      , selectDropdownCursorKind ctx inp+      , windowResizeCursorKind ctx inp+      , tableColResizeCursorKind ctx inp+      , scrollThumbCursorKind ctx inp+      , textFieldHoverCursorKind ctx inp+      ]+  case mKind of+    Just k -> pure k+    Nothing -> do+      let mouse = inputMousePos inp+      active <- readIORef (ctxActiveId ctx)+      activeKind <- cursorKindAt ctx active mouse inp+      if activeKind /= UiCursorDefault+        then pure activeKind+        else do+          hot <- getHotId ctx+          cursorKindAt ctx hot mouse inp++selectDropdownCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)+selectDropdownCursorKind ctx inp = do+  let mouse = inputMousePos inp+      na = ctxNodeArena ctx+  dropPress <- getsInteraction ctx isSelectDropPress+  store <- getStore ctx+  mSel <-+    findNodeM na $ \idx -> do+      nt <- getNodeType na idx+      if nt /= NodeSelect+        then pure False+        else do+          wid <- getWidgetId na idx+          opts <- getOptions na idx+          (x, y, w, h) <- getRect na idx+          let dropRect = selectDropRect x y w h (length opts)+          pure ((isSelectOpen store (intKey wid) || dropPress) && rectContains dropRect mouse)+  if isJust mSel+    then pure (Just UiCursorPointer)+    else+      -- A focused combo's dropdown (visible while its field holds focus) is+      -- not a select: pointer over its menu like the select's. The text-input+      -- menu case inside overlayMenuOwnerAt is unreachable here, since+      -- textEditMenuCursorKind runs first in uiCursorKind.+      (UiCursorPointer <$) <$> overlayMenuOwnerAt ctx mouse++scrollThumbCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)+scrollThumbCursorKind ctx inp = do+  mDrag <- getScrollDrag ctx+  if inputMouseDown inp && isJust mDrag+    then pure (Just UiCursorGrabbing)+    else do+      onThumb <- scrollThumbHit ctx (inputMousePos inp)+      pure (if onThumb then Just (grabHoverKind True inp) else Nothing)++-- Field well, not the label. Independent of focus and hot. A search field's+-- clear button raises the pointer cursor; everywhere else over a field is text.+textFieldHoverCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)+textFieldHoverCursorKind ctx inp = do+  let mouse = inputMousePos inp+  mWid <- textFieldWidgetAtMouse ctx mouse+  case mWid of+    Nothing -> pure Nothing+    Just wid -> do+      onClear <- searchClearHit ctx wid mouse+      onStepper <- numericStepperHit ctx wid mouse+      pure (Just (if onClear || onStepper then UiCursorPointer else UiCursorText))++-- | Whether the pointer is over a numeric field's stepper, which takes the+-- pointer cursor rather than the text cursor.+numericStepperHit :: Context -> WidgetId -> V2 -> IO Bool+numericStepperHit ctx wid mouse =+  findNodeByWidgetId ctx wid >>= \case+    Nothing -> pure False+    Just idx -> do+      si <- getStyleIdx (ctxNodeArena ctx) idx+      if not (textInputNumericMode si)+        then pure False+        else do+          (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+          let (up, down) = numericStepperRects x y w h+          pure (rectContains up mouse || rectContains down mouse)++scrollThumbHit :: Context -> V2 -> IO Bool+scrollThumbHit ctx mouse =+  fmap isJust . findNodeM na $ \idx -> do+    nt <- getNodeType na idx+    if nt /= NodeTextArea && not (isScrollNode nt)+      then pure False+      else do+        wid <- getWidgetId na idx+        any (\(_, layout, _) -> rectContains (sbThumb layout) mouse) <$> scrollBarsFor ctx idx wid+  where+    na = ctxNodeArena ctx++cursorKindAt :: Context -> WidgetId -> V2 -> Input -> IO UiCursorKind+cursorKindAt ctx wid mouse inp+  | hashWidgetId wid == 0 = pure UiCursorDefault+  | otherwise = do+      disabled <- isDisabled ctx wid+      if disabled+        then pure UiCursorDefault+        else do+          mCursorFn <- lookupCustomCursor ctx wid+          case mCursorFn of+            Just cursorFn -> do+              visible <- widgetVisibleAt ctx wid mouse+              if not visible+                then pure UiCursorDefault+                else do+                  active <- readIORef (ctxActiveId ctx)+                  hot <- getHotId ctx+                  focused <- (== wid) <$> getFocusId ctx+                  theme <- widgetTheme ctx wid+                  let cdc =+                        CustomDrawContext+                          { cdcHovered = hot == wid+                          , cdcPressed = active == wid+                          , cdcFocused = focused+                          , cdcActive = active == wid+                          , cdcDisabled = disabled+                          , cdcTheme = theme+                          , cdcFont = ctxFontMetrics ctx+                          }+                  pure (cursorFn cdc)+            Nothing -> do+              -- Resolve the node through the arena's id index rather than+              -- building a type table of every widget for two lookups.+              mNodeType <- findNodeByWidgetId ctx wid >>= traverse (getNodeType (ctxNodeArena ctx))+              case mNodeType of+                Just NodeButton -> widgetPointerCursor ctx wid mouse+                Just NodeCheckbox -> widgetPointerCursor ctx wid mouse+                Just NodeRadio -> widgetPointerCursor ctx wid mouse+                Just NodeTree -> widgetPointerCursor ctx wid mouse+                Just NodeSelect -> selectCursorKind ctx wid mouse+                Just NodeColorPicker -> pure UiCursorPointer+                Just NodeTextInput -> textInputCursorKind ctx wid mouse+                Just NodeTextArea -> textAreaCursorKind ctx wid mouse+                Just NodeSlider -> sliderCursorKind ctx wid mouse inp+                _ -> pure UiCursorDefault++selectCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind+selectCursorKind ctx wid mouse = do+  visible <- widgetVisibleAt ctx wid mouse+  if not visible+    then pure UiCursorDefault+    else do+      mrect <- scrollHitRect ctx wid+      pure (if maybe False (`rectContains` mouse) mrect then UiCursorPointer else UiCursorDefault)++widgetVisibleAt :: Context -> WidgetId -> V2 -> IO Bool+widgetVisibleAt ctx wid mouse = do+  mIdx <- findNodeByWidgetId ctx wid+  case mIdx of+    Nothing -> pure False+    Just idx -> nodePointVisible ctx idx mouse++widgetPointerCursor :: Context -> WidgetId -> V2 -> IO UiCursorKind+widgetPointerCursor ctx wid mouse = do+  visible <- widgetVisibleAt ctx wid mouse+  pure (if visible then UiCursorPointer else UiCursorDefault)++sliderCursorKind :: Context -> WidgetId -> V2 -> Input -> IO UiCursorKind+sliderCursorKind ctx wid mouse inp = do+  active <- readIORef (ctxActiveId ctx)+  if active == wid && inputMouseDown inp+    then pure UiCursorGrabbing+    else do+      visible <- widgetVisibleAt ctx wid mouse+      if not visible+        then pure UiCursorDefault+        else do+          mrect <- scrollHitRect ctx wid+          pure $+            case mrect of+              Nothing -> UiCursorDefault+              Just (Rect x y w h) ->+                let Rect tx ty tw th = sliderTrackBounds x y w h+                    hitRect = Rect tx (ty - sliderHandleSlack) tw (th + 2 * sliderHandleSlack)+                 in grabDragKind (rectContains hitRect mouse) False inp++textInputCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind+textInputCursorKind ctx wid mouse = do+  visible <- widgetVisibleAt ctx wid mouse+  if not visible+    then pure UiCursorDefault+    else do+      mIdx <- findNodeByWidgetId ctx wid+      mrect <- scrollHitRect ctx wid+      case (mIdx, mrect) of+        (Just idx, Just (Rect x y w h)) -> do+          (field, _) <- nodeTextFieldGeom ctx idx x y w h+          onStepper <- numericStepperHit ctx wid mouse+          pure $+            if onStepper+              then UiCursorPointer+              else if rectContains field mouse then UiCursorText else UiCursorDefault+        _ -> pure UiCursorDefault++textAreaCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind+textAreaCursorKind ctx wid mouse = do+  mIdx <- findNodeByWidgetId ctx wid+  case mIdx of+    Nothing -> pure UiCursorDefault+    Just idx -> do+      onScroll <- isMouseOnTextAreaScrollBarAt ctx idx mouse+      if onScroll+        then pure UiCursorDefault+        else+          textFieldCursorKind ctx wid mouse $ \_ x y w h ->+            Rect x y w h++textFieldCursorKind ::+  Context ->+  WidgetId ->+  V2 ->+  (FontMetrics -> Float -> Float -> Float -> Float -> Rect) ->+  IO UiCursorKind+textFieldCursorKind ctx wid mouse fieldAt = do+  visible <- widgetVisibleAt ctx wid mouse+  if not visible+    then pure UiCursorDefault+    else do+      mrect <- scrollHitRect ctx wid+      pure $+        case mrect of+          Just (Rect x y w h)+            | rectContains (fieldAt (ctxFontMetrics ctx) x y w h) mouse -> UiCursorText+          _ -> UiCursorDefault++tableColResizeCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)+tableColResizeCursorKind ctx inp = do+  store <- getStore ctx+  let dragging = any (\n -> n <= -1000 && n > -2000) (IM.elems (storeInt store))+      na = ctxNodeArena ctx+      V2 mx my = inputMousePos inp+  if inputMouseDown inp && dragging+    then pure (Just UiCursorEwResize)+    else do+      mEdge <-+        findNodeM na $ \idx -> do+          nt <- getNodeType na idx+          if nt /= NodeButton+            then pure False+            else do+              si <- getStyleIdx na idx+              if not (isTableHeaderStyle si)+                then pure False+                else do+                  (x, y, w, h) <- getRect na idx+                  -- The resize cursor spans the whole column height+                  -- (header plus body cells down to the body+                  -- scroller's bottom edge), matching the drag grab+                  -- zone: tableBodyScrollerBottom locates the same+                  -- body scroller whose rect the grab zone anchors+                  -- on (its prev-frame value, readable at build+                  -- time), so the two zones cannot disagree.+                  yBot <- fromMaybe (y + h) <$> tableBodyScrollerBottom ctx idx+                  pure (my >= y && my <= yBot && abs (mx - (x + w)) <= 4 && w > 0 && h > 0)+      pure (UiCursorEwResize <$ mEdge)++-- | Bottom edge of a table's body scroller, located structurally from one+-- of its header buttons: walk up to the first ancestor that has a direct+-- Column-direction scroll-container child (the pane column built by+-- tableSplitPanes) and take that child's rect bottom. Runs post-solve, so+-- the rect is current-frame. Nothing when no such scroller exists (the+-- caller falls back to the header button's own bottom).+tableBodyScrollerBottom :: Context -> NodeIdx -> IO (Maybe Float)+tableBodyScrollerBottom ctx = goUp+  where+    na = ctxNodeArena ctx+    goUp i = do+      p <- getParent na i+      if p < 0+        then pure Nothing+        else do+          mScroller <-+            findChildM na p $ \c -> do+              nt <- getNodeType na c+              if isScrollNode nt+                then (== DirColumn) <$> getDirection na c+                else pure False+          case mScroller of+            Just sc -> do+              (_, sy, _, sh) <- getRect na sc+              pure (Just (sy + sh))+            Nothing -> goUp p++pointerCursorWanted :: Context -> Input -> IO Bool+pointerCursorWanted ctx inp = cursorKindIs ctx inp UiCursorPointer++cursorKindIs :: Context -> Input -> UiCursorKind -> IO Bool+cursorKindIs ctx inp want = (== want) <$> uiCursorKind ctx inp
+ lib/NanoUI/Frame/Focus.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}++-- | Focus traversal and modal focus constraints.+module NanoUI.Frame.Focus+  ( filterModalFocusables+  , constrainFocusToModal+  , syncWidgetLabels+  , tabNext+  , tabNextFocusables+  ) where++import Control.Monad (filterM, unless, when)+import Data.IORef (readIORef, writeIORef)+import Data.Primitive.PrimArray (readPrimArray)+import qualified Data.IntMap.Strict as IM+import NanoUI.Context (Context (..), WidgetStore (..), getStore, intBool, intKey)+import NanoUI.Frame.Hit (widgetIdInSubtree)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Layout.Arena+  ( NodeType (NodeCheckbox, NodeRadio, NodeTree)+  , forNodes_+  , getNodeType+  , getParent+  , getStyleIdx+  , getWidgetId+  , setNodeValue+  , topModalNode+  )+import NanoUI.WidgetText (treeDecodeStyle)++tabNext :: WidgetId -> [WidgetId] -> Bool -> WidgetId+tabNext cur ids shift =+  case ids of+    [] -> WidgetId 0+    first : rest ->+      let lastId !prev [] = prev+          lastId _ (x : xs) = lastId x xs+          search _ [] = first+          search prev (x : xs)+            | x == cur = if shift then prev else case xs of+                next : _ -> next+                [] -> first+            | otherwise = search x xs+       in if cur == first && shift+            then lastId first rest+            else search first ids++-- | Scan the live focus buffer. Skip zero ids. No freeze or list copy.+tabNextFocusables :: Context -> WidgetId -> Bool -> IO WidgetId+tabNextFocusables ctx cur shift = do+  n <- readIORef (ctxFocusablesCount ctx)+  arr <- readIORef (ctxFocusables ctx)+  let at i = readPrimArray arr i+      findCur !i+        | i >= n = pure Nothing+        | otherwise = do+            w <- at i+            if w == cur && hashWidgetId w /= 0 then pure (Just i) else findCur (i + 1)+      firstLive !i+        | i >= n = pure (WidgetId 0)+        | otherwise = do+            w <- at i+            if hashWidgetId w /= 0 then pure w else firstLive (i + 1)+      step !i !left+        | left <= 0 = firstLive 0+        | otherwise = do+            let j = if shift then (i - 1 + n) `mod` n else (i + 1) `mod` n+            w <- at j+            if hashWidgetId w /= 0 then pure w else step j (left - 1)+  if n <= 0+    then pure (WidgetId 0)+    else do+      found <- findCur 0+      case found of+        Nothing -> firstLive 0+        Just i -> step i n++filterModalFocusables :: Context -> [WidgetId] -> IO [WidgetId]+filterModalFocusables ctx ids = do+  -- Searching the arena once per focusable makes a large modal's Tab traversal+  -- quadratic. Resolve its root once, then test ancestry for each widget.+  top <- topModalNode (ctxNodeArena ctx)+  case top of+    Nothing -> pure ids+    Just modal -> filterM (widgetIdInSubtree ctx modal) ids++constrainFocusToModal :: Context -> IO ()+constrainFocusToModal ctx = do+  top <- topModalNode (ctxNodeArena ctx)+  case top of+    Nothing -> pure ()+    Just modal -> do+      focus <- readIORef (ctxFocusId ctx)+      when (hashWidgetId focus /= 0) $ do+        ok <- widgetIdInSubtree ctx modal focus+        unless ok $ writeIORef (ctxFocusId ctx) (WidgetId 0)++syncWidgetLabels :: Context -> IO ()+syncWidgetLabels ctx = do+  store <- getStore ctx+  let na = ctxNodeArena ctx+  forNodes_ na $ \idx -> do+    nt <- getNodeType na idx+    wid <- getWidgetId na idx+    let key = intKey wid+    case nt of+      NodeCheckbox ->+        -- Only sync when the widget owns stored state; otherwise keep the+        -- value set from the initial argument during the UI pass.+        case IM.lookup key (storeInt store) of+          Just v -> setNodeValue na idx (if intBool v then 1 else 0)+          Nothing -> pure ()+      _+        -- A radio's option index is its style; a tree row packs its node+        -- index there. Either is selected when its group's stored value names it.+        | nt == NodeRadio || nt == NodeTree -> do+            parent <- getParent na idx+            si <- getStyleIdx na idx+            groupWid <- getWidgetId na parent+            let own+                  | nt == NodeTree, (nodeIdx, _, _, _) <- treeDecodeStyle si = nodeIdx+                  | otherwise = si+                selected = IM.findWithDefault own (intKey groupWid) (storeInt store)+            setNodeValue na idx (if selected == own then 1 else 0)+      _ -> pure ()
+ lib/NanoUI/Frame/Hit.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DataKinds #-}++-- | Layout hit testing for modals, windows, and overlay stacking.+module NanoUI.Frame.Hit+  ( findNodeByWidgetId+  , findNodeByKey+  , modalTreeOpen+  , nodeInSubtree+  , widgetIdInSubtree+  , overlayHitAllowed+  , topmostOverlayAtMouse+  , topmostModalAtMouse+  , widgetOverlayAllowed+  , scrollHitRect+  , nodePointVisible+  , nodeClippedHit+  , nodeInteractionHit+  ) where++import Data.Maybe (isJust)+import NanoUI.Context (Context (..), getPrevRect, getPrevClipRect)+import NanoUI.Id (WidgetId)+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (NodeModal, NodePopup, NodeScrollContainer, NodeWindow)+  , findNodeRevM+  , getClipRect+  , getNodeType+  , getParent+  , getRect+  , getWidgetId+  , lookupNodeByKey+  , lookupNodeByWidgetId+  , topModalNode+  )+import NanoUI.Types (Rect (..), V2 (..), rectContains, rectH, rectW)++findNodeByWidgetId :: Context -> WidgetId -> IO (Maybe NodeIdx)+findNodeByWidgetId ctx wid = lookupNodeByWidgetId (ctxNodeArena ctx) wid++findNodeByKey :: Context -> Int -> IO (Maybe NodeIdx)+findNodeByKey ctx k = lookupNodeByKey (ctxNodeArena ctx) k++modalTreeOpen :: Context -> IO Bool+modalTreeOpen ctx = do+  top <- topModalNode (ctxNodeArena ctx)+  pure (isJust top)++nodeInSubtree :: Context -> NodeIdx -> NodeIdx -> IO Bool+nodeInSubtree ctx idx top = go idx+  where+    go i+      | i < 0 = pure False+      | i == top = pure True+      | otherwise = do+          parent <- getParent (ctxNodeArena ctx) i+          go parent++-- | Membership predicate for an already-resolved subtree root. Callers+-- filtering many widgets can resolve the root once for the whole operation.+widgetIdInSubtree :: Context -> NodeIdx -> WidgetId -> IO Bool+widgetIdInSubtree ctx root wid = do+  node <- findNodeByWidgetId ctx wid+  maybe (pure False) (\idx -> nodeInSubtree ctx idx root) node++overlayHitAllowed :: Context -> NodeIdx -> V2 -> IO Bool+overlayHitAllowed ctx idx mouse = do+  mModal <- topModalNode (ctxNodeArena ctx)+  case mModal of+    Just top -> nodeInSubtree ctx idx top+    Nothing -> do+      mTop <- topmostOverlayAtMouse ctx mouse+      case mTop of+        Nothing -> pure True+        Just tidx -> nodeInSubtree ctx idx tidx++topmostOverlayAtMouse :: Context -> V2 -> IO (Maybe NodeIdx)+topmostOverlayAtMouse ctx mouse =+  topmostFloatingAtMouse ctx mouse (\nt -> nt == NodeWindow || nt == NodePopup)++topmostModalAtMouse :: Context -> V2 -> IO (Maybe NodeIdx)+topmostModalAtMouse ctx mouse =+  topmostFloatingAtMouse ctx mouse (== NodeModal)++topmostFloatingAtMouse :: Context -> V2 -> (NodeType -> Bool) -> IO (Maybe NodeIdx)+topmostFloatingAtMouse ctx mouse wanted =+  findNodeRevM (ctxNodeArena ctx) $ \idx -> do+    nt <- getNodeType (ctxNodeArena ctx) idx+    if not (wanted nt)+      then pure False+      else do+        (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+        pure (w > 0 && h > 0 && rectContains (Rect x y w h) mouse)++widgetOverlayAllowed :: Context -> WidgetId -> IO Bool+widgetOverlayAllowed ctx wid = do+  top <- topModalNode (ctxNodeArena ctx)+  case top of+    Nothing -> pure True+    Just modal -> widgetIdInSubtree ctx modal wid++-- Prev rects are visual space (snapshot after applyScrollOffsets).+scrollHitRect :: Context -> WidgetId -> IO (Maybe Rect)+scrollHitRect = getPrevRect++{-# INLINE nodePointVisible #-}+nodePointVisible :: Context -> NodeIdx -> V2 -> IO Bool+nodePointVisible ctx idx mouse = do+  (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+  let vis = Rect x y w h+  if not (w > 0 && h > 0 && rectContains vis mouse)+    then pure False+    else do+      mClip <- getClipRect (ctxNodeArena ctx) idx+      pure (maybe True (`rectContains` mouse) mClip)++{-# INLINE nodeClippedHit #-}+nodeClippedHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool+nodeClippedHit ctx idx rect mouse = do+  if not (rectW rect > 0 && rectH rect > 0 && rectContains rect mouse)+    then pure False+    else do+      na <- pure (ctxNodeArena ctx)+      mLive <- getClipRect na idx+      mClip <-+        case mLive of+          Just r -> pure (Just r)+          Nothing -> do+            wid <- getWidgetId na idx+            getPrevClipRect ctx wid+      pure (maybe True (`rectContains` mouse) mClip)++-- | Hit test during UI build (before applyScrollOffsets). Uses prev rects and+-- scroll viewport clips only, not per-node live clips.+{-# INLINE nodeInteractionHit #-}+nodeInteractionHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool+nodeInteractionHit ctx idx rect mouse = do+  if not (rectW rect > 0 && rectH rect > 0 && rectContains rect mouse)+    then pure False+    else scrollViewportHit ctx idx mouse++scrollViewportHit :: Context -> NodeIdx -> V2 -> IO Bool+scrollViewportHit ctx idx mouse = go idx+  where+    go i+      | i <= 0 = pure True+      | otherwise = do+          p <- getParent (ctxNodeArena ctx) i+          if p < 0+            then pure True+            else do+              nt <- getNodeType (ctxNodeArena ctx) p+              if nt == NodeScrollContainer+                then do+                  wid <- getWidgetId (ctxNodeArena ctx) p+                  mClip <- getPrevClipRect ctx wid+                  case mClip of+                    Nothing -> go p+                    Just clip ->+                      if rectContains clip mouse then go p else pure False+                else go p
+ lib/NanoUI/Frame/Input.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Input+  ( finalizeTabFocus+  , refreshHover+  , armPointerPress+  , disarmPointerPress+  , finalizePointerPress+  , finalizePointerRelease+  , finalizeTextInputFocus+  , finalizeSelectFocus+  , findTopWidgetUnderMouse+  , isInteractiveNode+  ) where++import Control.Applicative ((<|>))+import Control.Monad (unless, when)+import Data.IORef (readIORef, writeIORef)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (isJust, isNothing)+import NanoUI.Context+  ( Context (..)+  , TextInputMenu (..)+  , WidgetStore (..)+  , damageWidget+  , getFocusables+  , getMenuPointerGesture+  , getStore+  , getTextInputMenu+  , intKey+  , isDisabled+  , markDirty+  , pointerBlockedByOverlay+  , setAnimationValue+  , setMenuPointerGesture+  , setStore+  , setTextInputMenu+  , startAnimation+  )+import NanoUI.Frame.Focus (filterModalFocusables, tabNext, tabNextFocusables)+import NanoUI.Frame.Hit+  ( findNodeByWidgetId+  , modalTreeOpen+  , nodeClippedHit+  , nodeInteractionHit+  , overlayHitAllowed+  , scrollHitRect+  )+import NanoUI.Frame.Redraw (probeHotId)+import NanoUI.Frame.Select (findSelectUnderMouse, overlayMenuOwnerAt)+import NanoUI.Frame.Spans (widgetHitRect)+import NanoUI.Frame.TextEdit (collapseTextFieldSelection)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input+  ( Input (..)+  , Key (..)+  , inputKeysElem+  , inputModifiers+  , inputMousePos+  , inputMousePressed+  , inputMouseReleased+  , inputMouseRightPressed+  , inputMouseRightReleased+  , modShift+  )+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , findNodeM+  , foldNodesM+  , getNodeType+  , getParent+  , getRect+  , getStyleIdx+  , getWidgetId+  )+import NanoUI.Monad (whenM)+import NanoUI.Types (DamageBounds (..), Rect (..), V2 (..), defaultDamageSlop, rectContains, rectH, rectW)+import NanoUI.WidgetText (buttonVisualStyle, isMenuBarStyle, isMenuItemStyle, isTabButtonStyle)++finalizeTabFocus :: Context -> Input -> IO ()+finalizeTabFocus ctx inp =+  when (inputKeysElem KeyTab (inputKeys inp)) $ do+    open <- modalTreeOpen ctx+    let shift = modShift (inputModifiers inp)+    cur <- readIORef (ctxFocusId ctx)+    next <-+      if not open+        then tabNextFocusables ctx cur shift+        else do+          focusables <- getFocusables ctx+          ids <- filterModalFocusables ctx (filter (/= WidgetId 0) focusables)+          pure (tabNext cur ids shift)+    when (hashWidgetId next /= 0) $ do+      -- Keyboard focus shows its ring until the next pointer press. Focus that+      -- stays put (a lone focusable) changes no focus rect, so damage it here.+      wasVisible <- readIORef (ctxFocusVisible ctx)+      when (next == cur && not wasVisible) $+        damageWidget ctx next (DamageInflated defaultDamageSlop)+      writeIORef (ctxFocusId ctx) next+      writeIORef (ctxFocusVisible ctx) True+      markDirty ctx++-- Flat menu buttons never animate: their hover highlight snaps on and off.+isMenuButtonWidget :: Context -> WidgetId -> IO Bool+isMenuButtonWidget ctx wid+  | hashWidgetId wid == 0 = pure False+  | otherwise =+      findNodeByWidgetId ctx wid >>= \case+        Nothing -> pure False+        Just idx -> do+          nt <- getNodeType (ctxNodeArena ctx) idx+          if nt /= NodeButton+            then pure False+            else do+              si <- getStyleIdx (ctxNodeArena ctx) idx+              pure (isMenuItemStyle si || isMenuBarStyle si)++refreshHover :: Context -> Input -> IO ()+refreshHover ctx inp = do+  prevHot <- readIORef (ctxLastHotId ctx)+  newHot <- probeHotId ctx (inputMousePos inp)+  writeIORef (ctxHotId ctx) newHot+  writeIORef (ctxLastHotId ctx) newHot+  when (prevHot /= newHot) $ do+    prevMenu <- isMenuButtonWidget ctx prevHot+    newMenu <- isMenuButtonWidget ctx newHot+    when (hashWidgetId prevHot /= 0 && not prevMenu) $ startAnimation ctx prevHot 1 0 0.12+    when (hashWidgetId newHot /= 0 && not newMenu) $ startAnimation ctx newHot 0 1 0.12++-- | Remember where a press landed, before the UI builds: widgets resolve their+-- click against this point, so a release that drifted onto a neighbour fires+-- nowhere. Runs every frame; 'disarmPointerPress' clears it once the button+-- comes up and the frame has consumed the release.+armPointerPress :: Context -> Input -> IO ()+armPointerPress ctx inp = do+  let here = Just (inputMousePos inp)+  when (inputMousePressed inp) $ writeIORef (ctxPressPos ctx) here+  when (inputMouseRightPressed inp) $ writeIORef (ctxRightPressPos ctx) here++disarmPointerPress :: Context -> Input -> IO ()+disarmPointerPress ctx inp = do+  when (inputMouseReleased inp) $ writeIORef (ctxPressPos ctx) Nothing+  when (inputMouseRightReleased inp) $ writeIORef (ctxRightPressPos ctx) Nothing++-- Same walk as refreshHover: later nodes paint first, earlier widget hits win.+finalizePointerPress :: Context -> Input -> IO ()+finalizePointerPress ctx inp =+  when (inputMousePressed inp) $ do+    -- A pointer press hides the keyboard focus ring.+    writeIORef (ctxFocusVisible ctx) False+    gesture <- getMenuPointerGesture ctx+    if gesture+      then writeIORef (ctxActiveId ctx) (WidgetId 0)+      else do+        let mouse = inputMousePos inp+        mMenu <- overlayMenuOwnerAt ctx mouse+        case mMenu of+          Just _ -> do+            setMenuPointerGesture ctx True+            writeIORef (ctxActiveId ctx) (WidgetId 0)+          Nothing -> do+            mWid <- findTopWidgetUnderMouse ctx mouse isInteractiveNode+            case mWid of+              Nothing -> pure ()+              Just wid ->+                whenM (not <$> isDisabled ctx wid) $+                  writeIORef (ctxActiveId ctx) wid++-- | The widget of a wanted type under @mouse@ that hover would pick: the+-- first in arena order, since earlier siblings paint over later ones.+findTopWidgetUnderMouse :: Context -> V2 -> (NodeType -> Bool) -> IO (Maybe WidgetId)+findTopWidgetUnderMouse ctx mouse wanted = do+  let na = ctxNodeArena ctx+  mIdx <-+    findNodeM na $ \idx -> do+      nt <- getNodeType na idx+      if not (wanted nt)+        then pure False+        else do+          (x, y, w, h) <- getRect na idx+          rect <- widgetHitRect ctx nt idx x y w h+          if rectW rect > 0 && rectH rect > 0+            then do+              hit <- nodeClippedHit ctx idx rect mouse+              if hit then overlayHitAllowed ctx idx mouse else pure False+            else pure False+  traverse (getWidgetId na) mIdx++isInteractiveNode :: NodeType -> Bool+isInteractiveNode nt =+  nt == NodeButton+    || nt == NodeCheckbox+    || nt == NodeRadio+    || nt == NodeTree+    || nt == NodeSlider+    || nt == NodeSelect+    || nt == NodeColorPicker+    || nt == NodeTextInput+    || nt == NodeTextArea+    || nt == NodeDrawing++-- Clicks are finalized against solved layout rects; widgets only track press state.+-- Radio/tab selection is written here. Clickable widgets use the same solved+-- hit; if in-UI prev-rect tests missed, ctxClickedId fires next frame.+finalizePointerRelease :: Context -> Input -> IO ()+finalizePointerRelease ctx inp =+  when (inputMouseReleased inp) $ do+    let mouse = inputMousePos inp+        na = ctxNodeArena ctx+    gesture <- getMenuPointerGesture ctx+    mMenu <- overlayMenuOwnerAt ctx mouse+    if gesture || isJust mMenu+      then do+        writeIORef (ctxActiveId ctx) (WidgetId 0)+        setMenuPointerGesture ctx False+      else do+        active <- readIORef (ctxActiveId ctx)+        when (hashWidgetId active /= 0) $ do+          releasedClicked <- readIORef (ctxReleaseClickedId ctx)+          -- Every node carrying the active id takes the release; the first+          -- one decides whether the pointer came up over the widget.+          let release over idx = do+                wid <- getWidgetId na idx+                if wid /= active+                  then pure over+                  else do+                    nt <- getNodeType na idx+                    (x, y, w, h) <- getRect na idx+                    visible <- nodeClippedHit ctx idx (Rect x y w h) mouse+                    when visible $ do+                      case nt of+                        NodeRadio -> getStyleIdx na idx >>= setParentSelection ctx idx+                        NodeButton -> do+                          packed <- getStyleIdx na idx+                          when (isTabButtonStyle packed) $+                            setParentSelection ctx idx (buttonVisualStyle packed `div` 4)+                        _ -> pure ()+                      when (postsLayoutClick nt && releasedClicked /= active) $ do+                        uiHit <- inUiClickHit ctx active mouse+                        unless uiHit $ writeIORef (ctxClickedId ctx) active+                    pure (over <|> Just visible)+          releasedOver <- foldNodesM na release Nothing+          writeIORef (ctxActiveId ctx) (WidgetId 0)+          when (releasedOver == Just True) $+            setAnimationValue ctx active 1++-- Radio options and tab buttons keep their selection on the parent group.+setParentSelection :: Context -> NodeIdx -> Int -> IO ()+setParentSelection ctx idx selected = do+  parent <- getParent (ctxNodeArena ctx) idx+  when (parent >= 0) $ do+    store <- getStore ctx+    groupWid <- getWidgetId (ctxNodeArena ctx) parent+    setStore ctx store {storeInt = IM.insert (intKey groupWid) selected (storeInt store)}++postsLayoutClick :: NodeType -> Bool+postsLayoutClick nt =+  nt == NodeButton || nt == NodeTree || nt == NodeSelect || nt == NodeCheckbox++inUiClickHit :: Context -> WidgetId -> V2 -> IO Bool+inUiClickHit ctx wid mouse = do+  disabled <- isDisabled ctx wid+  blocked <- pointerBlockedByOverlay ctx mouse+  if disabled || blocked+    then pure False+    else do+      mrect <- scrollHitRect ctx wid+      case mrect of+        Nothing -> pure False+        Just r ->+          findNodeByWidgetId ctx wid >>= \case+            Nothing -> pure (rectContains r mouse)+            Just idx -> nodeInteractionHit ctx idx r mouse++-- Focus text inputs using solved layout rects so the caret appears on first press.+-- A press on an open dropdown overlay (select menu or a focused combo's+-- suggestions) must not clear focus first: the combo's dropdown is visible+-- exactly while its field holds focus, and the select finalizers below need+-- the owner still resolvable to route the pick.+finalizeTextInputFocus :: Context -> Input -> IO ()+finalizeTextInputFocus ctx inp =+  when (inputMousePressed inp) $ do+    mMenu <- getTextInputMenu ctx+    let mouse = inputMousePos inp+    mDrop <- overlayMenuOwnerAt ctx mouse+    let onMenu = maybe False (\menu -> rectContains (textInputMenuRect menu) mouse) mMenu+    when (not onMenu && isNothing mDrop) $ do+      prevFocus <- readIORef (ctxFocusId ctx)+      mFocused <- findTextInputUnderMouse ctx mouse+      case mFocused of+        Nothing -> do+          when (prevFocus /= WidgetId 0) $ markDirty ctx+          collapseTextFieldSelection ctx prevFocus+          writeIORef (ctxFocusId ctx) (WidgetId 0)+          setTextInputMenu ctx Nothing+        Just wid -> do+          writeIORef (ctxFocusId ctx) wid+          when (prevFocus /= wid) $ markDirty ctx++finalizeSelectFocus :: Context -> Input -> IO ()+finalizeSelectFocus ctx inp =+  when (inputMousePressed inp) $ do+    let mouse = inputMousePos inp+    mOpen <- findSelectUnderMouse ctx mouse+    -- A press on a select's own field that just closed its dropdown leaves no+    -- open dropdown under the pointer, but the select keeps focus all the same.+    mWid <- maybe (findTopWidgetUnderMouse ctx mouse (== NodeSelect)) (pure . Just) mOpen+    case mWid of+      Nothing -> pure ()+      Just wid ->+        whenM (not <$> isDisabled ctx wid) $ do+          prev <- readIORef (ctxFocusId ctx)+          writeIORef (ctxFocusId ctx) wid+          when (prev /= wid) $ markDirty ctx++findTextInputUnderMouse :: Context -> V2 -> IO (Maybe WidgetId)+findTextInputUnderMouse ctx mouse = do+  let na = ctxNodeArena ctx+  mIdx <-+    findNodeM na $ \idx -> do+      nt <- getNodeType na idx+      if nt /= NodeTextInput && nt /= NodeTextArea+        then pure False+        else do+          (x, y, w, h) <- getRect na idx+          rect <- widgetHitRect ctx nt idx x y w h+          hit <- nodeClippedHit ctx idx rect mouse+          if hit then overlayHitAllowed ctx idx mouse else pure False+  mWid <- traverse (getWidgetId na) mIdx+  -- A press on a disabled field lands on nothing: it takes focus from+  -- whichever field had it and gives it to none.+  case mWid of+    Just wid -> do+      disabled <- isDisabled ctx wid+      pure (if disabled then Nothing else Just wid)+    Nothing -> pure Nothing
+ lib/NanoUI/Frame/Node.hs view
@@ -0,0 +1,118 @@+-- | Per-node queries shared by the paint, span, scroll and hit passes: the+-- font a node renders and measures in, and a scroll node's fields and content+-- viewport.+module NanoUI.Frame.Node+  ( resolveFontFor+  , resolveTextFont+  , nodeFontMetrics+  , ScrollNode (..)+  , readScrollNode+  , scrollNodeViewport+  ) where++import Data.Text (Text)+import NanoUI.Context (Context (..))+import NanoUI.Draw.Types (TextFont (..))+import NanoUI.Font (FontMetrics, ScrollBarSlot, isDefaultNodeFont, measureTextIO)+import NanoUI.Frame.Scroll.Geometry+  ( ScrollConfig+  , decodeScrollConfig+  , scrollConfigNative2D+  , scrollContentClip+  , scrollViewportClip2D+  )+import NanoUI.Layout.Arena+  ( DirTag+  , NodeArena+  , NodeIdx+  , NodeType (..)+  , getDirection+  , getNodeFontSize+  , getNodeType+  , getNodeValue+  , getPadding+  , getScrollContentW+  , getStyleIdx+  )+import NanoUI.Layout.Solve (scrollBarSlotOf)+import NanoUI.Style (FontVariant (..), Padding)+import NanoUI.Types (Rect)+import NanoUI.WidgetText (textNodeFontStyle, textNodeFontVariant, textNodeFontWeight)++-- | Font for a node of type @nt@ with an explicit size and packed style: the+-- metrics, whether the host returned a native styled face (paint then skips+-- synthetic weight and slant), and the matching measure. Base sans and mono+-- resolve to the pre-read metrics; everything else defers to the host+-- resolver. INLINE: it runs for every text-bearing node painted, and inlining+-- lets the result triple fold away at each call site (measured: 30 MB less+-- allocation over the 3000-frame profile).+--+-- Only text and text-input nodes pack a font into their style. Other widgets+-- keep their own data in those bits (a radio's option index, a colour picker+-- part, a tab's look), so their style must not be read as a font.+{-# INLINE resolveFontFor #-}+resolveFontFor :: Context -> NodeType -> Float -> Int -> IO (FontMetrics, Bool, Text -> IO (Float, Float))+resolveFontFor ctx nt size packed+  | isDefaultNodeFont size weight style variant =+      pure $+        if variant == FontMono+          then (ctxMonoFontMetrics ctx, False, measureTextIO (ctxMonoFontMetrics ctx))+          else (ctxFontMetrics ctx, False, ctxMeasureText ctx)+  | otherwise = do+      (fm, native) <- ctxResolveFont ctx size weight style variant+      pure (fm, native, ctxResolveMeasure ctx size weight style variant)+  where+    si = if nt == NodeText || nt == NodeTextInput then packed else 0+    variant = textNodeFontVariant si+    weight = textNodeFontWeight si+    style = textNodeFontStyle si++-- | The font a 'DrawTextStyled' op names, and whether the host draws its+-- weight and slant natively.+resolveTextFont :: Context -> TextFont -> IO (FontMetrics, Bool)+resolveTextFont ctx (TextFont size variant weight style _)+  | isDefaultNodeFont size weight style variant =+      pure (if variant == FontMono then ctxMonoFontMetrics ctx else ctxFontMetrics ctx, False)+  | otherwise = ctxResolveFont ctx size weight style variant++-- | Metrics of the font node @idx@ is styled with.+nodeFontMetrics :: Context -> NodeIdx -> IO FontMetrics+nodeFontMetrics ctx idx = do+  nt <- getNodeType (ctxNodeArena ctx) idx+  si <- getStyleIdx (ctxNodeArena ctx) idx+  size <- getNodeFontSize (ctxNodeArena ctx) idx+  (fm, _, _) <- resolveFontFor ctx nt size si+  pure fm++-- | What the scroll passes read off a scroll container: its bar slot, scroll+-- config, whether it scrolls natively in 2D, direction, padding, the content+-- extent along its main axis (the content height for 2D) and, for 2D, the+-- content width.+data ScrollNode = ScrollNode+  { snSlot :: !ScrollBarSlot+  , snConfig :: !ScrollConfig+  , sn2D :: !Bool+  , snDir :: !DirTag+  , snPad :: {-# UNPACK #-} !Padding+  , snContentMain :: {-# UNPACK #-} !Float+  , snContentW :: {-# UNPACK #-} !Float+  }++{-# INLINE readScrollNode #-}+readScrollNode :: NodeArena -> NodeIdx -> IO ScrollNode+readScrollNode na idx = do+  si <- getStyleIdx na idx+  slot <- scrollBarSlotOf na idx+  dir <- getDirection na idx+  pad <- getPadding na idx+  contentMain <- getNodeValue na idx+  contentW <- getScrollContentW na idx+  let cfg = decodeScrollConfig si+  pure $! ScrollNode slot cfg (si /= 0 && scrollConfigNative2D cfg) dir pad contentMain contentW++-- | Content viewport of a scroll node placed at @x y w h@: its padding box+-- minus the live scrollbar gutters.+scrollNodeViewport :: ScrollNode -> Float -> Float -> Float -> Float -> Rect+scrollNodeViewport (ScrollNode slot cfg native2D dir pad contentMain contentW) x y w h+  | native2D = scrollViewportClip2D slot cfg x y w h pad contentW contentMain+  | otherwise = scrollContentClip slot cfg dir x y w h pad contentMain
+ lib/NanoUI/Frame/Overlay.hs view
@@ -0,0 +1,60 @@+-- | Floating panel overlays: windows, popups and modals (with the modal+-- backdrop), each a menu-style panel with its subtree painted inside.+module NanoUI.Frame.Overlay+  ( drawWindowOverlays+  , drawModalOverlays+  , drawPopupOverlays+  ) where++import Control.Monad (when)+import Data.IORef (readIORef)+import NanoUI.Context (Context (..), nodeTheme)+import NanoUI.Draw (pushRect, withClip)+import NanoUI.Frame.Chrome (overlayMenuStyle, overlayModalStyle, overlayWindowStyle, paintMenuPanel)+import NanoUI.Frame.Hit (modalTreeOpen)+import NanoUI.Frame.Paint (walkChildren)+import NanoUI.Layout.Arena (NodeIdx, NodeType (..), forNodes_, getNodeType, getPadding, getRect)+import NanoUI.Style (Padding (..), Style, Theme, themeOverlayDim, themeSeparator)+import NanoUI.Types (Rect (..), Size (..))+import NanoUI.Widgets.Chrome (titleBarChromeHFor, windowChromeSepH)++drawWindowOverlays :: Context -> IO ()+drawWindowOverlays ctx =+  forFloatingNode ctx NodeWindow $ \idx rect@(Rect x y w _) -> do+    theme <- nodeTheme ctx idx+    drawFloatingPanel ctx theme idx (overlayWindowStyle theme) rect+    pad <- getPadding (ctxNodeArena ctx) idx+    let sepY = y + padT pad + titleBarChromeHFor - windowChromeSepH+    pushRect+      (ctxDrawArena ctx)+      (Rect (x + padL pad) sepY (max 0 (w - padL pad - padR pad)) windowChromeSepH)+      (themeSeparator theme)++drawPopupOverlays :: Context -> IO ()+drawPopupOverlays ctx =+  forFloatingNode ctx NodePopup $ \idx rect -> do+    theme <- nodeTheme ctx idx+    drawFloatingPanel ctx theme idx (overlayMenuStyle theme) rect++drawModalOverlays :: Context -> Size -> IO ()+drawModalOverlays ctx (Size ww wh) = do+  found <- modalTreeOpen ctx+  when found $ do+    theme <- readIORef (ctxTheme ctx)+    pushRect (ctxDrawArena ctx) (Rect 0 0 ww wh) (themeOverlayDim theme)+    forFloatingNode ctx NodeModal $ \idx rect -> do+      modalTheme <- nodeTheme ctx idx+      drawFloatingPanel ctx modalTheme idx (overlayModalStyle modalTheme) rect++forFloatingNode :: Context -> NodeType -> (NodeIdx -> Rect -> IO ()) -> IO ()+forFloatingNode ctx nodeType draw =+  forNodes_ (ctxNodeArena ctx) $ \idx -> do+    nt <- getNodeType (ctxNodeArena ctx) idx+    when (nt == nodeType) $ do+      (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+      draw idx (Rect x y w h)++drawFloatingPanel :: Context -> Theme -> NodeIdx -> Style -> Rect -> IO ()+drawFloatingPanel ctx theme idx style rect = do+  paintMenuPanel (ctxDrawArena ctx) theme style rect+  withClip (ctxDrawArena ctx) rect (walkChildren ctx idx)
+ lib/NanoUI/Frame/Paint.hs view
@@ -0,0 +1,438 @@+-- Paint traversal for NanoUI. This module owns the node walk and the+-- structural painters; widget chrome painting lives in sibling+-- NanoUI.Frame.Paint.Widgets.+--+-- The module is shaped for GHC's optimizer: the recursive walker+--+--   paintNodeWithEnv -> lowerNodeVisible (explicit dispatch)+--         -> per-node painters (containers recurse via walkChildrenWithOccluders)+--+-- sits on top of {-# NOINLINE #-} seams, and the heavyweight painters (widget+-- chrome, text, scroll containers, drawings) stay out of line, so no single+-- binding carries the whole painting body inside the recursive loop. That+-- stops the simplifier / SpecConstr from seeing one monolithic binding in the+-- loop, which is what blew up compilation under -fspecialise-aggressively ++-- LLVM; hence the guard flags below.+{-# OPTIONS_GHC -fasm -fno-specialise-aggressively #-}++{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Paint+  ( lowerShapes+  , walkChildren+  ) where++import Control.Monad (forM_, unless, when)+import Data.Bits ((.&.))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Primitive.PrimArray+  ( PrimArray+  , emptyPrimArray+  , indexPrimArray+  , newPrimArray+  , shrinkMutablePrimArray+  , sizeofPrimArray+  , unsafeFreezePrimArray+  , writePrimArray+  )+import qualified Data.Text as T+import Data.Word (Word32)+import NanoUI.Context+  ( Context (..)+  , CustomDrawingEntry (..)+  , DrawingEntry (..)+  , atlasTextureId+  , cachedCustomDrawingOps+  , cachedDrawingOps+  , getScrollOffset+  , getScrollOffset2D+  , lookupCustomDrawing+  , lookupDrawing+  , lookupImageUv+  , nodeTheme+  , scopeTheme+  )+import NanoUI.Draw+  ( Layer (..)+  , beginLayer+  , currentClip+  , currentLayer+  , emitDrawOps+  , pushImage+  , pushRect+  , pushRoundedStroke+  , pushTextStyled+  , withClip+  )+import NanoUI.Font (ScrollBarSlot (..))+import NanoUI.Frame.Chrome+  ( floatingAncestor+  , imageIdFromText+  , overlayMenuStyle+  , overlayModalStyle+  , overlayWindowStyle+  , paintScrollBarLayout+  , paintStyledRect+  )+import NanoUI.Frame.Node (ScrollNode (..), readScrollNode, resolveFontFor, resolveTextFont, scrollNodeViewport)+import NanoUI.Frame.Paint.Types (PaintEnv (..), buildPaintEnv)+import NanoUI.Frame.Paint.Widgets (paintTextAreaNode, paintTextInputNode, paintWidget)+import NanoUI.Frame.Scroll.Geometry+  ( borderContentClip+  , padContentClip+  , scrollBare+  , scrollBarLayout+  , scrollBarLayouts2D+  , scrollChromeActive+  )+import NanoUI.Frame.Spans (collectNodeTextSpans)+import NanoUI.Id (hashWidgetId)+import NanoUI.Layout.Arena+  ( DirTag (..)+  , NodeIdx+  , NodeType (..)+  , SizingTag (..)+  , arenaCount+  , floatingNodeCount+  , foldNodesM+  , forChildNodes_+  , getHeightSizing+  , getNodeFontColor+  , getNodeFontSize+  , getNodeScope+  , getNodeType+  , getRect+  , getStyleIdx+  , getText+  , getWidgetId+  , getWidthSizing+  , isFloatingNode+  )+import NanoUI.Style+  ( FontStyle (..)+  , FontWeight (..)+  , Style (..)+  , Theme (..)+  , scrollBarThumbColor+  , scrollBarTrackColor+  , themeAccent+  , themeFloatingWindow+  , themeInput+  , themePanel+  , themeSeparator+  , themeWindow+  , fadeAlpha+  , themeDisabledFade+  , themeFocusRing+  )+import NanoUI.Types (Color (..), ImageId (..), Rect (..), V2 (..), colorA, colorRGBA, rectInflate)+import NanoUI.Widgets.ColorPicker (colorPickerPartRect)+import NanoUI.Widgets.Custom (mkCustomDrawContext)+import NanoUI.WidgetText+  ( tableStripeColor+  , textNodeFontStyle+  , textNodeFontWeight+  , textNodeTextDecoration+  )++lowerShapes :: Context -> IO ()+lowerShapes ctx = do+  count <- arenaCount (ctxNodeArena ctx)+  when (count > 0) $ do+    occluders <- collectFloatingOccluders ctx+    buildPaintEnv ctx occluders >>= (`paintNodeWithEnv` 0)++-- | Rects of opaque floating panels, inset past their rounded border, that+-- hide whatever lies fully behind them, as @x0, y0, x1, y1@ runs. Frames+-- without floating nodes skip the arena walk.+collectFloatingOccluders :: Context -> IO (PrimArray Float)+collectFloatingOccluders ctx = do+  let na = ctxNodeArena ctx+  floating <- floatingNodeCount na+  if floating <= 0+    then pure emptyPrimArray+    else do+      buf <- newPrimArray (floating * 4)+      n <- foldNodesM na (addOccluder na buf) 0+      shrinkMutablePrimArray buf (n * 4)+      unsafeFreezePrimArray buf+  where+    isOpaque s = colorA (styleBg s) == 255+    occludes theme = \case+      NodeWindow -> isOpaque (overlayWindowStyle theme)+      NodeModal -> isOpaque (overlayModalStyle theme)+      NodePopup -> isOpaque (overlayMenuStyle theme)+      _ -> False+    addOccluder na buf !n idx = do+      nt <- getNodeType na idx+      opaque <- if isFloatingNode nt then (`occludes` nt) <$> nodeTheme ctx idx else pure False+      if not opaque+        then pure n+        else do+          (x, y, w, h) <- getRect na idx+          if not (w > 6 && h > 6)+            then pure n+            else do+              let !o = n * 4+                  Rect ox oy ow oh = rectInflate (-3) (Rect x y w h)+              writePrimArray buf o ox+              writePrimArray buf (o + 1) oy+              writePrimArray buf (o + 2) (ox + ow)+              writePrimArray buf (o + 3) (oy + oh)+              pure (n + 1)++-- | Clip + occluder short-circuit, then lower the node. NOINLINE so the+-- recursive container walk never exposes the dispatch below to the simplifier.+--+-- The clip test widens the node by 'paintOverhang': a clip frame starts from a+-- blank backdrop, so a node whose focus ring reaches into the clip must repaint+-- even when its own rect stays outside.+{-# NOINLINE paintNodeWithEnv #-}+paintNodeWithEnv :: PaintEnv -> NodeIdx -> IO ()+paintNodeWithEnv env idx = do+  (x, y, w, h) <- getRect (peNodeArena env) idx+  Rect cx cy cw ch <- currentClip (peDrawArena env)+  let !l = max (x - paintOverhang) cx+      !t = max (y - paintOverhang) cy+      !r = min (x + w + paintOverhang) (cx + cw)+      !b = min (y + h + paintOverhang) (cy + ch)+  unless (w <= 0 || h <= 0 || r <= l || b <= t) $+    unless (occluded (peOccluders env) l t r b) $ do+      nt <- getNodeType (peNodeArena env) idx+      scope <- getNodeScope (peNodeArena env) idx+      if scope == peScope env+        then lowerNodeVisible env idx nt (Rect x y w h)+        else do+          theme <- scopeTheme (peContext env) scope+          lowerNodeVisible env {peTheme = theme, peScope = scope} idx nt (Rect x y w h)++-- | Whether an opaque floating panel fully covers the clipped node rect+-- @l, t, r, b@, which the caller has already checked is non-empty.+{-# INLINE occluded #-}+occluded :: PrimArray Float -> Float -> Float -> Float -> Float -> Bool+occluded occ !l !t !r !b = go 0+  where+    !end = sizeofPrimArray occ+    go !o+      | o >= end = False+      | l >= indexPrimArray occ o+          && t >= indexPrimArray occ (o + 1)+          && r <= indexPrimArray occ (o + 2)+          && b <= indexPrimArray occ (o + 3) =+          True+      | otherwise = go (o + 4)++-- | How far a node may paint outside its rect: the focus ring sits 2px out+-- with a 1.5px stroke.+paintOverhang :: Float+paintOverhang = 4++-- | Explicit per-node-type dispatch. Kept NOINLINE and thin so the recursive+-- loop never sees the branch bodies.+{-# NOINLINE lowerNodeVisible #-}+lowerNodeVisible :: PaintEnv -> NodeIdx -> NodeType -> Rect -> IO ()+lowerNodeVisible env idx nt rect = do+  case nt of+    NodeContainer -> paintContainerNode env idx rect+    NodePanel -> paintPanelNode env idx rect+    NodeScrollContainer -> paintScrollContainerNode env idx rect+    NodeText -> paintTextNode env idx rect+    NodeSeparator -> paintSeparatorNode env rect+    NodeTextInput -> paintTextInputNode env idx rect+    NodeTextArea -> paintTextAreaNode env idx rect+    NodeSpacer -> pure ()+    NodeModal -> pure ()+    NodeWindow -> pure ()+    NodePopup -> pure ()+    NodeBox -> paintBoxNode env idx rect+    NodeImage -> paintImageNode env idx rect+    NodeDrawing -> paintDrawingNode env idx rect+    NodeWidget -> pure ()+    _ -> paintWidget env idx nt rect+  unless (hashWidgetId (peFocusRing env) == 0) $+    paintFocusRing env idx nt rect++-- | Accent ring around the widget holding keyboard focus. Text fields and+-- selects already swap in an accent border while focused, so they get none.+-- Tree rows fill their scroller edge to edge, so their ring sits just inside+-- the row; colour picker parts ring the square or bar they draw.+{-# NOINLINE paintFocusRing #-}+paintFocusRing :: PaintEnv -> NodeIdx -> NodeType -> Rect -> IO ()+paintFocusRing env idx nt rect = do+  wid <- getWidgetId (peNodeArena env) idx+  when (wid == peFocusRing env && nt /= NodeTextInput && nt /= NodeTextArea && nt /= NodeSelect) $ do+    target <-+      if nt == NodeColorPicker+        then colorPickerPartRect (peNodeArena env) idx rect+        else pure rect+    let (ring, radius)+          | nt == NodeTree = (rectInflate (-1) target, 0)+          | otherwise = (rectInflate 2 target, 4)+    pushRoundedStroke (peDrawArena env) ring radius 1.5 (themeFocusRing (peTheme env))++paintContainerNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintContainerNode env idx rect = do+  walkChildrenWithOccluders env idx+  let ctx = peContext env+  wid <- getWidgetId (peNodeArena env) idx+  mBuild <- lookupCustomDrawing ctx wid+  forM_ mBuild $ \(CustomDrawingEntry _ build) -> do+    let fm = peFontMetrics env+        da = peDrawArena env+    cdc <- mkCustomDrawContext ctx fm wid+    withClip da rect (emitDrawOps da fm (resolveTextFont ctx) (build cdc rect))++paintPanelNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintPanelNode env idx rect = do+  let da = peDrawArena env+      style = themePanel (peTheme env)+  paintStyledRect da style rect+  withClip da (borderContentClip style rect) $ walkChildrenWithOccluders env idx++{-# NOINLINE paintScrollContainerNode #-}+paintScrollContainerNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintScrollContainerNode env idx rect@(Rect x y w h) = do+  let ctx = peContext env+      arena = peNodeArena env+      da = peDrawArena env+      tm = peTheme env+  sn <- readScrollNode arena idx+  -- A bare scroller paints nothing at all: it only lends its clip and+  -- offset, so whatever sits behind it (window, panel) keeps showing+  -- through. Grow×grow scrollers (page-level) keep no well so they blend+  -- into the window backdrop. That backdrop only exists while the runner+  -- clears it on DamageFull frames; on clip frames (scrolling, resize)+  -- the strip vacated by scrolled content has no covering command and+  -- the retained texture would show stale pixels, a ghost of a previous+  -- scroll position. Paint the full rect with the window color instead:+  -- invisible on a cleared backdrop, and clip replay then always+  -- repaints the whole viewport.+  unless (scrollBare (snConfig sn)) $ do+    inFloating <- maybe False isFloatingNode <$> floatingAncestor ctx idx+    (wTag, _) <- getWidthSizing arena idx+    (hTag, _) <- getHeightSizing arena idx+    if wTag == SizingGrow && hTag == SizingGrow+      then pushRect da rect (if inFloating then styleBg (themeFloatingWindow tm) else themeWindow tm)+      else do+        let well = (if inFloating then themeFloatingWindow tm else themeInput tm) {styleCornerRadius = 0}+        paintStyledRect da well rect+  withClip da (scrollNodeViewport sn x y w h) $ walkChildrenWithOccluders env idx+  paintScrollChrome env idx sn rect++-- | Scrollbars of a scroll container whose chrome is active, drawn one layer+-- above the content so they stay on top of it.+paintScrollChrome :: PaintEnv -> NodeIdx -> ScrollNode -> Rect -> IO ()+paintScrollChrome env idx (ScrollNode slot cfg native2D dir pad contentMain contentW) (Rect x y w h) = do+  let ctx = peContext env+      da = peDrawArena env+      theme = peTheme env+      Rect _ _ innerW innerH = padContentClip x y w h pad+  wid <- getWidgetId (peNodeArena env) idx+  bars <-+    if native2D+      then+        if scrollChromeActive cfg DirColumn contentMain innerH || scrollChromeActive cfg DirRow contentW innerW+          then do+            V2 offX offY <- getScrollOffset2D ctx wid+            let (mV, mH) = scrollBarLayouts2D slot cfg x y w h pad contentW contentMain offX offY+            pure (catMaybes [mV, mH])+          else pure []+      else do+        let innerMain = case dir of+              DirColumn -> innerH+              DirRow -> innerW+        if scrollChromeActive cfg dir contentMain innerMain+          then do+            off <- getScrollOffset ctx wid+            pure (catMaybes [scrollBarLayout slot dir x y w h pad contentMain off])+          else pure []+  unless (null bars) $ do+    layer <- currentLayer da+    beginLayer da (if layer == LayerOverlay then LayerChrome else LayerContent)+    let base = case slot of+          ScrollBarWindow -> themeFloatingWindow theme+          _ -> themeInput theme+    mapM_ (paintScrollBarLayout da (scrollBarTrackColor base theme) (scrollBarThumbColor base theme)) bars+    beginLayer da layer++{-# NOINLINE paintTextNode #-}+paintTextNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintTextNode env idx rect = do+  let arena = peNodeArena env+      da = peDrawArena env+  si <- getStyleIdx arena idx+  forM_ (tableStripeColor (peTheme env) si) (pushRect da rect)+  raw <- getText arena idx+  unless (T.null raw) $ do+    spans <- collectNodeTextSpans (peContext env) idx+    fontSize <- getNodeFontSize arena idx+    (fm, isNative, _) <- resolveFontFor (peContext env) NodeText fontSize si+    let deco = textNodeTextDecoration si+        weight = if isNative then WeightNormal else textNodeFontWeight si+        style = if isNative then FontStyleNormal else textNodeFontStyle si+    forM_ spans $ \(Rect tx ty _ _, line, spanFg, _) ->+      unless (T.null line) $+        pushTextStyled da fm weight style deco tx ty line spanFg++paintSeparatorNode :: PaintEnv -> Rect -> IO ()+paintSeparatorNode env (Rect x y w h) =+  pushRect (peDrawArena env) line (themeSeparator (peTheme env))+  where+    line+      | w >= h = Rect x (y + (h - 1) / 2) w 1+      | otherwise = Rect (x + (w - 1) / 2) y 1 h++paintBoxNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintBoxNode env idx rect = do+  si <- getStyleIdx (peNodeArena env) idx+  -- styleIdx holds RGBA Word32 bits; see `box` in NanoUI.Widgets.+  pushRect (peDrawArena env) rect (Color (fromIntegral si :: Word32))++paintImageNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintImageNode env idx rect = do+  let da = peDrawArena env+  tex <- imageIdFromText <$> getText (peNodeArena env) idx+  mUv <- lookupImageUv (peContext env) (ImageId tex)+  case mUv of+    Just (u0, v0, u1, v1) -> do+      -- An image may carry a tint in its font colour (an SVG icon). A+      -- disabled image fades the way disabled widget colours do.+      base <- fromMaybe (colorRGBA 255 255 255 255) <$> getNodeFontColor (peNodeArena env) idx+      let tint+            | peScope env .&. 1 /= 0 = fadeAlpha base (round (fromIntegral (colorA base) * (1 - themeDisabledFade (peTheme env))))+            | otherwise = base+      pushImage da rect atlasTextureId u0 v0 u1 v1 tint+    _ -> pushRect da rect (themeAccent (peTheme env))++{-# NOINLINE paintDrawingNode #-}+paintDrawingNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintDrawingNode env idx rect = do+  let ctx = peContext env+      fm = peFontMetrics env+      da = peDrawArena env+  wid <- getWidgetId (peNodeArena env) idx+  mCustomBuild <- lookupCustomDrawing ctx wid+  case mCustomBuild of+    Just (CustomDrawingEntry content customBuild) -> do+      cdc <- mkCustomDrawContext ctx fm wid+      ops <- cachedCustomDrawingOps ctx wid content rect cdc customBuild+      withClip da rect (emitDrawOps da fm (resolveTextFont ctx) ops)+    Nothing -> do+      mBuild <- lookupDrawing ctx wid+      forM_ mBuild $ \(DrawingEntry content build) -> do+        ops <- cachedDrawingOps ctx wid content rect build+        withClip da rect (emitDrawOps da fm (resolveTextFont ctx) ops)++-- | Lower the children of @idx@ with the current paint env. NOINLINE keeps+-- this recursive call out of the simplifier's loop analysis, so the whole+-- walker stays a call to opaque seams rather than one inlined monster.+{-# NOINLINE walkChildrenWithOccluders #-}+walkChildrenWithOccluders :: PaintEnv -> NodeIdx -> IO ()+walkChildrenWithOccluders env idx =+  forChildNodes_ (peNodeArena env) idx (paintNodeWithEnv env)++-- | Children walk for callers painting a subtree inside their own clip+-- (floating overlays); builds a fresh env without occluders.+{-# NOINLINE walkChildren #-}+walkChildren :: Context -> NodeIdx -> IO ()+walkChildren ctx idx = buildPaintEnv ctx emptyPrimArray >>= (`walkChildrenWithOccluders` idx)
+ lib/NanoUI/Frame/Paint/Types.hs view
@@ -0,0 +1,86 @@+-- Shared leaf module for NanoUI.Frame.Paint and its widget painter sibling:+-- both the walker (NanoUI.Frame.Paint) and the chrome painters+-- (NanoUI.Frame.Paint.Widgets) consume the paint env, so the record and its+-- small helpers live here to keep the module graph acyclic (Paint imports+-- Widgets, Widgets imports Types, Paint imports Types).+module NanoUI.Frame.Paint.Types+  ( PaintEnv (..)+  , buildPaintEnv+  , popupPanelRect+  ) where++import Data.IORef (readIORef)+import Data.Primitive.PrimArray (PrimArray)+import NanoUI.Context (Context (..))+import NanoUI.Draw (DrawArena)+import NanoUI.Font (FontMetrics)+import NanoUI.Id (WidgetId (..))+import NanoUI.Layout.Arena+  ( NodeArena+  , NodeIdx+  , NodeType (..)+  , getNodeType+  , getParent+  , getRect+  )+import NanoUI.Style (Theme)+import NanoUI.Types (Rect (..))++-- | Everything a paint pass needs, bundled so the walker does not re-read the+-- theme IORef (or rebuild arena handles) for every node. Baked once per+-- frame by 'buildPaintEnv'. Fields are lazy: under+-- -funbox-strict-fields a strict paint env would unbox every reachable+-- field of Context/Theme/Style recursively, turning each record selector into+-- a ~100-way case that dominates Core size; lazy fields stay single pointers+-- (all bindings here are already-evaluated values, so no thunks are paid).+data PaintEnv = PaintEnv+  { peContext :: Context+  , peNodeArena :: NodeArena+  , peDrawArena :: DrawArena+  , peTheme :: Theme+  , peScope :: Int+    -- ^ The node scope 'peTheme' belongs to. A node in another scope repaints+    -- its subtree with that scope's theme.+  , peFontMetrics :: FontMetrics+  , peOccluders :: PrimArray Float+    -- ^ Opaque floating panel rects as @x0, y0, x1, y1@ runs; empty when the+    -- frame has none.+  , peFocusRing :: WidgetId+    -- ^ The focused widget while its keyboard focus ring shows, else 0.+  }++-- | Locality helper for callers inside the paint frame loop; a fresh env+-- re-reads the theme once.+{-# NOINLINE buildPaintEnv #-}+buildPaintEnv :: Context -> PrimArray Float -> IO PaintEnv+buildPaintEnv ctx occluders = do+  theme <- readIORef (ctxTheme ctx)+  focus <- readIORef (ctxFocusId ctx)+  focusVisible <- readIORef (ctxFocusVisible ctx)+  pure PaintEnv+    { peContext = ctx+    , peNodeArena = ctxNodeArena ctx+    , peDrawArena = ctxDrawArena ctx+    , peTheme = theme+    , peScope = 0+    , peFontMetrics = ctxFontMetrics ctx+    , peOccluders = occluders+    , peFocusRing = if focusVisible then focus else WidgetId 0+    }++-- | Rect of the nearest popup-panel ancestor of @idx@, if any. Menu rows use+-- it to paint hover fills edge-to-edge across the panel.+popupPanelRect :: Context -> NodeIdx -> IO (Maybe Rect)+popupPanelRect ctx = go+  where+    go i = do+      p <- getParent (ctxNodeArena ctx) i+      if p < 0+        then pure Nothing+        else do+          nt <- getNodeType (ctxNodeArena ctx) p+          if nt == NodePopup+            then do+              (px, py, pw, ph) <- getRect (ctxNodeArena ctx) p+              pure (Just (Rect px py pw ph))+            else go p
+ lib/NanoUI/Frame/Paint/Widgets.hs view
@@ -0,0 +1,527 @@+-- Widget chrome painters for NanoUI, extracted from NanoUI.Frame.Paint so the+-- recursive node walker stays small. Every exported painter carries the paint+-- env built by Paint.buildPaintEnv; the walker's explicit dispatch hands each+-- widget node to one of these NOINLINE seams instead of inlining a monolithic+-- body into the loop.+{-# OPTIONS_GHC -fasm -fno-specialise-aggressively #-}++{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Paint.Widgets+  ( paintWidget+  , paintTextInputNode+  , paintTextAreaNode+  ) where++import Control.Monad (unless, when)+import Data.IORef (readIORef)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import NanoUI.Context (Context (..), getStore)+import NanoUI.Draw+  ( DrawArena (..)+  , pushFilledTriangle+  , pushLine+  , pushRoundedRect+  , pushRoundedRectRaw+  , pushRoundedStroke+  , pushStrokeAA+  , pushText+  , withClip+  )+import NanoUI.Font+  ( FontMetrics (..)+  , centeredTextY+  , checkboxBoxSize+  , sliderHandleDiameter+  , sliderTrackBounds+  , tableCellInset+  , treeChevronRect+  )+import NanoUI.Frame.Chrome+  ( fillStyledRect+  , paintMenuAccent+  , paintTabHeader+  , paintTableHeader+  , strokeStyledRect+  , paintStyledRect+  , textInputFocused+  , textInputValue+  , widgetVisualStyle+  )+import NanoUI.Frame.Node (resolveFontFor)+import NanoUI.Frame.Paint.Types (PaintEnv (..), popupPanelRect)+import NanoUI.Frame.Spans (forWidgetTextPlacements_, selectableTextGeometry, widgetTextSpans)+import NanoUI.Frame.TextArea (drawTextAreaContentWith)+import NanoUI.Frame.TextArea.Content (resolveTextAreaFont)+import NanoUI.Frame.TextInput+  ( FieldEdit+  , drawTextInputCaret+  , drawTextInputSelection+  , readFieldEdit+  , syncTextInputScroll+  , textInputFieldRect+  , textInputFieldTextClip+  )+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , getNodeFontColor+  , getNodeFontSize+  , getNodeValue+  , getOptions+  , getStyleIdx+  , getText+  , getWidgetId+  )+import NanoUI.Style (Style, styleBg, styleBorder, styleFg, themeAccent, themeInput, themeOnAccent)+import NanoUI.Types (Color (..), Rect (..), clamp01, colorA, lerpColor, onGrid)+import NanoUI.WidgetText+  ( buttonCloseTrailing+  , buttonVisualStyle+  , comboTextClip+  , isCloseButtonStyle+  , isMenuBarStyle+  , isMenuItemStyle+  , isTabButtonStyle+  , isTableHeaderStyle+  , numericStepperRects+  , numericTextClip+  , searchFieldIconRects+  , searchFieldTextClip+  , selectChevronCenterX+  , selectChevronReserve+  , tableSortMarkOf+  , textInputNumericMode+  , textInputFieldText+  , textInputSearchMode+  , textInputSelectableMode+  , treeDecodeStyle+  )+import NanoUI.Widgets.ColorPicker (drawColorPickerPart)++-- | Single-line text input: selectable, bare, search, combo or captioned field+-- depending on the node's visual style.+{-# NOINLINE paintTextInputNode #-}+paintTextInputNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintTextInputNode env idx rect@(Rect x y w h) = do+  let ctx = peContext env+      da = peDrawArena env+      fm = peFontMetrics env+  style <- widgetVisualStyle ctx NodeTextInput idx+  focus <- textInputFocused ctx idx+  si <- getStyleIdx (peNodeArena env) idx+  if textInputNumericMode si+    then paintNumericField ctx da fm style idx focus rect+    else+      if textInputSelectableMode si+        then paintSelectableText env style idx rect+        else+          if textInputSearchMode si+            then do+              opts <- getOptions (peNodeArena env) idx+              if null opts+                then paintSearchField ctx da fm style idx focus rect+                else paintComboField ctx da fm style idx focus rect+            else do+              let field = textInputFieldRect fm x y w h+              paintStyledRect da style field+              spans <- widgetTextSpans ctx NodeTextInput idx x y w h+              case spans of+                (Rect fx fy _ _, txt, ffg, _) : _ -> do+                  mEdit <- readFieldEdit ctx idx x y w h =<< syncTextInputScroll ctx idx x y w h+                  paintClippedFieldText ctx da fm style idx mEdit (textInputFieldTextClip fm field) fx fy txt ffg+                [] -> pure ()++-- | Multi-line text area.+{-# NOINLINE paintTextAreaNode #-}+paintTextAreaNode :: PaintEnv -> NodeIdx -> Rect -> IO ()+paintTextAreaNode env idx (Rect x y w h) = do+  let ctx = peContext env+      da = peDrawArena env+  style <- widgetVisualStyle ctx NodeTextArea idx+  areaFm <- resolveTextAreaFont ctx idx+  paintStyledRect da style (Rect x y w h)+  drawTextAreaContentWith da ctx areaFm idx x y w h style++-- | Generic foreground / chrome widget (button, checkbox, radio, slider,+-- select, tree row, color swatch, table / tab header, ...). Splits into a+-- background pass and a label pass, both behind NOINLINE seams.+{-# NOINLINE paintWidget #-}+paintWidget :: PaintEnv -> NodeIdx -> NodeType -> Rect -> IO ()+paintWidget env idx nt rect@(Rect _ ry _ rh) = do+  let ctx = peContext env+  style <- widgetVisualStyle ctx nt idx+  value <- getNodeValue (peNodeArena env) idx+  si <- getStyleIdx (peNodeArena env) idx+  -- Menu rows paint edge-to-edge across the popup panel, exactly like the+  -- text-field context menu painter: the hover fill and the accent marker+  -- span the panel width instead of the (padded) node rect.+  menuRowRect <-+    if nt == NodeButton && isMenuItemStyle si+      then maybe rect (\(Rect px _ pw _) -> Rect px ry pw rh) <$> popupPanelRect ctx idx+      else pure rect+  paintWidgetBackground env idx nt style si menuRowRect value rect+  paintWidgetForeground env idx nt style si rect++-- The button kind flags are re-derived here from the style bits rather than+-- passed in: a flags record crossing this NOINLINE seam would be allocated+-- for every widget on every painted frame.+{-# NOINLINE paintWidgetBackground #-}+paintWidgetBackground :: PaintEnv -> NodeIdx -> NodeType -> Style -> Int -> Rect -> Float -> Rect -> IO ()+paintWidgetBackground env idx nt style si menuRowRect value (Rect x y w h) = do+  let ctx = peContext env+      da = peDrawArena env+      fm = peFontMetrics env+      theme = peTheme env+      -- Strict: lazy Bools here would allocate thunks per widget per frame.+      !isButton = nt == NodeButton+      !isClose = isButton && isCloseButtonStyle si+      !isTab = isButton && isTabButtonStyle si+      !isTable = isButton && isTableHeaderStyle si+      !isMenuItem = isButton && isMenuItemStyle si+      !isMenu = isMenuItem || (isButton && isMenuBarStyle si)+      !hasBg = colorA (styleBg style) > 0+      !opaqueBg+        | isMenu = hasBg+        | isClose || isTab = False+        | isTable || nt == NodeTree = hasBg+        | otherwise =+            nt /= NodeCheckbox && nt /= NodeRadio && nt /= NodeSlider+              && nt /= NodeTextInput && nt /= NodeTextArea && nt /= NodeColorPicker+  when opaqueBg $ fillStyledRect da style menuRowRect+  when (opaqueBg && not (isTab || isTable || isMenu) && nt /= NodeTree) $+    strokeStyledRect da style (Rect x y w h)+  when isMenuItem $ do+    wid <- getWidgetId (peNodeArena env) idx+    hot <- readIORef (ctxHotId ctx)+    -- Same marker as the text-field context menu, from the shared menu+    -- metrics, so the two painters cannot drift.+    when (wid == hot) $ paintMenuAccent da theme menuRowRect+  when isTab $+    paintTabHeader da theme (buttonVisualStyle si `mod` 4) (value > 0.5) style x y w h+  when isTable $+    paintTableHeader da theme (value > 0.5) style x y w h+  case nt of+    NodeCheckbox -> drawCheckbox da fm style x y h value (themeAccent theme) (styleBg (themeInput theme)) (themeOnAccent theme)+    NodeRadio -> drawRadio da fm style x y h value (themeAccent theme) (styleBg (themeInput theme))+    NodeTree -> do+      let (_, depth, hasKids, expanded) = treeDecodeStyle si+      when hasKids $+        drawTreeChevron da fm x y w h depth expanded (styleFg style)+    NodeSlider -> paintSliderBody env x y w h value+    NodeButton -> when isClose $ drawCloseIcon da (buttonVisualStyle si == buttonCloseTrailing) x y w h (styleFg style)+    NodeSelect -> drawSelectChevron da False x y w h (styleFg style)+    NodeColorPicker -> do+      store <- getStore ctx+      drawColorPickerPart (peNodeArena env) idx fm da store style (Rect x y w h)+    _ -> pure ()++{-# NOINLINE paintSliderBody #-}+paintSliderBody :: PaintEnv -> Float -> Float -> Float -> Float -> Float -> IO ()+paintSliderBody env x y w h value = do+  let da = peDrawArena env+      theme = peTheme env+      track@(Rect tx ty tw th) = sliderTrackBounds x y w h+      trackR = 3+      fillW = max 0 (tw * clamp01 value)+      outline = styleBorder (themeInput theme)+      well = lerpColor (styleBg (themeInput theme)) outline 0.35+      bw = 1+      innerR = max 0 (trackR - bw)+      innerX = tx + bw+      innerY = ty + bw+      innerW = tw - 2 * bw+      innerH = th - 2 * bw+      innerFillW = max 0 (innerW * clamp01 value)+  pushRoundedStroke da track trackR bw outline+  when (innerW > 0 && innerH > 0) $+    pushRoundedRect da (Rect innerX innerY innerW innerH) innerR well+  when (innerFillW > 0) $ do+    let fillR =+          if innerFillW >= innerW - 0.5+            then innerR+            else min innerR (innerFillW / 2)+    pushRoundedRect da (Rect innerX innerY innerFillW innerH) fillR (themeAccent theme)+  let handleD = sliderHandleDiameter+      handleCx = tx + max (handleD / 2) (min (tw - handleD / 2) fillW)+      handleHy = ty + (th - handleD) / 2+      innerD = handleD - 2+  pushRoundedRect+    da+    (Rect (handleCx - innerD / 2) (handleHy + (handleD - innerD) / 2) innerD innerD)+    (innerD / 2)+    (themeOnAccent theme)+  pushRoundedStroke da (Rect (handleCx - handleD / 2) handleHy handleD handleD) (handleD / 2) bw outline++{-# NOINLINE paintWidgetForeground #-}+paintWidgetForeground :: PaintEnv -> NodeIdx -> NodeType -> Style -> Int -> Rect -> IO ()+paintWidgetForeground env idx nt style si (Rect x y w h) = do+  let ctx = peContext env+      da = peDrawArena env+  mFontColor <- getNodeFontColor (peNodeArena env) idx+  fontSize <- getNodeFontSize (peNodeArena env) idx+  (fm, _, _) <- resolveFontFor ctx nt fontSize si+  let widgetFg = fromMaybe (styleFg style) mFontColor+      sortMark = if nt == NodeButton && isTableHeaderStyle si then tableSortMarkOf si else 0+      -- Table sort arrow: pinned to the header's right edge, inside the cell+      -- inset, whatever the label's alignment. The label still ends in a+      -- blank reserve slot (the ▲/▼ codepoint is not in the pruned UI font),+      -- which keeps the column wide enough for the text and the arrow.+      sortArrowX = x + w - tableCellInset - 5+      drawPlacement lastLine txt px py _ th =+        unless (T.null txt) $ do+          pushText da fm px py txt widgetFg+          when (sortMark /= 0 && lastLine) $+            drawSortTriangle da sortArrowX (py + th / 2) (sortMark == 2) widgetFg+  forWidgetTextPlacements_ ctx nt idx x y w h drawPlacement++-- | Sort direction triangle for a table header: up when ascending, down when+-- descending, centered on the label line in the header's reserved slot.+drawSortTriangle :: DrawArena -> Float -> Float -> Bool -> Color -> IO ()+drawSortTriangle da cx cy down col =+  if down+    then pushFilledTriangle da (cx - 5) (cy - 3.5) (cx + 5) (cy - 3.5) cx (cy + 3.5) col+    else pushFilledTriangle da (cx - 5) (cy + 3.5) (cx + 5) (cy + 3.5) cx (cy - 3.5) col++-- | Draw a single-line field's text, and its selection and caret while it is+-- being edited, inside @clip@. @penX/penY@ locate @txt@ (absolute).+{-# INLINE paintClippedFieldText #-}+paintClippedFieldText ::+  Context ->+  DrawArena ->+  FontMetrics ->+  Style ->+  NodeIdx ->+  Maybe FieldEdit ->+  Rect ->+  Float ->+  Float ->+  T.Text ->+  Color ->+  IO ()+paintClippedFieldText ctx da fm style idx mEdit clip penX penY txt fg =+  withClip da clip $ do+    mapM_ (drawTextInputSelection da ctx idx) mEdit+    unless (T.null txt) $+      pushText da fm penX penY txt fg+    mapM_ (\edit -> drawTextInputCaret da edit (styleFg style)) mEdit++-- | A caption-less field's value, or @placeholder@ (dimmed) while empty and+-- unfocused, scrolled to keep the caret in @clip@.+paintFieldValue :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> Rect -> T.Text -> T.Text -> IO ()+paintFieldValue ctx da fm style idx focus (Rect x y w h) clip@(Rect clipX _ _ _) placeholder value = do+  let display = textInputFieldText placeholder value focus+      baseFg = styleFg style+  scrollX <- syncTextInputScroll ctx idx x y w h+  (ty, fg) <-+    if T.null display+      then pure (0, baseFg)+      else do+        (_, th) <- ctxMeasureText ctx display+        pure+          ( centeredTextY fm y h th+          , if T.null value && not focus then lerpColor baseFg (styleBg style) 0.5 else baseFg+          )+  mEdit <- readFieldEdit ctx idx x y w h scrollX+  paintClippedFieldText ctx da fm style idx mEdit clip (clipX - scrollX) ty display fg++-- | Numeric field: the box, its value clipped left of the stepper, and the+-- stepper's up and down arrows beside a rule.+paintNumericField :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> IO ()+paintNumericField ctx da fm style idx focus box@(Rect x y w h) = do+  paintStyledRect da style box+  value <- textInputValue ctx idx+  let (up@(Rect ux _ _ _), down) = numericStepperRects x y w h+      iconCol = lerpColor (styleFg style) (styleBg style) 0.4+      ruleCol = lerpColor (styleBorder style) (styleBg style) 0.4+  pushLine da ux (y + 4) ux (y + h - 4) 1 ruleCol+  drawStepArrow da True up iconCol+  drawStepArrow da False down iconCol+  paintFieldValue ctx da fm style idx focus box (numericTextClip fm x y w h) "" value++-- | A stepper arrow in its half of the stepper, nudged toward the other half so+-- the pair reads as one control.+drawStepArrow :: DrawArena -> Bool -> Rect -> Color -> IO ()+drawStepArrow da up (Rect sx sy sw sh) col = do+  let cx = sx + sw / 2+      cy = sy + sh / 2 + (if up then 1 else -1)+      hw = 3.6+      tip = if up then -2.4 else 2.4+  pushFilledTriangle da (cx - hw) (cy - tip * 0.35) (cx + hw) (cy - tip * 0.35) cx (cy + tip) col++-- | Caption-less search field: box fills the node rect, magnifier on the left,+-- clear (×) on the right when there is text, and the editable value / caret /+-- selection confined to the space between them.+paintSearchField :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> IO ()+paintSearchField ctx da fm style idx focus box@(Rect x y w h) = do+  let (magRect, Rect cx cy cw ch) = searchFieldIconRects fm x y w h+      iconCol = lerpColor (styleFg style) (styleBg style) 0.45+  paintStyledRect da style box+  value <- textInputValue ctx idx+  lbl <- getText (ctxNodeArena ctx) idx+  drawSearchMagnifier da magRect iconCol+  paintFieldValue ctx da fm style idx focus box (searchFieldTextClip fm x y w h) lbl value+  unless (T.null value) $+    drawCloseIcon da False cx cy cw ch iconCol++-- | Selectable text: chrome-less, border-less, naturally sized text field+-- that supports mouse drag selection and text copying without an insertion caret.+paintSelectableText :: PaintEnv -> Style -> NodeIdx -> Rect -> IO ()+paintSelectableText env style idx rect@(Rect x y w h) = do+  let ctx = peContext env+      da = peDrawArena env+      arena = peNodeArena env+  si <- getStyleIdx arena idx+  mFontColor <- getNodeFontColor arena idx+  fontSize <- getNodeFontSize arena idx+  (fm, _, _) <- resolveFontFor ctx NodeTextInput fontSize si+  value <- textInputValue ctx idx+  let (penX, ty, _) = selectableTextGeometry fm x y h+  mEdit <- readFieldEdit ctx idx x y w h 0+  withClip da rect $ do+    mapM_ (drawTextInputSelection da ctx idx) mEdit+    unless (T.null value) $+      pushText da fm penX ty value (fromMaybe (styleFg style) mFontColor)++drawSearchMagnifier :: DrawArena -> Rect -> Color -> IO ()+drawSearchMagnifier da (Rect x y w h) col = do+  let cx = x + w / 2+      cy = y + h / 2+      s = min w h+      r0 = s * 0.36+      t = max 1.4 (s * 0.15)+      startOff = r0 * 0.7071+      endOff = r0 * 0.7071 + s * 0.22+  pushRoundedStroke da (Rect (cx - r0) (cy - r0) (2 * r0) (2 * r0)) r0 t col+  pushLine da (cx + startOff) (cy + startOff) (cx + endOff) (cy + endOff) (t * 0.8) col++-- | Combo box field: the search field's full-rect editable box, but styled+-- like a dropdown: no magnifier or clear chrome, and a select chevron in the+-- right reserve that flips up while the dropdown is open (i.e. focused).+paintComboField :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> IO ()+paintComboField ctx da fm style idx focus box@(Rect x y w h) = do+  paintStyledRect da style box+  value <- textInputValue ctx idx+  lbl <- getText (ctxNodeArena ctx) idx+  drawSelectChevron+    da+    focus+    (x + w - selectChevronReserve)+    y+    selectChevronReserve+    h+    (lerpColor (styleFg style) (styleBg style) 0.45)+  paintFieldValue ctx da fm style idx focus box (comboTextClip fm x y w h) lbl value++verticallyCenteredBox :: Float -> Float -> Float -> Float+verticallyCenteredBox y h box =+  let slotH = min h (box + 4)+   in y + max 0 ((slotH - box) / 2)++drawChoiceControl ::+  DrawArena ->+  FontMetrics ->+  Style ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Color ->+  Color ->+  Bool ->+  (Float -> Float -> Float -> IO ()) ->+  IO ()+drawChoiceControl da fm style x y h r bw value accent well solidChecked postMark = do+  let box = checkboxBoxSize fm+      bx = x+      by = verticallyCenteredBox y h box+      outer = Rect bx by box box+      checked = value >= 0.5+  if checked && solidChecked+    then do+      pushRoundedRect da outer r accent+      pushRoundedStroke da outer r bw accent+      postMark bx by box+    else do+      let inner = Rect (bx + bw) (by + bw) (box - 2 * bw) (box - 2 * bw)+          innerR = max 0 (r - bw)+          strokeCol = if checked then accent else styleBorder style+      pushRoundedRect da inner innerR well+      pushRoundedStroke da outer r bw strokeCol+      when checked $ postMark bx by box++drawCheckbox :: DrawArena -> FontMetrics -> Style -> Float -> Float -> Float -> Float -> Color -> Color -> Color -> IO ()+drawCheckbox da fm style x y h value accent well mark =+  let box = checkboxBoxSize fm+      r = min 6 (box / 3.5)+      bw = 1.5+   in drawChoiceControl da fm style x y h r bw value accent well True $ \bx by b ->+        drawCheckboxMark da bx by b mark++drawCheckboxMark :: DrawArena -> Float -> Float -> Float -> Color -> IO ()+drawCheckboxMark da bx by box markCol = do+  let t = max 1.6 (box * 0.11)+      x0 = bx + box * 0.22+      y0 = by + box * 0.52+      x1 = bx + box * 0.42+      y1 = by + box * 0.72+      x2 = bx + box * 0.78+      y2 = by + box * 0.28+      capR = t / 2+      cap cx cy =+        pushRoundedRect da (Rect (cx - capR) (cy - capR) t t) capR markCol+  pushStrokeAA da x0 y0 x1 y1 t markCol+  pushStrokeAA da x1 y1 x2 y2 t markCol+  cap x0 y0+  cap x1 y1+  cap x2 y2++drawRadio :: DrawArena -> FontMetrics -> Style -> Float -> Float -> Float -> Float -> Color -> Color -> IO ()+drawRadio da fm style x y h value accent well =+  let box = checkboxBoxSize fm+      r = box / 2+      bw = 2+   in drawChoiceControl da fm style x y h r bw value accent well False $ \bx by b -> do+        s <- readIORef (daSnapScale da)+        let !dot = b * 0.72+            !dx = onGrid s bx + (b - dot) / 2+            !dy = onGrid s by + (b - dot) / 2+        pushRoundedRectRaw da (Rect dx dy dot dot) (dot / 2) accent++-- | A cross centered in the box, or against its right edge when @trailing@.+drawCloseIcon :: DrawArena -> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()+drawCloseIcon da trailing x y w h col = do+  let arm = min w h * 0.21+      t = max 1.3 (min w h * 0.064)+      cx = if trailing then x + w - arm - t / 2 else x + w / 2+      cy = y + h / 2+  pushLine da (cx - arm) (cy - arm) (cx + arm) (cy + arm) t col+  pushLine da (cx - arm) (cy + arm) (cx + arm) (cy - arm) t col++-- | Select chevron centered in the right reserve of @x w@; points up when+-- @up@ (an open combo dropdown), down otherwise.+drawSelectChevron :: DrawArena -> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()+drawSelectChevron da up x y w h col = do+  let cx = selectChevronCenterX x w+      cy = y + h / 2+      hw = 4.2+      tip = if up then -2.6 else 2.6+  pushFilledTriangle da (cx - hw) (cy - tip * 0.35) (cx + hw) (cy - tip * 0.35) cx (cy + tip) col++drawTreeChevron :: DrawArena -> FontMetrics -> Float -> Float -> Float -> Float -> Int -> Bool -> Color -> IO ()+drawTreeChevron da fm x y w h depth expanded col = do+  let Rect cx cy cw ch = treeChevronRect fm x y w h depth+      mx = cx + cw / 2+      my = cy + ch / 2+      s = min 4.5 (min cw ch * 0.28)+      t = max 1.0 (s * 0.16)+  if expanded+    then do+      pushLine da (mx - s) (my - s * 0.45) mx (my + s * 0.7) t col+      pushLine da mx (my + s * 0.7) (mx + s) (my - s * 0.45) t col+    else do+      pushLine da (mx - s * 0.45) (my - s) (mx + s * 0.7) my t col+      pushLine da (mx + s * 0.7) my (mx - s * 0.45) (my + s) t col
+ lib/NanoUI/Frame/Redraw.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Redraw+  ( needsRedraw+  , pointerDragActive+  , textFieldActive+  , floatingPanelActive+  , debugPanelOpen+  , overlayMenuOpen+  , probeHotId+  ) where++import Data.IORef (IORef, readIORef)+import Data.Maybe (isJust)+import NanoUI.Context+  ( Context (..)+  , anyAnimating+  , anySelectOpen+  , getMenuPointerGesture+  , getScrollDrag+  , getStore+  , getTextInputMenu+  , getWindowDrag+  , getWindowResize+  , isDirty+  , modalActive+  )+import NanoUI.Frame.Hit (findNodeByWidgetId, nodePointVisible, overlayHitAllowed)+import NanoUI.Frame.Select (overlayMenuOwnerAt)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (Input (..), inputInteracted, inputMousePos, inputPointerHeld)+import NanoUI.Layout.Arena+  ( NodeType (..)+  , findNodeM+  , getNodeType+  , getOptions+  , getWidgetId+  , isFloatingNode+  , isWidgetNode+  )+import NanoUI.Types (V2 (..))++needsRedraw :: Context -> Input -> Input -> IO Bool+needsRedraw ctx prev inp = do+  dirty <- isDirty ctx+  anim <- anyAnimating ctx+  mDrag <- getScrollDrag ctx+  mWinDrag <- getWindowDrag ctx+  overlay <- overlayMenuOpen ctx+  edit <- textFieldActive ctx+  let moved = inputMousePos prev /= inputMousePos inp+  if dirty+    || anim+    || inputInteracted prev inp+    || inputWindowRedraw inp+    || inputPointerHeld inp+    || isJust mDrag+    || isJust mWinDrag+    || (overlay && moved)+    || edit+    then pure True+    else+      -- Idle: hover can only change when the pointer moved since the frame+      -- whose hover state we still hold. Skip the O(n) hot probe otherwise.+      if not moved+        then pure False+        else do+          lastHot <- readIORef (ctxLastHotId ctx)+          (/= lastHot) <$> probeHotId ctx (inputMousePos inp)++-- Window/scroll/resize drag marks dirty every frame, so input must still be+-- polled on those frames.+-- Color picker and slider hold ctxActiveId without extra window/scroll refs.+pointerDragActive :: Context -> IO Bool+pointerDragActive ctx = do+  winDrag <- isJust <$> getWindowDrag ctx+  scrollDrag <- isJust <$> getScrollDrag ctx+  winResize <- isJust <$> getWindowResize ctx+  sliderOrPicker <- focusedNodeIs ctx ctxActiveId (\nt -> nt == NodeSlider || nt == NodeColorPicker)+  pure (winDrag || scrollDrag || winResize || sliderOrPicker)++-- | Whether the node of the widget id held in @ref@ satisfies @p@.+focusedNodeIs :: Context -> (Context -> IORef WidgetId) -> (NodeType -> Bool) -> IO Bool+focusedNodeIs ctx ref p = do+  wid <- readIORef (ref ctx)+  if hashWidgetId wid == 0+    then pure False+    else do+      mIdx <- findNodeByWidgetId ctx wid+      case mIdx of+        Nothing -> pure False+        Just idx -> p <$> getNodeType (ctxNodeArena ctx) idx++-- Select dropdown or text-input menu is open. Overlay hover is not a widget id.+-- A focused combo (a search-style field carrying options) also owns an open+-- dropdown: report it so every frame while it is up redraws with full damage:+-- the floating list is painted by an overlay, so clip-damage frames would+-- leave stale rows in the retained texture.+overlayMenuOpen :: Context -> IO Bool+overlayMenuOpen ctx = do+  store <- getStore ctx+  menu <- getTextInputMenu ctx+  if anySelectOpen store || isJust menu+    then pure True+    else do+      focus <- readIORef (ctxFocusId ctx)+      if hashWidgetId focus == 0+        then pure False+        else do+          mIdx <- findNodeByWidgetId ctx focus+          case mIdx of+            Nothing -> pure False+            Just idx -> do+              nt <- getNodeType (ctxNodeArena ctx) idx+              if nt /= NodeTextInput+                then pure False+                else not . null <$> getOptions (ctxNodeArena ctx) idx++-- Focused text field or its context menu. Keep the loop live so typed bytes+-- are not stuck behind SDL_WaitEvent.+textFieldActive :: Context -> IO Bool+textFieldActive ctx = do+  menu <- getTextInputMenu ctx+  if isJust menu+    then pure True+    else focusedNodeIs ctx ctxFocusId (\nt -> nt == NodeTextInput || nt == NodeTextArea)++-- Last frame still has a floating node (modal or window). Used by backends to+-- decide whether overlay content might need periodic refresh (debug HUD).+floatingPanelActive :: Context -> IO Bool+floatingPanelActive ctx = do+  modal <- modalActive ctx+  if modal+    then pure True+    else isJust <$> findNodeM (ctxNodeArena ctx) (fmap isFloatingNode . getNodeType (ctxNodeArena ctx))++-- Floating window overlay (debug HUD). Prev floating rects persist across idle frames.+debugPanelOpen :: Context -> IO Bool+debugPanelOpen ctx =+  isJust <$> findNodeM (ctxNodeArena ctx) (fmap (== NodeWindow) . getNodeType (ctxNodeArena ctx))++probeHotId :: Context -> V2 -> IO WidgetId+probeHotId ctx mouse = do+  gesture <- getMenuPointerGesture ctx+  if gesture+    then pure (WidgetId 0)+    else do+      mOverlay <- overlayMenuOwnerAt ctx mouse+      case mOverlay of+        Just wid -> pure wid+        -- Earlier siblings paint over later ones, so the first hit wins.+        Nothing -> maybe (pure (WidgetId 0)) (getWidgetId na) =<< findNodeM na hits+  where+    na = ctxNodeArena ctx+    hits idx = do+      nt <- getNodeType na idx+      if not (isWidgetNode nt)+        then pure False+        else do+          visible <- nodePointVisible ctx idx mouse+          if visible then overlayHitAllowed ctx idx mouse else pure False
+ lib/NanoUI/Frame/Scroll.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE DataKinds #-}++-- | Scroll input: offsets baked into the arena, wheel routing, and scrollbar+-- thumb drags and track jumps.+module NanoUI.Frame.Scroll+  ( applyScrollOffsets+  , updateScrollWheel+  , updateScrollDrag+  , scrollBarsFor+  , scrollBarLayout+  , ScrollBarLayout (..)+  ) where++import Control.Applicative ((<|>))+import Control.Monad (forM_, void, when)+import Data.Foldable (find)+import Data.Maybe (fromMaybe)+import NanoUI.Context+  ( Context (..)+  , ScrollAxes (..)+  , ScrollBehavior (..)+  , applyScrollTarget+  , beginScrollMetrics+  , cacheScrollMetrics+  , clampScrollOffset+  , getMenuPointerGesture+  , getScrollDrag+  , getScrollOffset+  , getScrollOffset2D+  , getScrollOffsetIn+  , resolveScrollStep+  , scrollTargetOffset+  , setScrollOffset+  , setScrollOffset2D+  , nodeTheme+  , InteractionState (..)+  , getsInteraction+  , modifyInteraction+  )+import NanoUI.Frame.Hit (topmostModalAtMouse, topmostOverlayAtMouse)+import NanoUI.Frame.Node (ScrollNode (..), readScrollNode, scrollNodeViewport)+import NanoUI.Frame.Scroll.Geometry+  ( ScrollBarLayout (..)+  , ScrollConfig+  , borderContentClip+  , decodeScrollConfig+  , isScrollStyle2D+  , scrollAxisRange+  , scrollBarLayout+  , scrollBarLayouts2D+  , scrollChromeLane+  , scrollChromeSuppressed+  , scrollOffsetFromThumb+  , scrollWheelSuppressed+  )+import NanoUI.Frame.TextArea.Content (textAreaContentGeom)+import NanoUI.Frame.TextArea.Geometry (TextAreaBars (..), TextAreaScrollBarLayouts (..), textAreaBars, textAreaScrollBarLayouts)+import NanoUI.Id (WidgetId)+import NanoUI.Input (Input (..), inputMouseDown, inputMousePos, inputMousePressed, inputMouseReleased, inputScroll)+import NanoUI.Layout.Arena+  ( DirTag (..)+  , NodeIdx+  , NodeType (..)+  , arenaCount+  , findNodeM+  , forChildNodes_+  , getDirection+  , getFirstChild+  , getLayoutRect+  , getNextSibling+  , getNodeType+  , getParent+  , getRect+  , getStyleIdx+  , getWidgetId+  , isFloatingNode+  , isScrollNode+  , setClipRect+  , setRect+  , snapshotLayoutRects+  )+import NanoUI.Style (Padding (..), themePanel)+import NanoUI.Types (Rect (..), V2 (..), rectContains, rectIntersect, rectUnion)++applyScrollOffsets :: Context -> IO ()+applyScrollOffsets ctx = do+  beginScrollMetrics ctx+  snapshotLayoutRects (ctxNodeArena ctx)+  -- A frame that added no widgets has no root to walk.+  count <- arenaCount (ctxNodeArena ctx)+  when (count > 0) $ do+    (wx, wy, ww, wh) <- getRect (ctxNodeArena ctx) 0+    transformSubtree ctx 0 0 0 (Rect wx wy ww wh)++transformSubtree :: Context -> NodeIdx -> Float -> Float -> Rect -> IO ()+transformSubtree ctx idx scrollX scrollY parentClip = do+  let na = ctxNodeArena ctx+  nt <- getNodeType na idx+  (lx, ly, lw, lh) <- getLayoutRect na idx+  let floating = isFloatingNode nt+      (sx, sy) = if floating then (0, 0) else (scrollX, scrollY)+      within r = fromMaybe parentClip (rectIntersect parentClip r)+  (vx, vy, vw, vh) <-+    if floating+      then getRect na idx+      else pure (lx + sx, ly + sy, lw, lh)+  when (not floating) $ setRect na idx vx vy vw vh+  (!childScrollX, !childScrollY, !childClip) <-+    if isScrollNode nt+      then do+        (axes, viewport, range) <- scrollNodeGeometry ctx idx (Rect vx vy lw lh)+        wid <- getWidgetId na idx+        -- The only pass that sees a scroller's placed geometry. Everything+        -- that scrolls one between frames reads it back from here.+        cacheScrollMetrics ctx wid axes viewport range+        V2 dx dy <- getScrollOffsetIn ctx wid axes+        let clip = within viewport+        setClipRect na idx clip+        pure (sx - dx, sy - dy, clip)+      else do+        clip <-+          case nt of+            NodePanel -> do+              theme <- nodeTheme ctx idx+              pure (within (borderContentClip (themePanel theme) (Rect vx vy vw vh)))+            _ -> pure $! if floating then Rect vx vy vw vh else parentClip+        setClipRect na idx clip+        pure (sx, sy, clip)+  forChildNodes_ na idx $ \ci ->+    transformSubtree ctx ci childScrollX childScrollY childClip++-- | Axes, content viewport and reachable offset range of the scroll container+-- at @idx@ placed at @rect@, in window axes. The wheel, the programmatic+-- commands and the transform pass all size a scroll off this, so a scroller+-- cannot disagree with itself about how far it reaches.+scrollNodeGeometry :: Context -> NodeIdx -> Rect -> IO (ScrollAxes, Rect, V2)+scrollNodeGeometry ctx idx (Rect x y w h) = do+  sn@ScrollNode {snPad = pad, snContentMain = contentMain} <- readScrollNode (ctxNodeArena ctx) idx+  let viewport = scrollNodeViewport sn x y w h+      rangeH = scrollAxisRange contentMain (rectH viewport) (padB pad)+  pure $+    if sn2D sn+      then (ScrollAxisXY, viewport, V2 (scrollAxisRange (snContentW sn) (rectW viewport) (padR pad)) rangeH)+      else case snDir sn of+        DirColumn -> (ScrollAxisY, viewport, V2 0 rangeH)+        DirRow -> (ScrollAxisX, viewport, V2 (scrollAxisRange contentMain (rectW viewport) (padR pad)) 0)++updateScrollWheel :: Context -> Input -> IO ()+updateScrollWheel ctx inp = do+  let scroll@(V2 wheelX wheelY) = inputScroll inp+  when (wheelY /= 0 || wheelX /= 0) $ do+    -- An open dropdown (select menu or combo suggestions) owns the wheel:+    -- the combo widget scrolls its own window, and the scroller underneath+    -- the floating list must not move with it.+    mDrop <- getsInteraction ctx isOpenSelectDrop+    let overDrop = maybe False (\(_, r) -> rectContains r (inputMousePos inp)) mDrop+    when (not overDrop) $ do+      mNode <- findScrollNodeUnderMouse ctx (inputMousePos inp)+      forM_ mNode $ \idx -> do+        wid <- getWidgetId (ctxNodeArena ctx) idx+        void (tryApplyScrollWheelDelta ctx wid scroll)+        applyCrossAxisScroll ctx idx scroll++-- Nested 2D: apply the unused axis to a paired scroller in the same panel.+-- Do not walk past panel/window/modal into the page scroller.+applyCrossAxisScroll :: Context -> NodeIdx -> V2 -> IO ()+applyCrossAxisScroll ctx idx scroll = do+  dir <- getDirection (ctxNodeArena ctx) idx+  mAnc <- walkOppositeAncestor ctx idx dir+  case mAnc of+    Just pwid -> void (tryApplyScrollWheelDelta ctx pwid scroll)+    Nothing -> do+      mDesc <- findOppositeScrollDescendant ctx idx dir+      forM_ mDesc $ \dwid -> tryApplyScrollWheelDelta ctx dwid scroll++scrollCrossAxisStop :: NodeType -> Bool+scrollCrossAxisStop nt =+  nt == NodePanel || nt == NodeWindow || nt == NodeModal++walkOppositeAncestor :: Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)+walkOppositeAncestor ctx idx childDir = do+  p <- getParent (ctxNodeArena ctx) idx+  if p < 0+    then pure Nothing+    else do+      nt <- getNodeType (ctxNodeArena ctx) p+      if scrollCrossAxisStop nt+        then pure Nothing+        else+          if not (isScrollNode nt)+            then walkOppositeAncestor ctx p childDir+            else do+              pdir <- getDirection (ctxNodeArena ctx) p+              if pdir == childDir+                then walkOppositeAncestor ctx p childDir+                else Just <$> getWidgetId (ctxNodeArena ctx) p++findOppositeScrollDescendant :: Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)+findOppositeScrollDescendant ctx idx childDir = goChildren idx+  where+    want = if childDir == DirColumn then DirRow else DirColumn+    goChildren parent = getFirstChild (ctxNodeArena ctx) parent >>= go+    go ci+      | ci < 0 = pure Nothing+      | otherwise = do+          nt <- getNodeType (ctxNodeArena ctx) ci+          found <-+            if isScrollNode nt+              then do+                d <- getDirection (ctxNodeArena ctx) ci+                if d == want+                  then Just <$> getWidgetId (ctxNodeArena ctx) ci+                  else goChildren ci+              else goChildren ci+          case found of+            Just w -> pure (Just w)+            Nothing -> getNextSibling (ctxNodeArena ctx) ci >>= go++-- | Node owning scroller @wid@: its text area, or the first scroll container+-- with that id that the predicate does not rule out (table slave panes share+-- an id with their master). Thumb drags use the chrome predicate, since a+-- hidden bar has no lane to grab; the wheel uses the wider one, since a+-- hidden bar still scrolls.+scrollOwnerNode :: (ScrollConfig -> Bool -> DirTag -> Bool) -> Context -> WidgetId -> IO (Maybe NodeIdx)+scrollOwnerNode suppressed ctx wid =+  findNodeM na $ \idx -> do+    nt <- getNodeType na idx+    if nt /= NodeTextArea && not (isScrollNode nt)+      then pure False+      else do+        owner <- getWidgetId na idx+        if owner /= wid+          then pure False+          else+            if nt == NodeTextArea+              then pure True+              else do+                si <- getStyleIdx na idx+                dir <- getDirection na idx+                pure (not (suppressed (decodeScrollConfig si) (isScrollStyle2D si) dir))+  where+    na = ctxNodeArena ctx++tryApplyScrollWheelDelta :: Context -> WidgetId -> V2 -> IO Bool+tryApplyScrollWheelDelta ctx wid (V2 wheelX wheelY) = do+  mIdx <- scrollOwnerNode scrollWheelSuppressed ctx wid+  case mIdx of+    Nothing -> pure False+    Just idx -> do+      nt <- getNodeType na idx+      (axes, range) <-+        if nt == NodeTextArea+          then do+            (fm, field, contentW, contentH) <- textAreaContentGeom ctx idx+            let bars = textAreaBars fm field contentW contentH+            pure+              ( ScrollAxisXY+              , V2 (max 0 (contentW - tabViewW bars)) (max 0 (contentH - tabViewH bars))+              )+          else do+            (x, y, w, h) <- getRect na idx+            (axes, _, range) <- scrollNodeGeometry ctx idx (Rect x y w h)+            pure (axes, range)+      step <- resolveScrollStep ctx wid+      cur <- getScrollOffsetIn ctx wid axes+      -- Notches land on where the scroller is headed, not on where it is, so+      -- a flick mid-glide adds to the throw instead of restarting it.+      base@(V2 baseX baseY) <- scrollTargetOffset ctx wid cur+      let next = clampScrollOffset range (V2 (baseX + wheelX * step) (baseY + wheelY * step))+      if next == base && next == cur+        then pure False+        else True <$ applyScrollTarget ctx wid axes next ScrollSmooth+  where+    na = ctxNodeArena ctx++findScrollNodeUnderMouse :: Context -> V2 -> IO (Maybe NodeIdx)+findScrollNodeUnderMouse ctx mouse = do+  count <- arenaCount (ctxNodeArena ctx)+  if count <= 0+    then pure Nothing+    else do+      mModal <- topmostModalAtMouse ctx mouse+      mTop <- topmostOverlayAtMouse ctx mouse+      let start = fromMaybe 0 (mModal <|> mTop)+      (x, y, w, h) <- getRect (ctxNodeArena ctx) start+      queryScrollTarget ctx start mouse (Rect x y w h)++queryScrollTarget :: Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)+queryScrollTarget ctx idx mouse parentClip = do+  nt <- getNodeType (ctxNodeArena ctx) idx+  mClipHere <- scrollHitClip ctx idx nt parentClip+  case mClipHere of+    Nothing -> pure Nothing+    Just clip -> do+      childHit <- walkScrollSiblings ctx idx mouse clip+      case childHit of+        Just hit -> pure (Just hit)+        Nothing -> scrollHitSelf ctx idx nt mouse clip++walkScrollSiblings :: Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)+walkScrollSiblings ctx parent mouse clip = getFirstChild (ctxNodeArena ctx) parent >>= go+  where+    go ci+      | ci < 0 = pure Nothing+      | otherwise = do+          hit <- queryScrollTarget ctx ci mouse clip+          case hit of+            Just found -> pure (Just found)+            Nothing -> getNextSibling (ctxNodeArena ctx) ci >>= go++scrollHitSelf :: Context -> NodeIdx -> NodeType -> V2 -> Rect -> IO (Maybe NodeIdx)+scrollHitSelf ctx idx nt mouse clip+  | nt == NodeTextArea = do+      (fm, field, contentW, contentH) <- textAreaContentGeom ctx idx+      let bars = textAreaBars fm field contentW contentH+      pure $ case rectIntersect clip field of+        Just fclip+          | visibleHit fclip && (tabVertical bars || tabHorizontal bars) -> Just idx+        _ -> Nothing+  | isScrollNode nt && visibleHit clip = pure (Just idx)+  | otherwise = pure Nothing+  where+    visibleHit r@(Rect _ _ rw rh) = rw > 0 && rh > 0 && rectContains r mouse++-- Same clip stack as the span walk: scroll viewport (plus its bar lanes),+-- then panel bounds.+scrollHitClip :: Context -> NodeIdx -> NodeType -> Rect -> IO (Maybe Rect)+scrollHitClip ctx idx nt parentClip+  | isScrollNode nt = do+      (x, y, w, h) <- getRect na idx+      sn <- readScrollNode na idx+      let lane d = scrollChromeLane (snSlot sn) d x y w h (snPad sn)+          viewport = scrollNodeViewport sn x y w h+          hit+            | sn2D sn = rectUnion viewport (rectUnion (lane DirColumn) (lane DirRow))+            | otherwise = rectUnion viewport (lane (snDir sn))+      pure (rectIntersect parentClip hit)+  | nt == NodePanel = do+      (x, y, w, h) <- getRect na idx+      pure (rectIntersect parentClip (Rect x y w h))+  | otherwise = pure (Just parentClip)+  where+    na = ctxNodeArena ctx++-- | Scrollbar layouts of the scroller at @idx@ (id @wid@), each paired with a+-- setter for that axis's offset that skips unchanged values. Covers text+-- areas and native 2D and 1D scroll containers; a 1D scroller with suppressed+-- chrome has none.+scrollBarsFor :: Context -> NodeIdx -> WidgetId -> IO [(DirTag, ScrollBarLayout, Float -> IO ())]+scrollBarsFor ctx idx wid = do+  nt <- getNodeType na idx+  if nt == NodeTextArea+    then do+      (fm, field, contentW, contentH) <- textAreaContentGeom ctx idx+      cur@(V2 curX curY) <- getScrollOffset2D ctx wid+      let layouts = textAreaScrollBarLayouts fm field contentW contentH curX curY+      pure (axes2D cur (tasbVertical layouts) (tasbHorizontal layouts))+    else do+      (x, y, w, h) <- getRect na idx+      ScrollNode slot cfg native2D dir pad contentMain contentW <- readScrollNode na idx+      if native2D+        then do+          cur@(V2 offX offY) <- getScrollOffset2D ctx wid+          let (mV, mH) = scrollBarLayouts2D slot cfg x y w h pad contentW contentMain offX offY+          pure (axes2D cur mV mH)+        else+          if scrollChromeSuppressed cfg dir+            then pure []+            else do+              off <- getScrollOffset ctx wid+              pure+                [ (dir, layout, \new -> when (new /= off) (setScrollOffset ctx wid new))+                | Just layout <- [scrollBarLayout slot dir x y w h pad contentMain off]+                ]+  where+    na = ctxNodeArena ctx+    axes2D (V2 curX curY) mV mH =+      [(DirColumn, layout, \new -> when (new /= curY) (setScrollOffset2D ctx wid (V2 curX new))) | Just layout <- [mV]]+        ++ [(DirRow, layout, \new -> when (new /= curX) (setScrollOffset2D ctx wid (V2 new curY))) | Just layout <- [mH]]++updateScrollDrag :: Context -> Input -> IO ()+updateScrollDrag ctx inp+  | inputMouseReleased inp = modifyInteraction ctx (\s -> s {isScrollDrag = Nothing})+  | otherwise = do+      gesture <- getMenuPointerGesture ctx+      mDrag <- getScrollDrag ctx+      case mDrag of+        _ | gesture -> pure ()+        Just (wid, dragDir, grabOff)+          | inputMouseDown inp -> do+              -- A hidden bar has no lane to grab.+              bars <- maybe (pure []) (\idx -> scrollBarsFor ctx idx wid) =<< scrollOwnerNode (\cfg _ dir -> scrollChromeSuppressed cfg dir) ctx wid+              forM_ bars $ \(dir, layout, setOffset) ->+                when (dir == dragDir) $+                  setOffset (scrollOffsetFromThumb dir layout grabOff (inputMousePos inp))+        Nothing | inputMousePressed inp -> tryStartScrollDrag ctx inp+        _ -> pure ()++-- | Grab a thumb, or jump the thumb's center to a track press and keep+-- dragging from there.+tryStartScrollDrag :: Context -> Input -> IO ()+tryStartScrollDrag ctx inp = do+  let mouse = inputMousePos inp+  mIdx <- findScrollNodeUnderMouse ctx mouse+  forM_ mIdx $ \hitIdx -> do+    wid <- getWidgetId (ctxNodeArena ctx) hitIdx+    bars <- maybe (pure []) (\idx -> scrollBarsFor ctx idx wid) =<< scrollOwnerNode (\cfg _ dir -> scrollChromeSuppressed cfg dir) ctx wid+    forM_ (find (\(_, l, _) -> rectContains (sbThumb l) mouse || rectContains (sbTrack l) mouse) bars) $+        \(dir, layout, setOffset) -> do+          let thumb = sbThumb layout+              along (V2 mx my) = if dir == DirColumn then my else mx+              Rect tx ty tw th = thumb+          if rectContains thumb mouse+            then modifyInteraction ctx (\s -> s {isScrollDrag = Just (wid, dir, along mouse - along (V2 tx ty))})+            else do+              let half = along (V2 tw th) / 2+              setOffset (scrollOffsetFromThumb dir layout half mouse)+              modifyInteraction ctx (\s -> s {isScrollDrag = Just (wid, dir, half)})
+ lib/NanoUI/Frame/Scroll/Geometry.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE DataKinds #-}++-- | Scrollbar geometry: gutters, viewport clips, and track and thumb layout.+module NanoUI.Frame.Scroll.Geometry+  ( ScrollPolicy (..)+  , ScrollConfig (..)+  , defaultScrollConfig+  , ScrollBarLayout (..)+  , scrollContentClip+  , scrollViewportClip2D+  , scrollChromeLane+  , scrollBarLayout+  , scrollBarLayouts2D+  , scrollAxisRange+  , scrollOffsetFromThumb+  , padContentClip+  , encodeScrollConfig+  , decodeScrollConfig+  , scrollConfigNative2D+  , scrollDefault1D+  , scrollVerticalAuto+  , scrollVerticalHidden+  , scrollHorizontalHidden+  , scrollAxisGutter+  , scrollGutters2D+  , scrollChromeSuppressed+  , scrollWheelSuppressed+  , scrollLineFor+  , scrollAxisOverflows+  , scrollChromeActive+  , isScrollStyle2D+  , tagClippedSpans+  , padTextClipRect+  , borderContentClip+  ) where++import Data.Bits ((.&.), shiftL, shiftR)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import NanoUI.Font+  ( ScrollBarSlot (..)+  , scrollBarGap+  , scrollBarGeomFor+  , scrollBarGutter+  , scrollBarSideGap+  , scrollLayoutGutter+  )+import NanoUI.Types (Color, Rect (..), V2 (..), rectH, rectIntersect, rectW, rectX, rectY, v2X, v2Y)+import NanoUI.Layout.Arena (DirTag (..))+import NanoUI.Style (Direction (..), Padding (..), Style (..), styleBorderWidth, windowPad)++-- | Axis scrollbar visibility and interaction policy.+data ScrollPolicy+  = ScrollAuto+  | ScrollAlways+  | ScrollNone+  | ScrollHidden+  deriving (Eq, Show, Enum, Bounded)++-- | 2D scroll configuration (policy per axis).+data ScrollConfig = ScrollConfig+  { scrollPolicyX :: !ScrollPolicy+  , scrollPolicyY :: !ScrollPolicy+  , scrollClamp :: !Bool+  -- | A bare scroller paints no well of its own: no input background, no+  -- border, no window fill. Only the clipped children render, so a strip that+  -- borrows the scroller for its offset and clip (tab headers) looks exactly+  -- like it did before it started scrolling. Chrome policies still apply on+  -- top: 'ScrollHidden' plus bare is the fully chrome-less scroller.+  , scrollBare :: !Bool+  }+  deriving (Eq, Show)++defaultScrollConfig :: ScrollConfig+defaultScrollConfig =+  ScrollConfig+    { scrollPolicyX = ScrollAuto+    , scrollPolicyY = ScrollAuto+    , scrollClamp = True+    , scrollBare = False+    }++scrollConfigNative2D :: ScrollConfig -> Bool+scrollConfigNative2D cfg =+  scrollAxisActive (scrollPolicyX cfg) && scrollAxisActive (scrollPolicyY cfg)+  where+    scrollAxisActive = \case+      ScrollNone -> False+      _ -> True++encodeScrollConfig :: ScrollConfig -> Int+encodeScrollConfig cfg =+  policyBits (scrollPolicyX cfg)+    + shiftL (policyBits (scrollPolicyY cfg)) 2+    + (if scrollClamp cfg then 16 else 0)+    + (if scrollBare cfg then 32 else 0)+  where+    policyBits = \case+      ScrollAuto -> 0+      ScrollAlways -> 1+      ScrollNone -> 2+      ScrollHidden -> 3++decodeScrollConfig :: Int -> ScrollConfig+decodeScrollConfig bits =+  ScrollConfig+    { scrollPolicyX = decodePolicy (bits .&. 3)+    , scrollPolicyY = decodePolicy (shiftR bits 2 .&. 3)+    , scrollClamp = bits .&. 16 /= 0+    , scrollBare = bits .&. 32 /= 0+    }+  where+    decodePolicy 1 = ScrollAlways+    decodePolicy 2 = ScrollNone+    decodePolicy 3 = ScrollHidden+    decodePolicy _ = ScrollAuto++scrollDefault1D :: Direction -> ScrollConfig+scrollDefault1D Column = scrollVerticalAuto+scrollDefault1D Row = scrollHorizontalAuto++scrollVerticalAuto :: ScrollConfig+scrollVerticalAuto = ScrollConfig ScrollNone ScrollAuto True False++scrollHorizontalAuto :: ScrollConfig+scrollHorizontalAuto = ScrollConfig ScrollAuto ScrollNone True False++scrollVerticalHidden :: ScrollConfig+scrollVerticalHidden = ScrollConfig ScrollNone ScrollHidden True False++scrollHorizontalHidden :: ScrollConfig+scrollHorizontalHidden = ScrollConfig ScrollHidden ScrollNone True False++-- | Cross-axis gutter for one bar. @trailPad@ is the scroller's padding on+-- the bar's side (right for the vertical bar, bottom for the horizontal one).+scrollAxisGutter ::+  ScrollPolicy ->+  ScrollBarSlot ->+  Float ->+  Float ->+  Float ->+  Float+scrollAxisGutter policy slot trailPad contentSize innerMain =+  case policy of+    ScrollNone -> 0+    ScrollHidden -> 0+    ScrollAuto -> scrollLayoutGutter slot trailPad contentSize innerMain+    ScrollAlways -> scrollBarGutter slot trailPad++-- Vertical bar takes width. Horizontal bar takes height. Second pass+-- covers the corner case where one bar makes the other axis overflow.+scrollGutters2D ::+  ScrollBarSlot ->+  ScrollConfig ->+  Padding ->+  Float ->+  Float ->+  Float ->+  Float ->+  (Float, Float)+scrollGutters2D slot cfg pad contentW contentH innerW innerH =+  let gVert inner = scrollAxisGutter (scrollPolicyY cfg) slot (padR pad) contentH inner+      gHorz inner = scrollAxisGutter (scrollPolicyX cfg) slot (padB pad) contentW inner+      gW0 = gVert innerH+      gH0 = gHorz innerW+      gW = gVert (innerH - gH0)+      gH = gHorz (innerW - gW0)+   in (gW, gH)++isScrollStyle2D :: Int -> Bool+isScrollStyle2D si = si /= 0 && scrollConfigNative2D (decodeScrollConfig si)++scrollShowsChrome :: ScrollConfig -> DirTag -> Bool+scrollShowsChrome cfg dir =+  case dir of+    DirColumn -> axisShows (scrollPolicyY cfg)+    DirRow -> axisShows (scrollPolicyX cfg)+  where+    axisShows = \case+      ScrollAuto -> True+      ScrollAlways -> True+      _ -> False++scrollChromeSuppressed :: ScrollConfig -> DirTag -> Bool+scrollChromeSuppressed cfg dir = not (scrollShowsChrome cfg dir)++-- | Distance one wheel notch scrolls along a live axis. Window hosts step a+-- text line. Widgets that map wheel notches onto a scroller's offset share+-- this so the step cannot drift per caller.+scrollLineFor :: Float+scrollLineFor = 20++-- | Wheel eligibility is wider than chrome eligibility: a hidden bar never+-- paints or drags, but it still scrolls. Only a dead axis ('ScrollNone')+-- ignores the wheel outright. Native 2D scrollers always keep both axes+-- live by construction.+scrollWheelSuppressed :: ScrollConfig -> Bool -> DirTag -> Bool+scrollWheelSuppressed cfg native2D dir =+  not native2D+    && ( case dir of+           DirColumn -> scrollPolicyY cfg == ScrollNone+           DirRow -> scrollPolicyX cfg == ScrollNone+       )++scrollAxisOverflows :: ScrollPolicy -> Float -> Float -> Bool+scrollAxisOverflows policy contentSize innerMain =+  case policy of+    ScrollNone -> False+    ScrollHidden -> False+    ScrollAlways -> True+    ScrollAuto -> contentSize > innerMain + 0.5++-- | Scroll range along one axis. Content that fits (modulo the trailing+-- padding, which must not surface a bar by itself) does not scroll; genuine+-- overflow extends the range past the last child by the trailing padding so+-- scrolling to the end still reveals it. Stored content sizes exclude the+-- trailing padding (see positionScrollChildren); this is where it is added+-- back into the reachable range.+scrollAxisRange :: Float -> Float -> Float -> Float+scrollAxisRange contentSize innerMain trailingPad+  | contentSize > innerMain + 0.5 = max 0 (contentSize + trailingPad - innerMain)+  | otherwise = 0++scrollChromeActive :: ScrollConfig -> DirTag -> Float -> Float -> Bool+scrollChromeActive cfg dir contentSize innerMain =+  scrollShowsChrome cfg dir+    && scrollAxisOverflows+      (case dir of+         DirColumn -> scrollPolicyY cfg+         DirRow -> scrollPolicyX cfg)+      contentSize+      innerMain++data ScrollBarLayout = ScrollBarLayout+  { sbTrack :: Rect+  , sbThumb :: Rect+  , sbMaxOff :: Float+  }+  deriving (Eq, Show)++padContentClip :: Float -> Float -> Float -> Float -> Padding -> Rect+padContentClip x y w h pad =+  Rect+    (x + padL pad)+    (y + padT pad)+    (max 0 (w - padL pad - padR pad))+    (max 0 (h - padT pad - padB pad))++scrollContentClip ::+  ScrollBarSlot ->+  ScrollConfig ->+  DirTag ->+  Float ->+  Float ->+  Float ->+  Float ->+  Padding ->+  Float ->+  Rect+scrollContentClip slot cfg dir x y w h pad contentSize =+  let base = padContentClip x y w h pad+      innerMain =+        case dir of+          DirColumn -> rectH base+          DirRow -> rectW base+      (policy, trailPad) =+        case dir of+          DirColumn -> (scrollPolicyY cfg, padR pad)+          DirRow -> (scrollPolicyX cfg, padB pad)+      gutter = scrollAxisGutter policy slot trailPad contentSize innerMain+   in case dir of+        DirColumn -> Rect (rectX base) (rectY base) (max 0 (rectW base - gutter)) (rectH base)+        DirRow -> Rect (rectX base) (rectY base) (rectW base) (max 0 (rectH base - gutter))++scrollViewportClip2D ::+  ScrollBarSlot ->+  ScrollConfig ->+  Float ->+  Float ->+  Float ->+  Float ->+  Padding ->+  Float ->+  Float ->+  Rect+scrollViewportClip2D slot cfg x y w h pad contentW contentH =+  let base = padContentClip x y w h pad+      innerW = rectW base+      innerH = rectH base+      (gutterW, gutterH) = scrollGutters2D slot cfg pad contentW contentH innerW innerH+   in Rect (rectX base) (rectY base) (max 0 (innerW - gutterW)) (max 0 (innerH - gutterH))++-- | The strip a bar sits in. A list bar sits one gap (see 'scrollBarGap')+-- inside its well's edge. A page bar sits a side gap inside the page's edge,+-- and a window body's bar a side gap inside the window's edge, out in the+-- window's padding. The gutter keeps the content one gap before each of them.+scrollChromeLane ::+  ScrollBarSlot -> DirTag -> Float -> Float -> Float -> Float -> Padding -> Rect+scrollChromeLane slot dir x y w h pad =+  let (barW, _) = scrollBarGeomFor slot+      -- From the scroller's edge in to the bar's far side. Window and modal+      -- bodies only scroll vertically, so the window's side padding is the+      -- one that places their bar.+      inset trailPad = case slot of+        ScrollBarList -> scrollBarGap trailPad+        ScrollBarPage -> scrollBarSideGap+        ScrollBarWindow -> scrollBarSideGap - padR windowPad+   in case dir of+        DirColumn ->+          Rect (max x (x + w - inset (padR pad) - barW)) (y + padT pad) barW (max 0 (h - padT pad - padB pad))+        DirRow ->+          Rect (x + padL pad) (max y (y + h - inset (padB pad) - barW)) (max 0 (w - padL pad - padR pad)) barW++scrollBarLayout ::+  ScrollBarSlot ->+  DirTag ->+  Float ->+  Float ->+  Float ->+  Float ->+  Padding ->+  Float ->+  Float ->+  Maybe ScrollBarLayout+scrollBarLayout slot dir x y w h pad contentSize off =+  let innerW = w - padL pad - padR pad+      innerH = h - padT pad - padB pad+      viewMain = case dir of+        DirColumn -> innerH+        DirRow -> innerW+   in scrollBarLayoutIn slot dir x y w h pad viewMain contentSize off++-- | 'scrollBarLayout' with an explicit visible main extent. A native 2D+-- scroller passes the padding box minus the cross-axis lane (see+-- 'scrollGutters2D'), so its reachable range and thumb reflect the viewport+-- that is actually visible rather than the lane-underlapped padding box. On a+-- one-dimensional scroller @viewMain@ is just the padding box on that axis.+scrollBarLayoutIn ::+  ScrollBarSlot ->+  DirTag ->+  Float ->+  Float ->+  Float ->+  Float ->+  Padding ->+  Float ->+  Float ->+  Float ->+  Maybe ScrollBarLayout+scrollBarLayoutIn slot dir x y w h pad viewMain contentSize off =+  let (barW, barMargin) = scrollBarGeomFor slot+      minThumb = 16+   in case dir of+        DirColumn ->+          let trailH = padB pad+              extentH = contentSize + trailH+              maxOff = scrollAxisRange contentSize viewMain trailH+           in if maxOff <= 0+                then Nothing+                else+                  let lane = scrollChromeLane slot DirColumn x y w h pad+                      trackX = rectX lane+                      trackY = y + padT pad + barMargin+                      trackH = max 0 (viewMain - 2 * barMargin)+                      thumbH = max minThumb (trackH * viewMain / extentH)+                      ratio = off / maxOff+                      thumbY = trackY + ratio * (trackH - thumbH)+                   in+                    Just+                      ScrollBarLayout+                        { sbTrack = Rect trackX trackY barW trackH+                        , sbThumb = Rect trackX thumbY barW thumbH+                        , sbMaxOff = maxOff+                        }+        DirRow ->+          let trailW = padR pad+              extentW = contentSize + trailW+              maxOff = scrollAxisRange contentSize viewMain trailW+           in if maxOff <= 0+                then Nothing+                else+                  let lane = scrollChromeLane slot DirRow x y w h pad+                      trackY = rectY lane+                      trackX = x + padL pad + barMargin+                      trackW = max 0 (viewMain - 2 * barMargin)+                      thumbW = max minThumb (trackW * viewMain / extentW)+                      ratio = off / maxOff+                      thumbX = trackX + ratio * (trackW - thumbW)+                   in+                    Just+                      ScrollBarLayout+                        { sbTrack = Rect trackX trackY trackW barW+                        , sbThumb = Rect thumbX trackY thumbW barW+                        , sbMaxOff = maxOff+                        }++-- | Both-axis layouts for a native 2D scroller: (vertical, horizontal). Each+-- axis's visible main extent is reduced by the other axis's live gutter, so+-- the range and thumb are computed against the viewport minus the opposite+-- scrollbar lane.+scrollBarLayouts2D ::+  ScrollBarSlot ->+  ScrollConfig ->+  Float ->+  Float ->+  Float ->+  Float ->+  Padding ->+  Float ->+  Float ->+  Float ->+  Float ->+  (Maybe ScrollBarLayout, Maybe ScrollBarLayout)+scrollBarLayouts2D slot cfg x y w h pad contentW contentH offX offY =+  let innerW = w - padL pad - padR pad+      innerH = h - padT pad - padB pad+      (gutterW, gutterH) = scrollGutters2D slot cfg pad contentW contentH innerW innerH+      viewW = max 0 (innerW - gutterW)+      viewH = max 0 (innerH - gutterH)+      v = scrollBarLayoutIn slot DirColumn x y w h pad viewH contentH offY+      hr = scrollBarLayoutIn slot DirRow x y w h pad viewW contentW offX+   in (v, hr)++scrollOffsetFromThumb :: DirTag -> ScrollBarLayout -> Float -> V2 -> Float+scrollOffsetFromThumb dir layout grabOff mouse =+  let maxOff = sbMaxOff layout+      track = sbTrack layout+      thumb = sbThumb layout+   in case dir of+        DirColumn ->+          let trackY = rectY track+              trackH = rectH track+              thumbH = rectH thumb+              thumbTop = v2Y mouse - grabOff+              ratio = (thumbTop - trackY) / max 1 (trackH - thumbH)+           in max 0 (min maxOff (ratio * maxOff))+        DirRow ->+          let trackX = rectX track+              trackW = rectW track+              thumbW = rectW thumb+              thumbLeft = v2X mouse - grabOff+              ratio = (thumbLeft - trackX) / max 1 (trackW - thumbW)+           in max 0 (min maxOff (ratio * maxOff))++textClipSlop :: Float+textClipSlop = 4++tagClippedSpans :: Rect -> [(Rect, Text, Color, Color)] -> [(Rect, Text, Color, Color, Rect)]+tagClippedSpans clip =+  mapMaybe (\(rect, txt, fg, bg) -> (rect, txt, fg, bg,) <$> rectIntersect clip (padTextClipRect rect))++padTextClipRect :: Rect -> Rect+padTextClipRect (Rect x y w h) = Rect x y (w + textClipSlop) h++borderContentClip :: Style -> Rect -> Rect+borderContentClip style (Rect x y w h) =+  if styleBorderWidth style <= 0+    then Rect x y w h+    else+      let bw = max 1 (styleBorderWidth style)+       in Rect (x + bw) (y + bw) (max 0 (w - 2 * bw)) (max 0 (h - 2 * bw))
+ lib/NanoUI/Frame/Select.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Select+  ( selectDropRect+  , selectDropPickIndex+  , closeSelectOnOutsideClick+  , finalizeSelectKeyboard+  , finalizeSelectPick+  , markSelectDropPress+  , drawSelectOverlays+  , collectSelectDropdownSpans+  , findSelectUnderMouse+  , overlayMenuOwnerAt+  , cacheOpenSelectDrop+  , tagSelectClippedSpans+  , comboDropRect+  , comboDropPickIndex+  , comboScrollGeom+  ) where++import Control.Monad (forM, forM_, unless, when)+import Data.Foldable (find)+import Data.IORef (readIORef, writeIORef)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (catMaybes, listToMaybe, maybeToList)+import qualified Data.Text as T+import NanoUI.Context+  ( Context (..)+  , TextInputMenu (..)+  , WidgetStore (..)+  , anySelectOpen+  , closeSelects+  , getStore+  , getTextInputMenu+  , intKey+  , isSelectOpen+  , markDirty+  , markEscapeConsumed+  , setSelectOpen+  , setStore+  , widgetTheme+  , isDisabled+  , InteractionState (..)+  , modifyInteraction+  )+import NanoUI.Draw (pushRect, pushRoundedRect, pushText, withClip)+import NanoUI.Font (FontMetrics, centeredTextY, menuItemPadX, menuItemRowH, menuOuterPad, widgetContentInset)+import NanoUI.Frame.Chrome (overlayMenuStyle, paintMenuAccent, paintMenuPanel)+import NanoUI.Frame.Hit (findNodeByWidgetId, widgetOverlayAllowed)+import NanoUI.Frame.Scroll.Geometry (padTextClipRect)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (Input (..), Key (..), foldInputKeys, inputKeys, inputMouseDown, inputMousePos, inputMousePressed)+import NanoUI.Layout.Arena (NodeType (NodeSelect, NodeTextInput), findNodeM, foldNodeRevM, getNodeType, lookupNodeByWidgetId, getOptions, getRect, getWidgetId)+import NanoUI.Store (Slot (..), slotKey)+import NanoUI.Style (Style (..), Theme (..), scrollBarThumbColor, scrollBarTrackColor, themeAccent, themeInput)+import NanoUI.Types (Color (..), Rect (..), V2 (..), rectContains, rectIntersect)+import NanoUI.WidgetText (selectChevronReserve)++-- | An open dropdown: a select with its open flag set, or a combo box (a+-- search field carrying options) exactly while it holds focus.+data Dropdown = Dropdown+  { ddWidget :: !WidgetId+  , ddCombo :: !Bool+  , ddOptions :: [T.Text]+  , ddAnchor :: !Rect+  , ddRect :: !Rect+  , ddPicked :: !Int+  -- ^ Row shown as picked: the select's value, or the combo's keyboard+  -- highlight relative to its window (-1 highlights nothing).+  , ddComboRows :: !Int+  , ddComboWindow :: !Int+  , ddComboScrollX :: !Float+  , ddComboContentW :: !Float+  }++-- | Every open dropdown, in arena order.+openDropdowns :: Context -> IO [Dropdown]+openDropdowns ctx = do+  store <- getStore ctx+  focus <- readIORef (ctxFocusId ctx)+  -- Selects open only through the store flag and combos only while focused.+  -- With no select open, the focused node is the only candidate, so only an+  -- open select walks the arena.+  if anySelectOpen store+    then foldNodeRevM na (\acc idx -> maybe acc (: acc) <$> dropdownAt store focus idx) []+    else+      if hashWidgetId focus == 0+        then pure []+        else maybe (pure []) (fmap maybeToList . dropdownAt store focus) =<< lookupNodeByWidgetId na focus+  where+    na = ctxNodeArena ctx+    dropdownAt store focus idx =+      getNodeType na idx >>= \case+        NodeSelect -> do+          wid <- getWidgetId na idx+          if isSelectOpen store (intKey wid) then Just <$> build store idx wid False else pure Nothing+        NodeTextInput -> do+          wid <- getWidgetId na idx+          opts <- getOptions na idx+          if wid /= focus || null opts then pure Nothing else Just <$> build store idx wid True+        _ -> pure Nothing+    build store idx wid combo = do+      opts <- getOptions na idx+      (x, y, w, h) <- getRect na idx+      let key = intKey wid+          slotInt slot def = IM.findWithDefault def (slotKey slot key) (storeInt store)+          slotFloat slot = IM.findWithDefault 0 (slotKey slot key) (storeFloat store)+          nOpts = length opts+          rows = slotInt SlotComboCount nOpts+          window = slotInt SlotComboScroll 0+          contentW = slotFloat SlotComboContentW+      pure+        Dropdown+          { ddWidget = wid+          , ddCombo = combo+          , ddOptions = opts+          , ddAnchor = Rect x y w h+          , ddRect =+              if combo+                then comboDropRect x y w h nOpts rows contentW+                else selectDropRect x y w h nOpts+          , ddPicked =+              if combo+                then slotInt SlotComboHighlight (-1) - window+                else IM.findWithDefault 0 key (storeInt store)+          , ddComboRows = rows+          , ddComboWindow = window+          , ddComboScrollX = slotFloat SlotComboScrollX+          , ddComboContentW = contentW+          }++-- | One placed row of an open dropdown.+data DropdownRow = DropdownRow+  { drIndex :: !Int+  , drOption :: T.Text+  , drRect :: !Rect+  , drTextX :: !Float+  , drHovered :: !Bool+  }++-- | Rows of an open dropdown, shared by its painter and its text spans. Combo+-- rows sit flush at the drop rect's top edge (no outer margin) and scroll+-- horizontally; select rows keep their padded layout.+dropdownRows :: FontMetrics -> V2 -> Dropdown -> [DropdownRow]+dropdownRows fm mouse dd =+  let Rect dx dy dw _ = ddRect dd+      top = if ddCombo dd then dy else dy + menuOuterPad+      textX0 = dx + menuItemPadX + fst (widgetContentInset fm)+      textX = if ddCombo dd then textX0 - ddComboScrollX dd else textX0+   in [ DropdownRow i opt row textX (rectContains row mouse)+      | (i, opt) <- zip [0 ..] (ddOptions dd)+      , let row = Rect dx (top + menuItemRowH * fromIntegral i) dw menuItemRowH+      ]++overlayMenuOwnerAt :: Context -> V2 -> IO (Maybe WidgetId)+overlayMenuOwnerAt ctx mouse = do+  mMenu <- getTextInputMenu ctx+  case mMenu of+    Just m | rectContains (textInputMenuRect m) mouse -> pure (Just (textInputMenuWidget m))+    _ -> fmap ddWidget . find (\dd -> rectContains (ddRect dd) mouse) <$> openDropdowns ctx++cacheOpenSelectDrop :: Context -> IO ()+cacheOpenSelectDrop ctx = do+  dropdowns <- openDropdowns ctx+  modifyInteraction ctx (\s -> s {isOpenSelectDrop = (\dd -> (ddWidget dd, ddRect dd)) <$> listToMaybe dropdowns})++markSelectDropPress :: Context -> Input -> IO ()+markSelectDropPress ctx inp =+  when (inputMouseDown inp) $ do+    store <- getStore ctx+    when (anySelectOpen store) $ do+      let mouse = inputMousePos inp+      dropdowns <- openDropdowns ctx+      when (any (\dd -> rectContains (ddAnchor dd) mouse || rectContains (ddRect dd) mouse) dropdowns) $+        modifyInteraction ctx (\s -> s {isSelectDropPress = True})++closeSelectOnOutsideClick :: Context -> Input -> IO ()+closeSelectOnOutsideClick ctx inp =+  when (inputMousePressed inp || inputMouseReleased inp) $ do+    store <- getStore ctx+    when (anySelectOpen store) $ do+      let mouse = inputMousePos inp+      dropdowns <- openDropdowns ctx+      unless (any (\dd -> rectContains (ddAnchor dd) mouse || rectContains (ddRect dd) mouse) dropdowns) $+        setStore ctx (closeSelects store)++finalizeSelectKeyboard :: Context -> Input -> IO ()+finalizeSelectKeyboard ctx inp = do+  let (wantNext, wantPrev, wantEsc, wantEnter) =+        foldInputKeys+          ( \(n, p, e, r) k ->+              ( n || k == KeyDown || k == KeyRight+              , p || k == KeyUp || k == KeyLeft+              , e || k == KeyEscape+              , r || k == KeyEnter+              )+          )+          (False, False, False, False)+          (inputKeys inp)+      wantStep = wantNext || wantPrev+  when (wantStep || wantEsc || wantEnter) $ do+    focus <- readIORef (ctxFocusId ctx)+    store <- getStore ctx+    mTarget <- pickSelectKeyboardTarget ctx focus store wantStep+    forM_ mTarget $ \(wid, open) -> do+      allow <- widgetOverlayAllowed ctx wid+      when allow $+        if wantEsc || wantEnter+          then when open $ do+            setStore ctx (setSelectOpen store (intKey wid) False)+            when wantEsc $ markEscapeConsumed ctx+            markDirty ctx+          else do+            mIdx <- findNodeByWidgetId ctx wid+            forM_ mIdx $ \idx -> do+              n <- length <$> getOptions (ctxNodeArena ctx) idx+              when (n > 0) $ do+                let key = intKey wid+                    cur = IM.findWithDefault 0 key (storeInt store)+                    next = max 0 (min (n - 1) (cur + if wantNext then 1 else -1))+                when (next /= cur) $ do+                  setStore ctx (store {storeInt = IM.insert key next (storeInt store)})+                  markDirty ctx++pickSelectKeyboardTarget :: Context -> WidgetId -> WidgetStore -> Bool -> IO (Maybe (WidgetId, Bool))+pickSelectKeyboardTarget ctx focus store wantStep = do+  mFocus <- if wantStep then selectWidgetIfAny ctx focus else pure Nothing+  case mFocus of+    Just wid -> pure (Just (wid, isSelectOpen store (intKey wid)))+    Nothing -> fmap (,True) <$> findOpenSelectWidget ctx++selectWidgetIfAny :: Context -> WidgetId -> IO (Maybe WidgetId)+selectWidgetIfAny ctx wid+  | hashWidgetId wid == 0 = pure Nothing+  | otherwise = do+      mIdx <- findNodeByWidgetId ctx wid+      case mIdx of+        Nothing -> pure Nothing+        Just idx -> do+          nt <- getNodeType (ctxNodeArena ctx) idx+          disabled <- isDisabled ctx wid+          pure (if nt == NodeSelect && not disabled then Just wid else Nothing)++findOpenSelectWidget :: Context -> IO (Maybe WidgetId)+findOpenSelectWidget ctx = do+  store <- getStore ctx+  let na = ctxNodeArena ctx+  mIdx <-+    findNodeM na $ \idx -> do+      nt <- getNodeType na idx+      if nt /= NodeSelect+        then pure False+        else isSelectOpen store . intKey <$> getWidgetId na idx+  traverse (getWidgetId na) mIdx++finalizeSelectPick :: Context -> Input -> IO ()+finalizeSelectPick ctx inp =+  when (inputMousePressed inp || inputMouseReleased inp) $ do+    let mouse@(V2 _ mouseY) = inputMousePos inp+    dropdowns <- openDropdowns ctx+    forM_ dropdowns $ \dd -> do+      allow <- widgetOverlayAllowed ctx (ddWidget dd)+      when (allow && rectContains (ddRect dd) mouse) $ do+        st <- getStore ctx+        let wid = ddWidget dd+            key = intKey wid+            nOpts = length (ddOptions dd)+        if ddCombo dd+          then do+            -- Combo: pick on press only, never from the scrollbar lanes, so+            -- finishing a thumb drag cannot commit a row. Picking commits the+            -- option text into the field and defocuses it: the combo's+            -- dropdown is visible exactly while focused, so the menu+            -- disappears with the pick.+            let (_, vSb, hSb, _) = comboScrollGeom (ddRect dd) (ddComboRows dd) nOpts (ddComboWindow dd) (ddComboScrollX dd) (ddComboContentW dd)+                onLane = any (\(track, _) -> rectContains track mouse) (catMaybes [vSb, hSb])+            when (inputMousePressed inp && not onLane) $+              forM_ (comboDropPickIndex (ddRect dd) menuItemRowH nOpts mouseY) $ \picked -> do+                let txt = maybe "" id (listToMaybe (drop picked (ddOptions dd)))+                    len = T.length txt+                setStore+                  ctx+                  ( st+                      { storeText = IM.insert key txt (storeText st)+                      , storeInt =+                          IM.insert (slotKey SlotCursor key) len $+                            IM.insert (slotKey SlotAnchor key) len (storeInt st)+                      }+                  )+                writeIORef (ctxFocusId ctx) (WidgetId 0)+                markDirty ctx+          else+            forM_ (selectDropPickIndex (ddRect dd) menuItemRowH nOpts mouseY) $ \picked -> do+              setStore ctx (setSelectOpen (st {storeInt = IM.insert key picked (storeInt st)}) key False)+              writeIORef (ctxFocusId ctx) wid+              markDirty ctx++-- | Topmost open dropdown owner (in reverse arena order) whose anchor or menu+-- is under @mouse@ and that the modal state lets receive input.+findSelectUnderMouse :: Context -> V2 -> IO (Maybe WidgetId)+findSelectUnderMouse ctx mouse = do+  dropdowns <- openDropdowns ctx+  firstAllowed [dd | dd <- reverse dropdowns, rectContains (ddAnchor dd) mouse || rectContains (ddRect dd) mouse]+  where+    firstAllowed [] = pure Nothing+    firstAllowed (dd : rest) = do+      allow <- widgetOverlayAllowed ctx (ddWidget dd)+      if allow then pure (Just (ddWidget dd)) else firstAllowed rest++-- | Vertical gap between the select widget and its dropdown menu.+selectDropGap :: Float+selectDropGap = 4++selectDropRect :: Float -> Float -> Float -> Float -> Int -> Rect+selectDropRect x y w h nOpts =+  Rect x (y + h + selectDropGap) w (menuItemRowH * fromIntegral nOpts + 2 * menuOuterPad)++selectDropPickIndex :: Rect -> Float -> Int -> Float -> Maybe Int+selectDropPickIndex dropRect itemH nOpts mouseY =+  let Rect _ dy _ dh = dropRect+      innerH = itemH * fromIntegral nOpts+      rel = mouseY - dy - max 0 ((dh - innerH) / 2)+   in if rel < 0 || rel >= innerH+        then Nothing+        else Just (max 0 (min (nOpts - 1) (floor (rel / max itemH 1))))++-- Combo dropdown scrollbar sizes: lane thickness and the shortest a thumb+-- ever gets.+comboSbW, comboSbMinThumb :: Float+comboSbW = 10+comboSbMinThumb = 24++-- | Scrollbar geometry for a combo dropdown, shared by the overlay painter,+-- the pick guard, and the widget's thumb-drag gesture. The list has no outer+-- margin: rows fill the drop rect edge to edge, and a vertical lane sits on+-- the right when rows overflow the window, a horizontal one on the bottom+-- when the widest row overflows the width. Returns (inner rows area,+-- vertical (track, thumb), horizontal (track, thumb), usable content width).+comboScrollGeom ::+  Rect ->+  Int ->+  Int ->+  Int ->+  Float ->+  Float ->+  (Rect, Maybe (Rect, Rect), Maybe (Rect, Rect), Float)+comboScrollGeom (Rect dx dy dw dh) n vis win xOff contentW =+  let+    vScroll = n > vis && vis > 0+    vLaneW = if vScroll then comboSbW else 0+    usableW = max 0 (dw - vLaneW)+    hScroll = contentW > usableW && contentW > 0+    hLaneH = if hScroll then comboSbW else 0+    -- Rows fill the drop rect from the top, stopping short of the lanes.+    inner = Rect dx dy (max 0 (dw - vLaneW)) (max 0 (dh - hLaneH))+    -- Lanes sit flush against the dropdown border and share the corner.+    vTrack = Rect (dx + dw - comboSbW) dy comboSbW (max 0 (dh - hLaneH))+    hTrack = Rect dx (dy + dh - comboSbW) (max 0 (dw - vLaneW)) comboSbW+    vSb =+      if vScroll+        then+          let Rect vx vy _ vh = vTrack+              trackH = max 1 vh+              thumbH = max (min comboSbMinThumb trackH) (min trackH (trackH * fromIntegral vis / fromIntegral n))+              maxWin = max 1 (n - vis)+              ty = vy + (trackH - thumbH) * fromIntegral (max 0 (min maxWin win)) / fromIntegral maxWin+           in Just (vTrack, Rect (vx + 2) ty (comboSbW - 4) thumbH)+        else Nothing+    hSb =+      if hScroll+        then+          let Rect hx hy hw _ = hTrack+              trackW = max 1 hw+              thumbW = max (min comboSbMinThumb trackW) (min trackW (trackW * usableW / contentW))+              maxOff = max 1 (contentW - usableW)+              tx = hx + (trackW - thumbW) * max 0 (min maxOff xOff) / maxOff+           in Just (hTrack, Rect tx (hy + 2) thumbW (comboSbW - 4))+        else Nothing+   in (inner, vSb, hSb, usableW)++-- | Combo dropdown rect: like 'selectDropRect', but with no outer margin+-- (rows start flush at the top), and the height reserves a flush bottom+-- scrollbar lane when the widest row overflows, so the horizontal bar never+-- covers the bottommost row. Must agree with 'comboScrollGeom' on when lanes+-- appear (same inputs, same formulas).+comboDropRect :: Float -> Float -> Float -> Float -> Int -> Int -> Float -> Rect+comboDropRect x y w h nRows nTotal contentW =+  let vLaneW = if nTotal > nRows then comboSbW else 0+      hScroll = contentW > max 0 (w - vLaneW) && contentW > 0+   in Rect x (y + h + selectDropGap) w (fromIntegral nRows * menuItemRowH + (if hScroll then comboSbW else 0))++-- | Row index at @mouseY@ for a combo dropdown, whose rows start flush at the+-- drop rect's top (unlike 'selectDropPickIndex', which centers them).+comboDropPickIndex :: Rect -> Float -> Int -> Float -> Maybe Int+comboDropPickIndex (Rect _ dy _ _) itemH nOpts mouseY =+  let rel = mouseY - dy+   in if rel < 0 || rel >= itemH * fromIntegral nOpts+        then Nothing+        else Just (max 0 (min (nOpts - 1) (floor (rel / max itemH 1))))++drawSelectOverlays :: Context -> Input -> IO ()+drawSelectOverlays ctx inp = do+  dropdowns <- openDropdowns ctx+  forM_ dropdowns $ \dd -> do+    allow <- widgetOverlayAllowed ctx (ddWidget dd)+    when allow $ do+      theme <- widgetTheme ctx (ddWidget dd)+      drawDropdownMenu ctx inp theme dd++-- | Paint one open dropdown (select or combo). The combo list clips to its+-- inner area (so x-shifted text and row fills stop at the scrollbar lanes)+-- and gets vertical / horizontal scrollbars when the filtered rows or the+-- widest row overflow the window.+drawDropdownMenu :: Context -> Input -> Theme -> Dropdown -> IO ()+drawDropdownMenu ctx inp theme dd = do+  let da = ctxDrawArena ctx+      fm = ctxFontMetrics ctx+      style = overlayMenuStyle theme+      paintRows =+        forM_ (dropdownRows fm (inputMousePos inp) dd) $ \row -> do+          let picked = drIndex row == ddPicked dd+              Rect _ ry _ rh = drRect row+          if drHovered row+            then do+              pushRect da (drRect row) (styleHoverBg style)+              paintMenuAccent da theme (drRect row)+            else when picked $ pushRect da (drRect row) (styleActiveBg style)+          unless (T.null (drOption row)) $ do+            (_, th) <- ctxMeasureText ctx (drOption row)+            pushText da fm (drTextX row) (centeredTextY fm ry rh th) (drOption row) $+              if picked then themeAccent theme else styleFg style+  paintMenuPanel da theme style (ddRect dd)+  if ddCombo dd+    then do+      let (inner, vSb, hSb, _) = comboScrollGeom (ddRect dd) (ddComboRows dd) (length (ddOptions dd)) (ddComboWindow dd) (ddComboScrollX dd) (ddComboContentW dd)+          base = themeInput theme+          drawBar (track, thumb) = do+            pushRect da track (scrollBarTrackColor base theme)+            pushRoundedRect da thumb 3 (scrollBarThumbColor base theme)+      withClip da inner paintRows+      mapM_ drawBar vSb+      mapM_ drawBar hSb+    else paintRows++collectSelectDropdownSpans :: Context -> Input -> IO [(Rect, T.Text, Color, Color, Rect)]+collectSelectDropdownSpans ctx inp = do+  dropdowns <- openDropdowns ctx+  let fm = ctxFontMetrics ctx+  fmap concat . forM dropdowns $ \dd -> do+    allow <- widgetOverlayAllowed ctx (ddWidget dd)+    style <- overlayMenuStyle <$> widgetTheme ctx (ddWidget dd)+    if not allow+      then pure []+      else fmap concat . forM (dropdownRows fm (inputMousePos inp) dd) $ \row ->+        if T.null (drOption row)+          then pure []+          else do+            (tw, th) <- ctxMeasureText ctx (drOption row)+            let Rect _ ry _ rh = drRect row+                bg+                  | drHovered row = styleHoverBg style+                  | drIndex row == ddPicked dd = styleActiveBg style+                  | otherwise = styleBg style+            pure [(Rect (drTextX row) (centeredTextY fm ry rh th) tw th, drOption row, styleFg style, bg, ddRect dd)]++tagSelectClippedSpans ::+  Rect -> Float -> Float -> Float -> Float -> FontMetrics -> [(Rect, T.Text, Color, Color)] -> [(Rect, T.Text, Color, Color, Rect)]+tagSelectClippedSpans parentClip x y w h fm spans =+  let (ix, _) = widgetContentInset fm+      textClip = padTextClipRect (Rect (x + ix) y (max 0 (w - ix - selectChevronReserve)) (max 0 h))+   in case rectIntersect parentClip textClip of+        Nothing -> []+        Just clip -> [(rect, txt, fg, bg, clip) | (rect, txt, fg, bg) <- spans]
+ lib/NanoUI/Frame/SpanArena.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE RecordWildCards #-}++-- | Flat span buffer: strided prim arrays for geometry and colors, boxed texts.+module NanoUI.Frame.SpanArena+  ( SpanArena+  , newSpanArena+  , resetSpanArena+  , pushSpan+  , spanArenaCount+  , spanArenaToList+  , spanArenaToListOccluded+  , foldSpanArena+  ) where++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Data.IntMap.Strict as IM+import Data.Primitive.Array (MutableArray, copyMutableArray, newArray, readArray, sizeofMutableArray, writeArray)+import Data.Primitive.PrimArray+  ( MutablePrimArray+  , newPrimArray+  , readPrimArray+  , resizeMutablePrimArray+  , writePrimArray+  )+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word (Word32)+import GHC.Exts (RealWorld)+import NanoUI.Types (Color (..), Rect (..), colorToWord32, rectFullyInside, rectIntersect)++data SpanArena = SpanArena+  { saCount :: IORef Int+  , saArrays :: IORef SpanArenaArrays+  }++-- | Span columns. @saRects@ holds 'rectStride' floats per span (the span rect,+-- then its clip), @saColors@ the foreground and background, and @saTexts@ one+-- text per span; its size is the capacity.+data SpanArenaArrays = SpanArenaArrays+  { saRects :: !(MutablePrimArray RealWorld Float)+  , saColors :: !(MutablePrimArray RealWorld Word32)+  , saTexts :: !(MutableArray RealWorld Text)+  }++rectStride :: Int+rectStride = 8++newSpanArena :: Int -> IO SpanArena+newSpanArena cap0 = do+  let cap = max 16 cap0+  saCount <- newIORef 0+  saRects <- newPrimArray (cap * rectStride)+  saColors <- newPrimArray (cap * 2)+  saTexts <- newArray cap T.empty+  saArrays <- newIORef SpanArenaArrays {..}+  pure SpanArena {..}++resetSpanArena :: SpanArena -> IO ()+resetSpanArena sa = writeIORef (saCount sa) 0++spanArenaCount :: SpanArena -> IO Int+spanArenaCount sa = readIORef (saCount sa)++{-# NOINLINE growSpanArena #-}+growSpanArena :: SpanArena -> SpanArenaArrays -> Int -> IO SpanArenaArrays+growSpanArena sa SpanArenaArrays {saRects = rects, saColors = colors, saTexts = texts} needed = do+  let cap = sizeofMutableArray texts+      newCap = max needed (cap * 2)+  saRects <- resizeMutablePrimArray rects (newCap * rectStride)+  saColors <- resizeMutablePrimArray colors (newCap * 2)+  saTexts <- newArray newCap T.empty+  copyMutableArray saTexts 0 texts 0 cap+  let a = SpanArenaArrays {..}+  writeIORef (saArrays sa) a+  pure a++{-# INLINE pushSpan #-}+pushSpan :: SpanArena -> Rect -> Text -> Color -> Color -> Rect -> IO ()+pushSpan sa (Rect x y w h) txt fg bg (Rect cx cy cw ch) = do+  i <- readIORef (saCount sa)+  a0 <- readIORef (saArrays sa)+  SpanArenaArrays {..} <-+    if i < sizeofMutableArray (saTexts a0) then pure a0 else growSpanArena sa a0 (i + 1)+  let !r = i * rectStride+  writePrimArray saRects r x+  writePrimArray saRects (r + 1) y+  writePrimArray saRects (r + 2) w+  writePrimArray saRects (r + 3) h+  writePrimArray saRects (r + 4) cx+  writePrimArray saRects (r + 5) cy+  writePrimArray saRects (r + 6) cw+  writePrimArray saRects (r + 7) ch+  writePrimArray saColors (2 * i) (colorToWord32 fg)+  writePrimArray saColors (2 * i + 1) (colorToWord32 bg)+  writeArray saTexts i txt+  writeIORef (saCount sa) (i + 1)++spanArenaToList :: SpanArena -> IO [(Rect, Text, Color, Color, Rect)]+spanArenaToList = spanArenaToListOccluded IM.empty++-- | Spans in push order, dropping those hidden behind @panels@.+spanArenaToListOccluded :: IM.IntMap Rect -> SpanArena -> IO [(Rect, Text, Color, Color, Rect)]+spanArenaToListOccluded panels sa =+  foldSpans panels sa True (\acc r t fg bg c -> pure ((r, t, fg, bg, c) : acc)) []++foldSpanArena :: SpanArena -> (Rect -> Text -> Color -> Color -> Rect -> IO ()) -> IO ()+foldSpanArena sa f = foldSpans IM.empty sa False (\_ r t fg bg c -> f r t fg bg c) ()++-- | Fold over the spans not hidden behind @panels@, first to last, or last to+-- first when @backwards@ (so a consing fold builds a list in push order).+{-# INLINE foldSpans #-}+foldSpans ::+  IM.IntMap Rect ->+  SpanArena ->+  Bool ->+  (acc -> Rect -> Text -> Color -> Color -> Rect -> IO acc) ->+  acc ->+  IO acc+foldSpans panels sa backwards f z = do+  n <- readIORef (saCount sa)+  SpanArenaArrays {..} <- readIORef (saArrays sa)+  let panelRects = IM.elems panels+      go !i !acc+        | i < 0 || i >= n = pure acc+        | otherwise = do+            let !r = i * rectStride+            x <- readPrimArray saRects r+            y <- readPrimArray saRects (r + 1)+            w <- readPrimArray saRects (r + 2)+            h <- readPrimArray saRects (r + 3)+            cx <- readPrimArray saRects (r + 4)+            cy <- readPrimArray saRects (r + 5)+            cw <- readPrimArray saRects (r + 6)+            ch <- readPrimArray saRects (r + 7)+            fg <- readPrimArray saColors (2 * i)+            bg <- readPrimArray saColors (2 * i + 1)+            txt <- readArray saTexts i+            let rect = Rect x y w h+                clip = Rect cx cy cw ch+            acc' <-+              if not (null panelRects) && spanOccluded panelRects rect clip+                then pure acc+                else f acc rect txt (Color fg) (Color bg) clip+            go (if backwards then i - 1 else i + 1) acc'+  go (if backwards then n - 1 else 0) z++spanOccluded :: [Rect] -> Rect -> Rect -> Bool+spanOccluded panelRects rect clip =+  case rectIntersect rect clip of+    Nothing -> True+    Just visible -> any (rectFullyInside visible) panelRects
+ lib/NanoUI/Frame/Spans.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE DataKinds #-}++module NanoUI.Frame.Spans+  ( collectTextSpans+  , collectOverlayTextSpans+  , collectRasterSpans+  , widgetNodeCount+  , widgetHitRect+  , widgetTextSpans+  , forWidgetTextPlacements_+  , selectableTextGeometry+  , collectNodeTextSpans+  ) where++import Control.Monad (forM, unless, when)+import Data.IORef (readIORef, writeIORef)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Text as T+import NanoUI.Context+  ( Context (..)+  , SpanCacheEntry (..)+  , WidgetTextCacheEntry (..)+  , WidgetTextPlacement (..)+  , nodeTheme+  )+import NanoUI.Damage (floatingPanelRects)+import NanoUI.Font+  ( FontMetrics (..)+  , alignedTextPen+  , centeredTextY+  , checkboxLeading+  , menuItemPadX+  , prepareFontMetrics+  , tableCellInset+  , treeRowLeading+  , truncateTextIO+  , widgetContentInset+  , wrapTextLinesIO+  )+import NanoUI.Frame.Chrome (displayText, textInputFocused, textInputValue, widgetVisualStyle)+import NanoUI.Frame.Node (readScrollNode, resolveFontFor, scrollNodeViewport)+import NanoUI.Frame.Scroll.Geometry (padContentClip, tagClippedSpans)+import NanoUI.Frame.Select (collectSelectDropdownSpans, tagSelectClippedSpans)+import NanoUI.Frame.SpanArena (SpanArena, pushSpan, resetSpanArena, spanArenaToList, spanArenaToListOccluded)+import NanoUI.Frame.TextEdit.Menu (collectTextEditMenuSpans)+import NanoUI.Frame.TextInput (syncTextInputScroll, tagTextInputClippedSpans, textInputFieldRect)+import NanoUI.Input (Input)+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , SizingTag (..)+  , arenaCount+  , forNodes_+  , getAlignX+  , getClipRect+  , getFirstChild+  , getMinMax+  , getNextSibling+  , getNodeFontColor+  , getNodeFontSize+  , getNodeType+  , getPadding+  , getRect+  , getStyleIdx+  , getText+  , getWidthSizing+  , isFloatingNode+  , isScrollNode+  , isWidgetNode+  , parentIsRow+  )+import NanoUI.Layout.Solve (findAncestorMaxW)+import NanoUI.Style (AlignX (..), FontVariant (..), Style (..), Theme (..), themeAccent, themeMuted, themePanel)+import NanoUI.Types (Color (..), Rect (..), lerpColor, onGrid, rectIntersect)+import NanoUI.Widgets.ColorPicker (ColorPickerPart (..), colorPickerPartOf, colorPickerPartRect, colorPickerPreviewGeom)+import NanoUI.WidgetText+  ( colorPickerCurrentLabel+  , colorPickerNewLabel+  , isCloseButtonStyle+  , isMenuItemStyle+  , isTableHeaderStyle+  , numericTextClip+  , selectChevronReserve+  , tableStripeColor+  , textInputNumericMode+  , textInputFieldText+  , textInputSearchMode+  , textInputSelectableMode+  , textNodeFontVariant+  , treeDecodeStyle+  )++collectTextSpans :: Context -> IO [(Rect, T.Text, Color, Color, Rect)]+collectTextSpans ctx = do+  count <- arenaCount (ctxNodeArena ctx)+  let arena = ctxSpanBase ctx+  resetSpanArena arena+  when (count > 0) $+    collectClippedSpans ctx 0 (Rect 0 0 1e9 1e9) arena+  panels <- floatingPanelRects ctx+  spanArenaToListOccluded panels arena++collectOverlayTextSpans :: Context -> Input -> IO [(Rect, T.Text, Color, Color, Rect)]+collectOverlayTextSpans ctx inp = do+  let arena = ctxSpanOverlay ctx+      push (r, t, fg, bg, c) = pushSpan arena r t fg bg c+  resetSpanArena arena+  collectFloatingSpansInto ctx NodeWindow arena+  collectFloatingSpansInto ctx NodeModal arena+  collectFloatingSpansInto ctx NodePopup arena+  drops <- collectSelectDropdownSpans ctx inp+  menu <- collectTextEditMenuSpans ctx inp+  mapM_ push drops+  mapM_ push menu+  spanArenaToList arena++collectRasterSpans :: Context -> Input -> IO ([(Rect, T.Text, Color, Color, Rect)], [(Rect, T.Text, Color, Color, Rect)])+collectRasterSpans ctx inp = (,) <$> collectTextSpans ctx <*> collectOverlayTextSpans ctx inp++widgetNodeCount :: Context -> IO Int+widgetNodeCount ctx = arenaCount (ctxNodeArena ctx)++{-# INLINE collectClippedSpans #-}+collectClippedSpans :: Context -> NodeIdx -> Rect -> SpanArena -> IO ()+collectClippedSpans ctx idx clip arena = do+  nt <- getNodeType (ctxNodeArena ctx) idx+  unless (isFloatingNode nt) $+    collectClippedSpans' ctx idx nt clip arena++collectClippedSpans' :: Context -> NodeIdx -> NodeType -> Rect -> SpanArena -> IO ()+collectClippedSpans' ctx idx nt clip arena = do+  (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+  mClipChildren <-+    if isScrollNode nt+      then+        getClipRect (ctxNodeArena ctx) idx >>= \case+          Just live -> pure (rectIntersect clip live)+          Nothing -> (\sn -> rectIntersect clip (scrollNodeViewport sn x y w h)) <$> readScrollNode (ctxNodeArena ctx) idx+      else pure (if nt == NodePanel then rectIntersect clip (Rect x y w h) else Just clip)+  case mClipChildren of+    Nothing -> pure ()+    Just clipHere -> do+      let fm = ctxFontMetrics ctx+      spans <- collectNodeTextSpans ctx idx+      here <-+        case nt of+          NodeSelect -> pure (tagSelectClippedSpans clipHere x y w h fm spans)+          NodeTextInput -> do+            si <- getStyleIdx (ctxNodeArena ctx) idx+            pure $+              if textInputNumericMode si+                then maybe [] (`tagClippedSpans` spans) (rectIntersect clipHere (numericTextClip fm x y w h))+                else+                  if textInputSelectableMode si+                    then tagClippedSpans clipHere spans+                    else tagTextInputClippedSpans clipHere x y w h fm spans+          _ -> pure (tagClippedSpans clipHere spans)+      mapM_ (\(r, t, fg, bg, c) -> pushSpan arena r t fg bg c) here+      walkChildSpans ctx idx clipHere arena++walkChildSpans :: Context -> NodeIdx -> Rect -> SpanArena -> IO ()+walkChildSpans ctx idx clip arena = getFirstChild (ctxNodeArena ctx) idx >>= go+  where+    go ci+      | ci < 0 = pure ()+      | otherwise = do+          ns <- getNextSibling (ctxNodeArena ctx) ci+          -- Later siblings paint under earlier ones; walk reverse then collect.+          go ns+          collectClippedSpans ctx ci clip arena++-- | Text spans of one node. A text node's spans are cached per node until+-- its inputs change. Placement uses glyph ink ('alignedTextPen'), not+-- TTF_GetStringSize; wrapping still measures with the host so line breaks+-- stay on the TTF width.+collectNodeTextSpans :: Context -> NodeIdx -> IO [(Rect, T.Text, Color, Color)]+collectNodeTextSpans ctx idx = do+  let arena = ctxNodeArena ctx+  nt <- getNodeType arena idx+  (x, y, w, h) <- getRect arena idx+  if nt /= NodeText+    then if isWidgetNode nt then widgetTextSpans ctx nt idx x y w h else pure []+    else do+      theme <- nodeTheme ctx idx+      raw <- getText arena idx+      si <- getStyleIdx arena idx+      mCustomCol <- getNodeFontColor arena idx+      fontSize <- getNodeFontSize arena idx+      ax <- getAlignX arena idx+      (_, _, maxW, _) <- getMinMax arena idx+      (wTag, _) <- getWidthSizing arena idx+      isRowChild <- parentIsRow arena idx+      effMaxW <- if maxW < 1e8 then pure maxW else findAncestorMaxW arena idx+      let rect = Rect x y w h+          mStripe = tableStripeColor theme si+          variantFg = case textNodeFontVariant si of+            FontHeading -> themeAccent theme+            FontMuted -> themeMuted theme+            FontDanger -> themeRed theme+            _ -> styleFg (themePanel theme)+          fg = fromMaybe variantFg mCustomCol+          bg = fromMaybe (styleBg (themePanel theme)) mStripe+      cache <- readIORef (ctxSpanCache ctx)+      case IM.lookup idx cache of+        Just e+          | sceText e == raw+              && sceFg e == fg+              && sceBg e == bg+              && sceStyle e == si+              && sceFontSize e == fontSize+              && sceAlign e == fromEnum ax+              && sceWidthTag e == fromEnum wTag+              && sceRect e == rect+              && sceEffMaxW e == effMaxW+              && sceRowChild e == isRowChild ->+              pure (sceSpans e)+        _ -> do+          placed <-+            if T.null raw+              then pure []+              else do+                (fm, _, measure) <- resolveFontFor ctx NodeText fontSize si+                let ix = if isJust mStripe then tableCellInset else 0+                    measureW = fmap fst . measure+                    lineH = fmLineHeight fm+                    contentW = max 0 (w - 2 * ix)+                    wrapCap+                      | effMaxW < 1e8 = max 0 effMaxW+                      | wTag == SizingGrow && w > 0 = w+                      | otherwise = effMaxW+                tw <- measureW raw+                if T.any (== '\n') raw || (not isRowChild && wrapCap < 1e8 && wrapCap + 0.5 < tw)+                  then do+                    textLines <- wrapTextLinesIO measureW raw (max 0 (wrapCap - 2 * ix))+                    forM (zip [(0 :: Int) ..] textLines) $ \(i, line) -> do+                      prepared <- prepareFontMetrics fm line+                      let (tx, used) = alignedTextPen ax x w ix prepared line+                          ty = centeredTextY fm (y + onGrid (fmSnapScale fm) (fromIntegral i * lineH)) lineH lineH+                      pure (Rect tx ty used lineH, line)+                  else do+                    shown <-+                      if tw > contentW && contentW > 0 && (wTag == SizingGrow || maxW < 1e8)+                        then truncateTextIO measureW contentW raw+                        else pure raw+                    prepared <- prepareFontMetrics fm shown+                    let (tx, used) = alignedTextPen ax x w ix prepared shown+                    pure [(Rect tx (centeredTextY fm y h lineH) used lineH, shown)]+          let spans = [(r, line, fg, bg) | (r, line) <- placed]+          writeIORef (ctxSpanCache ctx) $+            IM.insert+              idx+              SpanCacheEntry+                { sceText = raw+                , sceFg = fg+                , sceBg = bg+                , sceStyle = si+                , sceFontSize = fontSize+                , sceAlign = fromEnum ax+                , sceWidthTag = fromEnum wTag+                , sceRect = rect+                , sceEffMaxW = effMaxW+                , sceRowChild = isRowChild+                , sceSpans = spans+                }+              cache+          pure spans++widgetHitRect :: Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO Rect+widgetHitRect ctx nt idx x y w h = do+  let fm = ctxFontMetrics ctx+  case nt of+    NodeTextInput -> do+      si <- getStyleIdx (ctxNodeArena ctx) idx+      if textInputSearchMode si || textInputSelectableMode si || textInputNumericMode si+        then pure (Rect x y w h)+        else pure (textInputFieldRect fm x y w h)+    NodeTextArea -> pure (Rect x y w h)+    NodeButton -> do+      si <- getStyleIdx (ctxNodeArena ctx) idx+      -- Close buttons get a padded target that stays inside the title bar, so+      -- the inner east resize still works below the control.+      if isCloseButtonStyle si+        then pure (Rect (x - 8) (y - 4) (w + 10) (h + 4))+        else pure (Rect x y w h)+    _ -> pure (Rect x y w h)++widgetTextSpans ::+  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO [(Rect, T.Text, Color, Color)]+widgetTextSpans ctx nt idx x y w h = do+  style <- widgetVisualStyle ctx nt idx+  mFontColor <- getNodeFontColor (ctxNodeArena ctx) idx+  placements <- widgetTextPlacements ctx nt idx x y w h+  let fg = fromMaybe (styleFg style) mFontColor+      bg = styleBg style+  case nt of+    NodeTextInput -> do+      value <- textInputValue ctx idx+      focus <- textInputFocused ctx idx+      let fieldFg = if T.null value && not focus then lerpColor fg bg 0.40 else fg+      pure [(Rect px py tw th, txt, fieldFg, bg) | (txt, px, py, tw, th) <- placements]+    _ ->+      pure [(Rect px py tw th, txt, fg, bg) | (txt, px, py, tw, th) <- placements, not (T.null txt)]++-- | Cacheable widget labels depend on text, style, font size, alignment and+-- dimensions, but not the absolute node origin. Text+-- fields / areas / colour pickers / sliders are data-dependent and stay out.+cacheableWidgetLabel :: NodeType -> Bool+cacheableWidgetLabel = \case+  NodeButton -> True+  NodeSelect -> True+  NodeTree -> True+  NodeCheckbox -> True+  NodeRadio -> True+  _ -> False++widgetTextPlacements ::+  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO [(T.Text, Float, Float, Float, Float)]+widgetTextPlacements ctx nt idx x y w h+  | cacheableWidgetLabel nt = do+      placement <- cachedWidgetLabel ctx nt idx w h+      pure [(txt, x + px, y + py, tw, th) | Just (WidgetTextPlacement txt px py tw th) <- [placement]]+  | otherwise = computeWidgetTextPlacements ctx nt idx x y w h++-- | Runtime consumer API. The Bool marks the last placement (for table sort+-- arrows); cached labels are translated directly into the consumer.+{-# INLINE forWidgetTextPlacements_ #-}+forWidgetTextPlacements_ ::+  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float ->+  (Bool -> T.Text -> Float -> Float -> Float -> Float -> IO ()) -> IO ()+forWidgetTextPlacements_ ctx nt idx x y w h emit+  | cacheableWidgetLabel nt = do+      placement <- cachedWidgetLabel ctx nt idx w h+      case placement of+        Nothing -> pure ()+        Just (WidgetTextPlacement txt px py tw th) -> emit True txt (x + px) (y + py) tw th+  | otherwise = do+      placements <- computeWidgetTextPlacements ctx nt idx x y w h+      let go [] = pure ()+          go ((txt, px, py, tw, th) : rest) =+            emit (null rest) txt px py tw th >> go rest+      go placements++cachedWidgetLabel :: Context -> NodeType -> NodeIdx -> Float -> Float -> IO (Maybe WidgetTextPlacement)+cachedWidgetLabel ctx nt idx w h = do+  fontSizeVal <- getNodeFontSize (ctxNodeArena ctx) idx+  si <- getStyleIdx (ctxNodeArena ctx) idx+  txt <- displayText ctx nt idx+  ax <-+    if nt == NodeButton && isTableHeaderStyle si+      then getAlignX (ctxNodeArena ctx) idx+      else pure AlignStart+  let ntTag = fromEnum nt+  cache <- readIORef (ctxWidgetTextCache ctx)+  case IM.lookup idx cache of+    Just e+      | wtcNodeType e == ntTag+          && wtcStyle e == si+          && wtcFontSize e == fontSizeVal+          && wtcText e == txt+          && wtcWidth e == w+          && wtcHeight e == h+          && wtcAlign e == fromEnum ax -> pure (wtcPlacement e)+    _ -> do+      placement <- computeWidgetLabel ctx nt txt si fontSizeVal ax w h+      writeIORef+        (ctxWidgetTextCache ctx)+        (IM.insert idx (WidgetTextCacheEntry ntTag si fontSizeVal txt w h (fromEnum ax) placement) cache)+      pure placement++-- All coordinates here are local. centeredTextY snaps the baseline offset,+-- not the origin; final device-pixel snapping stays in the draw backend.+computeWidgetLabel :: Context -> NodeType -> T.Text -> Int -> Float -> AlignX -> Float -> Float -> IO (Maybe WidgetTextPlacement)+computeWidgetLabel ctx nt txt si fontSizeVal ax w h+  | nt == NodeButton && isCloseButtonStyle si = pure Nothing+  | otherwise = do+      (source, _, measure) <- resolveFontFor ctx nt fontSizeVal si+      fm <- prepareFontMetrics source txt+      (tw, th) <- measure txt+      let (ix, _) = widgetContentInset fm+          (tx, used) = case nt of+            NodeButton+              | isTableHeaderStyle si -> alignedTextPen ax 0 w tableCellInset fm txt+              | isMenuItemStyle si ->+                  let inset = menuItemPadX + ix+                   in (inset, min tw (max 0 (w - inset - ix)))+              | otherwise -> alignedTextPen AlignCenter 0 w 0 fm txt+            NodeSelect -> (ix, min tw (w - ix - selectChevronReserve))+            NodeTree ->+              let (_, depth, _, _) = treeDecodeStyle si+               in (treeRowLeading fm depth, tw)+            _ -> (checkboxLeading fm, tw)+      let !placement = WidgetTextPlacement txt tx (centeredTextY fm 0 h th) used th+      pure (Just placement)++-- | Pure geometry of selectable text: the pen origin, centered baseline box and+-- line height. Selectable text never scrolls, so the pen is just the node x.+-- Paint uses this and skips the width measure; span placement adds it.+selectableTextGeometry :: FontMetrics -> Float -> Float -> Float -> (Float, Float, Float)+selectableTextGeometry fm x y h =+  let lineH = fmLineHeight fm+   in (x, centeredTextY fm y h lineH, lineH)++computeWidgetTextPlacements ::+  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO [(T.Text, Float, Float, Float, Float)]+computeWidgetTextPlacements ctx nt idx x y w h = do+  fontSizeVal <- getNodeFontSize (ctxNodeArena ctx) idx+  si <- getStyleIdx (ctxNodeArena ctx) idx+  (fm, _, measureTxt) <- resolveFontFor ctx nt fontSizeVal si+  let (ix, iy) = widgetContentInset fm+      lineH = fmLineHeight fm+  case nt of+    NodeColorPicker+      | colorPickerPartOf si /= PickerPreview -> pure []+      | otherwise -> do+          band@(Rect bx _ _ _) <- colorPickerPartRect (ctxNodeArena ctx) idx (Rect x y w h)+          let (currentY, _, newY, _) = colorPickerPreviewGeom fm band+              labelH = fmLineHeight fm+          (cw, ch) <- measureTxt colorPickerCurrentLabel+          (nw, nh) <- measureTxt colorPickerNewLabel+          pure+            [ (colorPickerCurrentLabel, bx, centeredTextY fm currentY labelH ch, cw, ch)+            , (colorPickerNewLabel, bx, centeredTextY fm newY labelH nh, nw, nh)+            ]+    NodeSlider -> pure []+    NodeTextInput+      | textInputSelectableMode si -> do+          value <- textInputValue ctx idx+          let (penX, ty, selLineH) = selectableTextGeometry fm x y h+          (fw, _) <- measureTxt value+          pure [(value, penX, ty, fw, selLineH)]+      | otherwise -> do+          let numeric = textInputNumericMode si+          ph <- if numeric then pure "" else getText (ctxNodeArena ctx) idx+          value <- textInputValue ctx idx+          focus <- textInputFocused ctx idx+          let fieldTxt = textInputFieldText ph value focus+              Rect _ fieldY _ fieldH = if numeric then Rect x y w h else textInputFieldRect fm x y w h+          (fw, _) <- measureTxt fieldTxt+          scrollX <- syncTextInputScroll ctx idx x y w h+          pure [(fieldTxt, x + ix - scrollX, centeredTextY fm fieldY fieldH lineH, fw, lineH)]+    NodeTextArea -> do+      lbl <- getText (ctxNodeArena ctx) idx+      value <- textInputValue ctx idx+      (lw, lh) <- measureTxt lbl+      (fw, _) <- measureTxt (if T.null value then " " else value)+      pure+        [ (lbl, x, centeredTextY fm y lineH lh, lw, lh)+        , (value, x + ix, y + iy, fw, h)+        ]+    NodeDrawing -> pure []+    _ -> do+      txt <- displayText ctx nt idx+      ax <- getAlignX (ctxNodeArena ctx) idx+      (_, th) <- measureTxt txt+      prepared <- prepareFontMetrics fm txt+      let (tx, used) = alignedTextPen ax x w ix prepared txt+      pure [(txt, tx, centeredTextY fm y h th, used, th)]++-- | Spans inside every floating panel of one kind, clipped to its content box.+collectFloatingSpansInto :: Context -> NodeType -> SpanArena -> IO ()+collectFloatingSpansInto ctx wanted arena =+  forNodes_ (ctxNodeArena ctx) $ \idx -> do+    nt <- getNodeType (ctxNodeArena ctx) idx+    when (nt == wanted) $ do+      (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+      clip <-+        if isScrollNode nt+          then (\sn -> scrollNodeViewport sn x y w h) <$> readScrollNode (ctxNodeArena ctx) idx+          else padContentClip x y w h <$> getPadding (ctxNodeArena ctx) idx+      walkChildSpans ctx idx clip arena
+ lib/NanoUI/Frame/TextArea.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DataKinds #-}++-- | Multi-line text areas: content painting (lines, selection, caret and+-- scrollbars) and mouse selection.+module NanoUI.Frame.TextArea+  ( TextAreaHit (..)+  , textAreaHitForWidget+  , drawTextAreaContentWith+  , finalizeTextAreaMouse+  , collapseTextAreaSelection+  ) where++import Control.Monad (forM_, unless, when)+import Data.IORef (writeIORef)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (catMaybes, isJust)+import qualified Data.Text as T+import NanoUI.Context+  ( Context (..)+  , TextInputDrag (..)+  , WidgetStore (..)+  , getStore+  , intKey+  , markDirty+  , setStore+  , setTextInputDrag+  , slotKey+  , nodeTheme+  , getsInteraction+  , InteractionState (..)+  )+import NanoUI.Draw (DrawArena, getDrawSnapScale, pushText, withClip)+import NanoUI.Font (FontMetrics, caretXIO, prepareFontMetrics, selectionSpans, textIndexAtX, widgetContentInset)+import NanoUI.Frame.Chrome (paintScrollBarLayout, textInputFocused)+import NanoUI.Frame.Hit (findNodeByWidgetId)+import NanoUI.Frame.TextArea.Content+  ( ensureTextAreaBuffer+  , isMouseOnTextAreaScrollBarAt+  , resolveTextAreaFont+  , textAreaContentMetrics+  )+import NanoUI.Frame.TextArea.Geometry+import NanoUI.Frame.TextInput (drawTextCaret, drawTextSelectionLine, normalizeTextFieldClicks)+import NanoUI.Id (WidgetId)+import NanoUI.Input+  ( Input (..)+  , inputMouseClicks+  , inputMouseDown+  , inputMousePos+  , inputMousePressed+  , inputMouseReleased+  )+import NanoUI.Layout.Arena (NodeIdx, NodeType (NodeTextArea), getNodeType, getRect, getWidgetId)+import NanoUI.Store (Slot (..))+import NanoUI.Style (Style (..), Theme, scrollBarThumbColor, scrollBarTrackColor, themePanel, themeSelection)+import NanoUI.Types (Rect (..), V2 (..), onGrid, rectContains)+import NanoUI.Widgets.TextArea (TextAreaState (..), loadTextAreaState, saveTextAreaState)+import qualified NanoUI.Widgets.TextArea as TA+import qualified NanoUI.Widgets.TextBuffer as TB+import NanoUI.Widgets.TextCommon (selectionCaretGeom, textWordBounds)++data TextAreaHit = TextAreaHit+  { tahNodeIdx :: !NodeIdx+  , tahFieldRect :: !Rect+  , tahContentX :: !Float+  , tahLineH :: !Float+  , tahWidgetX :: !Float+  , tahWidgetY :: !Float+  , tahWidgetW :: !Float+  , tahWidgetH :: !Float+  }++-- | Editor state of the text area at @idx@, its viewport set from the field+-- clip.+loadTextAreaStateAt :: Context -> NodeIdx -> FontMetrics -> Float -> Float -> Float -> Float -> IO TA.TextAreaState+loadTextAreaStateAt ctx idx fm x y w h = do+  wid <- getWidgetId (ctxNodeArena ctx) idx+  let key = intKey wid+  store <- getStore ctx+  let initial = IM.findWithDefault "" key (storeText store)+  buf <- ensureTextAreaBuffer ctx key initial+  let Rect _ _ vpW vpH = textAreaFieldClip fm (Rect x y w h)+      state0 = TA.loadTextAreaStateWithBuffer store key buf+  pure (TA.setTextAreaViewport (realToFrac vpW, realToFrac vpH) (realToFrac (textAreaLineHeight fm)) state0)++loadHitState :: Context -> TextAreaHit -> IO TA.TextAreaState+loadHitState ctx hit = do+  fm <- resolveTextAreaFont ctx (tahNodeIdx hit)+  loadTextAreaStateAt ctx (tahNodeIdx hit) fm (tahWidgetX hit) (tahWidgetY hit) (tahWidgetW hit) (tahWidgetH hit)++-- | Record the text viewport and clamp the stored scroll to the content.+-- This paint already reflects both, so the write marks nothing dirty: a+-- window resize would otherwise request a second frame that has nothing to+-- repaint.+syncTextAreaViewport :: Context -> NodeIdx -> FontMetrics -> Float -> Float -> Float -> Float -> IO ()+syncTextAreaViewport ctx idx fm x y w h = do+  wid <- getWidgetId (ctxNodeArena ctx) idx+  (contentW, contentH) <- textAreaContentMetrics ctx idx+  -- Read after the metrics query: a cold query caches into the store.+  store <- getStore ctx+  let key = intKey wid+      Rect _ _ clipW clipH = textAreaFieldClip fm (Rect x y w h)+      bars = textAreaBars fm (Rect x y w h) contentW contentH+      (sx, sy) = IM.findWithDefault (0, 0) (slotKey SlotTextAreaScroll key) (storePoint store)+      sx' = max 0 (min (max 0 (contentW - tabViewW bars)) sx)+      sy' = max 0 (min (max 0 (contentH - tabViewH bars)) sy)+      viewportKey = slotKey SlotTextAreaViewport key+      pts0 = IM.insert viewportKey (clipW, clipH) (storePoint store)+      pts1+        | sx' /= sx || sy' /= sy = IM.insert (slotKey SlotTextAreaScroll key) (sx', sy') pts0+        | otherwise = pts0+  unless (sx' == sx && sy' == sy && IM.lookup viewportKey (storePoint store) == Just (clipW, clipH)) $+    writeIORef (ctxStore ctx) $! store {storePoint = pts1}++-- | Snap a text-area scroll offset to the device pixel grid, the same grid+-- 'pushText' snaps to, so line pens and hit-testing stay in lockstep (and in+-- agreement with each other) while the text area scrolls. The raw 'Double'+-- offset keeps sub-pixel wheel deltas; only the applied value is quantized.+textAreaSnap :: DrawArena -> IO (Float -> Float)+textAreaSnap da = onGrid <$> getDrawSnapScale da++-- | The selection highlight on the rows between @firstRow@ and @lastRow@,+-- the ones in view.+drawTextAreaSelectionLines :: DrawArena -> Int -> Int -> TA.TextAreaState -> Rect -> FontMetrics -> Theme -> IO ()+drawTextAreaSelectionLines da firstRow lastRow state (Rect fieldX fieldY _ _) fm theme = do+  snap <- textAreaSnap da+  let anchor = TA.selectionAnchor state+      cursor = TB.getCursor (TA.buffer state)+  when (anchor /= cursor) $ do+    let (lo, hi) = TB.selectionRange anchor cursor+        lineH = textAreaLineHeight fm+        (ix, iy) = widgetContentInset fm+        (scrollX, scrollY) = TA.scrollOffset state+        scrollXf = snap (realToFrac scrollX)+        scrollYf = snap (realToFrac scrollY)+        contentTop = fieldY + iy+        selBg = themeSelection theme+        loRow = TB.cursorRow lo+        hiRow = TB.cursorRow hi+    forM_ [max loRow firstRow .. min hiRow lastRow] $ \row -> do+      let line = TB.lineAt row (TA.buffer state)+          clampCol c = max 0 (min (T.length line) c)+          startCol = clampCol (if row == loRow then TB.cursorCol lo else 0)+          endCol = clampCol (if row == hiRow then TB.cursorCol hi else T.length line)+      when (startCol < endCol) $ do+        prepared <- prepareFontMetrics fm line+        let ly = contentTop + fromIntegral row * lineH - scrollYf+        forM_ (selectionSpans prepared line startCol endCol) $ \(wLo, wHi) ->+          drawTextSelectionLine da (fieldX + ix + wLo - scrollXf) ly (wHi - wLo) (max 4 lineH) selBg++-- | Text-area content with the node font already resolved, so a paint pass+-- that also needs it (for the field frame) resolves it once.+drawTextAreaContentWith :: DrawArena -> Context -> FontMetrics -> NodeIdx -> Float -> Float -> Float -> Float -> Style -> IO ()+drawTextAreaContentWith da ctx fm idx x y w h style = do+  snap <- textAreaSnap da+  syncTextAreaViewport ctx idx fm x y w h+  focus <- textInputFocused ctx idx+  theme <- nodeTheme ctx idx+  let field = Rect x y w h+      lineH = textAreaLineHeight fm+      Rect clipX contentTop clipW clipH = textAreaFieldClip fm field+      fg = styleFg style+  state <- loadTextAreaStateAt ctx idx fm x y w h+  (contentW, contentH) <- textAreaContentMetrics ctx idx+  let buf = TA.buffer state+      (scrollX, scrollY) = TA.scrollOffset state+      scrollXf = snap (realToFrac scrollX)+      scrollYf = snap (realToFrac scrollY)+      contentX = clipX - scrollXf+      layouts = textAreaScrollBarLayouts fm field contentW contentH scrollXf scrollYf+      textClip =+        Rect+          clipX+          contentTop+          (if isJust (tasbVertical layouts) then max 0 (clipW - textAreaBarLane) else clipW)+          (if isJust (tasbHorizontal layouts) then max 0 (clipH - textAreaBarLane) else clipH)+      -- Only the rows in view are read, so painting costs the same however+      -- long the document is.+      rowAt py = floor ((py - contentTop + scrollYf) / max 1 lineH) :: Int+      firstRow = max 0 (rowAt y)+      lastRow = min (TB.getLineCount buf - 1) (rowAt (y + h))+  withClip da textClip $ do+    when focus $+      drawTextAreaSelectionLines da firstRow lastRow state field fm theme+    forM_ [firstRow .. lastRow] $ \row -> do+      let line = TB.lineAt row buf+          ly = contentTop + fromIntegral row * lineH - scrollYf+      unless (T.null line) $+        pushText da fm contentX ly line fg+    when focus $ do+      let TB.Cursor row col = TB.getCursor buf+          currentLine = TB.lineAt row buf+      pw <- caretXIO fm currentLine col+      let (caretX, caretY, caretH) = selectionCaretGeom contentX (contentTop + fromIntegral row * lineH - scrollYf) pw lineH+      drawTextCaret da caretX caretY caretH fg+  let base = themePanel theme+  mapM_+    (paintScrollBarLayout da (scrollBarTrackColor base theme) (scrollBarThumbColor base theme))+    (catMaybes [tasbVertical layouts, tasbHorizontal layouts])++textAreaHitForWidget :: Context -> WidgetId -> IO (Maybe TextAreaHit)+textAreaHitForWidget ctx wid = do+  mIdx <- findNodeByWidgetId ctx wid+  case mIdx of+    Nothing -> pure Nothing+    Just idx -> do+      nt <- getNodeType (ctxNodeArena ctx) idx+      if nt /= NodeTextArea+        then pure Nothing+        else do+          (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+          fm <- resolveTextAreaFont ctx idx+          let field = Rect x y w h+              Rect clipX _ _ _ = textAreaFieldClip fm field+          pure+            ( Just+                TextAreaHit+                  { tahNodeIdx = idx+                  , tahFieldRect = field+                  , tahContentX = clipX+                  , tahLineH = textAreaLineHeight fm+                  , tahWidgetX = x+                  , tahWidgetY = y+                  , tahWidgetW = w+                  , tahWidgetH = h+                  }+            )++textAreaCursorAt :: Context -> TA.TextAreaState -> TextAreaHit -> V2 -> IO (Int, Int)+textAreaCursorAt ctx state hit (V2 mouseX mouseY) = do+  snap <- textAreaSnap (ctxDrawArena ctx)+  fm <- resolveTextAreaFont ctx (tahNodeIdx hit)+  let buf = TA.buffer state+      lineCount = max 1 (TB.getLineCount buf)+      (scrollX, scrollY) = TA.scrollOffset state+      scrollXf = snap (realToFrac scrollX)+      scrollYf = snap (realToFrac scrollY)+      (_, iy) = widgetContentInset fm+      Rect _ fieldY _ _ = tahFieldRect hit+      relY = mouseY - (fieldY + iy) + scrollYf+      row = max 0 (min (lineCount - 1) (floor (relY / max 1 (tahLineH hit))))+      line = TB.lineAt row buf+  prepared <- prepareFontMetrics fm line+  pure (row, textIndexAtX prepared line (max 0 (mouseX - (tahContentX hit - scrollXf))))++updateTextAreaSelection :: Context -> WidgetId -> TextAreaHit -> TB.Cursor -> TB.Cursor -> IO ()+updateTextAreaSelection ctx wid hit anchor cursor = do+  state0 <- loadHitState ctx hit+  store <- getStore ctx+  -- A selection change keeps the stored text, so the document is not rejoined.+  let key = intKey wid+      text = IM.findWithDefault "" key (storeText store)+  setStore ctx (TA.saveTextAreaState key text (TA.setTextAreaSelection anchor cursor state0) store)+  markDirty ctx++applyTextAreaClick :: Context -> WidgetId -> TextAreaHit -> Int -> Int -> Int -> IO ()+applyTextAreaClick ctx wid hit row col clicks+  | clicks >= 3 = do+      state <- loadHitState ctx hit+      updateTextAreaSelection ctx wid hit (TB.Cursor 0 0) (TB.documentEnd (TA.buffer state))+  | clicks == 2 = do+      state <- loadHitState ctx hit+      let (lo, hi) = textWordBounds (TB.lineAt row (TA.buffer state)) col+      updateTextAreaSelection ctx wid hit (TB.Cursor row lo) (TB.Cursor row hi)+  | otherwise =+      updateTextAreaSelection ctx wid hit (TB.Cursor row col) (TB.Cursor row col)++applyTextAreaDrag :: Context -> WidgetId -> TextAreaHit -> Int -> Int -> Int -> Int -> Int -> IO ()+applyTextAreaDrag ctx wid hit anchorRow anchorCol row col clicks+  | clicks >= 3 = applyTextAreaClick ctx wid hit row col clicks+  | clicks == 2 = do+      state <- loadHitState ctx hit+      let buf = TA.buffer state+          (a0, a1) = textWordBounds (TB.lineAt anchorRow buf) anchorCol+          (c0, c1) = textWordBounds (TB.lineAt row buf) col+      updateTextAreaSelection ctx wid hit (TB.Cursor anchorRow (min a0 c0)) (TB.Cursor row (max a1 c1))+  | otherwise =+      updateTextAreaSelection ctx wid hit (TB.Cursor anchorRow anchorCol) (TB.Cursor row col)++-- | Mouse selection in text area @wid@: press (with word and document+-- multi-clicks) and drag. Presses on the scrollbars are left to the scroller.+finalizeTextAreaMouse :: Context -> Input -> WidgetId -> IO ()+finalizeTextAreaMouse ctx inp wid = do+  mHit <- textAreaHitForWidget ctx wid+  case mHit of+    Nothing -> pure ()+    Just hit -> do+      let mouse = inputMousePos inp+      onScroll <- isMouseOnTextAreaScrollBarAt ctx (tahNodeIdx hit) mouse+      let cursorAtMouse = do+            state <- loadHitState ctx hit+            textAreaCursorAt ctx state hit mouse+      if inputMousePressed inp && rectContains (tahFieldRect hit) mouse && not onScroll+        then do+          (row, col) <- cursorAtMouse+          clicks <- normalizeTextFieldClicks ctx wid 0 row col True (max 1 (inputMouseClicks inp))+          applyTextAreaClick ctx wid hit row col clicks+          setTextInputDrag ctx (Just (TextInputDrag wid 0 row col True clicks))+        else do+          mDrag <- getsInteraction ctx isTextInputDrag+          case mDrag of+            Just drag+              | textInputDragWidget drag == wid+                  , textInputDragMultiline drag+                  , inputMouseDown inp || inputMouseReleased inp -> do+                  (row, col) <- cursorAtMouse+                  applyTextAreaDrag+                    ctx+                    wid+                    hit+                    (textInputDragAnchorRow drag)+                    (textInputDragAnchorCol drag)+                    row+                    col+                    (textInputDragClicks drag)+            _ -> pure ()++collapseTextAreaSelection :: Context -> WidgetId -> IO ()+collapseTextAreaSelection ctx wid = do+  store <- getStore ctx+  let key = intKey wid+      text = IM.findWithDefault "" key (storeText store)+      row = IM.findWithDefault 0 (slotKey SlotTextAreaRow key) (storeInt store)+      col = IM.findWithDefault 0 (slotKey SlotTextAreaCol key) (storeInt store)+      state = loadTextAreaState store key text+  setStore ctx (saveTextAreaState key text state {selectionAnchor = TB.Cursor row col} store)
+ lib/NanoUI/Frame/TextArea/Content.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE BangPatterns #-}++-- | Store-backed text-area content shared by painting, scrolling and hit+-- testing: the node font, the cached document buffer and the cached content+-- extent. Free of the editor widget modules so scroll code stays light.+module NanoUI.Frame.TextArea.Content+  ( resolveTextAreaFont+  , ensureTextAreaBuffer+  , textAreaContentMetrics+  , textAreaContentGeom+  , isMouseOnTextAreaScrollBarAt+  ) where++import Data.Dynamic (fromDynamic, toDyn)+import Data.IORef (readIORef)+import qualified Data.IntMap.Strict as IM+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Text (Text)+import NanoUI.Context (Context (..), WidgetStore (..), getStore, intKey, setStore, slotKey)+import NanoUI.Font (FontMetrics (..), lineWidthIO)+import NanoUI.Frame.TextArea.Geometry (isMouseOnTextAreaScrollBar)+import NanoUI.Layout.Arena (NodeIdx, getNodeFontSize, getRect, getWidgetId)+import NanoUI.Store+  ( Slot (..)+  )+import NanoUI.Style (FontStyle (..), FontVariant (..), FontWeight (..))+import NanoUI.Types (Rect (..), V2, onGrid)+import qualified NanoUI.Widgets.TextBuffer as TB++-- | Font the text-area content is laid out and painted in. Honors the node's+-- @layoutFontSize@ (set via 'fontSize' on the editor layout) so a single text+-- area can zoom without changing the rest of the UI. A size of 0 means the+-- base UI font.+resolveTextAreaFont :: Context -> NodeIdx -> IO FontMetrics+resolveTextAreaFont ctx idx = do+  size <- getNodeFontSize (ctxNodeArena ctx) idx+  if size <= 0+    then pure (ctxFontMetrics ctx)+    else fst <$> ctxResolveFont ctx size WeightNormal FontStyleNormal FontRegular++-- | Return the text area's 'TB.TextBuffer', building it from the flat text only+-- when the cache is cold. Rebuilding splits the whole document into lines, so+-- caching it keeps loads and paint O(1) here. The cache is written together+-- with the flat text by 'saveTextAreaState', so a present entry is always the+-- buffer for the stored text.+ensureTextAreaBuffer :: Context -> Int -> Text -> IO TB.TextBuffer+ensureTextAreaBuffer ctx key text = do+  store <- getStore ctx+  case IM.lookup (slotKey SlotTextAreaBuffer key) (storeDyn store) >>= fromDynamic of+    Just buf -> pure buf+    Nothing -> do+      let buf = TB.fromText text+      setStore ctx store {storeDyn = IM.insert (slotKey SlotTextAreaBuffer key) (toDyn buf) (storeDyn store)}+      pure buf++-- | Content extent of a text area, @(contentWidth, contentHeight)@. Measuring+-- the width scans every character of the document, so the result is cached per+-- widget and only refreshed when the text changes (the editor clears+-- 'SlotTextAreaContentFont') or the node font changes.+textAreaContentMetrics :: Context -> NodeIdx -> IO (Float, Float)+textAreaContentMetrics ctx idx = do+  wid <- getWidgetId (ctxNodeArena ctx) idx+  size <- getNodeFontSize (ctxNodeArena ctx) idx+  store <- getStore ctx+  let key = intKey wid+      cacheKeyF = slotKey SlotTextAreaContentFont key+      cacheKeyW = slotKey SlotTextAreaContentW key+      cacheKeyH = slotKey SlotTextAreaContentH key+      widthsKey = slotKey SlotTextAreaWidths key+      cachedFont = IM.findWithDefault (-1) cacheKeyF (storeFloat store)+      cachedW = IM.findWithDefault (-1) cacheKeyW (storeFloat store)+  if cachedFont == size && cachedW >= 0+    then pure (cachedW, IM.findWithDefault 0 cacheKeyH (storeFloat store))+    else do+      fm <- resolveTextAreaFont ctx idx+      gen <- readIORef (ctxMetricGen ctx)+      buf <- ensureTextAreaBuffer ctx key (IM.findWithDefault "" key (storeText store))+      let lns = TB.bufferLines buf+          lineH = onGrid (fmSnapScale fm) (fmLineHeight fm)+          contentH = fromIntegral (max 1 (Seq.length lns)) * lineH+          (seenHead, seenTail) = TB.changedLines buf+          previous = case IM.lookup widthsKey (storeDyn store) >>= fromDynamic of+            Just lw@(LineWidths font fontGen _ _ _) | font == size && fontGen == gen -> lw+            _ -> LineWidths size gen Seq.empty (-1) 0+          LineWidths _ _ measured widest widestW = previous+          -- Keep the widths of the lines no edit touched since the last+          -- measurement and measure the rest.+          keepHead = min seenHead (Seq.length measured)+          keepTail = min seenTail (Seq.length measured - keepHead)+          changed = Seq.take (Seq.length lns - keepHead - keepTail) (Seq.drop keepHead lns)+      fresh <- traverse (lineWidthIO fm) changed+      let widths = Seq.take keepHead measured <> fresh <> Seq.drop (Seq.length measured - keepTail) measured+          shift = Seq.length lns - Seq.length measured+          freshWidest = Seq.foldlWithIndex (\best i w -> if w > snd best then (keepHead + i, w) else best) (-1, 0) fresh+          -- The widest line so far still counts when it was kept; only when+          -- an edit touched it do the widths need a full pass.+          -- A changed line at least as wide as the old widest also still wins.+          (widest', contentW)+            | widest >= 0 && widest < keepHead = pick (widest, widestW) freshWidest+            | widest >= 0 && widest >= Seq.length measured - keepTail = pick (widest + shift, widestW) freshWidest+            | widest >= 0 && snd freshWidest >= widestW = freshWidest+            | otherwise = Seq.foldlWithIndex (\best i w -> if w > snd best then (i, w) else best) (-1, 0) widths+          pick a b = if snd b > snd a then b else a+      store' <- getStore ctx+      setStore+        ctx+        ( store'+            { storeFloat =+                IM.insert cacheKeyF size $+                  IM.insert cacheKeyH contentH $+                    IM.insert cacheKeyW contentW (storeFloat store')+            , storeDyn =+                IM.insert widthsKey (toDyn (LineWidths size gen widths widest' contentW)) $+                  IM.insert (slotKey SlotTextAreaBuffer key) (toDyn (TB.markLinesSeen buf)) (storeDyn store')+            }+        )+      pure (contentW, contentH)++-- | Measured widths of a text area's lines, the font size and metric+-- generation they were measured at, and the widest line with its width.+data LineWidths = LineWidths !Float !Int !(Seq Float) !Int !Float++-- | Node font, field rect and content extent @(width, height)@ of a text area.+-- Zoom changes the node font, so scroll and hit math resolve it here rather+-- than using the base font, or the scroll range would clamp short.+textAreaContentGeom :: Context -> NodeIdx -> IO (FontMetrics, Rect, Float, Float)+textAreaContentGeom ctx idx = do+  fm <- resolveTextAreaFont ctx idx+  (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+  (contentW, contentH) <- textAreaContentMetrics ctx idx+  pure (fm, Rect x y w h, contentW, contentH)++-- | Whether @mouse@ is over one of the text area's shown scrollbars. Uses the+-- cached content extent: this runs on every hover through the cursor query.+isMouseOnTextAreaScrollBarAt :: Context -> NodeIdx -> V2 -> IO Bool+isMouseOnTextAreaScrollBarAt ctx idx mouse = do+  (fm, field, contentW, contentH) <- textAreaContentGeom ctx idx+  wid <- getWidgetId (ctxNodeArena ctx) idx+  store <- getStore ctx+  let (sx, sy) = IM.findWithDefault (0, 0) (slotKey SlotTextAreaScroll (intKey wid)) (storePoint store)+  pure (isMouseOnTextAreaScrollBar fm field contentW contentH sx sy mouse)
+ lib/NanoUI/Frame/TextArea/Geometry.hs view
@@ -0,0 +1,103 @@+-- | Pure text-area geometry: the field box, content clip, and which scrollbars+-- show where for a given content extent.+module NanoUI.Frame.TextArea.Geometry+  ( textAreaLineHeight+  , textAreaFieldClip+  , textAreaBarLane+  , TextAreaBars (..)+  , textAreaBars+  , TextAreaScrollBarLayouts (..)+  , textAreaScrollBarLayouts+  , textAreaScrollBarLayout+  , textAreaHScrollBarLayout+  , isMouseOnTextAreaScrollBar+  ) where++import NanoUI.Font (FontMetrics (..), ScrollBarSlot (..), scrollBarGeomFor, scrollBarSideGap, widgetContentInset)+import NanoUI.Frame.Scroll.Geometry (ScrollBarLayout (..), scrollBarLayout, scrollChromeLane)+import NanoUI.Layout.Arena (DirTag (..))+import NanoUI.Style (Padding (..))+import NanoUI.Types (Rect (..), V2, onGrid, rectContains)++-- | Text area row height, snapped to the device pixel grid.+textAreaLineHeight :: FontMetrics -> Float+textAreaLineHeight fm = onGrid (fmSnapScale fm) (fmLineHeight fm)++-- | Text clip of a text area field. A caption-less text area's field is its+-- whole node rect.+textAreaFieldClip :: FontMetrics -> Rect -> Rect+textAreaFieldClip fm (Rect fx fy fw fh) =+  let s = fmSnapScale fm+      (ix, iy) = widgetContentInset fm+   in Rect (fx + onGrid s ix) (fy + onGrid s iy) (max 0 (fw - 2 * ix)) (max 0 (fh - 2 * iy))++-- | Width of the vertical and height of the horizontal scrollbar lane.+textAreaBarLane :: Float+textAreaBarLane = fst (scrollBarGeomFor ScrollBarList) + scrollBarSideGap++-- | Which scrollbars a text area shows for its content extent, the text+-- viewport they leave, and the paddings that place each bar's lane.+data TextAreaBars = TextAreaBars+  { tabVertical :: !Bool+  , tabHorizontal :: !Bool+  , tabViewW :: !Float+  , tabViewH :: !Float+  , tabPadV :: !Padding+  , tabPadH :: !Padding+  }++textAreaBars :: FontMetrics -> Rect -> Float -> Float -> TextAreaBars+textAreaBars fm (Rect _ _ fw fh) contentW contentH =+  let (ix, iy) = widgetContentInset fm+      innerW = max 0 (fw - 2 * ix)+      innerH = max 0 (fh - 2 * iy)+      laneW = textAreaBarLane+      laneH = textAreaBarLane+      -- Either bar's lane can push the other axis into overflow.+      hasV = contentH > (if contentW > innerW then max 0 (innerH - laneH) else innerH)+      hasH = contentW > (if contentH > innerH then max 0 (innerW - laneW) else innerW)+   in TextAreaBars+        { tabVertical = hasV+        , tabHorizontal = hasH+        , tabViewW = if hasV then max 0 (innerW - laneW) else innerW+        , tabViewH = if hasH then max 0 (innerH - laneH) else innerH+        , tabPadV = Padding 0 0 iy (if hasH then iy + laneH else iy)+        , tabPadH = Padding ix (if hasV then ix + laneW else ix) 0 0+        }++data TextAreaScrollBarLayouts = TextAreaScrollBarLayouts+  { tasbVertical :: !(Maybe ScrollBarLayout)+  , tasbHorizontal :: !(Maybe ScrollBarLayout)+  }+  deriving (Eq, Show)++textAreaScrollBarLayouts :: FontMetrics -> Rect -> Float -> Float -> Float -> Float -> TextAreaScrollBarLayouts+textAreaScrollBarLayouts fm field@(Rect x y w h) contentW contentH scrollX scrollY =+  let bars = textAreaBars fm field contentW contentH+      layout shown dir pad content off+        | shown = scrollBarLayout ScrollBarList dir x y w h pad content off+        | otherwise = Nothing+   in TextAreaScrollBarLayouts+        { tasbVertical = layout (tabVertical bars) DirColumn (tabPadV bars) contentH scrollY+        , tasbHorizontal = layout (tabHorizontal bars) DirRow (tabPadH bars) contentW scrollX+        }++textAreaScrollBarLayout :: FontMetrics -> Rect -> Float -> Float -> Maybe ScrollBarLayout+textAreaScrollBarLayout fm field contentH scrollY =+  tasbVertical (textAreaScrollBarLayouts fm field 0 contentH 0 scrollY)++textAreaHScrollBarLayout :: FontMetrics -> Rect -> Float -> Float -> Maybe ScrollBarLayout+textAreaHScrollBarLayout fm field contentW scrollX =+  tasbHorizontal (textAreaScrollBarLayouts fm field contentW 0 scrollX 0)++-- | Whether @mouse@ is over a shown bar's lane or track.+isMouseOnTextAreaScrollBar :: FontMetrics -> Rect -> Float -> Float -> Float -> Float -> V2 -> Bool+isMouseOnTextAreaScrollBar fm field@(Rect x y w h) contentW contentH scrollX scrollY mouse =+  let bars = textAreaBars fm field contentW contentH+      layouts = textAreaScrollBarLayouts fm field contentW contentH scrollX scrollY+      onBar dir pad =+        maybe False $ \layout ->+          rectContains (scrollChromeLane ScrollBarList dir x y w h pad) mouse+            || rectContains (sbTrack layout) mouse+   in onBar DirColumn (tabPadV bars) (tasbVertical layouts)+        || onBar DirRow (tabPadH bars) (tasbHorizontal layouts)
+ lib/NanoUI/Frame/TextEdit.hs view
@@ -0,0 +1,64 @@+-- | Text-field editing facade: single-line fields ("NanoUI.Frame.TextInput"),+-- text areas ("NanoUI.Frame.TextArea") and their context menu+-- ("NanoUI.Frame.TextEdit.Menu"), plus the dispatchers that pick between the+-- two field kinds.+module NanoUI.Frame.TextEdit+  ( -- * Dispatch between field kinds+    finalizeTextFieldMouse+  , collapseTextFieldSelection+    -- * Context menu+  , applyTextFieldMenuAction+  , textEditMenuRectAt+  , textEditMenuWidth+    -- * Shared field helpers+  , normalizeTextFieldClicks+  , textWordBounds+    -- * Text areas+  , TextAreaHit (..)+  , TextAreaScrollBarLayouts (..)+  , resolveTextAreaFont+  , textAreaContentMetrics+  , textAreaBarLane+  , textAreaLineHeight+  , textAreaHitForWidget+  , textAreaScrollBarLayout+  , textAreaHScrollBarLayout+  , textAreaScrollBarLayouts+  ) where++import Control.Monad (unless, when)+import Data.IORef (readIORef)+import NanoUI.Context (Context (..), setTextInputDrag)+import NanoUI.Frame.Hit (findNodeByWidgetId)+import NanoUI.Frame.TextArea+import NanoUI.Frame.TextArea.Content (resolveTextAreaFont, textAreaContentMetrics)+import NanoUI.Frame.TextArea.Geometry+import NanoUI.Frame.TextEdit.Menu (applyTextFieldMenuAction, textEditMenuRectAt, textEditMenuWidth)+import NanoUI.Frame.TextInput+import NanoUI.Id (WidgetId, hashWidgetId)+import NanoUI.Input (Input, inputMouseReleased)+import NanoUI.Layout.Arena (NodeType (NodeTextArea, NodeTextInput), getNodeType)+import NanoUI.Widgets.TextCommon (textWordBounds)++-- | Mouse selection in the focused field, whichever kind it is. A release+-- ends any drag.+finalizeTextFieldMouse :: Context -> Input -> IO ()+finalizeTextFieldMouse ctx inp = do+  focus <- readIORef (ctxFocusId ctx)+  when (hashWidgetId focus /= 0) $ do+    handled <- finalizeTextInputMouse ctx inp focus+    unless handled $ finalizeTextAreaMouse ctx inp focus+  when (inputMouseReleased inp) $+    setTextInputDrag ctx Nothing++collapseTextFieldSelection :: Context -> WidgetId -> IO ()+collapseTextFieldSelection ctx wid =+  when (hashWidgetId wid /= 0) $ do+    mIdx <- findNodeByWidgetId ctx wid+    case mIdx of+      Nothing -> pure ()+      Just idx ->+        getNodeType (ctxNodeArena ctx) idx >>= \case+          NodeTextInput -> collapseTextInputSelection ctx wid+          NodeTextArea -> collapseTextAreaSelection ctx wid+          _ -> pure ()
+ lib/NanoUI/Frame/TextEdit/Menu.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE DataKinds #-}++-- | Text-field context menu (Cut / Copy / Paste / Select All): opening,+-- picking, painting, spans and cursor.+module NanoUI.Frame.TextEdit.Menu+  ( textEditMenuWidth+  , textEditMenuRectAt+  , openTextEditMenu+  , finalizeTextEditMenuPick+  , closeTextEditMenuOnOutsideClick+  , closeTextEditMenuOnEscape+  , drawTextEditMenuOverlays+  , collectTextEditMenuSpans+  , textEditMenuCursorKind+  , textFieldWidgetAtMouse+  , applyTextFieldMenuAction+  ) where++import Control.Monad (forM, forM_, unless, when)+import Data.IORef (writeIORef)+import qualified Data.IntMap.Strict as IM+import qualified Data.Text as T+import NanoUI.Context+  ( Context (..)+  , TextInputMenu (..)+  , WidgetStore (..)+  , getStore+  , getTextInputMenu+  , intKey+  , isDisabled+  , markDirty+  , markEscapeConsumed+  , setTextInputMenu+  , widgetTheme+  , InteractionState (..)+  , modifyInteraction+  )+import NanoUI.Draw (pushRect, pushText)+import NanoUI.Font+  ( centeredTextY+  , menuItemPadX+  , menuItemRowH+  , menuMinW+  , menuOuterPad+  , menuSepH+  , widgetContentInset+  )+import NanoUI.Frame.Chrome (overlayMenuStyle, paintMenuAccent, paintMenuPanel)+import NanoUI.Frame.Hit (nodeClippedHit, overlayHitAllowed, widgetOverlayAllowed)+import NanoUI.Frame.TextArea.Content (isMouseOnTextAreaScrollBarAt)+import NanoUI.Id (WidgetId)+import NanoUI.Input+  ( Input (..)+  , Key (..)+  , UiCursorKind (..)+  , inputKeys+  , inputKeysElem+  , inputMousePos+  , inputMousePressed+  , inputMouseRightPressed+  , inputWindowSize+  )+import NanoUI.Layout.Arena (NodeType (NodeTextArea, NodeTextInput), findNodeRevM, getNodeType, getRect, getWidgetId)+import NanoUI.Style (Style (..), themeSeparator)+import NanoUI.Types (Color (..), Rect (..), Size (..), V2 (..), lerpColor, rectContains)+import NanoUI.Widgets.TextEditor (EditorMode (..), TextCommand (..), canRedo, canUndo)+import NanoUI.Widgets.TextField (applyTextFieldCommand, textFieldHistory, textFieldMode)++data TextEditMenuRow+  = TextEditMenuSep+  | TextEditMenuItem Int T.Text++-- | The menu's commands, in row order; a row's index is its item number.+textEditMenuCommands :: [TextCommand]+textEditMenuCommands = [Undo, Redo, Cut, Copy, Paste, SelectAll]++textEditMenuRows :: [TextEditMenuRow]+textEditMenuRows =+  [ TextEditMenuItem 0 "Undo"+  , TextEditMenuItem 1 "Redo"+  , TextEditMenuSep+  , TextEditMenuItem 2 "Cut"+  , TextEditMenuItem 3 "Copy"+  , TextEditMenuItem 4 "Paste"+  , TextEditMenuSep+  , TextEditMenuItem 5 "Select All"+  ]++-- Use the same row metrics as generic popup menus.+textEditMenuRowH :: TextEditMenuRow -> Float+textEditMenuRowH = \case+  TextEditMenuSep -> menuSepH+  TextEditMenuItem {} -> menuItemRowH++textEditMenuContentH :: Float+textEditMenuContentH = sum (map textEditMenuRowH textEditMenuRows)++textEditMenuWidth :: Context -> IO Float+textEditMenuWidth ctx = do+  ws <- mapM (fmap fst . ctxMeasureText ctx) [lbl | TextEditMenuItem _ lbl <- textEditMenuRows]+  pure (max menuMinW (maximum ws + 2 * menuItemPadX + 2 * menuOuterPad))++-- | Menu rect at the pointer, kept inside the window.+textEditMenuRectAt :: Float -> Float -> Float -> Size -> Rect+textEditMenuRectAt x y menuW (Size ww wh) =+  let h = 2 * menuOuterPad + textEditMenuContentH+   in Rect (max 0 (min x (ww - menuW))) (max 0 (min y (wh - h))) menuW h++textEditMenuContentRect :: Rect -> Rect+textEditMenuContentRect (Rect x y w _) =+  Rect (x + menuOuterPad) (y + menuOuterPad) (w - 2 * menuOuterPad) textEditMenuContentH++-- | Every row with its band spanning the full menu width.+textEditMenuLayout :: Rect -> [(TextEditMenuRow, Rect)]+textEditMenuLayout menuRect@(Rect mx _ mw _) =+  let Rect _ top _ _ = textEditMenuContentRect menuRect+      go _ [] = []+      go relY (entry : rest) =+        let h = textEditMenuRowH entry+         in (entry, Rect mx (top + relY) mw h) : go (relY + h) rest+   in go 0 textEditMenuRows++textEditMenuPickAction :: Rect -> V2 -> Maybe Int+textEditMenuPickAction menuRect mouse@(V2 _ my) =+  let Rect _ top _ _ = textEditMenuContentRect menuRect+   in if my < top || my >= top + textEditMenuContentH+        then Nothing+        else+          case [entry | (entry, row) <- textEditMenuLayout menuRect, rectContainsY row] of+            TextEditMenuItem action _ : _ -> Just action+            _ -> Nothing+  where+    rectContainsY (Rect _ ry _ rh) = let V2 _ py = mouse in py >= ry && py < ry + rh++textEditMenuItemFg :: Style -> Bool -> Color+textEditMenuItemFg style enabled =+  if enabled+    then styleFg style+    else lerpColor (styleFg style) (styleBg style) 0.55++openTextEditMenu :: Context -> Input -> IO ()+openTextEditMenu ctx inp =+  when (inputMouseRightPressed inp) $ do+    let mouse@(V2 mx my) = inputMousePos inp+    mWid <- textFieldWidgetAtMouse ctx mouse+    case mWid of+      Nothing -> pure ()+      Just wid -> do+        writeIORef (ctxFocusId ctx) wid+        menuW <- textEditMenuWidth ctx+        let menuRect = textEditMenuRectAt mx my menuW (inputWindowSize inp)+        setTextInputMenu ctx (Just (TextInputMenu wid menuRect))+        markDirty ctx++textFieldWidgetAtMouse :: Context -> V2 -> IO (Maybe WidgetId)+textFieldWidgetAtMouse ctx mouse = do+  let na = ctxNodeArena ctx+  mIdx <-+    findNodeRevM na $ \idx -> do+      nt <- getNodeType na idx+      if nt /= NodeTextInput && nt /= NodeTextArea+        then pure False+        else do+          wid <- getWidgetId na idx+          disabled <- isDisabled ctx wid+          if disabled+            then pure False+            else do+              (x, y, w, h) <- getRect na idx+              hit <- nodeClippedHit ctx idx (Rect x y w h) mouse+              if not hit+                then pure False+                else do+                  allowed <- overlayHitAllowed ctx idx mouse+                  if not allowed+                    then pure False+                    else+                      if nt == NodeTextArea+                        then not <$> isMouseOnTextAreaScrollBarAt ctx idx mouse+                        else pure True+  traverse (getWidgetId na) mIdx++finalizeTextEditMenuPick :: Context -> Input -> IO ()+finalizeTextEditMenuPick ctx inp =+  when (inputMousePressed inp) $ do+    mMenu <- getTextInputMenu ctx+    case mMenu of+      Just menu+        | rectContains (textInputMenuRect menu) (inputMousePos inp) ->+            case textEditMenuPickAction (textInputMenuRect menu) (inputMousePos inp) of+              Nothing -> setTextInputMenu ctx Nothing+              Just action -> do+                enabled <- textFieldMenuActionEnabled ctx (textInputMenuWidget menu) action+                if enabled+                  then applyTextFieldMenuAction ctx (textInputMenuWidget menu) action+                  else do+                    setTextInputMenu ctx Nothing+                    markDirty ctx+      _ -> pure ()++closeTextEditMenuOnOutsideClick :: Context -> Input -> IO ()+closeTextEditMenuOnOutsideClick ctx inp =+  when (inputMousePressed inp || inputMouseRightPressed inp) $ do+    mMenu <- getTextInputMenu ctx+    case mMenu of+      Just menu+        | not (rectContains (textInputMenuRect menu) (inputMousePos inp)) ->+            setTextInputMenu ctx Nothing+      _ -> pure ()++closeTextEditMenuOnEscape :: Context -> Input -> IO ()+closeTextEditMenuOnEscape ctx inp =+  when (inputKeysElem KeyEscape (inputKeys inp)) $+    getTextInputMenu ctx >>= \case+      Nothing -> pure ()+      Just _ -> do+        setTextInputMenu ctx Nothing+        markEscapeConsumed ctx+        markDirty ctx++textEditMenuCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)+textEditMenuCursorKind ctx inp = do+  mMenu <- getTextInputMenu ctx+  let mouse = inputMousePos inp+  case mMenu of+    Just menu+      | rectContains (textInputMenuRect menu) mouse+      , Just action <- textEditMenuPickAction (textInputMenuRect menu) mouse -> do+          enabled <- textFieldMenuActionEnabled ctx (textInputMenuWidget menu) action+          pure (Just (if enabled then UiCursorPointer else UiCursorDefault))+    _ -> pure Nothing++drawTextEditMenuOverlays :: Context -> Input -> IO ()+drawTextEditMenuOverlays ctx inp = do+  mMenu <- getTextInputMenu ctx+  forM_ mMenu $ \menu -> do+    let wid = textInputMenuWidget menu+    allow <- widgetOverlayAllowed ctx wid+    when allow $ do+      theme <- widgetTheme ctx wid+      let da = ctxDrawArena ctx+          fm = ctxFontMetrics ctx+          menuRect = textInputMenuRect menu+          style = overlayMenuStyle theme+          Rect contentX _ _ _ = textEditMenuContentRect menuRect+          labelX = contentX + menuItemPadX + fst (widgetContentInset fm)+      paintMenuPanel da theme style menuRect+      forM_ (textEditMenuLayout menuRect) $ \case+        (TextEditMenuSep, Rect rx ry rw rh) ->+          pushRect da (Rect (rx + menuItemPadX) (ry + rh / 2) (rw - 2 * menuItemPadX) 1) (themeSeparator theme)+        (TextEditMenuItem action lbl, row@(Rect _ ry _ rh)) -> do+          enabled <- textFieldMenuActionEnabled ctx wid action+          when (enabled && rectContains row (inputMousePos inp)) $ do+            pushRect da row (styleHoverBg style)+            paintMenuAccent da theme row+          unless (T.null lbl) $ do+            (_, th) <- ctxMeasureText ctx lbl+            pushText da fm labelX (centeredTextY fm ry rh th) lbl (textEditMenuItemFg style enabled)++collectTextEditMenuSpans :: Context -> Input -> IO [(Rect, T.Text, Color, Color, Rect)]+collectTextEditMenuSpans ctx inp = do+  mMenu <- getTextInputMenu ctx+  case mMenu of+    Nothing -> pure []+    Just menu -> do+      let wid = textInputMenuWidget menu+      allow <- widgetOverlayAllowed ctx wid+      if not allow+        then pure []+        else do+          theme <- widgetTheme ctx wid+          let fm = ctxFontMetrics ctx+              menuRect = textInputMenuRect menu+              style = overlayMenuStyle theme+              Rect contentX _ _ _ = textEditMenuContentRect menuRect+              labelX = contentX + menuItemPadX + fst (widgetContentInset fm)+          fmap concat . forM (textEditMenuLayout menuRect) $ \case+            (TextEditMenuSep, _) -> pure []+            (TextEditMenuItem action lbl, row@(Rect _ ry _ rh)) -> do+              enabled <- textFieldMenuActionEnabled ctx wid action+              (tw, th) <- ctxMeasureText ctx lbl+              let bg+                    | enabled && rectContains row (inputMousePos inp) = styleHoverBg style+                    | otherwise = styleBg style+              pure [(Rect labelX (centeredTextY fm ry rh th) tw th, lbl, textEditMenuItemFg style enabled, bg, menuRect)]++applyTextFieldMenuAction :: Context -> WidgetId -> Int -> IO ()+applyTextFieldMenuAction ctx wid item =+  forM_ (take 1 (drop item textEditMenuCommands)) $ \cmd -> do+    modifyInteraction ctx (\s -> s {isTextEditLastAction = Just (wid, cmd)})+    applyTextFieldCommand ctx wid cmd++textFieldMenuActionEnabled :: Context -> WidgetId -> Int -> IO Bool+textFieldMenuActionEnabled ctx wid item = do+  store <- getStore ctx+  mMode <- textFieldMode ctx wid+  history <- textFieldHistory ctx wid+  let hasText = not (T.null (IM.findWithDefault "" (intKey wid) (storeText store)))+  case (mMode, drop item textEditMenuCommands) of+    (Just mode, cmd : _) -> case cmd of+      Undo -> pure (modeEditable mode && canUndo history)+      Redo -> pure (modeEditable mode && canRedo history)+      Cut -> pure (modeEditable mode && modeCopyable mode && hasText)+      Copy -> pure (modeCopyable mode && hasText)+      Paste+        | modeEditable mode -> maybe False (not . T.null) <$> ctxClipboardGet ctx+        | otherwise -> pure False+      _ -> pure hasText+    _ -> pure False
+ lib/NanoUI/Frame/TextInput.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE DataKinds #-}++-- | Single-line text fields: field geometry, horizontal scroll, caret and+-- selection painting, and mouse selection. Also holds the click-count and+-- caret primitives the text area shares.+module NanoUI.Frame.TextInput+  ( textInputFieldRect+  , textInputFieldTextClip+  , nodeTextFieldGeom+  , tagTextInputClippedSpans+  , syncTextInputScroll+  , FieldEdit+  , readFieldEdit+  , drawTextInputSelection+  , drawTextInputCaret+  , drawTextCaret+  , drawTextSelectionLine+  , searchClearHit+  , normalizeTextFieldClicks+  , finalizeTextInputMouse+  , collapseTextInputSelection+  ) where++import Control.Monad (forM_, when)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import NanoUI.Context+  ( Context (..)+  , TextFieldClickCell (..)+  , TextInputDrag (..)+  , WidgetStore (..)+  , getStore+  , intKey+  , markDirty+  , setStore+  , setTextInputDrag+  , Slot (..)+  , slotKey+  , nodeTheme+  , InteractionState (..)+  , getsInteraction+  , modifyInteraction+  )+import NanoUI.Draw (DrawArena, pushRect)+import NanoUI.Font (FontMetrics (..), caretXIO, centeredTextY, lineWidthIO, prepareFontMetrics, selectionSpans, textIndexAtX, widgetContentInset)+import NanoUI.Frame.Chrome (textInputFocused, textInputValue)+import NanoUI.Frame.Hit (findNodeByWidgetId)+import NanoUI.Frame.Node (nodeFontMetrics)+import NanoUI.Frame.Scroll.Geometry (padTextClipRect)+import NanoUI.Id (WidgetId)+import NanoUI.Input+  ( Input (..)+  , inputMouseClicks+  , inputMouseDown+  , inputMousePos+  , inputMousePressed+  , inputMouseReleased+  )+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (NodeTextInput)+  , getNodeType+  , getOptions+  , getRect+  , getStyleIdx+  , getWidgetId+  )+import NanoUI.Style (themeSelection)+import NanoUI.Types (Color (..), Rect (..), V2 (..), rectContains, rectIntersect, rectOverlapArea, rectW)+import NanoUI.WidgetText+  ( comboTextClip+  , numericTextClip+  , searchFieldIconRects+  , searchFieldTextClip+  , textInputNumericMode+  , textInputFieldHeight+  , textInputSearchMode+  , textInputSelectableMode+  )+import NanoUI.Widgets.TextCommon+  ( selectionCaretGeom+  , textSelectionForClick+  , textSelectionForDrag+  )++textInputFieldRect :: FontMetrics -> Float -> Float -> Float -> Float -> Rect+textInputFieldRect fm x y w h =+  let fieldH = if h > 0 then h else textInputFieldHeight fm+   in Rect x y w fieldH++textInputFieldTextClip :: FontMetrics -> Rect -> Rect+textInputFieldTextClip fm (Rect fx fy fw fh) =+  let (ix, iy) = widgetContentInset fm+   in Rect (fx + ix) (fy + iy) (max 0 (fw - 2 * ix)) (max 0 (fh - 2 * iy))++-- | Resolve the box a field paints/hits and the clip its text is confined to.+-- Search fields are caption-less: the whole node rect is the box and text is+-- clipped around the magnifier / clear chrome. Combo boxes (search fields+-- carrying dropdown options) clip to the left of the chevron instead.+nodeTextFieldGeom :: Context -> NodeIdx -> Float -> Float -> Float -> Float -> IO (Rect, Rect)+nodeTextFieldGeom ctx idx x y w h = do+  si <- getStyleIdx (ctxNodeArena ctx) idx+  opts <- getOptions (ctxNodeArena ctx) idx+  let fm = ctxFontMetrics ctx+      box = Rect x y w h+      field = textInputFieldRect fm x y w h+  pure $+    if textInputSelectableMode si+      then (box, box)+      else+        if textInputNumericMode si+          then (box, numericTextClip fm x y w h)+          else+            if textInputSearchMode si+              then (box, if null opts then searchFieldTextClip fm x y w h else comboTextClip fm x y w h)+              else (field, textInputFieldTextClip fm field)++-- | Whether the pointer is over the clear (×) button of a non-empty search+-- field. Search fields reserve that slot even when empty, but the button is+-- only active when there is text to clear.+searchClearHit :: Context -> WidgetId -> V2 -> IO Bool+searchClearHit ctx wid mouse = do+  mIdx <- findNodeByWidgetId ctx wid+  case mIdx of+    Nothing -> pure False+    Just idx -> do+      si <- getStyleIdx (ctxNodeArena ctx) idx+      opts <- getOptions (ctxNodeArena ctx) idx+      if not (textInputSearchMode si) || not (null opts)+        then pure False+        else do+          value <- textInputValue ctx idx+          if T.null value+            then pure False+            else do+              (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+              let (_, clearRect) = searchFieldIconRects (ctxFontMetrics ctx) x y w h+              pure (rectContains clearRect mouse)++-- | Clear a search field. The debounced pulse picks the empty text up as an+-- immediate (empty) commit on the next frame.+clearSearchField :: Context -> WidgetId -> IO ()+clearSearchField ctx wid = do+  store <- getStore ctx+  let key = intKey wid+      storeInt' =+        IM.insert (slotKey SlotAnchor key) 0 $+          IM.insert (slotKey SlotCursor key) 0 (storeInt store)+      store' = store {storeText = IM.insert key "" (storeText store), storeInt = storeInt'}+  setStore ctx store'+  markDirty ctx++tagTextInputClippedSpans ::+  Rect -> Float -> Float -> Float -> Float -> FontMetrics -> [(Rect, T.Text, Color, Color)] -> [(Rect, T.Text, Color, Color, Rect)]+tagTextInputClippedSpans parentClip x y w h fm spans =+  let fieldClip = textInputFieldTextClip fm (textInputFieldRect fm x y w h)+      labelClip = Rect x y w (fmLineHeight fm)+      tagOne (rect, txt, fg, bg) =+        let clipRect = padTextClipRect rect+            isField = rectOverlapArea fieldClip clipRect > rectOverlapArea labelClip clipRect+            area = if isField then fieldClip else labelClip+         in (rect, txt, fg, bg,) <$> (rectIntersect area clipRect >>= rectIntersect parentClip)+   in mapMaybe tagOne spans++drawTextCaret :: DrawArena -> Float -> Float -> Float -> Color -> IO ()+drawTextCaret da caretX caretY caretH fg =+  pushRect da (Rect caretX caretY 1 caretH) fg++drawTextSelectionLine :: DrawArena -> Float -> Float -> Float -> Float -> Color -> IO ()+drawTextSelectionLine da selX selY selW selH selBg =+  when (selW > 0) $+    pushRect da (Rect selX selY (max 1 selW) (max 4 selH)) selBg++computeTextInputScroll :: FontMetrics -> Float -> Text -> Int -> Float -> Bool -> IO Float+computeTextInputScroll fm viewportW value cursor oldScroll isFocused+  | not isFocused = pure 0+  | viewportW <= 0 = pure 0+  | otherwise = do+      caretRelX <- caretXIO fm value cursor+      totalTextW <- lineWidthIO fm value+      let maxScroll = max 0 (totalTextW + 1 - viewportW)+          s0+            | caretRelX < oldScroll = caretRelX+            | caretRelX + 1 > oldScroll + viewportW = caretRelX + 1 - viewportW+            | otherwise = oldScroll+      pure (max 0 (min maxScroll s0))++syncTextInputScroll :: Context -> NodeIdx -> Float -> Float -> Float -> Float -> IO Float+syncTextInputScroll ctx idx x y w h = do+  si <- getStyleIdx (ctxNodeArena ctx) idx+  if textInputSelectableMode si+    then pure 0+    else do+      wid <- getWidgetId (ctxNodeArena ctx) idx+      store <- getStore ctx+      let key = intKey wid+      value <- textInputValue ctx idx+      focus <- textInputFocused ctx idx+      (_, clip) <- nodeTextFieldGeom ctx idx x y w h+      let cursor = IM.findWithDefault (T.length value) (slotKey SlotCursor key) (storeInt store)+          oldScroll = IM.findWithDefault 0 (slotKey SlotTextInputScroll key) (storeFloat store)+      newScroll <- computeTextInputScroll (ctxFontMetrics ctx) (rectW clip) value cursor oldScroll focus+      when (newScroll /= oldScroll) $+        setStore ctx (store {storeFloat = IM.insert (slotKey SlotTextInputScroll key) newScroll (storeFloat store)})+      pure newScroll++-- | What a focused single-line field paints its selection and caret from: the+-- displayed value, cursor and anchor, the node font, the field box's top and+-- height, and the x its text starts at with the scroll applied.+data FieldEdit = FieldEdit !Text !Int !Int !FontMetrics !Float !Float !Float++-- | Editing state of field @idx@ at @x y w h@ scrolled by @scrollX@ (see+-- 'syncTextInputScroll'), or Nothing while it is unfocused.+readFieldEdit :: Context -> NodeIdx -> Float -> Float -> Float -> Float -> Float -> IO (Maybe FieldEdit)+readFieldEdit ctx idx x y w h scrollX = do+  focus <- textInputFocused ctx idx+  if not focus+    then pure Nothing+    else do+      value <- textInputValue ctx idx+      wid <- getWidgetId (ctxNodeArena ctx) idx+      store <- getStore ctx+      (Rect _ boxY _ boxH, Rect clipX _ _ _) <- nodeTextFieldGeom ctx idx x y w h+      fm <- nodeFontMetrics ctx idx+      let key = intKey wid+          !cursor = IM.findWithDefault (T.length value) (slotKey SlotCursor key) (storeInt store)+          !anchor = IM.findWithDefault cursor (slotKey SlotAnchor key) (storeInt store)+      pure $! Just (FieldEdit value cursor anchor fm boxY boxH (clipX - scrollX))++drawTextInputSelection :: DrawArena -> Context -> NodeIdx -> FieldEdit -> IO ()+drawTextInputSelection da ctx idx (FieldEdit value cursor anchor fm boxY boxH textX) = do+  let selLo = min anchor cursor+      selHi = max anchor cursor+      lineH = fmLineHeight fm+  when (selLo < selHi) $ do+    theme <- nodeTheme ctx idx+    prepared <- prepareFontMetrics fm value+    forM_ (selectionSpans prepared value selLo selHi) $ \(wLo, wHi) ->+      drawTextSelectionLine+        da+        (textX + wLo)+        (centeredTextY fm boxY boxH lineH)+        (wHi - wLo)+        lineH+        (themeSelection theme)++drawTextInputCaret :: DrawArena -> FieldEdit -> Color -> IO ()+drawTextInputCaret da (FieldEdit value cursor _ fm boxY boxH textX) fg = do+  let lineH = fmLineHeight fm+  pw <- caretXIO fm value cursor+  let (caretX, caretY, caretH) =+        selectionCaretGeom textX (centeredTextY fm boxY boxH lineH) pw lineH+  drawTextCaret da caretX caretY caretH fg++updateTextInputSelection :: Context -> WidgetId -> Int -> Int -> IO ()+updateTextInputSelection ctx wid anchor cursor = do+  store <- getStore ctx+  let key = intKey wid+      oldAnchor = IM.findWithDefault cursor (slotKey SlotAnchor key) (storeInt store)+      oldCursor = IM.findWithDefault 0 (slotKey SlotCursor key) (storeInt store)+  when (oldAnchor /= anchor || oldCursor /= cursor) $ do+    setStore+      ctx+      ( store+          { storeInt =+              IM.insert (slotKey SlotAnchor key) anchor $+                IM.insert (slotKey SlotCursor key) cursor (storeInt store)+          }+      )+    markDirty ctx++-- | Field box, text origin x (scroll applied), value and font of a single-line+-- field.+textInputGeomForWidget :: Context -> WidgetId -> IO (Maybe (Rect, Float, Text, FontMetrics))+textInputGeomForWidget ctx wid = do+  mIdx <- findNodeByWidgetId ctx wid+  case mIdx of+    Nothing -> pure Nothing+    Just idx -> do+      nt <- getNodeType (ctxNodeArena ctx) idx+      if nt /= NodeTextInput+        then pure Nothing+        else do+          (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+          (field, Rect clipX _ _ _) <- nodeTextFieldGeom ctx idx x y w h+          scrollX <- syncTextInputScroll ctx idx x y w h+          fm <- nodeFontMetrics ctx idx+          value <- textInputValue ctx idx+          pure (Just (field, clipX - scrollX, value, fm))++-- | Mouse selection in single-line field @wid@: click (with word and line+-- multi-clicks), drag, and the search clear button. False when @wid@ is not a+-- single-line field.+finalizeTextInputMouse :: Context -> Input -> WidgetId -> IO Bool+finalizeTextInputMouse ctx inp wid = do+  mGeom <- textInputGeomForWidget ctx wid+  case mGeom of+    Nothing -> pure False+    Just (fieldRect, contentX, value, fm) -> do+      let mouse@(V2 mouseX _) = inputMousePos inp+          charAt = do+            prepared <- prepareFontMetrics fm value+            pure (textIndexAtX prepared value (max 0 (mouseX - contentX)))+      if inputMousePressed inp && rectContains fieldRect mouse+        then do+          cleared <- searchClearHit ctx wid mouse+          if cleared+            then clearSearchField ctx wid+            else do+              idx <- charAt+              clicks <- normalizeTextFieldClicks ctx wid idx 0 0 False (max 1 (inputMouseClicks inp))+              uncurry (updateTextInputSelection ctx wid) (textSelectionForClick value idx clicks)+              setTextInputDrag ctx (Just (TextInputDrag wid idx 0 0 False clicks))+        else do+          mDrag <- getsInteraction ctx isTextInputDrag+          case mDrag of+            Just drag+              | textInputDragWidget drag == wid+                  , not (textInputDragMultiline drag)+                  , inputMouseDown inp || inputMouseReleased inp -> do+                  idx <- charAt+                  uncurry (updateTextInputSelection ctx wid) $+                    textSelectionForDrag value (textInputDragAnchor drag) idx (textInputDragClicks drag)+            _ -> pure ()+      pure True++collapseTextInputSelection :: Context -> WidgetId -> IO ()+collapseTextInputSelection ctx wid = do+  store <- getStore ctx+  let key = intKey wid+      cur = IM.findWithDefault 0 (slotKey SlotCursor key) (storeInt store)+  setStore ctx (store {storeInt = IM.insert (slotKey SlotAnchor key) cur (storeInt store)})++-- | Count a press as a multi-click only when it lands on the same cell as the+-- previous press; anything else restarts the count at one.+normalizeTextFieldClicks :: Context -> WidgetId -> Int -> Int -> Int -> Bool -> Int -> IO Int+normalizeTextFieldClicks ctx wid flat row col multiline rawClicks = do+  let cell =+        TextFieldClickCell+          { textFieldClickWidget = wid+          , textFieldClickFlat = flat+          , textFieldClickRow = row+          , textFieldClickCol = col+          , textFieldClickMultiline = multiline+          }+  if rawClicks <= 1+    then modifyInteraction ctx (\s -> s {isTextFieldClickCell = Just cell}) >> pure rawClicks+    else do+      mPrev <- getsInteraction ctx isTextFieldClickCell+      if maybe False (sameCell cell) mPrev+        then pure rawClicks+        else modifyInteraction ctx (\s -> s {isTextFieldClickCell = Just cell}) >> pure 1+  where+    sameCell a b =+      textFieldClickWidget a == textFieldClickWidget b+        && textFieldClickMultiline a == textFieldClickMultiline b+        && if textFieldClickMultiline a+          then textFieldClickRow a == textFieldClickRow b && textFieldClickCol a == textFieldClickCol b+          else textFieldClickFlat a == textFieldClickFlat b
+ lib/NanoUI/Frame/Window.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE DataKinds #-}++-- | Floating window input: dragging by the title bar, edge and inner-east+-- resizing, the resize cursor, and persisting window placement.+module NanoUI.Frame.Window+  ( lookupWindowPos+  , lookupWindowSize+  , persistWindowPositions+  , updateWindowDrag+  , updateWindowResize+  , WindowResizeEdge (..)+  , windowResizeCursorKind+  ) where++import Control.Monad (when)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (fromMaybe, isJust)+import NanoUI.Context+  ( Context (..)+  , WidgetStore (..)+  , WindowResizeDrag (..)+  , WindowResizeEdge (..)+  , damageWidget+  , getStore+  , getWindowDrag+  , getWindowResize+  , intKey+  , markDirty+  , setStore+  , slotKey+  , Slot (..)+  , InteractionState (..)+  , modifyInteraction+  )+import NanoUI.Font (ScrollBarSlot (..))+import NanoUI.Frame.Hit (findNodeByWidgetId, nodeInSubtree, topmostOverlayAtMouse)+import NanoUI.Frame.Input (findTopWidgetUnderMouse, isInteractiveNode)+import NanoUI.Frame.Redraw (probeHotId)+import NanoUI.Frame.Scroll.Geometry (scrollChromeLane)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (Input (..), UiCursorKind (..), inputMouseDown, inputMousePos, inputMousePressed)+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , findChildM+  , findNodeRevM+  , foldNodesM+  , getDirection+  , getFirstChild+  , getMinMax+  , getNextSibling+  , getNodeType+  , getNodeValue+  , getPadding+  , getRect+  , getWidgetId+  )+import NanoUI.Layout.Solve (placeWindowNode, scrollBarSlotOf)+import NanoUI.Style (Padding (..))+import NanoUI.Types (DamageBounds (..), Rect (..), V2 (..), haloDamageSlop, rectContains, rectInflate)++topmostWindowAtResizeHalo :: Context -> V2 -> IO (Maybe NodeIdx)+topmostWindowAtResizeHalo ctx mouse =+  findNodeRevM (ctxNodeArena ctx) $ \idx -> do+    nt <- getNodeType (ctxNodeArena ctx) idx+    if nt /= NodeWindow+      then pure False+      else do+        (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+        if w <= 0 || h <= 0+          then pure False+          else do+            let rect = Rect x y w h+            if rectContains (rectInflate windowResizeHandleFor rect) mouse+              then pure True+              else windowInnerEastResizeHit ctx idx rect mouse++windowInnerEastResizeHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool+windowInnerEastResizeHit ctx winIdx (Rect x _ w _) mouse@(V2 mx _) = do+  pad <- getPadding (ctxNodeArena ctx) winIdx+  if mx < x + w - padR pad || mx > x + w+    then pure False+    else do+      mLane <- windowBodyScrollLane ctx winIdx+      pure (not (maybe False (`rectContains` mouse) mLane))++lookupWindowPos :: Context -> WidgetId -> IO (Maybe (Float, Float))+lookupWindowPos ctx wid = do+  store <- getStore ctx+  pure (IM.lookup (intKey wid) (storePoint store))++lookupWindowSize :: Context -> WidgetId -> IO (Maybe (Float, Float))+lookupWindowSize ctx wid = do+  store <- getStore ctx+  pure (IM.lookup (slotKey SlotWinSize (intKey wid)) (storePoint store))++persistWindowPositions :: Context -> IO ()+persistWindowPositions ctx = do+  store0 <- getStore ctx+  let na = ctxNodeArena ctx+      record acc idx = do+        nt <- getNodeType na idx+        if nt /= NodeWindow+          then pure acc+          else do+            wid <- getWidgetId na idx+            (x, y, w, h) <- getRect na idx+            let k = intKey wid+                sizeKey = slotKey SlotWinSize k+                points = storePoint acc+            -- Keep an unchanged map as is, so the store comparison below+            -- short-circuits on pointer equality.+            pure $+              if IM.lookup k points == Just (x, y) && IM.lookup sizeKey points == Just (w, h)+                then acc+                else acc {storePoint = IM.insert k (x, y) (IM.insert sizeKey (w, h) points)}+  store1 <- foldNodesM na record store0+  when (store1 /= store0) $ setStore ctx store1++updateWindowDrag :: Context -> Input -> IO Bool+updateWindowDrag ctx inp = do+  resizing <- isJust <$> getWindowResize ctx+  if resizing+    then pure False+    else do+      drag <- getWindowDrag ctx+      case drag of+        Just (wid, gx, gy)+          | inputMouseDown inp -> do+              let V2 mx my = inputMousePos inp+              store <- getStore ctx+              setStore ctx (store {storePoint = IM.insert (intKey wid) (mx - gx, my - gy) (storePoint store)})+              damageWidget ctx wid (DamageInflated haloDamageSlop)+              markDirty ctx+              pure True+          | otherwise -> do+              modifyInteraction ctx (\s -> s {isWindowDrag = Nothing})+              pure False+        Nothing+          | inputMousePressed inp -> tryStartWindowDrag ctx (inputMousePos inp)+          | otherwise -> pure False++windowResizeHandleFor :: Float+windowResizeHandleFor = 12++-- Handles sit outside the window. The right pad strip also resizes beside the bar.+windowResizeEdgeAt :: Rect -> V2 -> Maybe WindowResizeEdge+windowResizeEdgeAt (Rect x y w h) (V2 mx my) =+  let s = windowResizeHandleFor+      onL = mx >= x - s && mx < x+      onR = mx > x + w && mx <= x + w + s+      onT = my >= y - s && my < y+      onB = my > y + h && my <= y + h + s+   in if not (onL || onR || onT || onB)+        then Nothing+        else+          Just $+            case (onT, onB, onL, onR) of+              (True, _, True, _) -> ResizeNW+              (True, _, _, True) -> ResizeNE+              (_, True, True, _) -> ResizeSW+              (_, True, _, True) -> ResizeSE+              (True, _, _, _) -> ResizeN+              (_, True, _, _) -> ResizeS+              (_, _, True, _) -> ResizeW+              _ -> ResizeE++innerEastCornerEdge :: Padding -> Rect -> Float -> WindowResizeEdge+innerEastCornerEdge pad (Rect _ y _ h) my =+  let s = windowResizeHandleFor+      minBand = 6+      topBand = max minBand (min s (padT pad))+      botBand = max minBand (min s (padB pad))+   in if my >= y && my < y + topBand+        then ResizeNE+        else if my > y + h - botBand && my <= y + h then ResizeSE else ResizeE++-- | Lane of the window body's scrollbar while its content overflows.+windowBodyScrollLane :: Context -> NodeIdx -> IO (Maybe Rect)+windowBodyScrollLane ctx winIdx = do+  let na = ctxNodeArena ctx+  mBody <-+    findChildM na winIdx $ \ci -> do+      nt <- getNodeType na ci+      if nt /= NodeScrollContainer+        then pure False+        else do+          slot <- scrollBarSlotOf na ci+          if slot /= ScrollBarWindow+            then pure False+            else do+              (_, _, _, h) <- getRect na ci+              pad <- getPadding na ci+              contentSize <- getNodeValue na ci+              pure (contentSize > h - padT pad - padB pad)+  traverse+    ( \ci -> do+        (x, y, w, h) <- getRect na ci+        pad <- getPadding na ci+        dir <- getDirection na ci+        pure (scrollChromeLane ScrollBarWindow dir x y w h pad)+    )+    mBody++windowInnerResizeEdgeAt :: Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)+windowInnerResizeEdgeAt ctx winIdx winRect@(Rect x y w h) mouse@(V2 mx my) = do+  hit <- windowInnerEastResizeHit ctx winIdx winRect mouse+  if hit+    then do+      pad <- getPadding (ctxNodeArena ctx) winIdx+      pure (Just (innerEastCornerEdge pad winRect my))+    else do+      let cornerW = min 16 (w / 3)+          cornerH = min 16 (h / 3)+          botH = min 6 (h / 3)+          inBotRightCorner = mx >= x + w - cornerW && mx <= x + w && my >= y + h - cornerH && my <= y + h+          inBotEdge = mx >= x && mx <= x + w && my >= y + h - botH && my <= y + h+      pure $+        if inBotRightCorner+          then Just ResizeSE+          else if inBotEdge then Just ResizeS else Nothing++windowResizeEdgeFor :: Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)+windowResizeEdgeFor ctx winIdx winRect mouse =+  case windowResizeEdgeAt winRect mouse of+    Just edge -> pure (Just edge)+    Nothing -> windowInnerResizeEdgeAt ctx winIdx winRect mouse++cursorForResizeEdge :: WindowResizeEdge -> UiCursorKind+cursorForResizeEdge = \case+  ResizeN -> UiCursorNsResize+  ResizeS -> UiCursorNsResize+  ResizeE -> UiCursorEwResize+  ResizeW -> UiCursorEwResize+  ResizeNW -> UiCursorNwseResize+  ResizeSE -> UiCursorNwseResize+  ResizeNE -> UiCursorNeswResize+  ResizeSW -> UiCursorNeswResize++resizeFromEdge :: WindowResizeDrag -> V2 -> Float -> Float -> (Float, Float, Float, Float)+resizeFromEdge wrd (V2 mx my) winW winH =+  let !dx = mx - wrdGrabX wrd+      !dy = my - wrdGrabY wrd+      !minW = max (wrdMinW wrd) 1.0+      !minH = max (wrdMinH wrd) 1.0+      !maxW = min (wrdMaxW wrd) winW+      !maxH = min (wrdMaxH wrd) winH+      !right0 = wrdStartX wrd + wrdStartW wrd+      !bottom0 = wrdStartY wrd + wrdStartH wrd+      edge = wrdEdge wrd+      !fromE = edge `elem` [ResizeE, ResizeNE, ResizeSE]+      !fromW = edge `elem` [ResizeW, ResizeNW, ResizeSW]+      !fromS = edge `elem` [ResizeS, ResizeSE, ResizeSW]+      !fromN = edge `elem` [ResizeN, ResizeNE, ResizeNW]+      !w0+        | fromE = wrdStartW wrd + dx+        | fromW = wrdStartW wrd - dx+        | otherwise = wrdStartW wrd+      !h0+        | fromS = wrdStartH wrd + dy+        | fromN = wrdStartH wrd - dy+        | otherwise = wrdStartH wrd+      !w = max minW (min maxW w0)+      !h = max minH (min maxH h0)+      !x0 = if fromW then right0 - w else wrdStartX wrd+      !y0 = if fromN then bottom0 - h else wrdStartY wrd+      !x = max 0 (min x0 (max 0 (winW - w)))+      !y = max 0 (min y0 (max 0 (winH - h)))+   in (w, h, x, y)++updateWindowResize :: Context -> Input -> Float -> Float -> IO Bool+updateWindowResize ctx inp winW winH = do+  drag <- getWindowResize ctx+  case drag of+    Just wrd+      | inputMouseDown inp -> do+          let (nw, nh, nx, ny) = resizeFromEdge wrd (inputMousePos inp) winW winH+              key = intKey (wrdWidget wrd)+          store <- getStore ctx+          setStore ctx (store {storePoint = IM.insert (slotKey SlotWinSize key) (nw, nh) (IM.insert key (nx, ny) (storePoint store))})+          relayoutWindow ctx winW winH (wrdWidget wrd) nw nh+          damageWidget ctx (wrdWidget wrd) (DamageInflated haloDamageSlop)+          markDirty ctx+          pure True+      | otherwise -> do+          modifyInteraction ctx (\s -> s {isWindowResize = Nothing})+          pure False+    Nothing+      | inputMousePressed inp -> tryStartWindowResize ctx (inputMousePos inp)+      | otherwise -> pure False++relayoutWindow :: Context -> Float -> Float -> WidgetId -> Float -> Float -> IO ()+relayoutWindow ctx winW winH wid nw nh = do+  mIdx <- findNodeByWidgetId ctx wid+  case mIdx of+    Nothing -> pure ()+    Just idx -> do+      mpos <- lookupWindowPos ctx wid+      (x, y, _, _) <- getRect (ctxNodeArena ctx) idx+      placeWindowNode (ctxNodeArena ctx) (ctxFontMetrics ctx) winW winH idx nw nh (const (fromMaybe (x, y) mpos))++-- | Resize edge under @mouse@ for the topmost window whose halo holds it,+-- unless the halo is blocked or the pointer is on the title bar or one of its+-- controls.+resizeEdgeTarget :: Context -> V2 -> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))+resizeEdgeTarget ctx mouse = do+  mWin <- topmostWindowAtResizeHalo ctx mouse+  case mWin of+    Nothing -> pure Nothing+    Just idx -> do+      (x, y, w, h) <- getRect (ctxNodeArena ctx) idx+      let rect = Rect x y w h+      -- The halo covers the window interior, so find the edge first and run+      -- the hover probe and node scans only when there is one.+      mEdge <- windowResizeEdgeFor ctx idx rect mouse+      case mEdge of+        Nothing -> pure Nothing+        Just edge -> do+          mTitle <- windowTitleRect ctx idx+          if maybe False (`rectContains` mouse) mTitle+            then pure Nothing+            else do+              blocked <- resizeHaloBlocked ctx mouse idx+              overControl <- if blocked then pure False else windowTitleHasInteractive ctx idx mouse+              pure (if blocked || overControl then Nothing else Just (idx, rect, edge))++tryStartWindowResize :: Context -> V2 -> IO Bool+tryStartWindowResize ctx mouse@(V2 mx my) = do+  mTarget <- resizeEdgeTarget ctx mouse+  case mTarget of+    Nothing -> pure False+    Just (idx, Rect x y w h, edge) -> do+      wid <- getWidgetId (ctxNodeArena ctx) idx+      (minW, minH, maxW, maxH) <- getMinMax (ctxNodeArena ctx) idx+      modifyInteraction ctx $ \s ->+        s+          { isWindowResize =+              Just+                WindowResizeDrag+                  { wrdWidget = wid+                  , wrdEdge = edge+                  , wrdGrabX = mx+                  , wrdGrabY = my+                  , wrdStartX = x+                  , wrdStartY = y+                  , wrdStartW = w+                  , wrdStartH = h+                  , wrdMinW = minW+                  , wrdMinH = minH+                  , wrdMaxW = maxW+                  , wrdMaxH = maxH+                  }+          }+      markDirty ctx+      pure True++windowResizeCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)+windowResizeCursorKind ctx inp = do+  mDrag <- getWindowResize ctx+  case mDrag of+    Just wrd+      | inputMouseDown inp -> pure (Just (cursorForResizeEdge (wrdEdge wrd)))+      | otherwise -> pure Nothing+    Nothing -> fmap (\(_, _, edge) -> cursorForResizeEdge edge) <$> resizeEdgeTarget ctx (inputMousePos inp)++-- Halo must not steal hits from page widgets or another window's interior.+resizeHaloBlocked :: Context -> V2 -> NodeIdx -> IO Bool+resizeHaloBlocked ctx mouse winIdx = do+  mInside <- topmostOverlayAtMouse ctx mouse+  case mInside of+    Just other | other /= winIdx -> pure True+    _ -> do+      hot <- probeHotId ctx mouse+      if hashWidgetId hot == 0+        then pure False+        else do+          mHot <- findNodeByWidgetId ctx hot+          case mHot of+            Nothing -> pure False+            Just hotIdx -> not <$> nodeInSubtree ctx hotIdx winIdx++tryStartWindowDrag :: Context -> V2 -> IO Bool+tryStartWindowDrag ctx mouse@(V2 mx my) = do+  mTop <- topmostOverlayAtMouse ctx mouse+  case mTop of+    Nothing -> pure False+    Just idx -> do+      nt <- getNodeType (ctxNodeArena ctx) idx+      mTitle <- if nt == NodeWindow then windowTitleRect ctx idx else pure Nothing+      case mTitle of+        Just title | rectContains title mouse -> do+          overClose <- windowTitleHasInteractive ctx idx mouse+          if overClose+            then pure False+            else do+              wid <- getWidgetId (ctxNodeArena ctx) idx+              (wx, wy, _, _) <- getRect (ctxNodeArena ctx) idx+              modifyInteraction ctx (\s -> s {isWindowDrag = Just (wid, mx - wx, my - wy)})+              markDirty ctx+              pure True+        _ -> pure False++-- | Title bar: the window's topmost child, stretched up to the window top.+windowTitleRect :: Context -> NodeIdx -> IO (Maybe Rect)+windowTitleRect ctx idx = do+  (_, wy, _, _) <- getRect (ctxNodeArena ctx) idx+  fc <- getFirstChild (ctxNodeArena ctx) idx+  mBest <- go fc Nothing+  pure $ case mBest of+    Nothing -> Nothing+    Just (Rect cx cy cw ch) ->+      let topY = min wy cy+       in Just (Rect cx topY cw ((cy - topY) + ch))+  where+    go ci best+      | ci < 0 = pure best+      | otherwise = do+          (x, y, w, h) <- getRect (ctxNodeArena ctx) ci+          ns <- getNextSibling (ctxNodeArena ctx) ci+          let here = Rect x y w h+          go ns $ case best of+            Just b@(Rect _ by _ _) | y >= by -> Just b+            _ -> Just here++windowTitleHasInteractive :: Context -> NodeIdx -> V2 -> IO Bool+windowTitleHasInteractive ctx idx mouse = do+  mWid <- findTopWidgetUnderMouse ctx mouse isInteractiveNode+  case mWid of+    Nothing -> pure False+    Just wid -> do+      mNode <- findNodeByWidgetId ctx wid+      maybe (pure False) (\wi -> nodeInSubtree ctx wi idx) mNode
+ lib/NanoUI/Hooks.hs view
@@ -0,0 +1,84 @@+-- | Local state hooks. The store representation varies by value type, but+-- identity, equality checks, and invalidation follow one policy.+module NanoUI.Hooks+  ( useState+  , useFlag+  , useInt+  , useFloat+  , useEnum+  , useText+  , useToggle+  )+where++import Control.Monad (when)+import Data.Dynamic (fromDynamic, toDyn)+import Data.IntMap.Strict qualified as IM+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Effectful (Eff, type (:>))+import NanoUI.Context (getStore, intKey, setStore)+import NanoUI.Monad (Ui, askContext, nextId, uiIO)+import NanoUI.Store (WidgetStore (..), boolInt, bumpMirror, intBool)++useState :: (Typeable a, Eq a, Ui :> es) => a -> Eff es (a, a -> Eff es ())+useState =+  useStored+    (\key store -> IM.lookup key (storeDyn store) >>= fromDynamic)+    ( \key value store -> store {storeDyn = IM.insert key (toDyn value) (storeDyn store)}+    )++useStored ::+  (Eq a, Ui :> es) =>+  (Int -> WidgetStore -> Maybe a)+  -> (Int -> a -> WidgetStore -> WidgetStore)+  -> a+  -> Eff es (a, a -> Eff es ())+useStored lookupValue update initial = do+  wid <- nextId+  ctx <- askContext+  let+    key = intKey wid+    valueIn = fromMaybe initial . lookupValue key+    setValue value = uiIO $ do+      -- A setter can run more than once in a frame. Compare with the latest+      -- store, not the value captured when the hook was evaluated.+      store <- getStore ctx+      when (valueIn store /= value) $+        setStore ctx (bumpMirror (update key value store))+  value <- valueIn <$> uiIO (getStore ctx)+  pure (value, setValue)++useFlag :: Ui :> es => Bool -> Eff es (Bool, Bool -> Eff es ())+useFlag initial = do+  (value, setValue) <- useInt (boolInt initial)+  pure (intBool value, setValue . boolInt)++useInt :: Ui :> es => Int -> Eff es (Int, Int -> Eff es ())+useInt =+  useStored+    (\key -> IM.lookup key . storeInt)+    (\key value store -> store {storeInt = IM.insert key value (storeInt store)})++useFloat :: Ui :> es => Float -> Eff es (Float, Float -> Eff es ())+useFloat =+  useStored+    (\key -> IM.lookup key . storeFloat)+    (\key value store -> store {storeFloat = IM.insert key value (storeFloat store)})++useEnum :: (Enum a, Ui :> es) => a -> Eff es (a, a -> Eff es ())+useEnum initial = do+  (index, setIndex) <- useInt (fromEnum initial)+  pure (toEnum index, setIndex . fromEnum)++useText :: Ui :> es => Text -> Eff es (Text, Text -> Eff es ())+useText =+  useStored+    (\key -> IM.lookup key . storeText)+    (\key value store -> store {storeText = IM.insert key value (storeText store)})++useToggle :: Ui :> es => Bool -> Eff es (Bool, Eff es ())+useToggle initial = do+  (value, setValue) <- useFlag initial+  pure (value, setValue (not value))
+ lib/NanoUI/Id.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StrictData #-}++-- | Widget ids and the id context they are derived from. See the+-- "Widget identity" section of "NanoUI" for how ids are assigned.+module NanoUI.Id+  ( WidgetId (..)+  , IdContext (..)+  , initialIdContext+  , idContextWidgetId+  , widgetId+  , hashWidgetId+  , fnv1a+  , mix64+  , mixFnv+  , scopeTag+  , enterScope+  , enterKeyed+  )+where++import Data.Bits (shiftR, xor)+import Data.Char (ord)+import Data.Hashable (Hashable)+import Data.Primitive.Types (Prim)+import Data.Word (Word64, Word8)+import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)++newtype WidgetId = WidgetId Word64+  deriving stock (Eq, Ord, Show)+  deriving newtype (Hashable, Prim)++data IdContext = IdContext+  { currentId :: {-# UNPACK #-} !Word64+  , siblingId :: {-# UNPACK #-} !Word64+  }+  deriving stock (Eq, Show)++initialIdContext :: IdContext+initialIdContext = IdContext 0x243F6A8885A308D3 0++-- | Id of the next sibling in this context. A zero hash becomes 1, so+-- @WidgetId 0@ never names a real widget.+{-# INLINE idContextWidgetId #-}+idContextWidgetId :: IdContext -> WidgetId+idContextWidgetId (IdContext cid sid) =+  let+    raw = mix64 cid sid+   in+    if raw == 0 then WidgetId 1 else WidgetId raw++scopeTag :: Word64+scopeTag = 0x9E3779B185EBCA87++keyedTag :: Word64+keyedTag = 0xC2B2AE3D27D4EB4F++{-# INLINE enterScope #-}+enterScope :: Word64 -> IdContext -> (IdContext, IdContext)+enterScope tag parent =+  let+    IdContext pid sib = parent+    child = IdContext (mix64 (mix64 pid sib) tag) 0+    parent' = parent {siblingId = sib + 1}+   in+    (parent', child)++{-# INLINE enterKeyed #-}+enterKeyed :: Word64 -> IdContext -> (IdContext, IdContext)+enterKeyed tag parent =+  let+    IdContext pid sid = parent+    child = IdContext (mix64 (mix64 pid tag) keyedTag) 0+    parent' = parent {siblingId = sid + 1}+   in+    (parent', child)++{-# INLINE widgetId #-}+widgetId :: HasCallStack => WidgetId+widgetId =+  let+    stack = getCallStack callStack+    loc = case stack of+      (_, loc') : _ -> loc'+      [] -> error "widgetId: empty CallStack"+   in+    hashSrcLoc loc++hashSrcLoc :: SrcLoc -> WidgetId+hashSrcLoc+  ( SrcLoc+      { srcLocPackage+      , srcLocModule+      , srcLocFile+      , srcLocStartLine+      , srcLocStartCol+      }+    ) =+    WidgetId $+      fnv1a srcLocPackage+        `mixFnv` fnv1a srcLocModule+        `mixFnv` fnv1a srcLocFile+        `mixFnv` fromIntegral srcLocStartLine+        `mixFnv` fromIntegral srcLocStartCol++{-# INLINE hashWidgetId #-}+hashWidgetId :: WidgetId -> Word64+hashWidgetId (WidgetId w) = w++{-# INLINE fnv1a #-}+fnv1a :: String -> Word64+fnv1a s =+  foldl'+    (\acc c -> (fromIntegral @Word8 @Word64 (fromIntegral (ord c)) `xor` acc) * 0x00000100000001B3)+    0xcbf29ce484222325+    s++{-# INLINE mix64 #-}+mix64 :: Word64 -> Word64 -> Word64+mix64 x y =+  let+    z = x + (y * 0x9E3779B97F4A7C15)+    z1 = z `xor` (z `shiftR` 30)+    z2 = z1 * 0xBF58476D1CE4E5B9+    z3 = z2 `xor` (z2 `shiftR` 27)+   in+    z3 * 0x94D049BB133111EB++{-# INLINE mixFnv #-}+mixFnv :: Word64 -> Word64 -> Word64+mixFnv x y = (x `xor` y) * 1099511628211
+ lib/NanoUI/Input.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE StrictData #-}++-- | The per-frame 'Input' record backends fill in: pointer state, keys and+-- modifiers, typed characters, scroll, window size, and file drops.+module NanoUI.Input+  ( Key (..)+  , Modifiers (..)+  , Input (..)+  , DropType (..)+  , DropEvent (..)+  , emptyDropEvents+  , emptyInput+  , inputInteracted+  , inputPointerHeld+  , appendInputKey+  , appendDropEvent+  , MouseButton (..)+  , applyMouseButton+  , inputKeysNull+  , inputKeysElem+  , foldInputKeys+  , inputKeysFromList+  , emptyInputKeys+  , stripInteractionInput+  , UiCursorKind (..)+  , grabHoverKind+  , grabDragKind+  , clearEphemeral+  , isHardQuitInput+  , splitFrame+  ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Primitive.SmallArray (SmallArray, copySmallArray, emptySmallArray, newSmallArray, runSmallArray, sizeofSmallArray, smallArrayFromList)+import NanoUI.Types (Size (..), V2 (..))++data Key+  = KeyBackspace+  | KeyDelete+  | KeyEnter+  | KeyEscape+  | KeyTab+  | KeyLeft+  | KeyRight+  | KeyUp+  | KeyDown+  | KeyHome+  | KeyEnd+  deriving (Eq, Show, Enum, Bounded)++data Modifiers = Modifiers+  { modShift :: !Bool+  , modCtrl :: !Bool+  , modAlt :: !Bool+  }+  deriving (Eq, Show)++-- | OS-level drag-and-drop event kind, mirroring @SDL_EventType@ drop codes.+data DropType+  = DropBegin     -- ^ A drag enters the window; no position or payload yet.+  | DropPosition  -- ^ The drag pointer moved over the window; position available.+  | DropFile      -- ^ A file path was dropped; 'dropEventData' holds the path.+  | DropText      -- ^ Text was dropped; 'dropEventData' holds the text.+  | DropComplete  -- ^ The OS drag operation finished.+  deriving (Eq, Show)++-- | A single normalized drop payload surfaced to widgets.+data DropEvent = DropEvent+  { dropEventType :: !DropType+  , dropEventPos :: !(Maybe V2)+  , dropEventData :: !Text+  }+  deriving (Eq, Show)++data Input = Input+  { inputMousePos :: {-# UNPACK #-} !V2+  , inputMouseDown :: {-# UNPACK #-} !Bool+  , inputMousePressed :: {-# UNPACK #-} !Bool+  , inputMouseReleased :: {-# UNPACK #-} !Bool+  , inputMouseRightDown :: {-# UNPACK #-} !Bool+  , inputMouseRightPressed :: {-# UNPACK #-} !Bool+  , inputMouseRightReleased :: {-# UNPACK #-} !Bool+  , inputMouseClicks :: {-# UNPACK #-} !Int+  , inputScroll :: {-# UNPACK #-} !V2+  , inputKeys :: SmallArray Key+  , inputChars :: !Text+  , inputModifiers :: !Modifiers+  , inputWindowSize :: {-# UNPACK #-} !Size+  , inputDeltaTime :: {-# UNPACK #-} !Float+  , inputDrops :: SmallArray DropEvent+  , inputWindowRedraw :: {-# UNPACK #-} !Bool+  }+  deriving (Eq, Show)++emptyInput :: Input+emptyInput =+  Input+    { inputMousePos = V2 0 0+    , inputMouseDown = False+    , inputMousePressed = False+    , inputMouseReleased = False+    , inputMouseRightDown = False+    , inputMouseRightPressed = False+    , inputMouseRightReleased = False+    , inputMouseClicks = 1+    , inputScroll = V2 0 0+    , inputKeys = emptyInputKeys+    , inputChars = ""+    , inputModifiers = Modifiers False False False+    , inputWindowSize = Size 800 600+    , inputDeltaTime = 0+    , inputDrops = emptyDropEvents+    , inputWindowRedraw = False+    }++data UiCursorKind+  = UiCursorDefault+  | UiCursorPointer+  | UiCursorText+  | UiCursorGrab+  | UiCursorGrabbing+  | UiCursorNsResize+  | UiCursorEwResize+  | UiCursorNwseResize+  | UiCursorNeswResize+  deriving (Eq, Show)++grabHoverKind :: Bool -> Input -> UiCursorKind+grabHoverKind onTarget inp = grabDragKind onTarget False inp++grabDragKind :: Bool -> Bool -> Input -> UiCursorKind+grabDragKind onTarget dragging inp+  | dragging = UiCursorGrabbing+  | onTarget, inputMouseDown inp = UiCursorGrabbing+  | onTarget = UiCursorGrab+  | otherwise = UiCursorDefault++clearEphemeral :: Input -> Input+clearEphemeral inp =+  inp+    { inputKeys = emptyInputKeys+    , inputChars = ""+    , inputMousePressed = False+    , inputMouseReleased = False+    , inputMouseRightPressed = False+    , inputMouseRightReleased = False+    , inputMouseClicks = 1+    , inputScroll = V2 0 0+    , inputDrops = emptyDropEvents+    , inputWindowRedraw = False+    }++isHardQuitInput :: Input -> Bool+isHardQuitInput inp =+  modCtrl (inputModifiers inp)+    && (T.elem 'c' (inputChars inp) || T.elem '\ETX' (inputChars inp))++splitFrame :: (a -> Bool) -> [a] -> ([a], [a])+splitFrame isEdge events =+  case break isEdge events of+    (before, edge : rest) -> (before ++ [edge], rest)+    (before, []) -> (before, [])++{-# INLINE appendInputKey #-}+appendInputKey :: Key -> SmallArray Key -> SmallArray Key+appendInputKey k ks = snocSmallArray ks k++-- | The drops with one more at the end.+{-# INLINE appendDropEvent #-}+appendDropEvent :: DropEvent -> SmallArray DropEvent -> SmallArray DropEvent+appendDropEvent ev evs = snocSmallArray evs ev++-- A frame holds a few keys and drops, so each append copies.+snocSmallArray :: SmallArray a -> a -> SmallArray a+snocSmallArray xs x = runSmallArray $ do+  let n = sizeofSmallArray xs+  out <- newSmallArray (n + 1) x+  copySmallArray out 0 xs 0 n+  pure out++-- | Mouse buttons tracked by 'Input'.+data MouseButton = MouseLeft | MouseRight+  deriving (Eq, Show)++-- | Apply a button transition: the held state plus that frame's one-shot+-- pressed or released flag.+applyMouseButton :: MouseButton -> Bool -> Input -> Input+applyMouseButton MouseLeft True inp = inp {inputMouseDown = True, inputMousePressed = True}+applyMouseButton MouseLeft False inp = inp {inputMouseDown = False, inputMouseReleased = True}+applyMouseButton MouseRight True inp = inp {inputMouseRightDown = True, inputMouseRightPressed = True}+applyMouseButton MouseRight False inp = inp {inputMouseRightDown = False, inputMouseRightReleased = True}++{-# INLINE inputKeysFromList #-}+inputKeysFromList :: [Key] -> SmallArray Key+inputKeysFromList = smallArrayFromList++emptyInputKeys :: SmallArray Key+emptyInputKeys = emptySmallArray++emptyDropEvents :: SmallArray DropEvent+emptyDropEvents = emptySmallArray++{-# INLINE inputKeysNull #-}+inputKeysNull :: SmallArray Key -> Bool+inputKeysNull ks = sizeofSmallArray ks == 0++{-# INLINE inputKeysElem #-}+inputKeysElem :: Key -> SmallArray Key -> Bool+inputKeysElem = elem++{-# INLINE foldInputKeys #-}+foldInputKeys :: (a -> Key -> a) -> a -> SmallArray Key -> a+foldInputKeys = foldl'++-- Buttons, keys, scroll, resize. Mouse motion alone does not count.+inputInteracted :: Input -> Input -> Bool+inputInteracted a b =+  inputMouseDown a /= inputMouseDown b+    || inputMousePressed a /= inputMousePressed b+    || inputMouseReleased a /= inputMouseReleased b+    || inputMouseRightDown a /= inputMouseRightDown b+    || inputMouseRightPressed a /= inputMouseRightPressed b+    || inputMouseRightReleased a /= inputMouseRightReleased b+    || inputMouseClicks a /= inputMouseClicks b+    || inputScroll a /= inputScroll b+    || inputKeys a /= inputKeys b+    || inputChars a /= inputChars b+    || inputModifiers a /= inputModifiers b+    || inputWindowSize a /= inputWindowSize b+    || inputDrops a /= inputDrops b++{-# INLINE inputPointerHeld #-}+inputPointerHeld :: Input -> Bool+inputPointerHeld inp =+  inputMouseDown inp || inputMouseRightDown inp++-- Rebuild UI after store mirrors update. Keep hover/drag; drop one-shot input.+stripInteractionInput :: Input -> Input+stripInteractionInput inp =+  inp+    { inputMousePressed = False+    , inputMouseReleased = False+    , inputMouseRightPressed = False+    , inputMouseRightReleased = False+    , inputKeys = emptyInputKeys+    , inputChars = ""+    , inputScroll = V2 0 0+    , inputDrops = emptyDropEvents+    }
+ lib/NanoUI/Layout/Arena.hs view
@@ -0,0 +1,1276 @@+{-# LANGUAGE RecordWildCards #-}++-- | The node arena: one frame's layout nodes stored column-wise in primitive+-- arrays (geometry, style, tags and tree links), with accessors, traversals+-- and the layout cache.+module NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , NodeArenaArrays (..)+  , isWidgetNode+  , isContainerNode+  , isScrollNode+  , isFloatingNode+  , SizingTag (..)+  , DirTag (..)+  , NodeArena (..)+  , FlexScratch (..)+  , newNodeArena+  , resetNodeArena+  , arenaCount+  , topModalNode+  , floatingNodeCount+  , arenaArrays+  , withArenaArraysSnap+  , geomX+  , geomY+  , geomW+  , geomH+  , styleWVal+  , styleHVal+  , styleMinW+  , styleMinH+  , styleMaxW+  , styleMaxH+  , stylePadL+  , stylePadR+  , stylePadT+  , stylePadB+  , styleGap+  , styleGridMinColW+  , tagNodeType+  , tagDirection+  , tagWSizing+  , tagHSizing+  , tagScrollBarSlot+  , treeParent+  , treeFirstChild+  , treeNextSibling+  , treeStyleIdx+  , treeGridCols+  , readGeom+  , writeGeom+  , readStyle+  , readTagEnum+  , writeTagEnum+  , readTree+  , writeTree+  , addNode+  , addNodeFromLayout+  , rootAttachParent+  , setNodeText+  , getParent+  , getFirstChild+  , getNextSibling+  , getChildCount+  , getNodeType+  , getDirection+  , getGridCols+  , getGridMinColW+  , getScrollContentW+  , setScrollContentW+  , getWidthSizing+  , getHeightSizing+  , getPadding+  , getGap+  , getMinMax+  , parentIsRow+  , getAlignX+  , getAlignY+  , getRect+  , setRect+  , getLayoutRect+  , getClipRect+  , setClipRect+  , snapshotLayoutRects+  , getText+  , getOptions+  , setOptions+  , getWidgetId+  , setWidgetId+  , lookupNodeByWidgetId+  , lookupNodeByKey+  , getStyleIdx+  , setStyleIdx+  , getNodeValue+  , setNodeValue+  , getNodeFontSize+  , getNodeFontColor+  , getNodeScope+  , getArenaScope+  , setArenaScope+  , getScopeSignature+  , ensureScratchCapacity+  , AxisSnapshot (..)+  , ensureAxisSnapshot+  , memoizeWidth+  , forNodes_+  , forChildNodes_+  , foldFlowChildrenM+  , findNodeRevM+  , foldNodeRevM+  , findNodeM+  , foldNodesM+  , findChildM+  , LayoutCache (..)+  , newLayoutCache+  , captureLayoutCache+  , layoutCacheEligible+  , layoutInputsMatch+  , restoreLayoutCache+  ) where++import Control.Exception (bracket_)+import Control.Monad (forM_, when)+import Data.Bits (shiftL, shiftR, xor, (.&.), (.|.))+import Data.HashTable.IO (BasicHashTable)+import qualified Data.HashTable.IO as HT+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Primitive.Array (MutableArray, copyMutableArray, newArray, readArray, sizeofMutableArray, writeArray)+import Data.Primitive.PrimArray+  ( MutablePrimArray+  , copyMutablePrimArray+  , newPrimArray+  , readPrimArray+  , setPrimArray+  , writePrimArray+  , resizeMutablePrimArray+  )+import Data.Primitive.Types (Prim)+import GHC.Exts (RealWorld)+import Data.Text (Text)+import Data.Word (Word8, Word32, Word64)+import qualified Data.Text as T+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Style (AlignX, AlignY, Direction (..), Layout (..), Padding (..), Sizing (..))+import NanoUI.Types (Color (..), Rect (..))++type NodeIdx = Int++data NodeType+  = NodeContainer+  | NodeText+  | NodeSpacer+  | NodeSeparator+  | NodeWidget+  | NodeButton+  | NodeCheckbox+  | NodeSlider+  | NodeTextInput+  | NodeTextArea+  | NodeScrollContainer+  | NodeSelect+  | NodeModal+  | NodeImage+  | NodePanel+  | NodeWindow+  -- Appended last: stored as Word8 in the arena. Update every exhaustive+  -- NodeType case when adding variants.+  | NodeBox+  | NodeRadio+  | NodeColorPicker+  | NodeTree+  | NodePopup+  | NodeDrawing+  deriving (Eq, Show, Enum, Bounded)++isWidgetNode :: NodeType -> Bool+isWidgetNode nt =+  case nt of+    NodeWidget -> True+    NodeButton -> True+    NodeCheckbox -> True+    NodeRadio -> True+    NodeSlider -> True+    NodeTextInput -> True+    NodeTextArea -> True+    NodeSelect -> True+    NodeColorPicker -> True+    NodeTree -> True+    NodeDrawing -> True+    _ -> False++isContainerNode :: NodeType -> Bool+isContainerNode nt =+  case nt of+    NodeContainer -> True+    NodeScrollContainer -> True+    NodeModal -> True+    NodePanel -> True+    NodeWindow -> True+    NodePopup -> True+    _ -> False++isScrollNode :: NodeType -> Bool+isScrollNode nt = nt == NodeScrollContainer++isFloatingNode :: NodeType -> Bool+isFloatingNode nt = nt == NodeModal || nt == NodeWindow || nt == NodePopup++data SizingTag+  = SizingFixed+  | SizingFit+  | SizingGrow+  | SizingShrink+  | SizingPercent+  deriving (Eq, Show, Enum, Bounded)++data DirTag = DirRow | DirColumn+  deriving (Eq, Show, Enum, Bounded)++-- | Node columns. Each array holds one row of @*Stride@ slots per node; the+-- column constants below name the slots.+data NodeArenaArrays = NodeArenaArrays+  { naArrGeom :: !(MutablePrimArray RealWorld Float)+  , naArrStyle :: !(MutablePrimArray RealWorld Float)+  , naArrTags :: !(MutablePrimArray RealWorld Word8)+  , naArrTree :: !(MutablePrimArray RealWorld Int)+  , naArrTextStore :: !(MutableArray RealWorld Text)+  , naArrOptionsStore :: !(MutableArray RealWorld [Text])+  , naArrFontColor :: !(MutablePrimArray RealWorld Int)+  , naArrScope :: !(MutablePrimArray RealWorld Int)+  -- ^ The paint scope each node was added under: a theme index shifted left+  -- one bit, and the disabled flag in bit 0. See+  -- 'NanoUI.Context.Types.ThemeScopes'.+  }++data NodeArena = NodeArena+  { naCount :: IORef Int+  , naCapacity :: IORef Int+  , naArrays :: IORef NodeArenaArrays+  , naArraysSnap :: IORef (Maybe NodeArenaArrays)+  , naScratch :: IORef FlexScratch+  -- Per-depth copies of the axis scratch while the position pass recurses.+  -- Children reuse the working scratch, so a container's child list must be+  -- snapshotted at its own depth to survive recursive positioning.+  , naSnapCap :: IORef Int+  , naSnapLevels :: IORef (MutableArray RealWorld (Maybe AxisSnapshot))+  -- Per-frame memos keyed by (node, quantized width): wrapped text sizes and+  -- fit heights. Text and style are fixed per node within a frame, so the+  -- frame tag is all that is needed to invalidate across frames.+  , naFrameTag :: IORef Word32+  , naWrapMemo :: IORef WidthMemo+  , naFitMemo :: IORef WidthMemo+  , naEpoch :: IORef Word32+  , naIndex :: IORef (BasicHashTable WidgetId Word64)+  -- The scope new nodes are stamped with, and a signature of the scoped+  -- nodes added this frame, so a frame that only changes scopes can tell.+  , naScope :: IORef Int+  , naScopeSig :: IORef Word64+  , naTopModal :: IORef Int+  -- ^ Index of the last modal node added this frame, or -1. Node types are+  -- fixed when a node is added and indices only grow until a reset, so this+  -- is the topmost modal without a scan.+  , naFloatingCount :: IORef Int+  -- ^ Floating nodes (windows, modals, popups) added this frame.+  }++-- | Flex solver scratch: child node indices, their measured widths and+-- heights, and the distributed output sizes.+data FlexScratch = FlexScratch+  { fsCap :: !Int+  , fsIdx :: !(MutablePrimArray RealWorld Int)+  , fsW :: !(MutablePrimArray RealWorld Float)+  , fsH :: !(MutablePrimArray RealWorld Float)+  , fsOutW :: !(MutablePrimArray RealWorld Float)+  , fsOutH :: !(MutablePrimArray RealWorld Float)+  }++-- | A per-frame memo of two floats per node keyed by a width. Slots hold+-- @(key, a, b)@ per node; an entry is live only while its tag equals the+-- arena's frame tag.+data WidthMemo = WidthMemo+  { wmTags :: !(MutablePrimArray RealWorld Word32)+  , wmSlots :: !(MutablePrimArray RealWorld Float)+  }++-- | Initial number of per-depth layout snapshot levels. The level array grows+-- on demand (see 'ensureSnapLevelsArr'), so this is not a depth limit.+maxSnapDepth :: Int+maxSnapDepth = 256++-- | One depth level's frozen child indices and distributed main-axis sizes.+data AxisSnapshot = AxisSnapshot+  { asIdx :: !(MutablePrimArray RealWorld Int)+  , asOut :: !(MutablePrimArray RealWorld Float)+  }++initialCapacity :: Int+initialCapacity = 256++-- | Geometry columns: solved rect, the position snapshot taken by+-- 'snapshotLayoutRects', and the clip rect.+geomStride, geomX, geomY, geomW, geomH, geomLayoutX, geomLayoutY :: Int+geomStride = 10+geomX = 0+geomY = 1+geomW = 2+geomH = 3+geomLayoutX = 4+geomLayoutY = 5++geomClipX, geomClipY, geomClipW, geomClipH :: Int+geomClipX = 6+geomClipY = 7+geomClipW = 8+geomClipH = 9++-- | Style columns: sizing values, padding, gap, min/max, grow, and per-node+-- values that are not layout inputs (scroll extent, node value, font size).+styleStride, styleWVal, styleHVal, stylePadL, stylePadR, stylePadT, stylePadB :: Int+styleStride = 16+styleWVal = 0+styleHVal = 1+stylePadL = 2+stylePadR = 3+stylePadT = 4+stylePadB = 5++styleGap, styleMinW, styleMinH, styleMaxW, styleMaxH, styleGrow :: Int+styleGap = 6+styleMinW = 7+styleMinH = 8+styleMaxW = 9+styleMaxH = 10+styleGrow = 11++styleScrollContentW, styleNodeValue, styleGridMinColW, styleFontSize :: Int+styleScrollContentW = 12+styleNodeValue = 13+styleGridMinColW = 14+styleFontSize = 15++-- | Tag columns (enum values as 'Word8'). Column 7 is unused. The scrollbar+-- slot is a solver output: measurement writes it for scroll containers, so+-- the layout cache skips it when comparing inputs and restores it on a hit.+tagStride, tagNodeType, tagDirection, tagWSizing, tagHSizing, tagScrollBarSlot, tagAlignX, tagAlignY :: Int+tagStride = 8 -- a power of two: layoutInputsMatch masks by it+tagNodeType = 0+tagDirection = 1+tagWSizing = 2+tagHSizing = 3+tagScrollBarSlot = 4+tagAlignX = 5+tagAlignY = 6++-- | Tree columns: links, widget id, style index, text index (-1 for no text),+-- and the grid column count (containers only).+treeStride, treeParent, treeFirstChild, treeNextSibling, treeChildCount :: Int+treeStride = 8+treeParent = 0+treeFirstChild = 1+treeNextSibling = 2+treeChildCount = 3++treeWidgetId, treeStyleIdx, treeTextIdx, treeGridCols :: Int+treeWidgetId = 4+treeStyleIdx = 5+treeTextIdx = 6+treeGridCols = 7++{-# INLINE readGeom #-}+readGeom :: NodeArenaArrays -> NodeIdx -> Int -> IO Float+readGeom a idx col = readPrimArray (naArrGeom a) (idx * geomStride + col)++{-# INLINE writeGeom #-}+writeGeom :: NodeArenaArrays -> NodeIdx -> Int -> Float -> IO ()+writeGeom a idx col = writePrimArray (naArrGeom a) (idx * geomStride + col)++{-# INLINE readStyle #-}+readStyle :: NodeArenaArrays -> NodeIdx -> Int -> IO Float+readStyle a idx col = readPrimArray (naArrStyle a) (idx * styleStride + col)++{-# INLINE writeStyle #-}+writeStyle :: NodeArenaArrays -> NodeIdx -> Int -> Float -> IO ()+writeStyle a idx col = writePrimArray (naArrStyle a) (idx * styleStride + col)++{-# INLINE readTagEnum #-}+readTagEnum :: Enum e => NodeArenaArrays -> NodeIdx -> Int -> IO e+readTagEnum a idx col = do+  t <- readPrimArray (naArrTags a) (idx * tagStride + col)+  pure $! toEnum (fromIntegral t)++{-# INLINE writeTagEnum #-}+writeTagEnum :: Enum e => NodeArenaArrays -> NodeIdx -> Int -> e -> IO ()+writeTagEnum a idx col v = writePrimArray (naArrTags a) (idx * tagStride + col) (fromIntegral (fromEnum v))++{-# INLINE readTree #-}+readTree :: NodeArenaArrays -> NodeIdx -> Int -> IO Int+readTree a idx col = readPrimArray (naArrTree a) (idx * treeStride + col)++{-# INLINE writeTree #-}+writeTree :: NodeArenaArrays -> NodeIdx -> Int -> Int -> IO ()+writeTree a idx col = writePrimArray (naArrTree a) (idx * treeStride + col)++newNodeArenaArrays :: Int -> IO NodeArenaArrays+newNodeArenaArrays cap = do+  naArrGeom <- newPrimArray (cap * geomStride)+  naArrStyle <- newPrimArray (cap * styleStride)+  naArrTags <- newPrimArray (cap * tagStride)+  naArrTree <- newPrimArray (cap * treeStride)+  naArrTextStore <- newArray cap T.empty+  naArrOptionsStore <- newArray cap []+  naArrFontColor <- newPrimArray cap+  naArrScope <- newPrimArray cap+  pure NodeArenaArrays {..}++newFlexScratch :: Int -> IO FlexScratch+newFlexScratch fsCap = do+  fsIdx <- newPrimArray fsCap+  fsW <- newPrimArray fsCap+  fsH <- newPrimArray fsCap+  fsOutW <- newPrimArray fsCap+  fsOutH <- newPrimArray fsCap+  pure FlexScratch {..}++-- | Memo slots per node: key and two values.+memoStride :: Int+memoStride = 3++-- Tags start zeroed: frame tags are never 0, so fresh entries always miss.+newWidthMemo :: Int -> IO WidthMemo+newWidthMemo cap = do+  wmTags <- newPrimArray cap+  setPrimArray wmTags 0 cap 0+  wmSlots <- newPrimArray (cap * memoStride)+  pure WidthMemo {..}++newNodeArena :: IO NodeArena+newNodeArena = do+  let cap = initialCapacity+      scratchCap = 64+  naCount <- newIORef 0+  naCapacity <- newIORef cap+  naArrays <- newIORef =<< newNodeArenaArrays cap+  naArraysSnap <- newIORef Nothing+  naScratch <- newIORef =<< newFlexScratch scratchCap+  naSnapCap <- newIORef scratchCap+  naSnapLevels <- newIORef =<< newArray maxSnapDepth Nothing+  naFrameTag <- newIORef 1+  naWrapMemo <- newIORef =<< newWidthMemo cap+  naFitMemo <- newIORef =<< newWidthMemo cap+  naEpoch <- newIORef 1+  naIndex <- newIORef =<< HT.new+  naScope <- newIORef 0+  naScopeSig <- newIORef 0+  naTopModal <- newIORef (-1)+  naFloatingCount <- newIORef 0+  pure NodeArena {..}++resetNodeArena :: NodeArena -> IO ()+resetNodeArena na = do+  writeIORef (naCount na) 0+  writeIORef (naScope na) 0+  writeIORef (naScopeSig na) 0+  writeIORef (naTopModal na) (-1)+  writeIORef (naFloatingCount na) 0+  !ft <- readIORef (naFrameTag na)+  writeIORef (naFrameTag na) (if ft == maxBound then 1 else ft + 1)+  !ep <- readIORef (naEpoch na)+  let !ep' = ep + 1+  if ep' == 0 || (ep' .&. 0x7F == 0)+    then do+      let !nextEp = if ep' == 0 then 1 else ep'+      writeIORef (naEpoch na) nextEp+      writeIORef (naIndex na) =<< HT.new+    else writeIORef (naEpoch na) ep'++-- | The topmost (last added) modal node, if any.+{-# INLINE topModalNode #-}+topModalNode :: NodeArena -> IO (Maybe NodeIdx)+topModalNode na = do+  i <- readIORef (naTopModal na)+  pure (if i >= 0 then Just i else Nothing)++{-# INLINE floatingNodeCount #-}+floatingNodeCount :: NodeArena -> IO Int+floatingNodeCount na = readIORef (naFloatingCount na)++{-# INLINE arenaCount #-}+arenaCount :: NodeArena -> IO Int+arenaCount na = readIORef (naCount na)++{-# INLINE arenaArrays #-}+arenaArrays :: NodeArena -> IO NodeArenaArrays+arenaArrays na = do+  m <- readIORef (naArraysSnap na)+  case m of+    Just a -> pure a+    Nothing -> readIORef (naArrays na)++-- | Pin arena column arrays for a layout pass so field reads skip naArrays IORef.+withArenaArraysSnap :: NodeArena -> IO a -> IO a+withArenaArraysSnap na act =+  bracket_+    (readIORef (naArrays na) >>= writeIORef (naArraysSnap na) . Just)+    (writeIORef (naArraysSnap na) Nothing)+    act++{-# NOINLINE ensureCapacity #-}+ensureCapacity :: NodeArena -> Int -> IO ()+ensureCapacity na needed = do+  cap <- readIORef (naCapacity na)+  if needed < cap+    then pure ()+    else do+      let newCap = cap * 2+      newA <- readIORef (naArrays na) >>= growNodeArenaArrays cap newCap+      growWidthMemo (naWrapMemo na) cap newCap+      growWidthMemo (naFitMemo na) cap newCap+      writeIORef (naArrays na) newA+      m <- readIORef (naArraysSnap na)+      case m of+        Just{} -> writeIORef (naArraysSnap na) (Just newA)+        Nothing -> pure ()+      writeIORef (naCapacity na) newCap++-- | Copy of @a@ with room for @newCap@ nodes; new slots are zero or empty.+growNodeArenaArrays :: Int -> Int -> NodeArenaArrays -> IO NodeArenaArrays+growNodeArenaArrays cap newCap a = do+  naArrGeom <- growPrimArrayCopy (naArrGeom a) (cap * geomStride) (newCap * geomStride) 0+  naArrStyle <- growPrimArrayCopy (naArrStyle a) (cap * styleStride) (newCap * styleStride) 0+  naArrTags <- growPrimArrayCopy (naArrTags a) (cap * tagStride) (newCap * tagStride) 0+  naArrTree <- growPrimArrayCopy (naArrTree a) (cap * treeStride) (newCap * treeStride) 0+  naArrTextStore <- growBoxedStoreCopy T.empty (naArrTextStore a) cap newCap+  naArrOptionsStore <- growBoxedStoreCopy [] (naArrOptionsStore a) cap newCap+  naArrFontColor <- growPrimArrayCopy (naArrFontColor a) cap newCap 0+  naArrScope <- growPrimArrayCopy (naArrScope a) cap newCap 0+  pure NodeArenaArrays {..}++{-# NOINLINE growPrimArrayCopy #-}+growPrimArrayCopy :: Prim a => MutablePrimArray RealWorld a -> Int -> Int -> a -> IO (MutablePrimArray RealWorld a)+growPrimArrayCopy oldArr cap newCap defVal = do+  newArr <- resizeMutablePrimArray oldArr newCap+  setPrimArray newArr cap (newCap - cap) defVal+  pure newArr++growWidthMemo :: IORef WidthMemo -> Int -> Int -> IO ()+growWidthMemo ref cap newCap = do+  WidthMemo tags slots <- readIORef ref+  wmTags <- growPrimArrayCopy tags cap newCap 0+  wmSlots <- growPrimArrayCopy slots (cap * memoStride) (newCap * memoStride) 0+  writeIORef ref WidthMemo {..}++{-# NOINLINE growBoxedStoreCopy #-}+growBoxedStoreCopy :: a -> MutableArray RealWorld a -> Int -> Int -> IO (MutableArray RealWorld a)+growBoxedStoreCopy emptyVal arr oldCap newCap = do+  newArr <- newArray newCap emptyVal+  copyMutableArray newArr 0 arr 0 oldCap+  pure newArr++{-# INLINE sizingTag #-}+sizingTag :: Sizing -> (SizingTag, Float)+sizingTag (Fixed v) = (SizingFixed, v)+sizingTag Fit = (SizingFit, 0)+sizingTag (Grow g) = (SizingGrow, g)+sizingTag (Shrink s) = (SizingShrink, s)+sizingTag (Percent p) = (SizingPercent, p)++-- Empty stack attaches to node 0 so walks from the page root still reach+-- windows/modals/popups built as UI siblings.+rootAttachParent :: NodeArena -> Int -> IO Int+rootAttachParent na parent+  | parent >= 0 = pure parent+  | otherwise = do+      n <- arenaCount na+      pure (if n > 0 then 0 else -1)++{-# INLINE addNode #-}+addNode ::+  NodeArena ->+  NodeType ->+  Int ->+  Direction ->+  Sizing ->+  Sizing ->+  Padding ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  AlignX ->+  AlignY ->+  IO NodeIdx+addNode na nt parent dir wSiz hSiz pad gap minW minH maxW maxH grow ax ay = do+  idx <- readIORef (naCount na)+  ensureCapacity na (idx + 1)+  let (wTag, wVal) = sizingTag wSiz+      (hTag, hVal) = sizingTag hSiz+  a <- arenaArrays na++  setPrimArray (naArrGeom a) (idx * geomStride) geomStride 0++  writeStyle a idx styleWVal wVal+  writeStyle a idx styleHVal hVal+  writeStyle a idx stylePadL (padL pad)+  writeStyle a idx stylePadR (padR pad)+  writeStyle a idx stylePadT (padT pad)+  writeStyle a idx stylePadB (padB pad)+  writeStyle a idx styleGap gap+  writeStyle a idx styleMinW minW+  writeStyle a idx styleMinH minH+  writeStyle a idx styleMaxW maxW+  writeStyle a idx styleMaxH maxH+  writeStyle a idx styleGrow grow+  setPrimArray (naArrStyle a) (idx * styleStride + styleScrollContentW) (styleStride - styleScrollContentW) 0++  setPrimArray (naArrTags a) (idx * tagStride) tagStride 0+  writeTagEnum a idx tagNodeType nt+  writeTagEnum a idx tagDirection $ case dir of+    Row -> DirRow+    Column -> DirColumn+  writeTagEnum a idx tagWSizing wTag+  writeTagEnum a idx tagHSizing hTag+  writeTagEnum a idx tagAlignX ax+  writeTagEnum a idx tagAlignY ay++  setPrimArray (naArrTree a) (idx * treeStride) treeStride 0+  writeTree a idx treeParent parent+  writeTree a idx treeFirstChild (-1)+  writeTree a idx treeNextSibling (-1)+  writeTree a idx treeTextIdx (-1)+  writePrimArray (naArrFontColor a) idx 0+  scope <- readIORef (naScope na)+  writePrimArray (naArrScope a) idx scope+  when (scope /= 0) $ do+    sig <- readIORef (naScopeSig na)+    writeIORef (naScopeSig na) $! (sig * 0x100000001b3) `xor` (fromIntegral idx `shiftL` 32 .|. fromIntegral scope)+  writeArray (naArrOptionsStore a) idx []++  when (parent >= 0) $ do+    fc <- readTree a parent treeFirstChild+    writeTree a idx treeNextSibling fc+    writeTree a parent treeFirstChild idx+    cc <- readTree a parent treeChildCount+    writeTree a parent treeChildCount (cc + 1)+  when (isFloatingNode nt) $ do+    when (nt == NodeModal) $ writeIORef (naTopModal na) idx+    fc <- readIORef (naFloatingCount na)+    writeIORef (naFloatingCount na) (fc + 1)+  writeIORef (naCount na) (idx + 1)+  pure idx++addNodeFromLayout :: NodeArena -> NodeType -> Int -> Layout -> IO NodeIdx+addNodeFromLayout na nt parent l = do+  idx <-+    addNode+      na+      nt+      parent+      (layoutDirection l)+      (layoutWidth l)+      (layoutHeight l)+      (layoutPadding l)+      (layoutGap l)+      (layoutMinW l)+      (layoutMinH l)+      (layoutMaxW l)+      (layoutMaxH l)+      0+      (layoutAlignX l)+      (layoutAlignY l)+  setGridCols na idx (layoutGridCols l)+  setGridMinColW na idx (layoutGridMinColW l)+  setNodeFontSize na idx (layoutFontSize l)+  setNodeFontColor na idx (layoutFontColor l)+  pure idx++{-# INLINE setNodeText #-}+setNodeText :: NodeArena -> NodeIdx -> Text -> IO ()+setNodeText na idx txt = do+  a <- arenaArrays na+  writeArray (naArrTextStore a) idx txt+  writeTree a idx treeTextIdx idx++{-# INLINE getParent #-}+getParent :: NodeArena -> NodeIdx -> IO NodeIdx+getParent na idx = arenaArrays na >>= \a -> readTree a idx treeParent++{-# INLINE getFirstChild #-}+getFirstChild :: NodeArena -> NodeIdx -> IO NodeIdx+getFirstChild na idx = arenaArrays na >>= \a -> readTree a idx treeFirstChild++{-# INLINE getNextSibling #-}+getNextSibling :: NodeArena -> NodeIdx -> IO NodeIdx+getNextSibling na idx = arenaArrays na >>= \a -> readTree a idx treeNextSibling++{-# INLINE getChildCount #-}+getChildCount :: NodeArena -> NodeIdx -> IO Int+getChildCount na idx = arenaArrays na >>= \a -> readTree a idx treeChildCount++{-# INLINE getNodeType #-}+getNodeType :: NodeArena -> NodeIdx -> IO NodeType+getNodeType na idx = arenaArrays na >>= \a -> readTagEnum a idx tagNodeType++{-# INLINE getDirection #-}+getDirection :: NodeArena -> NodeIdx -> IO DirTag+getDirection na idx = arenaArrays na >>= \a -> readTagEnum a idx tagDirection++{-# INLINE getGridCols #-}+getGridCols :: NodeArena -> NodeIdx -> IO Int+getGridCols na idx = arenaArrays na >>= \a -> readTree a idx treeGridCols++{-# INLINE setGridCols #-}+setGridCols :: NodeArena -> NodeIdx -> Int -> IO ()+setGridCols na idx c = arenaArrays na >>= \a -> writeTree a idx treeGridCols c++{-# INLINE getWidthSizing #-}+getWidthSizing :: NodeArena -> NodeIdx -> IO (SizingTag, Float)+getWidthSizing na idx = arenaArrays na >>= \a -> (,) <$> readTagEnum a idx tagWSizing <*> readStyle a idx styleWVal++{-# INLINE getHeightSizing #-}+getHeightSizing :: NodeArena -> NodeIdx -> IO (SizingTag, Float)+getHeightSizing na idx = arenaArrays na >>= \a -> (,) <$> readTagEnum a idx tagHSizing <*> readStyle a idx styleHVal++{-# INLINE getPadding #-}+getPadding :: NodeArena -> NodeIdx -> IO Padding+getPadding na idx = do+  a <- arenaArrays na+  Padding <$> readStyle a idx stylePadL <*> readStyle a idx stylePadR <*> readStyle a idx stylePadT <*> readStyle a idx stylePadB++{-# INLINE getGap #-}+getGap :: NodeArena -> NodeIdx -> IO Float+getGap na idx = arenaArrays na >>= \a -> readStyle a idx styleGap++{-# INLINE getMinMax #-}+getMinMax :: NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)+getMinMax na idx = do+  a <- arenaArrays na+  (,,,) <$> readStyle a idx styleMinW <*> readStyle a idx styleMinH <*> readStyle a idx styleMaxW <*> readStyle a idx styleMaxH++{-# INLINE getScrollContentW #-}+getScrollContentW :: NodeArena -> NodeIdx -> IO Float+getScrollContentW na idx = arenaArrays na >>= \a -> readStyle a idx styleScrollContentW++{-# INLINE setScrollContentW #-}+setScrollContentW :: NodeArena -> NodeIdx -> Float -> IO ()+setScrollContentW na idx v = arenaArrays na >>= \a -> writeStyle a idx styleScrollContentW v++{-# INLINE getGridMinColW #-}+getGridMinColW :: NodeArena -> NodeIdx -> IO Float+getGridMinColW na idx = arenaArrays na >>= \a -> readStyle a idx styleGridMinColW++{-# INLINE setGridMinColW #-}+setGridMinColW :: NodeArena -> NodeIdx -> Float -> IO ()+setGridMinColW na idx v = arenaArrays na >>= \a -> writeStyle a idx styleGridMinColW v++{-# INLINE parentIsRow #-}+parentIsRow :: NodeArena -> NodeIdx -> IO Bool+parentIsRow na idx = do+  p <- getParent na idx+  if p < 0+    then pure False+    else do+      dir <- getDirection na p+      pure (dir == DirRow)++{-# INLINE getAlignX #-}+getAlignX :: NodeArena -> NodeIdx -> IO AlignX+getAlignX na idx = arenaArrays na >>= \a -> readTagEnum a idx tagAlignX++{-# INLINE getAlignY #-}+getAlignY :: NodeArena -> NodeIdx -> IO AlignY+getAlignY na idx = arenaArrays na >>= \a -> readTagEnum a idx tagAlignY++{-# INLINE getRect #-}+getRect :: NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)+getRect na idx = do+  a <- arenaArrays na+  (,,,) <$> readGeom a idx geomX <*> readGeom a idx geomY <*> readGeom a idx geomW <*> readGeom a idx geomH++{-# INLINE setRect #-}+setRect :: NodeArena -> NodeIdx -> Float -> Float -> Float -> Float -> IO ()+setRect na idx x y w h = do+  a <- arenaArrays na+  writeGeom a idx geomX x+  writeGeom a idx geomY y+  writeGeom a idx geomW w+  writeGeom a idx geomH h++{-# INLINE getLayoutRect #-}+getLayoutRect :: NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)+getLayoutRect na idx = do+  a <- arenaArrays na+  (,,,) <$> readGeom a idx geomLayoutX <*> readGeom a idx geomLayoutY <*> readGeom a idx geomW <*> readGeom a idx geomH++{-# INLINE getClipRect #-}+getClipRect :: NodeArena -> NodeIdx -> IO (Maybe Rect)+getClipRect na idx = do+  a <- arenaArrays na+  x <- readGeom a idx geomClipX+  y <- readGeom a idx geomClipY+  w <- readGeom a idx geomClipW+  h <- readGeom a idx geomClipH+  let r = Rect x y w h+  pure (if w > 0 && h > 0 then Just r else Nothing)++{-# INLINE setClipRect #-}+setClipRect :: NodeArena -> NodeIdx -> Rect -> IO ()+setClipRect na idx (Rect x y w h) = do+  a <- arenaArrays na+  writeGeom a idx geomClipX x+  writeGeom a idx geomClipY y+  writeGeom a idx geomClipW w+  writeGeom a idx geomClipH h++{-# INLINE snapshotLayoutRects #-}+snapshotLayoutRects :: NodeArena -> IO ()+snapshotLayoutRects na = do+  a <- arenaArrays na+  forNodes_ na $ \i -> do+    readGeom a i geomX >>= writeGeom a i geomLayoutX+    readGeom a i geomY >>= writeGeom a i geomLayoutY++-- | Cached layout signature and solved geometry for whole-layout reuse. The+-- backing arrays are reused; only cache misses capture a new solved frame.+-- The font colour and scope columns are paint state and stay unused.+data LayoutCache = LayoutCache+  { lcCap :: !Int+  , lcCount :: !Int+  , lcArrays :: !NodeArenaArrays+  }++newLayoutCache :: Int -> IO LayoutCache+newLayoutCache cap0 = do+  let !cap = max 16 cap0+  LayoutCache cap 0 <$> newNodeArenaArrays cap++-- | Snapshot the current (post-solve) arena form, constraints and rects.+captureLayoutCache :: NodeArena -> LayoutCache -> IO LayoutCache+captureLayoutCache na lc0 = do+  n <- arenaCount na+  let !oldCap = lcCap lc0+      !newCap = max n (oldCap * 2)+  lc <-+    if n <= oldCap+      then pure lc0+      else LayoutCache newCap (lcCount lc0) <$> growNodeArenaArrays oldCap newCap (lcArrays lc0)+  a <- arenaArrays na+  let c = lcArrays lc+  copyMutablePrimArray (naArrGeom c) 0 (naArrGeom a) 0 (n * geomStride)+  copyMutablePrimArray (naArrStyle c) 0 (naArrStyle a) 0 (n * styleStride)+  copyMutablePrimArray (naArrTags c) 0 (naArrTags a) 0 (n * tagStride)+  copyMutablePrimArray (naArrTree c) 0 (naArrTree a) 0 (n * treeStride)+  copyMutableArray (naArrTextStore c) 0 (naArrTextStore a) 0 n+  copyMutableArray (naArrOptionsStore c) 0 (naArrOptionsStore a) 0 n+  pure lc {lcCount = n}++-- | Floating placement depends on state outside the arena descriptor. Custom+-- measurement is checked separately by Frame, which owns its registration.+layoutCacheEligible :: NodeArena -> IO Bool+layoutCacheEligible na = do+  n <- arenaCount na+  a <- arenaArrays na+  if n <= 0+    then pure False+    else allRangeM 0 n $ \i -> not . isFloatingNode <$> readTagEnum a i tagNodeType++-- | Compare layout inputs, stopping at the first mismatch. Node values are+-- paint state except on scroll containers, where they are solver outputs.+-- Neither belongs in the layout-input signature.+layoutInputsMatch :: NodeArena -> LayoutCache -> IO Bool+layoutInputsMatch na lc = do+  n <- arenaCount na+  if n <= 0 || n /= lcCount lc+    then pure False+    else do+      -- The cache only holds eligible layouts, and matching node types+      -- keep the current one eligible too.+      a <- arenaArrays na+      let c = lcArrays lc+      andThen (styleMatch (naArrStyle a) (naArrStyle c) n) $+        andThen (allRangeM 0 (n * tagStride) (\k -> if k .&. (tagStride - 1) == tagScrollBarSlot then pure True else primEqAt (naArrTags a) (naArrTags c) k)) $+          andThen (treeMatch a (naArrTree c) n) $+            andThen (allRangeM 0 n (boxedEqAt (naArrTextStore a) (naArrTextStore c))) $+              allRangeM 0 n (boxedEqAt (naArrOptionsStore a) (naArrOptionsStore c))++{-# INLINE andThen #-}+andThen :: IO Bool -> IO Bool -> IO Bool+andThen check next = do+  ok <- check+  if ok then next else pure False++-- | Whether @p@ holds at every index in @[lo, hi)@, stopping at the first miss.+{-# INLINE allRangeM #-}+allRangeM :: Int -> Int -> (Int -> IO Bool) -> IO Bool+allRangeM lo hi p = go lo+  where+    go !i+      | i >= hi = pure True+      | otherwise = do+          ok <- p i+          if ok then go (i + 1) else pure False++{-# INLINE primEqAt #-}+primEqAt :: (Prim a, Eq a) => MutablePrimArray RealWorld a -> MutablePrimArray RealWorld a -> Int -> IO Bool+primEqAt x y i = (==) <$> readPrimArray x i <*> readPrimArray y i++{-# INLINE boxedEqAt #-}+boxedEqAt :: Eq a => MutableArray RealWorld a -> MutableArray RealWorld a -> Int -> IO Bool+boxedEqAt x y i = (==) <$> readArray x i <*> readArray y i++-- The scroll-extent and node-value columns hold solver outputs or paint-only+-- values, so they are skipped.+styleMatch :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Int -> IO Bool+styleMatch x y n =+  allRangeM 0 n $ \i ->+    let !base = i * styleStride+     in andThen (allRangeM base (base + styleScrollContentW) (primEqAt x y)) $+          allRangeM (base + styleGridMinColW) (base + styleStride) (primEqAt x y)++-- Box/image/drawing style IDs are paint data; their intrinsic dimensions come+-- from sizing constraints. The grid column count only matters to containers.+treeMatch :: NodeArenaArrays -> MutablePrimArray RealWorld Int -> Int -> IO Bool+treeMatch a cached n =+  allRangeM 0 n $ \i -> do+    nt <- readTagEnum a i tagNodeType+    let paintStyle = nt == NodeBox || nt == NodeImage || nt == NodeDrawing+        !base = i * treeStride+    allRangeM 0 treeStride $ \j ->+      if (j == treeStyleIdx && paintStyle) || (j == treeGridCols && not (isContainerNode nt))+        then pure True+        else (==) <$> readTree a i j <*> readPrimArray cached (base + j)++-- | Restore only solver outputs. Rebuilt paint values/colors must survive a+-- cache hit; copying the entire cached style array would revert them.+restoreLayoutCache :: NodeArena -> LayoutCache -> IO ()+restoreLayoutCache na lc = do+  a <- arenaArrays na+  let !n = lcCount lc+      c = lcArrays lc+  copyMutablePrimArray (naArrGeom a) 0 (naArrGeom c) 0 (n * geomStride)+  let go !i+        | i >= n = pure ()+        | otherwise = do+            nt <- readTagEnum a i tagNodeType+            -- Scroll content width, node value (the content height) and+            -- scrollbar slot.+            when (isScrollNode nt) $ do+              let !off = i * styleStride + styleScrollContentW+                  !slotOff = i * tagStride + tagScrollBarSlot+              copyMutablePrimArray (naArrStyle a) off (naArrStyle c) off 2+              readPrimArray (naArrTags c) slotOff >>= writePrimArray (naArrTags a) slotOff+            go (i + 1)+  go 0++{-# INLINE getText #-}+getText :: NodeArena -> NodeIdx -> IO Text+getText na idx = do+  a <- arenaArrays na+  ti <- readTree a idx treeTextIdx+  if ti < 0+    then pure T.empty+    else readArray (naArrTextStore a) ti++{-# INLINE getOptions #-}+getOptions :: NodeArena -> NodeIdx -> IO [Text]+getOptions na idx = do+  a <- arenaArrays na+  readArray (naArrOptionsStore a) idx++{-# INLINE setOptions #-}+setOptions :: NodeArena -> NodeIdx -> [Text] -> IO ()+setOptions na idx opts = do+  a <- arenaArrays na+  writeArray (naArrOptionsStore a) idx opts++{-# INLINE getWidgetId #-}+getWidgetId :: NodeArena -> NodeIdx -> IO WidgetId+getWidgetId na idx = arenaArrays na >>= \a -> WidgetId . fromIntegral <$> readTree a idx treeWidgetId++{-# INLINE packEpochNode #-}+packEpochNode :: Word32 -> NodeIdx -> Word64+packEpochNode !epoch !idx = (fromIntegral epoch `shiftL` 32) .|. (fromIntegral idx .&. 0xFFFFFFFF)++{-# INLINE unpackEpochNode #-}+unpackEpochNode :: Word64 -> (Word32, NodeIdx)+unpackEpochNode !w = (fromIntegral (w `shiftR` 32), fromIntegral (w .&. 0xFFFFFFFF))++{-# INLINE setWidgetId #-}+setWidgetId :: NodeArena -> NodeIdx -> WidgetId -> IO ()+setWidgetId na idx wid = do+  a <- arenaArrays na+  let WidgetId w = wid+  writeTree a idx treeWidgetId (fromIntegral w)+  when (hashWidgetId wid /= 0) $ do+    !ep <- readIORef (naEpoch na)+    table <- readIORef (naIndex na)+    HT.insert table wid (packEpochNode ep idx)++{-# INLINE lookupNodeByWidgetId #-}+lookupNodeByWidgetId :: NodeArena -> WidgetId -> IO (Maybe NodeIdx)+lookupNodeByWidgetId na wid+  | hashWidgetId wid == 0 = pure Nothing+  | otherwise = do+      table <- readIORef (naIndex na)+      mVal <- HT.lookup table wid+      case mVal of+        Nothing -> pure Nothing+        Just val -> do+          !ep <- readIORef (naEpoch na)+          let (!entryEp, !idx) = unpackEpochNode val+          pure (if entryEp == ep then Just idx else Nothing)++{-# INLINE lookupNodeByKey #-}+lookupNodeByKey :: NodeArena -> Int -> IO (Maybe NodeIdx)+lookupNodeByKey na key = lookupNodeByWidgetId na (WidgetId (fromIntegral key))++{-# INLINE getNodeValue #-}+getNodeValue :: NodeArena -> NodeIdx -> IO Float+getNodeValue na idx = arenaArrays na >>= \a -> readStyle a idx styleNodeValue++{-# INLINE setNodeValue #-}+setNodeValue :: NodeArena -> NodeIdx -> Float -> IO ()+setNodeValue na idx v = arenaArrays na >>= \a -> writeStyle a idx styleNodeValue v++{-# INLINE getNodeFontSize #-}+getNodeFontSize :: NodeArena -> NodeIdx -> IO Float+getNodeFontSize na idx = arenaArrays na >>= \a -> readStyle a idx styleFontSize++{-# INLINE setNodeFontSize #-}+setNodeFontSize :: NodeArena -> NodeIdx -> Float -> IO ()+setNodeFontSize na idx v = arenaArrays na >>= \a -> writeStyle a idx styleFontSize v++-- | Per-node font color (paint-only, kept out of @naArrTree@+-- where 'treeGridCols' holds the grid column count for containers).+{-# INLINE getNodeFontColor #-}+getNodeFontColor :: NodeArena -> NodeIdx -> IO (Maybe Color)+getNodeFontColor na idx = do+  a <- arenaArrays na+  val <- readPrimArray (naArrFontColor a) idx+  if (val .&. 0x100000000) /= 0+    then pure (Just (Color (fromIntegral (val .&. 0xFFFFFFFF))))+    else pure Nothing++{-# INLINE setNodeFontColor #-}+setNodeFontColor :: NodeArena -> NodeIdx -> Maybe Color -> IO ()+setNodeFontColor na idx mCol = do+  a <- arenaArrays na+  let val = case mCol of+        Nothing -> 0+        Just (Color w) -> 0x100000000 .|. fromIntegral w+  writePrimArray (naArrFontColor a) idx val++{-# INLINE getNodeScope #-}+getNodeScope :: NodeArena -> NodeIdx -> IO Int+getNodeScope na idx = arenaArrays na >>= \a -> readPrimArray (naArrScope a) idx++{-# INLINE getArenaScope #-}+getArenaScope :: NodeArena -> IO Int+getArenaScope na = readIORef (naScope na)++{-# INLINE setArenaScope #-}+setArenaScope :: NodeArena -> Int -> IO ()+setArenaScope na = writeIORef (naScope na)++{-# INLINE getScopeSignature #-}+getScopeSignature :: NodeArena -> IO Word64+getScopeSignature na = readIORef (naScopeSig na)++{-# INLINE getStyleIdx #-}+getStyleIdx :: NodeArena -> NodeIdx -> IO Int+getStyleIdx na idx = arenaArrays na >>= \a -> readTree a idx treeStyleIdx++{-# INLINE setStyleIdx #-}+setStyleIdx :: NodeArena -> NodeIdx -> Int -> IO ()+setStyleIdx na idx v = arenaArrays na >>= \a -> writeTree a idx treeStyleIdx v++-- | Get the snapshot buffers for a recursion depth, grown to hold at least+-- @needed@ entries. Buffers are reused across frames; nothing is allocated in+-- steady state once capacity is warm.+{-# NOINLINE ensureAxisSnapshot #-}+ensureAxisSnapshot :: NodeArena -> Int -> Int -> IO AxisSnapshot+ensureAxisSnapshot na depth needed = do+  arr0 <- readIORef (naSnapLevels na)+  let !d = max 0 depth+  arr <- ensureSnapLevelsArr na arr0 (d + 1)+  cap <- readIORef (naSnapCap na)+  if needed <= cap+    then getLevel arr d cap+    else do+      let !newCap = max needed (cap * 2)+          !levels = sizeofMutableArray arr+      forM_ [0 .. levels - 1] $ \i -> do+        m <- readArray arr i+        case m of+          Nothing -> pure ()+          Just (AxisSnapshot idx out) -> do+            idx' <- growPrimArrayCopy idx cap newCap 0+            out' <- growPrimArrayCopy out cap newCap 0+            writeArray arr i (Just (AxisSnapshot idx' out'))+      writeIORef (naSnapCap na) newCap+      getLevel arr d newCap+  where+    getLevel arr d currentCap = do+      m <- readArray arr d+      case m of+        Just s -> pure s+        Nothing -> do+          asIdx <- newPrimArray currentCap+          asOut <- newPrimArray currentCap+          let s = AxisSnapshot asIdx asOut+          writeArray arr d (Just s)+          pure s++-- | Grow the per-depth snapshot-level array to hold at least @need@ levels,+-- so nesting depth has no fixed limit.+ensureSnapLevelsArr :: NodeArena -> MutableArray RealWorld (Maybe AxisSnapshot) -> Int -> IO (MutableArray RealWorld (Maybe AxisSnapshot))+ensureSnapLevelsArr na arr need = do+  let !sz = sizeofMutableArray arr+  if need <= sz+    then pure arr+    else do+      let !newSz = max need (sz * 2)+      arr' <- newArray newSz Nothing+      copyMutableArray arr' 0 arr 0 sz+      writeIORef (naSnapLevels na) arr'+      pure arr'++-- | Memoize @compute@ for node @idx@ at width @key@ in one of the arena's+-- per-frame memos. Widths within 0.25 px share an entry so near-identical+-- reflows still hit.+{-# INLINE memoizeWidth #-}+memoizeWidth :: NodeArena -> IORef WidthMemo -> NodeIdx -> Float -> IO (Float, Float) -> IO (Float, Float)+memoizeWidth na ref idx key compute = do+  ft <- readIORef (naFrameTag na)+  WidthMemo tags slots <- readIORef ref+  tag <- readPrimArray tags idx+  let !base = idx * memoStride+  hit <-+    if tag /= ft+      then pure False+      else do+        k <- readPrimArray slots base+        pure (abs (k - key) <= 0.25)+  if hit+    then (,) <$> readPrimArray slots (base + 1) <*> readPrimArray slots (base + 2)+    else do+      r@(x, y) <- compute+      WidthMemo tags' slots' <- readIORef ref+      writePrimArray tags' idx ft+      writePrimArray slots' base key+      writePrimArray slots' (base + 1) x+      writePrimArray slots' (base + 2) y+      pure r++-- | The flex scratch, grown to hold at least @needed@ entries.+{-# INLINE ensureScratchCapacity #-}+ensureScratchCapacity :: NodeArena -> Int -> IO FlexScratch+ensureScratchCapacity na needed = do+  s <- readIORef (naScratch na)+  if needed <= fsCap s then pure s else growScratch na s needed++{-# NOINLINE growScratch #-}+growScratch :: NodeArena -> FlexScratch -> Int -> IO FlexScratch+growScratch na s needed = do+  let !cap = fsCap s+      !newCap = max needed (cap * 2)+  fsIdx <- growPrimArrayCopy (fsIdx s) cap newCap (-1)+  fsW <- growPrimArrayCopy (fsW s) cap newCap 0+  fsH <- growPrimArrayCopy (fsH s) cap newCap 0+  fsOutW <- growPrimArrayCopy (fsOutW s) cap newCap 0+  fsOutH <- growPrimArrayCopy (fsOutH s) cap newCap 0+  let s' = FlexScratch {fsCap = newCap, ..}+  writeIORef (naScratch na) s'+  pure s'++{-# INLINE forNodes_ #-}+forNodes_ :: NodeArena -> (NodeIdx -> IO ()) -> IO ()+forNodes_ na f = do+  n <- arenaCount na+  let go !i+        | i >= n = pure ()+        | otherwise = f i >> go (i + 1)+  go 0++{-# INLINE forChildNodes_ #-}+forChildNodes_ :: NodeArena -> NodeIdx -> (NodeIdx -> IO ()) -> IO ()+forChildNodes_ na parentIdx f = do+  fc <- getFirstChild na parentIdx+  let go !ci+        | ci < 0 = pure ()+        | otherwise = do+            f ci+            ns <- getNextSibling na ci+            go ns+  go fc++-- | Fold over a node's children in sibling order, skipping floating+-- (modal, window, popup) children, which are placed outside the flow.+{-# INLINE foldFlowChildrenM #-}+foldFlowChildrenM :: NodeArena -> NodeIdx -> (acc -> NodeIdx -> IO acc) -> acc -> IO acc+foldFlowChildrenM na parentIdx f z = do+  fc <- getFirstChild na parentIdx+  let go !ci !acc+        | ci < 0 = pure acc+        | otherwise = do+            nt <- getNodeType na ci+            ns <- getNextSibling na ci+            if isFloatingNode nt+              then go ns acc+              else f acc ci >>= go ns+  go fc z++{-# INLINE findNodeRevM #-}+findNodeRevM :: NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)+findNodeRevM na p = do+  n <- arenaCount na+  let go !i+        | i < 0 = pure Nothing+        | otherwise = do+            ok <- p i+            if ok then pure (Just i) else go (i - 1)+  go (n - 1)+++{-# INLINE foldNodeRevM #-}+foldNodeRevM :: NodeArena -> (a -> NodeIdx -> IO a) -> a -> IO a+foldNodeRevM na f z = do+  n <- arenaCount na+  let go !i !acc+        | i < 0 = pure acc+        | otherwise = do+            acc' <- f acc i+            go (i - 1) acc'+  go (n - 1) z++-- ---------------------------------------------------------------------------+-- Frame traversal helpers: forward node scans and child searches, shaped like+-- 'forNodes_' and 'findNodeRevM'.+-- ---------------------------------------------------------------------------++-- | First node, in arena order, satisfying the predicate.+{-# INLINE findNodeM #-}+findNodeM :: NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)+findNodeM na p = do+  n <- arenaCount na+  let go !i+        | i >= n = pure Nothing+        | otherwise = do+            ok <- p i+            if ok then pure (Just i) else go (i + 1)+  go 0++-- | Left fold over every node in arena order.+{-# INLINE foldNodesM #-}+foldNodesM :: NodeArena -> (a -> NodeIdx -> IO a) -> a -> IO a+foldNodesM na f z = do+  n <- arenaCount na+  let go !i !acc+        | i >= n = pure acc+        | otherwise = f acc i >>= go (i + 1)+  go 0 z++-- | First direct child of @parentIdx@ satisfying the predicate.+{-# INLINE findChildM #-}+findChildM :: NodeArena -> NodeIdx -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)+findChildM na parentIdx p = do+  fc <- getFirstChild na parentIdx+  let go !ci+        | ci < 0 = pure Nothing+        | otherwise = do+            ok <- p ci+            if ok then pure (Just ci) else getNextSibling na ci >>= go+  go fc
+ lib/NanoUI/Layout/Solve.hs view
@@ -0,0 +1,1743 @@+-- | The layout solver: measures and places the node arena's flow tree, then+-- positions modals, windows and popups.+module NanoUI.Layout.Solve+  ( solveLayout+  , FontResolver+  , placeModals+  , placeWindows+  , placePopups+  , computePopupPosition+  , placeWindowNode+  , scrollBarSlotOf+  , findAncestorMaxW+  ) where++import Control.Monad (foldM, unless, when)+import Data.IORef (readIORef)+import Data.Maybe (fromMaybe)+import Data.Primitive.PrimArray+  ( MutablePrimArray+  , copyMutablePrimArray+  , newPrimArray+  , readPrimArray+  , writePrimArray+  )+import Data.Primitive.Types (Prim)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word (Word8)+import GHC.Exts (RealWorld)+import NanoUI.Font+  ( CustomMeasureFn+  , FontMetrics (..)+  , checkboxBoxSize+  , checkboxLeading+  , treeRowLeading+  , treeItemPadding+  , classifyScrollBar+  , measureTextIO+  , lineWidthIO+  , measureTextWrappedIO+  , tableCellInset+  , ScrollBarSlot (..)+  , widgetPadding+  , buttonPadding+  , menuItemPadX+  , menuOuterPad+  , selectPadding+  , isDefaultNodeFont+  , sliderTrackHeight+  , sliderHandleDiameter+  , sliderHandleSlack+  )+import NanoUI.Layout.Arena+  ( DirTag (..)+  , FlexScratch (..)+  , NodeArena+  , NodeArenaArrays+  , NodeIdx+  , NodeType (..)+  , SizingTag (..)+  , arenaArrays+  , arenaCount+  , withArenaArraysSnap+  , geomX+  , geomY+  , geomW+  , geomH+  , styleWVal+  , styleHVal+  , styleMinW+  , styleMinH+  , styleMaxW+  , styleMaxH+  , stylePadL+  , stylePadR+  , stylePadT+  , stylePadB+  , styleGap+  , styleGridMinColW+  , tagNodeType+  , tagDirection+  , treeStyleIdx+  , treeGridCols+  , tagWSizing+  , tagHSizing+  , tagScrollBarSlot+  , readGeom+  , writeTagEnum+  , writeGeom+  , readStyle+  , readTagEnum+  , readTree+  , treeParent+  , getAlignX+  , getAlignY+  , getChildCount+  , getDirection+  , getFirstChild+  , getGap+  , getGridCols+  , getGridMinColW+  , getHeightSizing+  , getMinMax+  , getNodeType+  , getOptions+  , getParent+  , getStyleIdx+  , getPadding+  , getRect+  , getText+  , getWidgetId+  , getWidthSizing+  , parentIsRow+  , isContainerNode+  , isFloatingNode+  , isScrollNode+  , setRect+  , getNodeValue+  , setNodeValue+  , getNodeFontSize+  , getScrollContentW+  , setScrollContentW+  , ensureScratchCapacity+  , AxisSnapshot (..)+  , ensureAxisSnapshot+  , memoizeWidth+  , forNodes_+  , foldFlowChildrenM+  , naScratch+  , naWrapMemo+  , naFitMemo+  )+import NanoUI.Id (WidgetId)+import NanoUI.Style (AlignX (..), AlignY (..), FontStyle (..), FontVariant (..), FontWeight (..), Padding (..), windowMargin)+import NanoUI.Types (PopupAnchor (..), PopupPlacement (..), Rect (..), V2 (..), clamp, onGrid)+import NanoUI.WidgetText+  ( colorPickerSvH+  , textNodeFontVariant+  , textNodeFontWeight+  , textNodeFontStyle+  , treeDecodeStyle+  , selectDisplayText+  , selectChevronReserve+  , textInputFieldHeight+  , textInputMinWidth+  , textInputSearchMode+  , textInputNumericMode+  , numericStepperW+  , textInputSelectableMode+  , searchFieldReserveW+  , isTableHeaderStyle+  , isMenuItemStyle+  , tableHeaderDisplayText+  )+import NanoUI.Frame.Scroll.Geometry+  ( decodeScrollConfig+  , isScrollStyle2D+  , scrollAxisGutter+  , scrollGutters2D+  , scrollPolicyX+  , scrollPolicyY+  )++type FontResolver = Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Text -> IO (Float, Float))++-- | Per-solve constants threaded through the measure and position passes.+data SolveEnv = SolveEnv+  { seArena :: !NodeArena+  , seArrays :: !NodeArenaArrays+  , seFm :: !FontMetrics+  , seMonoFm :: !FontMetrics+  , seMeasure :: !(Text -> IO (Float, Float))+  , seResolveFont :: !FontResolver+  , seLookupMeasure :: !(WidgetId -> IO (Maybe CustomMeasureFn))+  }++-- | Env for placing floating nodes after the solve: every text node uses the+-- default font, and there is no custom measurement.+floatingEnv :: NodeArena -> FontMetrics -> IO SolveEnv+floatingEnv na fm = do+  a <- arenaArrays na+  let measure = measureTextIO fm+  pure (SolveEnv na a fm fm measure (\_ _ _ _ -> pure (fm, measure)) (const (pure Nothing)))++-- | Strict accumulator for flow-child folds: a child count and two running+-- sums or extents. The strict fields keep the folds unboxed.+data FlowAcc = FlowAcc !Int !Float !Float++-- Keep font selection and single-line/wrapped measurement together so every+-- layout pass uses the same policy. Monospaced text uses its metrics directly;+-- proportional text uses the host's shaping-aware measurement callback.+data TextMeasurer = TextMeasurer+  { tmMetrics :: !FontMetrics+  , tmVariant :: !FontVariant+  , tmHostLine :: Text -> IO (Float, Float)+  }++textNodeMeasurer :: SolveEnv -> NodeIdx -> IO TextMeasurer+textNodeMeasurer SolveEnv {seArena = na, seFm = fm, seMonoFm = monoFm, seMeasure = measure, seResolveFont = resolveFont} idx = do+  si <- getStyleIdx na idx+  size <- getNodeFontSize na idx+  let variant = textNodeFontVariant si+      weight = textNodeFontWeight si+      style = textNodeFontStyle si+  (metrics, measureLine) <-+    if isDefaultNodeFont size weight style variant+      then pure (if variant == FontMono then monoFm else fm, measure)+      else resolveFont size weight style variant+  pure (TextMeasurer metrics variant measureLine)++-- Keep these operations as inline functions rather than allocating two+-- closures for every resolved node, including nodes that never wrap.+{-# INLINE measureFontLine #-}+measureFontLine :: TextMeasurer -> Text -> IO (Float, Float)+measureFontLine TextMeasurer {tmMetrics = metrics, tmVariant = variant, tmHostLine = hostLine} text+  | variant == FontMono = measureTextIO metrics text+  | otherwise = hostLine text++{-# INLINE measureFontWrapped #-}+measureFontWrapped :: TextMeasurer -> Text -> Float -> IO (Float, Float)+measureFontWrapped TextMeasurer {tmMetrics = metrics, tmVariant = variant, tmHostLine = hostLine} text width+  | variant == FontMono = measureTextWrappedIO (lineWidthIO metrics) metrics text width+  | otherwise = measureTextWrappedIO (fmap fst . hostLine) metrics text width++-- | A measured text node: whether it wrapped, its content size, and the line+-- height of its font.+data TextBox = TextBox+  { tbWrapped :: !Bool+  , tbW :: !Float+  , tbH :: !Float+  , tbLineH :: !Float+  }++-- | Measure a text node's content for the width @outerW@. The text wraps at+-- @outerW@ minus its label inset when it has explicit newlines, or when+-- @shouldWrap wrapW lineW@ holds for its single-line width.+measureTextNodeAt :: SolveEnv -> NodeIdx -> Text -> Float -> (Float -> Float -> Bool) -> IO TextBox+measureTextNodeAt env idx txt outerW shouldWrap = do+  measurer@TextMeasurer {tmMetrics = textFm} <- textNodeMeasurer env idx+  (tw0, th0) <- measureFontLine measurer txt+  let wrapW = max 0 outerW+      lineH = fmLineHeight textFm+      na = seArena env+  if T.any (== '\n') txt || shouldWrap wrapW tw0+    then do+      (tw, th) <- memoizeWidth na (naWrapMemo na) idx wrapW (measureFontWrapped measurer txt wrapW)+      pure (TextBox True tw th lineH)+    else pure (TextBox False tw0 th0 lineH)++-- | Wrap policy once a width is assigned: wrap when allowed and the single+-- line overflows a positive wrap width.+{-# INLINE wrapsNarrower #-}+wrapsNarrower :: Bool -> Float -> Float -> Bool+wrapsNarrower allowed wrapW lineW = allowed && wrapW + 0.5 < lineW && wrapW > 0++solveLayout ::+  NodeArena ->+  FontMetrics ->+  FontMetrics ->+  (Text -> IO (Float, Float)) ->+  FontResolver ->+  (WidgetId -> IO (Maybe CustomMeasureFn)) ->+  Float ->+  Float ->+  IO ()+solveLayout na fm monoFm measure resolveFont lookupMeasure rootW rootH =+  withArenaArraysSnap na $ do+    a <- arenaArrays na+    count <- arenaCount na+    when (count > 0) $ do+      let env = SolveEnv na a fm monoFm measure resolveFont lookupMeasure+      measurePass env count+      positionNodeA env 0 0 0 0 rootW rootH+      quantizeResultsA a count (fmSnapScale fm)++quantizeResultsA :: NodeArenaArrays -> Int -> Float -> IO ()+quantizeResultsA a count s+  | s <= 0 = pure ()+  | otherwise = do+      -- A floating node (modal, window, popup) and everything inside it is+      -- laid out by placement after the solve, which sizes the subtree from+      -- these measured sizes. Rounding them here would size a dialog and its+      -- content-sized parts off their content, so the subtree keeps them;+      -- placement overwrites its geometry anyway. A parent always precedes+      -- its children, so one pass marks each node from its parent.+      floating <- newPrimArray count :: IO (MutablePrimArray RealWorld Word8)+      let go i+            | i >= count = pure ()+            | otherwise = do+                nt <- readTagEnum a i tagNodeType+                parent <- readTree a i treeParent+                inFloating <-+                  if isFloatingNode nt+                    then pure True+                    else if parent >= 0 then (/= 0) <$> readPrimArray floating parent else pure False+                writePrimArray floating i (if inFloating then 1 else 0)+                unless inFloating $ do+                  x <- readGeom a i geomX+                  y <- readGeom a i geomY+                  w <- readGeom a i geomW+                  h <- readGeom a i geomH+                  writeGeom a i geomX (onGrid s x)+                  writeGeom a i geomY (onGrid s y)+                  writeGeom a i geomW (max 0 (onGrid s w))+                  writeGeom a i geomH (max 0 (onGrid s h))+                go (i + 1)+      go 0++measurePass :: SolveEnv -> Int -> IO ()+measurePass env count = do+  let go !idx+        | idx < 0 = pure ()+        | otherwise = do+            measureNode env idx+            go (idx - 1)+  go (count - 1)++measureNode :: SolveEnv -> NodeIdx -> IO ()+measureNode env@SolveEnv {seArena = na, seFm = fm} idx = do+  nt <- readTagEnum (seArrays env) idx tagNodeType+  case nt of+    NodeText -> measureTextNode env idx+    NodeSpacer -> measureSpacer na idx+    NodeSeparator -> measureSeparator na idx+    NodeScrollContainer -> measureScrollContainer env idx+    NodeImage -> measureImage na idx+    NodeBox -> measureImage na idx+    NodeDrawing -> do+      wid <- getWidgetId na idx+      mFn <- seLookupMeasure env wid+      case mFn of+        Just fn -> measureCustomNode na fm fn idx+        Nothing -> measureImage na idx+    _+      | isContainerNode nt -> do+          measureContainer env idx+          when (nt == NodeModal) $ setNodeValue na idx 0+      | otherwise -> measureWidget env idx++measureCustomNode ::+  NodeArena ->+  FontMetrics ->+  CustomMeasureFn ->+  NodeIdx ->+  IO ()+measureCustomNode na fm measureFn idx = do+  (minW, minH, maxW, maxH) <- getMinMax na idx+  (wTag, wVal) <- getWidthSizing na idx+  (hTag, hVal) <- getHeightSizing na idx+  let availW = case wTag of SizingFixed -> wVal; _ -> if maxW < 1e8 then maxW else 1e9+      availH = case hTag of SizingFixed -> hVal; _ -> if maxH < 1e8 then maxH else 1e9+      (mw, mh) = measureFn fm (availW, availH)+      w = case wTag of SizingFixed -> wVal; _ -> clamp minW maxW mw+      h = case hTag of SizingFixed -> hVal; _ -> clamp minH maxH mh+  setRect na idx 0 0 w h++findAncestorMaxW :: NodeArena -> NodeIdx -> IO Float+findAncestorMaxW na idx = go idx 0+  where+    go cur !padAccum = do+      p <- getParent na cur+      if p < 0+        then pure 1e9+        else do+          pad <- getPadding na p+          let padAccum' = padAccum + padL pad + padR pad+          (_, _, pMaxW, _) <- getMinMax na p+          (pwTag, pwVal) <- getWidthSizing na p+          if pwTag == SizingFixed+            then pure (max 0 (pwVal - padAccum'))+            else if pMaxW < 1e8+              then pure (max 0 (pMaxW - padAccum'))+              else go p padAccum'++measureTextNode :: SolveEnv -> NodeIdx -> IO ()+measureTextNode env@SolveEnv {seArena = na} idx = do+  (minW, minH, maxW, maxH) <- getMinMax na idx+  (wTag, _) <- getWidthSizing na idx+  (hTag, hVal) <- getHeightSizing na idx+  parentAssigns <- growParent na idx+  txt <- getText na idx+  isRowChild <- parentIsRow na idx+  effMaxW <-+    if maxW < 1e8+      then pure maxW+      else findAncestorMaxW na idx+  let canWrap = not isRowChild && effMaxW < 1e8+  TextBox {tbW = tw, tbH = th, tbLineH = lineH} <-+    measureTextNodeAt env idx txt effMaxW (\_ lineW -> canWrap && effMaxW + 0.5 < lineW)+  let reportedW =+        if wTag == SizingGrow && parentAssigns+          then clamp minW maxW 0+          else clamp minW maxW tw+  setRect na idx 0 0 reportedW $+    case hTag of+      SizingFixed -> clamp minH maxH hVal+      _ -> clamp minH maxH (max lineH th)++-- | Whether a grow-width node's width is assigned from above rather than+-- reported: its parent grows, and the nearest ancestor that does not grow is+-- not a modal. A modal takes its width from what it holds, so a grow label+-- inside one still reports its natural width; otherwise the modal could never+-- widen for it and the label would wrap into more lines than the modal+-- measured. Windows keep their own width and truncate long lines instead.+growParent :: NodeArena -> NodeIdx -> IO Bool+growParent na idx = getParent na idx >>= go True+  where+    go isParent p+      | p < 0 = pure (not isParent)+      | otherwise = do+          (pwTag, _) <- getWidthSizing na p+          if pwTag == SizingGrow+            then getParent na p >>= go False+            else+              if isParent+                then pure False+                else do+                  nt <- getNodeType na p+                  pure (nt /= NodeModal)++measureImage :: NodeArena -> NodeIdx -> IO ()+measureImage na idx = do+  (minW, minH, maxW, maxH) <- getMinMax na idx+  (wTag, wVal) <- getWidthSizing na idx+  (hTag, hVal) <- getHeightSizing na idx+  let w =+        case wTag of+          SizingFixed -> wVal+          _ -> if minW > 0 then minW else 32+      h =+        case hTag of+          SizingFixed -> hVal+          _ -> if minH > 0 then minH else 32+  setRect na idx 0 0 (clamp minW maxW w) (clamp minH maxH h)++measureSpacer :: NodeArena -> NodeIdx -> IO ()+measureSpacer na idx = do+  (wTag, wVal) <- getWidthSizing na idx+  (hTag, hVal) <- getHeightSizing na idx+  -- Non-fixed spacers reserve the default 8px extent.+  let w = if wTag == SizingFixed then wVal else 8+      h = if hTag == SizingFixed then hVal else 8+  setRect na idx 0 0 w h++measureSeparator :: NodeArena -> NodeIdx -> IO ()+measureSeparator na idx = do+  dir <- getDirection na idx+  case dir of+    DirRow -> setRect na idx 0 0 1 20+    DirColumn -> setRect na idx 0 0 20 1++{-# INLINE measureMarkedWidget #-}+measureMarkedWidget ::+  FontMetrics ->+  (Text -> IO (Float, Float)) ->+  Text ->+  Float ->+  IO (Float, Float, Float, Float)+measureMarkedWidget fm measure body leading = do+  (mw, mh) <- measure (if T.null body then " " else body)+  pure (mw, max mh (checkboxBoxSize fm), leading, 0)++measureTextField ::+  FontMetrics ->+  (Text -> IO (Float, Float)) ->+  Text ->+  Bool ->+  IO (Float, Float, Float, Float)+measureTextField fm measure txt multiline = do+  pw <- if multiline || T.null txt then pure 0 else fst <$> measure txt+  let fieldH = if multiline then max 96 (textInputFieldHeight fm * 4) else textInputFieldHeight fm+      contentW = max textInputMinWidth pw+  pure (contentW, fieldH, 0, 0)++-- Caption-less search box: single row tall, icons counted in the width budget.+measureSearchField ::+  FontMetrics ->+  (Text -> IO (Float, Float)) ->+  Text ->+  IO (Float, Float, Float, Float)+measureSearchField fm measure txt = do+  let lbl = if T.null txt then " " else txt+  (lw, _) <- measure lbl+  let contentW = max textInputMinWidth lw + searchFieldReserveW fm+  pure (contentW, textInputFieldHeight fm, 0, 0)++measureWidget :: SolveEnv -> NodeIdx -> IO ()+measureWidget env@SolveEnv {seArena = na, seArrays = a, seFm = fm, seMeasure = measure} idx = do+  nt <- readTagEnum a idx tagNodeType+  txt <- getText na idx+  si <- readTree a idx treeStyleIdx+  minW <- readStyle a idx styleMinW+  minH <- readStyle a idx styleMinH+  maxW <- readStyle a idx styleMaxW+  maxH <- readStyle a idx styleMaxH+  wTag <- readTagEnum a idx tagWSizing+  wVal <- readStyle a idx styleWVal+  hTag <- readTagEnum a idx tagHSizing+  hVal <- readStyle a idx styleHVal+  let (padX, padY) =+        case nt of+          NodeButton+            | isTableHeaderStyle si ->+                (2 * tableCellInset, 0)+            -- Menu rows reserve the same gutter the text-field context menu+            -- paints (outer pad + item pad on each side of the label), so the+            -- generic popup panel sizes identically.+            | isMenuItemStyle si ->+                (2 * (menuOuterPad + menuItemPadX), snd (buttonPadding fm))+            | otherwise -> buttonPadding fm+          NodeSelect -> selectPadding fm+          NodeTree -> treeItemPadding fm+          NodeTextInput+            | textInputSelectableMode si -> (0, 0)+          _+            | nt == NodeColorPicker+                || nt == NodeSlider+                || nt == NodeCheckbox+                || nt == NodeRadio+                || nt == NodeTextInput+                || nt == NodeTextArea ->+                (0, 0)+            | otherwise -> widgetPadding fm+  (tw, th, extraW, extraH) <-+    case nt of+      NodeSlider -> do+        let contentW = 60+            contentH = max sliderHandleDiameter (sliderTrackHeight + 2 * sliderHandleSlack)+        pure (contentW, contentH, 0, 0)+      NodeTree -> do+        let (_, depth, _, _) = treeDecodeStyle si+        measureMarkedWidget fm measure txt (treeRowLeading fm depth)+      NodeSelect -> do+        opts <- getOptions na idx+        let choices = if null opts then [""] else opts+        (mw, mh) <-+          foldM+            (\(!mw, !mh) c -> (\(w, h) -> (max mw w, max mh h)) <$> measure (selectDisplayText txt c))+            (0, 0)+            choices+        pure (mw, mh, selectChevronReserve, 0)+      -- Picker parts carry fixed layouts; the field grows to its square.+      NodeColorPicker -> pure (0, colorPickerSvH, 0, 0)+      NodeTextInput+        | textInputSelectableMode si -> do+            -- Size with the node's own font (paint and span placement resolve+            -- it too); the ambient `measure` is the default font only.+            measurer <- textNodeMeasurer env idx+            (mw, mh) <- measureFontLine measurer (if T.null txt then " " else txt)+            pure (mw, mh, 0, 0)+        -- Numeric field: a short editable box and its stepper.+        | textInputNumericMode si ->+            pure (56, textInputFieldHeight fm, numericStepperW, 0)+        | textInputSearchMode si ->+            measureSearchField fm measure txt+        | otherwise -> measureTextField fm measure txt False+      NodeTextArea -> measureTextField fm measure txt True+      _+        | nt == NodeCheckbox || nt == NodeRadio ->+            measureMarkedWidget fm measure txt (checkboxLeading fm)+        | otherwise -> do+            body <-+              if T.null txt+                then pure " "+                else+                  if isTableHeaderStyle si+                    then pure (tableHeaderDisplayText txt)+                    else pure txt+            (mw, mh) <- measure body+            pure (mw, mh, 0, 0)+  let rawW = tw + padX + extraW+      rawH = th + padY + extraH+      w = case wTag of SizingFixed -> wVal; _ -> clamp minW maxW rawW+      h = case hTag of SizingFixed -> hVal; _ -> clamp minH maxH rawH+  setRect na idx 0 0 w h++measureContainer :: SolveEnv -> NodeIdx -> IO ()+measureContainer env@SolveEnv {seArena = na, seArrays = a} idx = do+  (pad, gap, dir) <- containerFlow a idx+  gCols <- readTree a idx treeGridCols+  minColW <- readStyle a idx styleGridMinColW+  minW <- readStyle a idx styleMinW+  minH <- readStyle a idx styleMinH+  maxW <- readStyle a idx styleMaxW+  maxH <- readStyle a idx styleMaxH+  wTag <- readTagEnum a idx tagWSizing+  wVal <- readStyle a idx styleWVal+  hTag <- readTagEnum a idx tagHSizing+  hVal <- readStyle a idx styleHVal+  nt <- readTagEnum a idx tagNodeType+  let chrome = isChromeColumn nt dir+      padX = padL pad + padR pad+      padY = padT pad + padB pad+      innerMaxW =+        case wTag of+          SizingFixed -> max 0 (wVal - padX)+          _ -> max 0 (maxW - padX)+      innerAvailH =+        case hTag of+          SizingFixed -> max 0 (hVal - padY)+          _ -> max 0 (maxH - padY)+  (contentW, contentH) <-+    if gCols > 0 || minColW > 0+      then measureGridScratch env idx gCols minColW innerMaxW innerAvailH gap+      else if dir == DirColumn && chrome+        then do+          n <- loadChildrenScratch na idx (flowChildSize env False innerMaxW innerAvailH)+          foldChromeColumnScratch na n gap+        else foldChildDimsFromParent na idx dir gap+  let w =+        case wTag of+          SizingFixed -> clamp minW maxW wVal+          _ -> clamp minW maxW (contentW + padX)+      h =+        case hTag of+          SizingFixed -> clamp minH maxH hVal+          _ -> clamp minH maxH (contentH + padY)+  setRect na idx 0 0 w h++measureScrollContainer :: SolveEnv -> NodeIdx -> IO ()+measureScrollContainer SolveEnv {seArena = na, seArrays = a} idx = do+  (pad, gap, dir) <- containerFlow a idx+  let padX = padL pad + padR pad+      padY = padT pad + padB pad+  si <- getStyleIdx na idx+  (minW, minH, maxW, maxH) <- getMinMax na idx+  (wTag, wVal) <- getWidthSizing na idx+  (hTag, hVal) <- getHeightSizing na idx+  (contentW, contentH) <- foldChildDimsFromParent na idx dir gap+  parent <- getParent na idx+  -- A modal's body scrolls like a window's: its bar sits just inside the+  -- panel's edge, out in the panel padding.+  isWin <-+    if parent < 0+      then pure False+      else do+        pnt <- getNodeType na parent+        pure (pnt == NodeWindow || pnt == NodeModal)+  inPanel <- hasPanelAncestor na parent+  let slot = classifyScrollBar isWin (wTag == SizingGrow && hTag == SizingGrow && not inPanel)+  writeTagEnum a idx tagScrollBarSlot slot+  let fullW = contentW + padX+      fullH = contentH + padY+      assignedInnerH =+        case hTag of+          SizingFixed -> max 0 (hVal - padY)+          _ -> contentH+      cfg = decodeScrollConfig si+      fitGutterW+        | wTag == SizingGrow || wTag == SizingFixed = 0+        | isScrollStyle2D si = 0+        | otherwise =+            case dir of+              DirColumn -> scrollAxisGutter (scrollPolicyY cfg) slot (padR pad) contentH assignedInnerH+              DirRow -> 0+      viewportW =+        case wTag of+          SizingFixed -> wVal+          _ -> fullW + fitGutterW+      viewportH =+        case hTag of+          SizingFixed -> hVal+          _ -> fullH+  if isScrollStyle2D si+    then do+      setNodeValue na idx contentH+      setScrollContentW na idx contentW+    else setNodeValue na idx (case dir of DirColumn -> contentH; DirRow -> contentW)+  setRect na idx 0 0 (clamp minW maxW viewportW) (clamp minH maxH viewportH)++foldChildDimsFromParent :: NodeArena -> NodeIdx -> DirTag -> Float -> IO (Float, Float)+foldChildDimsFromParent na idx dir gap = do+  FlowAcc count main cross <- foldFlowChildrenM na idx step (FlowAcc 0 0 0)+  pure+    ( case dir of+        DirRow ->+          ( main + gap * fromIntegral (max 0 (count - 1))+          , if count <= 0 then 0 else cross+          )+        DirColumn ->+          ( if count <= 0 then 0 else main+          , cross + gap * fromIntegral (max 0 (count - 1))+          )+    )+  where+    step (FlowAcc count main cross) ci = do+      (_, _, w, h) <- getRect na ci+      pure $+        case dir of+          DirRow -> FlowAcc (count + 1) (main + w) (max cross h)+          DirColumn -> FlowAcc (count + 1) (max main w) (cross + h)++isChromeColumn :: NodeType -> DirTag -> Bool+isChromeColumn nt dir =+  dir == DirColumn && (nt == NodeWindow || nt == NodeModal)++-- | Gap before child @b@ in a column; chrome columns drop it before separators.+pairColumnGap :: NodeArena -> Bool -> NodeIdx -> Float -> IO Float+pairColumnGap _ False _ gap = pure gap+pairColumnGap na True b gap = do+  ntB <- getNodeType na b+  pure (if ntB == NodeSeparator then 0 else gap)++foldChromeColumnScratch :: NodeArena -> Int -> Float -> IO (Float, Float)+foldChromeColumnScratch na n gap = do+  FlexScratch {fsW = wArr, fsH = hArr} <- readIORef (naScratch na)+  gapSum <- columnGapSumScratch na True n gap+  let go !i !maxW !totalH+        | i >= n = pure (maxW, totalH + gapSum)+        | otherwise = do+            w <- readPrimArray wArr i+            h <- readPrimArray hArr i+            go (i + 1) (max maxW w) (totalH + h)+  go 0 0 0++-- | Grid column count: explicit, else as many @minColW@ columns as fit in a+-- positive @availW@, else one.+{-# INLINE gridColumnCount #-}+gridColumnCount :: Int -> Float -> Float -> Float -> Int+gridColumnCount gCols minColW availW gap+  | gCols > 0 = gCols+  | minColW > 0 && availW > 0 = max 1 (floor ((availW + gap) / (minColW + gap)))+  | otherwise = 1++-- | Height of grid row @r@: its tallest child.+gridRowHeight :: MutablePrimArray RealWorld Float -> Int -> Int -> Int -> IO Float+gridRowHeight hArr n cols r = go 0 0+  where+    go !j !accH+      | j >= cols = pure accH+      | otherwise = do+          let k = r * cols + j+          if k >= n+            then pure accH+            else do+              h <- readPrimArray hArr k+              go (j + 1) (max accH h)++measureGridScratch ::+  SolveEnv ->+  NodeIdx ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO (Float, Float)+measureGridScratch env idx gCols minColW innerMaxW innerAvailH gap = do+  n <- loadChildrenScratch (seArena env) idx (flowChildSize env False innerMaxW innerAvailH)+  if n <= 0+    then pure (0, 0)+    else do+      FlexScratch {fsW = wArr, fsH = hArr} <- readIORef (naScratch (seArena env))+      let cols = gridColumnCount gCols minColW (if innerMaxW < 1e8 then innerMaxW else 0) gap+          numRows = (n + cols - 1) `quot` cols+          calcRows !r !totalH+            | r >= numRows = pure totalH+            | otherwise = do+                rowH <- gridRowHeight hArr n cols r+                calcRows (r + 1) (totalH + rowH)+      totalH <- calcRows 0 0+      let contentH = totalH + gap * fromIntegral (max 0 (numRows - 1))+      contentW <-+        if innerMaxW > 0 && innerMaxW < 1e8+          then pure innerMaxW+          else if minColW > 0+            then pure (fromIntegral cols * minColW + gap * fromIntegral (max 0 (cols - 1)))+            else do+              let getMaxChildW !i !accW+                    | i >= n = pure accW+                    | otherwise = do+                        w <- readPrimArray wArr i+                        getMaxChildW (i + 1) (max accW w)+              maxChildW <- getMaxChildW 0 0+              pure (fromIntegral cols * maxChildW + gap * fromIntegral (max 0 (cols - 1)))+      pure (contentW, contentH)++recomputeFitHeightAtWidth :: SolveEnv -> NodeIdx -> Float -> IO Float+recomputeFitHeightAtWidth env idx availW = do+  let na = seArena env+  (_, h) <- memoizeWidth na (naFitMemo na) idx availW ((,) 0 <$> recomputeFitHeightAtWidthGo env idx availW)+  pure h++recomputeFitHeightAtWidthGo :: SolveEnv -> NodeIdx -> Float -> IO Float+recomputeFitHeightAtWidthGo env@SolveEnv {seArena = na, seFm = fm, seLookupMeasure = lookupMeasure} idx availW = do+  nt <- getNodeType na idx+  (minW, minH, maxW, maxH) <- getMinMax na idx+  (wTag, wVal) <- getWidthSizing na idx+  (hTag, _) <- getHeightSizing na idx+  (_, _, _, oldH) <- getRect na idx+  let effW = case wTag of+        SizingPercent -> availW * wVal / 100+        SizingFixed -> wVal+        _ -> availW+      effW' = clamp minW maxW effW+  case nt of+    NodeText+      | hTag /= SizingFixed -> do+          isRowChild <- parentIsRow na idx+          txt <- getText na idx+          if T.null txt+            then pure (clamp minH maxH 0)+            else do+              TextBox {tbWrapped, tbH, tbLineH} <-+                measureTextNodeAt env idx txt effW' (wrapsNarrower (wTag /= SizingFit && not isRowChild))+              pure (if tbWrapped then clamp minH maxH (max tbLineH tbH) else oldH)+      | otherwise -> pure oldH++    -- A measured drawing, like wrapped text, can be taller when narrower.+    NodeDrawing+      | hTag == SizingFit -> do+          wid <- getWidgetId na idx+          lookupMeasure wid >>= \case+            Just measure -> pure (clamp minH maxH (snd (measure fm (effW', if maxH < 1e8 then maxH else 1e9))))+            Nothing -> pure oldH+      | otherwise -> pure oldH++    _ | (nt == NodeContainer || nt == NodePanel), hTag /= SizingFixed -> do+          dir <- getDirection na idx+          if dir == DirRow+            then pure oldH+            else do+              pad <- getPadding na idx+              gap <- getGap na idx+              let innerW = max 0 (effW' - padL pad - padR pad)+                  step (FlowAcc count contentH _) ci = do+                    (subWTag, subWVal) <- getWidthSizing na ci+                    (_, _, subMaxW, _) <- getMinMax na ci+                    let subW = case subWTag of+                          SizingPercent -> innerW * subWVal / 100+                          SizingFixed -> subWVal+                          _ -> innerW+                        subW' = if subMaxW < 1e8 then min subW subMaxW else subW+                    subH <- recomputeFitHeightAtWidth env ci subW'+                    pure (FlowAcc (count + 1) (contentH + subH) 0)+              FlowAcc count contentH _ <- foldFlowChildrenM na idx step (FlowAcc 0 0 0)+              let totalH =+                    if count <= 0+                      then 0+                      else contentH + gap * fromIntegral (count - 1)+              pure (clamp minH maxH (totalH + padT pad + padB pad))++    _ -> pure oldH++-- | Load a parent's flow children into the flex scratch in child order, with+-- each child's (width, height) from @sizeOf@. Returns the child count.+{-# INLINE loadChildrenScratch #-}+loadChildrenScratch :: NodeArena -> NodeIdx -> (NodeIdx -> IO (Float, Float)) -> IO Int+loadChildrenScratch na parent sizeOf = do+  cc <- getChildCount na parent+  FlexScratch {fsIdx = idxArr, fsW = wArr, fsH = hArr} <- ensureScratchCapacity na cc+  let write !i ci = do+        (w, h) <- sizeOf ci+        writePrimArray idxArr i ci+        writePrimArray wArr i w+        writePrimArray hArr i h+        pure (i + 1)+  n <- foldFlowChildrenM na parent write 0+  reverseScratchTriple idxArr wArr hArr 0 (n - 1)+  pure n++-- | Scratch size of a flow child: its measured box, with percent sizing+-- resolved against the parent's inner box. With @refit@, a fit-height child+-- that the parent narrows (grow or percent width, or wider than @availW@) is+-- re-measured at the assigned width.+flowChildSize :: SolveEnv -> Bool -> Float -> Float -> NodeIdx -> IO (Float, Float)+flowChildSize env refit availW availH ci = do+  let a = seArrays env+  w <- readGeom a ci geomW+  h <- readGeom a ci geomH+  wTag <- readTagEnum a ci tagWSizing+  wVal <- readStyle a ci styleWVal+  hTag <- readTagEnum a ci tagHSizing+  hVal <- readStyle a ci styleHVal+  minW <- readStyle a ci styleMinW+  minH <- readStyle a ci styleMinH+  maxW <- readStyle a ci styleMaxW+  maxH <- readStyle a ci styleMaxH+  let w' =+        case wTag of+          SizingPercent -> clamp minW maxW (availW * wVal / 100)+          _ -> w+  h' <-+    if refit && hTag /= SizingFixed && hTag /= SizingPercent && (wTag == SizingGrow || wTag == SizingPercent || availW < w)+      then recomputeFitHeightAtWidth env ci (if wTag == SizingPercent then w' else availW)+      else pure $+        case hTag of+          SizingPercent -> clamp minH maxH (availH * hVal / 100)+          _ -> h+  pure (w', h')++positionNodeA ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionNodeA env@SolveEnv {seArena = na, seArrays = a, seFm = fm, seLookupMeasure = lookupMeasure} depth idx x y availW availH = do+  minW <- readStyle a idx styleMinW+  minH <- readStyle a idx styleMinH+  maxW <- readStyle a idx styleMaxW+  maxH <- readStyle a idx styleMaxH+  wTag <- readTagEnum a idx tagWSizing+  wVal <- readStyle a idx styleWVal+  hTag <- readTagEnum a idx tagHSizing+  hVal <- readStyle a idx styleHVal+  intrinsicW <- readGeom a idx geomW+  intrinsicH <- readGeom a idx geomH+  nt <- readTagEnum a idx tagNodeType+  let w = clamp minW maxW (resolveSize wTag wVal intrinsicW availW minW maxW)+  isRowChild <- parentIsRow na idx+  h <-+    if nt == NodeText && hTag /= SizingFixed && not isRowChild+      then do+        txt <- getText na idx+        if T.null txt+          then pure (clamp minH maxH 0)+          else do+            TextBox {tbWrapped, tbH, tbLineH} <-+              measureTextNodeAt env idx txt w (wrapsNarrower (wTag /= SizingFit))+            pure . clamp minH maxH $+              if tbWrapped+                then max tbLineH tbH+                else resolveSize hTag hVal intrinsicH availH minH maxH+      else+        if (nt == NodeContainer || nt == NodePanel) && hTag == SizingFit+          then pure (clamp minH maxH (max intrinsicH availH))+          else+            if nt == NodeDrawing && hTag == SizingFit && w /= intrinsicW+              then do+                -- A measured drawing laid out at another width than it was+                -- measured at takes its height at the width it got.+                wid <- getWidgetId na idx+                lookupMeasure wid >>= \case+                  Just measure -> pure (clamp minH maxH (snd (measure fm (w, if maxH < 1e8 then maxH else 1e9))))+                  Nothing -> pure (clamp minH maxH (resolveSize hTag hVal intrinsicH availH minH maxH))+              else pure (clamp minH maxH (resolveSize hTag hVal intrinsicH availH minH maxH))+  setRect na idx x y w h+  when (isContainerNode nt) $ do+    (pad, gap, dir) <- containerFlow a idx+    if isScrollNode nt+      then positionScrollChildren env depth idx dir gap pad x y w h+      else positionChildren env depth idx dir gap pad x y w h+  when (hTag == SizingFit && isContainerNode nt && not (isScrollNode nt)) $+    adjustFitHeight na fm idx minH maxH x y w++-- | A container's resolved padding and gap, and its direction.+{-# INLINE containerFlow #-}+containerFlow :: NodeArenaArrays -> NodeIdx -> IO (Padding, Float, DirTag)+containerFlow a idx = do+  pad <- Padding <$> readStyle a idx stylePadL <*> readStyle a idx stylePadR <*> readStyle a idx stylePadT <*> readStyle a idx stylePadB+  gap <- readStyle a idx styleGap+  dir <- readTagEnum a idx tagDirection+  pure (pad, gap, dir)++adjustFitHeight :: NodeArena -> FontMetrics -> NodeIdx -> Float -> Float -> Float -> Float -> Float -> IO ()+adjustFitHeight na fm idx minH maxH x y w = do+  fc <- getFirstChild na idx+  when (fc >= 0) $ do+    pad <- getPadding na idx+    let step maxB ci = do+          (_, subY, _, subH) <- getRect na ci+          pure (max maxB (subY + subH))+        -- Rounding a child's origin to the nearest device pixel can put its+        -- bottom up to half a pixel below where measurement did. That is not+        -- content outgrowing the measurement: growing for it adds half a+        -- pixel at every nested content-sized level, until a dialog sized to+        -- its content overflows its own scroll viewport. The small epsilon+        -- absorbs float error in the rounding.+        s = fmSnapScale fm+        snapSlack = if s > 0 then 0.5 / s + 1.0e-3 else 0+    maxB <- foldFlowChildrenM na idx step y+    let fitH = clamp minH maxH (maxB + padB pad - y)+    (_, _, _, curH) <- getRect na idx+    when (fitH > curH + snapSlack) $+      setRect na idx x y w fitH++positionScrollChildren ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  DirTag ->+  Float ->+  Padding ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionScrollChildren env@SolveEnv {seArena = na} depth idx dir gap pad px py pw ph = do+  si <- getStyleIdx na idx+  contentSize <- getNodeValue na idx+  slot <- scrollBarSlotOf na idx+  let cx = px + padL pad+      cy = py + padT pad+      innerW = pw - padL pad - padR pad+      innerH = ph - padT pad - padB pad+      cfg = decodeScrollConfig si+  if isScrollStyle2D si+    then do+      contentW <- getScrollContentW na idx+      let (gutterW, gutterH) = scrollGutters2D slot cfg pad contentW contentSize innerW innerH+          viewW = max 0 (innerW - gutterW)+          viewH = max 0 (innerH - gutterH)+          -- Keep measured content. Shrinking to the clip wraps table columns.+          layoutW = max contentW viewW+          layoutH = max contentSize viewH+      -- cx/cy and the layout box are already inside the padding.+      positionChildren env depth idx DirColumn gap (Padding 0 0 0 0) cx cy layoutW layoutH+    else do+      let gutterCol = scrollAxisGutter (scrollPolicyY cfg) slot (padR pad) contentSize innerH+          gutterRow = scrollAxisGutter (scrollPolicyX cfg) slot (padB pad) contentSize innerW+      case dir of+        DirRow -> do+          (wTag, _) <- getWidthSizing na idx+          let rowMain =+                if wTag == SizingGrow+                  then max contentSize (innerW - gutterRow)+                  else contentSize+          positionRowFromParent env depth idx gap cx cy rowMain (innerH - gutterRow)+        DirColumn -> positionColumnScroll env depth idx gap cx cy (innerW - gutterCol) innerH contentSize+  fc <- getFirstChild na idx+  when (fc >= 0) $ do+    let step (FlowAcc count maxB maxR) ci = do+          (subX, subY, subW, subH) <- getRect na ci+          pure (FlowAcc (count + 1) (max maxB (subY + subH)) (max maxR (subX + subW)))+    FlowAcc _ maxB maxR <- foldFlowChildrenM na idx step (FlowAcc 0 cy cx)+    -- Content size is measured from the content origin (px+padL, py+padT) so+    -- it compares against the padded viewport (innerW/innerH) on the same+    -- scale. Measuring from the padding-box origin double-counts the leading+    -- padding and makes a child that exactly fills the viewport look+    -- padX/padY bigger, surfacing a phantom scrollbar on padded scrollers.+    -- The trailing padding is excluded here too (so it cannot+    -- surface a bar by itself); scrollAxisRange adds it back into the+    -- reachable range once an axis genuinely overflows, so scrolling to the+    -- end still reveals it.+    let actualContentH = maxB - py - padT pad+        actualContentW = maxR - px - padL pad+    if isScrollStyle2D si+      then do+        oldH <- getNodeValue na idx+        oldW <- getScrollContentW na idx+        setNodeValue na idx (max oldH actualContentH)+        setScrollContentW na idx (max oldW actualContentW)+      else do+        oldVal <- getNodeValue na idx+        let actual = case dir of DirColumn -> actualContentH; DirRow -> actualContentW+        setNodeValue na idx (max oldVal actual)++-- | Where a scroll container's bar sits, as measurement stored it. Text+-- areas and other nodes read 'ScrollBarList'.+{-# INLINE scrollBarSlotOf #-}+scrollBarSlotOf :: NodeArena -> NodeIdx -> IO ScrollBarSlot+scrollBarSlotOf na idx = arenaArrays na >>= \a -> readTagEnum a idx tagScrollBarSlot++hasPanelAncestor :: NodeArena -> NodeIdx -> IO Bool+hasPanelAncestor na = go+  where+    go p+      | p < 0 = pure False+      | otherwise = do+          nt <- getNodeType na p+          case nt of+            NodePanel -> pure True+            NodeWindow -> pure False+            NodeModal -> pure False+            NodePopup -> pure False+            _ -> getParent na p >>= go++positionColumnScroll ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionColumnScroll env@SolveEnv {seArena = na} depth parent gap cx cy innerW innerH contentSize = do+  n <- loadChildrenScratch (seArena env) parent (flowChildSize env True innerW innerH)+  withAxisSnaps na depth n contentSize (gap * fromIntegral (max 0 (n - 1))) False $ \idxSnap outSnap -> do+    let go !i !curY+          | i >= n = pure ()+          | otherwise = do+              ci <- readPrimArray idxSnap i+              fh <- readPrimArray outSnap i+              nt <- getNodeType na ci+              fx <- columnChildX na ci cx innerW+              let cw = innerW+                  visibleSlice = max 0 (innerH - (curY - cy))+                  nodeH =+                    if isScrollNode nt+                      then min fh visibleSlice+                      else fh+              positionNodeA env (depth + 1) ci fx curY cw nodeH+              (_, _, _, placedH) <- getRect na ci+              go (i + 1) (curY + placedH + gap)+    go 0 cy++-- | Left edge of column child @ci@ in a column of width @cw@ at @cx@. Grow and+-- percent children already take the full width; alignment is for content+-- narrower than the column, not for shifting a full-width box past it.+{-# INLINE columnChildX #-}+columnChildX :: NodeArena -> NodeIdx -> Float -> Float -> IO Float+columnChildX na ci cx cw = do+  (wTag, _) <- getWidthSizing na ci+  if wTag == SizingGrow || wTag == SizingPercent+    then pure cx+    else do+      (_, _, iw, _) <- getRect na ci+      ax <- getAlignX na ci+      pure $! alignX ax cx cw iw++{-# INLINE resolveSize #-}+resolveSize :: SizingTag -> Float -> Float -> Float -> Float -> Float -> Float+resolveSize SizingFixed v _ _ _ _ = v+resolveSize SizingFit _ intrinsic avail minS maxS = clamp minS maxS (min intrinsic avail)+resolveSize SizingShrink _ intrinsic avail minS maxS = clamp minS maxS (min intrinsic avail)+resolveSize SizingGrow _ _ avail _ maxS = min avail maxS+resolveSize SizingPercent _ _ avail _ maxS = min avail maxS++positionChildren ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  DirTag ->+  Float ->+  Padding ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionChildren env@SolveEnv {seArena = na} depth idx dir gap pad px py pw ph = do+  nt <- getNodeType na idx+  gCols <- getGridCols na idx+  minColW <- getGridMinColW na idx+  let chrome = isChromeColumn nt dir+      cx = px + padL pad+      cy = py + padT pad+      cw = pw - padL pad - padR pad+      ch = ph - padT pad - padB pad+  if gCols > 0 || minColW > 0+    then positionGrid env depth idx gCols minColW gap cx cy cw ch+    else case dir of+      DirRow -> positionRowFromParent env depth idx gap cx cy cw ch+      DirColumn -> positionColumnFromParent env depth idx gap chrome px pw cx cy cw ch++childRowCrossSize :: NodeArena -> NodeIdx -> Float -> IO Float+childRowCrossSize na ci availCross = do+  (hTag, hVal) <- getHeightSizing na ci+  (_, _, _, intrinsic) <- getRect na ci+  (_, minH, _, maxH) <- getMinMax na ci+  let resolved = clamp minH maxH (resolveSize hTag hVal intrinsic availCross minH maxH)+  case hTag of+    SizingFixed -> pure (clamp minH maxH hVal)+    SizingGrow -> pure resolved+    SizingPercent -> pure resolved+    _ ->+      -- Fit/Shrink keep the measured box. Do not use the wrap-line+      -- or row slot as availH: that stretches every child when leftover+      -- leaks into scratch `fh`.+      pure (max minH intrinsic)++-- Column leftover must not change Fixed step height.+columnChildHeight :: NodeArena -> NodeIdx -> Float -> IO Float+columnChildHeight na ci scratchH = do+  (hTag, _) <- getHeightSizing na ci+  case hTag of+    SizingFixed -> do+      (_, minH, _, maxH) <- getMinMax na ci+      (_, _, _, ih) <- getRect na ci+      pure (clamp minH maxH ih)+    _ -> do+      (_, minH, _, maxH) <- getMinMax na ci+      pure (clamp minH maxH scratchH)++{-# INLINE withAxisSnaps #-}+withAxisSnaps ::+  NodeArena ->+  Int ->+  Int ->+  Float ->+  Float ->+  Bool ->+  (MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> IO a) ->+  IO a+withAxisSnaps na depth n availMain gapSum horizontal act = do+  distributeScratch na n availMain gapSum horizontal+  FlexScratch {fsIdx = idxArr, fsOutW = outW, fsOutH = outH} <- readIORef (naScratch na)+  let outArr = if horizontal then outW else outH+  AxisSnapshot idxSnap outSnap <- ensureAxisSnapshot na depth n+  copyMutablePrimArray idxSnap 0 idxArr 0 n+  copyMutablePrimArray outSnap 0 outArr 0 n+  act idxSnap outSnap++-- | Like 'withAxisSnaps' but snapshots the unscaled child cross sizes instead+-- of the distributed main-axis result. Grids compute rows from the measured+-- child heights, so freezing them lets the recursion reuse the working scratch.+withGridScratch :: NodeArena -> Int -> Int -> (MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> IO a) -> IO a+withGridScratch na depth n act = do+  FlexScratch {fsIdx = idxArr, fsH = hArr} <- readIORef (naScratch na)+  AxisSnapshot idxSnap crossSnap <- ensureAxisSnapshot na depth n+  copyMutablePrimArray idxSnap 0 idxArr 0 n+  copyMutablePrimArray crossSnap 0 hArr 0 n+  act idxSnap crossSnap++positionRowFromParent ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionRowFromParent env@SolveEnv {seArena = na, seFm = fm} depth parent gap cx cy cw ch = do+  n <- loadChildrenScratch (seArena env) parent (flowChildSize env False cw ch)+  withAxisSnaps na depth n cw (gap * fromIntegral (max 0 (n - 1))) True $ \idxSnap outSnap -> do+    let goRow !i !cur !prev+          | i >= n = pure ()+          | otherwise = do+              ci <- readPrimArray idxSnap i+              fw <- readPrimArray outSnap i+              let x = snappedOrigin (fmSnapScale fm) cur prev+              -- Fit/fixed children keep content height. Only Grow/Percent eat `ch`.+              crossH <- childRowCrossSize na ci ch+              ay <- getAlignY na ci+              let fy = alignY ay cy ch crossH+              positionNodeA env (depth + 1) ci x fy fw crossH+              -- A grow child that its max width stopped short of its share+              -- hands the rest to the siblings after it instead of leaving a+              -- hole.+              placedW <- readGeom (seArrays env) ci geomW+              goRow (i + 1) (cur + min fw placedW + gap) x+    goRow 0 cx (-1 / 0)++-- | Placed origin of the flow child at raw cursor @cur@ when the previous+-- sibling was placed at @prev@ (negative infinity for the first child), on a+-- device grid of scale @s@.+--+-- Flex positions stay exact: the cursor accumulates in raw floats and only the+-- placed origin snaps, never the running sum. Rounding the cumulative cursor+-- re-compounds error every child (1.667 -> 2.0 -> ...) so a shrink row+-- overruns its fixed width. The one-pixel floor past @prev@ keeps two+-- siblings from quantizing to the same origin while resisting that drift.+{-# INLINE snappedOrigin #-}+snappedOrigin :: Float -> Float -> Float -> Float+snappedOrigin s cur prev+  | s > 0 = max (onGrid s cur) (prev + 1 / s)+  | otherwise = cur++positionGrid ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionGrid env@SolveEnv {seArena = na} depth parent gCols minColW gap cx cy cw ch = do+  n <- loadChildrenScratch (seArena env) parent (flowChildSize env False cw ch)+  when (n > 0) $ do+    let cols = gridColumnCount gCols minColW cw gap+        colW = max 0 ((cw - gap * fromIntegral (cols - 1)) / fromIntegral cols)+        numRows = (n + cols - 1) `quot` cols+    -- Freeze child indices and their measured cross sizes before recursing.+    -- Children reuse the working scratch while this grid iterates rows and+    -- columns, so the live arrays would be clobbered by the first child.+    withGridScratch na depth n $ \idxArr hArr ->+      do+        let goRows !r !curY+              | r >= numRows = pure ()+              | otherwise = do+                  rowH <- gridRowHeight hArr n cols r+                  let goCols !j+                        | j >= cols = pure ()+                        | otherwise = do+                            let k = r * cols + j+                            if k >= n+                              then pure ()+                              else do+                                ci <- readPrimArray idxArr k+                                (minW, minH, maxW, maxH) <- getMinMax na ci+                                (wTag, wVal) <- getWidthSizing na ci+                                (hTag, hVal) <- getHeightSizing na ci+                                (_, _, iw, ih) <- getRect na ci+                                let childW = clamp minW maxW (resolveSize wTag wVal iw colW minW maxW)+                                    childH = clamp minH maxH (resolveSize hTag hVal ih rowH minH maxH)+                                    itemX = cx + fromIntegral j * (colW + gap)+                                ax <- getAlignX na ci+                                ay <- getAlignY na ci+                                let fx = alignX ax itemX colW childW+                                    fy = alignY ay curY rowH childH+                                positionNodeA env (depth + 1) ci fx fy colW rowH+                                goCols (j + 1)+                  goCols 0+                  goRows (r + 1) (curY + rowH + gap)+        goRows 0 cy++positionColumnFromParent ::+  SolveEnv ->+  Int ->+  NodeIdx ->+  Float ->+  Bool ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+positionColumnFromParent env@SolveEnv {seArena = na, seFm = fm} depth parent gap chrome px pw cx cy cw ch = do+  n <- loadChildrenScratch (seArena env) parent (flowChildSize env True cw ch)+  gapSum <- columnGapSumScratch na chrome n gap+  withAxisSnaps na depth n ch gapSum False $ \idxSnap outSnap -> do+    let go !i !cur !prev+          | i >= n = pure ()+          | otherwise = do+              ci <- readPrimArray idxSnap i+              fh <- readPrimArray outSnap i+              let y = snappedOrigin (fmSnapScale fm) cur prev+              nt <- getNodeType na ci+              (fx, nodeW) <-+                if chrome && nt == NodeSeparator+                  then pure (px, pw)+                  else (,cw) <$> columnChildX na ci cx cw+              childH <- columnChildHeight na ci fh+              positionNodeA env (depth + 1) ci fx y nodeW childH+              (_, _, _, placedH) <- getRect na ci+              gapAfter <-+                if i + 1 >= n+                  then pure 0+                  else do+                    nextCi <- readPrimArray idxSnap (i + 1)+                    pairColumnGap na chrome nextCi gap+              go (i + 1) (cur + placedH + gapAfter) y+    go 0 cy (-1 / 0)+++{-# INLINE reverseScratchTriple #-}+reverseScratchTriple ::+  MutablePrimArray RealWorld Int ->+  MutablePrimArray RealWorld Float ->+  MutablePrimArray RealWorld Float ->+  Int ->+  Int ->+  IO ()+reverseScratchTriple idxArr mainArr crossArr lo hi = do+  let go !a !b+        | a >= b = pure ()+        | otherwise = do+            swapPrim idxArr a b+            swapPrim mainArr a b+            swapPrim crossArr a b+            go (a + 1) (b - 1)+  go lo hi++{-# INLINE swapPrim #-}+swapPrim :: (Prim a) => MutablePrimArray RealWorld a -> Int -> Int -> IO ()+swapPrim arr a b = do+  x <- readPrimArray arr a+  y <- readPrimArray arr b+  writePrimArray arr a y+  writePrimArray arr b x+{-# SPECIALIZE swapPrim :: MutablePrimArray RealWorld Int -> Int -> Int -> IO () #-}+{-# SPECIALIZE swapPrim :: MutablePrimArray RealWorld Float -> Int -> Int -> IO () #-}++columnGapSumScratch :: NodeArena -> Bool -> Int -> Float -> IO Float+columnGapSumScratch _ False _ _ = pure 0+columnGapSumScratch _ True n _+  | n <= 1 = pure 0+columnGapSumScratch na True n gap = do+  FlexScratch {fsIdx = idxArr} <- readIORef (naScratch na)+  let go !i !acc+        | i >= n - 1 = pure acc+        | otherwise = do+            b <- readPrimArray idxArr (i + 1)+            g <- pairColumnGap na True b gap+            go (i + 1) (acc + g)+  go 0 0++-- | Resolve the main-axis sizes of the first @n@ scratch children.+distributeScratch :: NodeArena -> Int -> Float -> Float -> Bool -> IO ()+distributeScratch na n avail gapSum horizontal = do+  FlexScratch {fsIdx = idxArr, fsW = wArr, fsH = hArr, fsOutW = outW, fsOutH = outH} <- readIORef (naScratch na)+  total <- sumScratchAxis wArr hArr horizontal 0 n 0+  let slack = avail - (total + gapSum)+  if slack > 0.001+    then do+      growTotal <- sumFactors growFactor na idxArr horizontal n+      if growTotal <= 0+        then copyScratchRange wArr hArr outW outH 0 n+        else do+          -- Grow children share the free space by factor, but no child is+          -- squeezed below its content size (a min-content floor, like CSS+          -- flex with min-width:auto): two fillW columns come out equal unless+          -- one column's content needs more, and that one then takes exactly+          -- what it needs while the rest re-share what is left.+          --+          -- Grow factors live in the cross output (0 once a child is not or+          -- no longer growing): withAxisSnaps only consumes the main-axis+          -- array, so it is free scratch here and is restored to real cross+          -- sizes before returning. mainArr keeps the exact content size+          -- throughout; no arithmetic on markers.+          let mainArr = if horizontal then outW else outH+              crossArr = if horizontal then outH else outW+          markGrowFlags na idxArr wArr hArr mainArr crossArr horizontal 0 n+          (free, gfSum) <- settleGrow mainArr crossArr avail gapSum n (n + 1)+          applyGrowShares wArr hArr mainArr crossArr horizontal free gfSum 0 n+    else+      if slack < -0.001+        then do+          shrinkTotal <- sumFactors shrinkFactor na idxArr horizontal n+          if shrinkTotal <= 0+            then copyScratchRange wArr hArr outW outH 0 n+            else applyShrink na idxArr wArr hArr outW outH horizontal (negate slack) shrinkTotal 0 n+        else copyScratchRange wArr hArr outW outH 0 n++-- | @out[i] = (w[i], h[i])@ for the range.+copyScratchRange :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Int -> Int -> IO ()+{-# INLINE copyScratchRange #-}+copyScratchRange wArr hArr outW outH !i !end+  | i >= end = pure ()+  | otherwise = do+      w <- readPrimArray wArr i+      h <- readPrimArray hArr i+      writePrimArray outW i w+      writePrimArray outH i h+      copyScratchRange wArr hArr outW outH (i + 1) end++{-# INLINE sumScratchAxis #-}+sumScratchAxis :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Int -> Int -> Float -> IO Float+sumScratchAxis wArr hArr horizontal !i !end !acc+  | i >= end = pure acc+  | otherwise = do+      v <- if horizontal then readPrimArray wArr i else readPrimArray hArr i+      sumScratchAxis wArr hArr horizontal (i + 1) end (acc + v)++-- | Sizing along the main axis: width when @horizontal@, else height.+{-# INLINE getAxisSizing #-}+getAxisSizing :: NodeArena -> NodeIdx -> Bool -> IO (SizingTag, Float)+getAxisSizing na idx horizontal =+  if horizontal then getWidthSizing na idx else getHeightSizing na idx++-- | Sum a sizing-derived flex factor over the first @n@ scratch children.+{-# INLINE sumFactors #-}+sumFactors :: (SizingTag -> Float -> Float) -> NodeArena -> MutablePrimArray RealWorld Int -> Bool -> Int -> IO Float+sumFactors factor na idxArr horizontal n = go 0 0+  where+    go !i !acc+      | i >= n = pure acc+      | otherwise = do+          ci <- readPrimArray idxArr i+          (tag, val) <- getAxisSizing na ci horizontal+          go (i + 1) (acc + factor tag val)++{-# INLINE growFactor #-}+growFactor :: SizingTag -> Float -> Float+growFactor tag val = if tag == SizingGrow then val else 0++{-# INLINE shrinkFactor #-}+shrinkFactor :: SizingTag -> Float -> Float+shrinkFactor tag val =+  case tag of+    SizingShrink -> val+    -- Grow also gives space back when the window is smaller than content.+    SizingGrow -> if val > 0 then val else 1+    -- Percent flexes like CSS: when siblings plus gaps overflow the axis,+    -- percent children give the overflow back so e.g. two 50% columns and a+    -- gap land exactly on the row width. Covers percent on either axis,+    -- should height percent ever be sized that way.+    SizingPercent -> 1+    -- Fit stays content-sized. A pinned header must not squash when a Grow+    -- sibling (page scroll) is taller than the window.+    _ -> 0++markGrowFlags :: NodeArena -> MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Int -> Int -> IO ()+markGrowFlags na idxArr wArr hArr mainArr crossArr horizontal !i !end+  | i >= end = pure ()+  | otherwise = do+      ci <- readPrimArray idxArr i+      iw <- readPrimArray wArr i+      ih <- readPrimArray hArr i+      (tag, val) <- getAxisSizing na ci horizontal+      let gf = growFactor tag val+      writePrimArray mainArr i (if horizontal then iw else ih)+      writePrimArray crossArr i (if gf > 0 then gf else 0)+      markGrowFlags na idxArr wArr hArr mainArr crossArr horizontal (i + 1) end++-- One sweep: sum content of non-grow + already-locked children (factor 0) and+-- grow factors of the still-unlocked.+{-# INLINE scanGrow #-}+scanGrow :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Int -> Int -> Float -> Float -> IO (Float, Float)+scanGrow mainArr crossArr !i !end !occupied !gfSum+  | i >= end = pure (occupied, gfSum)+  | otherwise = do+      gf <- readPrimArray crossArr i+      if gf > 0+        then scanGrow mainArr crossArr (i + 1) end occupied (gfSum + gf)+        else do+          main <- readPrimArray mainArr i+          scanGrow mainArr crossArr (i + 1) end (occupied + main) gfSum++-- Pin every grow child whose content exceeds its would-be share by clearing+-- its factor; its content stays in mainArr.+lockGrow :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Float -> Float -> Int -> Int -> Int -> IO Int+lockGrow mainArr crossArr !free !gfSum !i !end !acc+  | i >= end = pure acc+  | otherwise = do+      gf <- readPrimArray crossArr i+      if gf > 0+        then do+          need <- readPrimArray mainArr i+          if need * gfSum > gf * free+            then do+              writePrimArray crossArr i 0+              lockGrow mainArr crossArr free gfSum (i + 1) end (acc + 1)+            else lockGrow mainArr crossArr free gfSum (i + 1) end acc+        else lockGrow mainArr crossArr free gfSum (i + 1) end acc++-- Each lock shrinks the share pool, possibly locking more children; the+-- locked set only grows, so this fixpoints within n sweeps.+settleGrow :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Float -> Float -> Int -> Int -> IO (Float, Float)+settleGrow mainArr crossArr avail gapSum n !passes = do+  (occupied, gfSum) <- scanGrow mainArr crossArr 0 n 0 0+  let free = avail - gapSum - occupied+  locked <- lockGrow mainArr crossArr free gfSum 0 n 0+  if locked == 0 || passes <= 1+    then pure (free, gfSum)+    else settleGrow mainArr crossArr avail gapSum n (passes - 1)++-- Hand shares to unlocked grow children and restore real cross sizes where+-- the factors clobbered them.+applyGrowShares :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Float -> Float -> Int -> Int -> IO ()+applyGrowShares wArr hArr mainArr crossArr horizontal !free !gfSum !i !end+  | i >= end = pure ()+  | otherwise = do+      iw <- readPrimArray wArr i+      ih <- readPrimArray hArr i+      gf <- readPrimArray crossArr i+      when (gf > 0) $+        writePrimArray mainArr i (max 0 (free * gf / gfSum))+      writePrimArray crossArr i (if horizontal then ih else iw)+      applyGrowShares wArr hArr mainArr crossArr horizontal free gfSum (i + 1) end++applyShrink :: NodeArena -> MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Float -> Float -> Int -> Int -> IO ()+applyShrink na idxArr wArr hArr outW outH horizontal !overflow !shrinkTotal !i !end+  | i >= end = pure ()+  | otherwise = do+      ci <- readPrimArray idxArr i+      iw <- readPrimArray wArr i+      ih <- readPrimArray hArr i+      (minW, minH, _, _) <- getMinMax na ci+      (tag, val) <- getAxisSizing na ci horizontal+      let sf = shrinkFactor tag val+          main = if horizontal then iw else ih+          minMain = if horizontal then minW else minH+          delta = overflow * sf / shrinkTotal+          shrunk = max minMain (main - delta)+      if horizontal+        then writePrimArray outW i shrunk >> writePrimArray outH i ih+        else writePrimArray outW i iw >> writePrimArray outH i shrunk+      applyShrink na idxArr wArr hArr outW outH horizontal overflow shrinkTotal (i + 1) end++alignX :: AlignX -> Float -> Float -> Float -> Float+alignX AlignStart cx _ _ = cx+alignX AlignCenter cx cw iw = cx + (cw - iw) / 2+alignX AlignEnd cx cw iw = cx + cw - iw++alignY :: AlignY -> Float -> Float -> Float -> Float+alignY AlignTop cy _ _ = cy+alignY AlignMiddle cy ch ih = cy + (ch - ih) / 2+alignY AlignBottom cy ch ih = cy + ch - ih++placeModals :: NodeArena -> FontMetrics -> Float -> Float -> IO ()+placeModals na fm winW winH = do+  env <- floatingEnv na fm+  let margin = windowMargin+  forNodes_ na $ \idx -> do+    nt <- getNodeType na idx+    when (nt == NodeModal) $ do+      (_, _, iw, ih) <- getRect na idx+      let maxW = max 0 (winW - 2 * margin)+          maxH = max 0 (winH - 2 * margin)+          w = min iw maxW+          h = min ih maxH+          x = max 0 ((winW - w) / 2)+          y = max 0 ((winH - h) / 2)+      positionNodeA env 0 idx x y w h++placeWindows ::+  NodeArena ->+  FontMetrics ->+  Float ->+  Float ->+  (WidgetId -> IO (Maybe (Float, Float))) ->+  (WidgetId -> IO (Maybe (Float, Float))) ->+  IO ()+placeWindows na fm winW winH lookupPos lookupSize = do+  let margin = windowMargin+  forNodes_ na $ \idx -> do+    nt <- getNodeType na idx+    when (nt == NodeWindow) $ do+      wid <- getWidgetId na idx+      (_, _, iw, ih) <- getRect na idx+      (w0, h0) <- fromMaybe (min iw winW, min ih winH) <$> lookupSize wid+      mpos <- lookupPos wid+      placeWindowNode na fm winW winH idx w0 h0 $ \w -> fromMaybe (winW - w - margin, margin) mpos++-- | Lay out window @idx@ at size @w0 h0@, clamped to its min and max size and+-- the screen, with its origin, given that size, clamped on screen. Fit sizing+-- caps at intrinsic size; floating windows use an explicit frame size.+placeWindowNode :: NodeArena -> FontMetrics -> Float -> Float -> NodeIdx -> Float -> Float -> (Float -> (Float, Float)) -> IO ()+placeWindowNode na fm winW winH idx w0 h0 originFor = do+  (minW, minH, maxW, maxH) <- getMinMax na idx+  let w = clamp minW (min maxW winW) w0+      h = clamp minH (min maxH winH) h0+      (x0, y0) = originFor w+      x = clamp 0 (max 0 (winW - w)) x0+      y = clamp 0 (max 0 (winH - h)) y0+  setRect na idx x y w h+  env <- floatingEnv na fm+  (pad, gap, dir) <- containerFlow (seArrays env) idx+  positionChildren env 0 idx dir gap pad x y w h++-- | Horizontal placement for a widget-anchored popup. Aligns the popup's left+-- edge with the anchor even when the anchor sits inside the window margin (a+-- menu bar flush to the left, say); the margin is only there to keep the popup+-- clear of the right edge.+clampPopupX :: Float -> Float -> Float -> Float -> Float+clampPopupX margin winW iw x0+  | x0 < margin && x0 + iw <= winW = max 0 x0+  | otherwise = max margin (min (winW - iw - margin) x0)++computePopupPosition ::+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  PopupAnchor ->+  PopupPlacement ->+  Float ->+  (Float, Float)+computePopupPosition winW winH margin iw ih anchor placement offset =+  case anchor of+    AnchorPoint (V2 px py) ->+      let x0 = case placement of+            PlacementLeft -> px - iw - offset+            PlacementRight -> px + offset+            _ -> px+          y0 = case placement of+            PlacementAbove -> py - ih - offset+            PlacementBelow -> py + offset+            _ -> py+          x = if x0 + iw > winW - margin && px - iw - margin >= 0+                then px - iw - offset+                else max margin (min (winW - iw - margin) x0)+          y = if y0 + ih > winH - margin && py - ih - margin >= 0+                then py - ih - offset+                else clampY y0+       in (x, y)+    AnchorRect (Rect rx ry rw rh) ->+      case placement of+        PlacementBelow ->+          let x0 = rx+              y0 = ry + rh + offset+              y = if y0 + ih > winH - margin && ry - ih - offset >= margin+                    then ry - ih - offset+                    else y0+              x = clampPopupX margin winW iw x0+           in (x, clampY y)+        PlacementAbove ->+          let x0 = rx+              y0 = ry - ih - offset+              y = if y0 < margin && ry + rh + offset + ih <= winH - margin+                    then ry + rh + offset+                    else y0+              x = clampPopupX margin winW iw x0+           in (x, clampY y)+        PlacementRight ->+          let x0 = rx + rw + offset+              y0 = ry+              x = if x0 + iw > winW - margin && rx - iw - offset >= margin+                    then rx - iw - offset+                    else x0+              y = clampY y0+           in (clampPopupX margin winW iw x, y)+        PlacementLeft ->+          let x0 = rx - iw - offset+              y0 = ry+              x = if x0 < margin && rx + rw + offset + iw <= winW - margin+                    then rx + rw + offset+                    else x0+              y = clampY y0+           in (clampPopupX margin winW iw x, y)+        PlacementAuto ->+          let spaceBelow = winH - margin - (ry + rh + offset)+              spaceAbove = ry - offset - margin+              y = if spaceBelow >= ih || spaceBelow >= spaceAbove+                    then ry + rh + offset+                    else ry - ih - offset+              x = clampPopupX margin winW iw rx+           in (x, clampY y)+        PlacementAtCursor ->+          (clampPopupX margin winW iw rx, clampY (ry + rh + offset))+  where+    -- Keep the popup's top edge within the window margins.+    clampY y = max margin (min (winH - ih - margin) y)++placePopups ::+  NodeArena ->+  FontMetrics ->+  Float ->+  Float ->+  (WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))) ->+  IO ()+placePopups na fm winW winH lookupAnchor = do+  env <- floatingEnv na fm+  let margin = windowMargin+  forNodes_ na $ \idx -> do+    nt <- getNodeType na idx+    when (nt == NodePopup) $ do+      wid <- getWidgetId na idx+      (_, _, iw, ih) <- getRect na idx+      mcfg <- lookupAnchor wid+      let (anchor, placement, offset) = case mcfg of+            Just (a, p, o) -> (a, p, o)+            Nothing -> (AnchorPoint (V2 0 0), PlacementAuto, 4)+          (x, y) = computePopupPosition winW winH margin iw ih anchor placement offset+      positionNodeA env 0 idx x y iw ih
+ lib/NanoUI/Monad.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | The 'Ui' effect and the 'NanoUI' view type: running a view, widget id+-- scopes and keys, theme scopes, and damage requests from inside a view.+module NanoUI.Monad+  ( NanoUI+  , Ui+  , runNanoUI+  , runUi+  , uiIO+  , emit+  , withKey+  , keyed+  , keyedTag+  , scope+  , withIdFrame+  , nextId+  , burstNextIds+  , currentId+  , askContext+  , askInput+  , askDefaultLayout+  , withDefaultLayout+  , askHost+  , uiFontMetrics+  , uiTime+  , uiTheme+  , setUiTheme+  , styled+  , themed+  , disabledWhen+  , uiMousePos+  , windowSize+  , windowWidth+  , windowHeight+  , damageWidgetNow+  , damageKeyNow+  , damageRectNow+  , damageGroupNow+  , damageFullNow+  , FrameMsg (..)+  , decodeMessages+  , reduceMessages+  , reduceUpdates+  , whenM+  , unlessM+  , ifM+  )+where+++import Control.Exception (bracket)+import Control.Monad (unless, when)+import Data.Bits (shiftL, (.&.), (.|.))+import Data.Hashable (Hashable, hash)+import Data.IORef (modifyIORef', readIORef, writeIORef)+import Data.Typeable (Typeable)+import Data.Word (Word64)+import Effectful+  ( Dispatch (Static)+  , DispatchOf+  , Eff+  , Effect+  , IOE+  , runEff+  , type (:>)+  )+import Effectful.Dispatch.Static+  ( SideEffects (WithSideEffects)+  , StaticRep+  , evalStaticRep+  , getStaticRep+  , localStaticRep+  , unEff+  , unsafeEff+  , unsafeEff_+  )+import GHC.Clock (getMonotonicTime)+import NanoUI.Context+  ( Context (..)+  , FrameMsg (..)+  , askHostIO+  , damageFull+  , damageKey+  , damagePeers+  , damageRect+  , damageWidget+  , decodeMessages+  , currentTheme+  , pushMessage+  , pushThemeScope+  , scopeRawTheme+  , setTheme+  , reduceMessages+  , reduceUpdates+  )+import NanoUI.Font (FontMetrics)+import NanoUI.Id+  ( IdContext (siblingId)+  , WidgetId+  , enterKeyed+  , enterScope+  , idContextWidgetId+  , scopeTag+  )+import NanoUI.Layout.Arena (getArenaScope, setArenaScope)+import NanoUI.Style (Layout, Theme, disabledTheme)+import NanoUI.Input (Input (..), inputMousePos, inputWindowSize, stripInteractionInput)+import NanoUI.Types (DamageBounds, Rect, Size (..), V2)++type NanoUI = Eff '[Ui, IOE]++data Ui :: Effect++type instance DispatchOf Ui = Static WithSideEffects++data instance StaticRep Ui = UiRep !Context !Input !Layout++{-# INLINE runUi #-}+runUi :: IOE :> es => Context -> Input -> Eff (Ui : es) a -> Eff es a+runUi ctx inp ui = do+  lay <- unsafeEff_ (readIORef (ctxDefaultLayout ctx))+  evalStaticRep (UiRep ctx inp lay) ui++{-# INLINE runNanoUI #-}+runNanoUI :: Context -> Input -> NanoUI a -> IO a+runNanoUI ctx inp = runEff . runUi ctx inp++{-# INLINE uiIO #-}+uiIO :: Ui :> es => IO a -> Eff es a+uiIO m = do+  UiRep {} <- getStaticRep+  unsafeEff_ m++{-# INLINE emit #-}+emit :: (Typeable msg, Ui :> es) => msg -> Eff es ()+emit msg = do+  ctx <- askContext+  uiIO (pushMessage ctx (FrameMsg msg))++-- | The id 'nextId' would issue, without consuming it.+{-# INLINE currentId #-}+currentId :: Ui :> es => Eff es WidgetId+currentId = do+  ctx <- askContext+  ic <- uiIO (readIORef (ctxIdContext ctx))+  pure (idContextWidgetId ic)++{-# INLINE nextId #-}+nextId :: Ui :> es => Eff es WidgetId+nextId = do+  ctx <- askContext+  uiIO $ do+    ic <- readIORef (ctxIdContext ctx)+    writeIORef (ctxIdContext ctx) $! ic {siblingId = siblingId ic + 1}+    pure (idContextWidgetId ic)++-- | Issue many widget ids in one IO loop (avoids deep Eff bind chains).+{-# INLINE burstNextIds #-}+burstNextIds :: Ui :> es => Int -> Eff es ()+burstNextIds n+  | n <= 0 = pure ()+  | otherwise = do+      ctx <- askContext+      uiIO $ modifyIORef' (ctxIdContext ctx) $ \ic ->+        let !sid = siblingId ic + fromIntegral n+         in ic {siblingId = sid}++-- Run @m@ in the child context from @enter@, then restore the advanced parent+-- (also on exceptions).+{-# INLINE withIdFrame #-}+withIdFrame ::+  Ui :> es => (IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a+withIdFrame enter m = do+  ctx <- askContext+  unsafeEff $ \es ->+    bracket+      (do+        old <- readIORef (ctxIdContext ctx)+        let !(!p, !c) = enter old+        writeIORef (ctxIdContext ctx) c+        pure p)+      (\parent' -> writeIORef (ctxIdContext ctx) parent')+      (\_ -> unEff m es)++{-# INLINE scope #-}+scope :: Ui :> es => Eff es a -> Eff es a+scope = withIdFrame (enterScope scopeTag)++{-# INLINE keyed #-}++-- | Stable child path from @tag@. Keys must be unique among siblings in the same scope.+keyed :: (Hashable k, Ui :> es) => k -> Eff es a -> Eff es a+keyed k = keyedTag (fromIntegral (hash k))++{-# INLINE keyedTag #-}+keyedTag :: Ui :> es => Word64 -> Eff es a -> Eff es a+keyedTag tag = withIdFrame (enterKeyed tag)++{-# INLINE withKey #-}+withKey :: (Hashable k, Ui :> es) => k -> Eff es a -> Eff es a+withKey = keyed++{-# INLINE askContext #-}+askContext :: Ui :> es => Eff es Context+askContext = do+  UiRep ctx _ _ <- getStaticRep+  pure ctx++{-# INLINE askDefaultLayout #-}+askDefaultLayout :: Ui :> es => Eff es Layout+askDefaultLayout = do+  UiRep _ _ l <- getStaticRep+  pure l++{-# INLINE withDefaultLayout #-}+withDefaultLayout :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a+withDefaultLayout f = localStaticRep (\(UiRep ctx inp l) -> UiRep ctx inp (f l))++{-# INLINE uiFontMetrics #-}+uiFontMetrics :: Ui :> es => Eff es FontMetrics+uiFontMetrics = fmap ctxFontMetrics askContext++{-# INLINE uiTime #-}+-- | Monotonic seconds since some fixed epoch (process boot), as a 'Double'.+-- Use it for time-based animation math inside the UI effect. It stays in+-- 'Double' on purpose: converting wall-clock seconds to 'Float' loses ~3 ms+-- of resolution at 8 h uptime (worse longer), which is coarser than a frame+-- and quantizes animation sweeps into visible steps.+uiTime :: Ui :> es => Eff es Double+uiTime = uiIO getMonotonicTime++-- | The theme the view is drawn with where this is called: the context theme+-- as modified by the enclosing 'styled' and 'disabledWhen' scopes.+{-# INLINE uiTheme #-}+uiTheme :: Ui :> es => Eff es Theme+uiTheme = do+  ctx <- askContext+  uiIO (currentTheme ctx)++-- | Draw a part of the view with a modified theme. Widgets declared inside+-- take their colours, borders and corner radii from it, and 'styled' scopes+-- nest, each modifying the theme of the scope around it:+--+-- > styled (buttonStyle (cornerRadius 8)) $ do+-- >   styled primary (button "Save")+-- >   button "Cancel"+--+-- The modifier runs once per scope per frame. The theme only affects how+-- widgets look, never their layout.+{-# INLINE styled #-}+styled :: Ui :> es => (Theme -> Theme) -> Eff es a -> Eff es a+styled f = withPaintScope $ \ctx outer -> do+  raw <- f <$> scopeRawTheme ctx outer+  let !disabled = outer .&. 1+  ti <- pushThemeScope ctx (disabled /= 0) raw (if disabled /= 0 then disabledTheme raw else raw)+  pure ((ti `shiftL` 1) .|. disabled)++-- | Draw a part of the view with another theme, whatever the theme around it.+{-# INLINE themed #-}+themed :: Ui :> es => Theme -> Eff es a -> Eff es a+themed theme = styled (const theme)++-- | Disable every widget declared inside when the condition holds. Disabled+-- widgets keep their place, state and layout, but take no pointer or+-- keyboard input, cannot be focused, and are drawn with 'disabledTheme'.+--+-- > disabledWhen (T.null name) $ whenM (button "Save") save+{-# INLINE disabledWhen #-}+disabledWhen :: Ui :> es => Bool -> Eff es a -> Eff es a+disabledWhen False m = m+disabledWhen True m =+  -- The view inside sees no presses, keys or wheel, so no widget's own input+  -- handling can fire; the frame's focus and click passes check the scope.+  localStaticRep+    (\(UiRep ctx inp l) -> UiRep ctx (stripInteractionInput inp) {inputMouseDown = False, inputMouseRightDown = False} l)+    (withPaintScope enter m)+  where+    enter ctx outer+      | outer .&. 1 /= 0 = pure outer+      | otherwise = do+          raw <- scopeRawTheme ctx outer+          ti <- pushThemeScope ctx True raw (disabledTheme raw)+          pure ((ti `shiftL` 1) .|. 1)++-- Run @m@ with the arena scope @enter@ picks, then restore the scope around it+-- (also on exceptions).+{-# INLINE withPaintScope #-}+withPaintScope :: Ui :> es => (Context -> Int -> IO Int) -> Eff es a -> Eff es a+withPaintScope enter m = do+  ctx <- askContext+  let na = ctxNodeArena ctx+  unsafeEff $ \es ->+    bracket+      (do+        old <- getArenaScope na+        setArenaScope na =<< enter ctx old+        pure old)+      (setArenaScope na)+      (\_ -> unEff m es)++{-# INLINE setUiTheme #-}+setUiTheme :: Ui :> es => Theme -> Eff es ()+setUiTheme th = do+  ctx <- askContext+  uiIO (setTheme ctx th)++{-# INLINE uiMousePos #-}+uiMousePos :: Ui :> es => Eff es V2+uiMousePos = fmap inputMousePos askInput++{-# INLINE askInput #-}+askInput :: Ui :> es => Eff es Input+askInput = do+  UiRep _ inp _ <- getStaticRep+  pure inp++{-# INLINE windowSize #-}+windowSize :: Ui :> es => Eff es Size+windowSize = fmap inputWindowSize askInput++{-# INLINE windowWidth #-}+windowWidth :: Ui :> es => Eff es Float+windowWidth = fmap (sizeW . inputWindowSize) askInput++{-# INLINE windowHeight #-}+windowHeight :: Ui :> es => Eff es Float+windowHeight = fmap (sizeH . inputWindowSize) askInput++{-# INLINE askHost #-}+askHost :: (Typeable a, Ui :> es) => Eff es (Maybe a)+askHost = do+  ctx <- askContext+  uiIO (askHostIO ctx)++{-# INLINE damageWidgetNow #-}+damageWidgetNow :: (Ui :> es) => WidgetId -> DamageBounds -> Eff es ()+damageWidgetNow wid bounds = do+  ctx <- askContext+  uiIO (damageWidget ctx wid bounds)++{-# INLINE damageKeyNow #-}+damageKeyNow :: (Ui :> es) => Int -> DamageBounds -> Eff es ()+damageKeyNow k bounds = do+  ctx <- askContext+  uiIO (damageKey ctx k bounds)++{-# INLINE damageRectNow #-}+damageRectNow :: (Ui :> es) => Rect -> Eff es ()+damageRectNow r = do+  ctx <- askContext+  uiIO (damageRect ctx r)++{-# INLINE damageGroupNow #-}+damageGroupNow :: (Ui :> es) => [WidgetId] -> DamageBounds -> Eff es ()+damageGroupNow wids bounds = do+  ctx <- askContext+  uiIO (damagePeers ctx wids bounds)++{-# INLINE damageFullNow #-}+damageFullNow :: (Ui :> es) => Eff es ()+damageFullNow = do+  ctx <- askContext+  uiIO (damageFull ctx)++-- | Monadic variant of 'when'. Runs the second action if the first returns 'True'.+--+-- Example:+--+-- @+-- whenM (button "Save") saveDocument+-- @+{-# INLINE whenM #-}+whenM :: Monad m => m Bool -> m () -> m ()+whenM mb ma = mb >>= \b -> when b ma++-- | Monadic variant of 'unless'. Runs the second action if the first returns 'False'.+{-# INLINE unlessM #-}+unlessM :: Monad m => m Bool -> m () -> m ()+unlessM mb ma = mb >>= \b -> unless b ma++-- | Monadic conditional selection.+{-# INLINE ifM #-}+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM mb t f = mb >>= \b -> if b then t else f
+ lib/NanoUI/Runner.hs view
@@ -0,0 +1,280 @@+-- | The event loop the backends share: event waiting and frame pacing, click+-- counting, the redraw decision, quit handling, and the drawing lock. A+-- backend supplies a 'SessionDriver' for event translation and presentation.+module NanoUI.Runner+  ( -- * Drawing Lock+    DrawingLock (..)+  , newDrawingLock+  , tryWithDrawingLock+    -- * Redraw Decision+  , shouldRedrawFrame+    -- * Session loop+  , SessionDriver (..)+  , runSessionLoop+  ) where++import Control.Concurrent (threadDelay)+import Control.Exception (finally, mask)+import Control.Monad (when)+import Data.IORef+  ( IORef+  , atomicModifyIORef'+  , newIORef+  , readIORef+  , writeIORef+  )+import GHC.Clock (getMonotonicTime)+import NanoUI.Context+  ( Context+  , anyAnimating+  , isDirty+  , overlayConsumesQuit+  , textInputEditActive+  )+import NanoUI.Debug+  ( DebugSamplerRef+  , debugRefreshDue+  , debugRefreshSec+  , isDebugActive+  , noteDebugLoop+  , noteDebugSkip+  )+import NanoUI.Frame.Redraw (needsRedraw, textFieldActive)+import NanoUI.Input+  ( Input (..)+  , clearEphemeral+  , inputDeltaTime+  , inputMouseClicks+  , inputMousePos+  , inputMousePressed+  , isHardQuitInput+  , splitFrame+  )+import NanoUI.Types (V2 (..))++-- | Standard upper bound for single-frame delta-time (50ms).+maxFrameDt :: Float+maxFrameDt = 0.05++-- | Wind forward to the next frame boundary after a timed-out event wait.+-- When pacing is active the backend requests a wait of ~period, but a one-shot+-- sleep lets frame starts drift by the scheduler's timer granularity (and land+-- late whenever the event waiter overruns), which reads as choppy animation on+-- uneven frame times. Sleep the bulk, then busy-wind the ≤1ms tail so frame+-- starts fall on uniform slices of the pacing period. The spin only runs when+-- an animation is actively presenting without vsync, and is bounded to about a+-- millisecond.+alignFrameStart :: Double -> Double -> IO ()+alignFrameStart periodSec lastT = do+  t0 <- getMonotonicTime+  let target = lastT + periodSec+      remain = target - t0+      bulkUs = max 0 (round ((remain - tailSlack) * 1e6))+  when (bulkUs > 0) (threadDelay bulkUs)+  fullSpin target+  where+    tailSlack = 2.5e-4+    fullSpin target = do+      now <- getMonotonicTime+      when (now < target) (fullSpin target)++-- | State for multi-click detection (double/triple click).+data ClickTrack = ClickTrack+  { ctTime :: !Double+  , ctPos :: !V2+  , ctCount :: !Int+  }++-- | Stamp multi-click counts into an 'Input' record: presses within 5 pixels+-- and 0.4 seconds of the previous one count up to a triple click.+stampClicks :: IORef ClickTrack -> Input -> IO Input+stampClicks ref inp+  | not (inputMousePressed inp) = pure inp+  | otherwise = do+      now <- getMonotonicTime+      prev <- readIORef ref+      let t = ctTime prev+          n = ctCount prev+          V2 x y = inputMousePos inp+          V2 px py = ctPos prev+          dx = x - px+          dy = y - py+          distSq = dx * dx + dy * dy+          close = distSq <= 25+          quick = (now - t) <= 0.4+          n' = if close && quick then min 3 (n + 1) else 1+      writeIORef ref ClickTrack {ctTime = now, ctPos = inputMousePos inp, ctCount = n'}+      pure (inp {inputMouseClicks = n'})++-- | Concurrency lock for drawing vs async callbacks (e.g. resize watchers).+newtype DrawingLock = DrawingLock (IORef Bool)++-- | Create a new unacquired drawing lock.+newDrawingLock :: IO DrawingLock+newDrawingLock = DrawingLock <$> newIORef False++-- | Attempt to execute an action under the drawing lock without blocking.+tryWithDrawingLock :: DrawingLock -> IO a -> IO (Maybe a)+tryWithDrawingLock (DrawingLock ref) act = mask $ \restore -> do+  ok <- atomicModifyIORef' ref $ \busy -> if busy then (True, False) else (True, True)+  if ok+    then Just <$> (restore act `finally` writeIORef ref False)+    else pure Nothing++-- | Centralized decision predicate: should the host backend redraw this frame?+shouldRedrawFrame ::+  Context ->+  Input ->       -- ^ Previous input+  Input ->       -- ^ Current input+  Bool ->        -- ^ Was animating on previous frame?+  Bool ->        -- ^ Continuous redraw requested?+  Bool ->        -- ^ Debug live refresh requested?+  IO Bool+shouldRedrawFrame ctx prevInp curInp wasAnim continuous wantDebug = do+  if continuous || wantDebug+    then pure True+    else do+      -- 'needsRedraw' already covers a dirty context, running animations and+      -- an active text field, so an animation that just ended is the only+      -- animation case left: it needs one final frame.+      need <- needsRedraw ctx prevInp curInp+      let pointerEdge =+            inputMousePressed curInp+              || inputMouseReleased curInp+              || inputMouseRightPressed curInp+              || inputMouseRightReleased curInp+          scrollEdge = inputScroll curInp /= V2 0 0+      pure (need || wasAnim || pointerEdge || scrollEdge)++-- | What a backend provides to 'runSessionLoop'.+data SessionDriver ev = SessionDriver+  { sdPollEvents    :: IO [ev]+    -- ^ Non-blocking poll for pending backend events.+  , sdWaitEvents    :: Int -> IO [ev]+    -- ^ Wait for events with a timeout in milliseconds (-1 indicates blocking wait).+  , sdApplyEvent    :: Input -> ev -> Input+    -- ^ Fold an event into the 'Input' state.+  , sdIsButtonEdge  :: ev -> Bool+    -- ^ Predicate identifying click/press boundaries where the event stream should be split.+  , sdIsHardQuit    :: ev -> Bool+    -- ^ Predicate for immediate OS/SIGINT hard-quit signals (e.g. Ctrl+C).+  , sdIsSessionQuit :: ev -> Bool+    -- ^ Predicate for window close requests.+  , sdSyncDisplay   :: Context -> Input -> IO (Context, Input)+    -- ^ Backend-specific display synchronization (window dimensions, DPI scale).+  , sdDebug         :: DebugSamplerRef+    -- ^ The session's debug sampler: loop timing, skips, and the 4 Hz+    -- readout refresh.+  , sdContinuous    :: !Bool+    -- ^ Redraw every pass without waiting for events.+  , sdPacingMs      :: !Int+    -- ^ Event wait in milliseconds while something animates or a text field+    -- is being edited.+  , sdPresentPaces  :: IO Bool+    -- ^ Whether the last present waited for the display (vsync), so a running+    -- animation can loop without waiting and still be frame-locked.+  , sdAlignSec      :: Double+    -- ^ Frame pacing period in seconds for the timed-out wait path. Frame+    -- starts are wound onto a uniform grid of this period so animation+    -- cadence matches the host, instead of drifting with the event waiter's+    -- timer granularity.+  , sdShouldDraw    :: Context -> Input -> Input -> Bool -> Bool -> IO Bool+    -- ^ Decision predicate: (ctx, prevInp, curInp, wasAnimating, debugDue) ->+    -- should this frame be rendered? Usually 'shouldRedrawFrame'.+  , sdDraw          :: Context -> Input -> Bool -> IO (Bool, Input)+    -- ^ Render frame: (ctx, curInp, forceFull) -> (dirtyAfterRender, syncedInput).+  , sdOnCursor      :: Context -> Input -> IO ()+    -- ^ Sync the host cursor icon after every pass.+  , sdShouldQuit    :: Input -> Bool+    -- ^ Application-level quit predicate.+  }++-- | Event wait while only the debug readout needs frames: its refresh period.+debugHudTimeout :: Int+debugHudTimeout = round (debugRefreshSec * 1000)++-- | Run an event-driven session loop until a termination event or user quit condition.+runSessionLoop ::+  SessionDriver ev ->+  Context ->+  Input ->+  IO ()+runSessionLoop drv ctx0 inp0 = do+  clickTracker <- newIORef ClickTrack {ctTime = 0, ctPos = V2 (-999) (-999), ctCount = 0}+  startT <- getMonotonicTime++  let waitForEvents timeout lastT+        | timeout < 0 = sdWaitEvents drv (-1)+        | otherwise = do+            polled <- sdPollEvents drv+            if not (null polled)+              then pure polled+              else do+                events <- sdWaitEvents drv timeout+                -- Only a timed-out paced wait needs frame alignment.+                when (timeout > 0 && null events) $+                  alignFrameStart (sdAlignSec drv) lastT+                pure events++      loop ctx inp queued lastT pendingDirty wasAnim = do+        (pending, debugDue) <-+          if not (null queued)+            then pure (queued, False)+            else if pendingDirty+              then (,False) <$> waitForEvents 0 lastT+              else do+                debugActive <- isDebugActive (sdDebug drv)+                refreshDue <- debugRefreshDue (sdDebug drv)+                animating <- anyAnimating ctx+                editing <- textFieldActive ctx+                dirty <- isDirty ctx+                presentPaces <- sdPresentPaces drv+                let dueNow = debugActive && refreshDue+                    timeout+                      | sdContinuous drv || dueNow || dirty || (animating && presentPaces) = 0+                      | wasAnim || animating || editing = sdPacingMs drv+                      | debugActive = debugHudTimeout+                      | otherwise = -1+                events <- waitForEvents timeout lastT+                -- A readout wait that timed out ends on its refresh.+                pure (events, dueNow || (timeout == debugHudTimeout && debugActive && null events))++        let (group, rest) = splitFrame (sdIsButtonEdge drv) pending+        editActive <- textInputEditActive ctx+        let hardQuitEv = any (sdIsHardQuit drv) group && not editActive+            sessionQuitEv = any (sdIsSessionQuit drv) group+        if hardQuitEv || sessionQuitEv+          then pure ()+          else do+            now <- getMonotonicTime+            let !dt = min maxFrameDt (realToFrac (now - lastT))+            noteDebugLoop (sdDebug drv) dt+            let inpFolded = foldl' (sdApplyEvent drv) (clearEphemeral inp {inputDeltaTime = dt}) group+            inpStamped <- stampClicks clickTracker inpFolded+            (ctx', inpSynced) <- sdSyncDisplay drv ctx inpStamped+            -- Hard quit (e.g. Ctrl+C) is ignored while a text editor is active.+            editActiveSynced <- textInputEditActive ctx'+            if isHardQuitInput inpSynced && not editActiveSynced+              then pure ()+              else do+                shouldDraw <- if pendingDirty+                  then pure True+                  else sdShouldDraw drv ctx' inp inpSynced wasAnim debugDue+                -- Force a full present only on the settle frame where an+                -- animation just finished (wasAnim && not animNow), so running+                -- animations keep clip damage.+                animNow <- anyAnimating ctx'+                (dirtyOut, synced) <- if shouldDraw+                  then sdDraw drv ctx' inpSynced (wasAnim && not animNow)+                  else do+                    noteDebugSkip (sdDebug drv)+                    pure (pendingDirty, inpSynced)+                sdOnCursor drv ctx' synced+                animAfter <- anyAnimating ctx'+                -- Open modals/overlays consume Escape/Quit before the app sees it.+                overlayQuit <- overlayConsumesQuit ctx' synced+                if sdShouldQuit drv synced && not overlayQuit+                  then pure ()+                  else loop ctx' synced rest now dirtyOut animAfter++  loop ctx0 inp0 [] startT False False
+ lib/NanoUI/SIMD.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-}++-- | Vertex and index writers for the draw buffers. Each vertex is written with+-- two 128-bit GHC SIMD stores (FloatX4#) instead of eight scalar stores.+--+-- GHC's native code generator compiles these primops from 9.12, and only on+-- x86-64. Other compilers and architectures use scalar stores that write the+-- same bytes.+module NanoUI.SIMD+  ( pokeVertexSIMD+  , pokeQuadSIMD+  , pokeQuadGradientSIMD+  , concentricOffsetsSIMD+  ) where++import Foreign.Storable (pokeByteOff)+import Data.Word (Word8)+#if __GLASGOW_HASKELL__ >= 912 && defined(x86_64_HOST_ARCH)+import GHC.Ptr (Ptr (..))+import GHC.Exts+  ( Float (F#)+  , Int (I#)+  , packFloatX4#+  , packWord32X4#+  , plusAddr#+  , writeFloatOffAddrAsFloatX4#+  , writeWord32OffAddrAsWord32X4#+  )+import GHC.Word (Word32 (W32#))+import GHC.IO (IO (..))+#else+import Data.Word (Word32)+import Foreign.Ptr (Ptr)+#endif++-- | Writes one 32-byte Vertex (8 floats) into memory using two 128-bit SIMD stores+-- instead of 8 scalar stores.+{-# INLINE pokeVertexSIMD #-}+pokeVertexSIMD ::+  Ptr Word8 ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  IO ()+#if __GLASGOW_HASKELL__ >= 912 && defined(x86_64_HOST_ARCH)+pokeVertexSIMD (Ptr addr#) (I# byteOff#) (F# px#) (F# py#) (F# r#) (F# g#) (F# b#) (F# a#) (F# u#) (F# v#) = IO $ \s0 ->+  -- Offsets are recomputed inline (the address add is a single lea) so the+  -- simplified body stays free of let bindings; the inspection test guards+  -- this with a NoAllocation obligation.+  case packFloatX4# (# px#, py#, r#, g# #) of+    v0# ->+      case packFloatX4# (# b#, a#, u#, v# #) of+        v1# ->+          case writeFloatOffAddrAsFloatX4# (plusAddr# addr# byteOff#) 0# v0# s0 of+            s1 -> case writeFloatOffAddrAsFloatX4# (plusAddr# (plusAddr# addr# byteOff#) 16#) 0# v1# s1 of+              s2 -> (# s2, () #)+#else+pokeVertexSIMD p off px py r g b a u v = do+  pokeByteOff p off px+  pokeByteOff p (off + 4) py+  pokeByteOff p (off + 8) r+  pokeByteOff p (off + 12) g+  pokeByteOff p (off + 16) b+  pokeByteOff p (off + 20) a+  pokeByteOff p (off + 24) u+  pokeByteOff p (off + 28) v+#endif++-- | Vectorized Quad Poking: writes 4 vertices (128 bytes total) and 6 indices (24 bytes total)+-- with SIMD vector stores.+{-# INLINE pokeQuadSIMD #-}+pokeQuadSIMD ::+  Ptr Word8 ->+  Int ->+  Ptr Word8 ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Word32 ->+  IO ()+pokeQuadSIMD vertices vOffset indices iOffset x y w h u0 v0 u1 v1 r g b a baseIdx = do+  let x1 = x + w+      y1 = y + h+  pokeVertexSIMD vertices vOffset x y r g b a u0 v0+  pokeVertexSIMD vertices (vOffset + 32) x1 y r g b a u1 v0+  pokeVertexSIMD vertices (vOffset + 64) x1 y1 r g b a u1 v1+  pokeVertexSIMD vertices (vOffset + 96) x y1 r g b a u0 v1+  pokeQuadIndicesSIMD indices iOffset baseIdx++-- Six indices form the same two triangles for both solid and gradient quads.+{-# INLINE pokeQuadIndicesSIMD #-}+pokeQuadIndicesSIMD :: Ptr Word8 -> Int -> Word32 -> IO ()+#if __GLASGOW_HASKELL__ >= 912 && defined(x86_64_HOST_ARCH)+pokeQuadIndicesSIMD (Ptr addr#) offset@(I# offset#) baseIdx = do+  let !(W32# b0#) = baseIdx+      !(W32# b1#) = baseIdx + 1+      !(W32# b2#) = baseIdx + 2+      !idxVec# = packWord32X4# (# b0#, b1#, b2#, b0# #)+  IO $ \s0 ->+    case writeWord32OffAddrAsWord32X4# (plusAddr# addr# offset#) 0# idxVec# s0 of+      s1 -> (# s1, () #)+  pokeByteOff (Ptr addr#) (offset + 16) (baseIdx + 2)+  pokeByteOff (Ptr addr#) (offset + 20) (baseIdx + 3)+#else+pokeQuadIndicesSIMD p offset baseIdx = do+  pokeByteOff p offset baseIdx+  pokeByteOff p (offset + 4) (baseIdx + 1)+  pokeByteOff p (offset + 8) (baseIdx + 2)+  pokeByteOff p (offset + 12) baseIdx+  pokeByteOff p (offset + 16) (baseIdx + 2)+  pokeByteOff p (offset + 20) (baseIdx + 3)+#endif++-- | Vectorized Quad with 4 distinct corner colors (top-left, top-right, bottom-right, bottom-left)+{-# INLINE pokeQuadGradientSIMD #-}+pokeQuadGradientSIMD ::+  Ptr Word8 ->+  Int ->+  Ptr Word8 ->+  Int ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  (Float, Float, Float, Float) ->+  (Float, Float, Float, Float) ->+  (Float, Float, Float, Float) ->+  (Float, Float, Float, Float) ->+  Word32 ->+  IO ()+pokeQuadGradientSIMD+  vertices vOffset indices iOffset x y w h u v+  (r0, g0, b0, a0) (r1, g1, b1, a1)+  (r2, g2, b2, a2) (r3, g3, b3, a3) baseIdx = do+  let x1 = x + w+      y1 = y + h+  pokeVertexSIMD vertices vOffset x y r0 g0 b0 a0 u v+  pokeVertexSIMD vertices (vOffset + 32) x1 y r1 g1 b1 a1 u v+  pokeVertexSIMD vertices (vOffset + 64) x1 y1 r2 g2 b2 a2 u v+  pokeVertexSIMD vertices (vOffset + 96) x y1 r3 g3 b3 a3 u v+  pokeQuadIndicesSIMD indices iOffset baseIdx++-- | Evaluates 4 concentric arc positions:+-- xs = cx + radii * ct+-- ys = cy + radii * st+--+-- Scalar on purpose: GHC 9.14.1 miscompiles the broadcast/pack/unpack FloatX4#+-- version at -O2 once it is inlined into a loop (liberate-case computed the y+-- lane from cx), corrupting anti-aliased border vertices. The results are+-- bit-identical to the vector version, which also multiplied and added separately.+{-# INLINE concentricOffsetsSIMD #-}+concentricOffsetsSIMD ::+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  Float ->+  ((Float, Float), (Float, Float), (Float, Float), (Float, Float))+concentricOffsetsSIMD cx cy ct st r0 r1 r2 r3 =+  ( (cx + r0 * ct, cy + r0 * st)+  , (cx + r1 * ct, cy + r1 * st)+  , (cx + r2 * ct, cy + r2 * st)+  , (cx + r3 * ct, cy + r3 * st)+  )
+ lib/NanoUI/Store.hs view
@@ -0,0 +1,268 @@+-- | The widget store: per-widget state in maps by value type, keyed by widget+-- id and 'Slot'.+module NanoUI.Store+  ( WidgetStore (..)+  , emptyWidgetStore+  , mirrorStoresChanged+  , bumpMirror+  , slotKey+  , Slot (..)+  , boolInt+  , intBool+  , anySelectOpen+  , isSelectOpen+  , setSelectOpen+  , closeSelects+  , ptrEq+  , eqByPtr+  )+where++import Data.Dynamic (Dynamic)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.Text (Text)+import Data.Word (Word64)+import qualified Data.IntMap.Strict as IM+import GHC.Exts (isTrue#, reallyUnsafePtrEquality#)+import NanoUI.Id (mix64)++-- | Physical-equality shortcut. Pointer equality implies value equality for+-- immutable values, so callers may use 'True' to skip a structural comparison+-- of a field the caller never rebuilt. 'False' only means \"compare properly\".+{-# INLINE ptrEq #-}+ptrEq :: a -> a -> Bool+ptrEq a b = isTrue# (reallyUnsafePtrEquality# a b)++-- | '==' with a physical-equality fast path. Unchanged fields of a+-- record-updated store keep their identity, so whole-store comparisons become+-- cheap when only one map was rebuilt.+{-# INLINE eqByPtr #-}+eqByPtr :: Eq a => a -> a -> Bool+eqByPtr a b = ptrEq a b || a == b++-- | Dynamic values do not implement Eq, but we can verify equality via+-- pointer equality fast path followed by checking key structure and+-- pointer equality of each Dynamic element.+{-# INLINE eqDynMap #-}+eqDynMap :: IntMap Dynamic -> IntMap Dynamic -> Bool+eqDynMap a b =+  ptrEq a b+    || (IM.size a == IM.size b && IM.isSubmapOfBy ptrEq a b)++-- | Widget state for every widget, in maps by value type. Same-type fields+-- that share a widget key use 'slotKey'.+data WidgetStore = WidgetStore+  { storeMirrorGen :: {-# UNPACK #-} !Word64+  , storeOpenSelect :: {-# UNPACK #-} !Int+  , storeInt :: !(IntMap Int)+  , storeFloat :: !(IntMap Float)+  , storeDouble :: !(IntMap Double)+  , storePoint :: !(IntMap (Float, Float))+  , storeText :: !(IntMap Text)+  , storeIntSet :: !(IntMap IntSet)+  , storeFloatList :: !(IntMap [Float])+  , storeIntList :: !(IntMap [Int])+  , storeDyn :: !(IntMap Dynamic)+  }++instance Eq WidgetStore where+  a == b =+    storeMirrorGen a == storeMirrorGen b+      && storeOpenSelect a == storeOpenSelect b+      && eqByPtr (storeInt a) (storeInt b)+      && eqByPtr (storeFloat a) (storeFloat b)+      && eqByPtr (storeDouble a) (storeDouble b)+      && eqByPtr (storePoint a) (storePoint b)+      && eqByPtr (storeText a) (storeText b)+      && eqByPtr (storeIntSet a) (storeIntSet b)+      && eqByPtr (storeFloatList a) (storeFloatList b)+      && eqByPtr (storeIntList a) (storeIntList b)+      && eqDynMap (storeDyn a) (storeDyn b)++instance Show WidgetStore where+  show st =+    "WidgetStore { "+      ++ "storeMirrorGen = " ++ show (storeMirrorGen st)+      ++ ", storeOpenSelect = " ++ show (storeOpenSelect st)+      ++ ", storeInt = " ++ show (storeInt st)+      ++ ", storeFloat = " ++ show (storeFloat st)+      ++ ", storeDouble = " ++ show (storeDouble st)+      ++ ", storePoint = " ++ show (storePoint st)+      ++ ", storeText = " ++ show (storeText st)+      ++ ", storeIntSet = " ++ show (storeIntSet st)+      ++ ", storeFloatList = " ++ show (storeFloatList st)+      ++ ", storeIntList = " ++ show (storeIntList st)+      ++ ", storeDynCount = " ++ show (IM.size (storeDyn st))+      ++ " }"++emptyWidgetStore :: WidgetStore+emptyWidgetStore =+  WidgetStore+    { storeMirrorGen = 0+    , storeOpenSelect = 0+    , storeInt = IM.empty+    , storeFloat = IM.empty+    , storeDouble = IM.empty+    , storePoint = IM.empty+    , storeText = IM.empty+    , storeIntSet = IM.empty+    , storeFloatList = IM.empty+    , storeIntList = IM.empty+    , storeDyn = IM.empty+    }++-- useText/useFlag bump this so Frame can re-run UI without watching every map.+{-# INLINE mirrorStoresChanged #-}+mirrorStoresChanged :: WidgetStore -> WidgetStore -> Bool+mirrorStoresChanged old new = storeMirrorGen old /= storeMirrorGen new++{-# INLINE bumpMirror #-}+bumpMirror :: WidgetStore -> WidgetStore+bumpMirror st = st {storeMirrorGen = storeMirrorGen st + 1}++-- Mix a field tag into a widget key so two Ints (cursor vs anchor) do not collide.+{-# INLINE slotKey #-}+slotKey :: Slot -> Int -> Int+slotKey s k = fromIntegral (mix64 (fromIntegral k) (slotTag s))++-- | Every built-in slot.+data Slot+  = SlotCursor+  | SlotAnchor+  | SlotDrag+  | SlotDragW+  | SlotDrop+  | SlotDropPos+  | SlotWinSize+  | SlotMenuOpen+  | SlotMenuPos+  | SlotScrollCfg+  | SlotScrollOff+  | SlotScrollCross+  | SlotScrollLinkX+  | SlotScrollLinkY+  | SlotScrollStep+  | SlotScrollAxes+  | SlotScrollViewPos+  | SlotScrollViewSize+  | SlotScrollRange+  | SlotScrollContent+  | SlotTextAreaRow+  | SlotTextAreaCol+  | SlotTextAreaPrefCol+  | SlotTextAreaScroll+  | SlotTextAreaViewport+  | SlotTextAreaAnchorRow+  | SlotTextAreaAnchorCol+  | -- | Cached text-area content extent (max line width, line count * line+    -- height) and the node font size they were measured at. Recomputing the width+    -- scans every character of the document, so it is cached and only refreshed+    -- when the text or font changes.+    SlotTextAreaContentW+  | SlotTextAreaContentH+  | SlotTextAreaContentFont+  | -- | Cached 'TextBuffer' for the text area, keyed by its flat 'Text'. Loads and+    -- paint reuse it so the document is not re-split into lines every call.+    SlotTextAreaBuffer+  | -- | Set (value 1) to signal that the text area's text changed through a path+    -- that does not flow through 'Input' (e.g. a context-menu cut/paste). The+    -- text area widget reads and clears this on its next frame, so the caller+    -- still gets a 'respChanged' pulse for edits that carry no keys or chars.+    SlotTextAreaChanged+  | -- | A text field's undo history with the text it was recorded against, in+    -- 'storeDyn'.+    SlotTextHistory+  | -- | Which kind of text field a widget id is: 1 single-line, 2 multi-line.+    -- Commands sent to the id between frames read it.+    SlotTextMode+  | -- | A text area's measured line widths, in 'storeDyn', kept in step with its+    -- lines so an edit remeasures only the lines it changed.+    SlotTextAreaWidths+  | SlotTextInputScroll+  | -- | Search-field debounce bookkeeping. Text slots on the text widget id: the last+    -- committed query and the monotonic timestamp of the last edit.+    SlotSearchCommitted+  | SlotSearchAge+  | -- | Combo box suggestion state (storeInt/storeFloat, keyed by the field+    -- widget): the highlighted option index (absolute into the filtered list),+    -- the start of the visible window slice (keyboard / wheel / scrollbar+    -- scrolling), and the scrollbar bookkeeping the overlay painter and the+    -- widget's thumb-drag gesture share (total filtered count, widest row, x+    -- offset, drag axis + grab offset).+    SlotComboHighlight+  | SlotComboScroll+  | SlotComboCount+  | SlotComboScrollX+  | SlotComboContentW+  | SlotComboDrag+  | SlotComboDragOff+  | -- | The last committed value (storeText): typing edits the live field text but+    -- only Enter, a row click, or losing focus commits it (Escape reverts).+    SlotComboCommitted+  | -- | Had-focus flag (storeInt) so the widget can see the focus-lost transition+    -- on the frame after blur and commit then.+    SlotComboFocus+  | -- | The field text as the widget last produced it (storeText): a frame-start+    -- value that differs from it changed externally (a frame-side row pick or a+    -- clipboard menu action), not by typing.+    SlotComboLive+  | -- | PaneGrid gesture slot (storeInt): 0 none, positive = dragged pane id,+    -- negative = split id being resized. Mirrors 'SlotDrag''s press-held-release+    -- lifecycle but keyed by the grid widget instead of a per-pane leaf.+    SlotPaneGest+  | -- | PaneGrid drag grab offset (storePoint): (mouse - pane origin) at grab start.+    SlotPaneGrab+  | -- | PaneGrid keyboard-navigation focus: focused pane id (0 = none, auto-first).+    SlotPaneFocus+  | -- | PaneGrid maximize state: maximized pane id (0 = none).+    SlotPaneMax+  | -- | PaneGrid resize start (storePoint): (ratio, main-axis mouse) captured when a+    -- divider is first grabbed, so dragging moves it by delta rather than snapping.+    SlotPaneResize+  | -- | PaneGrid id seed (storeInt): next split / pane id to allocate. Strictly+    -- monotonic per grid: ids are never reused, so per-pane state keyed by pane+    -- id cannot collide with a closed pane's state.+    SlotPaneNext+  | -- | The value a controlled widget last returned to its caller.+    SlotSeen+  | -- | A colour picker's opening colour.+    SlotColorBase+  | -- | The stepper arrow a numeric field's press holds: 1 up, -1 down.+    SlotNumericHeld+  | -- | When a numeric field's held stepper arrow next repeats, in monotonic+    -- seconds.+    SlotNumericRepeat+  deriving (Enum)++-- | Tag for a built-in slot: the constructor index mixed with a salt, so tags+-- are well spread.+{-# INLINE slotTag #-}+slotTag :: Slot -> Word64+slotTag s = mix64 0x534C4F5454414753 (fromIntegral (fromEnum s))++boolInt :: Bool -> Int+boolInt b = if b then 1 else 0++intBool :: Int -> Bool+intBool n = n /= 0++-- One open select at a time.+{-# INLINE anySelectOpen #-}+anySelectOpen :: WidgetStore -> Bool+anySelectOpen st = storeOpenSelect st /= 0++{-# INLINE isSelectOpen #-}+isSelectOpen :: WidgetStore -> Int -> Bool+isSelectOpen st k = k /= 0 && storeOpenSelect st == k++{-# INLINE setSelectOpen #-}+setSelectOpen :: WidgetStore -> Int -> Bool -> WidgetStore+setSelectOpen st k True = st {storeOpenSelect = k}+setSelectOpen st k False+  | isSelectOpen st k = closeSelects st+  | otherwise = st++{-# INLINE closeSelects #-}+closeSelects :: WidgetStore -> WidgetStore+closeSelects st = st {storeOpenSelect = 0}
+ lib/NanoUI/Style.hs view
@@ -0,0 +1,999 @@+{-# LANGUAGE StrictData #-}++module NanoUI.Style+  ( Sizing (..)+  , Direction (..)+  , AlignX (..)+  , AlignY (..)+  , Padding (..)+  , Layout (..)+  , defaultLayout+  , Style (..)+  , Theme (..)+  , defaultTheme+  , tomorrowNightMinDarkTheme+  , tomorrowMinLightTheme+  , tomorrowMidnightMinDarkTheme+  , Base16 (..)+  , themeFromBase16+  , themeFromBase16Dark+  , themeFromBase16Light+  , base16TomorrowNight+  , base16TomorrowLight+  -- * Style modifiers+  , background+  , foreground+  , borderColor+  , borderWidth+  , cornerRadius+  , hoverBackground+  , pressBackground+  , fillColor+  -- * Theme modifiers+  , buttonStyle+  , inputStyle+  , panelStyle+  , windowStyle+  , everyStyle+  , accentColor+  , textColor+  , mutedColor+  , linkColor+  , selectionColor+  , windowColor+  , rounded+  , tinted+  , primary+  , destructive+  , success+  , subtle+  , readableOn+  , disabledTheme+  , themeSeries+  , separatorTrackColor+  , scrollBarTrackColor+  , scrollBarThumbColor+  , fadeAlpha+  , windowPad+  , windowMargin+  , padAll+  , padXY+  , gap+  , fillW+  , fillH+  , grow+  , minW+  , maxW+  , fixedW+  , minH+  , maxH+  , fixedH+  , fixedWH+  , alignMid+  , alignEnd+  , tight+  , percent+  , gridMinColW+  , fixedAspectW+  , fixedAspectH+  , gridCols+  , FontVariant (..)+  , FontWeight (..)+  , FontStyle (..)+  , TextDecoration (..)+  , LayoutModifier+  , fontRegular+  , fontHeading+  , fontMuted+  , fontMono+  , fontDanger+  , fontSize+  , fontSizeScale+  , fontColor+  , fontWeight+  , fontBold+  , fontLight+  , fontMedium+  , fontSemiBold+  , fontExtraBold+  , fontBlack+  , fontStyle+  , fontItalic+  , fontOblique+  , textDecoration+  , fontUnderline+  , fontStrike+  , alignStart+  , alignCenter+  , alignTop+  , alignBottom+  ) where++import Data.Bits ((.&.), (.|.))+import Data.Word (Word8)+import NanoUI.Types (Color (..), colorA, colorLuminance, colorRGBA, contrastRatio, lerpColor)++data Sizing+  = Fixed Float+  | Fit+  | Grow Float+  | Shrink Float+  | Percent Float+  deriving (Eq, Show)++data Direction = Row | Column+  deriving (Eq, Show, Enum, Bounded)++data AlignX = AlignStart | AlignCenter | AlignEnd+  deriving (Eq, Show, Enum, Bounded)++data AlignY = AlignTop | AlignMiddle | AlignBottom+  deriving (Eq, Show, Enum, Bounded)++data Padding = Padding+  { padL :: {-# UNPACK #-} !Float+  , padR :: {-# UNPACK #-} !Float+  , padT :: {-# UNPACK #-} !Float+  , padB :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++-- Floating window chrome. The body sits one side-pad below the chrome and one+-- side-pad above the window's bottom edge (the window's own column gap fills+-- the top; see 'NanoUI.Widgets.Overlay').+windowPad :: Padding+windowPad = Padding 10 10 0 10++-- Screen inset for floating window/modal max size and default placement.+windowMargin :: Float+windowMargin = 14++data FontVariant+  = FontRegular+  | FontHeading+  | FontMuted+  | FontMono+  | FontDanger+  deriving (Eq, Show, Enum, Bounded, Ord)++data FontWeight+  = WeightNormal+  | WeightBold+  | WeightLight+  | WeightMedium+  | WeightSemiBold+  | WeightExtraBold+  | WeightBlack+  deriving (Eq, Show, Enum, Bounded, Ord)++data FontStyle+  = FontStyleNormal+  | FontStyleItalic+  | FontStyleOblique+  deriving (Eq, Show, Enum, Bounded, Ord)++data TextDecoration+  = DecorationNone+  | DecorationUnderline+  | DecorationStrikethrough+  | DecorationUnderlineStrike+  deriving (Eq, Show, Enum, Bounded, Ord)++type LayoutModifier = Layout -> Layout++data Layout = Layout+  { layoutDirection :: !Direction+  , layoutWidth :: !Sizing+  , layoutHeight :: !Sizing+  , layoutPadding :: !Padding+  , layoutGap :: {-# UNPACK #-} !Float+  , layoutAlignX :: !AlignX+  , layoutAlignY :: !AlignY+  , layoutMinW :: {-# UNPACK #-} !Float+  , layoutMinH :: {-# UNPACK #-} !Float+  , layoutMaxW :: {-# UNPACK #-} !Float+  , layoutMaxH :: {-# UNPACK #-} !Float+  , layoutFontVariant :: !FontVariant+  , layoutGridCols :: {-# UNPACK #-} !Int+  , layoutGridMinColW :: {-# UNPACK #-} !Float+  , layoutFontSize :: {-# UNPACK #-} !Float+  , layoutFontColor :: !(Maybe Color)+  , layoutFontWeight :: !FontWeight+  , layoutFontStyle :: !FontStyle+  , layoutTextDecoration :: !TextDecoration+  }+  deriving (Eq, Show)++defaultLayout :: Layout+defaultLayout =+  Layout+    { layoutDirection = Column+    , layoutWidth = Fit+    , layoutHeight = Fit+    , layoutPadding = Padding 3 3 3 3+    , layoutGap = 8+    , layoutAlignX = AlignStart+    , layoutAlignY = AlignTop+    , layoutMinW = 0+    , layoutMinH = 0+    , layoutMaxW = 1e9+    , layoutMaxH = 1e9+    , layoutFontVariant = FontRegular+    , layoutGridCols = 0+    , layoutGridMinColW = 0+    , layoutFontSize = 0+    , layoutFontColor = Nothing+    , layoutFontWeight = WeightNormal+    , layoutFontStyle = FontStyleNormal+    , layoutTextDecoration = DecorationNone+    }++padAll :: Float -> Layout -> Layout+padAll n l = l {layoutPadding = Padding n n n n}++padXY :: Float -> Float -> Layout -> Layout+padXY x y l = l {layoutPadding = Padding x x y y}++gap :: Float -> Layout -> Layout+gap n l = l {layoutGap = n}++fillW :: Layout -> Layout+fillW l = l {layoutWidth = Grow 1}++fillH :: Layout -> Layout+fillH l = l {layoutHeight = Grow 1}++grow :: Layout -> Layout+grow = fillW . fillH++minW :: Float -> Layout -> Layout+minW n l = l {layoutMinW = n}++maxW :: Float -> Layout -> Layout+maxW n l = l {layoutMaxW = n}++fixedW :: Float -> Layout -> Layout+fixedW n l = l {layoutWidth = Fixed n, layoutMinW = n, layoutMaxW = n}++minH :: Float -> Layout -> Layout+minH n l = l {layoutMinH = n}++maxH :: Float -> Layout -> Layout+maxH n l = l {layoutMaxH = n}++fixedH :: Float -> Layout -> Layout+fixedH n l = l {layoutHeight = Fixed n}++fixedWH :: Float -> Float -> Layout -> Layout+fixedWH w h l = l {layoutWidth = Fixed w, layoutHeight = Fixed h}++alignMid :: Layout -> Layout+alignMid l = l {layoutAlignY = AlignMiddle}++alignEnd :: Layout -> Layout+alignEnd l = l {layoutAlignX = AlignEnd}++tight :: Layout -> Layout+tight l = l {layoutPadding = Padding 0 0 0 0}++percent :: Float -> Layout -> Layout+percent p l = l {layoutWidth = Percent p}++gridMinColW :: Float -> Layout -> Layout+gridMinColW w l = l {layoutGridMinColW = max 0 w}++fixedAspectW :: Float -> Float -> Layout -> Layout+fixedAspectW w ratio = fixedWH w (w / ratio)++fixedAspectH :: Float -> Float -> Layout -> Layout+fixedAspectH h ratio = fixedWH (h * ratio) h++gridCols :: Int -> Layout -> Layout+gridCols n l = l {layoutGridCols = max 0 n}++fontRegular :: Layout -> Layout+fontRegular l = l {layoutFontVariant = FontRegular}++fontHeading :: Layout -> Layout+fontHeading l = l {layoutFontVariant = FontHeading}++fontMuted :: Layout -> Layout+fontMuted l = l {layoutFontVariant = FontMuted}++fontMono :: Layout -> Layout+fontMono l = l {layoutFontVariant = FontMono}++fontDanger :: Layout -> Layout+fontDanger l = l {layoutFontVariant = FontDanger}++fontSize :: Float -> Layout -> Layout+fontSize sz l = l {layoutFontSize = max 0 sz}++fontSizeScale :: Float -> Layout -> Layout+fontSizeScale s l =+  let cur = layoutFontSize l+      sz = if cur > 0 then cur * s else 16 * s+   in l {layoutFontSize = max 0 sz}++fontColor :: Color -> Layout -> Layout+fontColor col l = l {layoutFontColor = Just col}++fontWeight :: FontWeight -> Layout -> Layout+fontWeight w l = l {layoutFontWeight = w}++fontBold :: Layout -> Layout+fontBold = fontWeight WeightBold++fontLight :: Layout -> Layout+fontLight = fontWeight WeightLight++fontMedium :: Layout -> Layout+fontMedium = fontWeight WeightMedium++fontSemiBold :: Layout -> Layout+fontSemiBold = fontWeight WeightSemiBold++fontExtraBold :: Layout -> Layout+fontExtraBold = fontWeight WeightExtraBold++fontBlack :: Layout -> Layout+fontBlack = fontWeight WeightBlack++fontStyle :: FontStyle -> Layout -> Layout+fontStyle s l = l {layoutFontStyle = s}++fontItalic :: Layout -> Layout+fontItalic = fontStyle FontStyleItalic++fontOblique :: Layout -> Layout+fontOblique = fontStyle FontStyleOblique++textDecoration :: TextDecoration -> Layout -> Layout+textDecoration d l = l {layoutTextDecoration = d}++fontUnderline :: Layout -> Layout+fontUnderline l =+  let newDeco = case layoutTextDecoration l of+        DecorationStrikethrough -> DecorationUnderlineStrike+        DecorationUnderlineStrike -> DecorationUnderlineStrike+        _ -> DecorationUnderline+   in l {layoutTextDecoration = newDeco}++fontStrike :: Layout -> Layout+fontStrike l =+  let newDeco = case layoutTextDecoration l of+        DecorationUnderline -> DecorationUnderlineStrike+        DecorationUnderlineStrike -> DecorationUnderlineStrike+        _ -> DecorationStrikethrough+   in l {layoutTextDecoration = newDeco}++alignStart :: Layout -> Layout+alignStart l = l {layoutAlignX = AlignStart}++alignCenter :: Layout -> Layout+alignCenter l = l {layoutAlignX = AlignCenter}++alignTop :: Layout -> Layout+alignTop l = l {layoutAlignY = AlignTop}++alignBottom :: Layout -> Layout+alignBottom l = l {layoutAlignY = AlignBottom}++data Style = Style+  { styleBg :: {-# UNPACK #-} !Color+  , styleFg :: {-# UNPACK #-} !Color+  , styleBorder :: {-# UNPACK #-} !Color+  , styleBorderWidth :: {-# UNPACK #-} !Float+  , styleCornerRadius :: {-# UNPACK #-} !Float+  , styleHoverBg :: {-# UNPACK #-} !Color+  , styleActiveBg :: {-# UNPACK #-} !Color+  }+  deriving (Eq, Show)++data Theme = Theme+  { themeWindow :: {-# UNPACK #-} !Color+  , themePanel :: !Style+  , themeFloatingWindow :: !Style+  , themeButton :: !Style+  , themeInput :: !Style+  , themeSeparator :: {-# UNPACK #-} !Color+  , themeAccent :: {-# UNPACK #-} !Color+  , themeMuted :: {-# UNPACK #-} !Color+  , themeRed :: {-# UNPACK #-} !Color+  , themeOrange :: {-# UNPACK #-} !Color+  , themeYellow :: {-# UNPACK #-} !Color+  , themeGreen :: {-# UNPACK #-} !Color+  , themePurple :: {-# UNPACK #-} !Color+  , themeOverlayDim :: {-# UNPACK #-} !Color+  , themeOnAccent :: {-# UNPACK #-} !Color+  -- ^ Text and marks drawn on an accent fill: a checked box, an active tab,+  -- a primary button.+  , themeSelection :: {-# UNPACK #-} !Color+  -- ^ Selected text's highlight, drawn under the text. Usually translucent.+  , themeFocusRing :: {-# UNPACK #-} !Color+  , themeLink :: {-# UNPACK #-} !Color+  , themeShadow :: {-# UNPACK #-} !Color+  -- ^ Offset shadow under menus, dropdowns and floating windows. A zero alpha+  -- draws none.+  , themeDisabledFade :: {-# UNPACK #-} !Float+  -- ^ How far a disabled widget's colours fade toward the window colour, from+  -- 0 (not at all) to 1 (invisible).+  }+  deriving (Eq, Show)++-- -----------------------------------------------------------------------------+-- Style and theme modifiers+-- -----------------------------------------------------------------------------++-- $modifiers+-- Styles and themes change the way layouts do: through functions that+-- compose with @(.)@. A @Style -> Style@ edits one surface, and a+-- @Theme -> Theme@ edits the theme a part of the view is drawn with (see+-- @styled@ in "NanoUI"):+--+-- > styled (buttonStyle (cornerRadius 8) . accentColor teal) $ do ...+-- > styled primary (button "Save")++background :: Color -> Style -> Style+background c s = s {styleBg = c}++foreground :: Color -> Style -> Style+foreground c s = s {styleFg = c}++borderColor :: Color -> Style -> Style+borderColor c s = s {styleBorder = c}++borderWidth :: Float -> Style -> Style+borderWidth w s = s {styleBorderWidth = max 0 w}++cornerRadius :: Float -> Style -> Style+cornerRadius r s = s {styleCornerRadius = max 0 r}++hoverBackground :: Color -> Style -> Style+hoverBackground c s = s {styleHoverBg = c}++pressBackground :: Color -> Style -> Style+pressBackground c s = s {styleActiveBg = c}++-- | A background with hover and press shades derived from it: hovering mixes+-- in some of the foreground, pressing darkens.+fillColor :: Color -> Style -> Style+fillColor c s =+  s+    { styleBg = c+    , styleHoverBg = lerpColor c (styleFg s) 0.12+    , styleActiveBg = lerpColor c (colorRGBA 0 0 0 (colorA c)) 0.18+    }++buttonStyle :: (Style -> Style) -> Theme -> Theme+buttonStyle f t = t {themeButton = f (themeButton t)}++-- | Text fields, text areas, sliders' wells and scroller wells.+inputStyle :: (Style -> Style) -> Theme -> Theme+inputStyle f t = t {themeInput = f (themeInput t)}++-- | Panels, cards, menus, and label text.+panelStyle :: (Style -> Style) -> Theme -> Theme+panelStyle f t = t {themePanel = f (themePanel t)}++-- | Floating windows.+windowStyle :: (Style -> Style) -> Theme -> Theme+windowStyle f t = t {themeFloatingWindow = f (themeFloatingWindow t)}++everyStyle :: (Style -> Style) -> Theme -> Theme+everyStyle f = buttonStyle f . inputStyle f . panelStyle f . windowStyle f++accentColor :: Color -> Theme -> Theme+accentColor c t = t {themeAccent = c, themeFocusRing = c, themeSelection = fadeAlpha c (colorA (themeSelection t))}++-- | The foreground of every surface.+textColor :: Color -> Theme -> Theme+textColor c = everyStyle (foreground c)++mutedColor :: Color -> Theme -> Theme+mutedColor c t = t {themeMuted = c}++linkColor :: Color -> Theme -> Theme+linkColor c t = t {themeLink = c}++selectionColor :: Color -> Theme -> Theme+selectionColor c t = t {themeSelection = c}++-- | The backdrop behind everything, which disabled widgets also fade toward.+windowColor :: Color -> Theme -> Theme+windowColor c t = t {themeWindow = c}++-- | The corner radius of every surface.+rounded :: Float -> Theme -> Theme+rounded r = everyStyle (cornerRadius r)++-- | Buttons filled with a colour picked from the theme, with a readable label.+--+-- > styled (tinted themePurple) (button "Tag")+tinted :: (Theme -> Color) -> Theme -> Theme+tinted pick t =+  let c = pick t+      label = readableOn t c+   in buttonStyle+        ( \s ->+            s+              { styleBg = c+              , styleFg = label+              , styleBorder = c+              , styleHoverBg = lerpColor c label 0.14+              , styleActiveBg = lerpColor c (themeWindow t) 0.22+              }+        )+        t++-- | Buttons in the accent colour, for the action a view is for.+primary :: Theme -> Theme+primary = tinted themeAccent++-- | Buttons in the theme's red, for destructive actions.+destructive :: Theme -> Theme+destructive = tinted themeRed++success :: Theme -> Theme+success = tinted themeGreen++-- | Buttons without a fill or border until hovered, for toolbars and+-- secondary actions.+subtle :: Theme -> Theme+subtle =+  buttonStyle $ \s ->+    s+      { styleBg = clear+      , styleBorder = clear+      , styleBorderWidth = 0+      , styleHoverBg = fadeAlpha (styleFg s) 30+      , styleActiveBg = fadeAlpha (styleFg s) 48+      }+  where+    clear = colorRGBA 0 0 0 0++-- | Whichever of the theme's text colours reads best on @c@.+readableOn :: Theme -> Color -> Color+readableOn t c =+  let candidates = [themeOnAccent t, styleFg (themePanel t), themeWindow t]+      best a b = if contrastRatio a c >= contrastRatio b c then a else b+   in foldr1 best candidates++-- | The theme disabled widgets are drawn with: every colour faded toward the+-- window colour by 'themeDisabledFade', and no hover or press feedback.+disabledTheme :: Theme -> Theme+disabledTheme t =+  let f = themeDisabledFade t+      fade c+        | colorA c == 0 = c+        | otherwise = fadeAlpha (lerpColor c (themeWindow t) f) (colorA c)+      fadeStyle s =+        let bg = fade (styleBg s)+         in s {styleBg = bg, styleFg = fade (styleFg s), styleBorder = fade (styleBorder s), styleHoverBg = bg, styleActiveBg = bg}+   in t+        { themePanel = fadeStyle (themePanel t)+        , themeFloatingWindow = fadeStyle (themeFloatingWindow t)+        , themeButton = fadeStyle (themeButton t)+        , themeInput = fadeStyle (themeInput t)+        , themeSeparator = fade (themeSeparator t)+        , themeAccent = fade (themeAccent t)+        , themeMuted = fade (themeMuted t)+        , themeRed = fade (themeRed t)+        , themeOrange = fade (themeOrange t)+        , themeYellow = fade (themeYellow t)+        , themeGreen = fade (themeGreen t)+        , themePurple = fade (themePurple t)+        , themeOnAccent = fade (themeOnAccent t)+        , themeFocusRing = fade (themeFocusRing t)+        , themeLink = fade (themeLink t)+        }++-- | Flat widget style: bg/fg/border plus hover and active fills.+-- Border width 1 and corner radius 2, as the built-in themes use.+flatStyle :: Color -> Color -> Color -> Color -> Color -> Style+flatStyle bg fg border hoverBg activeBg =+  Style+    { styleBg = bg+    , styleFg = fg+    , styleBorder = border+    , styleBorderWidth = 1+    , styleCornerRadius = 2+    , styleHoverBg = hoverBg+    , styleActiveBg = activeBg+    }++-- | Neutral charcoal surfaces, warm text, and a blue selection accent.+-- Keep structural edges quiet; interactive borders and focus carry contrast.+defaultTheme :: Theme+defaultTheme =+  let panelSurface =+        flatStyle+          (colorRGBA 34 34 38 255)+          (colorRGBA 236 234 230 255)+          (colorRGBA 54 54 62 255)+          (colorRGBA 34 34 38 255)+          (colorRGBA 30 30 34 255)+   in Theme+        { themeWindow = colorRGBA 24 24 27 255+        , themePanel = panelSurface+        , themeFloatingWindow = panelSurface+        , themeButton =+            flatStyle+              (colorRGBA 52 52 58 255)+              (colorRGBA 248 247 245 255)+              (colorRGBA 74 76 84 255)+              (colorRGBA 68 70 78 255)+              (colorRGBA 42 42 48 255)+        , themeInput =+            flatStyle+              (colorRGBA 18 18 21 255)+              (colorRGBA 236 234 230 255)+              (colorRGBA 70 72 80 255)+              (colorRGBA 24 24 28 255)+              (colorRGBA 14 14 17 255)+        , themeSeparator = colorRGBA 62 64 72 255+        , themeAccent = colorRGBA 88 156 246 255+        , themeMuted = colorRGBA 176 172 164 255+        , themeRed = colorRGBA 252 165 165 255+        , themeOrange = colorRGBA 216 140 72 255+        , themeYellow = colorRGBA 212 176 88 255+        , themeGreen = colorRGBA 104 168 124 255+        , themePurple = colorRGBA 176 140 220 255+        , themeOverlayDim = colorRGBA 8 8 10 176+        , themeOnAccent = colorRGBA 255 255 255 255+        , themeSelection = fadeAlpha (colorRGBA 88 156 246 255) 115+        , themeFocusRing = colorRGBA 88 156 246 255+        , themeLink = colorRGBA 124 178 250 255+        , themeShadow = colorRGBA 0 0 0 72+        , themeDisabledFade = 0.55+        }++-- Status and series colours in hue order, then accent.+themeSeries :: Theme -> [Color]+themeSeries t =+  [ themeRed t+  , themeOrange t+  , themeYellow t+  , themeGreen t+  , themeAccent t+  , themePurple t+  ]++-- | Opaque tint of a base surface toward the separator color: the track color+-- for scrollbar tracks, divider strips, and similar hairline chrome.+separatorTrackColor :: Style -> Theme -> Color+separatorTrackColor base theme =+  lerpColor (styleBg base) (themeSeparator theme) 0.28++-- Scroll track/thumb tints. The track is an opaque mix of the surface it sits+-- on (the scroller well / floating window body) toward the separator colour, so+-- the lane reads against that surface on every theme. The thumb stays a+-- translucent foreground mix so the track shows through it.+scrollBarTrackColor :: Style -> Theme -> Color+scrollBarTrackColor base theme =+  separatorTrackColor base theme++scrollBarThumbColor :: Style -> Theme -> Color+scrollBarThumbColor base theme =+  let solid = lerpColor (themeSeparator theme) (styleFg base) 0.58+   in fadeAlpha solid 130++-- | Replaces the alpha channel of a color.+fadeAlpha :: Color -> Word8 -> Color+fadeAlpha (Color w) a = Color ((w .&. 0xFFFFFF00) .|. fromIntegral a)++-- | Ported from "Tomorrow Night Min" in https://github.com/biaqat/tomorrow-min-theme-zed+tomorrowNightMinDarkTheme :: Theme+tomorrowNightMinDarkTheme =+  let panelSurface =+        flatStyle+          (colorRGBA 30 31 33 255)  -- base.bg #1E1F21 (elevated panel canvas)+          (colorRGBA 234 234 234 255)  -- bright.fg #EAEAEA+          edgeCol+          (colorRGBA 52 54 62 255)  -- #34363E+          (colorRGBA 26 27 29 255)  -- #1A1B1D+   in Theme+        { themeWindow = colorRGBA 23 24 26 255         -- #17181A (dark root window backdrop)+        , themePanel = panelSurface+        , themeFloatingWindow = panelSurface+        , themeButton =+            flatStyle+              (colorRGBA 44 46 51 255)  -- elevated button surface+              (colorRGBA 245 245 245 255)  -- bright.fg / white+              edgeCol+              (colorRGBA 69 74 83 255)  -- #454A53+              (colorRGBA 28 29 32 255)  -- depressed on click+        , themeInput =+            flatStyle+              (colorRGBA 23 24 26 255)  -- #17181A (recessed into #1E1F21 panel)+              (colorRGBA 234 234 234 255)  -- bright.fg #EAEAEA+              edgeCol+              (colorRGBA 29 30 33 255)+              (colorRGBA 19 20 22 255)+        , themeSeparator = sepCol+        , themeAccent = accentCol+        , themeMuted = colorRGBA 150 152 150 255       -- comment #969896+        , themeRed = colorRGBA 204 102 102 255         -- base.red #CC6666+        , themeOrange = colorRGBA 222 147 95 255       -- base.orange #DE935F+        , themeYellow = colorRGBA 240 198 116 255      -- base.yellow #F0C674+        , themeGreen = colorRGBA 181 189 104 255       -- base.green #B5BD68+        , themePurple = colorRGBA 178 148 187 255      -- base.purple #B294BB+        , themeOverlayDim = colorRGBA 0 0 0 160+        , themeOnAccent = colorRGBA 255 255 255 255+        , themeSelection = fadeAlpha accentCol 115+        , themeFocusRing = accentCol+        , themeLink = accentCol+        , themeShadow = colorRGBA 0 0 0 72+        , themeDisabledFade = 0.55+        }+  where+  edgeCol    = colorRGBA 77 80 87 255              -- window #4D5057 (touch brighter crisp border)+  sepCol = colorRGBA 55 59 65 255              -- base.selection #373B41 (subtle divider)+  accentCol    = colorRGBA 103 150 230 255           -- vscode.cornflower_blue #6796E6++-- | Ported from "Tomorrow Min" in https://github.com/biaqat/tomorrow-min-theme-zed+tomorrowMinLightTheme :: Theme+tomorrowMinLightTheme =+  let panelSurface =+        flatStyle+          (colorRGBA 242 242 242 255)  -- #F2F2F2+          (colorRGBA 55 59 65 255)  -- #373B41+          (colorRGBA 222 222 222 255)  -- #DEDEDE+          (colorRGBA 231 231 231 255)  -- #E7E7E7 (darker than #F2F2F2 so hover reads)+          (colorRGBA 219 219 219 255)  -- #DBDBDB+   in Theme+        { themeWindow = colorRGBA 255 255 255 255     -- #FFFFFF+        , themePanel = panelSurface+        , themeFloatingWindow = panelSurface+        , themeButton =+            flatStyle+              (colorRGBA 232 232 232 255)  -- #E8E8E8 (step down from panel for zebra rows)+              (colorRGBA 55 59 65 255)  -- #373B41+              (colorRGBA 214 214 214 255)  -- #D6D6D6+              (colorRGBA 214 214 214 255)  -- #D6D6D6+              (colorRGBA 196 196 196 255)  -- #C4C4C4+        , themeInput =+            flatStyle+              (colorRGBA 255 255 255 255)  -- #FFFFFF+              (colorRGBA 55 59 65 255)+              (colorRGBA 210 210 210 255)+              (colorRGBA 243 243 243 255)  -- #F3F3F3 (darker than white so hover reads)+              (colorRGBA 255 255 255 255)  -- focus keeps the normal white bg; accent border signals focus+        , themeSeparator = colorRGBA 222 222 222 255  -- #DEDEDE+        , themeAccent = colorRGBA 82 134 188 255      -- #5286BC (Tomorrow Blue)+        , themeMuted = colorRGBA 140 140 140 255      -- #8C8C8C+        , themeRed = colorRGBA 197 78 82 255          -- Tomorrow Red #C54E52+        , themeOrange = colorRGBA 231 140 69 255      -- Tomorrow Orange #E78C45+        , themeYellow = colorRGBA 231 197 71 255      -- Tomorrow Yellow #E7C547+        , themeGreen = colorRGBA 113 140 0 255        -- Tomorrow Green #718C00+        , themePurple = colorRGBA 137 91 144 255      -- Tomorrow Purple #895B90+        , themeOverlayDim = colorRGBA 0 0 0 100+        , themeOnAccent = colorRGBA 255 255 255 255+        , themeSelection = fadeAlpha (colorRGBA 82 134 188 255) 80+        , themeFocusRing = colorRGBA 82 134 188 255+        , themeLink = colorRGBA 66 113 174 255+        , themeShadow = colorRGBA 0 0 0 36+        , themeDisabledFade = 0.55+        }++-- | Ported from "Tomorrow at Midnight Min" in https://github.com/biaqat/tomorrow-min-theme-zed+tomorrowMidnightMinDarkTheme :: Theme+tomorrowMidnightMinDarkTheme =+  let panelSurface =+        flatStyle+          (colorRGBA 16 17 20 255)  -- #101114 (elevated panel canvas)+          (colorRGBA 238 238 238 255)  -- #EEEEEE+          edgeCol+          (colorRGBA 46 48 56 255)  -- #2E3038+          (colorRGBA 12 13 15 255)  -- #0C0D0F+   in Theme+        { themeWindow = colorRGBA 0 0 0 255           -- #000000 (pitch black root window backdrop)+        , themePanel = panelSurface+        , themeFloatingWindow = panelSurface+        , themeButton =+            flatStyle+              (colorRGBA 26 27 34 255)  -- #1A1B22+              (colorRGBA 238 238 238 255)  -- #EEEEEE+              edgeCol+              (colorRGBA 54 58 72 255)  -- #363A48+              (colorRGBA 56 60 81 255)  -- #383C51+        , themeInput =+            flatStyle+              (colorRGBA 13 14 18 255)  -- #0D0E12 (recessed into panel)+              (colorRGBA 238 238 238 255)+              edgeCol+              (colorRGBA 21 22 28 255)+              (colorRGBA 8 9 11 255)+        , themeSeparator = sepCol+        , themeAccent = accentCol+        , themeMuted = colorRGBA 128 132 150 255       -- #808496+        , themeRed = colorRGBA 213 78 83 255           -- bright.red #D54E53+        , themeOrange = colorRGBA 231 140 69 255       -- bright.orange #E78C45+        , themeYellow = colorRGBA 231 197 71 255       -- bright.yellow #E7C547+        , themeGreen = colorRGBA 185 202 74 255        -- bright.green #B9CA4A+        , themePurple = colorRGBA 195 151 216 255      -- bright.purple #C397D8+        , themeOverlayDim = colorRGBA 0 0 0 160+        , themeOnAccent = colorRGBA 255 255 255 255+        , themeSelection = fadeAlpha accentCol 115+        , themeFocusRing = accentCol+        , themeLink = accentCol+        , themeShadow = colorRGBA 0 0 0 96+        , themeDisabledFade = 0.55+        }+  where+  edgeCol    = colorRGBA 48 52 70 255              -- #303446+  sepCol = colorRGBA 48 52 70 255              -- #303446+  accentCol    = colorRGBA 140 182 226 255           -- #8CB6E2++-- -----------------------------------------------------------------------------+-- Base16 Colorschemes+-- -----------------------------------------------------------------------------++-- | Standard Base16 palette containing 16 styling tones and syntax colours+-- following Chris Kempson's Base16 specification.+data Base16 = Base16+  { base00 :: {-# UNPACK #-} !Color -- ^ Default Background+  , base01 :: {-# UNPACK #-} !Color -- ^ Lighter Background (status bars, line numbers, panel backgrounds)+  , base02 :: {-# UNPACK #-} !Color -- ^ Selection Background (active elements, subtle highlights)+  , base03 :: {-# UNPACK #-} !Color -- ^ Comments, Invisibles, Line Highlighting (muted text, borders)+  , base04 :: {-# UNPACK #-} !Color -- ^ Dark Foreground (status bar foreground, secondary text)+  , base05 :: {-# UNPACK #-} !Color -- ^ Default Foreground, Caret, Delimiters, Operators+  , base06 :: {-# UNPACK #-} !Color -- ^ Light Foreground+  , base07 :: {-# UNPACK #-} !Color -- ^ Light Background / Highest contrast foreground+  , base08 :: {-# UNPACK #-} !Color -- ^ Variables, XML Tags, Markup Link Text, Markup Lists, Diff Deleted (Red)+  , base09 :: {-# UNPACK #-} !Color -- ^ Integers, Boolean, Constants, XML Attributes, Markup Link Url (Orange)+  , base0A :: {-# UNPACK #-} !Color -- ^ Classes, Markup Bold, Search Text Background (Yellow)+  , base0B :: {-# UNPACK #-} !Color -- ^ Strings, Inherited Class, Markup Code, Diff Inserted (Green)+  , base0C :: {-# UNPACK #-} !Color -- ^ Support, Regular Expressions, Escape Characters, Markup Quotes (Cyan)+  , base0D :: {-# UNPACK #-} !Color -- ^ Functions, Methods, Attribute IDs, Headings (Blue / Primary Accent)+  , base0E :: {-# UNPACK #-} !Color -- ^ Keywords, Storage, Selector, Markup Italic, Diff Changed (Purple / Magenta)+  , base0F :: {-# UNPACK #-} !Color -- ^ Deprecated, Opening/Closing Embedded Language Tags (Brown)+  }+  deriving (Eq, Show)++-- | Calculate a 'Theme' from a 'Base16' colorscheme, automatically selecting+-- dark or light styling based on background vs foreground luminance.+themeFromBase16 :: Base16 -> Theme+themeFromBase16 b+  | isDark = themeFromBase16Dark b+  | otherwise = themeFromBase16Light b+  where+    isDark = colorLuminance (base00 b) < colorLuminance (base05 b)++-- | Calculate a dark 'Theme' from a 'Base16' colorscheme.+themeFromBase16Dark :: Base16 -> Theme+themeFromBase16Dark b =+  let edgeCol = lerpColor (base02 b) (base03 b) 0.35+      panelBg = lerpColor (base01 b) (base02 b) 0.3+      panelSurface =+        flatStyle+          panelBg+          (base05 b)+          edgeCol+          (lerpColor panelBg (base02 b) 0.5)+          (lerpColor panelBg (base00 b) 0.4)+   in Theme+        { themeWindow = base00 b+        , themePanel = panelSurface+        , themeFloatingWindow = panelSurface+        , themeButton =+            flatStyle+              (base02 b)+              (base07 b)+              edgeCol+              (lerpColor (base02 b) (base03 b) 0.4)+              (base01 b)+        , themeInput =+            flatStyle+              (base00 b)+              (base05 b)+              edgeCol+              (base01 b)+              (base00 b)+        , themeSeparator = edgeCol+        , themeAccent = base0D b+        , themeMuted = base03 b+        , themeRed = base08 b+        , themeOrange = base09 b+        , themeYellow = base0A b+        , themeGreen = base0B b+        , themePurple = base0E b+        , themeOverlayDim = colorRGBA 0 0 0 160+        , themeOnAccent = if colorLuminance (base0D b) > 0.6 then base00 b else colorRGBA 255 255 255 255+        , themeSelection = fadeAlpha (base0D b) 115+        , themeFocusRing = base0D b+        , themeLink = base0D b+        , themeShadow = colorRGBA 0 0 0 72+        , themeDisabledFade = 0.55+        }++-- | Calculate a light 'Theme' from a 'Base16' colorscheme.+themeFromBase16Light :: Base16 -> Theme+themeFromBase16Light b =+  let edgeCol = base02 b+      panelBg = lerpColor (base00 b) (base01 b) 0.5+      panelSurface =+        flatStyle+          panelBg+          (base05 b)+          edgeCol+          (lerpColor panelBg (base00 b) 0.4)+          (lerpColor panelBg (base02 b) 0.4)+   in Theme+        { themeWindow = base00 b+        , themePanel = panelSurface+        , themeFloatingWindow = panelSurface+        , themeButton =+            flatStyle+              (base01 b)+              (base05 b)+              edgeCol+              (base02 b)+              (lerpColor (base02 b) (base03 b) 0.35)+        , themeInput =+            flatStyle+              (base00 b)+              (base05 b)+              edgeCol+              (lerpColor (base00 b) (base01 b) 0.3)+              (lerpColor (base00 b) (base01 b) 0.6)+        , themeSeparator = edgeCol+        , themeAccent = base0D b+        , themeMuted = base03 b+        , themeRed = base08 b+        , themeOrange = base09 b+        , themeYellow = base0A b+        , themeGreen = base0B b+        , themePurple = base0E b+        , themeOverlayDim = colorRGBA 0 0 0 100+        , themeOnAccent = if colorLuminance (base0D b) > 0.6 then base07 b else colorRGBA 255 255 255 255+        , themeSelection = fadeAlpha (base0D b) 80+        , themeFocusRing = base0D b+        , themeLink = base0D b+        , themeShadow = colorRGBA 0 0 0 36+        , themeDisabledFade = 0.55+        }++-- | Tomorrow Night Base16 reference palette.+base16TomorrowNight :: Base16+base16TomorrowNight =+  Base16+    { base00 = colorRGBA 29 31 33 255     -- #1D1F21+    , base01 = colorRGBA 40 42 46 255     -- #282A2E+    , base02 = colorRGBA 55 59 65 255     -- #373B41+    , base03 = colorRGBA 150 152 150 255 -- #969896+    , base04 = colorRGBA 180 183 180 255 -- #B4B7B4+    , base05 = colorRGBA 197 200 198 255 -- #C5C8C6+    , base06 = colorRGBA 224 224 224 255 -- #E0E0E0+    , base07 = colorRGBA 255 255 255 255 -- #FFFFFF+    , base08 = colorRGBA 213 78 83 255   -- #D54E53+    , base09 = colorRGBA 231 140 69 255  -- #E78C45+    , base0A = colorRGBA 231 197 71 255  -- #E7C547+    , base0B = colorRGBA 185 202 74 255  -- #B9CA4A+    , base0C = colorRGBA 112 192 186 255 -- #70C0BA+    , base0D = colorRGBA 103 150 230 255 -- #6796E6+    , base0E = colorRGBA 195 151 216 255 -- #C397D8+    , base0F = colorRGBA 163 104 90 255  -- #A3685A+    }++-- | Tomorrow Light Base16 reference palette.+base16TomorrowLight :: Base16+base16TomorrowLight =+  Base16+    { base00 = colorRGBA 255 255 255 255 -- #FFFFFF+    , base01 = colorRGBA 242 242 242 255 -- #F2F2F2+    , base02 = colorRGBA 222 222 222 255 -- #DEDEDE+    , base03 = colorRGBA 140 140 140 255 -- #8C8C8C+    , base04 = colorRGBA 150 152 150 255 -- #969896+    , base05 = colorRGBA 55 59 65 255    -- #373B41+    , base06 = colorRGBA 40 42 46 255    -- #282A2E+    , base07 = colorRGBA 29 31 33 255    -- #1D1F21+    , base08 = colorRGBA 197 78 82 255   -- #C54E52+    , base09 = colorRGBA 231 140 69 255  -- #E78C45+    , base0A = colorRGBA 231 197 71 255  -- #E7C547+    , base0B = colorRGBA 113 140 0 255   -- #718C00+    , base0C = colorRGBA 62 153 159 255  -- #3E999F+    , base0D = colorRGBA 82 134 188 255  -- #5286BC+    , base0E = colorRGBA 137 91 144 255  -- #895B90+    , base0F = colorRGBA 163 104 90 255  -- #A3685A+    }
+ lib/NanoUI/Svg.hs view
@@ -0,0 +1,1040 @@+{-# LANGUAGE BangPatterns #-}++-- | SVG documents for icons: a parser for the static subset icon sets use and+-- an anti-aliased rasterizer.+--+-- Supported: @svg@ (with @viewBox@, @width@, @height@), @g@, @path@, @rect@,+-- @circle@, @ellipse@, @line@, @polyline@ and @polygon@; the presentation+-- attributes @fill@, @stroke@, @stroke-width@, @stroke-linecap@,+-- @stroke-linejoin@, @stroke-miterlimit@, @fill-rule@, @opacity@,+-- @fill-opacity@ and @stroke-opacity@, also inside @style@; @transform@; and+-- colours as names, @#rgb@, @#rrggbb@, @rgb()@ and @currentColor@. Gradients,+-- patterns, text, masks, clipping, filters and @use@ are ignored.+module NanoUI.Svg+  ( Svg+  , svgSize+  , svgKey+  , svgMonochrome+  , parseSvg+  , rasterizeSvg+  ) where++import Control.Monad (forM_, unless, when)+import Control.Monad.ST (ST, runST)+import Foreign.Storable (pokeByteOff)+import Data.Bits (xor)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Internal qualified as BSI+import Data.Char (isAlpha, isDigit, isSpace, toLower)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.Read qualified as TR+import Text.XML.Hexml qualified as Hexml+import Data.Primitive.PrimArray (MutablePrimArray, PrimArray, copyMutablePrimArray, indexPrimArray, newPrimArray, readPrimArray, setPrimArray, sizeofPrimArray, unsafeFreezePrimArray, writePrimArray)+import Data.Primitive.SmallArray (SmallArray, indexSmallArray, sizeofSmallArray, smallArrayFromList)+import Data.Word (Word8)+import NanoUI.Types (Color (..), clamp01, colorA, colorB, colorG, colorR, colorRGBA)++-- | A parsed SVG document.+data Svg = Svg+  { svgViewBox :: !Box+  , svgSize :: !(Float, Float)+  -- ^ The document's own width and height, from its @width@ and @height@ or+  -- else its @viewBox@.+  , svgShapes :: !(SmallArray Shape)+  , svgKey :: !Int+  -- ^ A hash of the source, for caching rasters.+  , svgMonochrome :: !Bool+  -- ^ Every paint is @currentColor@ or unspecified, so the drawing is one+  -- colour and can be tinted.+  }++-- | Documents are equal when their sources hash the same.+instance Eq Svg where+  a == b = svgKey a == svgKey b++instance Show Svg where+  show doc = "<svg " <> show (svgSize doc) <> ">"++data Box = Box !Float !Float !Float !Float++data Paint = PaintNone | PaintCurrent | PaintColor !Color+  deriving (Eq)++data FillRule = NonZero | EvenOdd+  deriving (Eq)++data LineCap = CapButt | CapRound | CapSquare+  deriving (Eq)++data LineJoin = JoinMiter | JoinRound | JoinBevel+  deriving (Eq)++-- | Presentation state inherited from ancestors.+data PaintStyle = PaintStyle+  { psFill :: !(Maybe Paint)+  , psStroke :: !(Maybe Paint)+  , psStrokeWidth :: !Float+  , psCap :: !LineCap+  , psJoin :: !LineJoin+  , psMiterLimit :: !Float+  , psRule :: !FillRule+  , psOpacity :: !Float+  , psFillOpacity :: !Float+  , psStrokeOpacity :: !Float+  }++-- | Segments, the transform to user space, and the paint.+data Shape = Shape !(SmallArray Segment) !Matrix !PaintStyle++shapeStyle :: Shape -> PaintStyle+shapeStyle (Shape _ _ style) = style++data Segment+  = MoveTo !P+  | LineTo !P+  | CubicTo !P !P !P+  | QuadTo !P !P+  | ArcTo !Float !Float !Float !Bool !Bool !P+  | ClosePath++data P = P {-# UNPACK #-} !Float {-# UNPACK #-} !Float++-- | @a c e / b d f@, mapping @(x, y)@ to @(a x + c y + e, b x + d y + f)@.+data Matrix = Matrix !Float !Float !Float !Float !Float !Float++identity :: Matrix+identity = Matrix 1 0 0 1 0 0++mul :: Matrix -> Matrix -> Matrix+mul (Matrix a b c d e f) (Matrix a' b' c' d' e' f') =+  Matrix+    (a * a' + c * b')+    (b * a' + d * b')+    (a * c' + c * d')+    (b * c' + d * d')+    (a * e' + c * f' + e)+    (b * e' + d * f' + f)++apply :: Matrix -> P -> P+apply (Matrix a b c d e f) (P x y) = P (a * x + c * y + e) (b * x + d * y + f)++--------------------------------------------------------------------------------+-- XML+--------------------------------------------------------------------------------++data Element = Element !Text ![(Text, Text)] ![Element]++-- | The elements of a document, by hexml. Text, comments and processing+-- instructions are not elements; a DOCTYPE, which hexml rejects, is blanked+-- out first.+parseElements :: Text -> Either String [Element]+parseElements src =+  case Hexml.parse (withoutDoctype (TE.encodeUtf8 src)) of+    Left err -> Left (T.unpack (TE.decodeUtf8Lenient err))+    Right doc -> Right (map element (Hexml.children doc))+  where+    element node =+      Element+        (localName (TE.decodeUtf8Lenient (Hexml.name node)))+        [ (localName (TE.decodeUtf8Lenient (Hexml.attributeName a)), decodeEntities (TE.decodeUtf8Lenient (Hexml.attributeValue a)))+        | a <- Hexml.attributes node+        ]+        (map element (Hexml.children node))+    localName n = T.takeWhileEnd (/= ':') n++-- | The document with its DOCTYPE, internal subset included, replaced by+-- spaces, so positions in parse errors still match the source.+withoutDoctype :: ByteString -> ByteString+withoutDoctype bytes =+  case BS.breakSubstring "<!DOCTYPE" bytes of+    (_, rest) | BS.null rest -> bytes+    (before, rest) ->+      let close !depth !k+            | k >= BS.length rest = k+            | otherwise = case BS.index rest k of+                91 -> close (depth + 1 :: Int) (k + 1)+                93 -> close (depth - 1) (k + 1)+                62 | depth <= 0 -> k + 1+                _ -> close depth (k + 1)+          end = close 0 0+       in before <> BS.replicate end 32 <> BS.drop end rest++decodeEntities :: Text -> Text+decodeEntities =+  T.replace "&amp;" "&" . T.replace "&lt;" "<" . T.replace "&gt;" ">" . T.replace "&quot;" "\"" . T.replace "&apos;" "'"++--------------------------------------------------------------------------------+-- Document+--------------------------------------------------------------------------------++-- | Parse an SVG document.+parseSvg :: Text -> Either String Svg+parseSvg src = do+  els <- parseElements src+  root <- case [e | e@(Element n _ _) <- els, n == "svg"] of+    r : _ -> Right r+    [] -> Left "no svg element"+  let Element _ attrs _ = root+      attr k = lookup k attrs+      box = case attr "viewBox" >>= numbers4 of+        Just (x, y, w, h) | w > 0 && h > 0 -> Box x y w h+        _ -> Box 0 0 (fromMaybe 24 (attr "width" >>= length1)) (fromMaybe 24 (attr "height" >>= length1))+      Box _ _ bw bh = box+      width = fromMaybe bw (attr "width" >>= length1)+      height = fromMaybe bh (attr "height" >>= length1)+      shapes = collect identity defaultStyle root+      -- Unspecified paints and currentColor follow the tint; an explicit+      -- colour anywhere makes the drawing multicoloured.+      monochromePaint p = case p of+        Just (PaintColor _) -> False+        _ -> True+  pure+    Svg+      { svgViewBox = box+      , svgSize = (width, height)+      , svgShapes = smallArrayFromList shapes+      , svgKey = T.foldl' (\h c -> (h * 16777619) `xor` fromEnum c) 2166136261 src+      , svgMonochrome = all (\sh -> monochromePaint (psFill (shapeStyle sh)) && monochromePaint (psStroke (shapeStyle sh))) shapes+      }+  where+    numbers4 t = case numberList t of+      [a, b, c, d] -> Just (a, b, c, d)+      _ -> Nothing++defaultStyle :: PaintStyle+defaultStyle =+  PaintStyle+    { psFill = Nothing+    , psStroke = Just PaintNone+    , psStrokeWidth = 1+    , psCap = CapButt+    , psJoin = JoinMiter+    , psMiterLimit = 4+    , psRule = NonZero+    , psOpacity = 1+    , psFillOpacity = 1+    , psStrokeOpacity = 1+    }++-- | Shapes in document order, each with its full transform and style.+collect :: Matrix -> PaintStyle -> Element -> [Shape]+collect m0 style0 (Element name attrs children) =+  let props = attrs ++ styleProperties (fromMaybe "" (lookup "style" attrs))+      m = maybe m0 (mul m0 . parseTransform) (lookup "transform" attrs)+      -- Opacity multiplies down the tree; the other properties replace.+      style = (applyProperties props style0) {psOpacity = psOpacity style0 * maybe 1 clamp01 (lookup "opacity" props >>= number1)}+      shape segs = [Shape (smallArrayFromList segs) m style]+      num k = fromMaybe 0 (lookup k attrs >>= length1)+   in case name of+        "svg" -> concatMap (collect m style) children+        "g" -> concatMap (collect m style) children+        "a" -> concatMap (collect m style) children+        "path" -> shape (parsePath (fromMaybe "" (lookup "d" attrs)))+        "rect" -> shape (rectSegments (num "x") (num "y") (num "width") (num "height") (lookup "rx" attrs >>= length1) (lookup "ry" attrs >>= length1))+        "circle" -> shape (ellipseSegments (num "cx") (num "cy") (num "r") (num "r"))+        "ellipse" -> shape (ellipseSegments (num "cx") (num "cy") (num "rx") (num "ry"))+        "line" -> shape [MoveTo (P (num "x1") (num "y1")), LineTo (P (num "x2") (num "y2"))]+        "polyline" -> shape (polySegments False (fromMaybe "" (lookup "points" attrs)))+        "polygon" -> shape (polySegments True (fromMaybe "" (lookup "points" attrs)))+        _ -> []++styleProperties :: Text -> [(Text, Text)]+styleProperties =+  mapMaybe+    ( \decl -> case T.breakOn ":" decl of+        (k, v) | not (T.null v) -> Just (T.strip k, T.strip (T.drop 1 v))+        _ -> Nothing+    )+    . T.splitOn ";"++applyProperties :: [(Text, Text)] -> PaintStyle -> PaintStyle+applyProperties props s0 = foldl step s0 props+  where+    step s (k, v) = case k of+      "fill" -> s {psFill = Just (parsePaint v)}+      "stroke" -> s {psStroke = Just (parsePaint v)}+      "stroke-width" -> maybe s (\w -> s {psStrokeWidth = max 0 w}) (length1 v)+      "stroke-linecap" -> case v of+        "round" -> s {psCap = CapRound}+        "square" -> s {psCap = CapSquare}+        _ -> s {psCap = CapButt}+      "stroke-linejoin" -> case v of+        "round" -> s {psJoin = JoinRound}+        "bevel" -> s {psJoin = JoinBevel}+        _ -> s {psJoin = JoinMiter}+      "stroke-miterlimit" -> maybe s (\l -> s {psMiterLimit = max 1 l}) (number1 v)+      "fill-rule" -> s {psRule = if v == "evenodd" then EvenOdd else NonZero}+      "fill-opacity" -> maybe s (\o -> s {psFillOpacity = clamp01 o}) (number1 v)+      "stroke-opacity" -> maybe s (\o -> s {psStrokeOpacity = clamp01 o}) (number1 v)+      _ -> s+++parsePaint :: Text -> Paint+parsePaint raw+  | v == "none" || v == "transparent" = PaintNone+  | v == "currentcolor" = PaintCurrent+  | Just hex <- T.stripPrefix "#" v = maybe PaintNone PaintColor (hexColor hex)+  | Just args <- T.stripPrefix "rgb(" v = case numberList (T.takeWhile (/= ')') args) of+      [r, g, b] -> PaintColor (colorRGBA (channel r) (channel g) (channel b) 255)+      _ -> PaintNone+  | otherwise = maybe (PaintColor (colorRGBA 0 0 0 255)) PaintColor (lookup v namedColors)+  where+    v = T.toLower (T.strip raw)+    channel x = fromIntegral (max 0 (min 255 (round x :: Int)))+    hexColor h = case T.unpack h of+      [r, g, b] -> rgb (hex2 r r) (hex2 g g) (hex2 b b)+      [r1, r2, g1, g2, b1, b2] -> rgb (hex2 r1 r2) (hex2 g1 g2) (hex2 b1 b2)+      _ -> Nothing+    rgb (Just r) (Just g) (Just b) = Just (colorRGBA r g b 255)+    rgb _ _ _ = Nothing+    hex2 a b = (\x y -> fromIntegral (x * 16 + y)) <$> hexDigit a <*> hexDigit b+    hexDigit c+      | isDigit c = Just (fromEnum c - fromEnum '0')+      | c >= 'a' && c <= 'f' = Just (fromEnum c - fromEnum 'a' + 10)+      | otherwise = Nothing++namedColors :: [(Text, Color)]+namedColors =+  [ ("black", colorRGBA 0 0 0 255)+  , ("white", colorRGBA 255 255 255 255)+  , ("red", colorRGBA 255 0 0 255)+  , ("green", colorRGBA 0 128 0 255)+  , ("lime", colorRGBA 0 255 0 255)+  , ("blue", colorRGBA 0 0 255 255)+  , ("yellow", colorRGBA 255 255 0 255)+  , ("orange", colorRGBA 255 165 0 255)+  , ("purple", colorRGBA 128 0 128 255)+  , ("gray", colorRGBA 128 128 128 255)+  , ("grey", colorRGBA 128 128 128 255)+  , ("silver", colorRGBA 192 192 192 255)+  , ("navy", colorRGBA 0 0 128 255)+  , ("teal", colorRGBA 0 128 128 255)+  , ("maroon", colorRGBA 128 0 0 255)+  , ("olive", colorRGBA 128 128 0 255)+  , ("aqua", colorRGBA 0 255 255 255)+  , ("cyan", colorRGBA 0 255 255 255)+  , ("fuchsia", colorRGBA 255 0 255 255)+  , ("magenta", colorRGBA 255 0 255 255)+  ]++--------------------------------------------------------------------------------+-- Numbers, transforms and path data+--------------------------------------------------------------------------------++-- | Numbers separated by spaces or commas, stopping at the first thing that+-- is not a number.+numberList :: Text -> [Float]+numberList t0 = go (skipSep t0)+  where+    go t = case readNumber t of+      Just (x, rest) -> x : go (skipSep rest)+      Nothing -> []++skipSep :: Text -> Text+skipSep = T.dropWhile (\c -> isSpace c || c == ',')++-- | A number at the start of the text, allowing @.5@, @-.5e-3@ and a+-- following number that starts with a sign or a second decimal point.+readNumber :: Text -> Maybe (Float, Text)+readNumber t =+  let (sign, t1) = case T.uncons t of+        Just (c, r) | c == '-' || c == '+' -> (T.singleton c, r)+        _ -> (T.empty, t)+      intPart = T.takeWhile isDigit t1+      afterInt = T.drop (T.length intPart) t1+      (fracPart, afterFrac) = case T.uncons afterInt of+        Just ('.', r) -> let ds = T.takeWhile isDigit r in (T.cons '.' ds, T.drop (T.length ds) r)+        _ -> (T.empty, afterInt)+      (expPart, rest) = case T.uncons afterFrac of+        Just (e, r)+          | e == 'e' || e == 'E' ->+              let (esign, r1) = case T.uncons r of+                    Just (c, r') | c == '-' || c == '+' -> (T.singleton c, r')+                    _ -> (T.empty, r)+                  eds = T.takeWhile isDigit r1+               in if T.null eds then (T.empty, afterFrac) else (T.concat ["e", esign, eds], T.drop (T.length eds) r1)+        _ -> (T.empty, afterFrac)+      mantissa = intPart <> fracPart+   in if T.null (T.filter isDigit mantissa)+        then Nothing+        else case TR.signed TR.rational (T.concat [sign, if T.null intPart then "0" else "", mantissa, expPart]) of+          Right (x, _) -> Just (realToFrac (x :: Double), rest)+          Left _ -> Nothing++number1 :: Text -> Maybe Float+number1 t = fst <$> readNumber (T.strip t)++-- | A length in user units: a number with an optional @px@. Percentages and+-- other units are not lengths here.+length1 :: Text -> Maybe Float+length1 t = case readNumber (T.strip t) of+  Just (x, rest) | T.null rest || rest == "px" -> Just x+  _ -> Nothing++parseTransform :: Text -> Matrix+parseTransform t0 = go identity (T.stripStart t0)+  where+    go m t+      | T.null t = m+      | otherwise =+          let (name, rest) = T.span isAlpha t+              (args, rest') = T.breakOn ")" (T.drop 1 (T.dropWhile (/= '(') rest))+              next = T.dropWhile (\c -> isSpace c || c == ',') (T.drop 1 rest')+              m' = case (name, numberList args) of+                ("matrix", [a, b, c, d, e, f]) -> Matrix a b c d e f+                ("translate", [x]) -> Matrix 1 0 0 1 x 0+                ("translate", [x, y]) -> Matrix 1 0 0 1 x y+                ("scale", [s]) -> Matrix s 0 0 s 0 0+                ("scale", [sx, sy]) -> Matrix sx 0 0 sy 0 0+                ("rotate", [a]) -> rotation a+                ("rotate", [a, cx, cy]) -> Matrix 1 0 0 1 cx cy `mul` rotation a `mul` Matrix 1 0 0 1 (-cx) (-cy)+                ("skewX", [a]) -> Matrix 1 0 (tan (a * pi / 180)) 1 0 0+                ("skewY", [a]) -> Matrix 1 (tan (a * pi / 180)) 0 1 0 0+                _ -> identity+           in if T.null name then m else go (m `mul` m') next+    rotation a =+      let r = a * pi / 180+       in Matrix (cos r) (sin r) (negate (sin r)) (cos r) 0 0++-- | Path data as absolute segments. Parsing stops at the first error, keeping+-- what came before, as renderers do.+parsePath :: Text -> [Segment]+parsePath = go 'M' (P 0 0) (P 0 0) Nothing . skipSep+  where+    -- cmd: the current (repeatable) command; cur: the current point; start:+    -- the subpath start; ctrl: the last control point, for S and T.+    go cmd cur start ctrl t = case T.uncons t of+      Nothing -> []+      Just (c, rest)+        | isAlpha c && c /= 'e' && c /= 'E' ->+            if toLower c == 'z'+              then ClosePath : go (if c == 'z' then 'm' else 'M') start start Nothing (skipSep rest)+              else run c cur start ctrl (skipSep rest)+        | otherwise -> run cmd cur start ctrl t+    run cmd cur@(P cx cy) start ctrl t =+      let rel = cmd >= 'a'+          pt (P x y) = if rel then P (cx + x) (cy + y) else P x y+          nums n = takeNumbers n t+       in case toLower cmd of+            'm' -> case nums 2 of+              Just ([x, y], r) ->+                let p = pt (P x y)+                 in MoveTo p : go (if rel then 'l' else 'L') p p Nothing (skipSep r)+              _ -> []+            'l' -> case nums 2 of+              Just ([x, y], r) -> let p = pt (P x y) in LineTo p : go cmd p start Nothing (skipSep r)+              _ -> []+            'h' -> case nums 1 of+              Just ([x], r) -> let p = P (if rel then cx + x else x) cy in LineTo p : go cmd p start Nothing (skipSep r)+              _ -> []+            'v' -> case nums 1 of+              Just ([y], r) -> let p = P cx (if rel then cy + y else y) in LineTo p : go cmd p start Nothing (skipSep r)+              _ -> []+            'c' -> case nums 6 of+              Just ([x1, y1, x2, y2, x, y], r) ->+                let c2 = pt (P x2 y2)+                    p = pt (P x y)+                 in CubicTo (pt (P x1 y1)) c2 p : go cmd p start (Just c2) (skipSep r)+              _ -> []+            's' -> case nums 4 of+              Just ([x2, y2, x, y], r) ->+                let c1 = maybe cur (reflect cur) ctrl+                    c2 = pt (P x2 y2)+                    p = pt (P x y)+                 in CubicTo c1 c2 p : go cmd p start (Just c2) (skipSep r)+              _ -> []+            'q' -> case nums 4 of+              Just ([x1, y1, x, y], r) ->+                let c1 = pt (P x1 y1)+                    p = pt (P x y)+                 in QuadTo c1 p : go cmd p start (Just c1) (skipSep r)+              _ -> []+            't' -> case nums 2 of+              Just ([x, y], r) ->+                let c1 = maybe cur (reflect cur) ctrl+                    p = pt (P x y)+                 in QuadTo c1 p : go cmd p start (Just c1) (skipSep r)+              _ -> []+            'a' -> case arcArgs t of+              Just ((rx, ry, rot, large, sweep, x, y), r) ->+                let p = pt (P x y)+                 in ArcTo rx ry rot large sweep p : go cmd p start Nothing (skipSep r)+              _ -> []+            _ -> []+    reflect (P cx cy) (P x y) = P (2 * cx - x) (2 * cy - y)+    takeNumbers :: Int -> Text -> Maybe ([Float], Text)+    takeNumbers 0 t = Just ([], t)+    takeNumbers n t = do+      (x, rest) <- readNumber t+      (xs, rest') <- takeNumbers (n - 1) (skipSep rest)+      pure (x : xs, rest')+    -- Arc flags may be written without separators: @a1 1 0 00.5.5@.+    arcArgs t = do+      (rx, r1) <- readNumber t+      (ry, r2) <- readNumber (skipSep r1)+      (rot, r3) <- readNumber (skipSep r2)+      (large, r4) <- flag (skipSep r3)+      (sweep, r5) <- flag (skipSep r4)+      (x, r6) <- readNumber (skipSep r5)+      (y, r7) <- readNumber (skipSep r6)+      pure ((rx, ry, rot, large, sweep, x, y), r7)+    flag t = case T.uncons t of+      Just ('0', r) -> Just (False, r)+      Just ('1', r) -> Just (True, r)+      _ -> Nothing++rectSegments :: Float -> Float -> Float -> Float -> Maybe Float -> Maybe Float -> [Segment]+rectSegments x y w h mrx mry+  | w <= 0 || h <= 0 = []+  | rx <= 0 || ry <= 0 = [MoveTo (P x y), LineTo (P (x + w) y), LineTo (P (x + w) (y + h)), LineTo (P x (y + h)), ClosePath]+  | otherwise =+      [ MoveTo (P (x + rx) y)+      , LineTo (P (x + w - rx) y)+      , ArcTo rx ry 0 False True (P (x + w) (y + ry))+      , LineTo (P (x + w) (y + h - ry))+      , ArcTo rx ry 0 False True (P (x + w - rx) (y + h))+      , LineTo (P (x + rx) (y + h))+      , ArcTo rx ry 0 False True (P x (y + h - ry))+      , LineTo (P x (y + ry))+      , ArcTo rx ry 0 False True (P (x + rx) y)+      , ClosePath+      ]+  where+    rx = min (w / 2) (fromMaybe (fromMaybe 0 mry) mrx)+    ry = min (h / 2) (fromMaybe (fromMaybe 0 mrx) mry)++ellipseSegments :: Float -> Float -> Float -> Float -> [Segment]+ellipseSegments cx cy rx ry+  | rx <= 0 || ry <= 0 = []+  | otherwise =+      [ MoveTo (P (cx + rx) cy)+      , ArcTo rx ry 0 False True (P (cx - rx) cy)+      , ArcTo rx ry 0 False True (P (cx + rx) cy)+      , ClosePath+      ]++polySegments :: Bool -> Text -> [Segment]+polySegments closed pts = case pairs (numberList pts) of+  [] -> []+  p : ps -> MoveTo p : map LineTo ps ++ [ClosePath | closed]+  where+    pairs (x : y : rest) = P x y : pairs rest+    pairs _ = []++--------------------------------------------------------------------------------+-- Rings+--------------------------------------------------------------------------------++-- | Point lists in flat arrays: ring @i@ is points @starts[i]@ up to+-- @starts[i + 1]@, stored x then y, with a number the builder tagged it with.+data Rings = Rings !(PrimArray Float) !(PrimArray Int) !(PrimArray Int)++ringCount :: Rings -> Int+ringCount (Rings _ starts _) = sizeofPrimArray starts - 1++-- | Rings from a walk that calls @point x y@ for each point and @end tag@+-- after each ring's last. The walk runs twice, to size the arrays and then+-- to fill them, so it must visit the same points both times.+{-# INLINE buildRings #-}+buildRings :: (forall s. (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()) -> Rings+buildRings walk = runST $ do+  counts <- newPrimArray 2+  setPrimArray counts 0 2 (0 :: Int)+  let bump k = readPrimArray counts k >>= writePrimArray counts k . (+ 1)+  walk (\_ _ -> bump 0) (\_ -> bump 1)+  nPoints <- readPrimArray counts 0+  nRings <- readPrimArray counts 1+  points <- newPrimArray (2 * nPoints)+  starts <- newPrimArray (nRings + 1)+  tags <- newPrimArray nRings+  writePrimArray starts 0 0+  setPrimArray counts 0 2 0+  walk+    ( \x y -> do+        k <- readPrimArray counts 0+        writePrimArray points (2 * k) x+        writePrimArray points (2 * k + 1) y+        writePrimArray counts 0 (k + 1)+    )+    ( \tag -> do+        r <- readPrimArray counts 1+        readPrimArray counts 0 >>= writePrimArray starts (r + 1)+        writePrimArray tags r tag+        writePrimArray counts 1 (r + 1)+    )+  Rings <$> unsafeFreezePrimArray points <*> unsafeFreezePrimArray starts <*> unsafeFreezePrimArray tags++--------------------------------------------------------------------------------+-- Flattening+--------------------------------------------------------------------------------++-- | Flatten segments through a transform into contours in device pixels,+-- each tagged 1 when closed. Curves are split until they are within a+-- quarter pixel of their chords.+flatten :: Matrix -> SmallArray Segment -> Rings+flatten m segs = buildRings (flattenWalk m segs)++{-# INLINE flattenWalk #-}+flattenWalk :: Matrix -> SmallArray Segment -> (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()+flattenWalk m segs point end =+  let count = sizeofSmallArray segs+      emit p = let P x y = apply m p in point x y+      finish n closed = when (n > 0) (end (if closed then 1 else 0))+      -- A segment with no subpath open starts one at the current point.+      begin n started cur = if started || n > 0 then pure n else emit cur >> pure (1 :: Int)+      go !i !n !started cur start+        | i >= count = finish n False+        | otherwise = case indexSmallArray segs i of+            MoveTo p -> finish n False >> emit p >> go (i + 1) 1 True p p+            LineTo p -> do+              n1 <- begin n started cur+              emit p+              go (i + 1) (n1 + 1) True p start+            CubicTo c1 c2 p -> do+              n1 <- begin n started cur+              k <- cubicPoints point (apply m cur) (apply m c1) (apply m c2) (apply m p)+              go (i + 1) (n1 + k) True p start+            QuadTo c1 p -> do+              n1 <- begin n started cur+              let P x0 y0 = cur+                  P x1 y1 = c1+                  P x2 y2 = p+                  q1 = P (x0 + 2 / 3 * (x1 - x0)) (y0 + 2 / 3 * (y1 - y0))+                  q2 = P (x2 + 2 / 3 * (x1 - x2)) (y2 + 2 / 3 * (y1 - y2))+              k <- cubicPoints point (apply m cur) (apply m q1) (apply m q2) (apply m p)+              go (i + 1) (n1 + k) True p start+            ArcTo rx ry rot large sweep p -> do+              n1 <- begin n started cur+              k <- arcPoints emit cur rx ry rot large sweep p+              go (i + 1) (n1 + k) True p start+            ClosePath -> finish n True >> go (i + 1) 0 False start start+   in go 0 0 False (P 0 0) (P 0 0)++-- | The points after the start of a cubic, subdividing by flatness, and how+-- many there were.+{-# INLINE cubicPoints #-}+cubicPoints :: (Float -> Float -> ST s ()) -> P -> P -> P -> P -> ST s Int+cubicPoints point = go (0 :: Int)+  where+    go depth a b c d+      | depth >= 12 || flat a b c d = let P x y = d in point x y >> pure 1+      | otherwise = do+          let ab = mid a b+              bc = mid b c+              cd = mid c d+              abc = mid ab bc+              bcd = mid bc cd+              abcd = mid abc bcd+          k1 <- go (depth + 1) a ab abc abcd+          k2 <- go (depth + 1) abcd bcd cd d+          pure (k1 + k2)+    mid (P x0 y0) (P x1 y1) = P ((x0 + x1) / 2) ((y0 + y1) / 2)+    flat (P x0 y0) (P x1 y1) (P x2 y2) (P x3 y3) =+      let ux = 3 * x1 - 2 * x0 - x3+          uy = 3 * y1 - 2 * y0 - y3+          vx = 3 * x2 - 2 * x3 - x0+          vy = 3 * y2 - 2 * y3 - y0+       in max (ux * ux) (vx * vx) + max (uy * uy) (vy * vy) <= 16 * 0.25 * 0.25++-- | The points after the start of an SVG arc, by the endpoint-to-centre+-- conversion in the SVG specification, in user space, and how many there+-- were.+{-# INLINE arcPoints #-}+arcPoints :: (P -> ST s ()) -> P -> Float -> Float -> Float -> Bool -> Bool -> P -> ST s Int+arcPoints emit (P x1 y1) rx0 ry0 rotDeg large sweep (P x2 y2)+  | rx0 == 0 || ry0 == 0 || (x1 == x2 && y1 == y2) = emit (P x2 y2) >> pure 1+  | otherwise = do+      forM_ [1 .. steps - 1] $ \i -> emit (pointAt i)+      emit (P x2 y2)+      pure steps+  where+    phi = rotDeg * pi / 180+    cosP = cos phi+    sinP = sin phi+    dx = (x1 - x2) / 2+    dy = (y1 - y2) / 2+    x1' = cosP * dx + sinP * dy+    y1' = negate sinP * dx + cosP * dy+    lambda = (x1' * x1') / (rx0 * rx0) + (y1' * y1') / (ry0 * ry0)+    scale = if lambda > 1 then sqrt lambda else 1+    rx = abs rx0 * scale+    ry = abs ry0 * scale+    num = rx * rx * ry * ry - rx * rx * y1' * y1' - ry * ry * x1' * x1'+    den = rx * rx * y1' * y1' + ry * ry * x1' * x1'+    coef = (if large == sweep then -1 else 1) * sqrt (max 0 (num / den))+    cx' = coef * rx * y1' / ry+    cy' = coef * negate (ry * x1' / rx)+    cx = cosP * cx' - sinP * cy' + (x1 + x2) / 2+    cy = sinP * cx' + cosP * cy' + (y1 + y2) / 2+    angle ux uy vx vy = atan2 (ux * vy - uy * vx) (ux * vx + uy * vy)+    theta1 = angle 1 0 ((x1' - cx') / rx) ((y1' - cy') / ry)+    dtheta0 = angle ((x1' - cx') / rx) ((y1' - cy') / ry) ((negate x1' - cx') / rx) ((negate y1' - cy') / ry)+    dtheta+      | not sweep && dtheta0 > 0 = dtheta0 - 2 * pi+      | sweep && dtheta0 < 0 = dtheta0 + 2 * pi+      | otherwise = dtheta0+    steps = max 4 (ceiling (abs dtheta / (pi / 16)) :: Int)+    pointAt i =+      let t = theta1 + dtheta * fromIntegral i / fromIntegral steps+          ex = rx * cos t+          ey = ry * sin t+       in P (cosP * ex - sinP * ey + cx) (sinP * ex + cosP * ey + cy)++--------------------------------------------------------------------------------+-- Stroking+--------------------------------------------------------------------------------++-- | Polygons covering a stroke of width @w@ along the contours, each wound+-- counter-clockwise so a non-zero fill of all of them is their union.+strokePolygons :: Float -> LineCap -> LineJoin -> Float -> Rings -> Rings+strokePolygons w cap join miterLimit contours = buildRings (strokeWalk w cap join miterLimit contours)++{-# INLINE strokeWalk #-}+strokeWalk :: Float -> LineCap -> LineJoin -> Float -> Rings -> (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()+strokeWalk w cap join miterLimit contours@(Rings cpts cstarts ctags) point end =+  let hw = w / 2+      at k = P (indexPrimArray cpts (2 * k)) (indexPrimArray cpts (2 * k + 1))+      close (P x0 y0) (P x1 y1) = abs (x0 - x1) < 1e-4 && abs (y0 - y1) < 1e-4+      emitP (P x y) = point x y+      -- Twice the signed area of a polygon's corners, positive when they+      -- wind counter-clockwise.+      turn (P x0 y0) (P x1 y1) = x0 * y1 - x1 * y0+      -- A triangle or quad in the order given, or reversed when that winds+      -- clockwise.+      triangle a b c = do+        if turn a b + turn b c + turn c a < 0+          then emitP c >> emitP b >> emitP a+          else emitP a >> emitP b >> emitP c+        end 0+      quad a b c d = do+        if turn a b + turn b c + turn c d + turn d a < 0+          then emitP d >> emitP c >> emitP b >> emitP a+          else emitP a >> emitP b >> emitP c >> emitP d+        end 0+      normal (P x0 y0) (P x1 y1) =+        let dx = x1 - x0+            dy = y1 - y0+            len = max 1e-6 (sqrt (dx * dx + dy * dy))+         in (negate dy / len * hw, dx / len * hw)+      segmentQuad a@(P ax ay) b@(P bx by) = do+        let (nx, ny) = normal a b+        -- The quad winds clockwise as built, whatever its direction.+        emitP (P (ax - nx) (ay - ny))+        emitP (P (bx - nx) (by - ny))+        emitP (P (bx + nx) (by + ny))+        emitP (P (ax + nx) (ay + ny))+        end 0+      corner prev v@(P vx vy) next = do+        let (n1x, n1y) = normal prev v+            (n2x, n2y) = normal v next+            bevel = do+              triangle v (P (vx + n1x) (vy + n1y)) (P (vx + n2x) (vy + n2y))+              triangle v (P (vx - n1x) (vy - n1y)) (P (vx - n2x) (vy - n2y))+        case join of+          JoinRound -> disc v+          JoinBevel -> bevel+          JoinMiter -> do+            let mx = n1x + n2x+                my = n1y + n2y+                mlen2 = mx * mx + my * my+                -- The miter point sits along the bisector at hw / cos(half angle).+                scale = if mlen2 < 1e-9 then 0 else 2 * hw * hw / mlen2+                ratio = if mlen2 < 1e-9 then 1 / 0 else sqrt (scale * scale * mlen2) / hw+            if ratio > miterLimit+              then bevel+              else do+                quad v (P (vx + n1x) (vy + n1y)) (P (vx + mx * scale) (vy + my * scale)) (P (vx + n2x) (vy + n2y))+                quad v (P (vx - n1x) (vy - n1y)) (P (vx - mx * scale) (vy - my * scale)) (P (vx - n2x) (vy - n2y))+      endCap inner@(P ix iy) e@(P ex ey) = case cap of+        CapButt -> pure ()+        CapRound -> disc e+        CapSquare -> do+          let dx = ex - ix+              dy = ey - iy+              len = max 1e-6 (sqrt (dx * dx + dy * dy))+              ux = dx / len * hw+              uy = dy / len * hw+              (nx, ny) = normal inner e+          -- Wound clockwise as built, like a segment's quad.+          emitP (P (ex - nx) (ey - ny))+          emitP (P (ex - nx + ux) (ey - ny + uy))+          emitP (P (ex + nx + ux) (ey + ny + uy))+          emitP (P (ex + nx) (ey + ny))+          end 0+      disc (P cx cy) = do+        let n = max 8 (min 48 (ceiling (hw * 2.5) :: Int))+        forM_ [0 .. n - 1] $ \i ->+          let t = 2 * pi * fromIntegral i / fromIntegral n in point (cx + hw * cos t) (cy + hw * sin t)+        end 0+      square (P cx cy) = do+        emitP (P (cx - hw) (cy - hw))+        emitP (P (cx + hw) (cy - hw))+        emitP (P (cx + hw) (cy + hw))+        emitP (P (cx - hw) (cy + hw))+        end 0+      contour r = do+        let from = indexPrimArray cstarts r+            to = indexPrimArray cstarts (r + 1)+            closed = indexPrimArray ctags r /= 0+        -- The contour's points, dropping any that repeat the one before.+        kept <- newPrimArray (to - from)+        let dedupe !k !n+              | k >= to = pure n+              | n > 0 = do+                  prevK <- readPrimArray kept (n - 1)+                  if close (at prevK) (at k)+                    then dedupe (k + 1) n+                    else writePrimArray kept n k >> dedupe (k + 1) (n + 1)+              | otherwise = writePrimArray kept 0 k >> dedupe (k + 1) 1+        n0 <- dedupe from 0+        firstK <- readPrimArray kept 0+        lastK <- readPrimArray kept (max 0 (n0 - 1))+        -- A closed contour that returns to its start ends on that point.+        let n = if closed && n0 >= 2 && close (at firstK) (at lastK) then n0 - 1 else n0+            pt i = at <$> readPrimArray kept i+        case n of+          0 -> pure ()+          1 -> do+            p <- pt 0+            when (cap == CapRound) (disc p)+            when (cap == CapSquare) (square p)+          _ -> do+            forM_ [0 .. n - 2] $ \i -> do+              a <- pt i+              b <- pt (i + 1)+              segmentQuad a b+            when closed $ do+              a <- pt (n - 1)+              b <- pt 0+              segmentQuad a b+            let cornerAt i = do+                  prev <- pt ((i - 1 + n) `mod` n)+                  v <- pt i+                  next <- pt ((i + 1) `mod` n)+                  corner prev v next+            if closed+              then forM_ [0 .. n - 1] cornerAt+              else forM_ [1 .. n - 2] cornerAt+            unless closed $ do+              first <- pt 0+              second <- pt 1+              beforeLast <- pt (n - 2)+              final <- pt (n - 1)+              endCap second first+              endCap beforeLast final+   in forM_ [0 .. ringCount contours - 1] contour++--------------------------------------------------------------------------------+-- Rasterizing+--------------------------------------------------------------------------------++-- | Render the document into a @width@ by @height@ RGBA image (rows top to+-- bottom), scaled to fit and centred as SVG's default @xMidYMid meet@ does.+-- @current@ is what @currentColor@, and an unspecified fill, paint with.+rasterizeSvg :: Int -> Int -> Color -> Svg -> ByteString+rasterizeSvg width height current svg+  | width <= 0 || height <= 0 = BS.empty+  | otherwise = BSI.unsafeCreate (width * height * 4) $ \out ->+      forM_ [0 .. width * height - 1] $ \i -> do+        let al = indexPrimArray image (i * 4 + 3)+            byte x = fromIntegral (max 0 (min 255 (round (x * 255) :: Int))) :: Word8+            unpremul k = pokeByteOff out (i * 4 + k) (if al <= 0 then 0 else byte (indexPrimArray image (i * 4 + k) / al))+        unpremul 0+        unpremul 1+        unpremul 2+        pokeByteOff out (i * 4 + 3) (byte al)+  where+    image = runST $ do+      -- Premultiplied RGBA in [0, 1].+      acc <- newPrimArray (width * height * 4)+      setPrimArray acc 0 (width * height * 4) (0 :: Float)+      cov <- newPrimArray (width * height)+      let Box vx vy vw vh = svgViewBox svg+          s = min (fromIntegral width / vw) (fromIntegral height / vh)+          tx = (fromIntegral width - vw * s) / 2 - vx * s+          ty = (fromIntegral height - vh * s) / 2 - vy * s+          view = Matrix s 0 0 s tx ty+      forM_ (svgShapes svg) $ \(Shape segs m style) -> do+        let full = view `mul` m+            contours = flatten full segs+            Matrix a b c d _ _ = full+            scaleOf = sqrt (abs (a * d - b * c))+            opacity = psOpacity style+            paintColor p = case p of+              PaintNone -> Nothing+              PaintCurrent -> Just current+              PaintColor col -> Just col+            -- An unspecified fill paints black, or the current colour in a+            -- monochrome document, so an icon without paints tints.+            fill = fromMaybe (if svgMonochrome svg then PaintCurrent else PaintColor (colorRGBA 0 0 0 255)) (psFill style)+        forM_ (paintColor fill) $ \col -> do+          coverPolygons width height cov (psRule style) contours+          composite width height acc cov col (opacity * psFillOpacity style)+        forM_ (paintColor (fromMaybe PaintNone (psStroke style))) $ \col ->+          when (psStrokeWidth style > 0) $ do+            let wanted = psStrokeWidth style * scaleOf+                w = max 1 wanted+                polys = strokePolygons w (psCap style) (psJoin style) (psMiterLimit style) contours+            coverPolygons width height cov NonZero polys+            -- A hairline thinner than a pixel keeps its weight as opacity.+            composite width height acc cov col (opacity * psStrokeOpacity style * min 1 (wanted / w))+      unsafeFreezePrimArray acc++-- | Coverage of the rings with at least three points in @cov@ (cleared+-- first): five sample rows a pixel, each span's coverage split exactly+-- across the pixels it crosses.+--+-- Edges are counted per pixel row they start in and then written in row+-- order, so the sweep down the rows admits each row's edges as a block,+-- drops an edge past its bottom, and insertion sorts a row's few crossings+-- in a scratch array.+coverPolygons :: Int -> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()+coverPolygons width height cov rule rings@(Rings pts starts _) = do+  setPrimArray cov 0 (width * height) 0+  let capacity = sizeofPrimArray pts `div` 2+      -- Each edge that can cover a row: its first row, top, bottom, x at the+      -- top, slope and winding.+      {-# INLINE forEdges #-}+      forEdges :: (Int -> Float -> Float -> Float -> Float -> Int -> ST s ()) -> ST s ()+      forEdges visit =+        forM_ [0 .. ringCount rings - 1] $ \r -> do+          let from = indexPrimArray starts r+              to = indexPrimArray starts (r + 1)+          when (to - from >= 3) $+            forM_ [from .. to - 1] $ \k -> do+              let k' = if k + 1 == to then from else k + 1+                  ax = indexPrimArray pts (2 * k)+                  ay = indexPrimArray pts (2 * k + 1)+                  bx = indexPrimArray pts (2 * k')+                  by = indexPrimArray pts (2 * k' + 1)+                  up = ay < by+                  x0 = if up then ax else bx+                  y0 = if up then ay else by+                  x1 = if up then bx else ax+                  y1 = if up then by else ay+              when (ay /= by && y1 > 0 && y0 < fromIntegral height) $+                visit (max 0 (floor y0)) y0 y1 x0 ((x1 - x0) / (y1 - y0)) (if up then 1 else -1)+  -- Where each row's edges begin: counts, then running totals.+  rowStart <- newPrimArray (height + 1)+  setPrimArray rowStart 0 (height + 1) (0 :: Int)+  forEdges $ \row _ _ _ _ _ -> readPrimArray rowStart (row + 1) >>= writePrimArray rowStart (row + 1) . (+ 1)+  forM_ [1 .. height] $ \row -> do+    before <- readPrimArray rowStart (row - 1)+    readPrimArray rowStart row >>= writePrimArray rowStart row . (+ before)+  -- Four numbers an edge, in row order: top, bottom, x at the top, slope;+  -- windings apart.+  edges <- newPrimArray (capacity * 4)+  windings <- newPrimArray capacity+  cursor <- newPrimArray height+  copyMutablePrimArray cursor 0 rowStart 0 height+  forEdges $ \row y0 y1 x0 slope dir -> do+    e <- readPrimArray cursor row+    writePrimArray cursor row (e + 1)+    writePrimArray edges (e * 4) y0+    writePrimArray edges (e * 4 + 1) y1+    writePrimArray edges (e * 4 + 2) x0+    writePrimArray edges (e * 4 + 3) slope+    writePrimArray windings e (dir :: Int)+  totalEdges <- readPrimArray rowStart height+  active <- newPrimArray capacity+  crossX <- newPrimArray capacity+  crossDir <- newPrimArray capacity+  let samples = 5 :: Int+      weight = 1 / fromIntegral samples :: Float+      inside :: Int -> Bool+      inside w = case rule of+        NonZero -> w /= 0+        EvenOdd -> odd w+      add i v = readPrimArray cov i >>= \c -> writePrimArray cov i (c + v)+      spanCover base xa0 xb0 = do+        let xa = max 0 (min (fromIntegral width) xa0)+            xb = max 0 (min (fromIntegral width) xb0)+        when (xb > xa) $ do+          let ia = floor xa :: Int+              ib = min (width - 1) (floor xb)+          if ia == ib+            then add (base + ia) ((xb - xa) * weight)+            else do+              add (base + ia) ((fromIntegral (ia + 1) - xa) * weight)+              forM_ [ia + 1 .. ib - 1] $ \i -> add (base + i) weight+              when (ib < width) $ add (base + ib) ((xb - fromIntegral ib) * weight)+      -- The row's edges join the active list.+      admit !e !stop !n+        | e >= stop = pure n+        | otherwise = writePrimArray active n e >> admit (e + 1) stop (n + 1)+      -- A crossing goes where it sorts among the @j@ before it.+      insertCrossing !j !x !d+        | j > 0 = do+            xj <- readPrimArray crossX (j - 1)+            if xj > x+              then do+                writePrimArray crossX j xj+                readPrimArray crossDir (j - 1) >>= writePrimArray crossDir j+                insertCrossing (j - 1) x d+              else writePrimArray crossX j x >> writePrimArray crossDir j (d :: Int)+        | otherwise = writePrimArray crossX 0 x >> writePrimArray crossDir 0 d+      walk !base !crossings !k !w+        | k + 1 >= crossings = pure ()+        | otherwise = do+            d <- readPrimArray crossDir k+            let w' = w + d+            when (inside w') $ do+              xa <- readPrimArray crossX k+              xb <- readPrimArray crossX (k + 1)+              spanCover base xa xb+            walk base crossings (k + 1) w'+      -- One sample row: drop edges above it, collect the crossings of the+      -- rest, then cover the spans inside the fill.+      sample !r !si !n !a !kept !crossings+        | a < n = do+            e <- readPrimArray active a+            let sy = fromIntegral r + (fromIntegral si + 0.5) * weight+            y1 <- readPrimArray edges (e * 4 + 1)+            if y1 <= sy+              then sample r si n (a + 1) kept crossings+              else do+                writePrimArray active kept e+                y0 <- readPrimArray edges (e * 4)+                if sy < y0+                  then sample r si n (a + 1) (kept + 1) crossings+                  else do+                    x0 <- readPrimArray edges (e * 4 + 2)+                    slope <- readPrimArray edges (e * 4 + 3)+                    d <- readPrimArray windings e+                    insertCrossing crossings (x0 + (sy - y0) * slope) d+                    sample r si n (a + 1) (kept + 1) (crossings + 1)+        | otherwise = do+            walk (r * width) crossings 0 0+            if si + 1 < samples+              then sample r (si + 1) kept 0 0 0+              else rows (r + 1) kept+      rows !r !n+        | r >= height = pure ()+        | otherwise = do+            from <- readPrimArray rowStart r+            to <- readPrimArray rowStart (r + 1)+            -- Past the last edge's bottom nothing is left to cover.+            if n == 0 && from >= totalEdges+              then pure ()+              else admit from to n >>= \n' -> sample r 0 n' 0 0 0+  rows 0 0++-- | Draw @col@ at @alpha@ through the coverage over the accumulated image.+composite :: Int -> Int -> MutablePrimArray s Float -> MutablePrimArray s Float -> Color -> Float -> ST s ()+composite width height acc cov col alpha =+  forM_ [0 .. width * height - 1] $ \i -> do+    c <- readPrimArray cov i+    when (c > 0) $ do+      let sa = min 1 c * alpha * fromIntegral (colorA col) / 255+          blend k src = do+            dst <- readPrimArray acc (i * 4 + k)+            writePrimArray acc (i * 4 + k) (src * sa + dst * (1 - sa))+      blend 0 (fromIntegral (colorR col) / 255)+      blend 1 (fromIntegral (colorG col) / 255)+      blend 2 (fromIntegral (colorB col) / 255)+      dstA <- readPrimArray acc (i * 4 + 3)+      writePrimArray acc (i * 4 + 3) (sa + dstA * (1 - sa))
+ lib/NanoUI/Testing.hs view
@@ -0,0 +1,246 @@+-- | Deterministic frame execution and render inspection for tests and tools.+-- Application code should use a backend's runner, such as+-- @runSdlApp@ in @NanoUI.Backend.Sdl@, instead of this module.+module NanoUI.Testing+  ( -- * Frame+    runFrame+  , runFrameEff+  , runFrameReduce+  , runFrameReduceEff+  , needsRedraw+  , pointerDragActive+  , textFieldActive+  , floatingPanelActive+  , floatingPanelRects+  , debugPanelOpen+  , widgetNodeCount+  , pointerCursorWanted+  , cursorKindIs+  , uiCursorKind+  , UiCursorKind (..)+  , computePopupPosition+  , scrollBarLayout+  , ScrollBarLayout (..)+  , sliderTrackBounds+  , colorPickerSvSquare+  , widgetStoreBaseColor+  , widgetStoreColor+  , collectTextSpans+  , collectRasterSpans+  , collectOverlayTextSpans+  , ctxSpanBase+  , ctxSpanOverlay+  , SpanArena+  , spanArenaCount+  , foldSpanArena+    -- * Context+  , Context+  , newContext+  , newPixelContext+  , ctxTheme+  , ctxPaintFull+  , ctxFontMetrics+  , setHost+  , askHost+  , withFontMetrics+  , withMonoFontMetrics+  , withMeasureText+  , withFontResolver+  , wrapMeasureCache+  , withExternalText+  , enableMeasureCache+  , withTheme+  , setTheme+  , getTheme+  , markDirty+  , clearDirty+  , clearMeasureCache+  , isDirty+  , setWakeLoop+  , DamageRequest (..)+  , requestDamage+  , damageWidget+  , damageKey+  , damageRect+  , damagePeers+  , damageFull+  , getHotId+  , getFocusId+  , getPrevRect+  , getPrevClipRect+  , getStore+  , getScrollOffset+  , setScrollOffset+  , textInputEditActive+  , modalActive+  , overlayConsumesQuit+  , withClipboard+  , getAnimationValue+  , setAnimationValue+  , startAnimation+  , startAnimationEase+  , startAnimationEaseDelay+  , startSpring+  , anyAnimating+    -- * Images+  , registerImage+  , registerImages+  , atlasTextureId+  , atlasSnapshot+    -- * Messages+  , FrameMsg (..)+  , decodeMessages+  , reduceMessages+  , reduceUpdates+    -- * Draw+  , DrawData (..)+  , DrawCmd (..)+  , DrawOp (..)+  , drawTextBox+  , Layer (..)+  , LayerSlice (..)+  , drawCmdNull+  , drawCmdElems+  , forDrawCmdsInLayer_+  , drawCmdCount+  , vertexSize+  , indexSize+  , backdropDimTextureId+  , glyphAtlasTextureId+  , Damage (..)+  , takeDamage+  , damageIsEmpty+    -- * Effectful+  , Eff+  , runEff+  , IOE+  , type (:>)+  , askContext+  , askInput+  , Ui+  , uiIO+    -- * Compact+  , Compact+  , compactHost+  , askCompact+    -- * Text measurement+  , lineWidth+  , textIndexAtX+  , caretX+  , selectionSpans+  , textNodeFontWeight+  , textNodeFontStyle+  , textNodeTextDecoration+  ) where++import NanoUI.Compact (Compact, askCompact, compactHost)+import NanoUI.Context+  ( Context (..)+  , FrameMsg (..)+  , anyAnimating+  , atlasSnapshot+  , atlasTextureId+  , clearDirty+  , clearMeasureCache+  , ctxTheme+  , DamageRequest (..)+  , damageFull+  , damageKey+  , damagePeers+  , damageRect+  , damageWidget+  , decodeMessages+  , enableMeasureCache+  , getAnimationValue+  , getFocusId+  , getHotId+  , getPrevRect+  , getPrevClipRect+  , getScrollOffset+  , setScrollOffset+  , getStore+  , isDirty+  , markDirty+  , modalActive+  , overlayConsumesQuit+  , reduceMessages+  , reduceUpdates+  , registerImage+  , registerImages+  , requestDamage+  , setAnimationValue+  , setHost+  , setWakeLoop+  , startAnimation+  , startAnimationEase+  , startAnimationEaseDelay+  , startSpring+  , takeDamage+  , textInputEditActive+  , withClipboard+  , withExternalText+  , withFontMetrics+  , withMeasureText+  , withFontResolver+  , withMonoFontMetrics+  , withTheme+  , setTheme+  , getTheme+  , wrapMeasureCache+  )+import NanoUI.Context (newContext, newPixelHostContext)+import NanoUI.Frame.SpanArena (SpanArena, foldSpanArena, spanArenaCount)+import NanoUI.Draw+  ( DrawCmd (..)+  , DrawData (..)+  , DrawOp (..)+  , Layer (..)+  , LayerSlice (..)+  , backdropDimTextureId+  , glyphAtlasTextureId+  , drawCmdElems+  , forDrawCmdsInLayer_+  , drawCmdNull+  , drawCmdCount+  , drawTextBox+  , drawVertices+  , indexSize+  , vertexSize+  )+import NanoUI.Damage (floatingPanelRects)+import NanoUI.Font (caretX, lineWidth, selectionSpans, sliderTrackBounds, textIndexAtX)+import NanoUI.Widgets.ColorPicker+  ( colorPickerSvSquare+  , widgetStoreBaseColor+  , widgetStoreColor+  )+import NanoUI.Frame+  ( UiCursorKind (..)+  , collectOverlayTextSpans+  , collectRasterSpans+  , collectTextSpans+  , cursorKindIs+  , debugPanelOpen+  , floatingPanelActive+  , needsRedraw+  , pointerCursorWanted+  , pointerDragActive+  , runFrame+  , runFrameEff+  , runFrameReduce+  , runFrameReduceEff+  , textFieldActive+  , uiCursorKind+  , widgetNodeCount+  )+import NanoUI.Frame.Scroll (ScrollBarLayout (..), scrollBarLayout)+import NanoUI.Layout.Solve (computePopupPosition)+import NanoUI.Monad (Ui, askContext, askHost, askInput, uiIO)+import NanoUI.WidgetText (textNodeFontStyle, textNodeFontWeight, textNodeTextDecoration)+import NanoUI.Types (Damage (..), damageIsEmpty)+import Effectful (Eff, IOE, runEff, type (:>))++-- | A headless context for tests: 16px monospace metrics, the measure cache+-- on, text kept out of the vertex buffer, and the default theme.+newPixelContext :: IO Context+newPixelContext = newPixelHostContext
+ lib/NanoUI/Testing/Assert.hs view
@@ -0,0 +1,86 @@+-- | Assertion and frame helpers for the integration test suite.+--+-- Assertions count failures in a shared 'IORef' instead of aborting, so one+-- test reports every broken expectation. Each failure prints the caller's+-- source location and, where there are any, the compared values.+module NanoUI.Testing.Assert+  ( bump+  , assert+  , assertEq+  , assertGt+  , assertLt+  , withInput+  , run2Frames+  , evalUi+  , runClickReduce+  ) where++import Control.Monad (unless, when)+import Data.IORef (IORef, modifyIORef')+import Data.Typeable (Typeable)+import GHC.Stack (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)+import NanoUI (emptyInput, Input (..), NanoUI, Response (..), Size (..), V2 (..))+import NanoUI.Testing (Context, DrawData, FrameMsg, runFrame, runFrameReduce)++bump :: IORef Int -> IO ()+bump r = modifyIORef' r (+ 1)++-- | Count a failure and report where it happened.+failWith :: HasCallStack => IORef Int -> String -> IO ()+failWith r detail = do+  putStrLn ("assertion failed" <> (if null detail then "" else ": " <> detail))+  putStrLn (prettyCallStack callStack)+  bump r++assert :: HasCallStack => IORef Int -> Bool -> IO ()+assert r ok = unless ok (withFrozenCallStack (failWith r ""))++assertEq :: (HasCallStack, Eq a, Show a) => IORef Int -> a -> a -> IO ()+assertEq r a b = when (a /= b) (withFrozenCallStack (failWith r (show a <> " /= " <> show b)))++assertGt :: (HasCallStack, Ord a, Show a) => IORef Int -> a -> a -> IO ()+assertGt r a b = when (a <= b) (withFrozenCallStack (failWith r (show a <> " <= " <> show b)))++assertLt :: (HasCallStack, Ord a, Show a) => IORef Int -> a -> a -> IO ()+assertLt r a b = when (a >= b) (withFrozenCallStack (failWith r (show a <> " >= " <> show b)))++withInput :: Float -> Float -> Input+withInput w h = emptyInput {inputWindowSize = Size w h}++run2Frames :: Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)+run2Frames ctx inp ui = do+  _ <- runFrame ctx inp ui+  runFrame ctx inp ui++evalUi :: Context -> Input -> NanoUI a -> IO a+evalUi ctx inp ui = do+  (a, _, _, _) <- runFrame ctx inp ui+  pure a++runClickReduce ::+  (Typeable msg, Eq model) =>+  (msg -> model -> model)+  -> Context+  -> Input+  -> model+  -> (model -> NanoUI Response)+  -> V2+  -> IO (model, [msg], Bool)+runClickReduce reduce ctx inp0 model0 view pos = do+  let+    press =+      inp0+        { inputMousePos = pos+        , inputMouseDown = True+        , inputMousePressed = True+        , inputMouseReleased = False+        }+    release =+      press+        { inputMousePressed = False+        , inputMouseDown = False+        , inputMouseReleased = True+        }+  (_, modelP, _, _, _) <- runFrameReduce reduce ctx press model0 view+  (_, modelR, msgs, _, dirty) <- runFrameReduce reduce ctx release modelP view+  pure (modelR, msgs, dirty)
+ lib/NanoUI/Testing/Harness.hs view
@@ -0,0 +1,463 @@+-- | Shared helpers for integration tests: input gestures, spans, scroll checks.+module NanoUI.Testing.Harness+  ( clickPair+  , rightClickPair+  , pressAt+  , releaseAt+  , keyInp+  , tabInp+  , withInputOff+  , withDelta+  , centerOf+  , warmup+  , warmup2+  , warmupDraw+  , held+  , runClick+  , assertSpansHas+  , spanYOf+  , spanXOf+  , assertScrollGutterPad+  , assertWheelTitlePinned+  , findGrabHover+  , dragWindowEdge+  , vertUv+  , checkLabelAlignEndInk+  , checkIdleFullDamage+  , windowTitleGrab+  , runDragFrom+  , DemoSpan+  , spanCenter+  , hasText+  , spanLabel+  , findExact+  , findHeader+  , findRightmost+  , requireSpan+  , expectText+  , clickPos+  , clickTab+  , dragPos+  , drawQuads+  ) where++import Control.Monad (forM, unless, void, when)+import Data.IORef (IORef, readIORef, writeIORef)+import Data.Text qualified as T+import Data.Word (Word32, Word8)+import Foreign.C.Types (CSize (..))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peekByteOff)+import GHC.Stack (HasCallStack)+import NanoUI+import NanoUI.Font (alignedTextPen, textInkEnd)+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertLt, bump, withInput)++type DemoSpan = (Rect, T.Text, Color, Color, Rect)++foreign import ccall unsafe "string.h memcpy" c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()++-- | Decode the quads a frame actually rasterised: one @(rect, color)@ per+-- six-index quad, in draw order. Span and arena queries cannot see chrome+-- (scroller wells, scrollbar lanes); this can. Every rasterised op in the+-- draw arena is emitted as 4 vertices / 6 indices; a command that breaks+-- that packing fails loudly here instead of decoding garbage.+drawQuads :: DrawData -> IO [(Rect, Color)]+drawQuads dd =+  fmap concat $+    forM (drawCmdElems dd) $ \c -> do+      let ioff = fromIntegral (cmdIndexOffset c)+          icnt = fromIntegral (cmdIndexCount c)+      when (icnt `rem` 6 /= 0) $+        error ("drawQuads: draw command packs " ++ show icnt ++ " indices; not quad-packed")+      sequence+        [ decodeQuad (ioff + q)+        | q <- [0, 6 .. icnt - 1]+        ]+  where+    verts = drawVertices dd+    idxs = drawIndices dd+    peekWord32 :: Ptr Word8 -> IO Word32+    peekWord32 off = allocaBytes 4 $ \tmp -> do+      c_memcpy tmp off 4+      peekByteOff tmp 0+    peekVertex :: Ptr Word8 -> Int -> IO (Float, Float, Float, Float, Float, Float)+    peekVertex vp vi =+      allocaBytes vertexSize $ \tmp -> do+        c_memcpy tmp (vp `plusPtr` (vi * vertexSize)) (fromIntegral vertexSize)+        x <- peekByteOff tmp 0+        y <- peekByteOff tmp 4+        r <- peekByteOff tmp 8+        g <- peekByteOff tmp 12+        b <- peekByteOff tmp 16+        a <- peekByteOff tmp 20+        pure (x, y, r, g, b, a)+    decodeQuad iStart =+      withForeignPtr verts $ \vp ->+        withForeignPtr idxs $ \ip -> do+          vis <-+            forM [iStart .. iStart + 3] $ \ii -> do+              vi <- fromIntegral <$> peekWord32 (ip `plusPtr` (ii * indexSize))+              peekVertex vp vi+          case vis of+            [] -> pure (Rect 0 0 0 0, colorRGBA 0 0 0 0)+            (x0, y0, r0, g0, b0, a0) : rest -> do+              let xs = x0 : map (\(x, _, _, _, _, _) -> x) rest+                  ys = y0 : map (\(_, y, _, _, _, _) -> y) rest+                  toW8 f = max 0 (min 255 (round (f * 255)))+              pure+                ( Rect (minimum xs) (minimum ys) (maximum xs - minimum xs) (maximum ys - minimum ys)+                , colorRGBA (toW8 r0) (toW8 g0) (toW8 b0) (toW8 a0)+                )++spanCenter :: Rect -> V2+spanCenter (Rect x y w h) = V2 (x + w / 2) (y + h / 2)++hasText :: T.Text -> [(Rect, T.Text, a, b, c)] -> Bool+hasText needle = any (\(_, txt, _, _, _) -> needle `T.isInfixOf` txt)++-- Blank-glyph markers some span labels carry in front of their text (blanked+-- sort arrows, flags, sort-reserve padding).+dropSpanMarkers :: T.Text -> T.Text+dropSpanMarkers = T.dropWhile (`elem` ['\x01', '\x02', '\x05'])++spanLabel :: T.Text -> T.Text+spanLabel txt = dropSpanMarkers (T.strip txt)++findExact :: T.Text -> [DemoSpan] -> Maybe V2+findExact needle spans =+  pickRight+    [ (x, spanCenter r)+    | (r@(Rect x _ w h), txt, _, _, _) <- spans+    , w > 1 && h > 1+    , spanLabel txt == needle+    ]++findHeader :: T.Text -> [DemoSpan] -> Maybe V2+findHeader needle spans =+  -- Header spans keep their sort-reserve padding ("Name   " with the arrow+  -- glyph blanked when unsorted), while every other "Name" label is trimmed.+  -- Match the raw, untrimmed text so the header wins over right-aligned kv+  -- values that happen to repeat the column name.+  let marked =+        [ (x, spanCenter r)+        | (r@(Rect x _ w h), txt, _, _, _) <- spans+        , w > 1 && h > 1+        , T.isPrefixOf (needle <> " ") (dropSpanMarkers txt)+        ]+      exact =+        [ (x, spanCenter r)+        | (r@(Rect x _ w h), txt, _, _, _) <- spans+        , w > 1 && h > 1+        , spanLabel txt == needle+        ]+   in pickRight (if null marked then exact else marked)++findRightmost :: T.Text -> [DemoSpan] -> Maybe V2+findRightmost needle spans =+  pickRight [(x, spanCenter r) | (r@(Rect x _ _ _), txt, _, _, _) <- spans, needle `T.isInfixOf` txt]++pickRight :: [(Float, V2)] -> Maybe V2+pickRight [] = Nothing+pickRight (p : ps) = Just (go p ps)+ where+  go acc [] = snd acc+  go acc@(ax, _) (q@(qx, _) : qs) = go (if qx >= ax then q else acc) qs++requireSpan :: String -> Maybe V2 -> IO V2+requireSpan msg = maybe (fail msg) pure++-- | Fail with @msg@ unless a span contains @needle@.+expectText :: String -> T.Text -> [(Rect, T.Text, a, b, c)] -> IO ()+expectText msg needle spans = unless (hasText needle spans) (fail msg)++-- | Press, hold and release at @pos@, then two idle frames.+clickPos :: (Input -> IO ()) -> Input -> V2 -> IO ()+clickPos drawFrame base pos = dragPos drawFrame base pos pos++clickTab :: (Context -> IO [DemoSpan]) -> (Input -> IO ()) -> Context -> Input -> T.Text -> IO ()+clickTab getSpans drawFrame ctx base name = do+  spans <- getSpans ctx+  pos <- requireSpan ("selftest: tab " <> T.unpack name) (findExact name spans)+  clickPos drawFrame base pos++-- | Press at @from@, hold at @to@ and release there, then two idle frames.+dragPos :: (Input -> IO ()) -> Input -> V2 -> V2 -> IO ()+dragPos drawFrame base from to = do+  let press = pressAt base from+      hold = press {inputMousePressed = False, inputMousePos = to}+  mapM_ drawFrame [press, hold, releaseAt hold, base, base]++clickPair :: Input -> V2 -> (Input, Input)+clickPair inp pos =+  let+    press = pressAt inp pos+    release = releaseAt press+   in+    (press, release)++rightClickPair :: Input -> V2 -> (Input, Input)+rightClickPair inp pos =+  let+    press =+      inp+        { inputMousePos = pos+        , inputMouseRightDown = True+        , inputMouseRightPressed = True+        }+    release =+      press+        { inputMouseRightDown = False+        , inputMouseRightPressed = False+        , inputMouseRightReleased = True+        }+   in+    (press, release)++pressAt :: Input -> V2 -> Input+pressAt inp pos =+  inp+    { inputMousePos = pos+    , inputMouseDown = True+    , inputMousePressed = True+    , inputMouseReleased = False+    }++releaseAt :: Input -> Input+releaseAt press =+  press+    { inputMouseDown = False+    , inputMousePressed = False+    , inputMouseReleased = True+    }++-- | A single key-down frame.+keyInp :: Key -> Input -> Input+keyInp k inp = inp {inputKeys = inputKeysFromList [k]}++-- | Step the tab focus to the next focusable.+tabInp :: Input -> Input+tabInp = keyInp KeyTab++withInputOff :: Float -> Float -> Input+withInputOff w h =+  let inp = withInput w h+   in inp {inputMousePos = V2 (-10) (-10)}++withDelta :: Float -> Float -> Float -> Input+withDelta w h dt =+  let inp = withInput w h+   in inp {inputDeltaTime = dt}++centerOf :: Response -> V2+centerOf = spanCenter . respRect++warmup :: Context -> Input -> NanoUI a -> IO ()+warmup ctx inp ui = void (runFrame ctx inp ui)++warmup2 :: Context -> Input -> NanoUI a -> IO a+warmup2 ctx inp ui = do+  _ <- runFrame ctx inp ui+  (a, _, _, _) <- runFrame ctx inp ui+  pure a++warmupDraw :: Context -> Input -> NanoUI a -> IO (a, DrawData)+warmupDraw ctx inp ui = do+  _ <- runFrame ctx inp ui+  (a, _, draw, _) <- runFrame ctx inp ui+  pure (a, draw)++-- | Drive a controlled input the way an application does: pass the value held+-- in the test's 'IORef' and store the widget's result for the next frame. Not+-- a hook: a hook write makes the frame run the view again without input, and+-- the frame then returns that pass's result without its click or change flags.+held :: Ui :> es => IORef a -> (a -> Eff es (r, a)) -> Eff es (r, a)+held ref widget = do+  result <- widget =<< uiIO (readIORef ref)+  uiIO (writeIORef ref (snd result))+  pure result++-- | Run a press frame and a release frame at @pos@ ('clickPair'), returning+-- the release frame's result.+runClick :: Context -> Input -> NanoUI a -> V2 -> IO a+runClick ctx inp0 ui pos = do+  let+    (press, release) = clickPair inp0 pos+  _ <- runFrame ctx press ui+  (a, _, _, _) <- runFrame ctx release ui+  pure a++assertSpansHas :: HasCallStack => IORef Int -> T.Text -> [(Rect, T.Text, a, b, c)] -> IO ()+assertSpansHas failed needle spans = assert failed (hasText needle spans)++spanYOf :: T.Text -> [(Rect, T.Text, a, b, c)] -> [Float]+spanYOf lbl spans = [y | (Rect _ y _ _, txt, _, _, _) <- spans, txt == lbl]++spanXOf :: T.Text -> [(Rect, T.Text, a, b, c)] -> [Float]+spanXOf lbl spans = [x | (Rect x _ _ _, txt, _, _, _) <- spans, txt == lbl]++assertScrollGutterPad ::+  HasCallStack+  => IORef Int+  -> Context+  -> WidgetId+  -> Response+  -> Float+  -> Float+  -> IO ()+assertScrollGutterPad failed ctx sid child gutter endPad = do+  mrect <- getPrevRect ctx sid+  case mrect of+    Nothing -> assert failed False+    Just (Rect sx _ sw _) -> do+      let+        Rect cx _ cw _ = respRect child+        contentRight = sx + sw - endPad - gutter+      assert failed (cx + cw >= contentRight - 0.5)+      assert failed (cx + cw <= contentRight + 0.01)++assertWheelTitlePinned ::+  HasCallStack+  => IORef Int+  -> Context+  -> Input+  -> NanoUI a+  -> T.Text+  -> T.Text+  -> V2+  -> Maybe Float+  -> IO ()+assertWheelTitlePinned failed ctx inp0 ui title line1 wheelAt mClipMax = do+  spans0 <- collectOverlayTextSpans ctx inp0+  let+    titleYs0 = spanYOf title spans0+    line1Ys0 = spanYOf line1 spans0+  assert failed (not (null titleYs0))+  case line1Ys0 of+    [] -> assert failed False+    b0 : _ -> do+      let+        wheel = inp0 {inputMousePos = wheelAt, inputScroll = V2 0 1}+      _ <- runFrame ctx wheel ui+      spans1 <- collectOverlayTextSpans ctx wheel+      let+        titleYs1 = spanYOf title spans1+        line1Ys1 = spanYOf line1 spans1+      case (titleYs0, titleYs1) of+        (y0 : _, y1 : _) -> assertEq failed y1 y0+        _ -> assert failed False+      case line1Ys1 of+        [] -> pure ()+        b1 : _ -> assertLt failed b1 b0+      case mClipMax of+        Nothing -> pure ()+        Just maxY ->+          assert failed (not (any (\(Rect _ y _ h, _, _, _, _) -> y < 0 || y + h > maxY) spans1))++findGrabHover ::+  Context -> NanoUI a -> Input -> Float -> [Float] -> IO (Maybe Input)+findGrabHover ctx ui inp0 thumbX = go+ where+  go [] = pure Nothing+  go (y : ys) = do+    let+      hover = inp0 {inputMousePos = V2 thumbX y}+    _ <- runFrame ctx hover ui+    kind <- uiCursorKind ctx hover+    if kind == UiCursorGrab then pure (Just hover) else go ys++dragWindowEdge ::+  Context+  -> Input+  -> NanoUI Response+  -> V2+  -> V2+  -> IO (Maybe Rect)+dragWindowEdge ctx inp0 ui grab dest = do+  let+    press = pressAt inp0 grab+  _ <- runFrame ctx press ui+  let+    dragged =+      press+        { inputMousePos = dest+        , inputMousePressed = False+        }+  _ <- runFrame ctx dragged ui+  let+    idle = inp0 {inputMousePos = dest}+  _ <- runFrame ctx idle ui+  (win, _, _, _) <- runFrame ctx idle ui+  getPrevRect ctx (respId win)++vertUv :: DrawData -> Int -> IO (Float, Float)+vertUv dd i =+  withForeignPtr (drawVertices dd) $ \p -> do+    let+      off = i * vertexSize+    u <- peekByteOff p (off + 24) :: IO Float+    v <- peekByteOff p (off + 28) :: IO Float+    pure (u, v)++checkIdleFullDamage ::+  HasCallStack => IORef Int -> Context -> Input -> Input -> NanoUI a -> IO ()+checkIdleFullDamage failed ctx inpAfter inpIdle ui = do+  need <- needsRedraw ctx inpAfter inpIdle+  assert failed need+  _ <- runFrame ctx inpIdle ui+  dmg <- takeDamage ctx+  assert failed (dmg == DamageFull)++-- AlignEnd pins last-glyph ink, so "10" / "1i" / "1." share one right edge.+-- Lives here rather than with its test case because the pen and ink helpers+-- are internal to the library.+checkLabelAlignEndInk :: IORef Int -> IO ()+checkLabelAlignEndInk failed = do+  let+    gq xoff gw =+      GlyphQuad+        { gqX = xoff+        , gqY = 0+        , gqW = gw+        , gqH = 10+        , gqU0 = 0+        , gqV0 = 0+        , gqU1 = 1+        , gqV1 = 1+        }+    fm =+      (monospaceMetrics 10)+        { fmAdvance = \c -> case c of+            'i' -> 4+            '.' -> 4+            _ -> 10+        , fmGlyph = \c -> case c of+            'i' -> Just (gq 0.5 3)+            '.' -> Just (gq 1 1)+            _ -> Just (gq 1 8)+        }+    boxW = 100+    visualRight txt =+      let (tx, _) = alignedTextPen AlignEnd 0 boxW 0 fm txt+       in tx + textInkEnd fm txt+    r0 = visualRight "10"+    ri = visualRight "1i"+    rd = visualRight "1."+  when (abs (r0 - boxW) > 0.01) $ bump failed+  when (abs (ri - boxW) > 0.01) $ bump failed+  when (abs (rd - boxW) > 0.01) $ bump failed++windowTitleGrab :: Rect -> V2+windowTitleGrab (Rect x0 y0 _ _) = V2 (x0 + 24) (y0 + padT windowPad + 19.5)++runDragFrom :: Context -> Input -> NanoUI a -> V2 -> V2 -> IO ()+runDragFrom ctx inp0 ui grab dest = do+  let+    press = pressAt inp0 grab+  _ <- runFrame ctx press ui+  let+    moved = press {inputMousePos = dest, inputMousePressed = False}+  void (runFrame ctx moved ui)
+ lib/NanoUI/Testing/Runner.hs view
@@ -0,0 +1,45 @@+-- | Shared runner for the @exitcode-stdio@ integration suites: runs named+-- specs against fresh contexts, selecting them by command-line name.+module NanoUI.Testing.Runner+  ( runTests+  ) where++import Control.Monad (forM_, when)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import NanoUI.Testing (Context)+import System.Environment (getArgs)+import System.IO (hFlush, stdout)++-- | Run the given specs. Each entry is a test name, a context maker, and the+-- test body (which receives the context and a shared failure counter). Names+-- passed as program arguments select which tests run; with no arguments+-- everything runs. A test counts as failed when it incremented the counter.+runTests :: [(String, IO Context, Context -> IORef Int -> IO ())] -> IO ()+runTests specs = do+  args <- getArgs+  let+    wantAll = null args+    want name = wantAll || name `elem` args+    names = [name | (name, _, _) <- specs]+    unknown = filter (`notElem` names) args+  when (not (null unknown)) $+    fail ("Unknown test names: " ++ unwords unknown)+  failed <- newIORef (0 :: Int)+  failedTests <- newIORef (0 :: Int)+  forM_ specs $ \(name, mkCtx, run) ->+    when (want name) $ do+      putStrLn ("RUN: " ++ name)+      hFlush stdout+      before <- readIORef failed+      ctx <- mkCtx+      run ctx failed+      after <- readIORef failed+      when (after > before) $ do+        modifyIORef' failedTests (+ 1)+        putStrLn ("FAIL: " ++ name)+  n <- readIORef failedTests+  if n == 0+    then putStrLn "All tests passed."+    else do+      putStrLn $ show n ++ " test(s) failed."+      fail "tests failed"
+ lib/NanoUI/Types.hs view
@@ -0,0 +1,351 @@+module NanoUI.Types+  ( V2 (..)+  , Rect (..)+  , Size (..)+  , Color (..)+  , colorRGBA+  , colorToWord32+  , colorR+  , colorG+  , colorB+  , colorA+  , colorFromWord32+  , rgbToHsv+  , hsvToRgb+  , clamp+  , clamp01+  , onGrid+  , lerpColor+  , colorLuminance+  , contrastRatio+  , ImageId (..)+  , rectContains+  , rectNonEmpty+  , rectHit+  , rectUnion+  , rectIntersect+  , rectFullyInside+  , rectOverlapArea+  , rectInflate+  , rectArea+  , Damage (..)+  , DamageBounds (..)+  , defaultDamageSlop+  , sliderDamageSlop+  , haloDamageSlop+  , resolveDamageRect+  , damageIsEmpty+  , v2Add+  , v2Sub+  , PopupAnchor (..)+  , PopupPlacement (..)+  ) where++import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.Word (Word8, Word32)++data V2 = V2+  { v2X :: {-# UNPACK #-} !Float+  , v2Y :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++data Size = Size+  { sizeW :: {-# UNPACK #-} !Float+  , sizeH :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++data Rect = Rect+  { rectX :: {-# UNPACK #-} !Float+  , rectY :: {-# UNPACK #-} !Float+  , rectW :: {-# UNPACK #-} !Float+  , rectH :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++newtype ImageId = ImageId+  { unImageId :: Int+  }+  deriving (Eq, Ord, Show)++newtype Color = Color Word32+  deriving (Eq, Show, Num)++{-# INLINE colorRGBA #-}+colorRGBA :: Word8 -> Word8 -> Word8 -> Word8 -> Color+colorRGBA r g b a =+  Color $+    (word32Of r `shiftL` 24)+      .|. (word32Of g `shiftL` 16)+      .|. (word32Of b `shiftL` 8)+      .|. word32Of a++{-# INLINE colorToWord32 #-}+colorToWord32 :: Color -> Word32+colorToWord32 (Color w) = w++{-# INLINE colorR #-}+colorR :: Color -> Word8+colorR (Color w) = fromIntegral ((w `shiftR` 24) .&. 0xFF)++{-# INLINE colorG #-}+colorG :: Color -> Word8+colorG (Color w) = fromIntegral ((w `shiftR` 16) .&. 0xFF)++{-# INLINE colorB #-}+colorB :: Color -> Word8+colorB (Color w) = fromIntegral ((w `shiftR` 8) .&. 0xFF)++{-# INLINE colorA #-}+colorA :: Color -> Word8+colorA (Color w) = fromIntegral (w .&. 0xFF)++{-# INLINE colorFromWord32 #-}+colorFromWord32 :: Word32 -> Color+colorFromWord32 = Color++{-# INLINE clamp #-}+clamp :: Ord a => a -> a -> a -> a+clamp lo hi x = max lo (min hi x)++{-# INLINE clamp01 #-}+clamp01 :: Float -> Float+clamp01 x = clamp 0 1 x++-- | Round a logical coordinate onto the device-pixel grid implied by draw+-- scale @s@ (device px = logical * s). Every layer that positions pixels --+-- the layout solve, text pens, scroll offsets, paint and glyph rasterization --+-- must route its coordinates through this single function, with ties rounding+-- to even (@round@), so geometry can never dephase from text. An identity when+-- @s <= 0@ (no scaling).+{-# INLINE onGrid #-}+onGrid :: Float -> Float -> Float+onGrid s v+  | s > 0 = fromIntegral (round (v * s) :: Int) / s+  | otherwise = v++rgbToHsv :: Color -> (Float, Float, Float)+rgbToHsv c =+  let r = fromIntegral (colorR c) / 255+      g = fromIntegral (colorG c) / 255+      b = fromIntegral (colorB c) / 255+      maxC = max r (max g b)+      minC = min r (min g b)+      delta = maxC - minC+      v = maxC+      s = if maxC <= 0 then 0 else delta / maxC+      rawH+        | delta <= 0 = 0+        | maxC == r =+            let t = (g - b) / delta+             in if t < 0 then 60 * (t + 6) else 60 * t+        | maxC == g = 60 * (((b - r) / delta) + 2)+        | otherwise = 60 * (((r - g) / delta) + 4)+      h = if rawH < 0 then rawH + 360 else rawH+   in (h, s, v)++hsvToRgb :: Float -> Float -> Float -> Color+hsvToRgb h s v =+  let hi = floor (h / 60) :: Int+      f = h / 60 - fromIntegral hi+      p = v * (1 - s)+      q = v * (1 - f * s)+      t = v * (1 - (1 - f) * s)+      (r, g, b) =+        case hi `mod` 6 of+          0 -> (v, t, p)+          1 -> (q, v, p)+          2 -> (p, v, t)+          3 -> (p, q, v)+          4 -> (t, p, v)+          _ -> (v, p, q)+      toCh x = round (clamp01 x * 255) :: Word8+   in colorRGBA (toCh r) (toCh g) (toCh b) 255++-- | WCAG 2 relative-luminance contrast. 4.5 is AA for normal text.+--+-- Alpha is ignored, so both colours must be opaque. Passing a translucent+-- colour such as 'NanoUI.Style.themeOverlayDim' gives a meaningless ratio;+-- composite it over its backdrop first.+contrastRatio :: Color -> Color -> Double+contrastRatio a b =+  let hi = max (colorLuminance a) (colorLuminance b)+      lo = min (colorLuminance a) (colorLuminance b)+   in (hi + 0.05) / (lo + 0.05)++colorLuminance :: Color -> Double+colorLuminance c =+  0.2126 * srgb (colorR c) + 0.7152 * srgb (colorG c) + 0.0722 * srgb (colorB c)++lerpColor :: Color -> Color -> Float -> Color+lerpColor (Color a) (Color b) t =+  let u = clamp01 t+      ch shift =+        round $+          fromIntegral ((a `shiftR` shift) .&. 0xFF) * (1 - u)+            + fromIntegral ((b `shiftR` shift) .&. 0xFF) * u+   in Color+        ( (ch 24 `shiftL` 24)+            .|. (ch 16 `shiftL` 16)+            .|. (ch 8 `shiftL` 8)+            .|. ch 0+        )++srgb :: Word8 -> Double+srgb ch =+  let x = fromIntegral ch / 255+   in if x <= 0.04045 then x / 12.92 else ((x + 0.055) / 1.055) ** 2.4++{-# INLINE word32Of #-}+word32Of :: Word8 -> Word32+word32Of = fromIntegral++{-# INLINE rectContains #-}+rectContains :: Rect -> V2 -> Bool+rectContains (Rect x y w h) (V2 px py) =+  px >= x && px < x + w && py >= y && py < y + h++-- | A rect that has actually been laid out (nonzero extent).+{-# INLINE rectNonEmpty #-}+rectNonEmpty :: Rect -> Bool+rectNonEmpty r = rectW r > 0 && rectH r > 0++-- | Hit test that ignores rects that have not been laid out yet.+{-# INLINE rectHit #-}+rectHit :: Rect -> V2 -> Bool+rectHit r p = rectNonEmpty r && rectContains r p++{-# INLINE rectUnion #-}+rectUnion :: Rect -> Rect -> Rect+rectUnion (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) =+  let x = min x1 x2+      y = min y1 y2+      xEnd = max (x1 + w1) (x2 + w2)+      yEnd = max (y1 + h1) (y2 + h2)+   in Rect x y (xEnd - x) (yEnd - y)++{-# INLINE rectIntersect #-}+rectIntersect :: Rect -> Rect -> Maybe Rect+rectIntersect (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) =+  let x = max x1 x2+      y = max y1 y2+      xEnd = min (x1 + w1) (x2 + w2)+      yEnd = min (y1 + h1) (y2 + h2)+      w = xEnd - x+      h = yEnd - y+   in if w > 0 && h > 0 then Just (Rect x y w h) else Nothing++{-# INLINE rectFullyInside #-}+rectFullyInside :: Rect -> Rect -> Bool+rectFullyInside (Rect ix iy iw ih) (Rect ox oy ow oh) =+  iw > 0+    && ih > 0+    && ix >= ox+    && iy >= oy+    && ix + iw <= ox + ow+    && iy + ih <= oy + oh++{-# INLINE rectOverlapArea #-}+rectOverlapArea :: Rect -> Rect -> Float+rectOverlapArea a b =+  maybe 0 (\r -> rectW r * rectH r) (rectIntersect a b)++{-# INLINE rectInflate #-}+rectInflate :: Float -> Rect -> Rect+rectInflate pad (Rect x y w h) =+  Rect (x - pad) (y - pad) (w + pad * 2) (h + pad * 2)++{-# INLINE rectArea #-}+rectArea :: Rect -> Float+rectArea (Rect _ _ w h) = w * h++-- Full window vs a scissor box around widgets that actually changed (hover, anim).+data Damage+  = DamageFull+  | DamageClip Rect+  deriving (Eq, Show)++{-# INLINE damageIsEmpty #-}+damageIsEmpty :: Damage -> Bool+damageIsEmpty dmg =+  case dmg of+    DamageFull -> False+    DamageClip r -> rectW r <= 0 || rectH r <= 0++-- | Invalidation bounding strategy for a widget and its interaction events.+data DamageBounds+  = DamageSelf                              -- ^ Exact layout bounding box Rect+  | DamageInflated {-# UNPACK #-} !Float    -- ^ Layout bounding box inflated by margin (focus rings, shadows, text slop)+  | DamageExact !Rect                       -- ^ Explicit rectangle in window space+  | DamageCustom (Rect -> Rect)             -- ^ Custom transformation on layout bounding box+  | DamageUnion !DamageBounds !DamageBounds -- ^ Combined invalidation bounds+  | DamageNone                              -- ^ No invalidation bounds++instance Show DamageBounds where+  show DamageSelf = "DamageSelf"+  show (DamageInflated f) = "DamageInflated " ++ show f+  show (DamageExact r) = "DamageExact " ++ show r+  show (DamageCustom _) = "DamageCustom <fn>"+  show (DamageUnion a b) = "DamageUnion (" ++ show a ++ ") (" ++ show b ++ ")"+  show DamageNone = "DamageNone"++instance Eq DamageBounds where+  DamageSelf == DamageSelf = True+  DamageInflated a == DamageInflated b = a == b+  DamageExact a == DamageExact b = a == b+  DamageUnion a1 b1 == DamageUnion a2 b2 = a1 == a2 && b1 == b2+  DamageNone == DamageNone = True+  _ == _ = False++-- | Standard damage slop for text overhang, focus rings, and border anti-aliasing.+defaultDamageSlop :: Float+defaultDamageSlop = 4.0++-- | Damage slop for slider handles that extend past track bounds.+sliderDamageSlop :: Float+sliderDamageSlop = 8.0++-- | Damage slop for window resize halos and shadows.+haloDamageSlop :: Float+haloDamageSlop = 12.0++-- | Resolve damage bounds against a given layout rect.+resolveDamageRect :: DamageBounds -> Rect -> Rect+resolveDamageRect bounds r =+  case bounds of+    DamageSelf -> r+    DamageInflated pad -> rectInflate pad r+    DamageExact exactR -> exactR+    DamageCustom f -> f r+    DamageUnion a b ->+      -- An empty side (DamageNone, or an unlaid-out rect) contributes+      -- nothing; a plain rect union would stretch the damage to the origin.+      let ra = resolveDamageRect a r+          rb = resolveDamageRect b r+       in if not (rectNonEmpty ra)+            then rb+            else if not (rectNonEmpty rb) then ra else rectUnion ra rb+    DamageNone -> Rect 0 0 0 0++{-# INLINE v2Add #-}+v2Add :: V2 -> V2 -> V2+v2Add (V2 x1 y1) (V2 x2 y2) = V2 (x1 + x2) (y1 + y2)++{-# INLINE v2Sub #-}+v2Sub :: V2 -> V2 -> V2+v2Sub (V2 x1 y1) (V2 x2 y2) = V2 (x1 - x2) (y1 - y2)++data PopupAnchor+  = AnchorPoint !V2+  | AnchorRect !Rect+  deriving (Eq, Show)++data PopupPlacement+  = PlacementBelow+  | PlacementAbove+  | PlacementRight+  | PlacementLeft+  | PlacementAtCursor+  | PlacementAuto+  deriving (Eq, Show)
+ lib/NanoUI/WidgetText.hs view
@@ -0,0 +1,422 @@+module NanoUI.WidgetText+  ( intValueText+  , treeEncodeStyle+  , treeDecodeStyle+  , treeDecodeStripe+  , textInputFieldText+  , textInputMinWidth+  , textInputFieldPadY+  , textInputFieldHeight+  , textInputFlagSearch+  , textInputSearchMode+  , textInputFlagSelectable+  , textInputSelectableMode+  , textInputFlagPassword+  , textInputPasswordMode+  , textInputFlagNumeric+  , textInputNumericMode+  , numericStepperW+  , numericTextClip+  , numericStepperRects+  , comboTextClip+  , searchFieldReserveW+  , searchFieldTextClip+  , searchFieldIconRects+  , selectDisplayText+  , selectChevronReserve+  , selectChevronCenterX+  , colorPickerGap+  , colorPickerSvH+  , colorPickerCurrentLabel+  , colorPickerNewLabel+  , colorToHex+  , colorToHexA+  , colorFromHex+  , colorPickerParseHex+  , buttonFlagClose+  , buttonCloseTrailing+  , buttonFlagTab+  , buttonFlagTable+  , buttonFlagMenu+  , buttonFlagMenuBar+  , buttonFlagMask+  , tableStripeEven+  , tableStripeOdd+  , tableSortReserve+  , tableStripeColor+  , stripeColor+  , packTextNodeStyleFull+  , textNodeFontVariant+  , textNodeFontWeight+  , textNodeFontStyle+  , textNodeTextDecoration+  , textNodeStripe+  , tableHeaderLabel+  , tableHeaderDisplayText+  , tableSortMarkOf+  , tableSortBlank+  , isCloseButtonStyle+  , isTabButtonStyle+  , isTableHeaderStyle+  , isMenuItemStyle+  , isMenuBarStyle+  , buttonVisualStyle+  , buttonFlagsFromStyle+  ) where++import Data.Bits ((.&.), (.|.), complement, shiftL, shiftR)+import Data.Char (digitToInt, isHexDigit)+import Data.Maybe (fromMaybe)+import Data.Primitive.SmallArray (SmallArray, indexSmallArray, smallArrayFromList)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Lazy.Builder.Int as TB+import Data.Word (Word8)+import Numeric (showHex)+import NanoUI.Font (FontMetrics (..), fmLineHeight, widgetContentInset)+import NanoUI.Style (FontStyle (..), FontVariant (..), FontWeight (..), TextDecoration (..), Theme (..), styleBg, themeButton, themePanel, themeWindow)+import NanoUI.Types (Color (..), Rect (..), colorA, colorB, colorG, colorR, colorRGBA, lerpColor)+import qualified Data.Text as T++intValueText :: Int -> Text+intValueText = TL.toStrict . TB.toLazyText . TB.decimal++-- | styleIdx: nodeIdx in bits 11+, depth in 0-7, hasKids bit 8, expanded bit 9, stripeOdd bit 10.+treeEncodeStyle :: Int -> Int -> Bool -> Bool -> Bool -> Int+treeEncodeStyle nodeIdx depth hasKids expanded isOdd =+  (nodeIdx `shiftL` 11)+    .|. (if isOdd then 0x400 else 0)+    .|. (if expanded then 0x200 else 0)+    .|. (if hasKids then 0x100 else 0)+    .|. (depth .&. 0xff)++treeDecodeStyle :: Int -> (Int, Int, Bool, Bool)+treeDecodeStyle s =+  ( s `shiftR` 11+  , s .&. 0xff+  , s .&. 0x100 /= 0+  , s .&. 0x200 /= 0+  )++treeDecodeStripe :: Int -> Int+treeDecodeStripe s = if s .&. 0x400 /= 0 then tableStripeOdd else tableStripeEven++textInputMinWidth :: Float+textInputMinWidth = 160++textInputFieldPadY :: FontMetrics -> Float+textInputFieldPadY fm = max 3 (fmAdvance fm ' ' * 1.25)++textInputFieldHeight :: FontMetrics -> Float+textInputFieldHeight fm = fmLineHeight fm + 2 * textInputFieldPadY fm++-- | Search-field icon geometry. Returns+-- (icon diameter, outer pad, left chrome lead, right chrome tail). The lead/tail+-- are the horizontal space the magnifier / clear buttons reserve either side of+-- the editable text.+searchFieldChrome :: FontMetrics -> (Float, Float, Float, Float)+searchFieldChrome fm =+  let (ix, _) = widgetContentInset fm+      s = max 12 (min 15 (fmLineHeight fm * 0.8))+      pad = fmAdvance fm ' ' * 0.6+   in (s, ix, ix + s + pad, pad + s + ix)++-- | Total horizontal chrome a caption-less search box reserves for its icons.+searchFieldReserveW :: FontMetrics -> Float+searchFieldReserveW fm =+  let (_, _, lead, tailw) = searchFieldChrome fm+   in lead + tailw++-- | Region a caption-less search field's editable text may occupy. Excludes the+-- magnifier on the left and the clear slot on the right.+searchFieldTextClip :: FontMetrics -> Float -> Float -> Float -> Float -> Rect+searchFieldTextClip fm x y w h =+  let (_, _, lead, tailw) = searchFieldChrome fm+      (_, iy) = widgetContentInset fm+   in Rect (x + lead) (y + iy) (max 0 (w - lead - tailw)) (max 0 (h - 2 * iy))++-- | Square slots (magnifier left, clear right) the search icons are drawn in.+searchFieldIconRects :: FontMetrics -> Float -> Float -> Float -> Float -> (Rect, Rect)+searchFieldIconRects fm x y w h =+  let (s, ix, _, _) = searchFieldChrome fm+      cy = y + h / 2+      mag = Rect (x + ix) (cy - s / 2) s s+      clear = Rect (x + w - ix - s) (cy - s / 2) s s+   in (mag, clear)++textInputFieldText :: Text -> Text -> Bool -> Text+textInputFieldText ph value focused =+  let body = value+   in if T.null body && not focused+        then ph+        else body++-- | Marks a @NodeTextInput@ as a caption-less search field. Lives in the high+-- style bits (like the button flags) so it survives the arena's int storage.+textInputFlagSearch :: Int+textInputFlagSearch = 0x04000000++{-# INLINE textInputSearchMode #-}+textInputSearchMode :: Int -> Bool+textInputSearchMode si = si .&. textInputFlagSearch /= 0++-- | Marks a @NodeTextInput@ as a selectable text label: read-only, caption-less,+-- chrome-less, sized to its text content, with mouse drag-to-select and copy.+textInputFlagSelectable :: Int+textInputFlagSelectable = 0x10000000++{-# INLINE textInputSelectableMode #-}+textInputSelectableMode :: Int -> Bool+textInputSelectableMode si = si .&. textInputFlagSelectable /= 0++-- | Marks a @NodeTextInput@ as a password field: its value is displayed masked+-- and is never copied or cut to the clipboard.+textInputFlagPassword :: Int+textInputFlagPassword = 0x20000000++{-# INLINE textInputPasswordMode #-}+textInputPasswordMode :: Int -> Bool+textInputPasswordMode si = si .&. textInputFlagPassword /= 0++-- | Marks a @NodeTextInput@ as a numeric field: a caption-less box whose text+-- stops short of an up / down stepper at its right edge.+textInputFlagNumeric :: Int+textInputFlagNumeric = 0x40000000++{-# INLINE textInputNumericMode #-}+textInputNumericMode :: Int -> Bool+textInputNumericMode si = si .&. textInputFlagNumeric /= 0++-- | Width of a numeric field's stepper column.+numericStepperW :: Float+numericStepperW = 18++-- | Region a numeric field's text may occupy: inside the content inset, left+-- of the stepper.+numericTextClip :: FontMetrics -> Float -> Float -> Float -> Float -> Rect+numericTextClip fm x y w h =+  let (ix, iy) = widgetContentInset fm+   in Rect (x + ix) (y + iy) (max 0 (w - 2 * ix - numericStepperW)) (max 0 (h - 2 * iy))++-- | The up and down halves of a numeric field's stepper.+numericStepperRects :: Float -> Float -> Float -> Float -> (Rect, Rect)+numericStepperRects x y w h =+  let sx = x + w - numericStepperW+      half = h / 2+   in (Rect sx y numericStepperW half, Rect sx (y + half) numericStepperW (h - half))++-- | Region a combo box's editable text may occupy: from the left content inset+-- to the select chevron reserve on the right.+comboTextClip :: FontMetrics -> Float -> Float -> Float -> Float -> Rect+comboTextClip fm x y w h =+  let (ix, iy) = widgetContentInset fm+   in Rect (x + ix) (y + iy) (max 0 (w - ix - selectChevronReserve)) (max 0 (h - 2 * iy))++selectDisplayText :: Text -> Text -> Text+selectDisplayText lbl opt+  | T.null lbl = opt+  | otherwise = lbl <> ": " <> opt++-- Space reserved on the right of a select for the chevron.+selectChevronReserve :: Float+selectChevronReserve = 16++selectChevronCenterX :: Float -> Float -> Float+selectChevronCenterX x w = x + w - selectChevronReserve / 2++colorPickerGap :: Float+colorPickerGap = 4++-- Height of a colour picker's field row; the field grows to a square this tall.+colorPickerSvH :: Float+colorPickerSvH = 250++colorPickerCurrentLabel :: Text+colorPickerCurrentLabel = "Current"++colorPickerNewLabel :: Text+colorPickerNewLabel = "New"++colorToHex :: Color -> Text+colorToHex c =+  "#" <> hexByte (colorR c) <> hexByte (colorG c) <> hexByte (colorB c)++-- | Eight-digit form for the alpha-aware picker: @#RRGGBBAA@.+colorToHexA :: Color -> Text+colorToHexA c = colorToHex c <> hexByte (colorA c)++hexByte :: Word8 -> Text+hexByte n = indexSmallArray hexBytes (fromIntegral n)++-- Each byte's two-character representation is allocated once, shared by+-- color-picker labels instead of formatting fresh Strings every frame.+hexBytes :: SmallArray Text+hexBytes =+  smallArrayFromList+    [T.justifyRight 2 '0' (T.pack (showHex n "")) | n <- [0 .. 255 :: Int]]++-- | Parse a hex colour, accepting an optional leading @#@ and either 6 or 8+-- digits. The fourth component is 'Nothing' for the six-digit form.+colorPickerParseHex :: Text -> Maybe (Word8, Word8, Word8, Maybe Word8)+colorPickerParseHex txt =+  let bare = T.dropWhile (== '#') (T.strip txt)+      pair i = parseHexPair (T.take 2 (T.drop i bare))+      n = T.length bare+   in if n /= 6 && n /= 8+        then Nothing+        else do+          r <- pair 0+          g <- pair 2+          b <- pair 4+          a <- if n == 8 then Just <$> pair 6 else pure Nothing+          pure (r, g, b, a)++colorFromHex :: Text -> Maybe Color+colorFromHex txt = do+  (r, g, b, ma) <- colorPickerParseHex txt+  pure (colorRGBA r g b (fromMaybe 255 ma))++parseHexPair :: Text -> Maybe Word8+parseHexPair t = case T.unpack t of+  [hi, lo]+    | isHexDigit hi && isHexDigit lo -> Just (fromIntegral (digitToInt hi * 16 + digitToInt lo))+  _ -> Nothing++tableStripeEven :: Int+tableStripeEven = 1++tableStripeOdd :: Int+tableStripeOdd = 2++{-# INLINE packTextNodeStyleFull #-}+packTextNodeStyleFull :: FontVariant -> FontWeight -> FontStyle -> TextDecoration -> Int -> Int+packTextNodeStyleFull fvar weight fstyle deco stripe =+  (stripe `shiftL` 4)+    .|. (fromEnum fvar .&. 0x0F)+    .|. ((fromEnum weight .&. 0x0F) `shiftL` 8)+    .|. ((fromEnum fstyle .&. 0x03) `shiftL` 12)+    .|. ((fromEnum deco .&. 0x03) `shiftL` 14)++-- | The enum packed in the style bits at @shift@ under @mask@, or @fallback@+-- when they hold no constructor.+{-# INLINE decodeStyleEnum #-}+decodeStyleEnum :: forall a. (Bounded a, Enum a) => Int -> Int -> a -> Int -> a+decodeStyleEnum shift mask fallback si =+  let v = (si `shiftR` shift) .&. mask+   in if v >= fromEnum (minBound :: a) && v <= fromEnum (maxBound :: a) then toEnum v else fallback++{-# INLINE textNodeFontVariant #-}+textNodeFontVariant :: Int -> FontVariant+textNodeFontVariant = decodeStyleEnum 0 0x0F FontRegular++{-# INLINE textNodeFontWeight #-}+textNodeFontWeight :: Int -> FontWeight+textNodeFontWeight = decodeStyleEnum 8 0x0F WeightNormal++{-# INLINE textNodeFontStyle #-}+textNodeFontStyle :: Int -> FontStyle+textNodeFontStyle = decodeStyleEnum 12 0x03 FontStyleNormal++{-# INLINE textNodeTextDecoration #-}+textNodeTextDecoration :: Int -> TextDecoration+textNodeTextDecoration = decodeStyleEnum 14 0x03 DecorationNone++{-# INLINE textNodeStripe #-}+textNodeStripe :: Int -> Int+textNodeStripe si = (si `shiftR` 4) .&. 0x0F++{-# INLINE stripeColor #-}+stripeColor :: Theme -> Int -> Maybe Color+stripeColor theme s+  | s == tableStripeEven = Just (lerpColor (styleBg (themePanel theme)) (themeWindow theme) 0.26)+  | s == tableStripeOdd = Just (lerpColor (styleBg (themePanel theme)) (styleBg (themeButton theme)) 0.55)+  | otherwise = Nothing++tableStripeColor :: Theme -> Int -> Maybe Color+tableStripeColor theme si = stripeColor theme (textNodeStripe si)++-- | Trailing slot reserved in every header so the sort mark never changes column width.+tableSortReserve :: Text+tableSortReserve = "  ▲"++tableHeaderLabel :: Text -> Text+tableHeaderLabel hdr = hdr <> tableSortReserve++-- | Sort direction encoded for a table-header style. Lives in bits 16-17: the+-- low nibbles are the font fields, and a mark value of 1 or 2 in bit 0-1 used+-- to flip the header's font variant (heading / muted), which blanked the+-- arrow glyph.+tableSortMarkOf :: Int -> Int+tableSortMarkOf styleIdx = (styleIdx `shiftR` 16) .&. 0x03++-- | Blank reserve slot (spaces only). The sort mark is drawn as a triangle+-- over this slot, so the ▲/▼ codepoint never enters measured or laid-out text+-- (the pruned UI font does not carry it).+tableSortBlank :: Text+tableSortBlank = T.map (const ' ') tableSortReserve++tableHeaderDisplayText :: Text -> Text+tableHeaderDisplayText txt =+  fromMaybe txt (T.stripSuffix tableSortReserve txt) <> tableSortBlank++-- Type flags live in bits 28-31 so visual style and tab index stay in the low bits.+buttonFlagClose :: Int+buttonFlagClose = 0x20000000++-- | Visual style of a title-bar close button: its cross sits against the+-- box's right edge, so it lines up with the panel padding the way the title+-- does on the left.+buttonCloseTrailing :: Int+buttonCloseTrailing = 1++buttonFlagTab :: Int+buttonFlagTab = 0x40000000++buttonFlagTable :: Int+buttonFlagTable = 0x80000000++-- Flat menu row / menu-bar entry: transparent at rest, hover highlight, and an+-- accent marker on hover. Rendered by 'menuItemVisualStyle'.+buttonFlagMenu :: Int+buttonFlagMenu = 0x10000000++-- Flat menu-bar title: same flat/hover/open fill as a menu row, but centered+-- text and no hover accent marker (that marker belongs to drop-down rows).+buttonFlagMenuBar :: Int+buttonFlagMenuBar = 0x08000000++buttonFlagMask :: Int+buttonFlagMask = buttonFlagClose .|. buttonFlagTab .|. buttonFlagTable .|. buttonFlagMenu .|. buttonFlagMenuBar++{-# INLINE buttonVisualStyle #-}+buttonVisualStyle :: Int -> Int+buttonVisualStyle si = si .&. complement buttonFlagMask++{-# INLINE buttonFlagsFromStyle #-}+buttonFlagsFromStyle :: Int -> (Bool, Bool, Bool)+buttonFlagsFromStyle si =+  ( si .&. buttonFlagClose /= 0+  , si .&. buttonFlagTab /= 0+  , si .&. buttonFlagTable /= 0+  )++{-# INLINE isCloseButtonStyle #-}+isCloseButtonStyle :: Int -> Bool+isCloseButtonStyle si = si .&. buttonFlagClose /= 0++{-# INLINE isTabButtonStyle #-}+isTabButtonStyle :: Int -> Bool+isTabButtonStyle si = si .&. buttonFlagTab /= 0++{-# INLINE isTableHeaderStyle #-}+isTableHeaderStyle :: Int -> Bool+isTableHeaderStyle si = si .&. buttonFlagTable /= 0++{-# INLINE isMenuItemStyle #-}+isMenuItemStyle :: Int -> Bool+isMenuItemStyle si = si .&. buttonFlagMenu /= 0++{-# INLINE isMenuBarStyle #-}+isMenuBarStyle :: Int -> Bool+isMenuBarStyle si = si .&. buttonFlagMenuBar /= 0
+ lib/NanoUI/Widgets/Animate.hs view
@@ -0,0 +1,107 @@+module NanoUI.Widgets.Animate+  ( Transition (..)+  , animate+  , animateTo+  , animateToA+  , pulse+  , keepAnimating+  )+where++import Control.Monad (when)+import Data.Maybe (isNothing)+import Effectful (Eff, type (:>))+import NanoUI.Animatable (Animatable (..))+import NanoUI.Animation (SpringParams)+import NanoUI.Context+  ( Ease (..)+  , approxEq+  , easeSameSpec+  , getAnimationValue+  , lookupAnimation+  , setAnimationValue+  , startAnimation+  , startAnimationEaseDelay+  , startSpring+  )+import NanoUI.Monad (Ui, askContext, nextId, scope, uiIO, uiTime, withKey)+import NanoUI.Widgets.Node (HasResponse, respId)++-- | How an animated value moves.+data Transition+  = -- | Eased tween: duration and start delay, in seconds.+    Tween !Ease !Float !Float+  | -- | Damped spring; retargets from its current position and velocity.+    Spring !SpringParams++-- | Animate from @from@ to @to@. It starts over from @from@ once it has+-- finished (a tween completes, a spring settles) or its tween changes, so+-- calling it every frame cycles.+animate :: Ui :> es => Transition -> Float -> Float -> Eff es Float+animate transition from to = do+  wid <- nextId+  ctx <- askContext+  uiIO $ do+    case transition of+      Tween ease dur delay -> startAnimationEaseDelay ctx wid from to dur ease delay+      Spring params -> do+        running <- lookupAnimation ctx wid+        when (isNothing running) (setAnimationValue ctx wid from)+        startSpring ctx wid params to+    getAnimationValue ctx wid++-- | Animate from the current value toward @target@. An unchanged target keeps+-- the running animation; a new one retargets from wherever the value is.+animateTo :: Ui :> es => Transition -> Float -> Eff es Float+animateTo transition target = do+  wid <- nextId+  ctx <- askContext+  uiIO $ do+    case transition of+      Tween ease dur delay -> do+        cur <- getAnimationValue ctx wid+        manim <- lookupAnimation ctx wid+        case manim of+          Just a | easeSameSpec a ease dur delay target -> pure ()+          Nothing | approxEq cur target -> pure ()+          _ -> startAnimationEaseDelay ctx wid cur target dur ease delay+      Spring params -> startSpring ctx wid params target+    getAnimationValue ctx wid++-- | 'animateTo' for every component of a composite value.+animateToA :: (Animatable a, Ui :> es) => Transition -> a -> Eff es a+animateToA transition = animateComponents (animateTo transition)++-- Component keys are local to one composite value, not its parent widget.+animateComponents ::+  (Animatable a, Ui :> es) => (Float -> Eff es Float) -> a -> Eff es a+animateComponents animateComponent target = scope $ do+  components <-+    mapM+      (\(index, value) -> withKey (index :: Int) (animateComponent value))+      (zip [0 ..] (toComponents target))+  pure (fromComponents components)++-- | A smoothly oscillating value in @[0,1]@ driven by the real-time clock, with+-- the given period in seconds (e.g. @pulse 6@ sweeps once every six seconds).+-- The time is captured in 'Double' (see 'NanoUI.Monad.uiTime'), so the sweep+-- stays sub-frame smooth even on long-running processes. The value is+-- re-evaluated each frame, like 'animate'.+pulse :: Ui :> es => Float -> Eff es Float+pulse periodSec = do+  t <- uiTime+  let+    period = max 0.001 (realToFrac periodSec :: Double)+  pure (realToFrac (0.5 + 0.5 * sin (2 * pi * t / period)) :: Float)++-- | Keep a widget animating indefinitely so the frame loop never idles. Widgets+-- driven by the wall clock ('pulse', or drawing from 'NanoUI.Monad.uiTime')+-- rather than by a frame-counted animation would otherwise stop repainting+-- once other animations settle.+--+-- > bar <- progressBar' =<< pulse 6+-- > keepAnimating bar+keepAnimating :: (HasResponse r, Ui :> es) => r -> Eff es ()+keepAnimating resp = do+  ctx <- askContext+  uiIO (startAnimation ctx (respId resp) 0 1 1e9)
+ lib/NanoUI/Widgets/Behavior.hs view
@@ -0,0 +1,247 @@+-- | Interaction hooks shared by widgets: 1D drags, drag reordering, arrow-key+-- navigation, click-outside and Escape dismissal, and the keyboard focus+-- check. Their state lives in the widget store.+module NanoUI.Widgets.Behavior+  ( DragAxis (..)+  , keyedDragHeld+  , useDrag1D+  , useReorder+  , useKeyNav+  , keyboardFocused+  , keyActivated+  , KeyNav (..)+  , useDismissable+  , dragThresholdPx+  )+where++import Control.Monad (when)+import Data.Hashable (Hashable, hash)+import Data.IORef (readIORef)+import Data.List (find)+import Effectful (Eff, type (:>))+import qualified Data.IntMap.Strict as IM+import NanoUI.Context+  ( Context (..)+  , getFocusId+  , getStore+  , intKey+  , isDisabled+  , markEscapeConsumed+  , getMenuPointerGesture+  , pointerBlockedByModal+  , Slot (..)+  , slotKey+  , modifyStore+  )+import NanoUI.Id (WidgetId (..), enterKeyed, hashWidgetId, idContextWidgetId)+import NanoUI.Input+  ( Input (..)+  , Key (..)+  , inputChars+  , inputKeys+  , inputKeysElem+  , inputKeysNull+  , inputMouseDown+  , inputMousePos+  , inputMousePressed+  , inputMouseReleased+  , inputMouseRightPressed+  )+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)+import NanoUI.Store (WidgetStore (..))+import NanoUI.Types (Rect (..), clamp01, rectHit, v2X, v2Y)+import qualified Data.Text as T++-- | Pointer slop in pixels before a held press counts as a drag.+dragThresholdPx :: Float+dragThresholdPx = 8++data DragAxis = DragAxisX | DragAxisY+  deriving (Eq, Show)++-- | True when a prior keyed useDrag1D on this path is still held.+-- Peeks the keyed first-id without enterKeyed bumping parent siblingId.+keyedDragHeld :: (Hashable k, Ui :> es) => k -> Eff es Bool+keyedDragHeld k = do+  ctx <- askContext+  uiIO $ do+    old <- readIORef (ctxIdContext ctx)+    let wid = idContextWidgetId (snd (enterKeyed (fromIntegral (hash k)) old))+        dragK = slotKey SlotDrag (intKey wid)+    store <- getStore ctx+    pure (IM.findWithDefault 0 dragK (storeInt store) /= 0)++-- | Clamped 1D drag. Maps pointer position on 'track' into [lo, hi].+useDrag1D ::+  (Ui :> es) =>+  DragAxis ->+  Float ->+  Float ->+  Float ->+  Rect ->+  Eff es (Float, Bool)+useDrag1D axis lo hi current track = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  let key = intKey wid+      dragK = slotKey SlotDrag key+      trackLen = case axis of+        DragAxisX -> rectW track+        DragAxisY -> rectH track+      origin = case axis of+        DragAxisX -> rectX track+        DragAxisY -> rectY track+      mouse = case axis of+        DragAxisX -> v2X (inputMousePos inp)+        DragAxisY -> v2Y (inputMousePos inp)+      down = inputMouseDown inp+  store <- uiIO (getStore ctx)+  gesture <- uiIO (getMenuPointerGesture ctx)+  let active0 = IM.findWithDefault 0 dragK (storeInt store) /= 0+      hit = rectHit track (inputMousePos inp) && not gesture+      active = down && not gesture && (active0 || hit)+      frac =+        if trackLen <= 0+          then 0+          else clamp01 ((mouse - origin) / trackLen)+      next =+        if active+          then lo + frac * (hi - lo)+          else current+  when (active /= active0) $+    uiIO $+      modifyStore ctx $ \st ->+        st+          { storeInt =+              if active+                then IM.insert dragK 1 (storeInt st)+                else IM.delete dragK (storeInt st)+          }+  pure (next, active)++-- | Drag-and-drop reorder of a visible index list.+useReorder ::+  (Ui :> es) =>+  [Int] ->+  [(Int, Rect)] ->+  Eff es ([Int], Maybe Int)+useReorder order items = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  let key = intKey wid+      dragK = slotKey SlotDrag key+      mouse = inputMousePos inp+      down = inputMouseDown inp+      press = inputMousePressed inp+      release = inputMouseReleased inp+      hit =+        find+          (\(_, r) -> rectHit r mouse)+          items+  store <- uiIO (getStore ctx)+  let from0 = IM.findWithDefault (-1) dragK (storeInt store)+      startX = IM.findWithDefault 0 (slotKey SlotDragW key) (storeFloat store)+      dragging = if press then maybe (-1) fst hit else from0+      nextDrag =+        if release || not down+          then -1+          else dragging+      -- Resolve the drop using the held source before clearing it on release.+      moved =+        not press && dragging >= 0 && abs (v2X mouse - startX) > dragThresholdPx+      dropTo = if moved then fmap fst hit else Nothing+      nextOrder =+        case dropTo of+          Just toCol | release -> moveItem order dragging toCol+          _ -> order+  when (nextDrag /= from0 || (press && nextDrag >= 0)) $+    uiIO $+      modifyStore ctx $ \st ->+        st+          { storeInt = IM.insert dragK nextDrag (storeInt st)+          , storeFloat =+              IM.insert+                (slotKey SlotDragW key)+                (if press then v2X mouse else startX)+                (storeFloat st)+          }+  pure (nextOrder, if nextDrag >= 0 then Just nextDrag else Nothing)++moveItem :: [Int] -> Int -> Int -> [Int]+moveItem xs from to+  | from == to = xs+  | otherwise =+      let without = filter (/= from) xs+          (pre, post) = break (== to) without+       in pre ++ from : post++data KeyNav = KeyNav+  { knUp :: !Bool+  , knDown :: !Bool+  , knLeft :: !Bool+  , knRight :: !Bool+  , knEnter :: !Bool+  , knSpace :: !Bool+  }+  deriving (Eq, Show)++-- | Focus alone does not grant keyboard input. A retained focus ID must still+-- respect disabled state and the modal currently being declared. Unfocused+-- controls avoid the store and modal checks entirely.+{-# INLINE keyboardFocused #-}+keyboardFocused :: Ui :> es => WidgetId -> Eff es Bool+keyboardFocused wid+  | hashWidgetId wid == 0 = pure False+  | otherwise = do+      ctx <- askContext+      focus <- uiIO (getFocusId ctx)+      if focus /= wid+        then pure False+        else uiIO $ do+          disabled <- isDisabled ctx wid+          if disabled then pure False else not <$> pointerBlockedByModal ctx++-- | Arrow / Enter / Space while 'wid' is focused and eligible for input.+useKeyNav :: (Ui :> es) => WidgetId -> Eff es KeyNav+useKeyNav wid = do+  inp <- askInput+  let keys = inputKeys inp+      none = KeyNav False False False False False False+  if hashWidgetId wid == 0 || (inputKeysNull keys && T.null (inputChars inp))+    then pure none+    else do+      eligible <- keyboardFocused wid+      if not eligible+        then pure none+        else pure KeyNav+          { knUp = inputKeysElem KeyUp keys+          , knDown = inputKeysElem KeyDown keys+          , knLeft = inputKeysElem KeyLeft keys+          , knRight = inputKeysElem KeyRight keys+          , knEnter = inputKeysElem KeyEnter keys+          , knSpace = T.any (== ' ') (inputChars inp)+          }++-- | True when Enter or Space was pressed while @wid@ holds focus. Buttons,+-- checkboxes, and toggle switches treat this as a click.+{-# INLINE keyActivated #-}+keyActivated :: (Ui :> es) => WidgetId -> Eff es Bool+keyActivated wid = do+  nav <- useKeyNav wid+  pure (knEnter nav || knSpace nav)++-- | Escape and click-outside-rect dismiss. Consumes Escape when it fires.+useDismissable :: (Ui :> es) => Rect -> Eff es Bool+useDismissable panel = do+  ctx <- askContext+  inp <- askInput+  let mouse = inputMousePos inp+      inside = rectHit panel mouse+      esc = inputKeysElem KeyEscape (inputKeys inp)+      backdrop = (inputMousePressed inp || inputMouseRightPressed inp) && not inside+      dismissed = esc || backdrop+  when esc $ uiIO (markEscapeConsumed ctx)+  pure dismissed
+ lib/NanoUI/Widgets/Button.hs view
@@ -0,0 +1,50 @@+-- | Push buttons.+module NanoUI.Widgets.Button+  ( button+  , button'+  , buttonWith+  , buttonWith'+  )+where++import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Monad (Ui)+import NanoUI.Style (Layout, defaultLayout)+import NanoUI.Widgets.Combinators (buttonStyledEx)+import NanoUI.Widgets.Node (Response, respClicked)++-- | Button with a text label. 'True' on the frame it is clicked, by pointer+-- or by Enter or Space while focused.+--+-- @+-- whenM (button "Save") saveDocument+-- @+{-# INLINE button #-}+button :: Ui :> es => Text -> Eff es Bool+button txt = respClicked <$> button' txt++-- | 'button' returning its 'Response', for tooltips, anchored popups, or+-- hover state.+--+-- @+-- help <- button' "Help"+-- tooltip help "Open the manual"+-- when (respClicked help) openManual+-- @+{-# INLINE button' #-}+button' :: Ui :> es => Text -> Eff es Response+button' = buttonWith' id++-- | 'button' with a layout modifier.+--+-- @+-- whenM (buttonWith (fixedW 120) "Submit") submitForm+-- @+{-# INLINE buttonWith #-}+buttonWith :: Ui :> es => (Layout -> Layout) -> Text -> Eff es Bool+buttonWith f txt = respClicked <$> buttonWith' f txt++{-# INLINE buttonWith' #-}+buttonWith' :: Ui :> es => (Layout -> Layout) -> Text -> Eff es Response+buttonWith' f txt = buttonStyledEx True txt 0 (f defaultLayout) 0
+ lib/NanoUI/Widgets/Checkbox.hs view
@@ -0,0 +1,35 @@+-- | Checkbox control.+module NanoUI.Widgets.Checkbox (checkbox, checkbox') where++import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context (adoptStoreInt, intKey, recordStoreInt, registerFocusable, writeStoreBool)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, nextId, uiIO)+import NanoUI.Store (boolInt, intBool)+import NanoUI.Style (defaultLayout)+import NanoUI.Widgets.Behavior (keyActivated)+import NanoUI.Widgets.Node (Response, addWidget, respClicked, setChanged)++-- | Checkbox with a caption. Pass whether it is checked; the result is the+-- state after this frame's click or Space/Enter.+{-# INLINE checkbox #-}+checkbox :: Ui :> es => Text -> Bool -> Eff es Bool+checkbox txt checked = snd <$> checkbox' txt checked++checkbox' :: Ui :> es => Text -> Bool -> Eff es (Response, Bool)+checkbox' txt checked = do+  wid <- nextId+  ctx <- askContext+  uiIO $ registerFocusable ctx wid+  let key = intKey wid+  current <- intBool <$> uiIO (adoptStoreInt ctx wid key (boolInt checked))+  resp <- addWidget wid NodeCheckbox txt (if current then 1 else 0) defaultLayout+  keyClick <- keyActivated wid+  let+    clicked = respClicked resp || keyClick+    display = current /= clicked+  uiIO $ do+    writeStoreBool ctx wid display+    recordStoreInt ctx key (boolInt display)+  pure (setChanged clicked resp, display)
+ lib/NanoUI/Widgets/Chrome.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Floating overlay chrome: title bars, close buttons.+module NanoUI.Widgets.Chrome+  ( modalTitleBarH+  , titleBarChromeHFor+  , titleBarLayoutFor+  , titleLabelLayoutFor+  , floatMinFor+  , closeButton+  , windowChromeTop+  , windowChromeSepH+  ) where++import Data.Bits ((.|.))+import Effectful (Eff, type (:>))+import NanoUI.WidgetText (buttonCloseTrailing, buttonFlagClose)+import NanoUI.Monad (Ui)+import NanoUI.Style+  ( Layout (..)+  , alignMid+  , defaultLayout+  , fillW+  , fixedH+  , fixedWH+  , gap+  , tight+  )+import NanoUI.Types (clamp)+import NanoUI.Widgets.Combinators (buttonStyled)+import NanoUI.Widgets.Node (Response)++titleBarH :: Float+titleBarH = 28++closeButtonSize :: Float+closeButtonSize = 24++windowChromeTop :: Float+windowChromeTop = 10++modalTitleBarH :: Float+modalTitleBarH = 40++windowChromeSepH :: Float+windowChromeSepH = 1++titleBarChromeHFor :: Float+titleBarChromeHFor = titleBarH + windowChromeTop + windowChromeSepH++titleBarLayoutFor :: Float -> Layout+titleBarLayoutFor barH =+  tight . gap 6 . alignMid . fixedH barH . fillW $ defaultLayout++titleLabelLayoutFor :: Float -> Layout+titleLabelLayoutFor barH =+  (fixedH barH . alignMid . tight) $+    defaultLayout {layoutMinH = barH, layoutMaxH = barH}++floatMinFor :: Float -> Float -> Float+floatMinFor authored avail = clamp 1 avail authored++{-# INLINE closeButton #-}+closeButton :: (Ui :> es) => Eff es Response+closeButton = buttonStyled "" 0 layout (buttonFlagClose .|. buttonCloseTrailing)+  where+    layout = tight . fixedWH closeButtonSize closeButtonSize . alignMid $ defaultLayout
+ lib/NanoUI/Widgets/ColorPicker.hs view
@@ -0,0 +1,705 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Colour picker. The saturation / value field, the hue bar, the alpha bar and+-- the Current / New preview are separate 'NodeColorPicker' nodes in one row,+-- so each bar is its own focus stop with its own keyboard control.+module NanoUI.Widgets.ColorPicker+  ( ColorPickerPart (..)+  , colorPickerPartOf+  , widgetStoreColor+  , widgetStoreBaseColor+  , colorPickerSvSquare+  , colorPickerPartRect+  , colorPickerPreviewGeom+  , drawColorPickerPart+  , colorPicker+  , colorPicker'+  , colorPickerRGBA+  , colorPickerRGBA'+  )+where++import Control.Monad (forM_, void, when)+import Data.Bits ((.&.))+import Data.IORef (readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Word (Word8)+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , WidgetStore (..)+  , getMenuPointerGesture+  , getStore+  , intKey+  , recordStoreInt+  , registerFocusable+  , setStore+  , getsOverlay+  , OverlayState (..)+  , modifyStore+  )+import NanoUI.Draw+  ( DrawArena+  , pushQuadGradient+  , pushRect+  , pushRoundedRect+  , pushRoundedStroke+  )+import NanoUI.Font+  ( FontMetrics (..)+  )+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (Input (..), Key (..), inputKeys, inputKeysElem, inputModifiers, inputMouseDown, inputMousePressed, modShift)+import NanoUI.Layout.Arena+  ( NodeArena+  , NodeIdx+  , NodeType (..)+  , getFirstChild+  , getNextSibling+  , getNodeType+  , getParent+  , getRect+  , getStyleIdx+  , getWidgetId+  )+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)+import NanoUI.Store (Slot (..), slotKey)+import NanoUI.Style+  ( AlignY (..)+  , Direction (..)+  , Layout (..)+  , Padding (..)+  , Sizing (..)+  , Style (..)+  , defaultLayout+  )+import NanoUI.Types+  ( Color (..)+  , Rect (..)+  , clamp+  , clamp01+  , colorA+  , colorB+  , colorFromWord32+  , colorG+  , colorR+  , colorRGBA+  , colorToWord32+  , hsvToRgb+  , rectH+  , rectW+  , rectX+  , rectY+  , rgbToHsv+  )+import NanoUI.WidgetText+  ( colorPickerGap+  , colorPickerParseHex+  , colorPickerSvH+  , colorToHex+  , colorToHexA+  )+import NanoUI.Widgets.Behavior+  ( DragAxis (..)+  , keyboardFocused+  , keyedDragHeld+  , useDrag1D+  )+import NanoUI.Widgets.Node+  ( Response (..)+  , addWidget+  , addWidgetStyled+  , container+  , respRect+  , setChanged+  )+import NanoUI.Widgets.NumericInput (NumericInputConfig (..), defaultNumericInputConfig, numericInputConfigured)+import NanoUI.Widgets.TextEditor (singleLineMode)+import NanoUI.Widgets.TextInput (editTextField)++colorPickerDefaultColor :: Color+colorPickerDefaultColor = colorRGBA 128 128 128 255++colorPickerBarW :: Float+colorPickerBarW = 14++colorPickerSwatchH :: Float+colorPickerSwatchH = 30++colorPickerSwatchW :: Float+colorPickerSwatchW = 80++-- Width reserved for the Current / New preview column (label plus swatch).+colorPickerPreviewW :: Float+colorPickerPreviewW = 112++-- | The piece of a colour picker a 'NodeColorPicker' node paints, kept in the+-- low bits of its style.+data ColorPickerPart = PickerSv | PickerHue | PickerAlpha | PickerPreview+  deriving (Eq, Show, Enum, Bounded)++{-# INLINE colorPickerPartOf #-}+colorPickerPartOf :: Int -> ColorPickerPart+colorPickerPartOf si = toEnum (si .&. 3)++storeColorAt :: WidgetStore -> Int -> Color -> Color+storeColorAt store key fallback =+  colorFromWord32+    ( fromIntegral+        ( IM.findWithDefault+            (fromIntegral (colorToWord32 fallback))+            key+            (storeInt store)+        )+    )++widgetStoreColor :: WidgetStore -> WidgetId -> Color -> Color+widgetStoreColor store wid fallback = storeColorAt store (intKey wid) fallback++widgetStoreBaseColor :: WidgetStore -> WidgetId -> Color -> Color+widgetStoreBaseColor store wid fallback =+  storeColorAt+    store+    (slotKey SlotColorBase (intKey wid))+    (widgetStoreColor store wid fallback)++-- RGB cannot tell hue 0 from 360. Keep the slider end the user last set.+widgetStoreHue :: WidgetStore -> WidgetId -> Color -> Float+widgetStoreHue store wid fallback =+  let+    (h0, _, _) = rgbToHsv (widgetStoreColor store wid fallback)+   in+    IM.findWithDefault h0 (intKey wid) (storeFloat store)++-- Black collapses S in RGB. Keep the last mouse S/V so the marker does not jitter.+widgetStoreSv :: WidgetStore -> WidgetId -> Color -> (Float, Float)+widgetStoreSv store wid fallback =+  let+    (_, s0, v0) = rgbToHsv (widgetStoreColor store wid fallback)+   in+    fromMaybe (s0, v0) (IM.lookup (intKey wid) (storePoint store))++-- | Store the live colour with the hue and S/V it was set through.+putColorState :: Int -> Color -> Float -> (Float, Float) -> WidgetStore -> WidgetStore+putColorState key col hue sv st =+  st+    { storeInt = IM.insert key (fromIntegral (colorToWord32 col)) (storeInt st)+    , storeFloat = IM.insert key hue (storeFloat st)+    , storePoint = IM.insert key sv (storePoint st)+    }++withAlpha :: Word8 -> Color -> Color+withAlpha a c = colorRGBA (colorR c) (colorG c) (colorB c) a++-- | The square the saturation / value field fills, centered in its node.+colorPickerSvSquare :: Rect -> Rect+colorPickerSvSquare (Rect x y w h) =+  let s = max 0 (min w h)+   in Rect (x + (w - s) / 2) (y + (h - s) / 2) s s++-- | The field node of the picker a part belongs to: the part's sibling that+-- paints the saturation / value square. Its widget id keys the picker's state.+pickerSvNode :: NodeArena -> NodeIdx -> IO NodeIdx+pickerSvNode na idx = do+  parent <- getParent na idx+  if parent < 0 then pure idx else getFirstChild na parent >>= go+  where+    go ci+      | ci < 0 = pure idx+      | otherwise = do+          nt <- getNodeType na ci+          si <- getStyleIdx na ci+          if nt == NodeColorPicker && colorPickerPartOf si == PickerSv+            then pure ci+            else getNextSibling na ci >>= go++-- | Where the part at @idx@ (laid out at @rect@) draws: the field's square, or+-- the part's column cut to the square's height so the bars and the preview+-- line up with the field.+colorPickerPartRect :: NodeArena -> NodeIdx -> Rect -> IO Rect+colorPickerPartRect na idx rect@(Rect x _ w _) = do+  si <- getStyleIdx na idx+  case colorPickerPartOf si of+    PickerSv -> pure (colorPickerSvSquare rect)+    _ -> do+      (sx, sy0, sw, sh) <- pickerSvNode na idx >>= getRect na+      let Rect _ sy _ side = colorPickerSvSquare (Rect sx sy0 sw sh)+      pure (Rect x sy w side)++-- | The preview column's rows, stacked and centered in its band: the Current+-- label's top, its swatch, the New label's top, and its swatch.+colorPickerPreviewGeom :: FontMetrics -> Rect -> (Float, Rect, Float, Rect)+colorPickerPreviewGeom fm (Rect x y w h) =+  let+    labelH = fmLineHeight fm+    swatchW = min colorPickerSwatchW w+    swatchH = clamp 0 colorPickerSwatchH (h - labelH * 2 - colorPickerGap)+    stackH = labelH + swatchH + colorPickerGap + labelH + swatchH+    top = y + max 0 ((h - stackH) / 2)+    currentY = top + labelH+    newLabelY = currentY + swatchH + colorPickerGap+   in+    (top, Rect x currentY swatchW swatchH, newLabelY, Rect x (newLabelY + labelH) swatchW swatchH)++-- Wider than the painted bar so the handle is easy to grab.+colorPickerBarHitRect :: Rect -> Rect+colorPickerBarHitRect (Rect x y w h) =+  let+    pad = 2+   in+    Rect (x - pad) y (w + pad * 2) h++drawSvField :: DrawArena -> Rect -> Float -> IO ()+drawSvField da rect hue = do+  let+    white = colorRGBA 255 255 255 255+    hueCol = hsvToRgb hue 1 1+    clear = colorRGBA 0 0 0 0+    black = colorRGBA 0 0 0 255+  -- Horizontal: white to hue. Vertical overlay: fade to black (alpha over).+  pushQuadGradient da rect white hueCol hueCol white+  pushQuadGradient da rect clear clear black black++-- Vertical rainbow: each stop band fades into the next.+drawHueBar :: DrawArena -> Rect -> IO ()+drawHueBar da rect =+  let+    stops = (6 :: Int)+    cellH = rectH rect / fromIntegral stops+    stopCol i = hsvToRgb (360 * fromIntegral i / fromIntegral stops) 1 1+   in+    mapM_+      ( \i ->+          let+            cell = Rect (rectX rect) (rectY rect + fromIntegral i * cellH) (rectW rect) cellH+           in+            pushQuadGradient+              da+              cell+              (stopCol i)+              (stopCol i)+              (stopCol (i + 1))+              (stopCol (i + 1))+      )+      [0 .. stops - 1]++drawChecker :: DrawArena -> Rect -> IO ()+drawChecker da (Rect x y w h) = goRows 0+  where+    s = 6 :: Float+    cols = ceiling (max 0 w / s) :: Int+    rows = ceiling (max 0 h / s) :: Int+    -- Nested range folds retain a shared column list under -O2. Explicit+    -- counters keep both loops numeric, without allocating that list.+    goRows !ry = when (ry < rows) $ do+      goCols ry 0+      goRows (ry + 1)+    goCols !ry !cx = when (cx < cols) $ do+      let+        col =+          if even (ry + cx) then colorRGBA 190 190 190 255 else colorRGBA 140 140 140 255+        rx = x + fromIntegral cx * s+        ry' = y + fromIntegral ry * s+        cw = clamp 0 s (x + w - rx)+        ch = clamp 0 s (y + h - ry')+      pushRect da (Rect rx ry' cw ch) col+      goCols ry (cx + 1)++drawAlphaBar :: DrawArena -> Rect -> Color -> IO ()+drawAlphaBar da rect col = do+  drawChecker da rect+  let+    c0 = withAlpha 0 col+    c1 = withAlpha 255 col+  pushQuadGradient da rect c0 c0 c1 c1++drawBarHandle :: DrawArena -> Rect -> Float -> Color -> IO ()+drawBarHandle da bar cy col = do+  let+    w = rectW bar+    x = rectX bar+    h = 4+    handle = Rect (x - 3) (cy - h / 2) (w + 6) h+  pushRoundedRect da handle 2 (colorRGBA 255 255 255 255)+  pushRoundedStroke da handle 2 1 col++-- | Paint one part of a picker from its state in the store.+drawColorPickerPart :: NodeArena -> NodeIdx -> FontMetrics -> DrawArena -> WidgetStore -> Style -> Rect -> IO ()+drawColorPickerPart na idx fm da store style rect = do+  si <- getStyleIdx na idx+  owner <- pickerSvNode na idx >>= getWidgetId na+  area <- colorPickerPartRect na idx rect+  let+    newCol = widgetStoreColor store owner colorPickerDefaultColor+    border = styleBorder style+    handleCol = colorRGBA 0 0 0 180+  case colorPickerPartOf si of+    PickerSv -> do+      let+        hue = widgetStoreHue store owner colorPickerDefaultColor+        (sat, val) = widgetStoreSv store owner colorPickerDefaultColor+        marker = 6+        mx = rectX area + sat * rectW area+        my = rectY area + (1 - val) * rectH area+        dot = Rect (mx - marker / 2) (my - marker / 2) marker marker+      drawSvField da area hue+      pushRoundedStroke da area 4 1 border+      pushRoundedRect da dot (marker / 2) (colorRGBA 255 255 255 255)+      pushRoundedStroke da dot (marker / 2) 1 handleCol+    PickerHue -> do+      let hue = widgetStoreHue store owner colorPickerDefaultColor+      drawHueBar da area+      pushRoundedStroke da area 3 1 border+      drawBarHandle da area (rectY area + (hue / 360) * rectH area) handleCol+    PickerAlpha -> do+      drawAlphaBar da area newCol+      pushRoundedStroke da area 3 1 border+      drawBarHandle da area (rectY area + (fromIntegral (colorA newCol) / 255) * rectH area) handleCol+    PickerPreview -> do+      let+        (_, current, _, new) = colorPickerPreviewGeom fm area+        swatch r col = do+          drawChecker da r+          pushRect da r col+          pushRoundedStroke da r 0 1 border+      swatch current (widgetStoreBaseColor store owner colorPickerDefaultColor)+      swatch new newCol++colorPickerLayout :: Layout+colorPickerLayout =+  defaultLayout+    { layoutDirection = Column+    , layoutWidth = Grow 1+    , layoutGap = colorPickerGap+    , layoutPadding = Padding 0 0 0 0+    }++-- The field, bars and preview side by side.+colorPickerCanvasLayout :: Layout+colorPickerCanvasLayout =+  colorPickerLayout {layoutDirection = Row}++-- The field grows up to a square as tall as the row.+colorPickerSvLayout :: Layout+colorPickerSvLayout =+  defaultLayout+    { layoutWidth = Grow 1+    , layoutHeight = Fixed colorPickerSvH+    , layoutMinW = 60+    , layoutMaxW = colorPickerSvH+    , layoutPadding = Padding 0 0 0 0+    }++colorPickerColumnLayout :: Float -> Layout+colorPickerColumnLayout w =+  colorPickerSvLayout {layoutWidth = Fixed w, layoutMinW = w, layoutMaxW = w}++-- A row of channel fields. Children are groups sized by 'percent' so the+-- R/G/B(/A) and H/S/V rows share the same column widths.+colorPickerRowLayout :: Layout+colorPickerRowLayout =+  colorPickerLayout {layoutDirection = Row, layoutAlignY = AlignMiddle}++-- One channel field: an inline label plus its bare box, taking @pct@ of the row.+colorPickerFieldGroupLayout :: Float -> Layout+colorPickerFieldGroupLayout pct =+  colorPickerLayout+    { layoutDirection = Row+    , layoutWidth = Percent pct+    , layoutAlignY = AlignMiddle+    }++colorPickerFieldLayout :: Layout+colorPickerFieldLayout =+  defaultLayout+    { layoutWidth = Grow 1+    , layoutMinW = 40+    , layoutPadding = Padding 0 0 0 0+    }++-- A numeric channel field: room for three digits beside its stepper.+colorPickerChannelLayout :: Layout+colorPickerChannelLayout = colorPickerFieldLayout {layoutMinW = 60}++colorPickerLabelLayout :: Layout+colorPickerLabelLayout =+  defaultLayout {layoutPadding = Padding 0 0 0 0, layoutAlignY = AlignMiddle}++-- | RGB colour picker: a saturation/value field, a hue bar, and RGB, HSV and+-- hex fields. Pass the current colour; the result is the colour after this+-- frame's edits.+--+-- The field and each bar take keyboard focus in turn. On the field the arrow+-- keys move the marker (left and right for saturation, up and down for+-- value); on a bar they move its handle, and Home and End jump to its ends.+-- Shift takes steps ten times larger.+{-# INLINE colorPicker #-}+colorPicker :: Ui :> es => Color -> Eff es Color+colorPicker value = snd <$> colorPickerWith False value++colorPicker' :: Ui :> es => Color -> Eff es (Response, Color)+colorPicker' = colorPickerWith False++-- | 'colorPicker' with an alpha bar and an A / @#RRGGBBAA@ field.+{-# INLINE colorPickerRGBA #-}+colorPickerRGBA :: Ui :> es => Color -> Eff es Color+colorPickerRGBA value = snd <$> colorPickerWith True value++colorPickerRGBA' :: Ui :> es => Color -> Eff es (Response, Color)+colorPickerRGBA' = colorPickerWith True++-- | The byte fields: label, the channel read, and the channel write.+rgbChannels, rgbaChannels :: [(Text, Color -> Word8, Word8 -> Color -> Color)]+rgbChannels =+  [ ("R", colorR, \v c -> colorRGBA v (colorG c) (colorB c) (colorA c))+  , ("G", colorG, \v c -> colorRGBA (colorR c) v (colorB c) (colorA c))+  , ("B", colorB, \v c -> colorRGBA (colorR c) (colorG c) v (colorA c))+  ]+rgbaChannels = rgbChannels ++ [("A", colorA, \v c -> colorRGBA (colorR c) (colorG c) (colorB c) v)]++-- | The HSV fields: label, the largest value, the shown value, and the+-- (hue, s, v) a typed value makes.+hsvChannels :: [(Text, Int, (Float, Float, Float) -> Int, Int -> (Float, Float, Float) -> (Float, Float, Float))]+hsvChannels =+  [ ("H", 360, \(h, _, _) -> round h, \n (_, s, v) -> (fromIntegral n, s, v))+  , ("S", 100, \(_, s, _) -> round (s * 100), \n (h, _, v) -> (h, percent n, v))+  , ("V", 100, \(_, _, v) -> round (v * 100), \n (h, s, _) -> (h, s, percent n))+  ]+  where+    percent n = fromIntegral n / 100++-- | Widget ids of a picker's parts. The field's id keys the picker's state.+data PickerParts = PickerParts+  { ppSv :: !WidgetId+  , ppHue :: !WidgetId+  , ppAlpha :: !WidgetId+  , ppPreview :: !WidgetId+  }++colorPickerWith ::+  Ui :> es => Bool -> Color -> Eff es (Response, Color)+colorPickerWith showAlpha value = do+  ctx <- askContext+  parts <- PickerParts <$> nextId <*> nextId <*> nextId <*> nextId+  let+    wid = ppSv parts+    key = intKey wid+    pct = 100 / (if showAlpha then 4 else 3)+    readColor = (\st -> widgetStoreColor st wid value) <$> uiIO (getStore ctx)+    writePicker col hue sv = uiIO (modifyStore ctx (putColorState key col hue sv))+    writeColor col =+      let (h, s, v) = rgbToHsv col+       in writePicker col (clamp 0 360 h) (s, v)+    -- Without the alpha bar the colour stays opaque.+    alphaOf c = if showAlpha then colorA c else 255+    part pid p lay = addWidgetStyled pid NodeColorPicker "" 0 lay (fromEnum p)+  uiIO $ do+    adoptColorPickerValue ctx wid value+    mapM_ (registerFocusable ctx) (wid : ppHue parts : [ppAlpha parts | showAlpha])+  (start, final, svResp) <- container NodeContainer colorPickerLayout $ do+    (svResp, hueResp, alphaResp) <-+      container NodeContainer colorPickerCanvasLayout $ do+        sv <- part wid PickerSv colorPickerSvLayout+        hue <- part (ppHue parts) PickerHue (colorPickerColumnLayout colorPickerBarW)+        alpha <-+          if showAlpha+            then Just <$> part (ppAlpha parts) PickerAlpha (colorPickerColumnLayout colorPickerBarW)+            else pure Nothing+        void (part (ppPreview parts) PickerPreview (colorPickerColumnLayout colorPickerPreviewW))+        pure (sv, hue, alpha)+    start <- colorPickerCanvas parts value svResp hueResp alphaResp+    -- Only the focused field edits, so each row's fields share one store read.+    rgb <- readColor+    _ <- container NodeContainer colorPickerRowLayout $+      forM_ (if showAlpha then rgbaChannels else rgbChannels) $ \(lbl, get, set) -> do+        let shown = fromIntegral (get rgb)+        n <- channelField pct lbl 255 shown+        when (n /= shown) $+          writeColor (set (fromIntegral n) (withAlpha (alphaOf rgb) rgb))+    hsvStore <- uiIO (getStore ctx)+    let+      (s0, v0) = widgetStoreSv hsvStore wid value+      hsv = (widgetStoreHue hsvStore wid value, s0, v0)+      alpha = alphaOf (widgetStoreColor hsvStore wid value)+    _ <- container NodeContainer colorPickerRowLayout $ do+      forM_ hsvChannels $ \(lbl, hi, shown, edit) -> do+        n <- channelField pct lbl hi (shown hsv)+        when (n /= shown hsv) $ do+          let (h, s, v) = edit n hsv+          writePicker (withAlpha alpha (hsvToRgb h s v)) h (s, v)+      when showAlpha $+        void (container NodeContainer (colorPickerFieldGroupLayout pct) (pure ()))+    hex <- readColor+    let hexText = if showAlpha then colorToHexA hex else colorToHex hex+    hexWid <- nextId+    (_, thex, fhex, _) <- editTextField hexWid singleLineMode hexText (Just hexText)+    _ <-+      container NodeContainer (colorPickerFieldGroupLayout 100) $+        addWidgetStyled hexWid NodeTextInput "" 0 colorPickerFieldLayout 0+    when (fhex && thex /= hexText) $+      forM_ (colorPickerParseHex thex) $ \(r, g, b, ma) ->+        writeColor (colorRGBA r g b (if showAlpha then fromMaybe (colorA hex) ma else 255))+    final <- readColor+    pure (start, final, svResp)+  uiIO $ recordStoreInt ctx key (fromIntegral (colorToWord32 final))+  pure (setChanged (final /= start) svResp, final)++-- | The field and the bars: pointer drags, then arrow keys on whichever part+-- holds focus, then committing the "current" swatch when a drag ends or a key+-- moved the colour. Returns the colour the frame started with.+colorPickerCanvas :: Ui :> es => PickerParts -> Color -> Response -> Response -> Maybe Response -> Eff es Color+colorPickerCanvas parts initial svResp hueResp alphaResp = do+  ctx <- askContext+  inp <- askInput+  active <- uiIO (readIORef (ctxActiveId ctx))+  blocked <- uiIO (getsOverlay ctx osLastPointerBlocked)+  gesture <- uiIO (getMenuPointerGesture ctx)+  store0 <- uiIO (getStore ctx)+  hueHeld0 <- keyedDragHeld ("hue" :: Text)+  alphaHeld0 <- keyedDragHeld ("alpha" :: Text)+  sHeld0 <- keyedDragHeld ("s" :: Text)+  vHeld0 <- keyedDragHeld ("v" :: Text)+  let+    wid = ppSv parts+    showAlpha = isJust alphaResp+    current0 = widgetStoreColor store0 wid initial+    h0 = widgetStoreHue store0 wid initial+    (s0, v0) = widgetStoreSv store0 wid initial+    svHeld0 = sHeld0 || vHeld0+    empty = Rect 0 0 0 0+    isActive = active == wid+    -- A press lands on whichever part is under the pointer; the picker then+    -- takes the active id over while it drags.+    ownsActive = active `elem` [wid, ppHue parts, ppAlpha parts, ppPreview parts]+    heldByOther =+      inputMouseDown inp+        && not (inputMousePressed inp)+        && hashWidgetId active /= 0+        && not ownsActive+    locked = blocked || heldByOther || gesture+    svSquare = colorPickerSvSquare (respRect svResp)+    band resp = Rect (rectX (respRect resp)) (rectY svSquare) (rectW (respRect resp)) (rectH svSquare)+    svRect = if locked || hueHeld0 || alphaHeld0 then empty else svSquare+    hueRect = if locked || svHeld0 || alphaHeld0 then empty else colorPickerBarHitRect (band hueResp)+    alphaRect =+      case alphaResp of+        Just r | not (locked || svHeld0 || hueHeld0) -> colorPickerBarHitRect (band r)+        _ -> empty+  (sDrag, sA) <- withKey ("s" :: Text) (useDrag1D DragAxisX 0 1 s0 svRect)+  (vDrag, vA) <- withKey ("v" :: Text) (useDrag1D DragAxisY 1 0 v0 svRect)+  let svA = sA || vA+  (hDrag, hA) <-+    withKey ("hue" :: Text) (useDrag1D DragAxisY 0 360 h0 (if svA then empty else hueRect))+  (aDrag, aA) <-+    withKey+      ("alpha" :: Text)+      (useDrag1D DragAxisY 0 255 (fromIntegral (colorA current0)) (if svA || hA then empty else alphaRect))+  let+    dragging = svA || hA || aA+    nextHue = if hA then hDrag else h0+    nextS = if sA then sDrag else s0+    nextV = if vA then vDrag else v0+    nextA =+      if aA then clamp 0 255 (round aDrag :: Int) else fromIntegral (colorA current0)+    base = hsvToRgb nextHue nextS nextV+    dragged+      | aA && not (svA || hA) = withAlpha (fromIntegral nextA) current0+      | otherwise = withAlpha (if showAlpha then fromIntegral nextA else 255) base+  when (dragging && not isActive) $ uiIO $ writeIORef (ctxActiveId ctx) wid+  when ((not dragging || blocked) && isActive) $+    uiIO $ writeIORef (ctxActiveId ctx) (WidgetId 0)+  when (dragging && (dragged /= current0 || nextHue /= h0 || nextS /= s0 || nextV /= v0)) $+    uiIO $ modifyStore ctx (putColorState (intKey wid) dragged nextHue (nextS, nextV))+  svFocus <- keyboardFocused wid+  hueFocus <- keyboardFocused (ppHue parts)+  alphaFocus <- if showAlpha then keyboardFocused (ppAlpha parts) else pure False+  keyMoved <-+    if not (svFocus || hueFocus || alphaFocus)+      then pure False+      else uiIO (applyColorPickerKeys ctx wid initial inp svFocus hueFocus)+  let releasedDrag = (hueHeld0 || alphaHeld0 || svHeld0) && not dragging+  when (releasedDrag || keyMoved) $+    uiIO $ do+      st <- getStore ctx+      commitColorPickerCurrent ctx wid (widgetStoreColor st wid initial)+  pure current0++-- | One channel field: an inline label and a numeric box over @0..hi@ that+-- shows @value@ while unfocused. Returns the value after this frame's edits.+channelField :: Ui :> es => Float -> Text -> Int -> Int -> Eff es Int+channelField pct label hi value =+  container NodeContainer (colorPickerFieldGroupLayout pct) $ do+    labelWid <- nextId+    void (addWidget labelWid NodeText label 0 colorPickerLabelLayout)+    round+      <$> numericInputConfigured+        defaultNumericInputConfig {nicMin = 0, nicMax = fromIntegral hi, nicLayout = colorPickerChannelLayout}+        (fromIntegral value)++-- | Adopt the caller's colour as 'NanoUI.Context.adoptStoreInt' does. A new+-- colour also resets the hue, S/V, and the "current" swatch.+adoptColorPickerValue :: Context -> WidgetId -> Color -> IO ()+adoptColorPickerValue ctx wid value = do+  store0 <- getStore ctx+  let+    key = intKey wid+    packed = fromIntegral (colorToWord32 value)+    seenKey = slotKey SlotSeen key+    ints = IM.insert seenKey packed (storeInt store0)+  when (IM.lookup seenKey (storeInt store0) /= Just packed) $+    setStore ctx $+      if IM.lookup key (storeInt store0) == Just packed+        then store0 {storeInt = ints}+        else+          let (h, s, v) = rgbToHsv value+           in putColorState key value (clamp 0 360 h) (s, v) $+                store0 {storeInt = IM.insert (slotKey SlotColorBase key) packed ints}++commitColorPickerCurrent :: Context -> WidgetId -> Color -> IO ()+commitColorPickerCurrent ctx wid col = do+  st <- getStore ctx+  let+    packed = fromIntegral (colorToWord32 col)+    k = slotKey SlotColorBase (intKey wid)+    old = IM.findWithDefault packed k (storeInt st)+  when (old /= packed) $+    setStore ctx (st {storeInt = IM.insert k packed (storeInt st)})++-- | Arrow, Home and End keys on the focused part: the field when @svFocus@,+-- the hue bar when @hueFocus@, otherwise the alpha bar. Arrows move a part+-- the way it is drawn: the marker right for more saturation and up for more+-- value, a bar's handle down (or right) towards its bottom end. Returns+-- whether the colour moved.+applyColorPickerKeys :: Context -> WidgetId -> Color -> Input -> Bool -> Bool -> IO Bool+applyColorPickerKeys ctx wid fallback inp svFocus hueFocus = do+  store <- getStore ctx+  let+    keys = inputKeys inp+    down k = inputKeysElem k keys+    step = if modShift (inputModifiers inp) then 10 else 1+    along neg pos = (if down pos then 1 else 0) - (if down neg then 1 else 0) :: Float+    dx = along KeyLeft KeyRight+    dy = along KeyUp KeyDown+    current = widgetStoreColor store wid fallback+    h = widgetStoreHue store wid current+    (s, v) = widgetStoreSv store wid current+    a = fromIntegral (colorA current) :: Float+    bar lo hi cur+      | down KeyHome = lo+      | down KeyEnd = hi+      | otherwise = clamp lo hi (cur + (dx + dy) * step)+    (col', h', sv')+      | svFocus =+          let sat = clamp01 (s + dx * step / 100)+              val = clamp01 (v - dy * step / 100)+           in (withAlpha (colorA current) (hsvToRgb h sat val), h, (sat, val))+      | hueFocus =+          let hue = bar 0 360 h+           in (withAlpha (colorA current) (hsvToRgb hue s v), hue, (s, v))+      | otherwise = (withAlpha (round (bar 0 255 a)) current, h, (s, v))+    moved = col' /= current || h' /= h || sv' /= (s, v)+  when moved $+    setStore ctx (putColorState (intKey wid) col' h' sv' store)+  pure moved
+ lib/NanoUI/Widgets/Combinators.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Button and selection helpers shared by the widget modules.+module NanoUI.Widgets.Combinators+  ( buttonStyled+  , buttonStyledEx+  , selectableItem+  , withBoundedIndex+  )+where++import Control.Monad (when)+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context (isDisabled, registerFocusable)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, nextId, uiIO)+import NanoUI.Style (Layout (..))+import NanoUI.Widgets.Behavior (keyActivated)+import NanoUI.Widgets.Node+  ( Response (..)+  , addWidgetStyled+  , setClicked+  )++-- | Button with styleIdx for active, sort, badge, or close chrome. Focusable+-- and activatable with Enter or Space while focused.+buttonStyled :: (Ui :> es) => Text -> Float -> Layout -> Int -> Eff es Response+buttonStyled = buttonStyledEx True++-- | Shared activation path for ordinary buttons, menu items, and header chrome.+-- Disabled controls keep their identity and geometry but cannot take focus or+-- activate, including through a click queued before they became disabled.+{-# INLINE buttonStyledEx #-}+buttonStyledEx :: (Ui :> es) => Bool -> Text -> Float -> Layout -> Int -> Eff es Response+buttonStyledEx enabled txt value layout styleIdx = do+  wid <- nextId+  ctx <- askContext+  disabled <- uiIO (isDisabled ctx wid)+  let active = enabled && not disabled+  when active $ uiIO (registerFocusable ctx wid)+  resp <- addWidgetStyled wid NodeButton txt value layout styleIdx+  if active+    then do+      keyClick <- keyActivated wid+      pure (if keyClick then setClicked True resp else resp)+    else pure resp+      { rawRespHovered = False+      , rawRespPressed = False+      , rawRespClicked = False+      , rawRespRightPressed = False+      , rawRespRightClicked = False+      }++selectableItem :: (Ui :> es) => NodeType -> Text -> Bool -> Layout -> Int -> Eff es Response+selectableItem nt txt selected layout styleIdx = do+  wid <- nextId+  addWidgetStyled+    wid+    nt+    txt+    (if selected then 1 else 0)+    layout+    styleIdx++-- | Run an index-based picker over every value of a bounded enum. Indices+-- are offset by @fromEnum minBound@, so enums that do not start at 0 map+-- correctly. Meant for small enums: every value becomes an option.+withBoundedIndex ::+  forall a r f.+  (Bounded a, Enum a, Functor f) =>+  (a -> Text) -> a -> ([Text] -> Int -> f (r, Int)) -> f (r, a)+withBoundedIndex encode initial pick =+  fmap (toEnum . (+ lower))+    <$> pick (map encode [minBound .. maxBound]) (fromEnum initial - lower)+  where+    lower = fromEnum (minBound :: a)
+ lib/NanoUI/Widgets/Combo.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Combo box: a search field with a filtered, scrollable suggestion dropdown.+-- The per-frame logic is the pure 'comboStep' over a persisted 'ComboState'.+module NanoUI.Widgets.Combo+  ( comboBox+  , comboBox'+  , ComboState (..)+  , ComboInput (..)+  , ComboStep (..)+  , comboStep+  )+where++import Control.Monad (foldM, when, (<$!>))+import Data.IORef (writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , getStore+  , intKey+  , markDirty+  , markEscapeConsumed+  , modifyStore+  , recordStoreText+  )+import NanoUI.Font (FontMetrics, menuItemRowH)+import NanoUI.Frame.Hit (findNodeByWidgetId)+import NanoUI.Frame.Select (comboDropPickIndex, comboDropRect, comboScrollGeom)+import NanoUI.Id (WidgetId (..))+import NanoUI.Input (Key (..), inputKeys, inputMouseDown, inputMousePos, inputMousePressed, inputScroll)+import NanoUI.Layout.Arena (setOptions)+import NanoUI.Monad (Ui, askContext, askInput, uiIO)+import NanoUI.Store+  ( WidgetStore (..)+  , boolInt+  , Slot (..)+  , slotKey+  )+import NanoUI.Types (Rect (..), V2 (..), clamp, rectContains, rectNonEmpty, v2X, v2Y)+import NanoUI.WidgetText (textInputFlagSearch)+import NanoUI.Widgets.Behavior (keyboardFocused)+import NanoUI.Widgets.Node (Response (..), setChanged)+import NanoUI.Widgets.TextInput (buildTextInput, searchFieldLayout)++-- | Maximum suggestion rows the combo dropdown shows at once; Up/Down walk+-- the highlight and the wheel scrolls the list through a sliding window.+comboBoxMaxVisible :: Int+comboBoxMaxVisible = 8++-- | Rows scrolled per wheel notch.+comboBoxRowsPerNotch :: Float+comboBoxRowsPerNotch = 3++-- | Case-insensitive substring filter behind the combo's suggestion list.+comboFiltered :: Foldable f => f Text -> Text -> [Text]+comboFiltered options q+  | T.null q = opts+  | otherwise =+      let needle = T.toLower q+        in filter (T.isInfixOf needle . T.toLower) opts+  where+    opts = foldr (:) [] options++-- | A combo's state between frames.+data ComboState = ComboState+  { csHighlight :: !Int+    -- ^ Highlighted row of the filtered list; -1 for none.+  , csWindow :: !Int+    -- ^ First visible row.+  , csScrollX :: !Float+  , csContentW :: !Float+    -- ^ Widest matching row, measured while focused.+  , csDrag :: !Int+    -- ^ Scrollbar thumb drag: 0 none, 1 vertical, 2 horizontal.+  , csDragOff :: !Float+    -- ^ Pointer offset into the dragged thumb.+  , csCommitted :: !Text+    -- ^ Last committed value.+  , csLive :: !Text+    -- ^ Field text the combo last produced.+  , csFocused :: !Bool+  }+  deriving (Eq, Show)++-- | One frame's inputs to 'comboStep'.+data ComboInput = ComboInput+  { ciFocused :: !Bool+  , ciEdited :: !Bool+    -- ^ Typing changed the field text this frame.+  , ciText :: !Text+    -- ^ Field text after this frame's editing.+  , ciRows :: ![Text]+    -- ^ Options matching the field text.+  , ciContentW :: !Float+    -- ^ Width of the widest matching row.+  , ciField :: !Rect+    -- ^ The field's rect; empty before its first layout.+  , ciMetrics :: !FontMetrics+  , ciMouse :: !V2+  , ciPressed :: !Bool+  , ciDown :: !Bool+  , ciScroll :: !V2+  , ciKeyUp :: !Bool+  , ciKeyDown :: !Bool+  , ciEnter :: !Bool+  , ciEscape :: !Bool+  }++-- | What one frame of the combo decided.+data ComboStep = ComboStep+  { stepState :: !ComboState+  , stepCommit :: !(Maybe Text)+    -- ^ The newly committed value, on the frame the committed value changes.+  , stepPicked :: !Bool+    -- ^ Enter picked the highlighted row; the caret moves to the text's end.+  , stepDismissed :: !Bool+    -- ^ Escape reverted the field to the committed value and releases focus.+  , stepRedraw :: !Bool+    -- ^ Something visible moved.+  }++-- | One frame of the combo: highlight, scrolling, thumb drags, and commits.+--+-- Typing edits the live text but never commits it: the committed value only+-- changes on Enter (which commits the highlighted row only), on a row click+-- (a field text the combo did not produce), or when the field loses focus.+-- Escape reverts the live text to the last committed value. Hover+-- highlights a row and makes it the Enter target; Up/Down move the highlight.+comboStep :: ComboInput -> ComboState -> ComboStep+comboStep ci cs0 =+  ComboStep+    { stepState =+        ComboState+          { csHighlight = hi'+          , csWindow = win+          , csScrollX = xOff+          , csContentW = contentW+          , csDrag = dragKind'+          , csDragOff = dragOff'+          , csCommitted = fromMaybe committed0 commitText+          , csLive = finalText+          , csFocused = isFocus+          }+    , stepCommit = if commitPulse then commitText else Nothing+    , stepPicked = picked+    , stepDismissed = escDismiss+    , stepRedraw =+        picked || nav /= 0 || escDismiss || wheelDelta /= 0 || xWheel /= 0+          || win /= storedWin || xOff /= storedX || hi' /= storedHi+          || dragKind' /= drag0 || commitPulse || csFocused cs0 /= isFocus+    }+  where+    isFocus = ciFocused ci+    text = ciText ci+    displayed = ciRows ci+    contentW = ciContentW ci+    n = length displayed+    vis = max 1 comboBoxMaxVisible+    storedHi = csHighlight cs0+    storedWin = csWindow cs0+    storedX = csScrollX cs0+    drag0 = csDrag cs0+    dragOff0 = csDragOff cs0+    committed0 = csCommitted cs0+    -- Typing clears the highlight (-1): it never pre-selects a row.+    hi0 = if ciEdited ci then -1 else storedHi+    win0 = if ciEdited ci then 0 else storedWin+    nav+      | not isFocus || n <= 0 = 0 :: Int+      | ciKeyDown ci = 1+      | ciKeyUp ci = -1+      | otherwise = 0+    hi+      | nav == 0 = hi0+      | hi0 < 0 = if nav > 0 then 0 else n - 1+      | otherwise = clamp 0 (n - 1) (hi0 + nav)+    clampWin = clamp 0 (max 0 (n - vis))+    -- Keep the highlighted row inside the window after keyboard navigation.+    alignWin v+      | n <= vis = 0+      | hi < v = hi+      | hi >= v + vis = hi - vis + 1+      | otherwise = clampWin v+    Rect rx ry rw rh = ciField ci+    mouse = ciMouse ci+    dropRect = comboDropRect rx ry rw rh (min vis n) n contentW+    overDrop = isFocus && rectNonEmpty (ciField ci) && rectContains dropRect mouse+    itemH = menuItemRowH+    -- Hover highlights the row under the pointer (and makes it the Enter+    -- target); it never commits by itself. Rows on screen belong to the+    -- previous frame's window, so the hit test maps through storedWin.+    hoverIdx+      | overDrop = (storedWin +) <$> comboDropPickIndex dropRect itemH (min vis n) (v2Y mouse)+      | otherwise = Nothing+    hiRaw = fromMaybe hi hoverIdx+    -- A hover mapped through a stale window can point past a shrunken list:+    -- highlight nothing then.+    hi' = if hiRaw < n then hiRaw else -1+    -- Scrollbar geometry from the pre-frame scroll state (the thumb the user+    -- is looking at when a drag starts).+    (_, vSb, hSb, usableW) = comboScrollGeom dropRect n vis storedWin storedX contentW+    maxOffX = max 0 (contentW - usableW)+    onVThumb = maybe False (\(_, th) -> rectContains th mouse) vSb+    onVTrack = maybe False (\(t, _) -> rectContains t mouse) vSb+    onHThumb = maybe False (\(_, th) -> rectContains th mouse) hSb+    onHTrack = maybe False (\(t, _) -> rectContains t mouse) hSb+    pressed = isFocus && ciPressed ci+    down = isFocus && ciDown ci+    startV = pressed && overDrop && onVTrack+    startH = pressed && overDrop && not startV && onHTrack+    vThumbR = maybe (Rect 0 0 0 0) snd vSb+    vTrackR = maybe (Rect 0 0 0 0) fst vSb+    hThumbR = maybe (Rect 0 0 0 0) snd hSb+    hTrackR = maybe (Rect 0 0 0 0) fst hSb+    vGrab = if onVThumb then v2Y mouse - rectY vThumbR else rectH vThumbR / 2+    hGrab = if onHThumb then v2X mouse - rectX hThumbR else rectW hThumbR / 2+    drag1+      | startV = 1+      | startH = 2+      | down && drag0 /= 0 = drag0+      | otherwise = 0+    -- Thumb-anchored drags move from the next frame on; track presses jump+    -- the window to the click immediately.+    draggingV = down && drag1 == 1 && ((drag0 == 1 && not startV) || (startV && not onVThumb))+    draggingH = down && drag1 == 2 && ((drag0 == 2 && not startH) || (startH && not onHThumb))+    dragWin = clampWin (round ((v2Y mouse - rectY vTrackR - dragOff0) / max 1 (rectH vTrackR - rectH vThumbR) * fromIntegral (n - vis)))+    dragX = clamp 0 maxOffX ((v2X mouse - rectX hTrackR - dragOff0) / max 1 (rectW hTrackR - rectW hThumbR) * maxOffX)+    wheelRows = round (v2Y (ciScroll ci) * comboBoxRowsPerNotch) :: Int+    wheelDelta = if overDrop then wheelRows else 0+    xWheel = if overDrop then v2X (ciScroll ci) * 20 else 0+    win+      | draggingV = dragWin+      | nav /= 0 = alignWin (win0 + wheelDelta)+      | otherwise = clampWin (win0 + wheelDelta)+    xOff+      | draggingH = dragX+      | otherwise = clamp 0 maxOffX (storedX + xWheel)+    dragKind' = if down then drag1 else 0+    dragOff' | startV = vGrab | startH = hGrab | otherwise = dragOff0+    -- Enter commits only an explicitly highlighted row (hover or Up/Down).+    picked = isFocus && n > 0 && hi' >= 0 && ciEnter ci+    pickedText = case drop (max 0 hi') displayed of+      chosen : _ | hi' >= 0 -> chosen+      _ -> text+    escDismiss = isFocus && ciEscape ci+    -- Commit points: Enter, a row click (the frame-side pick lands as a+    -- frame-start text the widget did not produce), and losing focus (which+    -- the blur frame after the focus clear detects). Escape is a cancel: it+    -- reverts the live text to the last committed value without committing.+    externalText = not (ciEdited ci) && text /= csLive cs0+    commitText+      | picked = Just pickedText+      | externalText = Just text+      | csFocused cs0 && not isFocus = Just text+      | otherwise = Nothing+    commitPulse = maybe False (/= committed0) commitText+    finalText+      | picked = pickedText+      | escDismiss = committed0+      | otherwise = text++-- | Combo box: the 'searchField' with a select-style dropdown of options.+-- While the field holds focus, the shared select dropdown overlay lists the+-- options filtered by the field text (all of them while it is empty). The+-- value is free text: options are suggestions, not a closed set. See+-- 'comboStep' for when the value commits. Pass the current text; the result is+-- the text after this frame, and 'respChanged' on 'comboBox'' marks a commit.+{-# INLINE comboBox #-}+comboBox :: (Foldable f, Ui :> es) => Text -> f Text -> Text -> Eff es Text+comboBox placeholder options value = snd <$> comboBox' placeholder options value++comboBox' :: (Foldable f, Ui :> es) => Text -> f Text -> Text -> Eff es (Response, Text)+comboBox' placeholder options value = do+  (resp, text) <-+    buildTextInput textInputFlagSearch searchFieldLayout placeholder value Nothing+  ctx <- askContext+  inp <- askInput+  let wid = rawRespId resp+      key = intKey wid+      keys = inputKeys inp+  isFocus <- keyboardFocused wid+  -- The dropdown only shows while the field is focused, so an unfocused+  -- combo steps with no rows. The matches stay lazy: the option window below+  -- forces only its rows, and the count is forced only on frames that store it.+  let matches = comboFiltered options text+      displayed = if isFocus then matches else []+  store <- uiIO (getStore ctx)+  let cs0 =+        ComboState+          { csHighlight = IM.findWithDefault (-1) (slotKey SlotComboHighlight key) (storeInt store)+          , csWindow = IM.findWithDefault 0 (slotKey SlotComboScroll key) (storeInt store)+          , csScrollX = IM.findWithDefault 0 (slotKey SlotComboScrollX key) (storeFloat store)+          , csContentW = IM.findWithDefault 0 (slotKey SlotComboContentW key) (storeFloat store)+          , csDrag = IM.findWithDefault 0 (slotKey SlotComboDrag key) (storeInt store)+          , csDragOff = IM.findWithDefault 0 (slotKey SlotComboDragOff key) (storeFloat store)+          , csCommitted = IM.findWithDefault value (slotKey SlotComboCommitted key) (storeText store)+          , csLive = IM.findWithDefault text (slotKey SlotComboLive key) (storeText store)+          , csFocused = IM.findWithDefault 0 (slotKey SlotComboFocus key) (storeInt store) /= 0+          }+  contentW <- uiIO $+    if isFocus && not (null displayed)+      then foldM (\widest t -> max widest . fst <$!> ctxMeasureText ctx t) 0 displayed+      else pure (csContentW cs0)+  let step =+        comboStep+          ComboInput+            { ciFocused = isFocus+            , ciEdited = rawRespChanged resp+            , ciText = text+            , ciRows = displayed+            , ciContentW = contentW+            , ciField = rawRespRect resp+            , ciMetrics = ctxFontMetrics ctx+            , ciMouse = inputMousePos inp+            , ciPressed = inputMousePressed inp+            , ciDown = inputMouseDown inp+            , ciScroll = inputScroll inp+            , ciKeyUp = KeyUp `elem` keys+            , ciKeyDown = KeyDown `elem` keys+            , ciEnter = KeyEnter `elem` keys+            , ciEscape = KeyEscape `elem` keys+            }+          cs0+      cs1 = stepState step+      finalText = csLive cs1+  when (isFocus || stepRedraw step) $+    uiIO $ do+      let len = T.length finalText+      modifyStore ctx $ \st ->+        let ints =+              IM.insert (slotKey SlotComboHighlight key) (csHighlight cs1) $+                IM.insert (slotKey SlotComboScroll key) (csWindow cs1) $+                  IM.insert (slotKey SlotComboCount key) (length matches) $+                    IM.insert (slotKey SlotComboFocus key) (boolInt (csFocused cs1)) $+                      IM.insert (slotKey SlotComboDrag key) (csDrag cs1) (storeInt st)+         in st+              { storeInt =+                  if stepPicked step+                    then IM.insert (slotKey SlotCursor key) len (IM.insert (slotKey SlotAnchor key) len ints)+                    else ints+              , storeFloat =+                  IM.insert (slotKey SlotComboScrollX key) (csScrollX cs1) $+                    IM.insert (slotKey SlotComboContentW key) (csContentW cs1) $+                      IM.insert (slotKey SlotComboDragOff key) (csDragOff cs1) (storeFloat st)+              , storeText =+                  IM.insert (slotKey SlotComboLive key) finalText $+                    IM.insert (slotKey SlotComboCommitted key) (csCommitted cs1) $+                      IM.insert key finalText (storeText st)+              }+      when (stepDismissed step) $ do+        writeIORef (ctxFocusId ctx) (WidgetId 0)+        markEscapeConsumed ctx+      when (stepRedraw step) $ markDirty ctx+  -- The dropdown overlay reads its rows from the node's option list: the+  -- visible window of the filtered list. Unfocused combos set it too, since a+  -- click that focuses the field this frame shows the dropdown this frame.+  uiIO $ do+    findNodeByWidgetId ctx wid+      >>= mapM_ (\idx -> setOptions (ctxNodeArena ctx) idx (take comboBoxMaxVisible (drop (csWindow cs1) matches)))+    recordStoreText ctx key finalText+  pure (setChanged (isJust (stepCommit step)) resp, finalText)
+ lib/NanoUI/Widgets/Custom.hs view
@@ -0,0 +1,743 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Custom widgets and the reference widgets built on them.+--+-- 'customWidget' takes a 'CustomWidgetSpec': a layout, optional measurement,+-- drawing that sees hover and press state, an optional content key, a cursor,+-- and damage slop.+-- 'canvas' is the short form for drawing into a laid-out rectangle with+-- 'CanvasM'. 'useDrag2D' and 'useWheelDelta' are gesture hooks for your own+-- controls; 'knob' and 'toggleSwitch' show how they fit together.+module NanoUI.Widgets.Custom+  ( -- * Custom widgets+    CustomWidgetSpec (..)+  , defaultCustomWidgetSpec+  , customWidget+  , customWidgetWithId+  , contentKey+  , CustomDrawContext (..)+  , CustomMeasureFn+  , CustomDrawBuild+  , mkCustomDrawContext+    -- * Canvas+  , CanvasM+  , runCanvas+  , canvas+  , drawRect+  , drawRoundedRect+  , drawCircle+  , drawStroke+  , drawStrokeRoundedRect+  , drawStrokeCircle+  , drawStrokeAA+  , drawQuadGradient+  , drawLinearGradientH+  , drawLinearGradientV+  , drawImage+  , drawImageUV+  , drawText+    -- * Gestures+  , useDrag2D+  , Drag2D (..)+  , useWheelDelta+    -- * Reference widgets+  , knob+  , knob'+  , knobWith+  , knobWith'+  , toggleSwitch+  , toggleSwitch'+  , toggleSwitchWith+  , toggleSwitchWith'+  , circularProgress+  , circularProgress'+  , circularProgressWith+  , circularProgressWith'+  , spinner+  , spinner'+  , spinnerWith+  , spinnerWith'+  , progressBar+  , progressBar'+  , progressBarWith+  , progressBarWith'+  , sparkline+  , sparkline'+  , sparklineWith+  , sparklineWith'+  ) where++import Control.Monad (forM_, void, when)+import Data.IORef (readIORef)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Data.Text qualified as T+import Data.Primitive.SmallArray (SmallArray, emptySmallArray, smallArrayFromList)+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , CustomDrawBuild+  , CustomDrawContext (..)+  , CustomMeasureFn+  , adoptStoreFloat+  , adoptStoreInt+  , getFocusId+  , getHotId+  , getStore+  , intKey+  , isDisabled+  , recordStoreFloat+  , recordStoreInt+  , registerCustomCursor+  , registerCustomDamageSlop+  , registerCustomDrawing+  , registerCustomMeasure+  , registerFocusable+  , writeStoreBool+  , writeStoreFloat+  , widgetTheme+  , modifyStore+  , getMenuPointerGesture+  )+import NanoUI.Draw (DrawOp (..))+import NanoUI.Font (FontMetrics)+import GHC.Float (castFloatToWord32)+import NanoUI.Id (WidgetId, mix64)+import NanoUI.Input+  ( Input (..)+  , UiCursorKind (..)+  , inputMouseDown+  , inputMousePos+  , inputMousePressed+  , inputScroll+  )+import NanoUI.Layout.Arena (NodeType (NodeDrawing))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, uiTime)+import NanoUI.Store (WidgetStore (..), boolInt, intBool, Slot (..), slotKey)+import NanoUI.Style+  ( AlignX (..)+  , AlignY (..)+  , Layout+  , defaultLayout+  , fillW+  , fixedH+  , fixedWH+  , styleActiveBg+  , styleBg+  , styleBorder+  , styleHoverBg+  , themeAccent+  , themeButton+  , themePanel+  , themeOnAccent+  , fadeAlpha+  )+import NanoUI.Types+  ( Color+  , ImageId (..)+  , Rect (..)+  , V2 (..)+  , clamp+  , clamp01+  , defaultDamageSlop+  , rectContains+  , v2X+  , v2Y+  )+import NanoUI.Widgets.Behavior (KeyNav (..), keyActivated, useKeyNav)+import NanoUI.Widgets.Node+  ( Response+  , addWidget+  , respClicked+  , respHovered+  , respPressed+  , respRect+  , setChanged+  )+import NanoUI.Widgets.Animate (keepAnimating)++-- -----------------------------------------------------------------------------+-- Canvas Monad+-- -----------------------------------------------------------------------------++-- | Monadic canvas builder that collects 'DrawOp' vector operations efficiently.+newtype CanvasM a = CanvasM { runCanvasM :: ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp]) }++instance Functor CanvasM where+  fmap f (CanvasM m) = CanvasM $ \s ->+    case m s of (a, s') -> (f a, s')++instance Applicative CanvasM where+  pure a = CanvasM $ \s -> (a, s)+  CanvasM mf <*> CanvasM mx = CanvasM $ \s ->+    case mf s of+      (f, s1) -> case mx s1 of+        (x, s2) -> (f x, s2)++instance Monad CanvasM where+  CanvasM m >>= f = CanvasM $ \s ->+    case m s of (a, s') -> runCanvasM (f a) s'++-- | Compile a 'CanvasM' block into an immutable 'SmallArray DrawOp'.+runCanvas :: CanvasM a -> SmallArray DrawOp+runCanvas (CanvasM m) =+  let (_, diff) = m id+   in smallArrayFromList (diff [])++emitOp :: DrawOp -> CanvasM ()+emitOp op = CanvasM $ \diff -> ((), diff . (op :))++-- | Fill a solid rectangle.+drawRect :: Rect -> Color -> CanvasM ()+drawRect r c = emitOp (FillRect r c)++-- | Fill a rounded rectangle with given corner radius.+drawRoundedRect :: Rect -> Float -> Color -> CanvasM ()+drawRoundedRect r radius c = emitOp (FillRoundedRect r radius c)++-- | Fill a solid circle at center with given radius.+drawCircle :: V2 -> Float -> Color -> CanvasM ()+drawCircle (V2 cx cy) radius c = emitOp (FillCircle cx cy radius c)++-- | Stroke a straight segment between two points with thickness.+drawStroke :: V2 -> V2 -> Float -> Color -> CanvasM ()+drawStroke (V2 x0 y0) (V2 x1 y1) thickness c = emitOp (Stroke x0 y0 x1 y1 thickness c)++-- | Stroke a rounded rectangle border with given radius and stroke width.+drawStrokeRoundedRect :: Rect -> Float -> Float -> Color -> CanvasM ()+drawStrokeRoundedRect r radius thickness c = emitOp (StrokeRoundedRect r radius thickness c)++-- | Stroke a circular outline at center with given radius and stroke width.+drawStrokeCircle :: V2 -> Float -> Float -> Color -> CanvasM ()+drawStrokeCircle (V2 cx cy) radius thickness c = emitOp (StrokeCircle cx cy radius thickness c)++-- | Antialiased smooth stroke line between two points.+drawStrokeAA :: V2 -> V2 -> Float -> Color -> CanvasM ()+drawStrokeAA (V2 x0 y0) (V2 x1 y1) thickness c = emitOp (StrokeLineAA x0 y0 x1 y1 thickness c)++-- | Four-corner bilinear gradient fill (top-left, top-right, bottom-right, bottom-left).+drawQuadGradient :: Rect -> Color -> Color -> Color -> Color -> CanvasM ()+drawQuadGradient r tl tr br bl = emitOp (FillQuadGradient r tl tr br bl)++-- | Horizontal 2-color linear gradient fill (left to right).+drawLinearGradientH :: Rect -> Color -> Color -> CanvasM ()+drawLinearGradientH r leftCol rightCol = emitOp (FillQuadGradient r leftCol rightCol rightCol leftCol)++-- | Vertical 2-color linear gradient fill (top to bottom).+drawLinearGradientV :: Rect -> Color -> Color -> CanvasM ()+drawLinearGradientV r topCol botCol = emitOp (FillQuadGradient r topCol topCol botCol botCol)++-- | Draw a textured image stretched over given rectangle.+drawImage :: Rect -> ImageId -> Color -> CanvasM ()+drawImage r (ImageId tid) c = emitOp (DrawImageRect r tid 0 0 1 1 c)++-- | Draw a sub-region of a textured image with explicit UV texture coordinates.+drawImageUV :: Rect -> ImageId -> Float -> Float -> Float -> Float -> Color -> CanvasM ()+drawImageUV r (ImageId tid) u0 v0 u1 v1 c = emitOp (DrawImageRect r tid u0 v0 u1 v1 c)++-- | Draw text positioned at a reference point with horizontal and vertical alignment.+drawText :: V2 -> AlignX -> AlignY -> Text -> Color -> CanvasM ()+drawText (V2 x y) alignX alignY txt col =+  let ax = case alignX of AlignStart -> 0; AlignCenter -> 0.5; AlignEnd -> 1+      ay = case alignY of AlignTop -> 1; AlignMiddle -> 0.5; AlignBottom -> 0+   in emitOp (DrawText x y ax ay txt col)++-- -----------------------------------------------------------------------------+-- Custom Widget Specification+-- -----------------------------------------------------------------------------++-- | Complete specification for defining a custom widget.+data CustomWidgetSpec a = CustomWidgetSpec+  { widgetLayout     :: !Layout+    -- ^ Flex layout constraints (width/height sizing, min/max, alignment, padding).+  , widgetMeasure    :: !(Maybe CustomMeasureFn)+    -- ^ Optional intrinsic measurement hook for 'Fit' or dynamic sizing.+  , widgetDraw       :: !CustomDrawBuild+    -- ^ Vector drawing procedure receiving interaction context and layout rect.+  , widgetContent    :: !Int+    -- ^ Content key: a number that changes whenever 'widgetDraw' would draw+    -- something different from the state it reads (a value, a flag, a model+    -- revision; 'contentKey' hashes numbers into one). A frame whose key,+    -- size, interaction state and metrics are unchanged neither rebuilds the+    -- ops nor repaints the widget (a widget that only moved has its ops+    -- translated), so key a drawing whose ops are expensive to build. The default 0 means no key: the ops are rebuilt every frame and+    -- compared, which repaints correctly whatever the drawing reads but pays+    -- for the rebuild. A stale key draws stale pixels, so derive it from+    -- everything the drawing reads, an animated value included: a key is+    -- believed while the widget animates, as a versioned drawing's version is.+  , widgetCursor     :: !(Maybe (CustomDrawContext -> UiCursorKind))+    -- ^ Optional custom mouse cursor when pointer is over the widget.+  , widgetFocusable  :: !Bool+    -- ^ Whether this widget accepts tab/keyboard focus.+  , widgetDamageSlop :: !Float+    -- ^ Padding added to dirty rectangles (for shadows, glow, or drag handles).+  , widgetInteract   :: !(Response -> CustomDrawContext -> Input -> (Response, a))+    -- ^ Interaction hook. It receives the widget's resolved 'Response' (hover,+    -- press, right-click, and clicks including one queued from a previous+    -- frame), the draw context and the input, and returns the final response+    -- and value.+  }++-- | Default configuration for a custom widget with standard hover/press/click behavior.+defaultCustomWidgetSpec :: CustomWidgetSpec ()+defaultCustomWidgetSpec = CustomWidgetSpec+  { widgetLayout     = defaultLayout+  , widgetMeasure    = Nothing+  , widgetDraw       = \_ _ -> emptySmallArray+  , widgetContent    = 0+  , widgetCursor     = Nothing+  , widgetFocusable  = False+  , widgetDamageSlop = defaultDamageSlop+  , widgetInteract   = \resp _ _ -> (resp, ())+  }++-- | A 'widgetContent' key for a drawing whose output follows these numbers.+-- Pass every value the drawing reads; @0@ means "no key", so a hash that lands+-- there becomes 1.+{-# INLINE contentKey #-}+contentKey :: [Float] -> Int+contentKey vs =+  let raw = foldl' (\acc v -> mix64 acc (fromIntegral (castFloatToWord32 v))) 0x9E3779B97F4A7C15 vs+      k = fromIntegral raw+   in if k == 0 then 1 else k++-- | Build the draw context a custom widget sees, resolving hover/press/focus+-- state for @wid@ from the ambient context. One policy for state masking.+mkCustomDrawContext :: Context -> FontMetrics -> WidgetId -> IO CustomDrawContext+mkCustomDrawContext ctx fm wid = do+  hot <- getHotId ctx+  active <- readIORef (ctxActiveId ctx)+  customDrawContext ctx fm wid (hot == wid) (active == wid)++-- | Draw context for @wid@ with the given hover and press state; a disabled+-- widget is never hovered or pressed.+customDrawContext :: Context -> FontMetrics -> WidgetId -> Bool -> Bool -> IO CustomDrawContext+customDrawContext ctx fm wid hovered pressed = do+  disabled <- isDisabled ctx wid+  focused <- (== wid) <$> getFocusId ctx+  active <- readIORef (ctxActiveId ctx)+  theme <- widgetTheme ctx wid+  pure+    CustomDrawContext+      { cdcHovered = hovered && not disabled+      , cdcPressed = pressed && not disabled+      , cdcFocused = focused+      , cdcActive = active == wid+      , cdcDisabled = disabled+      , cdcTheme = theme+      , cdcFont = fm+      }++-- | Instantiates a custom widget using an existing 'WidgetId'.+customWidgetWithId :: (Ui :> es) => WidgetId -> CustomWidgetSpec a -> Eff es (Response, a)+customWidgetWithId wid spec = do+  ctx <- askContext+  inp <- askInput+  uiIO $ do+    when (widgetFocusable spec) $ registerFocusable ctx wid+    mapM_ (registerCustomMeasure ctx wid) (widgetMeasure spec)+    registerCustomDrawing ctx wid (widgetContent spec) (widgetDraw spec)+    mapM_ (registerCustomCursor ctx wid) (widgetCursor spec)+    when (widgetDamageSlop spec > 0) $+      registerCustomDamageSlop ctx wid (widgetDamageSlop spec)+  resp0 <- addWidget wid NodeDrawing T.empty 0 (widgetLayout spec)+  cdc <- uiIO (customDrawContext ctx (ctxFontMetrics ctx) wid (respHovered resp0) (respPressed resp0))+  pure (widgetInteract spec resp0 cdc inp)++-- | Instantiates a custom widget from a 'CustomWidgetSpec'.+--+-- Connects the widget into:+-- - The two-pass layout arena (respecting 'widgetMeasure' or layout constraints).+-- - Off-heap vector drawing pipeline. Without a 'widgetContent' key the draw+--   function runs once a frame and the widget repaints when its ops change, so+--   it may read anything; with one, an unchanged key skips both.+-- - Interactive hit-testing, focus management, and custom cursor resolution.+-- - Accurate damage region tracking with 'widgetDamageSlop'.+customWidget :: (Ui :> es) => CustomWidgetSpec a -> Eff es (Response, a)+customWidget spec = do+  wid <- nextId+  customWidgetWithId wid spec++-- | Draw into a rectangle sized by the layout modifier. Use 'customWidget'+-- when the drawing needs hover or press state.+canvas :: (Ui :> es) => (Layout -> Layout) -> (Rect -> CanvasM ()) -> Eff es Response+canvas f drawAction =+  fst <$> customWidget defaultCustomWidgetSpec+    { widgetLayout = f defaultLayout+    , widgetDraw   = \_ rect -> runCanvas (drawAction rect)+    }++-- -----------------------------------------------------------------------------+-- Common Gesture & Behavior Helpers+-- -----------------------------------------------------------------------------++-- | Result of a 2D drag gesture.+data Drag2D = Drag2D+  { dragPosition :: !V2+    -- ^ Current dragged pointer position clamped within bounds.+  , dragActive   :: !Bool+    -- ^ True while pointer is pressed and dragging is active.+  , dragDelta    :: !V2+    -- ^ Movement delta since previous frame.+  }+  deriving (Eq, Show)++-- | Tracks pointer dragging across a 2D area (e.g. for color pickers, joysticks, canvas panning).+useDrag2D ::+  (Ui :> es) =>+  Rect ->+  Eff es Drag2D+useDrag2D bounds = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  -- The drag flag lives in 'storeInt' and the last pointer position in+  -- 'storePoint', both under the widget's drag slot.+  let dragK = slotKey SlotDrag (intKey wid)+      mouse = inputMousePos inp+  store <- uiIO (getStore ctx)+  -- A press that belongs to an open menu's pointer gesture drags nothing.+  gesture <- uiIO (getMenuPointerGesture ctx)+  let active0 = IM.findWithDefault 0 dragK (storeInt store) /= 0+      active = inputMouseDown inp && not gesture && (active0 || (inputMousePressed inp && rectContains bounds mouse))+      (prevX, prevY) = IM.findWithDefault (v2X mouse, v2Y mouse) dragK (storePoint store)+      delta =+        if active && active0+          then V2 (v2X mouse - prevX) (v2Y mouse - prevY)+          else V2 0 0+      clampedMouse =+        V2+          (clamp (rectX bounds) (rectX bounds + rectW bounds) (v2X mouse))+          (clamp (rectY bounds) (rectY bounds + rectH bounds) (v2Y mouse))+  when (active || active0) $+    uiIO $+      modifyStore ctx $ \st ->+        if active+          then+            st+              { storeInt = IM.insert dragK 1 (storeInt st)+              , storePoint = IM.insert dragK (v2X mouse, v2Y mouse) (storePoint st)+              }+          else+            st+              { storeInt = IM.delete dragK (storeInt st)+              , storePoint = IM.delete dragK (storePoint st)+              }+  pure Drag2D { dragPosition = clampedMouse, dragActive = active, dragDelta = delta }++-- | Inspects mouse wheel scroll delta when pointer is hovering over bounds.+useWheelDelta :: (Ui :> es) => Rect -> Eff es (Float, Float)+useWheelDelta bounds = do+  inp <- askInput+  let mouse = inputMousePos inp+  if rectContains bounds mouse+    then pure (v2X (inputScroll inp), v2Y (inputScroll inp))+    else pure (0, 0)++-- -----------------------------------------------------------------------------+-- Reference Custom Widgets+-- -----------------------------------------------------------------------------++-- | Rotary knob over @[minV, maxV]@, 36 px across. Drag vertically, scroll,+-- or use the arrow keys. Pass the current value; the result is the value+-- after this frame.+{-# INLINE knob #-}+knob :: Ui :> es => Float -> Float -> Float -> Eff es Float+knob minV maxV value = snd <$> knobWith' id 36 minV maxV value++{-# INLINE knob' #-}+knob' :: Ui :> es => Float -> Float -> Float -> Eff es (Response, Float)+knob' = knobWith' id 36++-- | 'knob' with a layout modifier and a diameter in pixels.+{-# INLINE knobWith #-}+knobWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Float -> Float -> Eff es Float+knobWith f diameter minV maxV value = snd <$> knobWith' f diameter minV maxV value++knobWith' ::+  Ui :> es =>+  (Layout -> Layout) -> Float -> Float -> Float -> Float -> Eff es (Response, Float)+knobWith' f diameter minV maxV value = do+  wid <- nextId+  ctx <- askContext+  let key = intKey wid+  current <- uiIO $ adoptStoreFloat ctx wid key value+  let range = maxV - minV+      frac = if range > 0 then clamp01 ((current - minV) / range) else 0+  (resp, ()) <- customWidgetWithId wid defaultCustomWidgetSpec+    { widgetLayout = fixedWH diameter diameter (f defaultLayout)+    , widgetMeasure = Just $ \_ _ -> (diameter, diameter)+    , widgetCursor = Just (\_ -> UiCursorNsResize)+    , widgetFocusable = True+    , widgetContent = contentKey [frac]+    , widgetDraw = \cdc (Rect x y w h) -> runCanvas $ do+        let cx = x + w / 2+            cy = y + h / 2+            r = min (w / 2) (h / 2) - 2+            theme = cdcTheme cdc+            hover = cdcHovered cdc+            pressed = cdcPressed cdc+            bgCol =+              if pressed+                then styleActiveBg (themeButton theme)+                else if hover+                  then styleHoverBg (themeButton theme)+                  else styleBg (themeButton theme)+            accent = themeAccent theme+            borderCol = styleBorder (themeButton theme)+            angle = (135 + frac * 270) * (pi / 180)+            ix = cx + cos angle * (r * 0.75)+            iy = cy + sin angle * (r * 0.75)+        drawCircle (V2 cx cy) r bgCol+        drawStrokeCircle (V2 cx cy) r 1.5 borderCol+        drawStrokeAA (V2 cx cy) (V2 ix iy) 2.5 accent+    }+  let bounds = respRect resp+  drag <- useDrag2D bounds+  (_scrollX, scrollY) <- useWheelDelta bounds+  nav <- useKeyNav wid+  let isDragging = dragActive drag+      dy = if isDragging then - v2Y (dragDelta drag) else 0+      dScroll = scrollY * 2.0+      dKey =+        (if knRight nav || knUp nav then 1 else 0 :: Int)+          - (if knLeft nav || knDown nav then 1 else 0)+      deltaNorm =+        if range > 0+          then (dy / 120.0) + (dScroll / 60.0) + fromIntegral dKey * 0.05+          else 0+      finalVal =+        if deltaNorm /= 0+          then clamp minV maxV (current + deltaNorm * range)+          else current+  uiIO $ do+    writeStoreFloat ctx wid key finalVal+    recordStoreFloat ctx key finalVal+  pure (setChanged (finalVal /= current) resp, finalVal)++-- | On/off switch. Pass the current state; the result is the state after+-- this frame's click or Space/Enter.+{-# INLINE toggleSwitch #-}+toggleSwitch :: Ui :> es => Bool -> Eff es Bool+toggleSwitch on = snd <$> toggleSwitchWith' id on++{-# INLINE toggleSwitch' #-}+toggleSwitch' :: Ui :> es => Bool -> Eff es (Response, Bool)+toggleSwitch' = toggleSwitchWith' id++-- | 'toggleSwitch' with a layout modifier.+{-# INLINE toggleSwitchWith #-}+toggleSwitchWith :: Ui :> es => (Layout -> Layout) -> Bool -> Eff es Bool+toggleSwitchWith f on = snd <$> toggleSwitchWith' f on++toggleSwitchWith' :: Ui :> es => (Layout -> Layout) -> Bool -> Eff es (Response, Bool)+toggleSwitchWith' f on = do+  wid <- nextId+  ctx <- askContext+  let key = intKey wid+  current <- intBool <$> uiIO (adoptStoreInt ctx wid key (boolInt on))+  let pillW = 44.0+      pillH = 24.0+  (resp, ()) <- customWidgetWithId wid defaultCustomWidgetSpec+    { widgetLayout = fixedWH pillW pillH (f defaultLayout)+    , widgetMeasure = Just $ \_ _ -> (pillW, pillH)+    , widgetCursor = Just (\_ -> UiCursorPointer)+    , widgetFocusable = True+    , widgetContent = contentKey [if current then 1 else 0]+    , widgetDraw = \cdc (Rect x y w h) -> runCanvas $ do+        let theme = cdcTheme cdc+            r = h / 2+            accent = themeAccent theme+            mutedCol = styleBg (themeButton theme)+            bgCol = if current then accent else mutedCol+            thumbR = r - 3+            thumbX = if current then (x + w - r) else (x + r)+            thumbY = y + r+            thumbCol = themeOnAccent theme+        drawRoundedRect (Rect x y w h) r bgCol+        drawStrokeRoundedRect (Rect x y w h) r 1 (styleBorder (themeButton theme))+        drawCircle (V2 thumbX thumbY) thumbR thumbCol+    }+  keyClick <- keyActivated wid+  let clicked = respClicked resp || keyClick+      newVal = current /= clicked+  uiIO $ do+    writeStoreBool ctx wid newVal+    recordStoreInt ctx key (boolInt newVal)+  pure (setChanged clicked resp, newVal)++-- | Progress ring for a fraction in @[0, 1]@, 32 px across.+{-# INLINE circularProgress #-}+circularProgress :: Ui :> es => Float -> Eff es ()+circularProgress frac = void (circularProgressWith' id 32 frac)++{-# INLINE circularProgress' #-}+circularProgress' :: Ui :> es => Float -> Eff es Response+circularProgress' = circularProgressWith' id 32++-- | 'circularProgress' with a layout modifier and a diameter in pixels.+{-# INLINE circularProgressWith #-}+circularProgressWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es ()+circularProgressWith f diameter frac = void (circularProgressWith' f diameter frac)++circularProgressWith' :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es Response+circularProgressWith' f diameter frac =+  fst <$> customWidget defaultCustomWidgetSpec+    { widgetLayout = fixedWH diameter diameter (f defaultLayout)+    , widgetMeasure = Just $ \_ _ -> (diameter, diameter)+    , widgetContent = contentKey [clamp01 frac]+    , widgetDraw = \cdc (Rect x y w h) -> runCanvas $ do+        let cx = x + w / 2+            cy = y + h / 2+            r = min (w / 2) (h / 2) - 2+            theme = cdcTheme cdc+            trackCol = styleBorder (themeButton theme)+            accent = themeAccent theme+            clampedFrac = clamp01 frac+        drawStrokeCircle (V2 cx cy) r 2.0 trackCol+        when (clampedFrac > 0) $+          drawCircle (V2 cx cy) (r * clampedFrac) accent+    }++-- | An indeterminate loading indicator: a short accent arc turning over a+-- faint ring, 18 px across. It keeps the frame loop running while it is on+-- screen and repaints only its own rect.+{-# INLINE spinner #-}+spinner :: Ui :> es => Eff es ()+spinner = void (spinnerWith' id 18)++{-# INLINE spinner' #-}+spinner' :: Ui :> es => Eff es Response+spinner' = spinnerWith' id 18++-- | 'spinner' with a layout modifier and a diameter in pixels.+{-# INLINE spinnerWith #-}+spinnerWith :: Ui :> es => (Layout -> Layout) -> Float -> Eff es ()+spinnerWith f diameter = void (spinnerWith' f diameter)++spinnerWith' :: Ui :> es => (Layout -> Layout) -> Float -> Eff es Response+spinnerWith' f diameter = do+  t <- uiTime+  let !d = max 4 diameter+      -- One turn every 0.8 s, in 48 steps: the step is the content key, so+      -- frames within a step reuse the ops.+      !step = floor (t * 48 / 0.8) `mod` 48 :: Int+  resp <-+    fst <$> customWidget defaultCustomWidgetSpec+      { widgetLayout = fixedWH d d (f defaultLayout)+      , widgetMeasure = Just $ \_ _ -> (d, d)+      , widgetContent = step + 1+      , widgetDraw = \cdc (Rect x y w h) -> runCanvas $ do+          let theme = cdcTheme cdc+              thick = max 1.5 (d / 9)+              r = min w h / 2 - thick / 2+              cx = x + w / 2+              cy = y + h / 2+              start = 2 * pi * fromIntegral step / 48+              at a = V2 (cx + r * cos a) (cy + r * sin a)+              segments = 8 :: Int+              sweep = pi / 2+          drawStrokeCircle (V2 cx cy) r thick (fadeAlpha (themeAccent theme) 48)+          forM_ [0 .. segments - 1] $ \i -> do+            let a0 = start + sweep * fromIntegral i / fromIntegral segments+                a1 = start + sweep * fromIntegral (i + 1) / fromIntegral segments+            drawStrokeAA (at a0) (at a1) thick (themeAccent theme)+      }+  keepAnimating resp+  pure resp++-- | Horizontal progress bar for a fraction in @[0, 1]@. It fills the+-- available width at a fixed height.+{-# INLINE progressBar #-}+progressBar :: Ui :> es => Float -> Eff es ()+progressBar frac = void (progressBarWith' id progressBarDefaultHeight frac)++{-# INLINE progressBar' #-}+progressBar' :: Ui :> es => Float -> Eff es Response+progressBar' = progressBarWith' id progressBarDefaultHeight++-- | 'progressBar' with a layout modifier and a bar height in pixels.+{-# INLINE progressBarWith #-}+progressBarWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es ()+progressBarWith f height frac = void (progressBarWith' f height frac)++progressBarWith' :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es Response+progressBarWith' f height frac =+  let !barH = max 0 height+   in fst <$> customWidget defaultCustomWidgetSpec+        { widgetLayout = fillW (fixedH barH (f defaultLayout))+        , widgetMeasure = Just $ \_ _ -> (progressBarDefaultWidth, barH)+        , widgetContent = contentKey [clamp01 frac]+        , widgetDraw = \cdc (Rect x y w h) -> runCanvas $ do+            let theme = cdcTheme cdc+                trackCol = styleBg (themeButton theme)+                borderCol = styleBorder (themeButton theme)+                fillCol = themeAccent theme+                barW = max 0 w+                barH' = max 0 h+                rad = barH' / 2+                clamped = clamp01 frac+                fillWpx = barW * clamped+                fillRad = if barH' <= 0 then 0 else min rad (fillWpx / 2)+            drawRoundedRect (Rect x y barW barH') rad trackCol+            when (clamped > 0 && fillWpx > 0) $+              drawRoundedRect (Rect x y fillWpx barH') fillRad fillCol+            drawStrokeRoundedRect (Rect x y barW barH') rad 1 borderCol+        }++-- | Default height and minimum content width for 'progressBar'.+progressBarDefaultHeight, progressBarDefaultWidth :: Float+progressBarDefaultHeight = 12.0+progressBarDefaultWidth = 120.0++-- | A small line chart of the values, 80 by 24 px, scaled to their range.+{-# INLINE sparkline #-}+sparkline :: Ui :> es => [Float] -> Eff es ()+sparkline values = void (sparklineWith' id 80 24 values)++{-# INLINE sparkline' #-}+sparkline' :: Ui :> es => [Float] -> Eff es Response+sparkline' = sparklineWith' id 80 24++-- | 'sparkline' with a layout modifier and a width and height in pixels.+{-# INLINE sparklineWith #-}+sparklineWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> [Float] -> Eff es ()+sparklineWith f prefW prefH values = void (sparklineWith' f prefW prefH values)++sparklineWith' :: Ui :> es => (Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response+sparklineWith' f prefW prefH values =+  fst <$> customWidget defaultCustomWidgetSpec+    { widgetLayout = fixedWH prefW prefH (f defaultLayout)+    , widgetMeasure = Just $ \_ _ -> (prefW, prefH)+    , widgetContent = contentKey values+    , widgetDraw = \cdc (Rect x y rw rh) -> runCanvas $ do+        let theme = cdcTheme cdc+            accent = themeAccent theme+            bg = styleBg (themePanel theme)+        drawRoundedRect (Rect x y rw rh) 3.0 bg+        case values of+          [] -> pure ()+          [_] -> drawCircle (V2 (x + rw / 2) (y + rh / 2)) 2.0 accent+          vs -> do+            let minV = minimum vs+                maxV = maximum vs+                range = if maxV > minV then maxV - minV else 1.0+                pad = 4.0+                plotW = max 1.0 (rw - 2 * pad)+                plotH = max 1.0 (rh - 2 * pad)+                n = length vs+                stepX = plotW / fromIntegral (max 1 (n - 1))+                pts = [ V2 (x + pad + fromIntegral i * stepX)+                           (y + rh - pad - ((v - minV) / range) * plotH)+                      | (i, v) <- zip [0 :: Int ..] vs+                      ]+                drawSegments [] = pure ()+                drawSegments [_] = pure ()+                drawSegments (p1 : p2 : rest) = do+                  drawStrokeAA p1 p2 1.5 accent+                  drawSegments (p2 : rest)+            drawSegments pts+            case pts of+              [] -> pure ()+              _ -> drawCircle (last pts) 2.5 accent+    }
+ lib/NanoUI/Widgets/Display.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Display helpers: styled labels, key/value rows, cards, toolbars, images+-- and colour boxes.+module NanoUI.Widgets.Display+  ( heading+  , muted+  , mono+  , danger+  , bold+  , italic+  , underline+  , kv+  , kvMono+  , kvBlock+  , card+  , toolbar+  , image+  , image'+  , freshImageId+  , registerImageRgba+  , svgIcon+  , svgIconWith+  , svgIconWith'+  , loadSvg+  , box+  )+where++import Control.Exception (IOException, try)+import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Map.Strict qualified as Map+import Data.Text.Encoding qualified as TE+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import NanoUI.Atlas qualified as Atlas+import NanoUI.Context (Context (..), askHostIO, registerImage, setHost)+import NanoUI.Draw (getDrawSnapScale)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, nextId, uiIO, uiTheme)+import NanoUI.Svg (Svg, parseSvg, rasterizeSvg, svgKey, svgMonochrome, svgSize)+import NanoUI.Style+  ( Layout (..)+  , Sizing (..)+  , alignEnd+  , alignMid+  , defaultLayout+  , fillW+  , fontBold+  , fontDanger+  , fontItalic+  , fontMedium+  , fontMono+  , fontMuted+  , fontUnderline+  , gap+  , minW+  , padXY+  , styleFg+  , themePanel+  , tight+  )+import Data.Word (Word32)+import NanoUI.Types (Color (..), ImageId (..), colorRGBA, colorToWord32)+import NanoUI.WidgetText (intValueText)+import NanoUI.Widgets.Layout (labelEx, labelWith, panelWith, row', rowWith)+import NanoUI.Widgets.Node (Response, addWidget, addWidgetStyled)++heading :: Ui :> es => Text -> Eff es ()+heading = labelWith (tight . fontMedium)++muted :: Ui :> es => Text -> Eff es ()+muted = labelWith (fillW . fontMuted)++mono :: Ui :> es => Text -> Eff es ()+mono = labelWith fontMono++danger :: Ui :> es => Text -> Eff es ()+danger = labelWith (fillW . fontDanger)++bold :: Ui :> es => Text -> Eff es ()+bold = labelWith fontBold++italic :: Ui :> es => Text -> Eff es ()+italic = labelWith fontItalic++underline :: Ui :> es => Text -> Eff es ()+underline = labelWith fontUnderline++-- | Key/value row: a muted key on the left, the value right-aligned. Trailing+-- whitespace in the value is dropped.+kv :: Ui :> es => Text -> Text -> Eff es ()+kv k v =+  row' (tight . gap 12 . alignMid . fillW $ defaultLayout) $ do+    void (labelEx (fontMuted . tight . minW 88 $ defaultLayout) k)+    void (labelEx (tight . fillW . alignEnd $ defaultLayout) (T.stripEnd v))++-- | Key/value row with a monospace value.+kvMono :: Ui :> es => Text -> Text -> Eff es ()+kvMono k v =+  row' (tight . gap 12 . alignMid . fillW $ defaultLayout) $ do+    void (labelEx (tight . minW 88 $ defaultLayout) k)+    void (labelEx (tight . fillW . alignEnd . fontMono $ defaultLayout) (T.stripEnd v))++-- | Key/value pairs as one monospace block with the keys padded to a column.+kvBlock :: (Foldable f, Ui :> es) => f (Text, Text) -> Eff es ()+kvBlock rows =+  let maxK = foldl' (\acc (k, _) -> max acc (T.length k)) 0 rows+      padK k = T.justifyLeft maxK ' ' k+   in void $+        labelEx+          (tight . gap 0 . fontMono $ defaultLayout)+          (T.concat (foldr (\(k, v) rest -> padK k : "  " : v : "\n" : rest) [] rows))++card :: Ui :> es => Eff es a -> Eff es a+card = panelWith (minW 300 . padXY 12 10 . gap 8 . fillW)++toolbar :: Ui :> es => Eff es a -> Eff es a+toolbar = rowWith (tight . gap 8 . alignMid . fillW)++-- | An image registered with the host, sized by the layout modifier.+image :: Ui :> es => (Layout -> Layout) -> ImageId -> Eff es ()+image f iid = void (image' f iid)++-- | 'image' with its 'Response', for example to 'NanoUI.keepAnimating' an+-- image whose id changes over time.+image' :: Ui :> es => (Layout -> Layout) -> ImageId -> Eff es Response+image' f (ImageId tid) = do+  wid <- nextId+  let+    stored = if tid <= 0 then T.empty else intValueText tid+  addWidget wid NodeImage stored 0 (f defaultLayout)++-- | An image id that no registered image uses and no earlier call returned.+-- Take one for each image registered while the app runs.+freshImageId :: Ui :> es => Eff es ImageId+freshImageId = do+  ctx <- askContext+  uiIO (Atlas.freshImageId (ctxImageAtlas ctx))++-- | Register an RGBA image (4 bytes a pixel, rows top to bottom) under an id+-- while the app runs, for 'image' to draw. Returns 'False' when the size or+-- pixels are invalid, an image of another size already has the id, or the+-- atlas is full. An image of the same size is replaced.+registerImageRgba :: Ui :> es => ImageId -> Int -> Int -> ByteString -> Eff es Bool+registerImageRgba iid w h pixels = do+  ctx <- askContext+  uiIO (registerImage ctx iid w h pixels)++-- | Read and parse an SVG file.+loadSvg :: FilePath -> IO (Either String Svg)+loadSvg path = do+  result <- try (BS.readFile path)+  pure $ case result of+    Left (err :: IOException) -> Left (show err)+    Right bytes -> parseSvg (TE.decodeUtf8Lenient bytes)++-- | An SVG icon @size@ logical pixels square, drawn in the text colour where+-- it is used: a one-colour document (every paint @currentColor@ or+-- unspecified) takes the colour as a tint, and a multicoloured one paints+-- its @currentColor@ with it.+{-# INLINE svgIcon #-}+svgIcon :: Ui :> es => Float -> Svg -> Eff es ()+svgIcon size = svgIconWith (fixedSquare size)+  where+    fixedSquare n l = l {layoutWidth = Fixed n, layoutHeight = Fixed n}++-- | An SVG document sized by the layout modifier: a fixed width and height,+-- or else the document's own size. A 'NanoUI.fontColor' in the modifier+-- replaces the text colour.+{-# INLINE svgIconWith #-}+svgIconWith :: Ui :> es => (Layout -> Layout) -> Svg -> Eff es ()+svgIconWith f doc = void (svgIconWith' f doc)++-- | The document is rasterized once per pixel size and colour, at the+-- display's scale, and kept in the image atlas for as long as the app runs.+svgIconWith' :: Ui :> es => (Layout -> Layout) -> Svg -> Eff es Response+svgIconWith' f doc = do+  ctx <- askContext+  theme <- uiTheme+  let lay0 = f defaultLayout+      (docW, docH) = svgSize doc+      fixedOr sizing dflt = case sizing of+        Fixed n -> n+        _ -> dflt+      w = fixedOr (layoutWidth lay0) docW+      h = fixedOr (layoutHeight lay0) docH+      color = maybe (styleFg (themePanel theme)) id (layoutFontColor lay0)+      oneColour = svgMonochrome doc+      white = colorRGBA 255 255 255 255+      lay = lay0 {layoutWidth = Fixed w, layoutHeight = Fixed h, layoutFontColor = Just (if oneColour then color else white)}+  iid <- uiIO $ do+    scale <- getDrawSnapScale (ctxDrawArena ctx)+    let pw = max 1 (ceiling (w * max 1 scale))+        ph = max 1 (ceiling (h * max 1 scale))+        -- A one-colour raster is white and tinted when drawn, so every colour+        -- shares it.+        rasterColor = if oneColour then white else color+        key = (svgKey doc, pw, ph, colorToWord32 rasterColor)+    cache <- svgRasterCache ctx+    known <- Map.lookup key <$> readIORef cache+    case known of+      Just iid -> pure iid+      Nothing -> do+        iid <- Atlas.freshImageId (ctxImageAtlas ctx)+        ok <- registerImage ctx iid pw ph (rasterizeSvg pw ph rasterColor doc)+        if ok+          then atomicModifyIORef' cache (\m -> (Map.insert key iid m, ()))+          else pure ()+        pure (if ok then iid else ImageId 0)+  image' (const lay) iid++-- | Rasterized SVG documents by document, pixel size and colour.+newtype SvgRasters = SvgRasters (IORef (Map.Map (Int, Int, Int, Word32) ImageId))++svgRasterCache :: Context -> IO (IORef (Map.Map (Int, Int, Int, Word32) ImageId))+svgRasterCache ctx =+  askHostIO ctx >>= \case+    Just (SvgRasters ref) -> pure ref+    Nothing -> do+      ref <- newIORef Map.empty+      setHost ctx (SvgRasters ref)+      pure ref++-- | A solid rectangle sized by the layout modifier.+box :: Ui :> es => (Layout -> Layout) -> Color -> Eff es ()+box f col = do+  wid <- nextId+  void+    ( addWidgetStyled+        wid+        NodeBox+        T.empty+        0+        (f defaultLayout)+        (fromIntegral (colorToWord32 col))+    )
+ lib/NanoUI/Widgets/Drawing.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Drawing+  ( DrawOp (..)+  , DrawingBuild+  , drawing+  , drawingVersioned+  , drawingCached+  )+where++import Data.Text qualified as T+import Data.Primitive.SmallArray (SmallArray)+import Effectful (Eff, type (:>))+import NanoUI.Context (cachedWidgetLayout, registerDrawing)+import NanoUI.Draw (DrawOp (..), DrawingBuild)+import NanoUI.Layout.Arena (NodeType (NodeDrawing))+import NanoUI.Monad (Ui, askContext, nextId, uiIO)+import NanoUI.Style (Layout, defaultLayout)+import NanoUI.Types (Rect)+import NanoUI.Widgets.Node (Response, addWidget)++-- | Vector ops for a laid-out widget. Paint caches ops while width and height+-- stay the same, then translates when the widget moves. Unversioned: the cache+-- drops while the widget animates because the builder has no content key, and+-- a builder that draws something else at the same size neither rebuilds nor+-- repaints. Use 'drawingVersioned' for output that changes, or+-- 'NanoUI.Widgets.Custom.customWidget' without a key to have every frame+-- rebuild and compare.+{-# INLINE drawing #-}+drawing :: Ui :> es => (Layout -> Layout) -> (Rect -> SmallArray DrawOp) -> Eff es Response+drawing = drawingVersioned 0++-- | Like 'drawing', but the tessellated op cache is keyed by an explicit+-- content version. Change the version whenever the builder output changes+-- (a model pointer, dirty counter, or content hash): that rebuilds the ops and+-- repaints the widget. Frames with the same version replay cached ops without+-- rebuilding, even while the widget animates. Version 0 means unversioned, as+-- in 'drawing'.+drawingVersioned :: Ui :> es => Int -> (Layout -> Layout) -> (Rect -> SmallArray DrawOp) -> Eff es Response+drawingVersioned version f build = do+  wid <- nextId+  ctx <- askContext+  uiIO (registerDrawing ctx wid version build)+  addWidget wid NodeDrawing T.empty 0 (f defaultLayout)++-- | Like 'drawingVersioned', but the layout itself comes from @compute@, which+-- only reruns when the envelope, line height, content key, or modifier result+-- change.+drawingCached ::+  Ui :> es =>+  Double ->+  Double ->+  Float ->+  Int ->+  (Layout -> Layout) ->+  IO Layout ->+  DrawingBuild ->+  Eff es Response+drawingCached dw dh lh content f compute build = do+  wid <- nextId+  ctx <- askContext+  layout <- uiIO (cachedWidgetLayout ctx wid dw dh lh content (f defaultLayout) compute)+  uiIO (registerDrawing ctx wid content build)+  addWidget wid NodeDrawing T.empty 0 layout
+ lib/NanoUI/Widgets/Drop.hs view
@@ -0,0 +1,146 @@+{-# 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+  { dropHovered :: !Bool+    -- ^ A drag is currently positioned over the target rect.+  , dropReceived :: !Bool+    -- ^ One or more payloads landed on the target this frame.+  , dropFiles :: ![Text]+    -- ^ File paths dropped on the target this frame.+  , dropTexts :: ![Text]+    -- ^ Text snippets dropped on the target this frame.+  , dropPosition :: !(Maybe V2)+    -- ^ Last known drop position in window coordinates, if any.+  }+  deriving (Eq, 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 bounds = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  let key = intKey wid+      activeK = slotKey SlotDrop key+      posK = slotKey SlotDropPos key+  store <- uiIO (getStore ctx)+  let active0 = IM.findWithDefault 0 activeK (storeInt store) /= 0+      lastPos0 = fmap (\(x, y) -> V2 x y) (IM.lookup posK (storePoint store))+      events = toList (inputDrops inp)+      -- A drag is active from 'DropBegin' until 'DropComplete'.+      active1 =+        foldl'+          ( \active ev -> case dropEventType ev of+              DropBegin -> True+              DropComplete -> False+              _ -> active+          )+          active0+          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 =+        drop 1 $ scanl+          ( \pos ev -> case dropEventType ev of+              DropPosition -> dropEventPos ev <|> pos+              DropComplete -> Nothing+              _ -> pos+          )+          lastPos0+          events+      lastPos1 = last (lastPos0 : positions)+      payloads ty =+        [dropEventData ev | (ev, pos) <- zip events positions, dropEventType ev == ty, posInside bounds pos]+      files = payloads DropFile+      texts = payloads DropText+      hovered = active1 && posInside bounds lastPos1+  when (active1 /= active0 || lastPos1 /= lastPos0) $+    uiIO $+      modifyStore ctx $ \st ->+        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 x y) -> IM.insert posK (x, y) (storePoint 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 bounds = maybe False (rectContains 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 f child = do+  base <- askDefaultLayout+  (a, resp) <- containerResponse NodePanel (f base) child+  target <- useDrop (respRect resp)+  pure (a, resp, target)
+ lib/NanoUI/Widgets/Layout.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Layout+  ( panel+  , panelWith+  , panel'+  , callout+  , calloutWith+  , row+  , rowWith+  , row'+  , column+  , columnWith+  , column'+  , hstack+  , vstack+  , label+  , label'+  , labelWith+  , labelWith'+  , labelEx+  , separator+  , spacer+  , flex+  , scroll+  , scrollWith+  , scroll'+  , scroll2D+  , scroll2DWith+  , scroll2D'+  , scrollArea+  , scrollArea2D+  , scrollConfigured+  , scrollAreaIdConfigured+  , grid+  , gridWith+  , grid'+  , responsive+  , responsiveRowCol+  , center+  )+where++import Control.Monad (void)+import Data.IORef (readIORef)+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context (Context (..), setScrollConfig)+import NanoUI.Frame.Scroll.Geometry+  ( ScrollConfig (..)+  , defaultScrollConfig+  , encodeScrollConfig+  , scrollDefault1D+  )+import NanoUI.Id (WidgetId)+import NanoUI.Layout.Arena+  ( DirTag (..)+  , NodeIdx+  , NodeType (..)+  , addNodeFromLayout+  , getDirection+  , setStyleIdx+  , setWidgetId+  )+import NanoUI.Input (Input (inputWindowSize))+import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, styled, uiIO)+import NanoUI.Style+  ( AlignX (..)+  , Direction (..)+  , Layout (..)+  , Sizing (..)+  , alignMid+  , fillW+  , gap+  , grow+  , padXY+  , panelStyle+  )+import NanoUI.Style qualified as Style+import NanoUI.Types (Color (..), Size (..), lerpColor)+import NanoUI.Widgets.Node+  ( Response+  , addSizingLeafNode+  , addWidget+  , container++  , parentIdx+  , withContainerNode+  )++-- =============================================================================+-- Internal Ambient Helpers+-- =============================================================================++{-# INLINE withDefault #-}+withDefault :: Ui :> es => (Layout -> Eff es a -> Eff es r) -> Eff es a -> Eff es r+withDefault = withDefaultWith id++{-# INLINE withDefaultWith #-}+withDefaultWith :: Ui :> es => (Layout -> Layout) -> (Layout -> Eff es a -> Eff es r) -> Eff es a -> Eff es r+withDefaultWith f c child = do+  base <- askDefaultLayout+  c (f base) child++-- =============================================================================+-- Panel+-- =============================================================================++{-# INLINE panel #-}+panel :: Ui :> es => Eff es a -> Eff es a+panel = withDefault panel'++{-# INLINE panelWith #-}+panelWith :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a+panelWith = (`withDefaultWith` panel')++{-# INLINE panel' #-}+panel' :: Ui :> es => Layout -> Eff es a -> Eff es a+panel' = container NodePanel++{-# INLINE callout #-}+callout :: Ui :> es => Color -> Eff es a -> Eff es a+callout borderCol = calloutWith borderCol id++-- | A panel tinted with @col@: a border in it and a faint wash of it over the+-- panel colour. The tint applies to the callout's own panel and to panels+-- nested in it.+{-# INLINE calloutWith #-}+calloutWith :: Ui :> es => Color -> (Layout -> Layout) -> Eff es a -> Eff es a+calloutWith col f =+  styled+    (\t -> panelStyle (Style.background (lerpColor col (Style.styleBg (Style.themePanel t)) 0.88) . Style.borderColor col) t)+    . panelWith (f . padXY 10 6 . gap 8 . fillW)++-- =============================================================================+-- Row+-- =============================================================================++{-# INLINE row #-}+row :: Ui :> es => Eff es a -> Eff es a+row = withDefault row'++{-# INLINE rowWith #-}+rowWith :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a+rowWith = (`withDefaultWith` row')++{-# INLINE row' #-}+row' :: Ui :> es => Layout -> Eff es a -> Eff es a+row' layout = container NodeContainer (layout {layoutDirection = Row})++-- =============================================================================+-- Column+-- =============================================================================++{-# INLINE column #-}+column :: Ui :> es => Eff es a -> Eff es a+column = withDefault column'++{-# INLINE columnWith #-}+columnWith :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a+columnWith = (`withDefaultWith` column')++{-# INLINE column' #-}+column' :: Ui :> es => Layout -> Eff es a -> Eff es a+column' layout = container NodeContainer (layout {layoutDirection = Column})++-- =============================================================================+-- Collection stacks+-- =============================================================================++-- | Run a collection of widgets side by side, as in @hstack (map label names)@.+{-# INLINE hstack #-}+hstack :: (Foldable f, Ui :> es) => f (Eff es ()) -> Eff es ()+hstack = row . sequence_++-- | Run a collection of widgets top to bottom.+{-# INLINE vstack #-}+vstack :: (Foldable f, Ui :> es) => f (Eff es ()) -> Eff es ()+vstack = column . sequence_++-- =============================================================================+-- Grid+-- =============================================================================++{-# INLINE grid #-}+grid :: Ui :> es => Int -> Eff es a -> Eff es a+grid n = withDefault (grid' n)++{-# INLINE gridWith #-}+gridWith :: Ui :> es => Int -> (Layout -> Layout) -> Eff es a -> Eff es a+gridWith n f = withDefaultWith f (grid' n)++{-# INLINE grid' #-}+grid' :: Ui :> es => Int -> Layout -> Eff es a -> Eff es a+grid' n layout = container NodeContainer (layout {layoutGridCols = max 1 n})++-- =============================================================================+-- Responsive+-- =============================================================================++-- | Choose between two container builders based on window width.+{-# INLINE responsive #-}+responsive :: Ui :> es => Float -> (Eff es a -> Eff es a) -> (Eff es a -> Eff es a) -> Eff es a -> Eff es a+responsive breakpoint wideContainer narrowContainer child = do+  inp <- askInput+  let w = sizeW (inputWindowSize inp)+  if w >= breakpoint then wideContainer child else narrowContainer child++-- | A row while the window is at least @breakpoint@ wide, a column below it.+{-# INLINE responsiveRowCol #-}+responsiveRowCol :: Ui :> es => Float -> (Layout -> Layout) -> Eff es a -> Eff es a+responsiveRowCol breakpoint f child = do+  inp <- askInput+  base <- askDefaultLayout+  let w = sizeW (inputWindowSize inp)+      dir = if w >= breakpoint then Row else Column+  container NodeContainer ((f base) {layoutDirection = dir}) child++-- | A line of text. Newlines start new lines.+{-# INLINE label #-}+label :: Ui :> es => Text -> Eff es ()+label txt = void (label' txt)++-- | 'label' returning its 'Response', for a tooltip or an anchored popup.+{-# INLINE label' #-}+label' :: Ui :> es => Text -> Eff es Response+label' txt = do+  base <- askDefaultLayout+  labelEx base txt++-- | 'label' with a layout modifier, for example @labelWith fontMono@.+{-# INLINE labelWith #-}+labelWith :: Ui :> es => (Layout -> Layout) -> Text -> Eff es ()+labelWith f txt = void (labelWith' f txt)++{-# INLINE labelWith' #-}+labelWith' :: Ui :> es => (Layout -> Layout) -> Text -> Eff es Response+labelWith' f txt = do+  base <- askDefaultLayout+  labelEx (f base) txt++{-# INLINE labelEx #-}+labelEx :: Ui :> es => Layout -> Text -> Eff es Response+labelEx layout txt = do+  wid <- nextId+  addWidget wid NodeText txt 0 layout++-- | Takes up the remaining space along the parent's direction.+{-# INLINE flex #-}+flex :: Ui :> es => Eff es ()+flex = spacer (Grow 1) Fit++-- | A one-pixel rule: horizontal in a column, vertical in a row.+separator :: Ui :> es => Eff es ()+separator = void $ do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    let+      parent = parentIdx stack+    parentDir <-+      if parent < 0+        then pure DirColumn+        else getDirection (ctxNodeArena ctx) parent+    let+      (dir, wSiz, hSiz) =+        case parentDir of+          DirColumn -> (Column, Grow 1, Fixed 1)+          DirRow -> (Row, Fixed 1, Grow 1)+    addSizingLeafNode ctx inp wid NodeSeparator dir wSiz hSiz++-- | Empty space with the given sizing on each axis.+{-# INLINE spacer #-}+spacer :: Ui :> es => Sizing -> Sizing -> Eff es ()+spacer w h = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  void (uiIO $ addSizingLeafNode ctx inp wid NodeSpacer Row w h)++{-# INLINE scroll #-}+scroll :: Ui :> es => Eff es a -> Eff es a+scroll = withDefault scroll'++{-# INLINE scrollWith #-}+scrollWith :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a+scrollWith = (`withDefaultWith` scroll')++{-# INLINE scroll' #-}+scroll' :: Ui :> es => Layout -> Eff es a -> Eff es a+scroll' layout child =+  snd <$> scrollConfigured (scrollDefault1D (layoutDirection layout)) layout child++{-# INLINE center #-}+center :: Ui :> es => Eff es a -> Eff es a+center = columnWith (grow . alignMid . (\l -> l { layoutAlignX = AlignCenter }))++-- | Push a scroll container node, run the child inside it, then pop.+{-# INLINE scrollContainerWith #-}+scrollContainerWith :: Ui :> es => WidgetId -> (NodeIdx -> IO ()) -> Layout -> Eff es a -> Eff es a+scrollContainerWith wid setup layout child = do+  ctx <- askContext+  idx <- uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    idx <- addNodeFromLayout (ctxNodeArena ctx) NodeScrollContainer (parentIdx stack) layout+    setWidgetId (ctxNodeArena ctx) idx wid+    setup idx+    pure idx+  -- Unscoped: a scroll container's children keep their parent's id scope.+  withContainerNode False idx child++-- | Style index + context scroll config for a container with a chosen config.+{-# INLINE configureScrollContainer #-}+configureScrollContainer :: Context -> WidgetId -> ScrollConfig -> NodeIdx -> IO ()+configureScrollContainer ctx wid cfg idx = do+  setStyleIdx (ctxNodeArena ctx) idx (encodeScrollConfig cfg)+  setScrollConfig ctx wid cfg++-- | 'scrollWith' that also returns the container's widget id, which keys its+-- scroll offset.+{-# INLINE scrollArea #-}+scrollArea :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es (WidgetId, a)+scrollArea f child = do+  layout <- f <$> askDefaultLayout+  scrollConfigured (scrollDefault1D (layoutDirection layout)) layout child++{-# INLINE scrollAreaIdConfigured #-}+scrollAreaIdConfigured :: Ui :> es => WidgetId -> Layout -> ScrollConfig -> Eff es a -> Eff es a+scrollAreaIdConfigured wid layout cfg child = do+  ctx <- askContext+  scrollContainerWith wid (configureScrollContainer ctx wid cfg) layout child++-- | Scroll container on both axes.+{-# INLINE scroll2D #-}+scroll2D :: Ui :> es => Eff es a -> Eff es a+scroll2D = withDefault scroll2D'++{-# INLINE scroll2DWith #-}+scroll2DWith :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a+scroll2DWith = (`withDefaultWith` scroll2D')++{-# INLINE scroll2D' #-}+scroll2D' :: Ui :> es => Layout -> Eff es a -> Eff es a+scroll2D' layout child = fmap snd (scrollConfigured defaultScrollConfig layout child)++-- | 'scroll2DWith' that also returns the container's widget id.+{-# INLINE scrollArea2D #-}+scrollArea2D :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es (WidgetId, a)+scrollArea2D f child = do+  layout <- f <$> askDefaultLayout+  scrollConfigured defaultScrollConfig layout child++{-# INLINE scrollConfigured #-}+scrollConfigured :: Ui :> es => ScrollConfig -> Layout -> Eff es a -> Eff es (WidgetId, a)+scrollConfigured cfg layout child = do+  ctx <- askContext+  wid <- nextId+  r <- scrollContainerWith wid (configureScrollContainer ctx wid cfg) layout child+  pure (wid, r)
+ lib/NanoUI/Widgets/Menu.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Menu+  ( contextMenu+  , contextMenuArea+  , useContextMenu+  , menuButton+  , menuButton'+  , MenuItem (..)+  , menuItemWith+  , menuItem+  , menuItem'+  , menuItemShortcut+  , menuItemDisabled+  , menuSeparator+  , menuHeader+  )+where++import Control.Monad (void, when)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context (getStore, intKey, modifyStore)+import NanoUI.Font (menuItemPadX, menuItemRowH, menuMinW, menuOuterPad, menuSepH)+import NanoUI.Input (inputMousePos, inputMouseReleased)+import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, uiIO)+import NanoUI.Store (WidgetStore (..), slotKey, Slot (..))+import NanoUI.Style (Layout (..), defaultLayout, fillW, fixedH, fontMuted, gap, minW, padXY, tight)+import NanoUI.Types (PopupAnchor (..), PopupPlacement (..), V2 (..))+import NanoUI.WidgetText (buttonFlagMenu, buttonFlagMenuBar)+import NanoUI.Widgets.Combinators (buttonStyled)+import NanoUI.Widgets.Layout (columnWith, labelEx, rowWith, separator)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Widgets.Node (HasResponse, Response (..), containerResponse, respClicked, respHovered, respRightClicked)+import NanoUI.Widgets.Popup (PopupConfig (..), popup)++-- | A context menu for any widget response, opened by right-clicking it.+-- Returns the menu body's result while the menu is open.+contextMenu ::+  (Ui :> es, HasResponse r) =>+  r ->+  Eff es a ->+  Eff es (Maybe a)+contextMenu target child = do+  menu <- useContextMenu+  runContextMenu menu (respRightClicked target) (const child)++-- | A container whose right-click opens a context menu. The menu body+-- receives the position it was opened at.+contextMenuArea ::+  Ui :> es =>+  (Layout -> Layout) ->+  Eff es a ->+  (V2 -> Eff es b) ->+  Eff es (a, Maybe b)+contextMenuArea f areaContent menuContent = do+  menu <- useContextMenu+  base <- askDefaultLayout+  (areaRes, areaResp) <- containerResponse NodeContainer (f base) areaContent+  (,) areaRes <$> runContextMenu menu (respRightClicked areaResp) menuContent++-- | Open the menu at the pointer on a right click, show it while open, and+-- close it once a row is picked or it is dismissed.+runContextMenu ::+  Ui :> es =>+  (Bool, V2, V2 -> Eff es (), Eff es ()) ->+  Bool ->+  (V2 -> Eff es a) ->+  Eff es (Maybe a)+runContextMenu (isOpen0, pos0, openAt, close) rightClick child = do+  inp <- askInput+  let mouse = inputMousePos inp+      pos = if rightClick then mouse else pos0+      cfg =+        PopupConfig+          { cfgAnchor = AnchorPoint pos+          , cfgPlacement = PlacementAtCursor+          , cfgDismissable = True+          , cfgOffset = 0+          }+  when rightClick (openAt mouse)+  (popupResp, mBody) <- popup (isOpen0 || rightClick) cfg (columnWith (tight . gap 0) (child pos))+  let picked = respHovered popupResp && inputMouseReleased inp+  when (respClicked popupResp || picked) close+  pure mBody++-- | Open state for a context menu you position yourself: whether it is open,+-- where it was opened, an action to open it at a point, and one to close it.+useContextMenu ::+  Ui :> es =>+  Eff es (Bool, V2, V2 -> Eff es (), Eff es ())+useContextMenu = do+  wid <- nextId+  ctx <- askContext+  let key = intKey wid+      openK = slotKey SlotMenuOpen key+      posK = slotKey SlotMenuPos key+  store <- uiIO (getStore ctx)+  let isOpen = IM.findWithDefault 0 openK (storeInt store) /= 0+      (px, py) = IM.findWithDefault (0, 0) posK (storePoint store)+      openAt (V2 x y) =+        uiIO $+          modifyStore ctx $ \st ->+            st+              { storeInt = IM.insert openK 1 (storeInt st)+              , storePoint = IM.insert posK (x, y) (storePoint st)+              }+      close = uiIO $ modifyStore ctx $ \st -> st {storeInt = IM.delete openK (storeInt st)}+  pure (isOpen, V2 px py, openAt, close)++-- | One context-menu row; the whole row is the button.+data MenuItem = MenuItem+  { menuItemLabel :: !Text+  , menuItemHint :: !(Maybe Text)+    -- ^ Shortcut hint shown after the label, e.g. @Ctrl+S@.+  , menuItemEnabled :: !Bool+    -- ^ Disabled rows are dimmed and cannot be clicked or focused.+  }+  deriving (Eq, Show)++-- | Render a menu row, returning its full 'Response'. A disabled row is a+-- muted label, not a disabled button: hover tracking does not know a button's+-- enabled flag and would still highlight it. Its response never reports+-- interaction.+menuItemWith :: Ui :> es => MenuItem -> Eff es Response+menuItemWith (MenuItem lbl hint enabled)+  | enabled = buttonStyled text 0 menuRowLayout buttonFlagMenu+  | otherwise = do+      resp <- labelEx (tight . fillW . fontMuted $ defaultLayout) text+      pure+        resp+          { rawRespHovered = False+          , rawRespPressed = False+          , rawRespClicked = False+          , rawRespRightPressed = False+          , rawRespRightClicked = False+          }+  where+    text = maybe lbl (\s -> mconcat [lbl, "  ", s]) hint++-- | Menu row. 'True' on the frame it is clicked.+--+-- @+-- whenM (menuItem "Open...") openFile+-- @+{-# INLINE menuItem #-}+menuItem :: Ui :> es => Text -> Eff es Bool+menuItem txt = respClicked <$> menuItem' txt++{-# INLINE menuItem' #-}+menuItem' :: Ui :> es => Text -> Eff es Response+menuItem' txt = menuItemWith (MenuItem txt Nothing True)++-- | Menu row with a shortcut hint after the label. The hint is only text;+-- handle the key itself elsewhere.+--+-- @+-- whenM (menuItemShortcut "Save" "Ctrl+S") saveFile+-- @+menuItemShortcut :: Ui :> es => Text -> Text -> Eff es Bool+menuItemShortcut txt hint = respClicked <$> menuItemWith (MenuItem txt (Just hint) True)++-- | Dimmed menu row that cannot be clicked.+menuItemDisabled :: Ui :> es => Text -> Eff es ()+menuItemDisabled txt = void (menuItemWith (MenuItem txt Nothing False))++-- | Row layout shared by menu items, matching the text-field context menu:+-- 28px rows and a 148px minimum menu width (@menuItemRowH@ and @menuMinW@ in+-- @NanoUI.Font@).+menuRowLayout :: Layout+menuRowLayout = minW menuMinW . fixedH menuItemRowH . tight . fillW $ defaultLayout++-- | Menu-bar title: a flat, label-sized button. @open@ tints the title while+-- its drop-down is showing. 'True' on the frame it is clicked.+{-# INLINE menuButton #-}+menuButton :: Ui :> es => Text -> Bool -> Eff es Bool+menuButton txt open = respClicked <$> menuButton' txt open++-- | 'menuButton' returning its 'Response', whose rect anchors the drop-down.+menuButton' :: Ui :> es => Text -> Bool -> Eff es Response+menuButton' txt open =+  buttonStyled txt (if open then 1 else 0) menuBarTitleLayout buttonFlagMenuBar++menuBarTitleLayout :: Layout+menuBarTitleLayout = tight $ defaultLayout++-- | Separator line inside a context menu, matching the text-field context+-- menu painter exactly: a 1px rule inset 'menuItemPadX' from the panel edge+-- (the popup already contributes 'menuOuterPad', the row adds the remainder)+-- centered in a 'menuSepH' band (@lineY = bandY + h\/2@ via 4.5px vertical+-- padding around a zero-height content box). The rule sits in a 'tight'+-- column so it stays horizontal ('separator' adapts to its parent's+-- direction and would grow vertically inside the padded row) and so the+-- default 3px container padding does not inset or stretch it.+menuSeparator :: Ui :> es => Eff es ()+menuSeparator = do+  rowWith (fixedH menuSepH . padXY (menuItemPadX - menuOuterPad) 4.5 . fillW) $+    columnWith (tight . fillW) separator++-- | Header / category title inside a context menu.+menuHeader :: Ui :> es => Text -> Eff es ()+menuHeader txt =+  void (labelEx (padXY 6 2 defaultLayout) txt)
+ lib/NanoUI/Widgets/Node.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Widget node construction and interaction responses.+module NanoUI.Widgets.Node+  ( Response (..)+  , HasResponse (..)+  , respId+  , respRect+  , respHovered+  , respPressed+  , respClicked+  , respChanged+  , respSubmitted+  , respRightPressed+  , respRightClicked+  , mkResponse+  , emptyModalResp+  , setClicked+  , setChanged+  , setSubmitted+  , parentIdx+  , container+  , containerResponse+  , withContainerNode+  , floatingPanel+  , addWidget+  , addWidgetStyled+  , addWidgetWithOptions+  , addSizingLeafNode+  , resolveInteraction+  , tagContainer+  )+where++import Control.Monad (when)+import Data.IORef (readIORef, writeIORef)+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , isDisabled+  , pointerBlockedByOverlay+  , OverlayState (..)+  , getsOverlay+  , modifyOverlay+  )+import NanoUI.Id (WidgetId (..), enterScope, hashWidgetId, scopeTag)+import NanoUI.Input+  ( Input (..)+  , inputMouseDown+  , inputMousePos+  , inputMouseReleased+  , inputMouseRightDown+  , inputMouseRightReleased+  )+import NanoUI.Layout.Arena+  ( NodeIdx+  , NodeType (..)+  , addNode+  , addNodeFromLayout+  , rootAttachParent+  , setNodeText+  , setOptions+  , setNodeValue+  , setStyleIdx+  , setWidgetId+  )+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)+import NanoUI.WidgetText (packTextNodeStyleFull)+import NanoUI.Style+  ( AlignX (..)+  , AlignY (..)+  , Direction (..)+  , Layout (..)+  , Padding (..)+  , Sizing (..)+  )+import NanoUI.Types (Rect (..), rectContains, rectH, rectHit, rectUnion, rectW)+import NanoUI.Frame.Hit (findNodeByWidgetId, nodeInteractionHit, scrollHitRect)++parentIdx :: [Int] -> Int+parentIdx = \case+  [] -> -1+  (p : _) -> p++-- | Anything that carries a widget 'Response' (composite widget results such+-- as 'NanoUI.Widgets.Tabs.TabResponse'). The @resp*@ accessors work on all of them.+class HasResponse r where+  toResponse :: r -> Response++instance HasResponse Response where+  {-# INLINE toResponse #-}+  toResponse = id++{-# INLINE respId #-}+respId :: HasResponse r => r -> WidgetId+respId = rawRespId . toResponse++{-# INLINE respRect #-}+respRect :: HasResponse r => r -> Rect+respRect = rawRespRect . toResponse++{-# INLINE respHovered #-}+respHovered :: HasResponse r => r -> Bool+respHovered = rawRespHovered . toResponse++{-# INLINE respPressed #-}+respPressed :: HasResponse r => r -> Bool+respPressed = rawRespPressed . toResponse++{-# INLINE respClicked #-}+respClicked :: HasResponse r => r -> Bool+respClicked = rawRespClicked . toResponse++{-# INLINE respChanged #-}+respChanged :: HasResponse r => r -> Bool+respChanged = rawRespChanged . toResponse++{-# INLINE respSubmitted #-}+respSubmitted :: HasResponse r => r -> Bool+respSubmitted = rawRespSubmitted . toResponse++{-# INLINE respRightPressed #-}+respRightPressed :: HasResponse r => r -> Bool+respRightPressed = rawRespRightPressed . toResponse++{-# INLINE respRightClicked #-}+respRightClicked :: HasResponse r => r -> Bool+respRightClicked = rawRespRightClicked . toResponse++data Response = Response+  { rawRespId :: !WidgetId+  , rawRespRect :: !Rect+  , rawRespHovered :: !Bool+  , rawRespPressed :: !Bool+  , rawRespClicked :: !Bool+  , rawRespChanged :: !Bool+  , rawRespSubmitted :: !Bool+  , rawRespRightPressed :: !Bool+  , rawRespRightClicked :: !Bool+  }+  deriving (Eq, Show)++instance Semigroup Response where+  a <> b =+    Response+      { rawRespId = if rawRespId b == WidgetId 0 then rawRespId a else rawRespId b+      , rawRespRect = unionRespRect (rawRespRect a) (rawRespRect b)+      , rawRespHovered = rawRespHovered a || rawRespHovered b+      , rawRespPressed = rawRespPressed a || rawRespPressed b+      , rawRespClicked = rawRespClicked a || rawRespClicked b+      , rawRespChanged = rawRespChanged a || rawRespChanged b+      , rawRespSubmitted = rawRespSubmitted a || rawRespSubmitted b+      , rawRespRightPressed = rawRespRightPressed a || rawRespRightPressed b+      , rawRespRightClicked = rawRespRightClicked a || rawRespRightClicked b+      }++instance Monoid Response where+  mempty = mkResponse (WidgetId 0) (Rect 0 0 0 0) False False False False++unionRespRect :: Rect -> Rect -> Rect+unionRespRect a b+  | rectW a <= 0 || rectH a <= 0 = b+  | rectW b <= 0 || rectH b <= 0 = a+  | otherwise = rectUnion a b++setClicked :: Bool -> Response -> Response+setClicked c r = r {rawRespClicked = c}++setChanged :: Bool -> Response -> Response+setChanged c r = r {rawRespChanged = c}++setSubmitted :: Bool -> Response -> Response+setSubmitted s r = r {rawRespSubmitted = s}++mkResponse :: WidgetId -> Rect -> Bool -> Bool -> Bool -> Bool -> Response+mkResponse wid rect hovered pressed clicked changed =+  Response+    { rawRespId = wid+    , rawRespRect = rect+    , rawRespHovered = hovered+    , rawRespPressed = pressed+    , rawRespClicked = clicked+    , rawRespChanged = changed+    , rawRespSubmitted = False+    , rawRespRightPressed = False+    , rawRespRightClicked = False+    }++emptyModalResp :: WidgetId -> Response+emptyModalResp wid = mempty {rawRespId = wid}++container :: Ui :> es => NodeType -> Layout -> Eff es a -> Eff es a+container nt layout child = runContainer nt layout Nothing child++containerResponse :: Ui :> es => NodeType -> Layout -> Eff es a -> Eff es (a, Response)+containerResponse nt layout child = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  r <- runContainer nt layout (Just wid) child+  resp <- uiIO (resolveInteraction ctx inp wid)+  pure (r, resp)++runContainer :: Ui :> es => NodeType -> Layout -> Maybe WidgetId -> Eff es a -> Eff es a+runContainer nt layout mWid child = do+  ctx <- askContext+  idx <- uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    idx <- addNodeFromLayout (ctxNodeArena ctx) nt (parentIdx stack) layout+    mapM_ (setWidgetId (ctxNodeArena ctx) idx) mWid+    pure idx+  withContainerNode True idx child++-- | Push container node @idx@ (already added under the current parent), run+-- @child@ inside it, then pop. @scoped@ also runs the children in a fresh id+-- scope; it changes the children's widget ids (and so their store keys), so+-- callers pick it explicitly: plain containers scope, scroll containers do not.+withContainerNode :: Ui :> es => Bool -> NodeIdx -> Eff es a -> Eff es a+withContainerNode scoped idx child = do+  ctx <- askContext+  (stack, parentIds) <- uiIO $ do+    stack0 <- readIORef (ctxContainerStack ctx)+    writeIORef (ctxContainerStack ctx) (idx : stack0)+    ids0 <- readIORef (ctxIdContext ctx)+    if scoped+      then do+        let (parentIds, childIds) = enterScope scopeTag ids0+        writeIORef (ctxIdContext ctx) childIds+        pure (stack0, parentIds)+      else pure (stack0, ids0)+  r <- child+  uiIO $ do+    writeIORef (ctxContainerStack ctx) stack+    when scoped $ writeIORef (ctxIdContext ctx) parentIds+  pure r++-- | A floating panel (popup, modal, window): its node attaches to the root+-- layer and it is the current floating panel while @body@ runs. @addPanel@+-- adds the node under the given parent; @enter@ runs once the node is pushed+-- (seeding its rect, opening a modal).+floatingPanel ::+  Ui :> es => Bool -> WidgetId -> (Int -> IO NodeIdx) -> IO () -> Eff es a -> Eff es a+floatingPanel scoped wid addPanel enter body = do+  ctx <- askContext+  let arena = ctxNodeArena ctx+  prevFloat <- uiIO (getsOverlay ctx osCurrentFloatingId)+  idx <- uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    idx <- addPanel =<< rootAttachParent arena (parentIdx stack)+    setWidgetId arena idx wid+    pure idx+  r <- withContainerNode scoped idx (uiIO (enter >> modifyOverlay ctx (\os -> os {osCurrentFloatingId = Just wid})) >> body)+  uiIO (modifyOverlay ctx (\os -> os {osCurrentFloatingId = prevFloat}))+  pure r++addSizingLeafNode ::+  Context+  -> Input+  -> WidgetId+  -> NodeType+  -> Direction+  -> Sizing+  -> Sizing+  -> IO Response+addSizingLeafNode ctx inp wid nt dir wSiz hSiz = do+  stack <- readIORef (ctxContainerStack ctx)+  let+    parent = parentIdx stack+  idx <-+    addNode+      (ctxNodeArena ctx)+      nt+      parent+      dir+      wSiz+      hSiz+      (Padding 0 0 0 0)+      0+      0+      0+      1e9+      1e9+      0+      AlignStart+      AlignTop+  setWidgetId (ctxNodeArena ctx) idx wid+  resolveInteraction ctx inp wid++{-# INLINE addWidget #-}+addWidget ::+  Ui :> es =>+  WidgetId+  -> NodeType+  -> Text+  -> Float+  -> Layout+  -> Eff es Response+addWidget wid nt txt value layout = addWidgetStyled wid nt txt value layout 0++{-# INLINE addWidgetStyled #-}+addWidgetStyled ::+  Ui :> es =>+  WidgetId+  -> NodeType+  -> Text+  -> Float+  -> Layout+  -> Int+  -> Eff es Response+addWidgetStyled wid nt txt value layout styleIdx = do+  ctx <- askContext+  inp <- askInput+  uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    let+      parent = parentIdx stack+    idx <- addNodeFromLayout (ctxNodeArena ctx) nt parent layout+    setNodeText (ctxNodeArena ctx) idx txt+    setNodeValue (ctxNodeArena ctx) idx value+    let effectiveStyle+          | nt == NodeText = packTextNodeStyleFull (layoutFontVariant layout) (layoutFontWeight layout) (layoutFontStyle layout) (layoutTextDecoration layout) styleIdx+          | otherwise = styleIdx+    setStyleIdx (ctxNodeArena ctx) idx effectiveStyle+    setWidgetId (ctxNodeArena ctx) idx wid+    resolveInteraction ctx inp wid++addWidgetWithOptions ::+  Ui :> es =>+  WidgetId+  -> NodeType+  -> Text+  -> [Text]+  -> Float+  -> Layout+  -> Eff es Response+addWidgetWithOptions wid nt txt opts value layout = do+  ctx <- askContext+  inp <- askInput+  uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    let parent = parentIdx stack+    idx <- addNodeFromLayout (ctxNodeArena ctx) nt parent layout+    setNodeText (ctxNodeArena ctx) idx txt+    setOptions (ctxNodeArena ctx) idx opts+    setNodeValue (ctxNodeArena ctx) idx value+    setStyleIdx (ctxNodeArena ctx) idx 0+    setWidgetId (ctxNodeArena ctx) idx wid+    resolveInteraction ctx inp wid++resolveInteraction :: Context -> Input -> WidgetId -> IO Response+resolveInteraction ctx inp wid = do+  mrect <- scrollHitRect ctx wid+  active <- readIORef (ctxActiveId ctx)+  pending <- readIORef (ctxClickedId ctx)+  let+    mouse = inputMousePos inp+    rect = case mrect of+      Just r -> r+      Nothing -> Rect 0 0 0 0+    canHit = rectHit rect mouse || pending == wid+  if not canHit+    then pure $! mkResponse wid rect False False False False+    else do+      disabled <- isDisabled ctx wid+      blocked <- pointerBlockedByOverlay ctx mouse+      mIdx <- findNodeByWidgetId ctx wid+      let+        hitAt p = case mIdx of+          Nothing -> pure (rectContains rect p)+          Just idx -> nodeInteractionHit ctx idx rect p+        -- Whether the button held in @ref@ went down on this widget. A press+        -- the frame never saw (synthesized input, or one swallowed before it+        -- arrived) leaves the gesture unowned, so nobody is ruled out.+        startedHere ref = readIORef ref >>= maybe (pure True) hitAt+      -- A held button belongs to whatever it went down on. Another widget the+      -- drag passes over is not hovered, so it neither lights up nor reports a+      -- press of its own.+      captured <-+        if not (inputMouseDown inp)+          then pure False+          else+            if hashWidgetId active /= 0 && active /= wid+              then pure True+              else not <$> startedHere (ctxPressPos ctx)+      hovered <-+        if disabled || blocked || captured+          then pure False+          else hitAt mouse+      let+        pressed = hovered && inputMouseDown inp+        rightPressed = hovered && inputMouseRightDown inp+      -- The click belongs to whatever the press went down on: a release that+      -- drifted here from a neighbouring widget is not this widget's click.+      released <-+        if hovered && inputMouseReleased inp+          then startedHere (ctxPressPos ctx)+          else pure False+      rightReleased <-+        if hovered && inputMouseRightReleased inp+          then startedHere (ctxRightPressPos ctx)+          else pure False+      when (released && wid == active) $+        writeIORef (ctxReleaseClickedId ctx) wid+      let+        clicked = released || pending == wid+        rightClicked = rightReleased+      pure $!+        Response+          { rawRespId = wid+          , rawRespRect = rect+          , rawRespHovered = hovered+          , rawRespPressed = pressed+          , rawRespClicked = clicked+          , rawRespChanged = False+          , rawRespSubmitted = False+          , rawRespRightPressed = rightPressed+          , rawRespRightClicked = rightClicked+          }++-- | Stamp the current container with a widget id (radio/tree group key).+tagContainer :: Ui :> es => WidgetId -> Eff es ()+tagContainer wid = do+  ctx <- askContext+  uiIO $ do+    stack <- readIORef (ctxContainerStack ctx)+    case stack of+      (idx : _) -> setWidgetId (ctxNodeArena ctx) idx wid+      [] -> pure ()
+ lib/NanoUI/Widgets/NumericInput.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Numeric field: a text field that only accepts numbers, with an up / down+-- stepper, arrow-key steps, and an optional hexadecimal mode.+module NanoUI.Widgets.NumericInput+  ( NumericInputConfig (..)+  , defaultNumericInputConfig+  , numericInput+  , numericInput'+  , numericInputConfigured+  , numericInputConfigured'+  )+where++import Control.Monad (when)+import Data.Char (isDigit, isHexDigit)+import Data.IntMap.Strict qualified as IM+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Read qualified as TR+import Effectful (Eff, type (:>))+import GHC.Clock (getMonotonicTime)+import NanoUI.Context (getStore, intKey, markDirty, registerFocusable, modifyStore)+import NanoUI.Input (Key (..), inputKeys, inputKeysElem, inputModifiers, inputMouseDown, inputMousePos, inputMousePressed, modShift)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)+import NanoUI.Store (WidgetStore (..), slotKey, Slot (..))+import NanoUI.Style (Layout (..), Sizing (..), defaultLayout)+import NanoUI.Types (Rect (..), rectContains)+import NanoUI.WidgetText (numericStepperRects, textInputFlagNumeric)+import NanoUI.Widgets.Behavior (keyboardFocused)+import NanoUI.Widgets.Node (Response, addWidgetStyled, respHovered, respRect, setChanged, setSubmitted)+import NanoUI.Widgets.TextEditor (singleLineMode)+import NanoUI.Widgets.TextInput (TextInputState (..), editTextInput, editorTextState, loadTextInputState, saveTextEditor, saveTextInputState)+import Numeric (showFFloat, showHex)++-- | How a numeric field reads, shows, and steps its value.+data NumericInputConfig = NumericInputConfig+  { nicMin :: !Double+    -- ^ Smallest value (default: no limit).+  , nicMax :: !Double+    -- ^ Largest value (default: no limit).+  , nicStep :: !Double+    -- ^ What one arrow key or stepper click adds (default 1). Shift steps ten+    -- times as far.+  , nicDecimals :: !Int+    -- ^ Digits after the decimal point, both shown and accepted (default 0).+  , nicHex :: !Bool+    -- ^ Show and accept the value as a whole hexadecimal number (default+    -- 'False'). 'nicDecimals' is ignored in this mode.+  , nicLayout :: !Layout+  }+  deriving (Eq, Show)++defaultNumericInputConfig :: NumericInputConfig+defaultNumericInputConfig =+  NumericInputConfig+    { nicMin = -1 / 0+    , nicMax = 1 / 0+    , nicStep = 1+    , nicDecimals = 0+    , nicHex = False+    , nicLayout = defaultLayout {layoutWidth = Grow 1, layoutMinW = 80}+    }++-- | Numeric field over whole numbers. Pass the current value; the result is+-- the value after this frame's typing, arrow keys, and stepper clicks.+--+-- Only digits, and a leading minus sign when the range reaches below zero, can+-- be typed. Up and Down step the value, Shift steps ten times as far, and+-- holding a stepper arrow repeats. Enter, a step, or leaving the field rewrites+-- the text as the value, clamped to the range.+{-# INLINE numericInput #-}+numericInput :: Ui :> es => Double -> Eff es Double+numericInput value = snd <$> numericInputConfigured' defaultNumericInputConfig value++{-# INLINE numericInput' #-}+numericInput' :: Ui :> es => Double -> Eff es (Response, Double)+numericInput' = numericInputConfigured' defaultNumericInputConfig++-- | 'numericInput' with a range, a step, decimal places, hexadecimal mode, or+-- its own layout.+--+-- @+-- byte' <- numericInputConfigured defaultNumericInputConfig {nicMin = 0, nicMax = 255, nicHex = True} byte+-- @+{-# INLINE numericInputConfigured #-}+numericInputConfigured :: Ui :> es => NumericInputConfig -> Double -> Eff es Double+numericInputConfigured cfg value = snd <$> numericInputConfigured' cfg value++numericInputConfigured' :: Ui :> es => NumericInputConfig -> Double -> Eff es (Response, Double)+numericInputConfigured' cfg value = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  uiIO $ registerFocusable ctx wid+  store <- uiIO (getStore ctx)+  isFocus <- keyboardFocused wid+  let+    key = intKey wid+    given = clampNumber cfg value+    stored = IM.lookup key (storeText store)+    -- Unfocused, the field shows the caller's value; focused, it keeps the+    -- text being typed.+    text0 = if isFocus then fromMaybe (formatNumber cfg given) stored else formatNumber cfg given+    s0 = loadTextInputState store key text0+    lastValue = IM.findWithDefault given key (storeDouble store)+  mEdited <- if isFocus then uiIO (editTextInput ctx singleLineMode inp store key s0) else pure Nothing+  resp <- addWidgetStyled wid NodeTextInput "" 0 (nicLayout cfg) textInputFlagNumeric+  let+    -- An edit that would leave text no number can start with is dropped.+    typed = maybe s0 editorTextState mEdited+    s1 = if acceptsNumberText cfg (tisText typed) then typed else s0+    current+      | isFocus = maybe lastValue (clampNumber cfg) (parseNumber cfg (tisText s1))+      | otherwise = given+    Rect rx ry rw rh = respRect resp+    (upRect, downRect) = numericStepperRects rx ry rw rh+    mouse = inputMousePos inp+    keys = inputKeys inp+    over r dir = if respHovered resp && rectContains r mouse then dir else 0+    pressDir+      | inputMousePressed inp = over upRect 1 + over downRect (-1)+      | otherwise = 0 :: Int+    held0 = IM.findWithDefault 0 (slotKey SlotNumericHeld key) (storeInt store)+    holding =+      held0 /= 0+        && inputMouseDown inp+        && over (if held0 > 0 then upRect else downRect) held0 /= 0+    keyDir+      | not isFocus = 0+      | inputKeysElem KeyUp keys = 1+      | inputKeysElem KeyDown keys = -1+      | otherwise = 0+  now <- if pressDir /= 0 || holding then uiIO getMonotonicTime else pure 0+  let+    repeatAt0 = IM.findWithDefault 0 (slotKey SlotNumericRepeat key) (storeDouble store)+    -- A held arrow repeats after a pause.+    repeatDir = if pressDir == 0 && holding && now >= repeatAt0 then held0 else 0+    dir+      | pressDir /= 0 = pressDir+      | repeatDir /= 0 = repeatDir+      | otherwise = keyDir+    held1+      | pressDir /= 0 = pressDir+      | holding = held0+      | otherwise = 0+    repeatAt1+      | pressDir /= 0 = now + 0.4+      | repeatDir /= 0 = now + 0.06+      | held1 == 0 = 0+      | otherwise = repeatAt0+    scale = if modShift (inputModifiers inp) then 10 else 1+    final+      | dir /= 0 = clampNumber cfg (roundNumber cfg (current + fromIntegral dir * scale * nicStep cfg))+      | otherwise = current+    submitted = isFocus && inputKeysElem KeyEnter keys+    -- A step or Enter rewrites the text as the value, caret at its end.+    s2+      | dir /= 0 || submitted =+          let t = formatNumber cfg final+           in TextInputState t (T.length t) (T.length t)+      | otherwise = s1+    heldK = slotKey SlotNumericHeld key+    repeatK = slotKey SlotNumericRepeat key+    dirty =+      stored /= Just (tisText s2)+        || s2 /= s0+        || IM.lookup key (storeDouble store) /= Just final+        || held1 /= held0+        || repeatAt1 /= repeatAt0+  when dirty $+    uiIO $ do+      -- An accepted edit keeps its undo history; a rejected one or a step+      -- rewrites the text without it.+      let save = case mEdited of+            Just ed | editorTextState ed == s2 -> saveTextEditor key ed+            _ -> saveTextInputState key s2+      modifyStore ctx $ \st0 ->+        let st = save st0+         in st+              { storeInt = (if held1 == 0 then IM.delete heldK else IM.insert heldK held1) (storeInt st)+              , storeDouble = IM.insert key final (IM.insert repeatK repeatAt1 (storeDouble st))+              }+  -- Keep frames coming while an arrow is held so it can repeat.+  when (held1 /= 0) $ uiIO (markDirty ctx)+  pure (setSubmitted submitted (setChanged (final /= value) resp), final)++clampNumber :: NumericInputConfig -> Double -> Double+clampNumber cfg = max (nicMin cfg) . min (nicMax cfg)++-- | The value rounded to what the field shows.+roundNumber :: NumericInputConfig -> Double -> Double+roundNumber cfg v+  | nicHex cfg || nicDecimals cfg <= 0 = fromInteger (round v)+  | otherwise = fromInteger (round (v * scale)) / scale+  where+    scale = 10 ^ nicDecimals cfg++formatNumber :: NumericInputConfig -> Double -> Text+formatNumber cfg v+  | nicHex cfg =+      let n = round v :: Integer+       in (if n < 0 then "-" else "") <> T.toUpper (T.pack (showHex (abs n) ""))+  | nicDecimals cfg <= 0 = T.pack (show (round v :: Integer))+  | otherwise = T.pack (showFFloat (Just (nicDecimals cfg)) v "")++-- | Whether @t@ can stand in the field mid-edit: an optional minus sign when+-- the range reaches below zero, then digits (hexadecimal ones in hex mode),+-- and with decimal places, one point followed by at most that many digits.+acceptsNumberText :: NumericInputConfig -> Text -> Bool+acceptsNumberText cfg t =+  signOk && case T.splitOn "." body of+    [whole] -> T.all digit whole+    [whole, frac] -> decimals > 0 && T.all isDigit whole && T.all isDigit frac && T.length frac <= decimals+    _ -> False+  where+    (negative, body) = maybe (False, t) ((,) True) (T.stripPrefix "-" t)+    signOk = not negative || nicMin cfg < 0+    digit = if nicHex cfg then isHexDigit else isDigit+    decimals = if nicHex cfg then 0 else nicDecimals cfg++-- | The value the text reads as, once it reads as one.+parseNumber :: NumericInputConfig -> Text -> Maybe Double+parseNumber cfg t+  | nicHex cfg = case TR.signed TR.hexadecimal t of+      Right (n, rest) | T.null rest -> Just (fromInteger n)+      _ -> Nothing+  | otherwise = case TR.signed TR.rational (T.dropWhileEnd (== '.') t) of+      Right (v, rest) | T.null rest -> Just v+      _ -> Nothing
+ lib/NanoUI/Widgets/Overlay.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Overlay+  ( modal+  , window+  )+where++import Control.Monad (void, when)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , beginModal+  , endModal+  , getPrevRect+  , getStore+  , intKey+  , seedFloatingPanel+  )+import NanoUI.Id (WidgetId)+import NanoUI.Input+  ( inputWindowSize+  )+import NanoUI.Layout.Arena (NodeType (..), addNode)+import NanoUI.Monad+  ( Ui+  , askContext+  , askInput+  , uiIO+  , withKey+  )+import NanoUI.Store (WidgetStore (..), slotKey, Slot (..))+import NanoUI.Style+  ( AlignX (..)+  , AlignY (..)+  , Direction (..)+  , Padding (..)+  , Sizing (..)+  , grow+  , padB+  , padT+  , tight+  , windowMargin+  , windowPad+  )+import NanoUI.Types (Rect (..), Size (..), rectNonEmpty)+import NanoUI.Widgets.Chrome+  ( closeButton+  , floatMinFor+  , modalTitleBarH+  , titleBarChromeHFor+  , titleBarLayoutFor+  , titleLabelLayoutFor+  )+import NanoUI.Widgets.Popup (floatingOverlay)+import NanoUI.Widgets.Layout+  ( flex+  , labelEx+  , row'+  , scrollWith+  , separator+  )+import NanoUI.Widgets.Node+  ( Response (..)+  , respClicked+  )++data OverlayKind+  = ModalOverlay+  | WindowOverlay+  deriving Eq++modal :: Ui :> es => Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)+modal = overlay ModalOverlay++window :: Ui :> es => Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)+window = overlay WindowOverlay++overlay ::+  Ui :> es =>+  OverlayKind -> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)+overlay kind open title child = do+  ctx <- askContext+  inp <- askInput+  let+    Size winW winH = inputWindowSize inp+    margin = windowMargin+    availW = max 1 (winW - 2 * margin)+    availH = max 1 (winH - 2 * margin)+    isModal = kind == ModalOverlay+    -- Modals share the window's side padding. The body's scrollbar sits+    -- out in it just inside the panel's edge, that padding from the+    -- content.+    padding = if isModal then windowPad {padB = 12} else windowPad+    barH = if isModal then modalTitleBarH else titleBarChromeHFor+    -- Window body breathing room: one side-pad between the chrome and+    -- the body, matching the window's left/right padding. Modals keep+    -- their own larger gap.+    bodyGap = if isModal then 8 else 10+    minWidth =+      floatMinFor+        (if isModal then 260 else 280)+        availW+    minHeight =+      if isModal+        then 0+        else+          min availH (padT padding + titleBarChromeHFor + bodyGap + padB padding)+    addOverlayNode _ parent =+      addNode+        (ctxNodeArena ctx)+        (if isModal then NodeModal else NodeWindow)+        parent+        Column+        Fit+        Fit+        padding+        bodyGap+        minWidth+        minHeight+        availW+        availH+        0+        AlignStart+        AlignTop+    enter wid = do+      when isModal (beginModal ctx)+      seedFloatingPanel ctx wid+        =<< floatingSeedRect ctx wid isModal minWidth minHeight margin winW winH+    titleLabel = void (labelEx (titleLabelLayoutFor barH) title)+  floatingOverlay open isModal addOverlayNode enter $ do+    close <-+      row' (titleBarLayoutFor barH) $ do+        when (not (T.null title)) $+          case kind of+            ModalOverlay -> titleLabel+            WindowOverlay -> withKey title titleLabel+        flex+        withKey ("close" :: Text) closeButton+    when (isModal && not (T.null title)) separator+    r <- scrollWith (tight . grow) child+    when isModal (uiIO (endModal ctx))+    pure (respClicked close, r)++floatingSeedRect ::+  Context+  -> WidgetId+  -> Bool+  -> Float+  -> Float+  -> Float+  -> Float+  -> Float+  -> IO Rect+floatingSeedRect ctx wid isModal minWidth minHeight margin winW winH = do+  mPrev <- getPrevRect ctx wid+  case mPrev of+    Just r | rectNonEmpty r -> pure r+    _ -> do+      store <- getStore ctx+      let+        k = intKey wid+        pos = IM.lookup k (storePoint store)+        sz = IM.lookup (slotKey SlotWinSize k) (storePoint store)+      pure $+        case (pos, sz) of+          (Just (x, y), Just (w, h)) | w > 0 && h > 0 -> Rect x y w h+          (Just (x, y), _) -> Rect x y minWidth (max minHeight 1)+          _ ->+            let+              w = minWidth+              h = max minHeight 1+             in+              if isModal+                then Rect ((winW - w) / 2) ((winH - h) / 2) w h+                else Rect (max 0 (winW - w - margin)) margin w h
+ lib/NanoUI/Widgets/PaneGrid.hs view
@@ -0,0 +1,1005 @@+{-# 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+  { pgLayout :: !(Layout -> Layout)+    -- ^ Layout modifier for the grid container (default 'id'); pass+    -- @fillW . fillH@ to fill the parent area.+  , pgSpacing :: !Float+    -- ^ Gutter between panes per split level (default 4).+  , pgMinSize :: !Float+    -- ^ Minimum physical size any pane may shrink to (default 40).+  , 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).+  , 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.+  , pgViewPane :: !(Word64 -> PaneGridCtx es -> Eff es PaneView)+    -- ^ Renders the content of one pane.+  }++defaultPaneGridConfig :: PaneGridConfig es+defaultPaneGridConfig =+  PaneGridConfig+    { pgLayout = id+    , pgSpacing = 4+    , pgMinSize = 40+    , pgLeeway = 6+    , pgEdgeBand = 20+    , pgViewPane = \_ _ -> pure (PaneView "" False Nothing)+    }++-- | Actions handed to a pane so it can mutate the grid immediately.+data PaneGridCtx es = PaneGridCtx+  { pgcPaneId :: !Word64+  , 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.+  , pgcMaximized :: !Bool+    -- ^ True when this pane currently fills the whole grid.+  , 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.+  , pgcDndActive :: !Bool+    -- ^ True while any pane drag-and-drop gesture is in progress.+  , pgcSplit :: !(GridAxis -> Eff es Word64)+    -- ^ Split this pane along the axis; returns the new pane id.+  , pgcClose :: !(Eff es ())+  , pgcMaximize :: !(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+  { pvTitle :: !Text+    -- ^ Label shown (abbreviated to fit) on the compact drag indicator.+  , 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'.+  , 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 (Eq, 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+  { pgrChanged :: !Bool+    -- ^ Any structural or maximize change happened this frame.+  , pgrPaneCount :: !Int+    -- ^ Number of panes (0 once the last pane has been closed).+  , pgrPanes :: ![Word64]+    -- ^ Live pane ids, depth-first.+  , pgrFocusedPane :: !Word64+    -- ^ Focused pane id, 0 when the grid has no panes.+  , pgrMaximizedPane :: !Word64+    -- ^ Maximized pane id, 0 when none.+  }+  deriving (Eq, Show)++-- -----------------------------------------------------------------------------+-- Internal state+-- -----------------------------------------------------------------------------++data RenderedPane = RenderedPane+  { rpPaneId :: !Word64+  , rpView :: !PaneView+  , rpControlHit :: !Bool+  }++-- | Per-frame shared environment.+data GridEnv es = GridEnv+  { geCtx :: !Context+  , geKey :: !Int+  , gePaneScope :: !IdContext+    -- ^ Pane identity is rooted at the grid widget, independent of split+    -- ancestry so rearranging or temporarily collapsing splits preserves state.+  , geCfg :: !(PaneGridConfig es)+  , geGutter :: !Float+  , geThickness :: !Float+  , geMinSize :: !Float+  , geLeeway :: !Float+  , geRegions :: !(Map Word64 Rect)+    -- ^ Prev-frame pane regions; drives hit testing and 'pgcRect'.+  , geBaseRect :: !Rect+    -- ^ Prev-frame rect of the grid's root container.+  , geTree :: !GridNode+  , 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.+  , geDrag0 :: !Int+  , geMax :: !Word64+  , geChangedRef :: !(IORef Bool)+  , geMakeCtx :: Word64 -> Rect -> Bool -> PaneGridCtx es+  }++-- | Computed drag-and-drop interaction state for one frame.+data DragInfo = DragInfo+  { dgiActive :: !Bool+  , dgiMoved :: !Bool+  , dgiGhost :: !(Maybe Rect)+  , 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 k st = IM.lookup k (storeDyn st) >>= fromDynamic++-- | A stored pane id that still exists in the tree, else 0.+validPane :: GridNode -> Int -> Word64+validPane t n =+  let p = fromIntegral n+   in if paneExist t p then p else 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 tree maxPane focus0+  | maxPane /= 0 = maxPane+  | paneExist tree focus0 = focus0+  | otherwise = fromMaybe 1 (listToMaybe (treePanes tree))++-- -----------------------------------------------------------------------------+-- Entry point+-- -----------------------------------------------------------------------------++paneGrid :: (Ui :> es) => PaneGridConfig es -> Eff es PaneGridResponse+paneGrid cfg = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  uiIO (registerFocusable ctx wid)+  let key = intKey wid+      gestK = slotKey SlotPaneGest key+      grabK = slotKey SlotPaneGrab key+      focusK = slotKey SlotPaneFocus key+      maxK = slotKey SlotPaneMax key+      seedK = slotKey SlotPaneNext key+      spacing = max 0 (pgSpacing cfg)+      minSize = max 0 (pgMinSize cfg)+      leeway = max 0 (pgLeeway cfg)+      edgeBand = max 0 (pgEdgeBand cfg)+      gutter = spacing + 2 * leeway+  st <- uiIO (getStore ctx)+  (tree0, seed1) <- case lookupTree key st of+    Just t ->+      -- Init seeded the store before the tree existed, so the stored seed+      -- is already above every id in the tree.+      pure (t, fromIntegral (IM.findWithDefault 1 seedK (storeInt st)))+    Nothing -> do+      let seed = max 1 (fromIntegral (IM.findWithDefault 1 seedK (storeInt st)))+          start = Pane seed+      uiIO $+        setStore+          ctx+          ( bumpMirror+              ( st+                  { storeInt = IM.insert seedK (fromIntegral (seed + 1)) (storeInt st)+                  , storeDyn = IM.insert key (toDyn start) (storeDyn st)+                  }+              )+          )+      pure (start, seed + 1)+  mPrev <- uiIO (getPrevRect ctx wid)+  let baseRect = fromMaybe (Rect 0 0 0 0) mPrev+      drag0 = IM.findWithDefault 0 gestK (storeInt st)+      maxPane = validPane tree0 (IM.findWithDefault 0 maxK (storeInt st))+      focus0 = IM.findWithDefault 0 focusK (storeInt st)+      focusedInit = resolveFocus tree0 maxPane (fromIntegral focus0)+      mouse = inputMousePos inp+      (regions, dividers) = layoutNode minSize gutter tree0 baseRect+  changedRef <- uiIO (newIORef False)+  let mGrab = IM.lookup grabK (storePoint st)+      dgi =+        computeDragInfo+          drag0+          (IM.findWithDefault 0 grabK (storeInt st) /= 0)+          DragGeom+            { dgMinSize = minSize+            , dgGutter = gutter+            , dgTree = tree0+            , dgBaseRect = baseRect+            , dgBand = edgeBand+            , dgRegions = regions+            }+          mGrab+          mouse+      dgiShown = dgiActive dgi && dgiMoved dgi && inputMouseDown 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 dgiShown then treeRemovePane (fromIntegral drag0) tree0 else Just tree0+      (visibleRegions, visibleDividers)+        | dgiShown = maybe (M.empty, []) (\t -> layoutNode minSize gutter t baseRect) visibleTree+        | otherwise = (regions, dividers)+      divMap = M.fromList [(diSplitId d, d) | d <- visibleDividers]+      env =+        GridEnv+          { geCtx = ctx+          , geKey = key+          , gePaneScope = IdContext (hashWidgetId wid) 0+          , geCfg = cfg+          , geGutter = gutter+          , geThickness = spacing+          , geMinSize = minSize+          , geLeeway = leeway+          , geRegions = visibleRegions+          , geBaseRect = baseRect+          , geTree = tree0+          , geSeed = seed1+          , geDrag0 = drag0+          , geMax = maxPane+          , geChangedRef = changedRef+          , geMakeCtx = \pid rect dragging ->+              PaneGridCtx+                { pgcPaneId = pid+                , pgcRect = rect+                , pgcMaximized = maxPane == pid+                , pgcDragging = dragging+                , pgcDndActive = dgiMoved dgi+                , pgcSplit = \axis -> splitPane env pid axis+                , pgcClose = closePane env pid+                , pgcMaximize = maximizePane env pid+                , pgcRestore = restorePane 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) $ \r ->+            uiIO $ registerCustomDrawing ctx wid (contentKey [1, rectX r, rectY r, rectW r, rectH r]) $ \cdc _ ->+              runCanvas (drawStrokeRoundedRect (rectInflate (-2) r) 2 1.5 (themeAccent (cdcTheme 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 = inputChars inp+        cur = 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 = lookupTree key stEnd+      maxEnd = maybe 0 (\t -> validPane t (IM.findWithDefault 0 maxK (storeInt stEnd))) treeEnd+      focusEnd =+        maybe+          0+          (\t -> resolveFocus t maxEnd (fromIntegral (IM.findWithDefault 0 focusK (storeInt stEnd))))+          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 minSize f =+  f+    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 wSiz hSiz =+  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 = sizingLay (Grow 1) (Grow 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 AxisV p = sizingLay (Percent p) (Grow 1)+splitSideLay AxisH p = sizingLay (Grow 1) (Percent p)++minSized :: Layout -> Float -> Float -> Layout+minSized l minW_ minH_ = l {layoutMinW = minW_, layoutMinH = minH_}++-- | The pane content wrapper: fills its cell, never below one minimum pane.+paneLay :: Float -> Layout+paneLay m = minSized fillLay m m++-- Percent of the main-axis extent for side A, after min clamping.+splitPct :: Float -> Float -> Float -> Float -> Float -> Float+splitPct spacing avail minA minB ratio+  | avail <= 0 = 50+  | otherwise = splitLength spacing avail minA minB ratio / avail * 100++-- -----------------------------------------------------------------------------+-- Rendering+-- -----------------------------------------------------------------------------++renderMaxPane :: (Ui :> es) => GridEnv es -> Word64 -> Eff es [RenderedPane]+renderMaxPane env pid =+  renderPane env pid (geBaseRect env) (paneLay (geMinSize env)) 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 env pid =+  withIdFrame (\parent -> (parent {siblingId = siblingId parent + 1}, gePaneScope env)) . withKey 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 env pid rect lay dragging =+  withPaneKey env pid $ do+    inp <- askInput+    let ctx = geCtx env+        arena = ctxNodeArena ctx+    start <- uiIO (arenaCount arena)+    let ctxt = geMakeCtx env pid rect 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 idx+                | idx >= end = pure False+                | otherwise = do+                    nt <- getNodeType arena idx+                    hit <-+                      if isInteractiveNode nt+                        then do+                          child <- getWidgetId arena idx+                          r <- scrollHitRect ctx child+                          maybe (pure False) (\childRect -> nodeInteractionHit ctx idx childRect (inputMousePos 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 env dividers = \case+  Pane pid ->+    renderPane env pid (paneRect env pid) (paneLay (geMinSize env)) (draggingPane env pid)+  Split sid0 ax _ a b ->+    withKey sid0 $ do+      let (wa, ha) = subtreeMin (geMinSize env) (geGutter env) a+          (wb, hb) = subtreeMin (geMinSize env) (geGutter env) b+          mDiv = M.lookup sid0 dividers+          avail = maybe 0 (mainLen ax . diRegion) mDiv+          (mA, mB) = mainMins ax (wa, ha) (wb, hb)+          pct = splitPct (geGutter env) avail mA mB (maybe 0.5 diRatio mDiv)+          aLay = minSized (splitSideLay ax pct) wa ha+          bLay = minSized fillLay wb hb+          inner = do+            a' <- container NodeContainer aLay (renderNode env dividers a)+            dividerWidget env ax+            b' <- container NodeContainer bLay (renderNode env dividers b)+            pure (a' <> b')+      case ax of+        AxisV -> row' fillLay inner+        AxisH -> column' fillLay inner++-- | Prev-frame rect of a pane; zero until the pane has been laid out once.+paneRect :: GridEnv es -> Word64 -> Rect+paneRect env pid = fromMaybe (Rect 0 0 0 0) (M.lookup pid (geRegions 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 env pid = fromIntegral (geDrag0 env) == 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 env axis = do+  void $+    customWidget+      defaultCustomWidgetSpec+        { widgetLayout = dLay+        , widgetContent = contentKey [if axis == AxisV then 1 else 2, geThickness env, geLeeway env]+        , widgetDraw = \cdc rect -> drawDivider cdc rect axis (geThickness env) (geLeeway env)+        , widgetCursor = Just (const (if axis == AxisV then UiCursorEwResize else UiCursorNsResize))+        }+  where+    dLay = case axis of+      AxisV -> sizingLay (Fixed (geGutter env)) (Grow 1)+      AxisH -> sizingLay (Grow 1) (Fixed (geGutter env))++drawDivider :: CustomDrawContext -> Rect -> GridAxis -> Float -> Float -> SmallArray DrawOp+drawDivider cdc rect axis thickness leeway =+  runCanvas $ do+    let theme = cdcTheme cdc+        panel = themePanel theme+        rail = lerpColor (styleBg panel) (themeSeparator theme) 0.12+        track = separatorTrackColor panel theme+        trackRect = case axis of+          AxisV -> Rect (rectX rect + leeway) (rectY rect) thickness (rectH rect)+          AxisH -> Rect (rectX rect) (rectY rect + leeway) (rectW rect) thickness+    drawRect rect rail+    drawRect trackRect track+    when (cdcHovered cdc || cdcPressed cdc) $ do+      -- Full accent while grabbed; a calmer tint while merely hovering.+      let line+            | cdcPressed cdc = themeAccent theme+            | otherwise = lerpColor (themeAccent theme) (styleBg panel) 0.45+      case axis of+        AxisV ->+          let cx = rectX rect + rectW rect / 2+           in drawStroke (V2 cx (rectY rect)) (V2 cx (rectY rect + rectH rect)) 2 line+        AxisH ->+          let cy = rectY rect + rectH rect / 2+           in drawStroke (V2 (rectX rect) cy) (V2 (rectX rect + rectW rect) cy) 2 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 env wid rendered ghost zone = do+  st <- uiIO (getStore (geCtx env))+  let ctx = geCtx env+      dragPane = fromIntegral (geDrag0 env)+      cached = IM.lookup (slotKey SlotPaneGrab (geKey env)) (storeDyn st) >>= fromDynamic+      title = maybe (fromMaybe "" cached) pvTitle (fmap rpView (find ((== dragPane) . rpPaneId) rendered))+      rectKey = maybe [0, 0, 0, 0, 0] (\(Rect x y w h) -> [1, x, y, w, h])+      key = contentKey (2 : fromIntegral (hash title) : rectKey ghost ++ rectKey zone)+  uiIO $+    registerCustomDrawing ctx wid key (\cdc _ -> drawOverlay (cdcTheme cdc) title ghost 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 title ghost zone =+  runCanvas $ do+    let accent = themeAccent theme+        win = themeFloatingWindow theme+        panelFill = fadeAlpha accent 48+        panelBorder = fadeAlpha accent 128+        previewFill = fadeAlpha accent 32+        shortTitle = if T.length title > 12 then T.take 11 title <> "…" else title+    forM_ ghost $ \gr -> do+      drawRoundedRect gr 2 panelFill+      drawStrokeRoundedRect gr 2 2 panelBorder+      when (not (T.null title)) $+        drawText (V2 (rectX gr + 6) (rectY gr + 6)) AlignStart AlignTop shortTitle (fadeAlpha (styleFg win) 160)+    forM_ zone $ \zr -> do+      drawRoundedRect zr 2 previewFill+      drawStrokeRoundedRect (rectInflate (-1) zr) 2 2 accent++-- -----------------------------------------------------------------------------+-- Gestures+-- -----------------------------------------------------------------------------++-- | Grid geometry 'computeDragInfo' needs for the current frame.+data DragGeom = DragGeom+  { dgMinSize :: !Float+    -- ^ Per-pane size floor used by the preview layout.+  , dgGutter :: !Float+    -- ^ Layout gutter between panes ('pgSpacing' + 2 * 'pgLeeway').+  , dgTree :: !GridNode+    -- ^ Current split tree.+  , dgBaseRect :: !Rect+    -- ^ Prev-frame rect of the grid's root container.+  , dgBand :: !Float+    -- ^ Thickness of the grid's outer top-level drop band.+  , 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 drag0 latched geom mGrab mouse+  | drag0 <= 0 = DragInfo False False Nothing Nothing+  | otherwise =+      let DragGeom{dgMinSize = minSize, dgGutter = gutter, dgTree = tree, dgBaseRect = baseRect, dgBand = band, dgRegions = regions} = geom+          pid = fromIntegral drag0+          mFrom = M.lookup pid regions+          (gx, gy) = fromMaybe (0, 0) mGrab+          moved = latched || case mFrom of+            Just (Rect px py _ _) ->+              let vx = v2X mouse - (px + gx)+                  vy = v2Y mouse - (py + gy)+               in vx * vx + vy * vy > dragThresholdPx * dragThresholdPx+            Nothing -> False+          ghost = case mFrom of+            Just _+              | moved -> Just (Rect (v2X mouse + 12) (v2Y mouse + 12) 112 28)+            _ -> Nothing+          targetRegions = maybe M.empty (\t -> fst (layoutNode minSize gutter t baseRect)) (treeRemovePane pid tree)+          under =+            [ (q, r)+            | (q, r) <- M.toList targetRegions+            , q /= pid+            , rectHit r mouse+            ]+          zone = case topLevelDropTarget band baseRect mouse of+            Just dt -> dropPreview minSize gutter tree pid baseRect dt+            Nothing -> case under of+              (q, r) : _ ->+                let dt = dropTargetForPane r mouse q+                 in dropPreview minSize gutter tree pid baseRect dt+              [] -> Nothing+       in DragInfo True moved ghost zone++-- | Apply resize / drag transitions, writing to the widget store.+runGestures ::+  (Ui :> es) =>+  GridEnv es ->+  [DividerInfo] ->+  [RenderedPane] ->+  DragInfo ->+  Eff es ()+runGestures env dividers rendered dgi = do+  ctx <- askContext+  inp <- askInput+  let regions = geRegions env+      mouse = inputMousePos inp+      press = inputMousePressed inp+      down = inputMouseDown inp+      drag0 = geDrag0 env+      busy = drag0 /= 0+      -- diBand already spans spacing + both leeway margins. Inflating it+      -- again steals presses from the neighboring pane, especially headers.+      hitDiv =+        find+          (\d -> rectHit (diBand d) mouse)+          dividers+      -- The pane whose pick rect (or, when 'pvDraggable', whole region) is+      -- under the pointer.+      pickHit =+        listToMaybe+          [ p+          | pane <- rendered+          , let p = rpPaneId pane+                v = rpView pane+          , maybe False (`rectHit` mouse) (pvDragPick v)+              || (pvDraggable v && maybe False (`rectHit` mouse) (M.lookup p regions))+          ]+      gestK = slotKey SlotPaneGest (geKey env)+      grabK = slotKey SlotPaneGrab (geKey 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 d ->+        storeWrite env True $ \st -> 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)+          }+      Nothing ->+        forM_ pickHit $ \pid -> do+          let title = maybe "" (pvTitle . rpView) (find ((== pid) . rpPaneId) rendered)+              (gx, gy) = maybe (0, 0) (\(Rect px py _ _) -> (v2X mouse - px, v2Y mouse - py)) (M.lookup pid regions)+          storeWrite env True $ \st -> 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 = fromIntegral (negate drag0)+    forM_ (find ((== sid) . diSplitId) dividers) $ \d -> do+      st <- uiIO (getStore 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 = mainLen (diAxis d) (diRegion d) - geGutter env+          r0 =+            if usable <= 0+              then ratio0+              else ratio0 + (mouseMain d mouse - main0) / usable+          r' = clampTreeRatio (geTree env) sid (diRegion d) (geGutter env) (geMinSize env) 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 $ \st -> 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 = fromIntegral drag0+        dropped+          | dgiMoved dgi = dgiZone dgi >>= \(_, dt) -> treeMovePane moved (geSeed env) dt (geTree env)+          | otherwise = Nothing+    storeWrite env True $ \st -> case dropped of+      Nothing -> st {storeInt = IM.delete gestK (storeInt st)}+      Just t' ->+        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 d mouse = case diAxis d of+  AxisV -> v2X mouse+  AxisH -> v2Y mouse++-- -----------------------------------------------------------------------------+-- Keyboard navigation+-- -----------------------------------------------------------------------------++moveFocus ::+  (Ui :> es) =>+  GridEnv es ->+  Word64 ->+  (Float, Float) ->+  Eff es ()+moveFocus env cur dir =+  case neighborPane (geRegions env) cur dir of+    Just pid -> putPaneSlot False SlotPaneFocus env pid+    Nothing -> pure ()++neighborPane :: Map Word64 Rect -> Word64 -> (Float, Float) -> Maybe Word64+neighborPane regions cur (dx, dy) =+  case M.lookup cur regions of+    Nothing -> Nothing+    Just curR ->+      let (cx, cy) = centerOf curR+          scored =+            [ (pid, s)+            | (pid, r) <- M.toList regions+            , pid /= cur+            , rectNonEmpty r+            , let (px, py) = centerOf r+                  vx = px - cx+                  vy = py - cy+                  dotv = vx * dx + vy * dy+            , dotv > 0+            , let s = abs (vx * dy - vy * dx) / dotv+            ]+       in case scored of+            [] -> Nothing+            _ -> Just (fst (minimumBy (comparing snd) scored))++centerOf :: Rect -> (Float, Float)+centerOf r = (rectX r + rectW r / 2, rectY r + rectH r / 2)++-- -----------------------------------------------------------------------------+-- Store mutation helpers+-- -----------------------------------------------------------------------------++splitPane :: (Ui :> es) => GridEnv es -> Word64 -> GridAxis -> Eff es Word64+splitPane env pid axis = do+  let splitId = geSeed env+      newPane = geSeed env + 1+  putTree env (Just (treeSplit pid splitId axis False newPane (geTree env)))+  putSeed env (geSeed env + 2)+  putPaneSlot False SlotPaneFocus env newPane+  pure newPane++closePane :: (Ui :> es) => GridEnv es -> Word64 -> Eff es ()+closePane env pid =+  case treeRemovePane pid (geTree env) of+    Nothing -> putTree env Nothing+    Just t' -> do+      putTree env (Just t')+      when (geMax env == pid) (putPaneSlot True SlotPaneMax env 0)++maximizePane :: (Ui :> es) => GridEnv es -> Word64 -> Eff es ()+maximizePane env pid = do+  let v = if geMax env == pid then 0 else pid+  putPaneSlot True SlotPaneMax env 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.+  when (v /= 0) (writeGest env 0)++restorePane :: (Ui :> es) => GridEnv es -> Eff es ()+restorePane env = putPaneSlot True SlotPaneMax env 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 env mirror f =+  uiIO $ modifyStore (geCtx env) ((if mirror then bumpMirror else id) . f)++-- | Flag 'pgrChanged' for this frame.+markChanged :: (Ui :> es) => GridEnv es -> Eff es ()+markChanged env = uiIO (writeIORef (geChangedRef env) 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 env mTree = do+  storeWrite env True $ \st ->+    st {storeDyn = maybe (IM.delete k) (IM.insert k . toDyn) mTree (storeDyn st)}+  markChanged env+  where+    k = geKey env++-- | Gesture slot: 0 none, positive = dragged pane id, negative = resized+-- split id.+writeGest :: (Ui :> es) => GridEnv es -> Int -> Eff es ()+writeGest env n =+  storeWrite env True $ \st ->+    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 structural slot env v = do+  let k = slotKey slot (geKey env)+      n = fromIntegral v+  st <- uiIO (getStore (geCtx env))+  when (IM.findWithDefault 0 k (storeInt st) /= n) $ do+    storeWrite env True (\st' -> 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 env v =+  storeWrite env False $ \st ->+    st {storeInt = IM.insert (slotKey SlotPaneNext (geKey env)) (fromIntegral v) (storeInt st)}
+ lib/NanoUI/Widgets/Popup.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Popup+  ( PopupAnchor (..)+  , PopupPlacement (..)+  , PopupConfig (..)+  , defaultPopupConfig+  , popup+  , popupWith+  , floatingOverlay+  , tooltipWidget+  , tooltipAt+  , tooltip+  , withTooltip+  )+where++import Control.Monad (void)+import Data.IORef (modifyIORef')+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , getPrevRect+  , registerPopupConfig+  , seedFloatingPanel+  )+import NanoUI.Id (WidgetId, enterScope, scopeTag)+import NanoUI.Input (inputMousePos)+import NanoUI.Layout.Arena (NodeIdx, NodeType (..), addNode)+import NanoUI.Monad+  ( Ui+  , askContext+  , askDefaultLayout+  , askInput+  , nextId+  , uiIO+  )+import NanoUI.Style+  ( AlignX (..)+  , AlignY (..)+  , Layout (..)+  , Padding (..)+  , defaultLayout+  , tight+  )+import NanoUI.Types+  ( PopupAnchor (..)+  , PopupPlacement (..)+  , Rect (..)+  , rectHit+  , rectNonEmpty+  )+import NanoUI.Widgets.Behavior (useDismissable)+import NanoUI.Widgets.Layout (label)+import NanoUI.Widgets.Node+  ( HasResponse+  , Response (..)+  , containerResponse+  , emptyModalResp+  , floatingPanel+  , mkResponse+  , respHovered+  , respRect+  )++data PopupConfig = PopupConfig+  { cfgAnchor :: !PopupAnchor+  , cfgPlacement :: !PopupPlacement+  , cfgDismissable :: !Bool+  , cfgOffset :: !Float+  }+  deriving (Eq, Show)++defaultPopupConfig :: PopupAnchor -> PopupConfig+defaultPopupConfig anchor =+  PopupConfig+    { cfgAnchor = anchor+    , cfgPlacement = PlacementAuto+    , cfgDismissable = True+    , cfgOffset = 4+    }++-- | A floating panel placed by the config, shown while @open@. Returns the+-- body's result while open. The 'Response' reports a dismissal (Escape, or a+-- click outside when 'cfgDismissable') as a click.+popup ::+  Ui :> es =>+  Bool ->+  PopupConfig ->+  Eff es a ->+  Eff es (Response, Maybe a)+popup open cfg child = popupWith open cfg id child++-- | 'popup' with a modifier applied to its tight default layout.+popupWith ::+  Ui :> es =>+  Bool ->+  PopupConfig ->+  (Layout -> Layout) ->+  Eff es a ->+  Eff es (Response, Maybe a)+popupWith open cfg f child = do+  ctx <- askContext+  let+    layout = f (tight defaultLayout)+    addPopupNode wid parent = do+      registerPopupConfig ctx wid (cfgAnchor cfg) (cfgPlacement cfg) (cfgOffset cfg)+      addNode+        (ctxNodeArena ctx)+        NodePopup+        parent+        (layoutDirection layout)+        (layoutWidth layout)+        (layoutHeight layout)+        (Padding 6 6 6 6)+        4+        0+        0+        1e9+        1e9+        0+        AlignStart+        AlignTop+    seedFromPrev wid = getPrevRect ctx wid >>= mapM_ (seedFloatingPanel ctx wid)+  floatingOverlay open (cfgDismissable cfg) addPopupNode seedFromPrev ((,) False <$> child)++-- | The floating panel behind popups, modals and windows, shown while @open@+-- with its body in its own id scope. @addPanel@ and @enter@ are those of+-- 'floatingPanel', given the panel's id. The body returns whether it closed+-- the panel along with its result. The 'Response' reports a dismissal (the+-- body's close, Escape, or a click outside when @dismissable@) as a click. A+-- closed panel still consumes its id scope, so the ids of later siblings do+-- not shift when it opens.+floatingOverlay ::+  Ui :> es =>+  Bool ->+  Bool ->+  (WidgetId -> Int -> IO NodeIdx) ->+  (WidgetId -> IO ()) ->+  Eff es (Bool, a) ->+  Eff es (Response, Maybe a)+floatingOverlay open dismissable addPanel enter body = do+  wid <- nextId+  ctx <- askContext+  if not open+    then do+      uiIO (modifyIORef' (ctxIdContext ctx) (fst . enterScope scopeTag))+      pure (emptyModalResp wid, Nothing)+    else do+      inp <- askInput+      (closed, r) <- floatingPanel True wid (addPanel wid) (enter wid) body+      panel <- fromMaybe (Rect 0 0 0 0) <$> uiIO (getPrevRect ctx wid)+      outside <-+        if dismissable && rectNonEmpty panel+          then useDismissable panel+          else pure False+      let dismissed = closed || outside+      pure+        ( mkResponse wid panel (rectHit panel (inputMousePos inp)) False dismissed dismissed+        , Just r+        )++-- | Attach a rich tooltip widget to any target response, displayed on hover.+tooltipWidget ::+  (Ui :> es, HasResponse r) =>+  r ->+  Eff es a ->+  Eff es (Maybe a)+tooltipWidget target child =+  snd <$> popup (respHovered target) cfg child+  where+    cfg = (defaultPopupConfig (AnchorRect (respRect target))) {cfgPlacement = PlacementBelow, cfgDismissable = False}++-- | Attach a rich tooltip widget to an inner UI computation.+withTooltip ::+  Ui :> es =>+  Eff es a ->+  Eff es b ->+  Eff es (a, Maybe b)+withTooltip mainChild tipChild = do+  base <- askDefaultLayout+  (res, contResp) <- containerResponse NodeContainer (tight base) mainChild+  mTip <- tooltipWidget contResp tipChild+  pure (res, mTip)++-- | 'tooltip' with a placement.+tooltipAt ::+  (Ui :> es, HasResponse r) =>+  PopupPlacement ->+  r ->+  Text ->+  Eff es ()+tooltipAt placement target txt =+  void (popup (respHovered target) cfg (label txt))+  where+    cfg = (defaultPopupConfig (AnchorRect (respRect target))) {cfgPlacement = placement, cfgDismissable = False}++-- | Text shown below a widget while the pointer is over it.+--+-- @+-- save <- button' "Save"+-- tooltip save "Write the file to disk"+-- @+tooltip ::+  (Ui :> es, HasResponse r) =>+  r ->+  Text ->+  Eff es ()+tooltip = tooltipAt PlacementBelow
+ lib/NanoUI/Widgets/Radio.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Radio+  ( radio+  , radio'+  , boundedRadio+  , boundedRadio'+  , enumRadio+  , enumRadio'+  )+where++import Control.Monad (foldM)+import Data.Foldable (toList)+import Data.Hashable (hash)+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import NanoUI.Context (adoptStoreInt, intKey, recordStoreInt, registerFocusable, writeStoreInt)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, nextId, uiIO, withKey)+import NanoUI.Style (Layout, defaultLayout, fillW, gap, tight)+import NanoUI.Types (clamp)+import NanoUI.Widgets.Behavior (KeyNav (..), useKeyNav)+import NanoUI.Widgets.Combinators (selectableItem, withBoundedIndex)+import NanoUI.Widgets.Layout (column')+import NanoUI.Widgets.Node+  ( Response (..)+  , setChanged+  , tagContainer+  )++radioLay :: Layout+radioLay = tight (fillW defaultLayout)++radioGroupLay :: Layout+radioGroupLay = tight (gap 4 (fillW defaultLayout))++radioSalt :: Int+radioSalt = hash ("radio" :: Text)++-- | A column of radio buttons over @options@ in fold order. Pass the selected+-- index; the result is the index after this frame's click or arrow keys.+{-# INLINE radio #-}+radio :: (Foldable f, Ui :> es) => f Text -> Int -> Eff es Int+radio options index = snd <$> radio' options index++radio' ::+  (Foldable f, Ui :> es) => f Text -> Int -> Eff es (Response, Int)+radio' options index =+  withKey radioSalt $ do+    gid <- nextId+    ctx <- askContext+    let+      opts = case toList options of+        [] -> [""]+        xs -> xs+      !len = length opts+      !key = intKey gid+    stored <- uiIO $ adoptStoreInt ctx gid key (clamp 0 (len - 1) index)+    let !sel = clamp 0 (len - 1) stored+    uiIO $ registerFocusable ctx gid+    nav <- useKeyNav gid+    let+      !navDelta =+        (if knDown nav || knRight nav then 1 else 0 :: Int)+          - (if knUp nav || knLeft nav then 1 else 0)+      !selNav = if navDelta == 0 then sel else clamp 0 (len - 1) (sel + navDelta)+    column' radioGroupLay $ do+      tagContainer gid+      (combinedResp, clickedIdx) <- addRadioOptions selNav opts+      let !finalSel = if clickedIdx >= 0 then clickedIdx else selNav+      uiIO $ do+        writeStoreInt ctx gid key finalSel+        recordStoreInt ctx key finalSel+      -- Compare with the caller's index, as 'NanoUI.Widgets.Select' does, so a+      -- selection stored between frames still reports a change.+      pure (setChanged (finalSel /= clamp 0 (len - 1) index) combinedResp, finalSel)++-- Use the ordinary widget path for every option, including singleton groups.+-- It owns IDs, node construction, and scroll-aware interaction geometry.+addRadioOptions :: Ui :> es => Int -> [Text] -> Eff es (Response, Int)+addRadioOptions sel opts = foldM addOption (mempty, -1) (zip [0 ..] opts)+ where+  addOption (!acc, !clickedIdx) (i, txt) = do+    r <- selectableItem NodeRadio txt (sel == i) radioLay i+    let+      clickedIdx' = if rawRespClicked r && clickedIdx < 0 then i else clickedIdx+    pure (acc <> r, clickedIdx')++-- | Radio buttons for every value of a bounded enum, labelled by @encode@.+{-# INLINE boundedRadio #-}+boundedRadio :: (Bounded a, Enum a, Ui :> es) => (a -> Text) -> a -> Eff es a+boundedRadio encode value = snd <$> boundedRadio' encode value++boundedRadio' :: (Bounded a, Enum a, Ui :> es) => (a -> Text) -> a -> Eff es (Response, a)+boundedRadio' encode value = withBoundedIndex encode value radio'++-- | 'boundedRadio' labelled with 'show'.+{-# INLINE enumRadio #-}+enumRadio :: (Bounded a, Enum a, Show a, Ui :> es) => a -> Eff es a+enumRadio = boundedRadio (T.pack . show)++enumRadio' :: (Bounded a, Enum a, Show a, Ui :> es) => a -> Eff es (Response, a)+enumRadio' = boundedRadio' (T.pack . show)
+ lib/NanoUI/Widgets/RichText.hs view
@@ -0,0 +1,339 @@+-- | Paragraphs of mixed-style text and links.+module NanoUI.Widgets.RichText+  ( Inline+  , inlineText+  , inlineWith+  , restyle+  , strong+  , emphasis+  , inlineCode+  , hyperlink+  , richText+  , richText'+  , richTextWith+  , richTextWith'+  ) where++import Control.Monad (unless)+import Data.Hashable (hashWithSalt)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.IntMap.Strict qualified as IM+import Data.List (dropWhileEnd, groupBy)+import Data.Maybe (fromMaybe, isJust)+import Data.Primitive.SmallArray (SmallArray, indexSmallArray, smallArrayFromList)+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , askHostIO+  , intKey+  , setHost+  , registerCustomCursor+  , registerCustomDrawing+  , registerCustomMeasure+  )+import NanoUI.Draw (DrawOp (..), TextFont (..))+import NanoUI.Font (FontMetrics (..), lineWidthIO)+import NanoUI.Frame.Node (resolveTextFont)+import NanoUI.Input (Input (..), UiCursorKind (..))+import NanoUI.Layout.Arena (NodeType (NodeDrawing))+import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, uiIO, uiTheme)+import NanoUI.Style+  ( FontVariant (..)+  , Layout (..)+  , TextDecoration (..)+  , Theme (..)+  , fontBold+  , fontItalic+  , fontMono+  , styleFg+  )+import NanoUI.Types (Color (..), Rect (..), V2 (..))+import NanoUI.Widgets.Node (Response, addWidget, respClicked, respHovered, respRect)++-- | A piece of a paragraph: text in one style, and the hyperlink it follows when+-- it is one. A string literal is 'plain' text.+data Inline = Inline !Text (Layout -> Layout) !(Maybe Text)++instance IsString Inline where+  fromString = inlineText . T.pack++-- | Text in the paragraph's own style.+inlineText :: Text -> Inline+inlineText txt = Inline txt id Nothing++-- | Text styled by font modifiers (@fontBold@, @fontSize 20@,+-- @fontColor red . fontUnderline@), applied over the paragraph's layout.+inlineWith :: (Layout -> Layout) -> Text -> Inline+inlineWith f txt = Inline txt f Nothing++-- | Add font modifiers to a piece, a hyperlink included.+restyle :: (Layout -> Layout) -> Inline -> Inline+restyle f (Inline txt style target) = Inline txt (f . style) target++-- | Bold text.+strong :: Text -> Inline+strong = inlineWith fontBold++-- | Italic text.+emphasis :: Text -> Inline+emphasis = inlineWith fontItalic++-- | Monospaced text.+inlineCode :: Text -> Inline+inlineCode = inlineWith fontMono++-- | @hyperlink target label@: text in the theme's link colour, underlined while+-- hovered, whose click the paragraph reports as @target@.+hyperlink :: Text -> Text -> Inline+hyperlink target label = Inline label id (Just target)++-- | A paragraph of pieces, wrapped at its width. Returns the target of the+-- hyperlink clicked this frame.+richText :: Ui :> es => [Inline] -> Eff es (Maybe Text)+richText = richTextWith id++-- | 'richText' with a layout modifier, whose font choices are the default+-- for every piece.+richTextWith :: Ui :> es => (Layout -> Layout) -> [Inline] -> Eff es (Maybe Text)+richTextWith f pieces = snd <$> richTextWith' f pieces++richText' :: Ui :> es => [Inline] -> Eff es (Response, Maybe Text)+richText' = richTextWith' id++-- A resolved piece: its font, colour, line metrics and hyperlink.+data Run = Run+  { runFont :: !TextFont+  , runColor :: !Color+  , runLineHeight :: !Float+  , runAscent :: !Float+  , runTarget :: !(Maybe Text)+  }++data TokenKind = Word | Space | Break+  deriving (Eq)++-- A word, a run of spaces or a line break, with its width in its piece's font.+data Token = Token+  { _tokenText :: !Text+  , tokenRun :: !Int+  , tokenKind :: !TokenKind+  , tokenWidth :: !Float+  }++-- A laid-out line: its top, height and baseline offset, and its tokens with+-- their x positions.+data Line = Line+  { lineTop :: !Float+  , lineHeight :: !Float+  , lineAscent :: !Float+  , lineWidth :: !Float+  , lineTokens :: ![(Float, Token)]+  }++-- A paragraph's measured pieces and its lines at the width it last had,+-- kept between frames while its pieces, fonts and colours stay the same.+data Paragraph = Paragraph+  { paraKey :: !Int+  , paraRuns :: !(SmallArray Run)+  , paraTokens :: ![Token]+  , paraEmptyLine :: !(Float, Float)+  , paraNatural :: (Float, Float)+  , paraWidth :: !Float+  , paraLines :: [Line]+  }++newtype Paragraphs = Paragraphs (IORef (IM.IntMap Paragraph))++richTextWith' :: Ui :> es => (Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)+richTextWith' f pieces = do+  ctx <- askContext+  inp <- askInput+  base <- f <$> askDefaultLayout+  theme <- uiTheme+  wid <- nextId+  let styled = [(txt, pieceFont l, pieceColor theme l target, target) | Inline txt style target <- pieces, let l = style base]+  cacheRef <-+    uiIO $+      askHostIO ctx >>= \case+        Just (Paragraphs ref) -> pure ref+        Nothing -> do+          ref <- newIORef IM.empty+          setHost ctx (Paragraphs ref)+          pure ref+  gen <- uiIO (readIORef (ctxMetricGen ctx))+  let key =+        foldl'+          ( \h (txt, TextFont size variant weight fstyle deco, Color rgba, target) ->+              h `hashWithSalt` txt `hashWithSalt` size `hashWithSalt` fromEnum variant+                `hashWithSalt` fromEnum weight `hashWithSalt` fromEnum fstyle `hashWithSalt` fromEnum deco+                `hashWithSalt` rgba `hashWithSalt` target+          )+          gen+          styled+  cached <- uiIO (IM.lookup (intKey wid) <$> readIORef cacheRef)+  para0 <- case cached of+    Just para | paraKey para == key -> pure para+    _ -> uiIO $ do+      resolved <- mapM (measurePiece ctx) (zip [0 ..] styled)+      let runs = smallArrayFromList (map fst resolved)+          tokens = concatMap snd resolved+          emptyLine = case resolved of+            (run, _) : _ -> (runLineHeight run, runAscent run)+            [] -> (fmLineHeight (ctxFontMetrics ctx), fmAscent (ctxFontMetrics ctx))+      pure (Paragraph key runs tokens emptyLine (lineBoxes (layoutLines runs emptyLine 1e9 tokens)) (-1) [])+  resp <- addWidget wid NodeDrawing T.empty 0 base+  let Rect rx ry rw _ = respRect resp+      runs = paraRuns para0+      layoutAt width = layoutLines runs (paraEmptyLine para0) width (paraTokens para0)+      para+        | paraWidth para0 == rw = para0+        | otherwise = para0 {paraWidth = rw, paraLines = layoutAt rw}+      linesAt width+        | width == paraWidth para = paraLines para+        | otherwise = layoutAt width+      V2 mx my = inputMousePos inp+      hoveredRun+        | not (respHovered resp) = Nothing+        | otherwise =+            case [ tokenRun tok+                 | line <- paraLines para+                 , my >= ry + lineTop line && my < ry + lineTop line + lineHeight line+                 , (x, tok) <- lineTokens line+                 , tokenKind tok /= Break+                 , mx >= rx + x && mx < rx + x + tokenWidth tok+                 , isJust (runTarget (indexSmallArray runs (tokenRun tok)))+                 ] of+              run : _ -> Just run+              [] -> Nothing+      -- Words are drawn one by one, so a decoration is drawn once across a+      -- piece's words on a line and the spaces between them.+      draw _cdc (Rect x0 y0 w _) =+        smallArrayFromList $+          concat+            [ [ DrawTextStyled (x0 + x) (lineY line run) ((runFont run) {textFontDecoration = DecorationNone}) txt (runColor run)+              | (x, Token txt runIdx Word _) <- lineTokens line+              , let run = indexSmallArray runs runIdx+              ]+                ++ concat+                  [ [FillRect (Rect (x0 + x1) (y + offset) (x2 - x1) thick) (runColor run) | offset <- decorationOffsets deco run]+                  | group <- groupBy (\(_, a) (_, b) -> tokenRun a == tokenRun b) (lineTokens line)+                  , let trimmed = dropWhileEnd isSpaceToken (dropWhile isSpaceToken group)+                  , (x1, first) : _ <- [trimmed]+                  , let runIdx = tokenRun first+                        run = indexSmallArray runs runIdx+                        deco = decorationOf runIdx+                        (lastX, lastTok) = last trimmed+                        x2 = lastX + tokenWidth lastTok+                        y = lineY line run+                        thick = max 1 (0.06 * runLineHeight run)+                  , deco /= DecorationNone+                  ]+            | line <- linesAt w+            ]+        where+          lineY line run = y0 + lineTop line + lineAscent line - runAscent run+          isSpaceToken (_, tok) = tokenKind tok == Space+      decorationOf runIdx+        | Just runIdx == hoveredRun = underlined (textFontDecoration (runFont (indexSmallArray runs runIdx)))+        | otherwise = textFontDecoration (runFont (indexSmallArray runs runIdx))+      -- Where underline and strikethrough sit below a line box's top, as+      -- styled labels draw them.+      decorationOffsets deco run =+        let lh = runLineHeight run+            under = runAscent run + max 1 (0.1 * lh)+            strike = runAscent run * 0.65+         in case deco of+              DecorationUnderline -> [under]+              DecorationStrikethrough -> [strike]+              DecorationUnderlineStrike -> [under, strike]+              DecorationNone -> []+      drawKey = key `hashWithSalt` fromMaybe (-1) hoveredRun+  uiIO $ do+    unless (paraWidth para0 == rw && fmap paraKey cached == Just key) $+      modifyIORef' cacheRef $ \m ->+        -- Paragraphs no longer drawn are dropped all at once past a bound.+        IM.insert (intKey wid) para (if IM.size m > 4096 then IM.empty else m)+    registerCustomMeasure ctx wid $ \_ (availW, _) ->+      if availW >= 1e9 then paraNatural para else lineBoxes (linesAt availW)+    registerCustomDrawing ctx wid (if drawKey == 0 then 1 else drawKey) draw+    registerCustomCursor ctx wid (const (if isJust hoveredRun then UiCursorPointer else UiCursorDefault))+  let clicked+        | respClicked resp = hoveredRun >>= runTarget . indexSmallArray runs+        | otherwise = Nothing+  pure (resp, clicked)+  where+    underlined DecorationStrikethrough = DecorationUnderlineStrike+    underlined DecorationNone = DecorationUnderline+    underlined deco = deco+    lineBoxes lines' = (maximum (0 : map lineWidth lines'), sum (map lineHeight lines'))++-- | The font a piece's layout chooses.+pieceFont :: Layout -> TextFont+pieceFont l = TextFont (layoutFontSize l) (layoutFontVariant l) (layoutFontWeight l) (layoutFontStyle l) (layoutTextDecoration l)++-- | A piece's colour: its own, else the link colour for a link, else its+-- font variant's colour.+pieceColor :: Theme -> Layout -> Maybe Text -> Color+pieceColor theme l target =+  let variantColor = case layoutFontVariant l of+        FontHeading -> themeAccent theme+        FontMuted -> themeMuted theme+        FontDanger -> themeRed theme+        _ -> styleFg (themePanel theme)+   in fromMaybe (maybe variantColor (const (themeLink theme)) target) (layoutFontColor l)++-- | A piece's line metrics and its tokens measured in its font.+measurePiece :: Context -> (Int, (Text, TextFont, Color, Maybe Text)) -> IO (Run, [Token])+measurePiece ctx (i, (txt, font, color, target)) = do+  (fm, _) <- resolveTextFont ctx font+  tokens <- mapM (measure fm) (T.groupBy (\a b -> kindOf a == kindOf b && kindOf a /= Break) txt)+  pure (Run font color (fmLineHeight fm) (fmAscent fm) target, tokens)+  where+    kindOf c+      | c == '\n' = Break+      | c == ' ' || c == '\t' = Space+      | otherwise = Word+    measure fm part = do+      let kind = kindOf (T.head part)+      w <- if kind == Break then pure 0 else lineWidthIO fm part+      pure (Token part i kind w)++-- | Greedy lines at @width@: a break goes between words only at spaces or+-- line breaks, spaces at a wrap are dropped, and a word wider than the line+-- takes a line of its own.+layoutLines :: SmallArray Run -> (Float, Float) -> Float -> [Token] -> [Line]+layoutLines runs (emptyH, emptyAscent) width = go 0 [] 0 [] True+  where+    -- @placed@ holds the line's tokens in reverse, @pending@ the spaces since+    -- its last word; @fresh@ whether the line starts after a wrap.+    go top placed x pending fresh toks = case toks of+      [] -> [finish top placed x]+      tok : rest -> case tokenKind tok of+        Break -> let line = finish top placed x in line : go (top + lineHeight line) [] 0 [] False rest+        Space -> go top placed x (tok : pending) fresh rest+        Word ->+          let (word, rest') = span (\t -> tokenKind t == Word) toks+              wordW = sum (map tokenWidth word)+              spaceW = if null placed && fresh then 0 else sum (map tokenWidth pending)+           in if not (null placed) && x + spaceW + wordW > width+                then+                  let line = finish top placed x+                   in line : go (top + lineHeight line) [] 0 [] True toks+                else+                  let (placed', x') = foldl' place (placed, x) (if null placed && fresh then [] else reverse pending)+                      (placed'', x'') = foldl' place (placed', x') word+                   in go top placed'' x'' [] False rest'+    place (acc, x) tok = ((x, tok) : acc, x + tokenWidth tok)+    finish top placed x =+      let toks = reverse placed+          metrics = [indexSmallArray runs (tokenRun tok) | (_, tok) <- toks]+          (h, ascent) = case metrics of+            [] -> (emptyH, emptyAscent)+            _ ->+              let ascent' = maximum (map runAscent metrics)+                  descent = maximum [runLineHeight r - runAscent r | r <- metrics]+               in (ascent' + descent, ascent')+       in Line top h ascent x toks
+ lib/NanoUI/Widgets/Select.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Dropdown select.+module NanoUI.Widgets.Select+  ( select+  , select'+  , selectWith+  , selectWith'+  , boundedSelect+  , boundedSelect'+  , enumSelect+  , enumSelect'+  )+where++import Control.Monad (forM_, when)+import Data.IORef (writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , adoptStoreInt+  , getStore+  , intKey+  , recordStoreInt+  , registerFocusable+  , modifyStore+  )+import NanoUI.Font (menuItemRowH)+import NanoUI.Frame.Select (selectDropPickIndex, selectDropRect)+import NanoUI.Input (inputMousePos, inputMousePressed, inputMouseReleased)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)+import NanoUI.Store (WidgetStore (..), isSelectOpen, setSelectOpen)+import NanoUI.Style (Layout, defaultLayout)+import NanoUI.Types (Rect (..), clamp, rectContains, rectHit, rectNonEmpty, v2Y)+import NanoUI.Widgets.Combinators (withBoundedIndex)+import NanoUI.Widgets.Node (Response, addWidgetWithOptions, respRect, setChanged)++-- | Dropdown over @options@ in fold order. Pass the selected index; the result+-- is the index after this frame's pick.+{-# INLINE select #-}+select :: (Foldable f, Ui :> es) => f Text -> Int -> Eff es Int+select options index = snd <$> selectWith' id options index++{-# INLINE select' #-}+select' :: (Foldable f, Ui :> es) => f Text -> Int -> Eff es (Response, Int)+select' = selectWith' id++-- | 'select' with a layout modifier.+{-# INLINE selectWith #-}+selectWith :: (Foldable f, Ui :> es) => (Layout -> Layout) -> f Text -> Int -> Eff es Int+selectWith f options index = snd <$> selectWith' f options index++selectWith' ::+  (Foldable f, Ui :> es) =>+  (Layout -> Layout) ->+  f Text ->+  Int ->+  Eff es (Response, Int)+selectWith' f options index = do+  wid <- nextId+  ctx <- askContext+  uiIO $ registerFocusable ctx wid+  let+    opts = case foldr (:) [] options of+      [] -> [""]+      xs -> xs+    n = length opts+    key = intKey wid+  stored <- uiIO $ adoptStoreInt ctx wid key (clamp 0 (n - 1) index)+  store0 <- uiIO (getStore ctx)+  let+    current = clamp 0 (n - 1) stored+    open = isSelectOpen store0 key+  resp <- addWidgetWithOptions wid NodeSelect "" opts 0 (f defaultLayout)+  inp <- askInput+  let+    rect@(Rect rx ry rw rh) = respRect resp+    mouse = inputMousePos inp+    dropRect = selectDropRect rx ry rw rh n+    picked+      | open && rectNonEmpty rect && rectContains dropRect mouse && inputMouseReleased inp =+          selectDropPickIndex dropRect menuItemRowH n (v2Y mouse)+      | otherwise = Nothing+    finalIdx = maybe current (clamp 0 (n - 1)) picked+  -- Opening, closing or picking changes the store, which wakes the loop.+  uiIO $ do+    when (rectHit rect mouse && inputMousePressed inp) $ do+      modifyStore ctx (\st -> setSelectOpen st key (not open))+      writeIORef (ctxFocusId ctx) wid+    forM_ picked $ \i -> do+      modifyStore ctx (\st -> setSelectOpen (st {storeInt = IM.insert key i (storeInt st)}) key False)+      writeIORef (ctxFocusId ctx) wid+    recordStoreInt ctx key finalIdx+  -- Compare with the caller's index, not 'current': a dropdown or keyboard+  -- pick lands in the store between frames and must still report a change.+  pure (setChanged (finalIdx /= clamp 0 (n - 1) index) resp, finalIdx)++-- | Select over every value of a bounded enum, labelled by @encode@.+{-# INLINE boundedSelect #-}+boundedSelect :: (Bounded a, Enum a, Ui :> es) => (a -> Text) -> a -> Eff es a+boundedSelect encode value = snd <$> boundedSelect' encode value++boundedSelect' :: (Bounded a, Enum a, Ui :> es) => (a -> Text) -> a -> Eff es (Response, a)+boundedSelect' encode value = withBoundedIndex encode value select'++-- | 'boundedSelect' labelled with 'show'.+{-# INLINE enumSelect #-}+enumSelect :: (Bounded a, Enum a, Show a, Ui :> es) => a -> Eff es a+enumSelect = boundedSelect (T.pack . show)++enumSelect' :: (Bounded a, Enum a, Show a, Ui :> es) => a -> Eff es (Response, a)+enumSelect' = boundedSelect' (T.pack . show)
+ lib/NanoUI/Widgets/Slider.hs view
@@ -0,0 +1,101 @@+-- | Horizontal slider control.+module NanoUI.Widgets.Slider+  ( slider+  , slider'+  , sliderWith+  , sliderWith'+  )+where++import Control.Monad (when)+import Data.IORef (readIORef, writeIORef)+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , adoptStoreFloat+  , intKey+  , recordStoreFloat+  , registerFocusable+  , writeStoreFloat+  , getsOverlay+  , OverlayState (..)+  )+import NanoUI.Font (sliderHandleSlack, sliderTrackBounds)+import NanoUI.Frame.Hit (scrollHitRect)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (inputMouseDown, inputMousePressed)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)+import NanoUI.Style (Layout, defaultLayout, fillW)+import NanoUI.Types (Rect (..), clamp)+import NanoUI.Widgets.Behavior (DragAxis (..), KeyNav (..), useDrag1D, useKeyNav)+import NanoUI.Widgets.Node (Response, addWidget, setChanged)++-- | Slider over @[minV, maxV]@ that fills the available width. Pass the+-- current value; the result is the value after this frame's drag or arrow+-- keys.+{-# INLINE slider #-}+slider :: Ui :> es => Float -> Float -> Float -> Eff es Float+slider minV maxV value = snd <$> sliderWith' id minV maxV value++{-# INLINE slider' #-}+slider' :: Ui :> es => Float -> Float -> Float -> Eff es (Response, Float)+slider' = sliderWith' id++-- | 'slider' with a layout modifier.+--+-- @+-- volume' <- sliderWith (fixedW 200) 0 100 volume+-- @+{-# INLINE sliderWith #-}+sliderWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Float -> Eff es Float+sliderWith f minV maxV value = snd <$> sliderWith' f minV maxV value++sliderWith' ::+  Ui :> es =>+  (Layout -> Layout) -> Float -> Float -> Float -> Eff es (Response, Float)+sliderWith' f minV maxV value = do+  wid <- nextId+  ctx <- askContext+  inp <- askInput+  uiIO $ registerFocusable ctx wid+  let key = intKey wid+  current <- uiIO $ adoptStoreFloat ctx wid key value+  let+    frac = if maxV > minV then (current - minV) / (maxV - minV) else 0+  resp <- addWidget wid NodeSlider "" frac (f (fillW defaultLayout))+  active <- uiIO (readIORef (ctxActiveId ctx))+  blocked <- uiIO (getsOverlay ctx osLastPointerBlocked)+  mrect <- uiIO (scrollHitRect ctx wid)+  let+    isActive = active == wid+    heldByOther =+      inputMouseDown inp+        && not (inputMousePressed inp)+        && hashWidgetId active /= 0+        && not isActive+    track0 =+      case mrect of+        Just (Rect x y w h) ->+          let tr = sliderTrackBounds x y w h+           in Rect (rectX tr) (rectY tr - sliderHandleSlack) (rectW tr) (rectH tr + 2 * sliderHandleSlack)+        Nothing -> Rect 0 0 0 0+    track = if blocked || heldByOther then Rect 0 0 0 0 else track0+  (dragged, dragging) <- withKey ("drag" :: Text) (useDrag1D DragAxisX minV maxV current track)+  when (dragging && not isActive) $ uiIO $ writeIORef (ctxActiveId ctx) wid+  when ((not dragging || blocked) && isActive) $+    uiIO $ writeIORef (ctxActiveId ctx) (WidgetId 0)+  nav <- useKeyNav wid+  let+    range = maxV - minV+    step = if range > 0 then range / 100 else 0+    navStep =+      (if knRight nav || knUp nav then 1 else 0 :: Int)+        - (if knLeft nav || knDown nav then 1 else 0)+    baseVal = if dragging then dragged else current+    finalVal = clamp minV maxV (baseVal + fromIntegral navStep * step)+  uiIO $ do+    writeStoreFloat ctx wid key finalVal+    recordStoreFloat ctx key finalVal+  pure (setChanged (finalVal /= current) resp, finalVal)
+ lib/NanoUI/Widgets/SplitPane.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE LambdaCase #-}++-- | Pure pane-grid tree model and geometry, modelled on iced's @PaneGrid@.+--+-- A 'GridNode' is a binary split tree of panes. Each split stores an axis+-- ('AxisV' = vertical divider splitting width, 'AxisH' = horizontal divider+-- splitting height), a ratio in @[0,1]@ for the first (A) side, and the two+-- child subtrees. Every pane and split has a globally unique 'Word64' id so+-- pane state can be keyed by pane id regardless of position in the tree.+--+-- All functions here are pure; the interactive wrapper in+-- "NanoUI.Widgets.PaneGrid" persists a 'GridNode' as a "Data.Dynamic" value+-- in the widget store.+module NanoUI.Widgets.SplitPane+  ( GridAxis (..)+  , GridNode (..)+  , PaneDrop (..)+  , treePanes+  , treeSize+  , paneExist+  , subtreeMin+  , mainMins+  , mainLen+  , splitLength+  , layoutNode+  , DividerInfo (..)+  , treeSplit+  , treeSetRatio+  , treeRemovePane+  , treeMovePane+  , clampTreeRatio+  , dropPreview+  , dropTargetForPane+  , topLevelDropTarget+  ) where++import Control.Applicative ((<|>))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Word (Word64)+import NanoUI.Types (Rect (..), V2 (..), clamp, clamp01, rectH, rectNonEmpty, rectW, rectX, rectY)++-- | Divider orientation. 'AxisV' draws a vertical divider (panes left/right),+-- 'AxisH' draws a horizontal divider (panes stacked top/bottom).+data GridAxis = AxisV | AxisH+  deriving (Eq, Ord, Show, Enum, Bounded)++-- | Binary split tree node. Pane and split ids share one monotonic counter.+-- Positional (non-record) so the multi-constructor type keeps total fields.+data GridNode+  = Split+      !Word64+      -- ^ Split id.+      !GridAxis+      -- ^ Orientation of the divider.+      !Float+      -- ^ Ratio in @[0,1]@ for the A side.+      !GridNode+      -- ^ Left / top subtree.+      !GridNode+      -- ^ Right / bottom subtree.+  | Pane+      !Word64+      -- ^ Pane id.+  deriving (Eq, Show)++-- | Result of dropping a dragged pane on a target pane.+data PaneDrop+  = DropSwap Word64+      -- ^ Drop on the center of the pane: the two panes swap places.+  | DropSplit Word64 GridAxis Bool+      -- ^ Drop near an edge: the target pane splits along the axis and the+      -- dragged pane moves into the new child. 'True' puts the dragged pane on+      -- the A (left/top) side, 'False' on the B (right/bottom) side.+  | DropTop GridAxis Bool+      -- ^ Drop on the outer edge of the whole grid: the entire tree is wrapped+      -- in a new top-level split and the dragged pane takes one side, so the+      -- rest of the grid collapses onto the other. 'True' puts the dragged+      -- pane on the A (left/top) side, 'False' on the B (right/bottom) side.+  deriving (Eq, Show)++-- | Fold a tree bottom-up: @onPane@ for each pane id, @onSplit@ for each+-- split (id, axis, ratio) with its already-folded A and B sides. The sides+-- are passed lazily, so a short-circuiting @onSplit@ stops early.+foldGrid :: (Word64 -> r) -> (Word64 -> GridAxis -> Float -> r -> r -> r) -> GridNode -> r+foldGrid onPane onSplit = go+  where+    go (Pane pid) = onPane pid+    go (Split sid axis ratio a b) = onSplit sid axis ratio (go a) (go b)++-- | Pane ids in the tree (depth-first, A then B).+treePanes :: GridNode -> [Word64]+treePanes = foldGrid pure (\_ _ _ a b -> a <> b)++-- | Number of panes.+treeSize :: GridNode -> Int+treeSize = foldGrid (const 1) (\_ _ _ a b -> a + b)++-- | Does a pane with the given id exist?+paneExist :: GridNode -> Word64 -> Bool+paneExist t p = foldGrid (== p) (\_ _ _ a b -> a || b) t++-- | Minimum (width, height) that must be reserved for a subtree under a+-- 'minSize' per-pane floor and 'spacing' between every split level.+subtreeMin :: Float -> Float -> GridNode -> (Float, Float)+subtreeMin minSize spacing = \case+  Pane _ -> (minSize, minSize)+  Split _ axis _ a b ->+    let (wa, ha) = subtreeMin minSize spacing a+        (wb, hb) = subtreeMin minSize spacing b+     in case axis of+          AxisV -> (wa + spacing + wb, max ha hb)+          AxisH -> (max wa wb, ha + spacing + hb)++-- | Extent of a region along a split's main axis.+mainLen :: GridAxis -> Rect -> Float+mainLen AxisV = rectW+mainLen AxisH = rectH++-- | The subtree minima that apply along a split's main axis: widths for+-- 'AxisV' (panes left/right), heights for 'AxisH' (panes stacked).+mainMins :: GridAxis -> (Float, Float) -> (Float, Float) -> (Float, Float)+mainMins AxisV (wa, _) (wb, _) = (wa, wb)+mainMins AxisH (_, ha) (_, hb) = (ha, hb)++-- | A-side extent for a split along its main axis, honouring the subtree+-- minima. The ratio shares out the extent left after the gutter between the+-- sides, so a 0.5 split gives both sides the same length. Falls back to the+-- raw share when the region is too small to satisfy both minima.+splitLength :: Float -> Float -> Float -> Float -> Float -> Float+splitLength spacing avail minA minB ratio+  | avail <= 0 = 0+  | lo <= hi = clamp lo hi share+  | otherwise = clamp 0 avail share+  where+    share = ratio * max 0 (avail - spacing)+    lo = minA+    hi = avail - spacing - minB++-- | Carve a region at offset @d@ along the main axis into (A, B, divider band).+splitBounds :: GridAxis -> Float -> Rect -> Float -> (Rect, Rect, Rect)+splitBounds AxisV spacing r d =+  let avail = rectW r+   in ( r {rectW = d}+      , r {rectX = rectX r + d + spacing, rectW = avail - d - spacing}+      , Rect (rectX r + d) (rectY r) spacing (rectH r)+      )+splitBounds AxisH spacing r d =+  let avail = rectH r+   in ( r {rectH = d}+      , r {rectY = rectY r + d + spacing, rectH = avail - d - spacing}+      , Rect (rectX r) (rectY r + d) (rectW r) spacing+      )++-- | Per-split divider information: the split's own region (where the ratio+-- applies), the exact spacing band, and the axis / ratio / id.+data DividerInfo = DividerInfo+  { diSplitId :: {-# UNPACK #-} !Word64+  , diAxis :: !GridAxis+  , diRegion :: !Rect+  , diBand :: !Rect+  , diRatio :: {-# UNPACK #-} !Float+  }+  deriving (Eq, Show)++-- | Lay out a tree into per-pane regions and divider bands within 'Rect'.+-- Dividers are reported parent-before-child so dragging a divider resizes its+-- immediate subtrees relative to the same region.+layoutNode :: Float -> Float -> GridNode -> Rect -> (Map Word64 Rect, [DividerInfo])+layoutNode minSize spacing sp r =+  case sp of+    Pane pid -> (M.singleton pid r, [])+    Split sid axis ratio0 a b ->+      let (wa, ha) = subtreeMin minSize spacing a+          (wb, hb) = subtreeMin minSize spacing b+          (mA, mB) = mainMins axis (wa, ha) (wb, hb)+          (rA, rB, band) = splitBounds axis spacing r (splitLength spacing (mainLen axis r) mA mB ratio0)+          self = DividerInfo sid axis r band ratio0+          (regionsA, divsA) = layoutNode minSize spacing a rA+          (regionsB, divsB) = layoutNode minSize spacing b rB+       in (M.union regionsA regionsB, self : divsA <> divsB)++-- | Split the pane (first arg) along the axis with a 0.5 ratio, inserting the+-- new pane. 'newOnA' places the new pane on the A (left/top) side of the new+-- split; 'False' puts it on the B (right/bottom) side. Returns the updated+-- tree (unchanged if the pane does not exist).+treeSplit :: Word64 -> Word64 -> GridAxis -> Bool -> Word64 -> GridNode -> GridNode+treeSplit targetPaneId splitId axis newOnA newPaneId = foldGrid onPane Split+  where+    onPane p+      | p /= targetPaneId = Pane p+      | newOnA = Split splitId axis 0.5 (Pane newPaneId) (Pane p)+      | otherwise = Split splitId axis 0.5 (Pane p) (Pane newPaneId)++-- | Set the raw ratio of a split (clamped to @[0,1]@).+treeSetRatio :: Word64 -> Float -> GridNode -> GridNode+treeSetRatio splitId r =+  foldGrid Pane (\sid ax r0 -> Split sid ax (if sid == splitId then clamp01 r else r0))++-- | Remove a pane. The sibling subtree absorbs its space. @Nothing@ if the+-- pane does not exist or removing it would empty the tree.+treeRemovePane :: Word64 -> GridNode -> Maybe GridNode+treeRemovePane pid = foldGrid onPane onSplit+  where+    onPane p = if p == pid then Nothing else Just (Pane p)+    onSplit sid ax r0 ma mb = case (ma, mb) of+      (Just a, Just b) -> Just (Split sid ax r0 a b)+      (Nothing, b) -> b+      (a, Nothing) -> a++-- | Swap two panes by id (content follows the pane id).+treeSwapPanes :: Word64 -> Word64 -> GridNode -> GridNode+treeSwapPanes a b = foldGrid (\p -> Pane (if p == a then b else if p == b then a else p)) Split++-- | Move a pane onto a drop target. Center drops swap the two panes; edge+-- drops split the target pane with the given fresh split id and move the+-- dragged pane into the new child; top-level drops wrap the whole tree in a+-- new root split with the dragged pane on one side.+treeMovePane :: Word64 -> Word64 -> PaneDrop -> GridNode -> Maybe GridNode+treeMovePane moved splitId dt tree+  | not (paneExist tree moved) = Nothing+  | otherwise =+      case dt of+        DropSwap tgt+          | tgt == moved -> Nothing+          | not (paneExist tree tgt) -> Nothing+          | otherwise -> Just (treeSwapPanes moved tgt tree)+        DropSplit tgt axis onA+          | tgt == moved -> Nothing+          | not (paneExist tree tgt) -> Nothing+          | otherwise -> do+              t' <- treeRemovePane moved tree+              Just (treeSplit tgt splitId axis onA moved t')+        DropTop axis onA+          | treeSize tree <= 1 -> Nothing+          | otherwise -> do+              t' <- treeRemovePane moved tree+              Just+                ( if onA+                    then Split splitId axis 0.5 (Pane moved) t'+                    else Split splitId axis 0.5 t' (Pane moved)+                )++-- | Find the split node with a given id (or 'Nothing').+findSplitNode :: GridNode -> Word64 -> Maybe GridNode+findSplitNode (Pane _) _ = Nothing+findSplitNode s@(Split sid0 _ _ a b) target+  | sid0 == target = Just s+  | otherwise = findSplitNode a target <|> findSplitNode b target++-- | Clamp a proposed ratio for a split so both subtrees keep at least their+-- minimum size within the given region.+clampTreeRatio :: GridNode -> Word64 -> Rect -> Float -> Float -> Float -> Float+clampTreeRatio tree splitId region spacing minSize r0 =+  case findSplitNode tree splitId of+    Nothing -> r0+    Just (Pane _) -> r0+    Just (Split _ ax _ a b) ->+      let avail = mainLen ax region+          usable = avail - spacing+       in if usable <= 0+            then r0+            else+              let (wa, ha) = subtreeMin minSize spacing a+                  (wb, hb) = subtreeMin minSize spacing b+                  (mA, mB) = mainMins ax (wa, ha) (wb, hb)+               in splitLength spacing avail mA mB r0 / usable++-- | Which drop zone a pointer falls into for a target pane rect.+data EdgeZone = ZoneCenter | ZoneLeft | ZoneRight | ZoneTop | ZoneBottom++-- | Classify a drop point into a zone of the target pane.+edgeZone :: Rect -> V2 -> EdgeZone+edgeZone r (V2 mx my)+  | not (rectNonEmpty r) = ZoneCenter+  | tx < 0.25 = ZoneLeft+  | tx > 0.75 = ZoneRight+  | ty < 0.25 = ZoneTop+  | ty > 0.75 = ZoneBottom+  | otherwise = ZoneCenter+  where+    tx = (mx - rectX r) / rectW r+    ty = (my - rectY r) / rectH r++-- | Classify a drop point on a target pane into the 'PaneDrop' the drop+-- performs: the pane's center swaps the two panes, an edge zone splits the+-- target along that edge's axis with the dragged pane on the near side.+dropTargetForPane :: Rect -> V2 -> Word64 -> PaneDrop+dropTargetForPane r mouse tgt =+  case edgeZone r mouse of+    ZoneCenter -> DropSwap tgt+    ZoneLeft -> DropSplit tgt AxisV True+    ZoneRight -> DropSplit tgt AxisV False+    ZoneTop -> DropSplit tgt AxisH True+    ZoneBottom -> DropSplit tgt AxisH False++-- | Classify a drop point against the grid's outer boundary. If the pointer+-- sits within @band@ px of a grid edge, return the 'DropTop' target for that+-- edge; otherwise 'Nothing'. Checked before pane-level drops so the outermost+-- edge always restructures the whole grid.+topLevelDropTarget :: Float -> Rect -> V2 -> Maybe PaneDrop+topLevelDropTarget band r@(Rect l t w h) (V2 x y)+  | not (rectNonEmpty r) = Nothing+  | x <= l + band = Just (DropTop AxisV True)+  | x >= l + w - band = Just (DropTop AxisV False)+  | y <= t + band = Just (DropTop AxisH True)+  | y >= t + h - band = Just (DropTop AxisH False)+  | otherwise = Nothing++-- | Drop preview for a drop target: the rect to highlight and the+-- 'PaneDrop' the drop performs. The highlight is found by simulating the+-- drop ('treeMovePane' with a throwaway split id) and laying the resulting+-- tree out ('layoutNode') into the grid rect, so it is exactly the region the+-- dragged pane will occupy after the drop, accounting for the restructuring+-- that removing the pane causes (its parent split collapses and sibling+-- subtrees expand) and for 'spacing' and min-size floors. Estimating the rect+-- from the target's pre-drop bounds goes wrong wherever mixed 'AxisV' /+-- 'AxisH' splits make those two layouts diverge. @spacing@ must be the gutter+-- actually laid out between panes: 'NanoUI.Widgets.PaneGrid' passes+-- @pgSpacing + 2 * pgLeeway@, not @pgSpacing@, or the preview regions drift+-- from the on-screen layout. 'Nothing' when the drop cannot be performed+-- (unknown pane ids, 'DropTop' on a single-pane grid).+dropPreview :: Float -> Float -> GridNode -> Word64 -> Rect -> PaneDrop -> Maybe (Rect, PaneDrop)+dropPreview minSize spacing tree moved baseRect dt = do+  t' <- treeMovePane moved 0 dt tree+  let (regions, _) = layoutNode minSize spacing t' baseRect+  r <- M.lookup moved regions+  pure (r, dt)
+ lib/NanoUI/Widgets/Table.hs view
@@ -0,0 +1,692 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Table+  ( SortDir (..)+  , SortCol (..)+  , ColSize (..)+  , TableConfig (..)+  , TableResponse (..)+  , defaultTableConfig+  , table+  , tableWith+  , tableConfigured+  , simpleTable+  , useTableSort+  , tableHiddenIndices+  , sortRows+  , Colonnade+  , Headed (..)+  , headed+  , headless+  )+where++import Colonnade (Colonnade, Headed (..), headed, headless)+import Colonnade.Encode qualified as Encode+import Control.Monad (forM, forM_, unless, void, when)+import Control.Monad.ST (runST)+import Data.Char (isDigit)+import Data.Foldable (toList)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IS+import Data.List (sortOn)+import Data.Maybe (fromMaybe, isJust, listToMaybe)+import Data.Ord (Down (..))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Primitive.PrimArray (PrimArray, generatePrimArray, indexPrimArray, newPrimArray, primArrayFromList, readPrimArray, sizeofPrimArray, unsafeFreezePrimArray, writePrimArray)+import Data.Primitive.SmallArray (SmallArray, indexSmallArray, mapSmallArray', newSmallArray, sizeofSmallArray, smallArrayFromList, unsafeFreezeSmallArray, writeSmallArray)+import Data.Primitive.Types (Prim)+import Data.Vector qualified as V+import Effectful (Eff, type (:>))+import qualified Data.IntMap.Strict as IM+import NanoUI.Context (Context (..), getPrevRect, getScrollOffset2D, getStore, intKey, linkScrollAxes, setStore, modifyStore)+import NanoUI.Hooks (useInt)+import NanoUI.Font (ScrollBarSlot (..), scrollBarGutter, tableCellInset, lineWidthIO)+import NanoUI.Input (Input (..), inputMouseDown, inputMousePos, inputMousePressed, inputMouseReleased)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)+import NanoUI.Store (WidgetStore (..), Slot (..), slotKey)+import NanoUI.Style (AlignX (..), AlignY (..), Direction (..), FontVariant (..), Layout (..), Padding (..), Sizing (..), defaultLayout, fillH, fillW, tight)+import Data.Bits ((.|.), shiftL)+import NanoUI.Types (Rect (..), clamp, rectH, rectW, rectY, v2X, V2 (..), rectContains)+import NanoUI.WidgetText (buttonFlagTable, tableHeaderLabel, tableSortReserve)+import NanoUI.Widgets.Behavior (dragThresholdPx, useReorder)+import NanoUI.Widgets.Combinators (buttonStyled)+import NanoUI.Widgets.Layout (column', panel', row', scrollAreaIdConfigured, separator, spacer)+import NanoUI.Frame.Scroll.Geometry (ScrollConfig (..), ScrollPolicy (..), scrollHorizontalHidden, scrollVerticalAuto, scrollVerticalHidden)+import NanoUI.Widgets.Node+  ( HasResponse (..)+  , Response (..)+  , rawRespRect+  , respClicked+  , respRightClicked+  , setChanged+  , setClicked+  , tagContainer+  , addWidgetStyled+  )++-- | True if the first n column sizes contain ColStretch.+{-# INLINE tableStretchN #-}+tableStretchN :: Int -> [ColSize] -> Bool+tableStretchN n = any (== ColStretch) . take n++-- | Columns fill the table width when one stretches or the table grows.+tableFillInner :: Bool -> Layout -> Bool+tableFillInner hasStretch outer =+  hasStretch+    || case layoutWidth outer of+      Grow _ -> True+      _ -> False++data SortDir = SortAsc | SortDesc+  deriving (Eq, Show, Enum, Bounded)++data SortCol = SortCol {sortColIndex :: !Int, sortColDir :: !SortDir}+  deriving (Eq, Show)++data ColSize = ColContent | ColStretch | ColFixed Float+  deriving (Eq, Show)++data TableConfig = TableConfig+  { tableFreezeCols :: {-# UNPACK #-} !Int+  , tableFreezeRows :: {-# UNPACK #-} !Int+  , tableColSizes :: ![ColSize]+  , tableHidden :: !IntSet+  }+  deriving (Eq, Show)++defaultTableConfig :: TableConfig+defaultTableConfig = TableConfig 0 0 [] IS.empty++data TableResponse = TableResponse+  { tableWidgetResponse :: !Response+  , tableSort :: !SortCol+  , tableColOrder :: ![Int]+  , tableHiddenCols :: !IntSet+  }+  deriving (Eq, Show)++instance HasResponse TableResponse where+  {-# INLINE toResponse #-}+  toResponse = tableWidgetResponse++tableHiddenIndices :: TableResponse -> [Int]+tableHiddenIndices = IS.toAscList . tableHiddenCols++packSort :: SortCol -> Int+packSort (SortCol c SortAsc) = c * 2+packSort (SortCol c SortDesc) = c * 2 + 1++unpackSort :: Int -> SortCol+unpackSort n = SortCol (n `div` 2) (if odd n then SortDesc else SortAsc)++clampSortCol :: Int -> SortCol -> SortCol+clampSortCol n (SortCol idx dir) = SortCol (clamp 0 (max 0 (n - 1)) idx) dir++-- Sort mark in bits 16-17 (see tableSortMarkOf): the low nibbles are the+-- font fields and a mark of 1 or 2 in bit 0-1 flips the header's font+-- variant, which blanks the arrow glyph.+sortMarkStyle :: SortCol -> Int -> Int+sortMarkStyle sort idx+  | sortColIndex sort /= idx = 0+  | sortColDir sort == SortDesc = 2 `shiftL` 16+  | otherwise = 1 `shiftL` 16++sortRows :: Foldable f => Colonnade Headed row Text -> SortCol -> f row -> [row]+sortRows cols sort inputRows =+  let rows = toList inputRows+      n = V.length (Encode.getColonnade cols)+      idx = sortColIndex (clampSortCol n sort)+      enc = maybe (const T.empty) Encode.oneColonnadeEncode (Encode.getColonnade cols V.!? idx)+   in case sortColDir sort of+        SortAsc -> sortOn enc rows+        SortDesc -> sortOn (Down . enc) rows++columnCount :: Colonnade Headed row Text -> Int+columnCount = V.length . Encode.getColonnade++isNumericCell :: Text -> Bool+isNumericCell txt =+  let s = T.strip txt+      digits = case T.uncons s of+        Just (c, rest) | c == '-' || c == '+' -> rest+        _ -> s+   in not (T.null digits) && T.all isDigit digits++-- | Content width and numeric flag of each column, measured once over the+-- encoded rows.+columnMetrics :: Context -> V.Vector Text -> SmallArray (V.Vector Text) -> IO (PrimArray Float, SmallArray Bool)+columnMetrics ctx hdrs encoded = do+  let fm = ctxFontMetrics ctx+      mono = ctxMonoFontMetrics ctx+      cellPadX = 2 * tableCellInset+      count = V.length hdrs+      nRows = sizeofSmallArray encoded+      cell r c = indexSmallArray encoded r V.! c+  widths <- newPrimArray count+  numeric <- newSmallArray count False+  forM_ [0 .. count - 1] $ \c -> do+    hdrW <- (+ cellPadX) <$> lineWidthIO fm (hdrs V.! c <> tableSortReserve)+    let numericFrom !r = r >= nRows || (isNumericCell (cell r c) && numericFrom (r + 1))+        isNum = nRows > 0 && numericFrom 0+        font = if isNum then mono else fm+        widest !r !w+          | r >= nRows = pure w+          | otherwise = do+              width <- lineWidthIO font (cell r c)+              widest (r + 1) (max w (width + cellPadX))+    cellW <- widest 0 minColW+    writePrimArray widths c (if nRows == 0 then hdrW else max hdrW cellW)+    writeSmallArray numeric c isNum+  (,) <$> unsafeFreezePrimArray widths <*> unsafeFreezeSmallArray numeric++nextSortCol :: Int -> SortCol -> Int -> SortCol+nextSortCol n cur clicked =+  let clamped = clampSortCol n cur+   in if clicked == sortColIndex clamped+        then SortCol clicked (case sortColDir clamped of SortAsc -> SortDesc; SortDesc -> SortAsc)+        else SortCol clicked SortAsc++useTableSort :: Ui :> es => SortCol -> Eff es (SortCol, SortCol -> Eff es ())+useTableSort initial = do+  (packed, setPacked) <- useInt (packSort initial)+  pure (unpackSort packed, setPacked . packSort)++-- | Header pointer gesture on column @i@, stored as one Int in the drag slot:+-- 0 idle, @-(1000 + i)@ resizing, @-(2000 + i)@ dragging to reorder.+data HeaderDrag = HeaderIdle | HeaderResize !Int | HeaderReorder !Int+  deriving (Eq)++packHeaderDrag :: HeaderDrag -> Int+packHeaderDrag = \case+  HeaderIdle -> 0+  HeaderResize i -> -(1000 + i)+  HeaderReorder i -> -(2000 + i)++unpackHeaderDrag :: Int -> HeaderDrag+unpackHeaderDrag n+  | n <= -2000 = HeaderReorder (-2000 - n)+  | n <= -1000 = HeaderResize (-1000 - n)+  | otherwise = HeaderIdle++-- Metadata is indexed by original column id after reordering/hiding. Keep+-- it indexed throughout layout, rather than walking a list for each cell.+{-# INLINE primAt #-}+primAt :: Prim a => PrimArray a -> Int -> a -> a+primAt xs i fallback = if i >= 0 && i < sizeofPrimArray xs then indexPrimArray xs i else fallback++{-# INLINE smallAt #-}+smallAt :: SmallArray a -> Int -> a -> a+smallAt xs i fallback = if i >= 0 && i < sizeofSmallArray xs then indexSmallArray xs i else fallback++resolvedWidth :: SmallArray ColSize -> PrimArray Float -> PrimArray Float -> Int -> Float+resolvedWidth sizes contentWs stored i =+  let contentW = max minColW (primAt contentWs i minColW)+      saved = primAt stored i 0+   in case smallAt sizes i ColContent of+        ColStretch -> if saved > contentW then saved else contentW+        ColFixed f ->+          let base = max minColW f+           in if saved > 0 then max base saved else base+        ColContent -> if saved > 0 then max contentW saved else contentW++-- Width floor a column cannot shrink under: its declared fixed width, else+-- its content minimum. Shared by colSizing and the resize-drag clamp so a+-- dragged or stored width never wraps the cell text.+colFloor :: SmallArray ColSize -> PrimArray Float -> Int -> Float+colFloor sizes contentWs i = case smallAt sizes i ColContent of+  ColFixed f -> max minColW f+  _ -> max minColW (primAt contentWs i minColW)++colSizing :: Bool -> Bool -> SmallArray ColSize -> PrimArray Float -> PrimArray Float -> Int -> Sizing+colSizing fillInner hasStretch sizes contentWs stored i =+  let saved = primAt stored i 0+      floorW = colFloor sizes contentWs i+   in case smallAt sizes i ColContent of+        ColFixed _ -> Fixed (max floorW saved)+        ColStretch+          | saved > 0 -> Fixed (max floorW saved)+          | fillInner -> Grow 1+          | otherwise -> Fixed floorW+        ColContent+          | saved > 0 -> Fixed (max floorW saved)+          | fillInner && not hasStretch -> Grow 1+          | otherwise -> Fixed floorW++colBoxLayout :: Sizing -> Float -> Layout+colBoxLayout sizing minCol =+  let base =+        tight $+          defaultLayout+            { layoutGap = 0+            , layoutMinW = minCol+            , -- Columns stretch to the row height so every cell's background+              -- and borders span the full row even when one cell wraps.+              layoutHeight = Grow 1+            }+    in case sizing of+        Fixed w -> base {layoutWidth = Fixed w, layoutMaxW = w}+        Grow g -> base {layoutWidth = Grow g}+        _ -> base {layoutWidth = Fit}++-- | Sortable table with resizable, reorderable columns. @key@ tells tables in+-- one scope apart, and the columns are a colonnade over @row@. Pass the+-- current sort; the 'TableResponse' carries the sort after this frame's+-- header clicks, along with the column order and hidden columns.+{-# INLINE table #-}+table :: (Foldable f, Ui :> es) => Text -> Colonnade Headed row Text -> f row -> SortCol -> Eff es TableResponse+table = tableConfigured defaultTableConfig id++-- | 'table' with a layout modifier.+{-# INLINE tableWith #-}+tableWith :: (Foldable f, Ui :> es) => (Layout -> Layout) -> Text -> Colonnade Headed row Text -> f row -> SortCol -> Eff es TableResponse+tableWith = tableConfigured defaultTableConfig++-- | A table of text rows under the given headers.+simpleTable :: (Foldable f, Ui :> es) => [Text] -> f [Text] -> Eff es TableResponse+simpleTable headers rows = do+  let cols = mconcat [headed h (\r -> smallAt r i "") | (i, h) <- zip [0 ..] headers]+      indexedRows = map smallArrayFromList (toList rows)+  table "simple" cols indexedRows (SortCol 0 SortAsc)++-- | 'tableWith' with column sizes, frozen rows and columns, and initially+-- hidden columns.+tableConfigured ::+  (Foldable f, Ui :> es) =>+  TableConfig ->+  (Layout -> Layout) ->+  Text ->+  Colonnade Headed row Text ->+  f row ->+  SortCol ->+  Eff es TableResponse+tableConfigured cfg f key cols inputRows curSort =+  withKey ("table:" <> key) $ do+    let outerLayout = f (tight . fillW $ defaultLayout {layoutGap = 0})+    stateWid <- nextId+    vWid <- nextId+    hWid <- nextId+    tableWid <- nextId+    let n = columnCount cols+        sort0 = clampSortCol n curSort+        stateKey = intKey stateWid+        hdrs = Encode.header id cols+        -- Each row is encoded once and shared by measuring, sorting and the+        -- cells; the sort orders row indices.+        encoded = smallArrayFromList [Encode.row id cols r | r <- toList inputRows]+    ctx <- askContext+    inp <- askInput+    st0 <- uiIO (getStore ctx)+    (!contentWs, !numeric) <- uiIO (columnMetrics ctx hdrs encoded)+    let sizes = smallArrayFromList (tableColSizes cfg)+        order0 = normalizeOrder n (IM.findWithDefault [0 .. n - 1] stateKey (storeIntList st0))+        hidden0 = IM.findWithDefault (tableHidden cfg) stateKey (storeIntSet st0)+        widths0 = take n (IM.findWithDefault [] stateKey (storeFloatList st0) ++ repeat 0)+        drag0 = unpackHeaderDrag (IM.findWithDefault 0 (slotKey SlotDrag stateKey) (storeInt st0))+        dragX0 = IM.findWithDefault 0 stateKey (storeFloat st0)+        dragW0 = IM.findWithDefault 0 (slotKey SlotDragW stateKey) (storeFloat st0)+        mx = v2X (inputMousePos inp)+        -- A drag cannot push a column under its colFloor: the column reserved+        -- that much space for its text, and going under it wraps the cell and+        -- drags the whole row taller.+        widths1 = case drag0 of+          HeaderResize c+            | inputMouseDown inp ->+                setAt c (max (colFloor sizes contentWs c) (dragW0 + mx - dragX0)) widths0+          _ -> widths0+    when (widths1 /= widths0) $ uiIO $+      modifyStore ctx (\st -> st {storeFloatList = IM.insert stateKey widths1 (storeFloatList st)})+    let hasStretch = tableStretchN n (tableColSizes cfg)+        indexedWidths = primArrayFromList widths1+        vis = filter (`IS.notMember` hidden0) order0+        freezeN = clamp 0 (length vis) (tableFreezeCols cfg)+        frozenIdx = take freezeN vis+        unfrozenIdx = drop freezeN vis+        nRows = sizeofSmallArray encoded+        sorted =+          sortIndices+            (sortColDir sort0)+            (mapSmallArray' (\cells -> fromMaybe T.empty (cells V.!? sortColIndex sort0)) encoded)+        pinnedN = min nRows (max 0 (tableFreezeRows cfg))+        scrollN = nRows - pinnedN+        rowMinH = 28+        fillInner = tableFillInner hasStretch outerLayout+        mins = generatePrimArray n (resolvedWidth sizes contentWs indexedWidths)+        colBoxes = smallArrayFromList [colBoxLayout (colSizing fillInner hasStretch sizes contentWs indexedWidths i) (primAt mins i minColW) | i <- [0 .. n - 1]]+        colBox i = smallAt colBoxes i (tight defaultLayout)+        resolvedW i = primAt mins i minColW+        cellLayouts = smallArrayFromList $ flip map [0 .. n - 1] $ \i ->+          (tight defaultLayout)+              { layoutWidth = Grow 1+              , layoutHeight = Grow 1+              , layoutAlignX = if smallAt numeric i False then AlignEnd else AlignStart+              , layoutAlignY = AlignMiddle+              , layoutMinH = rowMinH+              , layoutFontVariant = if smallAt numeric i False then FontMono else FontRegular+              }+        cellLayout i = smallAt cellLayouts i (tight defaultLayout)+        -- Cell @i@ of display row @ri@, which shows encoded row @r@.+        renderCell ri r i = do+          wid <- nextId+          void (addWidgetStyled wid NodeText (indexSmallArray encoded r V.! i) 0 (cellLayout i) (if even ri then 1 else 2))+        rowCells rowLay idxs colLays ri =+          gridColumnsLay rowLay idxs colLays [renderCell ri (indexPrimArray sorted ri) i | i <- idxs]+        paneRoot =+          (if fillInner then tight . fillW . fillH else tight . fillH) defaultLayout+        minSum idxs = sum (map (layoutMinW . colBox) idxs) + fromIntegral (max 0 (length idxs - 1))+        vLay fill =+          let base = tight . fillH $ defaultLayout {layoutGap = 0}+           in if fill then fillW base else base+        hRowLay = defaultLayout {layoutDirection = Row, layoutPadding = Padding 0 0 0 0, layoutGap = 0}+        paneLay fill idxs =+          let base = tight $ defaultLayout {layoutGap = 0, layoutHeight = Grow 1}+           in if fill then fillW (fillH base) else base {layoutWidth = Fit, layoutMinW = minSum idxs}+        gridRowLay idxs =+          (if fillInner then fillW else id) (tight $ defaultLayout {layoutGap = 0, layoutMinW = minSum idxs})+        -- Header row, its rule, the pinned rows and their rule: the same in both+        -- panes.+        headerBlock idxs = do+          hs <- row' (gridRowLay idxs) $+            forM (zip [0 :: Int ..] idxs) $ \(k, i) -> do+              when (k > 0) $ void separator+              withKey i $+                column' (colBox i) $+                  buttonStyled (tableHeaderLabel (fromMaybe T.empty (hdrs V.!? i))) (if sortColIndex sort0 == i then 1 else 0) (cellLayout i) (sortMarkStyle sort0 i .|. buttonFlagTable)+          void separator+          let !rowLay = gridRowLay idxs+              !colLays = map colBox idxs+          forM_ [0 .. pinnedN - 1] $ \ri ->+            withKey ("pin" :: Text, ri) $ do+              when (ri > 0) $ void separator+              rowCells rowLay idxs colLays ri+          when (pinnedN > 0 && scrollN > 0) $ void separator+          pure hs+        bodyBlock idxs = do+          (lo, hi) <-+            if scrollN == 0+              then pure (0, -1)+              else uiIO $ do+                V2 _ scrollY <- getScrollOffset2D ctx vWid+                viewH <- maybe (rowMinH * 8) rectH <$> getPrevRect ctx vWid+                pure (listClipper scrollN scrollY viewH rowMinH)+          let !rowLay = gridRowLay idxs+              !colLays = map colBox idxs+              topH = fromIntegral lo * rowMinH+              botH = fromIntegral (max 0 (scrollN - hi - 1)) * rowMinH+          column' rowLay $ do+            when (topH > 0) $ void (spacer Fit (Fixed topH))+            forM_ [lo .. hi] $ \rowIdx ->+              withKey rowIdx $ do+                when (rowIdx > 0) $ void separator+                rowCells rowLay idxs colLays (rowIdx + pinnedN)+            when (botH > 0) $ void (spacer Fit (Fixed botH))+        frozenPane =+          column' (paneLay False frozenIdx) $ do+            hs <- headerBlock frozenIdx+            scrollAreaIdConfigured+              vWid+              (vLay False)+              (if null unfrozenIdx then scrollVerticalAuto else scrollVerticalHidden)+              (bodyBlock frozenIdx)+            pure hs+        unfrozenPane = do+          -- The body scroller has no padding, so its whole lane is gutter.+          let vGutter = scrollBarGutter ScrollBarList 0+              idxs = unfrozenIdx+          mPrevV <- uiIO (getPrevRect ctx vWid)+          let totalH = fromIntegral scrollN * rowMinH+              -- Prev-frame decision, one frame behind the body scroller's live 2D+              -- gutter: on the frame the vertical bar first appears (or vanishes)+              -- the header spacer disagrees with the body's reserved lane for one+              -- frame. The horizontal side dodges this class of lag by owning its+              -- bar inside the body scroller; the vertical lane cannot do that+              -- because the header must narrow by exactly the lane width at build+              -- time, and the body's live v-gutter is only known after this+              -- frame's solve. Known, accepted one-frame misalignment.+              hasVertBar = maybe (totalH > 100) (\r -> totalH > rectH r) mPrevV+          column' (paneLay fillInner idxs) $ do+            hs <-+              row' (tight . (if fillInner then fillW else id) $ defaultLayout {layoutGap = 0}) $ do+                hs' <-+                  scrollAreaIdConfigured+                    hWid+                    ( if fillInner+                        then fillW hRowLay+                        else hRowLay {layoutMinW = minSum idxs}+                    )+                    -- The header scroller is chrome-less: it follows the body's+                    -- horizontal offset (linkScrollAxes below) and clips the header+                    -- row at the pane edge. The horizontal scrollbar itself belongs+                    -- to the body scroller so it spans the full table width at the+                    -- table's bottom edge instead of sitting under the header.+                    scrollHorizontalHidden+                    (column' (gridRowLay idxs) (headerBlock idxs))+                when hasVertBar $ void (spacer (Fixed vGutter) Fit)+                pure hs'+            uiIO (linkScrollAxes ctx vWid hWid)+            -- The body owns both bars: the vertical one on the right, and the+            -- horizontal one at the bottom of the table. Its live 2D gutter logic+            -- reserves the lane exactly while the columns overflow, so the bar+            -- cannot flicker the way the prev-frame header lane did.+            scrollAreaIdConfigured+              vWid+              (vLay fillInner)+              (ScrollConfig ScrollAuto ScrollAuto True False)+              (bodyBlock idxs)+            pure hs+    column' outerLayout $ do+      showAllResp <-+        if IS.null hidden0+          then pure Nothing+          else fmap Just $+            buttonStyled "Show all columns" 0 (tight . fillW $ defaultLayout) 0+      headerPairs <-+        panel' paneRoot $ do+          tagContainer tableWid+          row' (paneRoot {layoutGap = 0}) $ do+            frozenHs <-+              if null frozenIdx+                then pure []+                else zip frozenIdx <$> frozenPane+            when (not (null frozenIdx) && not (null unfrozenIdx)) $ void separator+            unfrozenHs <-+              if null unfrozenIdx then pure [] else zip unfrozenIdx <$> unfrozenPane+            pure (frozenHs ++ unfrozenHs)+      mBodyRect <- uiIO (getPrevRect ctx vWid)+      let mouse = inputMousePos inp+          edgePad = 4+          -- Resize grab zone spans the header band plus the body scroller: a+          -- column boundary is resizable anywhere down the table, not just on+          -- the header cell. The bottom anchor is the body scroller's rect+          -- (prev frame: readable at build time). The resize cursor+          -- (Frame.Cursor.tableColResizeCursorKind) locates the same scroller+          -- structurally and uses its current-frame rect, so the grab zone and+          -- the cursor zone are the same rect and cannot drift apart. First+          -- frame (no prev rect yet): header band only.+          hdrSpans =+            [ (rectY rr, rectY rr + rectH rr)+            | (_, r) <- headerPairs+            , let rr = rawRespRect r+            ]+          (edgeTop, edgeBot) = case hdrSpans of+            [] -> (0, 0)+            _ ->+              ( minimum (map fst hdrSpans)+              , maybe (maximum (map snd hdrSpans)) (\(Rect _ by _ bh) -> by + bh) mBodyRect+              )+          edgeCol = headerEdgeHit edgePad edgeTop edgeBot headerPairs mouse+          hoverCol = listToMaybe [i | (i, r) <- headerPairs, rectContains (rawRespRect r) mouse]+          headerRects = [(i, rawRespRect r) | (i, r) <- headerPairs]+          (isResize, isReorder) = case drag0 of+            HeaderResize _ -> (True, False)+            HeaderReorder _ -> (False, True)+            HeaderIdle -> (False, False)+          resizing = isResize && inputMouseDown inp+      (vis', mReorder) <-+        withKey ("reorder" :: Text) $+          useReorder vis (if resizing || isJust edgeCol then [] else headerRects)+      let dragged = isReorder && abs (mx - dragX0) > dragThresholdPx+          pressResize = inputMousePressed inp && isJust edgeCol+          pressReorder = inputMousePressed inp && edgeCol == Nothing && isJust hoverCol+          nextDrag+            | pressResize = maybe HeaderIdle HeaderResize edgeCol+            | pressReorder = maybe HeaderIdle HeaderReorder hoverCol+            | inputMouseReleased inp || not (inputMouseDown inp) = HeaderIdle+            | otherwise = drag0+          nextDragX+            | pressResize || pressReorder = mx+            | nextDrag == HeaderIdle = 0+            | otherwise = dragX0+          nextDragW+            | pressResize = maybe 0 headerW edgeCol+            | nextDrag == HeaderIdle = 0+            | otherwise = dragW0+          headerW i = maybe (resolvedW i) (\r -> let w = rectW (rawRespRect r) in if w > 0 then w else resolvedW i) (lookup i headerPairs)+          nextOrder = if vis' /= vis then rebuildOrder hidden0 vis' order0 else order0+          -- respRightClicked, not a bare release: a right press that went down+          -- elsewhere and came up over a header must not hide that column.+          hideClicked = [i | (i, r) <- headerPairs, respRightClicked r, drag0 == HeaderIdle]+          nextHidden = case showAllResp of+            Just r | respClicked r -> IS.empty+            _ -> case hideClicked of+              (i : _) | IS.size hidden0 + 1 < n -> IS.insert i hidden0+              _ -> hidden0+          sortClick =+            if dragged || isJust mReorder || vis' /= vis || isResize+              then Nothing+              else+                if isJust edgeCol && (inputMouseDown inp || inputMouseReleased inp)+                  then Nothing+                  else listToMaybe [i | (i, r) <- headerPairs, respClicked r]+          nextSort = maybe sort0 (nextSortCol n sort0) sortClick+          hasChanged = nextSort /= sort0 || nextOrder /= order0 || nextHidden /= hidden0 || widths1 /= widths0+          widgetResp =+            setChanged hasChanged $+              setClicked (hasChanged && isJust sortClick) (mconcat (map snd headerPairs ++ maybe [] pure showAllResp))+      -- Compare the five slots, not the whole store: rewriting the store only+      -- when a slot moved keeps an idle table from diffing every map each frame.+      uiIO $ do+        st <- getStore ctx+        let dragCode = packHeaderDrag nextDrag+            dragK = slotKey SlotDrag stateKey+            dragWK = slotKey SlotDragW stateKey+            unchanged =+              IM.lookup stateKey (storeIntList st) == Just nextOrder+                && IM.lookup stateKey (storeIntSet st) == Just nextHidden+                && IM.lookup dragK (storeInt st) == Just dragCode+                && IM.lookup stateKey (storeFloat st) == Just nextDragX+                && IM.lookup dragWK (storeFloat st) == Just nextDragW+        unless unchanged $+          setStore+            ctx+            st+              { storeIntList = IM.insert stateKey nextOrder (storeIntList st)+              , storeIntSet = IM.insert stateKey nextHidden (storeIntSet st)+              , storeInt = IM.insert dragK dragCode (storeInt st)+              , storeFloat =+                  IM.insert stateKey nextDragX $+                    IM.insert dragWK nextDragW (storeFloat st)+              }+      pure (TableResponse widgetResp nextSort nextOrder nextHidden)++-- | One row of cells with custom row layout.+gridColumnsLay :: (Ui :> es) => Layout -> [Int] -> [Layout] -> [Eff es ()] -> Eff es ()+gridColumnsLay lay keys layouts cells =+  void (row' lay (go True keys layouts cells))+ where+  -- Walk in lockstep without allocating zip tuples and indices per cell.+  go first (key : moreKeys) (layout : moreLayouts) (cell : moreCells) = do+    when (not first) $ void separator+    void (withKey key (column' layout cell))+    go False moreKeys moreLayouts moreCells+  go _ _ _ _ = pure ()++-- | Indices of @keys@ stably sorted by key: a bottom-up merge sort between+-- two index buffers.+sortIndices :: SortDir -> SmallArray Text -> PrimArray Int+sortIndices dir keys = runST $ do+  let n = sizeofSmallArray keys+      before l r = case compare (indexSmallArray keys l) (indexSmallArray keys r) of+        LT -> dir == SortAsc+        GT -> dir == SortDesc+        EQ -> True+  start <- newPrimArray n+  let fill !i = when (i < n) (writePrimArray start i i >> fill (i + 1))+  fill 0+  spare <- newPrimArray n+  let pass !src !dst !width+        | width >= n = unsafeFreezePrimArray src+        | otherwise = do+            let mergeFrom !lo = when (lo < n) $ do+                  let !mid = min n (lo + width)+                      !hi = min n (lo + 2 * width)+                      takeLeft !i !j !k = readPrimArray src i >>= writePrimArray dst k >> go (i + 1) j (k + 1)+                      takeRight !i !j !k = readPrimArray src j >>= writePrimArray dst k >> go i (j + 1) (k + 1)+                      go !i !j !k+                        | k >= hi = pure ()+                        | i >= mid = takeRight i j k+                        | j >= hi = takeLeft i j k+                        | otherwise = do+                            l <- readPrimArray src i+                            r <- readPrimArray src j+                            if before l r then takeLeft i j k else takeRight i j k+                  go lo mid lo+                  mergeFrom hi+            mergeFrom 0+            pass dst src (2 * width)+  pass start spare 1++-- | First and last visible item index for a uniform-height list, or+-- @(0, -1)@ when nothing is visible.+{-# INLINE listClipper #-}+listClipper :: Int -> Float -> Float -> Float -> (Int, Int)+listClipper itemCount scrollOff viewH itemH+  | itemCount <= 0 || itemH <= 0 || viewH <= 0 = (0, -1)+  | otherwise =+      let firstVis = max 0 (floor (scrollOff / itemH))+          lastVis = min (itemCount - 1) (floor ((scrollOff + viewH - 1) / itemH))+       in if lastVis < firstVis then (0, -1) else (firstVis, lastVis)++setAt :: Int -> a -> [a] -> [a]+setAt i x xs+  | i < 0 = xs+  | otherwise = case splitAt i xs of+      (before, _ : after) -> before ++ x : after+      (_, []) -> xs++normalizeOrder :: Int -> [Int] -> [Int]+normalizeOrder n stored =+  let valid = filter (\i -> i >= 0 && i < n) stored+      seen = IS.fromList valid+   in valid ++ [i | i <- [0 .. n - 1], not (IS.member i seen)]++rebuildOrder :: IntSet -> [Int] -> [Int] -> [Int]+rebuildOrder hidden newVis old =+  let go [] vs = vs+      go (i : is) vs+        | IS.member i hidden = i : go is vs+        | otherwise = case vs of+            (v : vs') -> v : go is vs'+            [] -> i : is+   in go old newVis++minColW :: Float+minColW = 40++-- | Hit-test a column resize edge. The grab zone spans the whole column+-- height (header top to body bottom), so a column can be resized by its+-- boundary line anywhere down the table, not just on the header cell.+headerEdgeHit :: Float -> Float -> Float -> [(Int, Response)] -> V2 -> Maybe Int+headerEdgeHit pad yTop yBot cols mouse =+  listToMaybe+    [ i+    | (i, r) <- cols+    , let Rect x y w h = rawRespRect r+    , w > 0 && h > 0+    , let mx = v2X mouse+          my = v2Y mouse+    , my >= min y yTop && my <= max (y + h) yBot+    , abs (mx - (x + w)) <= pad+    ]
+ lib/NanoUI/Widgets/Tabs.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE OverloadedStrings #-}++module NanoUI.Widgets.Tabs+  ( Tab (..), TabStyle (..), TabOrientation (..), TabResponse (..)+  , TabsConfig (..), defaultTabsConfig+  , tab, closableTab+  , tabs, tabs', tabsConfigured, tabsConfigured'+  , tabBar, tabBar', tabBarConfigured, tabBarConfigured'+  )+where++import Control.Monad (forM_, when)+import Data.Bits ((.|.))+import Data.List (find)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (isJust, listToMaybe)+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , getPrevRect+  , getScrollOffset+  , getStore+  , intKey+  , markDirty+  , resolveScrollStep+  , setScrollOffset+  , setStore+  , currentTheme+  )+import NanoUI.Frame.Hit (findNodeByWidgetId)+import NanoUI.Frame.Scroll.Geometry (scrollAxisRange, scrollBare, scrollHorizontalHidden)+import NanoUI.Id (WidgetId)+import NanoUI.Input (inputMousePos, inputScroll)+import NanoUI.Layout.Arena (setNodeValue)+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)+import NanoUI.Store (WidgetStore (storeFloat), slotKey, Slot (..))+import NanoUI.Style+  ( AlignX (..)+  , AlignY (..)+  , Direction (..)+  , Layout (..)+  , Padding (..)+  , Sizing (..)+  , defaultLayout+  , fillW+  , grow+  , themeMuted+  , tight+  )+import NanoUI.Types (Rect (..), clamp, rectContains, rectW, v2Y)+import NanoUI.WidgetText (buttonFlagClose, buttonFlagTab)+import NanoUI.Widgets.Combinators (buttonStyledEx)+import NanoUI.Widgets.Layout (column', columnWith, row', rowWith, scrollAreaIdConfigured)+import NanoUI.Widgets.Node+  ( HasResponse (..)+  , Response (..)+  , respClicked+  , respId+  , respRect+  , setChanged+  , setClicked+  , tagContainer+  )++data TabStyle = TabUnderline | TabPill | TabSegmented | TabContained+  deriving (Eq, Show, Enum, Bounded)++data TabOrientation = TabTop | TabBottom | TabLeft | TabRight+  deriving (Eq, Show, Enum, Bounded)++-- | Header look and placement for 'tabsConfigured' and 'tabBarConfigured'.+data TabsConfig = TabsConfig+  { tabsStyle :: !TabStyle+  , tabsOrientation :: !TabOrientation+  }+  deriving (Eq, Show)++-- | Underlined headers along the top.+defaultTabsConfig :: TabsConfig+defaultTabsConfig = TabsConfig TabUnderline TabTop++data Tab a body = Tab+  { tabKey :: !a+  , tabTitle :: !Text+  , tabClosable :: !Bool+  , tabDisabled :: !Bool+  , tabBadge :: !(Maybe Text)+  , tabBody :: !body+  }++data TabResponse a = TabResponse+  { tabResponse :: !Response+  , tabClosed :: !(Maybe a)+  , tabActive :: !a+  }+  deriving (Eq, Show)++instance HasResponse (TabResponse a) where+  {-# INLINE toResponse #-}+  toResponse = tabResponse++tab :: a -> Text -> body -> Tab a body+tab key title body = Tab key title False False Nothing body++closableTab :: a -> Text -> body -> Tab a body+closableTab key title body = Tab key title True False Nothing body++-- | Header chrome height: one source for the strip bar, the scroller, and+-- the paging arrows so they cannot drift apart.+tabHeaderH :: Float+tabHeaderH = 28++-- | One rendered header, shared by selection, close handling, and scrolling.+data Header a = Header+  { headerKey :: !a+  , headerResponse :: !Response+  , headerClosed :: !Bool+  }++tabStrip ::+  (Eq a, Ui :> es) =>+  TabsConfig ->+  a ->+  [Tab a body] ->+  Maybe (a -> Eff es ()) ->+  Eff es (TabResponse a, a)+tabStrip (TabsConfig style orient) cur tabList mRenderBody = do+  ctx <- askContext+  groupId <- nextId+  let vertical = orient == TabLeft || orient == TabRight+      h = tabHeaderH+      styleVal = fromEnum style+      hdrLay =+        defaultLayout+          { layoutHeight = Fixed h+          , layoutPadding = Padding 8 8 4 4+          , layoutAlignX = AlignCenter+          , layoutAlignY = AlignMiddle+          , layoutGap = 4+          }+      barLay =+        if vertical+          then defaultLayout {layoutDirection = Column, layoutWidth = Fit, layoutHeight = Grow 1, layoutGap = 2, layoutPadding = Padding 2 2 2 2}+          else+            defaultLayout+              { layoutDirection = Row+              , layoutWidth = Grow 1+              , layoutHeight = Fixed (h + 4)+              , layoutGap = if style == TabSegmented then 0 else 4+              , layoutPadding = if style == TabContained then Padding 0 0 2 0 else Padding 0 0 0 0+              }+  let headerBar =+        if vertical+          then column' barLay $ do+            tagContainer groupId+            (tabResp, nextTab, _) <- renderHeaders ctx hdrLay styleVal cur (zip [0 :: Int ..] tabList)+            pure (tabResp, nextTab)+          else row' barLay $ do+            tagContainer groupId+            renderScrollableHeaders ctx style hdrLay barLay groupId cur tabList+  case mRenderBody of+    Nothing -> headerBar+    Just bodyRender ->+      let shell layout = layout $ do+            (tabResp, nextTab) <- headerBar+            bodyRender nextTab+            pure (tabResp, nextTab)+       in if vertical+            then shell (rowWith (tight . fillW . grow))+            else shell (columnWith (tight . fillW))++-- | Horizontal headers that page with chevron buttons when they overflow.+-- While the labels fit, the strip renders exactly as before (no scroll+-- container, no well). Once they overflow, the headers move into a 1D+-- hidden, bare 'scrollHorizontalHidden' container so the framework owns the+-- clip, the offset store, the damage, and the wheel: a bare scroller paints+-- no well, so the headers look exactly as they did before they could+-- scroll, and the hidden policy keeps the scrollbar away while the wheel+-- (both the left+right axis, applied by the framework, and up/down notches,+-- mapped here because a tab bar is horizontal) still pages the same offset.+-- The strip only adds the two buttons. The scroller grows between the+-- buttons, so the right arrow sits on the bar's far edge instead of+-- trailing the last tab.+renderScrollableHeaders ::+  (Eq a, Ui :> es) =>+  Context ->+  TabStyle ->+  Layout ->+  Layout ->+  WidgetId ->+  a ->+  [Tab a body] ->+  Eff es (TabResponse a, a)+renderScrollableHeaders ctx style hdrLay barLay groupId cur tabList = do+  scrollWid <- withKey ("tab-scroller" :: Text) nextId+  let h = tabHeaderH+      styleVal = fromEnum style+      barPad = layoutPadding barLay+      arrowW = 26+      leftGlyph = "\8249"+      rightGlyph = "\8250"+      innerLay =+        defaultLayout+          { layoutDirection = Row+          , layoutWidth = Fit+          , layoutHeight = Fixed h+          , layoutGap = layoutGap barLay+          , layoutPadding = Padding 0 0 0 0+          }+      scrollerLay =+        defaultLayout+          { layoutDirection = Row+          , layoutWidth = Grow 1+          , layoutHeight = Fixed h+          , layoutPadding = Padding 0 0 0 0+          }+      -- Hidden + bare: the scroller owns the clip, offset, wheel, and damage+      -- but paints nothing (no well, no scrollbar), so the headers look+      -- exactly as they did before the strip could scroll.+      scrollerCfg = scrollHorizontalHidden {scrollBare = True}+      rangeKey = slotKey SlotScrollContent (intKey scrollWid)+      renderInner =+        withKey ("tab-strip" :: Text) $+          row' innerLay (renderHeaders ctx hdrLay styleVal cur (zip [0 :: Int ..] tabList))+  -- The reachable range cached last frame decides whether the strip needs the+  -- scroller at all. Cached as a float so a pure scroll frame keeps its clip+  -- damage (see `onlyScrollFloatsChanged` in NanoUI.Damage).+  store <- uiIO (getStore ctx)+  let maxOffPrev = max 0 (IM.findWithDefault 0 rangeKey (storeFloat store))+      overflow = maxOffPrev > 0.5+  off <- uiIO (getScrollOffset ctx scrollWid)+  wheelStep <- uiIO (resolveScrollStep ctx scrollWid)+  mBar <- uiIO (getPrevRect ctx groupId)+  mScr <- uiIO (getPrevRect ctx scrollWid)+  inp <- askInput+  let overBar = maybe False (\r -> rectContains r (inputMousePos inp)) mBar+      notches = if overBar then round (v2Y (inputScroll inp)) else 0 :: Int+      canLeft = overflow && off > 0.5+  leftResp <-+    if overflow+      then Just <$> withKey ("tab-arrow-left" :: Text) (arrowButton ctx hdrLay arrowW h (not canLeft) leftGlyph)+      else pure Nothing+  (tabResp, nextTab, resps) <-+    if overflow+      then scrollAreaIdConfigured scrollWid scrollerLay scrollerCfg renderInner+      else renderInner+  let+    (viewX, viewW) =+      if overflow+        then maybe (0, 0) (\r -> (rectX r, rectW r)) mScr+        else+          case mBar of+            Just r ->+              ( rectX r + padL barPad+              , max 0 (rectW r - padL barPad - padR barPad)+              )+            Nothing -> (0, 0)+    maxRight = maximum (0 : [rectX r + rectW r | header <- resps, let r = respRect (headerResponse header)])+    contentW = maxRight - viewX + (if overflow then off else 0)+    -- The first overflow frame has no scroller rect yet (mScr is Nothing);+    -- keep the last cached range instead of measuring against a phantom+    -- viewport, so nothing pages or clamps wildly and the cache never+    -- flip-flops the scroller away.+    maxOff = case (overflow, mScr) of+      (True, Nothing) -> maxOffPrev+      _ -> scrollAxisRange contentW viewW 0+    page = max 1 (viewW * 0.9)+    canRight = overflow && off < maxOff - 0.5+  rightResp <-+    if overflow+      then Just <$> withKey ("tab-arrow-right" :: Text) (arrowButton ctx hdrLay arrowW h (not canRight) rightGlyph)+      else pure Nothing+  uiIO (cacheScrollRange ctx rangeKey maxOff)+  -- One final offset per frame. The paged result folds the arrow pages, the+  -- wheel notches, and the end clamp (a stale offset that outlived a wider+  -- bar); the active-follow wins over it so a programmatically changed tab+  -- always lands in view.+  let pagedOff+        | maybe False respClicked leftResp, canLeft = max 0 (off - page)+        | maybe False respClicked rightResp, canRight = min maxOff (off + page)+        | overflow, notches /= 0, maxOff > 0 =+            clamp 0 maxOff (off + fromIntegral notches * wheelStep)+        | overflow, off > maxOff + 0.5 = maxOff+        | otherwise = off+      finalOff+        | overflow+        , nextTab /= cur+        , Just header <- find ((== nextTab) . headerKey) resps+        , let hr = respRect (headerResponse header) =+            if rectX hr < viewX+              then max 0 (off - (viewX - rectX hr))+              else+                if rectX hr + rectW hr > viewX + viewW+                  then min maxOff (off + (rectX hr + rectW hr - viewX - viewW))+                  else pagedOff+        | otherwise = pagedOff+  when (finalOff /= off) $+    uiIO (setScrollOffset ctx scrollWid finalOff)+  pure (tabResp, nextTab)++-- | Remember the scroller's reachable range for the next frame's arrow+-- visibility. Sub-pixel churn is ignored so a parked strip never dirties.+cacheScrollRange :: Context -> Int -> Float -> IO ()+cacheScrollRange ctx key v = do+  st <- getStore ctx+  let prev = IM.findWithDefault 0 key (storeFloat st)+  when (abs (prev - v) > 0.5) $+    setStore ctx (st {storeFloat = IM.insert key v (storeFloat st)})++-- | A prettier thin chevron button for the strip. Disabled ends paint the+-- glyph in the muted fg instead of dropping the button, so the row width does+-- not jump as you page to either end.+arrowButton :: (Ui :> es) => Context -> Layout -> Float -> Float -> Bool -> Text -> Eff es Response+arrowButton ctx hdrLay arrowW barH muted glyph = do+  theme <- uiIO (currentTheme ctx)+  let lay =+        hdrLay+          { layoutWidth = Fixed arrowW+          , layoutHeight = Fixed barH+          , layoutFontColor = if muted then Just (themeMuted theme) else Nothing+          }+  buttonStyledEx (not muted) glyph 0 lay 0++renderHeaders ::+  (Eq a, Ui :> es) =>+  Context ->+  Layout ->+  Int ->+  a ->+  [(Int, Tab a body)] ->+  Eff es (TabResponse a, a, [Header a])+renderHeaders ctx hdrLay styleVal cur indexed = do+  resps <- mapM (\(i, t) -> withKey i (renderSingleHeader hdrLay (styleVal + 4 * i) cur t)) indexed+  let clickedKeys = [headerKey h | h <- resps, respClicked (headerResponse h), not (headerClosed h)]+      closedKey = headerKey <$> find headerClosed resps+      nextTab = case clickedKeys of+        (k : _) -> k+        [] -> cur+      hasChanged = nextTab /= cur+      hasClicked = not (null clickedKeys)+      overallResp =+        TabResponse+          { tabResponse = setChanged hasChanged (setClicked hasClicked (foldMap headerResponse resps))+          , tabClosed = closedKey+          , tabActive = nextTab+          }+  when (hasChanged || isJust closedKey) $ uiIO (markDirty ctx)+  when hasChanged $ uiIO (syncTabHeaderActive ctx nextTab resps)+  pure (overallResp, nextTab, resps)++renderSingleHeader ::+  (Eq a, Ui :> es) =>+  Layout ->+  Int ->+  a ->+  Tab a body ->+  Eff es (Header a)+renderSingleHeader hdrLay packedStyle cur t = do+  let isActive = tabKey t == cur+      headerText = maybe (tabTitle t) (\b -> mconcat [tabTitle t, " (", b, ")"]) (tabBadge t)+      tabStyle = packedStyle .|. buttonFlagTab+      headerButton = buttonStyledEx (not (tabDisabled t))+  if tabClosable t+    then do+      (tabResp, closed) <- rowWith tight $ do+        resp <- headerButton headerText (if isActive then 1 else 0) hdrLay tabStyle+        closeResp <- headerButton "\215" 0 (hdrLay {layoutPadding = Padding 2 4 4 4}) buttonFlagClose+        pure (resp, respClicked closeResp)+      pure (Header (tabKey t) tabResp closed)+    else do+      resp <- headerButton headerText (if isActive then 1 else 0) hdrLay tabStyle+      pure (Header (tabKey t) resp False)++syncTabHeaderActive :: Eq a => Context -> a -> [Header a] -> IO ()+syncTabHeaderActive ctx active resps =+  forM_ resps $ \(Header k r _) -> do+    mIdx <- findNodeByWidgetId ctx (respId r)+    case mIdx of+      Just i -> setNodeValue (ctxNodeArena ctx) i (if k == active then 1 else 0)+      Nothing -> pure ()++-- | Tab headers and the active tab's body. Pass the active key; the result is+-- the active key after this frame's clicks or arrow keys. Only the active+-- tab's body runs.+{-# INLINE tabs #-}+tabs :: (Foldable f, Eq a, Ui :> es) => a -> f (Tab a (Eff es ())) -> Eff es a+tabs = tabsConfigured defaultTabsConfig++-- | 'tabs' returning the 'TabResponse', which also reports a closed tab.+{-# INLINE tabs' #-}+tabs' :: (Foldable f, Eq a, Ui :> es) => a -> f (Tab a (Eff es ())) -> Eff es (TabResponse a)+tabs' = tabsConfigured' defaultTabsConfig++-- | 'tabs' with a header style and placement.+tabsConfigured :: (Foldable f, Eq a, Ui :> es) => TabsConfig -> a -> f (Tab a (Eff es ())) -> Eff es a+tabsConfigured cfg active inputTabs =+  let ts = foldr (:) [] inputTabs+   in snd <$> tabStrip cfg active ts (Just (renderBody ts))++tabsConfigured' :: (Foldable f, Eq a, Ui :> es) => TabsConfig -> a -> f (Tab a (Eff es ())) -> Eff es (TabResponse a)+tabsConfigured' cfg active inputTabs =+  let ts = foldr (:) [] inputTabs+   in fst <$> tabStrip cfg active ts (Just (renderBody ts))++-- | Tab headers only; the caller renders the body.+{-# INLINE tabBar #-}+tabBar :: (Foldable f, Eq a, Ui :> es) => a -> f (Tab a body) -> Eff es a+tabBar = tabBarConfigured defaultTabsConfig++{-# INLINE tabBar' #-}+tabBar' :: (Foldable f, Eq a, Ui :> es) => a -> f (Tab a body) -> Eff es (TabResponse a)+tabBar' = tabBarConfigured' defaultTabsConfig++tabBarConfigured :: (Foldable f, Eq a, Ui :> es) => TabsConfig -> a -> f (Tab a body) -> Eff es a+tabBarConfigured cfg active ts = snd <$> tabStrip cfg active (foldr (:) [] ts) Nothing++tabBarConfigured' :: (Foldable f, Eq a, Ui :> es) => TabsConfig -> a -> f (Tab a body) -> Eff es (TabResponse a)+tabBarConfigured' cfg active ts = fst <$> tabStrip cfg active (foldr (:) [] ts) Nothing++renderBody :: (Eq a, Ui :> es) => [Tab a (Eff es ())] -> a -> Eff es ()+renderBody ts activeKey =+  columnWith (tight . fillW) $+    case find ((== activeKey) . tabKey) ts of+      Just selected -> tabBody selected+      Nothing -> maybe (pure ()) tabBody (listToMaybe ts)
+ lib/NanoUI/Widgets/TextArea.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE BangPatterns #-}++-- | The multi-line text area widget and its state: the document buffer,+-- caret and selection, viewport, and commands run against it.+module NanoUI.Widgets.TextArea+  ( -- * Pure state+    TextAreaState (..)+  , initTextAreaState+  , setTextAreaViewport+  , setTextAreaSelection+    -- * Widget+  , textArea+  , textArea'+  , textAreaWith+  , textAreaWith'+  , textAreaLayout+  , loadTextAreaState+  , loadTextAreaStateWithBuffer+  , saveTextAreaState+  , textAreaEditor+  , runTextAreaCommand+  , applyTextAreaCommand+  ) where++import Control.Monad (foldM, when)+import Data.Dynamic (fromDynamic, toDyn)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.IntMap.Strict as IM+import Effectful (Eff, type (:>))+import NanoUI.Context+  ( Context (..)+  , damageWidget+  , getStore+  , intKey+  , markDirty+  , registerFocusable+  , setStore+  , setTextInputDrag+  , modifyStore+  )+import NanoUI.Font (fmLineHeight)+import NanoUI.Id (WidgetId)+import NanoUI.Input+  ( Input (..)+  , inputChars+  , inputKeys+  , inputKeysNull+  )+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)+import NanoUI.Store+  ( WidgetStore (..)+  , slotKey+  , Slot (..)+  )+import NanoUI.Style (FontStyle (..), FontVariant (..), FontWeight (..), Layout (..), Sizing (..), defaultLayout)+import NanoUI.Types (DamageBounds (..), clamp)+import NanoUI.Widgets.Behavior (keyboardFocused)+import NanoUI.Widgets.Node (Response, addWidget, setChanged)+import qualified NanoUI.Widgets.TextBuffer as TB+import NanoUI.Widgets.TextEditor+  ( Editor (..)+  , EditHistory+  , TextCommand (..)+  , inputTextCommands+  , editorModeCode+  , emptyHistory+  , multiLineMode+  , runCommand+  , runCommandIO+  , sealHistory+  )++data TextAreaState = TextAreaState+  { buffer :: !TB.TextBuffer+  , selectionAnchor :: !TB.Cursor+  , scrollOffset :: !(Double, Double)+  , viewportSize :: !(Double, Double)+  , lineHeight :: !Double+  , history :: !EditHistory+  }+  deriving (Show)++initTextAreaState :: T.Text -> TextAreaState+initTextAreaState initial =+  TextAreaState+    { buffer = TB.fromText initial+    , selectionAnchor = TB.Cursor 0 0+    , scrollOffset = (0.0, 0.0)+    , viewportSize = (0.0, 0.0)+    , lineHeight = 16.0+    , history = emptyHistory+    }++setTextAreaViewport :: (Double, Double) -> Double -> TextAreaState -> TextAreaState+setTextAreaViewport vp lh state =+  state {viewportSize = vp, lineHeight = lh}++cursorOf :: TextAreaState -> TB.Cursor+cursorOf state = TB.getCursor (buffer state)++setTextAreaSelection :: TB.Cursor -> TB.Cursor -> TextAreaState -> TextAreaState+setTextAreaSelection anchor cursor state =+  let buf =+        let b = TB.withCursor cursor (buffer state)+         in b {TB.preferredCol = TB.cursorCol cursor}+   in ensureCaretVisible state {buffer = buf, selectionAnchor = anchor}++textAreaEditor :: TextAreaState -> Editor+textAreaEditor state = Editor (buffer state) (selectionAnchor state) (history state)++withEditor :: TextAreaState -> Editor -> TextAreaState+withEditor state ed =+  ensureCaretVisible state {buffer = editorBuffer ed, selectionAnchor = editorAnchor ed, history = editorHistory ed}++-- | Run a command that needs no clipboard, keeping the caret in view.+runTextAreaCommand :: TextCommand -> TextAreaState -> TextAreaState+runTextAreaCommand cmd state = withEditor state (runCommand multiLineMode cmd (textAreaEditor state))++ensureCaretVisible :: TextAreaState -> TextAreaState+ensureCaretVisible state =+  let TB.Cursor r _ = TB.getCursor (buffer state)+      lh = lineHeight state+      vh = snd (viewportSize state)+      (sx, sy) = scrollOffset state+      caretY = fromIntegral r * lh+      caretH = lh+      contentH = fromIntegral (TB.getLineCount (buffer state)) * lh+      maxSy = max 0 (contentH - vh)+      sy'+        | vh <= 0 = 0+        | caretY < sy = caretY+        | caretY + caretH > sy + vh = caretY + caretH - vh+        | otherwise = sy+  in state {scrollOffset = (sx, clamp 0 maxSy sy')}++--------------------------------------------------------------------------------+-- Widget+--------------------------------------------------------------------------------++textAreaLayout :: Layout+textAreaLayout =+  defaultLayout+    { layoutWidth = Grow 1+    , layoutMinW = 200+    , layoutHeight = Fixed 140+    }++-- | Multi-line text editor. Pass the current text; the result is the text+-- after this frame's edits. Pair it with a 'label' when a caption is wanted.+{-# INLINE textArea #-}+textArea :: Ui :> es => Text -> Eff es Text+textArea value = snd <$> textAreaWith' id value++{-# INLINE textArea' #-}+textArea' :: Ui :> es => Text -> Eff es (Response, Text)+textArea' = textAreaWith' id++-- | 'textArea' with a modifier applied to 'textAreaLayout', for example+-- 'grow' to fill the parent.+{-# INLINE textAreaWith #-}+textAreaWith :: Ui :> es => (Layout -> Layout) -> Text -> Eff es Text+textAreaWith f value = snd <$> textAreaWith' f value++textAreaWith' :: Ui :> es => (Layout -> Layout) -> Text -> Eff es (Response, Text)+textAreaWith' f value = do+  wid <- nextId+  ctx <- askContext+  uiIO $ registerFocusable ctx wid+  inp <- askInput+  store0 <- uiIO (getStore ctx)+  let layout = f textAreaLayout+      key = intKey wid+      seenKey = slotKey SlotSeen key+      contentCacheKey = slotKey SlotTextAreaContentFont key+      changedSlotKey = slotKey SlotTextAreaChanged key+      texts0 = storeText store0+      replaced = IM.lookup key texts0 /= Just value+  -- Adopt the caller's text the way 'adoptStoreText' does. A replaced document+  -- orphans any cached buffer or content size for the key. Seed the scroll+  -- slot too: the wheel and drag paths write offsets through+  -- setScrollOffset2D, which only updates the text area's slot once it exists.+  -- Its undo history, recorded against the old text, goes with them.+  when (IM.lookup seenKey texts0 /= Just value) $+    uiIO $ setStore ctx+      store0+        { storeText = IM.insert seenKey value (IM.insert key value texts0)+        , storePoint = IM.insertWith (\_ old -> old) (slotKey SlotTextAreaScroll key) (0, 0) (storePoint store0)+        , storeFloat = if replaced then IM.delete contentCacheKey (storeFloat store0) else storeFloat store0+        , storeDyn =+            if replaced+              then IM.delete (slotKey SlotTextHistory key) (IM.delete (slotKey SlotTextAreaBuffer key) (storeDyn store0))+              else storeDyn store0+        , storeInt = IM.insert (slotKey SlotTextMode key) (editorModeCode multiLineMode) (storeInt store0)+        }+  store <- uiIO (getStore ctx)+  let current = IM.findWithDefault value key (storeText store)+      -- Set by commands run outside the frame ('applyTextAreaCommand') whose+      -- edits carry no keys or chars; folded into 'changed' so the caller+      -- gets its respChanged pulse, then cleared in the state write below.+      menuPulse = IM.member changedSlotKey (storeInt store)+  isFocus <- keyboardFocused wid+  (newText, stateChanged) <-+    if isFocus+      then do+        editFm <-+          if layoutFontSize layout <= 0+            then pure (ctxFontMetrics ctx)+            else fst <$> uiIO (ctxResolveFont ctx (layoutFontSize layout) WeightNormal FontStyleNormal FontRegular)+        let oldState = loadTextAreaState store key value+            s1 = setTextAreaViewport (viewportSize oldState) (realToFrac (fmLineHeight editFm)) oldState+            hadInput = not (T.null (inputChars inp)) || not (inputKeysNull (inputKeys inp))+        newState <- uiIO $ do+          when hadInput $ setTextInputDrag ctx Nothing+          case inputTextCommands multiLineMode inp of+            [] -> pure s1+            cmds -> withEditor s1 <$> foldM (flip (runCommandIO ctx multiLineMode)) (textAreaEditor s1) cmds+        let newText+              -- Commands only come from keys or chars, so idle focused frames+              -- skip the O(document) 'TB.toText' and stop at the cheap+              -- cursor/scroll checks.+              | hadInput || changed = TB.toText (buffer newState)+              | otherwise = current+            changed =+              cursorOf newState /= cursorOf oldState+                || selectionAnchor newState /= selectionAnchor oldState+                || scrollOffset newState /= scrollOffset oldState+                || menuPulse+                || (hadInput && newText /= current)+        -- Saving writes the new text and its buffer together; drop only the+        -- content size measured for the old text, and the menu pulse. The+        -- store damage is keyed on slots, not the widget, so damage the widget+        -- itself: a selection-only change (Ctrl+A) would otherwise repaint+        -- nothing until the next frame.+        when changed $+          uiIO $ do+            damageWidget ctx wid DamageSelf+            modifyStore ctx $ \st0 ->+              let st = saveTextAreaState key newText newState st0+               in st+                    { storeText = IM.insert seenKey newText (storeText st)+                    , storeInt = IM.delete changedSlotKey (storeInt st)+                    , storeFloat = IM.delete contentCacheKey (storeFloat st)+                    }+        pure (newText, changed)+      else do+        -- A command run on the unfocused area ('applyTextAreaCommand') still+        -- pulses this frame's respChanged, once.+        when menuPulse $+          uiIO $ modifyStore ctx $ \st -> st {storeInt = IM.delete changedSlotKey (storeInt st)}+        pure (current, menuPulse)+  resp <- addWidget wid NodeTextArea "" 0 layout+  pure (setChanged stateChanged resp, newText)++loadTextAreaState :: WidgetStore -> Int -> Text -> TextAreaState+loadTextAreaState store key initial =+  let text = IM.findWithDefault initial key (storeText store)+      -- The buffer cache is written together with storeText by+      -- saveTextAreaState, so a present entry is always the buffer for the+      -- stored text; no (O(document)) re-comparison is needed.+      cachedBuffer :: Maybe TB.TextBuffer =+        IM.lookup (slotKey SlotTextAreaBuffer key) (storeDyn store) >>= fromDynamic+      buf0 = case cachedBuffer of+        Just cached -> cached+        Nothing -> TB.fromText text+   in loadTextAreaStateWithBuffer store key buf0++-- | 'loadTextAreaState' with the buffer already resolved (the paint path+-- ensures the buffer cache and hands it straight through, avoiding a second+-- store lookup).+loadTextAreaStateWithBuffer :: WidgetStore -> Int -> TB.TextBuffer -> TextAreaState+loadTextAreaStateWithBuffer store key buf0 =+  let row = IM.findWithDefault 0 (slotKey SlotTextAreaRow key) (storeInt store)+      col = IM.findWithDefault 0 (slotKey SlotTextAreaCol key) (storeInt store)+      anchorRow = IM.findWithDefault row (slotKey SlotTextAreaAnchorRow key) (storeInt store)+      anchorCol = IM.findWithDefault col (slotKey SlotTextAreaAnchorCol key) (storeInt store)+      pref = IM.findWithDefault col (slotKey SlotTextAreaPrefCol key) (storeInt store)+      scroll =+        let (sx, sy) =+              IM.findWithDefault (0, 0) (slotKey SlotTextAreaScroll key) (storePoint store)+         in (realToFrac sx, realToFrac sy)+      viewport =+        let (vw, vh) =+              IM.findWithDefault (200, 96) (slotKey SlotTextAreaViewport key) (storePoint store)+         in (realToFrac vw, realToFrac vh)+      buf =+        let b = TB.withCursor (TB.Cursor row col) buf0+         in b {TB.preferredCol = pref}+      anchor = TB.getCursor (TB.withCursor (TB.Cursor anchorRow anchorCol) buf0)+      -- Replacing the document drops its history, so the recorded text is+      -- always the current one here.+      hist = case IM.lookup (slotKey SlotTextHistory key) (storeDyn store) >>= fromDynamic of+        Just (_ :: Text, h) -> h+        Nothing -> emptyHistory+   in TextAreaState+        { buffer = buf+        , selectionAnchor = anchor+        , scrollOffset = scroll+        , viewportSize = viewport+        , lineHeight = 16+        , history = hist+        }++-- | Store the editor state with its text. Callers pass the text because they+-- usually have it already, and 'TB.toText' joins the whole document.+saveTextAreaState :: Int -> Text -> TextAreaState -> WidgetStore -> WidgetStore+saveTextAreaState key text state store =+  let TB.Cursor row col = TB.getCursor (buffer state)+      TB.Cursor anchorRow anchorCol = selectionAnchor state+   in store+        { storeText = IM.insert key text (storeText store)+        , storeDyn =+            IM.insert (slotKey SlotTextAreaBuffer key) (toDyn (buffer state)) $+              IM.insert (slotKey SlotTextHistory key) (toDyn (text, history state)) (storeDyn store)+        , storeInt =+            IM.insert (slotKey SlotTextAreaRow key) row $+              IM.insert (slotKey SlotTextAreaCol key) col $+                IM.insert (slotKey SlotTextAreaPrefCol key) (TB.preferredCol (buffer state)) $+                  IM.insert (slotKey SlotTextAreaAnchorRow key) anchorRow $+                    IM.insert (slotKey SlotTextAreaAnchorCol key) anchorCol (storeInt store)+        , storePoint =+            IM.insert (slotKey SlotTextAreaScroll key) (realToFrac sx, realToFrac sy) $+              IM.insert (slotKey SlotTextAreaViewport key) (realToFrac vw, realToFrac vh) (storePoint store)+        }+  where+    (sx, sy) = scrollOffset state+    (vw, vh) = viewportSize state++-- | Run a command on a text area outside its frame (a context menu row, an+-- app's Edit menu). A change to the text pulses 'respChanged' on the area's+-- next frame.+applyTextAreaCommand :: Context -> WidgetId -> TextCommand -> IO ()+applyTextAreaCommand ctx wid cmd = do+  store <- getStore ctx+  let key = intKey wid+      text = IM.findWithDefault "" key (storeText store)+      s0 = loadTextAreaState store key text+  s1 <- withEditor s0 <$> runCommandIO ctx multiLineMode cmd (textAreaEditor s0 {history = sealHistory (history s0)})+  let newText = TB.toText (buffer s1)+      saved = saveTextAreaState key newText s1 store+  -- A changed text also drops the content size measured for the old one.+  setStore ctx $+    if newText == text+      then saved+      else+        saved+          { storeInt = IM.insert (slotKey SlotTextAreaChanged key) 1 (storeInt saved)+          , storeFloat = IM.delete (slotKey SlotTextAreaContentFont key) (storeFloat saved)+          }+  -- Store damage is keyed on slots, not the widget: damage the widget so a+  -- selection-only command (Select All) repaints this frame.+  damageWidget ctx wid DamageSelf+  markDirty ctx
+ lib/NanoUI/Widgets/TextBuffer.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE BangPatterns #-}++-- | A text document as a finger tree of lines with a cursor. Every change is+-- a 'TextEdit': replace the text at a position with other text. An edit+-- touches only the lines it spans, so edits, cursor moves and line lookups+-- cost O(log lines) plus the size of the lines involved, however long the+-- document is.+module NanoUI.Widgets.TextBuffer+  ( -- * Types+    TextBuffer (..)+  , Cursor (..)+  , TextEdit (..)++    -- * Construction & Conversion+  , empty+  , fromText+  , toText+  , toLines+  , lineAt++    -- * Cursor & Metrics+  , getCursor+  , getLineCount+  , withCursor+  , clampCursor+  , changedLines+  , markLinesSeen++    -- * Navigation+  , moveLeft+  , moveRight+  , moveUp+  , moveDown+  , moveToBOL+  , moveToEOL+  , moveToTop+  , moveToBottom+  , moveWordLeft+  , moveWordRight++    -- * Selection+  , selectionRange+  , selectedText+  , textRange+  , documentEnd++    -- * Edits+  , applyEdit+  , invertEdit+  , replaceEdit+  , insertableText+  )+where++import Control.Monad (when)+import Control.Monad.ST (runST)+import Data.Char (isPrint, isSpace)+import Data.Foldable (toList)+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Array qualified as A+import Data.Text.Internal (Text (..))++-- | Zero-indexed logical (row, column) position in the buffer. Fields are+-- row then column, so the derived 'Ord' is document order.+data Cursor = Cursor+  { cursorRow :: {-# UNPACK #-} !Int+  , cursorCol :: {-# UNPACK #-} !Int+  }+  deriving (Eq, Ord, Show)++-- | Lines (never empty, and without their newlines) and the cursor.+data TextBuffer = TextBuffer+  { bufferLines :: !(Seq Text)+  , bufferCursor :: {-# UNPACK #-} !Cursor+  , preferredCol :: {-# UNPACK #-} !Int+  -- ^ The column vertical motion aims for, kept while moving through+  -- shorter lines.+  , bufferSeenHead :: {-# UNPACK #-} !Int+  , bufferSeenTail :: {-# UNPACK #-} !Int+  -- ^ Lines at the start and the end that no edit has touched since+  -- 'markLinesSeen', so what was derived from them (their measured widths)+  -- still holds. See 'changedLines'.+  }+  deriving (Eq, Show)++-- | Replace 'editRemoved' at 'editAt' with 'editInserted'. Both texts may+-- span lines. An edit carries what it removes, so it can be inverted without+-- looking at the document.+data TextEdit = TextEdit+  { editAt :: {-# UNPACK #-} !Cursor+  , editRemoved :: !Text+  , editInserted :: !Text+  }+  deriving (Eq, Show)++-- | A TextBuffer containing a single blank line.+empty :: TextBuffer+empty = TextBuffer (Seq.singleton T.empty) (Cursor 0 0) 0 0 0++-- | Construct a TextBuffer from raw Text. Cursor is always (0, 0).+fromText :: Text -> TextBuffer+fromText t = TextBuffer (Seq.fromList (T.splitOn "\n" t)) (Cursor 0 0) 0 0 0++-- | All lines joined with newlines, copied once into a new text.+toText :: TextBuffer -> Text+toText buf =+  let lns = bufferLines buf+      !total = foldl' (\acc (Text _ _ len) -> acc + len + 1) (-1) lns+   in if total <= 0+        then T.empty+        else runST $ do+          dest <- A.new total+          let copyLine (Text arr start len) next !off = do+                A.copyI len dest off arr start+                when (off + len < total) $ A.unsafeWrite dest (off + len) 10+                next (off + len + 1)+          foldr copyLine (\_ -> pure ()) lns 0+          frozen <- A.unsafeFreeze dest+          pure (Text frozen 0 total)++toLines :: TextBuffer -> [Text]+toLines = toList . bufferLines++-- | The text of a row, or empty outside the document.+lineAt :: Int -> TextBuffer -> Text+lineAt row buf = fromMaybe T.empty (Seq.lookup row (bufferLines buf))++getCursor :: TextBuffer -> Cursor+getCursor = bufferCursor++getLineCount :: TextBuffer -> Int+getLineCount = Seq.length . bufferLines++-- | How many lines at the start and at the end are the ones there at the last+-- 'markLinesSeen'; the lines between may have changed. Whatever was derived+-- per line from the marked document can be kept for those lines and+-- rederived for the rest.+changedLines :: TextBuffer -> (Int, Int)+changedLines buf = (bufferSeenHead buf, bufferSeenTail buf)++-- | Record that every line has been seen, for 'changedLines'.+markLinesSeen :: TextBuffer -> TextBuffer+markLinesSeen buf = let n = getLineCount buf in buf {bufferSeenHead = n, bufferSeenTail = n}++-- | The nearest position inside the document.+clampCursor :: TextBuffer -> Cursor -> Cursor+clampCursor buf (Cursor row col) =+  let !r = max 0 (min (getLineCount buf - 1) row)+      !c = max 0 (min (T.length (lineAt r buf)) col)+   in Cursor r c++-- | Move to a position, clamped into the document, without changing text.+withCursor :: Cursor -> TextBuffer -> TextBuffer+withCursor cur buf =+  let c = clampCursor buf cur+   in buf {bufferCursor = c, preferredCol = cursorCol c}++--------------------------------------------------------------------------------+-- Navigation+--------------------------------------------------------------------------------++moveLeft :: TextBuffer -> TextBuffer+moveLeft buf = withCursor (positionLeft buf (getCursor buf)) buf++moveRight :: TextBuffer -> TextBuffer+moveRight buf = withCursor (positionRight buf (getCursor buf)) buf++positionLeft :: TextBuffer -> Cursor -> Cursor+positionLeft buf (Cursor row col)+  | col > 0 = Cursor row (col - 1)+  | row > 0 = Cursor (row - 1) (T.length (lineAt (row - 1) buf))+  | otherwise = Cursor 0 0++positionRight :: TextBuffer -> Cursor -> Cursor+positionRight buf (Cursor row col)+  | col < T.length (lineAt row buf) = Cursor row (col + 1)+  | row + 1 < getLineCount buf = Cursor (row + 1) 0+  | otherwise = Cursor row col++moveUp :: TextBuffer -> TextBuffer+moveUp = moveByRow (-1)++moveDown :: TextBuffer -> TextBuffer+moveDown = moveByRow 1++moveByRow :: Int -> TextBuffer -> TextBuffer+moveByRow d buf =+  let Cursor row _ = getCursor buf+      goal = preferredCol buf+   in buf {bufferCursor = clampCursor buf (Cursor (row + d) goal)}++moveToBOL :: TextBuffer -> TextBuffer+moveToBOL buf = withCursor (Cursor (cursorRow (getCursor buf)) 0) buf++moveToEOL :: TextBuffer -> TextBuffer+moveToEOL buf =+  let row = cursorRow (getCursor buf)+   in withCursor (Cursor row (T.length (lineAt row buf))) buf++moveToTop :: TextBuffer -> TextBuffer+moveToTop = withCursor (Cursor 0 0)++moveToBottom :: TextBuffer -> TextBuffer+moveToBottom buf = withCursor (documentEnd buf) buf++-- | Back over spaces (line breaks count), then over the word before them.+moveWordLeft :: TextBuffer -> TextBuffer+moveWordLeft buf = withCursor (wordLeft buf (getCursor buf)) buf++-- | Forward over spaces (line breaks count), then over the word after them.+moveWordRight :: TextBuffer -> TextBuffer+moveWordRight buf = withCursor (wordRight buf (getCursor buf)) buf++wordLeft :: TextBuffer -> Cursor -> Cursor+wordLeft buf (Cursor row col) =+  let before = T.take col (lineAt row buf)+      spaces = T.length (T.takeWhileEnd isSpace before)+      inWord = col - spaces+   in if inWord == 0 && row > 0+        -- Only spaces back to the line start: the line break is one more.+        then wordLeft buf (Cursor (row - 1) (T.length (lineAt (row - 1) buf)))+        else Cursor row (inWord - T.length (T.takeWhileEnd (not . isSpace) (T.take inWord before)))++wordRight :: TextBuffer -> Cursor -> Cursor+wordRight buf (Cursor row col) =+  let after = T.drop col (lineAt row buf)+      spaces = T.length (T.takeWhile isSpace after)+      rest = T.drop spaces after+   in if T.null rest && row + 1 < getLineCount buf+        then wordRight buf (Cursor (row + 1) 0)+        else Cursor row (col + spaces + T.length (T.takeWhile (not . isSpace) rest))++--------------------------------------------------------------------------------+-- Edits+--------------------------------------------------------------------------------++-- | Apply an edit and leave the cursor after the inserted text. The removed+-- text decides how far the edit reaches, so an edit recorded against this+-- document (or undone from one) is applied without reading the text it+-- removes.+applyEdit :: TextEdit -> TextBuffer -> TextBuffer+applyEdit (TextEdit at removed inserted) buf =+  let Cursor row col = clampCursor buf at+      Cursor endRow endCol = advance (Cursor row col) removed+      lns = bufferLines buf+      first = lineAt row buf+      lastLine = lineAt endRow buf+      prefix = T.take col first+      suffix = T.drop endCol lastLine+      newLines = case T.splitOn "\n" inserted of+        firstPiece : rest@(_ : _) ->+          Seq.fromList ((prefix <> firstPiece) : init rest ++ [last rest <> suffix])+        _ -> Seq.singleton (prefix <> inserted <> suffix)+      spliced = Seq.take row lns <> newLines <> Seq.drop (min (Seq.length lns) (endRow + 1)) lns+      end = advance (Cursor row col) inserted+      untouchedTail = Seq.length spliced - (row + Seq.length newLines)+   in TextBuffer spliced end (cursorCol end) (min row (bufferSeenHead buf)) (min untouchedTail (bufferSeenTail buf))++-- | The position after walking over @txt@ from @cur@.+advance :: Cursor -> Text -> Cursor+advance (Cursor row col) txt =+  case T.count "\n" txt of+    0 -> Cursor row (col + T.length txt)+    breaks -> Cursor (row + breaks) (T.length (T.takeWhileEnd (/= '\n') txt))++-- | The edit that takes the document back.+invertEdit :: TextEdit -> TextEdit+invertEdit (TextEdit at removed inserted) = TextEdit at inserted removed++-- | The edit replacing the text between two positions.+replaceEdit :: Text -> Cursor -> Cursor -> TextBuffer -> TextEdit+replaceEdit inserted a b buf =+  let (lo, hi) = selectionRange (clampCursor buf a) (clampCursor buf b)+   in TextEdit lo (textRange lo hi buf) inserted++-- | Text as it can enter the document: printable characters, tabs and line+-- breaks, with Windows line ends folded.+insertableText :: Text -> Text+insertableText = T.filter (\c -> isPrint c || c == '\t' || c == '\n') . T.replace "\r\n" "\n"++--------------------------------------------------------------------------------+-- Selection+--------------------------------------------------------------------------------++selectionRange :: Cursor -> Cursor -> (Cursor, Cursor)+selectionRange a b = (min a b, max a b)++selectedText :: Cursor -> Cursor -> TextBuffer -> Text+selectedText a b buf =+  let (lo, hi) = selectionRange (clampCursor buf a) (clampCursor buf b)+   in textRange lo hi buf++-- | The text between two positions in document order, reading only the lines+-- between them.+textRange :: Cursor -> Cursor -> TextBuffer -> Text+textRange (Cursor loRow loCol) (Cursor hiRow hiCol) buf+  | loRow == hiRow = T.take (hiCol - loCol) (T.drop loCol (lineAt loRow buf))+  | otherwise =+      let middle = toList (Seq.take (hiRow - loRow - 1) (Seq.drop (loRow + 1) (bufferLines buf)))+       in T.intercalate "\n" (T.drop loCol (lineAt loRow buf) : middle ++ [T.take hiCol (lineAt hiRow buf)])++documentEnd :: TextBuffer -> Cursor+documentEnd buf =+  let row = getLineCount buf - 1+   in Cursor row (T.length (lineAt row buf))
+ lib/NanoUI/Widgets/TextCommand.hs view
@@ -0,0 +1,49 @@+-- | The commands text fields run: the same ones for keys, context menus and+-- app code.+module NanoUI.Widgets.TextCommand+  ( TextCommand (..)+  , TextMotion (..)+  ) where++import Data.Text (Text)+import NanoUI.Widgets.TextBuffer (Cursor)++-- | Where a motion takes the cursor.+data TextMotion+  = CharLeft+  | CharRight+  | WordLeft+  | WordRight+  | LineStart+  | LineEnd+  | LineUp+  | LineDown+  | DocumentStart+  | DocumentEnd+  deriving (Eq, Show, Enum, Bounded)++-- | Something done to a text field. Commands that change text are undoable+-- and replace the selection where one exists.+data TextCommand+  = -- | Replace the selection with text (typing, a snippet).+    InsertText !Text+  | -- | Delete the selection, or from the cursor to where the motion lands:+    -- @Delete CharLeft@ is Backspace, @Delete WordRight@ Ctrl+Delete.+    Delete !TextMotion+  | -- | Move the cursor, extending the selection when the flag is set.+    Move !TextMotion !Bool+  | SelectAll+  | -- | Select from the first position (the anchor) to the second (the+    -- cursor), clamped into the document.+    Select !Cursor !Cursor+  | -- | Replace the text between two positions, leaving the cursor after it.+    Replace !Cursor !Cursor !Text+  | -- | Replace the whole document as one undoable edit.+    ReplaceAll !Text+  | Undo+  | Redo+  | Cut+  | Copy+  | Paste+  deriving (Eq, Show)+
+ lib/NanoUI/Widgets/TextCommon.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE BangPatterns #-}++module NanoUI.Widgets.TextCommon+  ( -- * Character classes and word boundaries+    TextCharClass (..)+  , textCharClass+  , textWordBounds+    -- * Selection and caret helpers+  , textSelectionForClick+  , textSelectionForDrag+  , selectionCaretGeom+  ) where++import Data.Char (isAlphaNum, isSpace)+import Data.Text (Text)+import qualified Data.Text as T+import NanoUI.Types (clamp)++-- | Character classification for double-click word selection.+data TextCharClass = TextWord | TextSpace | TextOther+  deriving (Eq)++textCharClass :: Char -> TextCharClass+textCharClass c+  | isAlphaNum c || c == '_' = TextWord+  | isSpace c = TextSpace+  | otherwise = TextOther++-- | Find the word bounds around a character position in text.+textWordBounds :: Text -> Int -> (Int, Int)+textWordBounds text raw+  | T.null text = (0, 0)+  | otherwise =+      -- Split once: repeatedly indexing UTF-8 text makes long-word selection+      -- quadratic. The clamped index guarantees a non-empty suffix.+      let i = clamp 0 (T.length text - 1) raw+          (before, after) = T.splitAt i text+          sameClass = (== textCharClass (T.head after)) . textCharClass+       in ( i - T.length (T.takeWhileEnd sameClass before)+          , i + T.length (T.takeWhile sameClass after)+          )++-- | Calculate selection span for single/double/triple click.+textSelectionForClick :: Text -> Int -> Int -> (Int, Int)+textSelectionForClick value idx clicks+  | clicks >= 3 = (0, T.length value)+  | clicks == 2 = textWordBounds value idx+  | otherwise = (idx, idx)++-- | Calculate selection span when dragging mouse across text.+textSelectionForDrag :: Text -> Int -> Int -> Int -> (Int, Int)+textSelectionForDrag value anchor idx clicks+  | clicks >= 3 = (0, T.length value)+  | clicks == 2 =+      let (a0, a1) = textWordBounds value anchor+          (c0, c1) = textWordBounds value idx+       in (min a0 c0, max a1 c1)+  | otherwise = (anchor, idx)++-- | Shared caret geometry (caretX, caretY, caretH).+{-# INLINE selectionCaretGeom #-}+selectionCaretGeom :: Float -> Float -> Float -> Float -> (Float, Float, Float)+selectionCaretGeom originX originY pw lineH =+  (originX + pw, originY + 1, max 4 (lineH - 2))
+ lib/NanoUI/Widgets/TextEditor.hs view
@@ -0,0 +1,347 @@+-- | The editing core every text field shares: a document, a selection and an+-- undo history, changed only by 'TextCommand's. Keys and menu rows map onto+-- commands, and an app can run the same commands on a field.+module NanoUI.Widgets.TextEditor+  ( -- * Commands+    TextCommand (..)+  , TextMotion (..)+    -- * Editors+  , Editor (..)+  , EditorMode (..)+  , singleLineMode+  , multiLineMode+  , editorModeCode+  , editorModeFromCode+  , editorFromBuffer+  , editorSelection+  , hasSelection+  , runCommand+  , runCommandIO+    -- * Key bindings+  , inputTextCommands+  , keyCommand+    -- * History+  , EditHistory (..)+  , EditGroup (..)+  , StoredEdit (..)+  , EditKind (..)+  , emptyHistory+  , sealHistory+  , canUndo+  , canRedo+  ) where++import Control.Monad (void, when)+import Data.Bits ((.&.), (.|.))+import Data.Char (isPrint, isSpace, toLower)+import Data.Text qualified as T+import Data.Text.Short qualified as TS+import NanoUI.Context (Context (..))+import NanoUI.Input (Input (..), Key (..), Modifiers (..))+import NanoUI.Widgets.TextBuffer (Cursor (..), TextBuffer, TextEdit (..))+import NanoUI.Widgets.TextCommand (TextCommand (..), TextMotion (..))+import NanoUI.Widgets.TextBuffer qualified as TB++-- | How a field lets its document be changed.+data EditorMode = EditorMode+  { modeMultiLine :: !Bool+  , modeEditable :: !Bool+  -- ^ Off for selectable labels: only motion, selection and copy apply.+  , modeCopyable :: !Bool+  -- ^ Off for passwords: nothing reaches the clipboard.+  }+  deriving (Eq, Show)++singleLineMode :: EditorMode+singleLineMode = EditorMode {modeMultiLine = False, modeEditable = True, modeCopyable = True}++multiLineMode :: EditorMode+multiLineMode = singleLineMode {modeMultiLine = True}++-- | A mode as a store integer, so a command sent to a widget id between+-- frames knows what kind of field it edits.+editorModeCode :: EditorMode -> Int+editorModeCode m =+  8+    .|. (if modeMultiLine m then 1 else 0)+    .|. (if modeEditable m then 0 else 2)+    .|. (if modeCopyable m then 0 else 4)++editorModeFromCode :: Int -> Maybe EditorMode+editorModeFromCode code+  | code .&. 8 == 0 = Nothing+  | otherwise =+      Just+        EditorMode+          { modeMultiLine = code .&. 1 /= 0+          , modeEditable = code .&. 2 == 0+          , modeCopyable = code .&. 4 == 0+          }++-- | A document with its selection (the cursor is the buffer's, the anchor+-- the other end) and history.+data Editor = Editor+  { editorBuffer :: !TextBuffer+  , editorAnchor :: !Cursor+  , editorHistory :: !EditHistory+  }+  deriving (Show)++editorFromBuffer :: TextBuffer -> Editor+editorFromBuffer buf = Editor buf (TB.getCursor buf) emptyHistory++-- | @(anchor, cursor)@.+editorSelection :: Editor -> (Cursor, Cursor)+editorSelection ed = (editorAnchor ed, TB.getCursor (editorBuffer ed))++hasSelection :: Editor -> Bool+hasSelection ed = editorAnchor ed /= TB.getCursor (editorBuffer ed)++--------------------------------------------------------------------------------+-- History+--------------------------------------------------------------------------------++-- | What started a group of edits, which decides what may join it.+data EditKind = EditTyping | EditDeleting | EditOther+  deriving (Eq, Show)++-- | An edit as history keeps it. Undo steps live for the life of a field and+-- are rarely replayed, so their texts are compact copies: they cost two+-- words less than a 'T.Text', and never keep alive the larger text a slice+-- was cut from.+data StoredEdit = StoredEdit !Cursor !TS.ShortText !TS.ShortText+  deriving (Eq, Show)++-- | Edits undone and redone as one step.+data EditGroup = EditGroup+  { groupKind :: !EditKind+  , groupEdits :: ![StoredEdit]+  -- ^ Newest first.+  , groupBefore :: !(Cursor, Cursor)+  -- ^ Anchor and cursor before the first edit.+  , groupAfter :: !(Cursor, Cursor)+  -- ^ Anchor and cursor after the last edit.+  }+  deriving (Eq, Show)++data EditHistory = EditHistory+  { historyUndo :: ![EditGroup]+  , historyRedo :: ![EditGroup]+  , historyDepth :: !Int+  -- ^ Length of 'historyUndo'.+  , historyOpen :: !Bool+  -- ^ Whether the next edit may join the newest group. Undo, redo, cursor+  -- moves and commands from outside the field close it.+  }+  deriving (Eq, Show)++emptyHistory :: EditHistory+emptyHistory = EditHistory [] [] 0 False++-- | Start the next edit in a group of its own.+sealHistory :: EditHistory -> EditHistory+sealHistory h = h {historyOpen = False}++canUndo :: EditHistory -> Bool+canUndo = not . null . historyUndo++canRedo :: EditHistory -> Bool+canRedo = not . null . historyRedo++-- | Undo steps kept per field. Older steps are dropped in batches.+maxHistoryDepth :: Int+maxHistoryDepth = 500++-- | Record an edit. Typing joins the group before it while the selection is+-- where that group left it, until a new word starts; consecutive deletes+-- join the same way. Anything else starts a group. Recording clears redo.+record :: EditKind -> (Cursor, Cursor) -> TextEdit -> (Cursor, Cursor) -> EditHistory -> EditHistory+record kind before edit after (EditHistory undos _ depth open) =+  case undos of+    g : rest+      | joins g ->+          EditHistory (g {groupEdits = stored : groupEdits g, groupAfter = after} : rest) [] depth True+    _ ->+      let depth' = depth + 1+          group = EditGroup kind [stored] before after+       in if depth' > maxHistoryDepth + 50+            then EditHistory (take maxHistoryDepth (group : undos)) [] maxHistoryDepth True+            else EditHistory (group : undos) [] depth' True+  where+    stored = StoredEdit (editAt edit) (TS.fromText (editRemoved edit)) (TS.fromText (editInserted edit))+    joins g =+      open+        && kind /= EditOther+        && groupKind g == kind+        && groupAfter g == before+        && (kind /= EditTyping || not (startsWord g))+    -- A letter typed after a space starts a new undo step.+    startsWord g = case (groupEdits g, T.uncons (editInserted edit)) of+      (StoredEdit _ _ prevInserted : _, Just (c, _)) -> not (isSpace c) && maybe False (isSpace . snd) (TS.unsnoc prevInserted)+      _ -> False++--------------------------------------------------------------------------------+-- Commands+--------------------------------------------------------------------------------++-- | Run a command that needs no clipboard. 'Cut', 'Copy' and 'Paste' do+-- nothing here; 'runCommandIO' runs them.+runCommand :: EditorMode -> TextCommand -> Editor -> Editor+runCommand mode cmd ed@(Editor buf anchor hist) =+  case cmd of+    InsertText raw+      | modeEditable mode ->+          let txt = singleLine raw+              kind+                | T.length txt == 1 && txt /= "\n" = EditTyping+                | otherwise = EditOther+           in if T.null txt && not (hasSelection ed) then ed else replaceSelection kind txt+    Delete motion+      | modeEditable mode ->+          if hasSelection ed+            then replaceSelection EditDeleting T.empty+            else+              let target = motionTarget motion+               in if target == cursor+                    then ed+                    else edit EditDeleting (TB.replaceEdit T.empty cursor target buf)+    Move motion extend ->+      let moved = moveBuffer motion+       in Editor moved (if extend then anchor else TB.getCursor moved) (sealHistory hist)+    SelectAll ->+      let end = TB.documentEnd buf+       in Editor (TB.withCursor end buf) (Cursor 0 0) (sealHistory hist)+    Select a c ->+      Editor (TB.withCursor c buf) (TB.clampCursor buf a) (sealHistory hist)+    Replace a b txt+      | modeEditable mode -> edit EditOther (TB.replaceEdit (singleLine txt) a b buf)+    ReplaceAll txt+      | modeEditable mode ->+          edit EditOther (TB.replaceEdit (singleLine txt) (Cursor 0 0) (TB.documentEnd buf) buf)+    Undo -> case historyUndo hist of+      g : rest ->+        let buf' = foldl (\b e -> TB.applyEdit (TB.invertEdit (replayed e)) b) buf (groupEdits g)+            (a, c) = groupBefore g+         in Editor (TB.withCursor c buf') a hist {historyUndo = rest, historyRedo = g : historyRedo hist, historyDepth = historyDepth hist - 1, historyOpen = False}+      [] -> ed+    Redo -> case historyRedo hist of+      g : rest ->+        let buf' = foldr (TB.applyEdit . replayed) buf (groupEdits g)+            (a, c) = groupAfter g+         in Editor (TB.withCursor c buf') a hist {historyUndo = g : historyUndo hist, historyRedo = rest, historyDepth = historyDepth hist + 1, historyOpen = False}+      [] -> ed+    _ -> ed+  where+    cursor = TB.getCursor buf+    replayed (StoredEdit at removed inserted) = TextEdit at (TS.toText removed) (TS.toText inserted)+    singleLine = (if modeMultiLine mode then id else T.filter (/= '\n')) . TB.insertableText+    replaceSelection kind txt = edit kind (TB.replaceEdit txt anchor cursor buf)+    edit kind e+      | editRemoved e == editInserted e = ed+      | otherwise =+      let buf' = TB.applyEdit e buf+          end = TB.getCursor buf'+       in Editor buf' end (record kind (anchor, cursor) e (end, end) hist)+    motionTarget = \case+      -- Deleting to the end of a line from its end takes the line break, so+      -- Ctrl+K keeps making progress.+      LineEnd | T.length (TB.lineAt (cursorRow cursor) buf) == cursorCol cursor -> TB.getCursor (TB.moveRight buf)+      motion -> TB.getCursor (moveBuffer motion)+    moveBuffer = \case+      CharLeft -> TB.moveLeft buf+      CharRight -> TB.moveRight buf+      WordLeft -> TB.moveWordLeft buf+      WordRight -> TB.moveWordRight buf+      LineStart -> TB.moveToBOL buf+      LineEnd -> TB.moveToEOL buf+      LineUp -> if modeMultiLine mode then TB.moveUp buf else buf+      LineDown -> if modeMultiLine mode then TB.moveDown buf else buf+      DocumentStart -> TB.moveToTop buf+      DocumentEnd -> TB.moveToBottom buf++-- | 'runCommand', with the clipboard commands going through the context's+-- clipboard.+runCommandIO :: Context -> EditorMode -> TextCommand -> Editor -> IO Editor+runCommandIO ctx mode cmd ed =+  case cmd of+    Copy -> ed <$ copySelection+    Cut+      | modeEditable mode && modeCopyable mode -> do+          copySelection+          pure (runCommand mode (Delete CharRight) (if hasSelection ed then ed else runCommand mode SelectAll ed))+      | otherwise -> pure ed+    Paste+      | modeEditable mode -> do+          clip <- ctxClipboardGet ctx+          pure (maybe ed (\txt -> runCommand mode (InsertText txt) ed) clip)+      | otherwise -> pure ed+    _ -> pure (runCommand mode cmd ed)+  where+    -- Copy without a selection takes the whole field.+    copySelection = when (modeCopyable mode) $ do+      let (a, c) = editorSelection ed+          buf = editorBuffer ed+          txt = if a /= c then TB.selectedText a c buf else TB.toText buf+      when (not (T.null txt)) $ void (ctxClipboardSet ctx txt)++-- | The command a key runs. Ctrl or Alt turns character and deletion keys+-- into word motions, and Shift extends the selection.+keyCommand :: EditorMode -> Modifiers -> Key -> Maybe TextCommand+keyCommand mode mods key =+  case key of+    KeyBackspace -> Just (Delete (if word then WordLeft else CharLeft))+    KeyDelete -> Just (Delete (if word then WordRight else CharRight))+    KeyLeft -> move (if word then WordLeft else CharLeft)+    KeyRight -> move (if word then WordRight else CharRight)+    KeyHome -> move (if modCtrl mods && multi then DocumentStart else LineStart)+    KeyEnd -> move (if modCtrl mods && multi then DocumentEnd else LineEnd)+    KeyUp | multi && not word -> move LineUp+    KeyDown | multi && not word -> move LineDown+    KeyEnter | multi && not word -> Just (InsertText "\n")+    _ -> Nothing+  where+    multi = modeMultiLine mode+    word = modCtrl mods || modAlt mods+    move m = Just (Move m (modShift mods))++-- | This frame's typing and keys as commands, typed characters first. Ctrl+-- turns characters into shortcuts. Ctrl with Alt is AltGr on many layouts, so+-- its characters are typed like plain ones.+inputTextCommands :: EditorMode -> Input -> [TextCommand]+inputTextCommands mode inp = T.foldr char keys (inputChars inp)+  where+    mods = inputModifiers inp+    shortcut = modCtrl mods && not (modAlt mods)+    char c rest+      | shortcut = maybe rest (: rest) (ctrlCharCommand mode mods c)+      | isPrint c = InsertText (T.singleton c) : rest+      | otherwise = rest+    keys = foldr (\k rest -> maybe rest (: rest) (keyCommand mode mods k)) [] (inputKeys inp)++-- | The command a character typed with Ctrl runs. Letters may arrive as the+-- letter or as their control code.+ctrlCharCommand :: EditorMode -> Modifiers -> Char -> Maybe TextCommand+ctrlCharCommand mode mods c =+  case toLower c of+    'a' -> Just SelectAll+    'c' -> Just Copy+    'x' -> Just Cut+    'v' -> Just Paste+    'z' | modShift mods || c == 'Z' -> Just Redo+    'z' -> Just Undo+    'y' -> Just Redo+    'k' | multi -> Just (Delete LineEnd)+    'u' | multi -> Just (Delete LineStart)+    'e' | multi -> Just (Move LineEnd False)+    '\x01' -> Just SelectAll+    '\x03' -> Just Copy+    '\x18' -> Just Cut+    '\x16' -> Just Paste+    '\x1a' -> Just Undo+    '\x19' -> Just Redo+    '\v' | multi -> Just (Delete LineEnd)+    '\NAK' | multi -> Just (Delete LineStart)+    '\ENQ' | multi -> Just (Move LineEnd False)+    _ -> Nothing+  where+    multi = modeMultiLine mode
+ lib/NanoUI/Widgets/TextField.hs view
@@ -0,0 +1,97 @@+-- | Commands run on a text field from outside its frame: an app's Edit menu,+-- a toolbar button, the field's own context menu.+module NanoUI.Widgets.TextField+  ( runTextCommand+  , textCanUndo+  , textCanRedo+  , applyTextFieldCommand+  , textFieldMode+  , textFieldHistory+  ) where++import Data.Dynamic (fromDynamic)+import Data.IORef (writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Effectful (Eff, type (:>))+import NanoUI.Context (Context (..), WidgetStore (..), getStore, intKey, setTextInputMenu)+import NanoUI.Frame.Hit (findNodeByWidgetId)+import NanoUI.Id (WidgetId)+import NanoUI.Layout.Arena (NodeType (..), getNodeType, getStyleIdx)+import NanoUI.Monad (Ui, askContext, uiIO)+import NanoUI.Store (slotKey, Slot (..))+import NanoUI.Widgets.TextArea (applyTextAreaCommand)+import NanoUI.Widgets.TextEditor+  ( EditHistory+  , EditorMode (..)+  , TextCommand+  , canRedo+  , canUndo+  , editorModeFromCode+  , emptyHistory+  , multiLineMode+  )+import NanoUI.Widgets.TextInput (applyTextInputCommand, textInputMode)++-- | Run a command on the text field (text input, search field, text area)+-- with this id, as if its keys were pressed: @runTextCommand (respId resp)+-- Undo@. The field takes keyboard focus, and its next frame returns the+-- changed text and a 'NanoUI.respChanged' pulse. An id that is not a text+-- field is ignored.+runTextCommand :: Ui :> es => WidgetId -> TextCommand -> Eff es ()+runTextCommand wid cmd = do+  ctx <- askContext+  uiIO (applyTextFieldCommand ctx wid cmd)++-- | Whether 'NanoUI.Widgets.TextCommand.Undo' would change the field, for+-- enabling a menu item.+textCanUndo :: Ui :> es => WidgetId -> Eff es Bool+textCanUndo wid = do+  ctx <- askContext+  uiIO (canUndo <$> textFieldHistory ctx wid)++-- | Whether 'NanoUI.Widgets.TextCommand.Redo' would change the field, for+-- enabling a menu item.+textCanRedo :: Ui :> es => WidgetId -> Eff es Bool+textCanRedo wid = do+  ctx <- askContext+  uiIO (canRedo <$> textFieldHistory ctx wid)++-- | Run a command on the field with this id and focus it: the command comes+-- from a menu or button that may not be over the field, and the caret,+-- selection highlight and next keystroke belong to the field it edited.+applyTextFieldCommand :: Context -> WidgetId -> TextCommand -> IO ()+applyTextFieldCommand ctx wid cmd =+  textFieldMode ctx wid >>= \case+    Just mode -> do+      if modeMultiLine mode+        then applyTextAreaCommand ctx wid cmd+        else applyTextInputCommand ctx wid mode cmd+      writeIORef (ctxFocusId ctx) wid+      setTextInputMenu ctx Nothing+    Nothing -> pure ()++-- | How the field with this id edits: from its node when it has one this+-- frame, or from what it recorded the last time it was declared.+textFieldMode :: Context -> WidgetId -> IO (Maybe EditorMode)+textFieldMode ctx wid =+  findNodeByWidgetId ctx wid >>= \case+    Just idx ->+      getNodeType (ctxNodeArena ctx) idx >>= \case+        NodeTextInput -> Just . textInputMode <$> getStyleIdx (ctxNodeArena ctx) idx+        NodeTextArea -> pure (Just multiLineMode)+        _ -> pure Nothing+    Nothing -> do+      store <- getStore ctx+      pure (IM.lookup (slotKey SlotTextMode (intKey wid)) (storeInt store) >>= editorModeFromCode)++-- | The undo history of the field with this id, empty when it has none.+textFieldHistory :: Context -> WidgetId -> IO EditHistory+textFieldHistory ctx wid = do+  store <- getStore ctx+  let key = intKey wid+      stored = IM.lookup (slotKey SlotTextHistory key) (storeDyn store)+      text = IM.findWithDefault "" key (storeText store)+  pure $ case stored >>= fromDynamic of+    Just (recorded, h) | recorded == (text :: Text) -> h+    _ -> emptyHistory
+ lib/NanoUI/Widgets/TextInput.hs view
@@ -0,0 +1,413 @@+-- | Single-line text fields: editable inputs, debounced search fields, and+-- selectable read-only labels, plus the key handling they share.+module NanoUI.Widgets.TextInput+  ( TextInputState (..)+  , loadTextInputState+  , saveTextInputState+  , textInputLayout+  , searchFieldLayout+  , textInputEditor+  , editorTextState+  , saveTextEditor+  , editTextInput+  , textInputMode+  , applyTextInputCommand+    -- * Text fields+  , TextInputConfig (..)+  , defaultTextInputConfig+  , textInput+  , textInput'+  , textInputConfigured+  , textInputConfigured'+  , SearchFieldConfig (..)+  , defaultSearchFieldConfig+  , searchField+  , searchField'+  , searchFieldConfigured+  , searchFieldConfigured'+  , buildTextInput+  , editTextField+    -- * Selectable text+  , selectableText+  , selectableText'+  , selectableTextWith+  , selectableTextWith'+  )+where++import Control.Monad (foldM, void, when)+import Data.Bits ((.|.))+import Data.IntMap.Strict qualified as IM+import Data.Dynamic (fromDynamic, toDyn)+import Data.Maybe (fromMaybe, isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Effectful (Eff, type (:>))+import GHC.Clock (getMonotonicTime)+import NanoUI.Context+  ( Context (..)+  , adoptStoreText+  , getStore+  , intKey+  , markDirty+  , recordStoreText+  , registerFocusable+  , setStore+  , modifyStore+  )+import NanoUI.Id (WidgetId)+import NanoUI.Input+  ( Input (..)+  , Key (..)+  , inputKeys+  )+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, uiIO)+import NanoUI.Store (WidgetStore (..), Slot (..), slotKey)+import NanoUI.Style (Layout (..), Sizing (..), defaultLayout)+import NanoUI.WidgetText (packTextNodeStyleFull, textInputFlagPassword, textInputFlagSearch, textInputFlagSelectable, textInputPasswordMode, textInputSelectableMode)+import NanoUI.Widgets.Behavior (keyboardFocused)+import NanoUI.Widgets.Node (Response (..), addWidgetStyled, setChanged, setSubmitted)+import NanoUI.Widgets.TextBuffer qualified as TB+import NanoUI.Widgets.TextEditor+  ( Editor (..)+  , EditorMode (..)+  , TextCommand (..)+  , inputTextCommands+  , editorModeCode+  , emptyHistory+  , runCommandIO+  , sealHistory+  , singleLineMode+  )++textInputLayout :: Layout+textInputLayout =+  defaultLayout+    { layoutWidth = Grow 1+    , layoutMinW = 160+    }++-- | Layout for a caption-less search field. Grows to fill, keeps a little more+-- room for the embedded magnifier / clear chrome than a plain text input.+searchFieldLayout :: Layout+searchFieldLayout =+  defaultLayout+    { layoutWidth = Grow 1+    , layoutMinW = 180+    }++data TextInputState = TextInputState+  { tisText :: !Text+  , tisCursor :: !Int+  , tisAnchor :: !Int+  }+  deriving (Eq, Show)++-- | A field's cursor and anchor for @text@; the cursor defaults to the end+-- and the anchor to the cursor. Both are clamped to the text, which can have+-- been replaced from outside the field with a shorter one.+loadTextInputState :: WidgetStore -> Int -> Text -> TextInputState+loadTextInputState store key text =+  let len = T.length text+      cursor = min len (IM.findWithDefault len (slotKey SlotCursor key) (storeInt store))+      anchor = min len (IM.findWithDefault cursor (slotKey SlotAnchor key) (storeInt store))+   in TextInputState text cursor anchor++saveTextInputState :: Int -> TextInputState -> WidgetStore -> WidgetStore+saveTextInputState key s store =+  store+    { storeText = IM.insert key (tisText s) (storeText store)+    , storeInt =+        IM.insert (slotKey SlotCursor key) (tisCursor s) $+          IM.insert (slotKey SlotAnchor key) (tisAnchor s) (storeInt store)+    }++-- | The editor for a field's state, with the undo history stored for it. A+-- history recorded against other text (the caller replaced the value) is+-- dropped.+textInputEditor :: WidgetStore -> Int -> TextInputState -> Editor+textInputEditor store key s =+  let buf = TB.withCursor (TB.Cursor 0 (tisCursor s)) (TB.fromText (tisText s))+      history = case IM.lookup (slotKey SlotTextHistory key) (storeDyn store) >>= fromDynamic of+        Just (text, h) | text == tisText s -> h+        _ -> emptyHistory+   in Editor buf (TB.clampCursor buf (TB.Cursor 0 (tisAnchor s))) history++editorTextState :: Editor -> TextInputState+editorTextState ed =+  let buf = editorBuffer ed+   in TextInputState (TB.toText buf) (TB.cursorCol (TB.getCursor buf)) (TB.cursorCol (editorAnchor ed))++-- | Store an editor's text, selection and history.+saveTextEditor :: Int -> Editor -> WidgetStore -> WidgetStore+saveTextEditor key ed store =+  let s = editorTextState ed+      saved = saveTextInputState key s store+   in saved {storeDyn = IM.insert (slotKey SlotTextHistory key) (toDyn (tisText s, editorHistory ed)) (storeDyn saved)}++-- | Run this frame's commands on a field, or 'Nothing' when it had none.+editTextInput :: Context -> EditorMode -> Input -> WidgetStore -> Int -> TextInputState -> IO (Maybe Editor)+editTextInput ctx mode inp store key s0 =+  case inputTextCommands mode inp of+    [] -> pure Nothing+    cmds -> Just <$> foldM (flip (runCommandIO ctx mode)) (textInputEditor store key s0) cmds++-- | The editor mode of a single-line field with these style flags.+textInputMode :: Int -> EditorMode+textInputMode si =+  singleLineMode+    { modeEditable = not (textInputSelectableMode si)+    , modeCopyable = not (textInputPasswordMode si)+    }++-- | Run a command on a single-line field outside its frame (a context menu+-- row, an app's Edit menu). A change to the text pulses 'respChanged' on the+-- field's next frame.+applyTextInputCommand :: Context -> WidgetId -> EditorMode -> TextCommand -> IO ()+applyTextInputCommand ctx wid mode cmd = do+  store <- getStore ctx+  let+    key = intKey wid+    s0 = loadTextInputState store key (IM.findWithDefault "" key (storeText store))+  let ed0 = textInputEditor store key s0+  ed <- runCommandIO ctx mode cmd ed0 {editorHistory = sealHistory (editorHistory ed0)}+  let s1 = editorTextState ed+      saved = saveTextEditor key ed store+  setStore ctx $+    if tisText s1 /= tisText s0+      then saved {storeInt = IM.insert (slotKey SlotTextAreaChanged key) 1 (storeInt saved)}+      else saved+  markDirty ctx++-- -----------------------------------------------------------------------------+-- Text fields+-- -----------------------------------------------------------------------------++data TextInputConfig = TextInputConfig+  { ticPlaceholder :: !Text+  , ticPassword :: !Bool+  , ticLayout :: !Layout+  }+  deriving (Eq, Show)++defaultTextInputConfig :: TextInputConfig+defaultTextInputConfig =+  TextInputConfig+    { ticPlaceholder = ""+    , ticPassword = False+    , ticLayout = textInputLayout+    }++-- | Single-line text field. Pass the current text; the result is the text+-- after this frame's typing, pastes, and menu edits.+{-# INLINE textInput #-}+textInput :: Ui :> es => Text -> Eff es Text+textInput value = snd <$> textInputConfigured' defaultTextInputConfig value++{-# INLINE textInput' #-}+textInput' :: Ui :> es => Text -> Eff es (Response, Text)+textInput' = textInputConfigured' defaultTextInputConfig++-- | 'textInput' with a placeholder, password masking, or its own layout.+--+-- @+-- secret' <- textInputConfigured defaultTextInputConfig {ticPassword = True} secret+-- @+{-# INLINE textInputConfigured #-}+textInputConfigured :: Ui :> es => TextInputConfig -> Text -> Eff es Text+textInputConfigured cfg value = snd <$> textInputConfigured' cfg value++textInputConfigured' :: Ui :> es => TextInputConfig -> Text -> Eff es (Response, Text)+textInputConfigured' cfg value =+  buildTextInput+    (if ticPassword cfg then textInputFlagPassword else 0)+    (ticLayout cfg)+    (ticPlaceholder cfg)+    value+    Nothing++-- | One frame of a single-line field's text state: load the text (seeding+-- @initial@ on first use) with its cursor and anchor, run the editor while+-- focused, and save any change. While unfocused, @unfocusedText@ (when given)+-- replaces the stored text, so a field that mirrors another value follows it.+-- Returns the text before and after this frame, whether it is focused, and+-- whether a command run from outside the frame changed it.+editTextField :: Ui :> es => WidgetId -> EditorMode -> Text -> Maybe Text -> Eff es (Text, Text, Bool, Bool)+editTextField wid mode initial unfocusedText = do+  ctx <- askContext+  uiIO $ registerFocusable ctx wid+  inp <- askInput+  store <- uiIO (getStore ctx)+  let+    key = intKey wid+    modeKey = slotKey SlotTextMode key+    pulseKey = slotKey SlotTextAreaChanged key+    stored = IM.lookup key (storeText store)+    s0 = loadTextInputState store key (fromMaybe initial stored)+    pulse = IM.member pulseKey (storeInt store)+  when (isNothing stored || IM.lookup modeKey (storeInt store) /= Just (editorModeCode mode) || pulse) $+    uiIO $ modifyStore ctx $ \st -> st+      { storeText = if isNothing stored then IM.insert key initial (storeText st) else storeText st+      , storeInt = IM.delete pulseKey (IM.insert modeKey (editorModeCode mode) (storeInt st))+      }+  isFocus <- keyboardFocused wid+  mEdited <- if isFocus then uiIO (editTextInput ctx mode inp store key s0) else pure Nothing+  let s1 = case mEdited of+        Just ed -> editorTextState ed+        Nothing -> maybe s0 (\t -> s0 {tisText = t}) unfocusedText+  when (s1 /= s0) $+    uiIO $ modifyStore ctx (maybe (saveTextInputState key s1) (saveTextEditor key) mEdited)+  pure (tisText s0, tisText s1, isFocus, pulse)++-- | Shared single-line field builder. The caller's @value@ is adopted as by+-- 'NanoUI.Context.adoptStoreText'. @styleIdx@ may carry the search or password+-- flag on a @NodeTextInput@; when @mDebounceMs@ is present the returned change+-- pulse is delayed until the text has been idle for that long (immediate for+-- clear clicks).+buildTextInput ::+  Ui :> es =>+  Int ->+  Layout ->+  Text ->+  Text ->+  Maybe Float ->+  Eff es (Response, Text)+buildTextInput styleIdx layout placeholder value mDebounceMs = do+  wid <- nextId+  ctx <- askContext+  let key = intKey wid+  _ <- uiIO $ adoptStoreText ctx wid key value+  -- Both modes are constants, so an idle field allocates no mode record.+  let mode = if textInputPasswordMode styleIdx then singleLineMode {modeCopyable = False} else singleLineMode+  (oldText, newText, isFocus, pulse) <- editTextField wid mode value Nothing+  uiIO $ recordStoreText ctx key newText+  inp <- askInput+  let submitted = isFocus && KeyEnter `elem` inputKeys inp+      edited = pulse || newText /= oldText+  changed <- case mDebounceMs of+    Nothing -> pure edited+    Just ms -> uiIO (debounceSearchChanged ctx key isFocus edited ms)+  resp <- addWidgetStyled wid NodeTextInput placeholder 0 layout styleIdx+  pure (setSubmitted submitted (setChanged changed resp), newText)++-- | Debounced change pulse for a search field. Fires when the text differs from+-- the last committed query and either the field is empty, lost focus, or has+-- been idle for @ms@ (trailing edge). Field text lives under @key@; the last+-- committed query under 'SlotSearchCommitted'.+debounceSearchChanged :: Context -> Int -> Bool -> Bool -> Float -> IO Bool+debounceSearchChanged ctx key focused rawChanged ms = do+  store <- getStore ctx+  let+    committedKey = slotKey SlotSearchCommitted key+    ageKey = slotKey SlotSearchAge key+    fieldText = IM.findWithDefault "" key (storeText store)+    committedMissing = not (IM.member committedKey (storeText store))+    committed = IM.findWithDefault fieldText committedKey (storeText store)+    dirty = fieldText /= committed+    needClock = rawChanged || dirty+  now <- if needClock then getMonotonicTime else pure 0+  let+    -- Debounce timing stays in Double: wall-clock seconds as Float lose+    -- resolution at long uptimes (~125 ms at 12 days), which would shift+    -- (or skip) the trailing-edge window.+    lastEdit = IM.findWithDefault now ageKey (storeDouble store)+    deadline = realToFrac ms :: Double+    idleMs = (now - lastEdit) * 1000+    commit =+      not rawChanged+        && dirty+        && (T.null fieldText || not focused || idleMs >= deadline)+  when (rawChanged || commit || committedMissing) $+    modifyStore ctx $ \st ->+      st+        { storeText =+            if commit || committedMissing+              then IM.insert committedKey fieldText (storeText st)+              else storeText st+        , storeDouble =+            if rawChanged || commit+              then IM.insert ageKey now (storeDouble st)+              else storeDouble st+        }+  pure commit++-- | Search field: a caption-less 'NodeTextInput' with an embedded magnifier and+-- clear button. The label acts as the placeholder. Change pulses are debounced+-- (trailing edge); clearing with the embedded button fires immediately.+data SearchFieldConfig = SearchFieldConfig+  { sfcPlaceholder :: !Text+  , sfcDebounceMs :: !Float+  , sfcLayout :: !Layout+  }+  deriving (Eq, Show)++defaultSearchFieldConfig :: SearchFieldConfig+defaultSearchFieldConfig =+  SearchFieldConfig+    { sfcPlaceholder = "Search…"+    , sfcDebounceMs = 300+    , sfcLayout = searchFieldLayout+    }++-- | Search box with a magnifier and a clear button; the first argument is the+-- placeholder. Pass the current text; the result is the text after this+-- frame. 'respChanged' on 'searchField'' is debounced: it fires once typing+-- pauses, or at once when the field is cleared.+{-# INLINE searchField #-}+searchField :: Ui :> es => Text -> Text -> Eff es Text+searchField placeholder value = snd <$> searchField' placeholder value++{-# INLINE searchField' #-}+searchField' :: Ui :> es => Text -> Text -> Eff es (Response, Text)+searchField' placeholder =+  searchFieldConfigured' (defaultSearchFieldConfig {sfcPlaceholder = placeholder})++{-# INLINE searchFieldConfigured #-}+searchFieldConfigured :: Ui :> es => SearchFieldConfig -> Text -> Eff es Text+searchFieldConfigured cfg value = snd <$> searchFieldConfigured' cfg value++searchFieldConfigured' ::+  Ui :> es => SearchFieldConfig -> Text -> Eff es (Response, Text)+searchFieldConfigured' cfg value =+  buildTextInput+    textInputFlagSearch+    (sfcLayout cfg)+    (sfcPlaceholder cfg)+    value+    (Just (sfcDebounceMs cfg))++-- -----------------------------------------------------------------------------+-- Selectable text+-- -----------------------------------------------------------------------------++-- | Read-only text that can be selected with the mouse and copied with Ctrl+C.+{-# INLINE selectableText #-}+selectableText :: Ui :> es => Text -> Eff es ()+selectableText = selectableTextWith id++{-# INLINE selectableText' #-}+selectableText' :: Ui :> es => Text -> Eff es Response+selectableText' = selectableTextWith' id++{-# INLINE selectableTextWith #-}+selectableTextWith :: Ui :> es => (Layout -> Layout) -> Text -> Eff es ()+selectableTextWith f txt = void (selectableTextWith' f txt)++selectableTextWith' :: Ui :> es => (Layout -> Layout) -> Text -> Eff es Response+selectableTextWith' f txt = do+  layout <- f <$> askDefaultLayout+  wid <- nextId+  ctx <- askContext+  -- The caller owns the text; the editor only moves the selection.+  _ <- uiIO $ adoptStoreText ctx wid (intKey wid) txt+  _ <- editTextField wid singleLineMode {modeEditable = False} txt Nothing+  let styleIdx =+        textInputFlagSelectable+          .|. packTextNodeStyleFull+                (layoutFontVariant layout)+                (layoutFontWeight layout)+                (layoutFontStyle layout)+                (layoutTextDecoration layout)+                0+  addWidgetStyled wid NodeTextInput txt 0 layout styleIdx
+ lib/NanoUI/Widgets/Tree.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module NanoUI.Widgets.Tree (TreeItem (..), tree, tree') where++import Control.Applicative ((<|>))+import Control.Monad (when)+import Data.IORef (writeIORef)+import Data.Foldable (fold, toList)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Primitive.SmallArray (SmallArray, indexSmallArray, mapSmallArray', sizeofSmallArray, smallArrayFromList)+import Effectful (Eff, type (:>))+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+import NanoUI.Context (Context (..), adoptStoreInt, getFocusId, getStore, intKey, recordStoreInt, registerFocusable, setStore, writeStoreInt, modifyStore)+import NanoUI.Font (treeChevronRect)+import NanoUI.Frame.Hit (scrollHitRect)+import NanoUI.Id (WidgetId (..), hashWidgetId)+import NanoUI.Input (inputMousePos)+import NanoUI.Layout.Arena (NodeType (..))+import NanoUI.Store (WidgetStore (..))+import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)+import NanoUI.Style (defaultLayout, fillW, gap, tight)+import NanoUI.Types (Rect (..), clamp, rectContains)+import NanoUI.WidgetText (treeEncodeStyle)+import NanoUI.Widgets.Behavior (KeyNav (..), useKeyNav)+import NanoUI.Widgets.Combinators (selectableItem)+import NanoUI.Widgets.Layout (columnWith)+import NanoUI.Widgets.Node (Response (..), setChanged, tagContainer)++data TreeItem = TreeItem {treeItemLabel :: !Text, treeItemChildren :: ![TreeItem]}+  deriving (Eq, Show)++-- | A visible row: pre-order node index, depth, whether it has children, label.+type TreeRow = (Int, Int, Bool, Text)++-- | Nodes in a subtree, its root included.+subtreeSize :: TreeItem -> Int+subtreeSize item = 1 + forestSize (treeItemChildren item)++forestSize :: [TreeItem] -> Int+forestSize = foldl' (\acc x -> acc + subtreeSize x) 0++-- | Visible rows in pre-order, skipping the children of collapsed nodes. One+-- pass: rows come out in order, and a subtree hands the next pre-order index+-- to the continuation that lists its later siblings.+visibleRows :: IS.IntSet -> [TreeItem] -> SmallArray TreeRow+visibleRows expanded items = smallArrayFromList (go 0 0 items (const []))+  where+    go !idx !_ [] k = k idx+    go !idx !depth (item@(TreeItem lbl kids) : rest) k =+      let hasKids = not (null kids)+       in (idx, depth, hasKids, lbl)+            : if hasKids && IS.member idx expanded+              then go (idx + 1) (depth + 1) kids (\next -> go next depth rest k)+              else go (idx + subtreeSize item) depth rest k++-- | Pre-order indices of every node that has children (the default expansion).+parentIndices :: [TreeItem] -> IS.IntSet+parentIndices items = snd (go 0 items IS.empty)+  where+    go !idx [] acc = (idx, acc)+    go !idx (TreeItem _ kids : rest) acc+      | null kids = go (idx + 1) rest acc+      | otherwise = case go (idx + 1) kids (IS.insert idx acc) of+          (next, acc') -> go next rest acc'++treeKeyNav ::+  KeyNav ->+  SmallArray TreeRow ->+  SmallArray Response ->+  WidgetId ->+  Int ->+  IS.IntSet ->+  (Int, IS.IntSet, Maybe WidgetId)+treeKeyNav nav rows resps focus selected expanded+  | hashWidgetId focus == 0 || not moving = (selected, expanded, Nothing)+  | otherwise = case [pos | pos <- [0 .. n - 1], widAt pos == focus] of+      pos : _ -> step pos (indexSmallArray rows pos)+      [] -> (selected, expanded, Nothing)+ where+  moving = knUp nav || knDown nav || knLeft nav || knRight nav || knEnter nav || knSpace nav+  n = sizeofSmallArray rows+  widAt i = rawRespId (indexSmallArray resps i)+  idxAt i = let (idx, _, _, _) = indexSmallArray rows i in idx+  wantToggle = knEnter nav || knSpace nav+  parentPosition pos depth = go (pos - 1)+    where+      go i+        | i < 0 = Nothing+        | otherwise =+            let (_, d, _, _) = indexSmallArray rows i+             in if d < depth then Just i else go (i - 1)+  step pos (nodeIdx, depth, hasKids, _)+    | knDown nav, pos + 1 < n = let p = pos + 1 in (idxAt p, expanded, Just (widAt p))+    | knUp nav, pos > 0 = let p = pos - 1 in (idxAt p, expanded, Just (widAt p))+    | wantToggle, hasKids = (selected, toggle nodeIdx expanded, Nothing)+    | knRight nav, hasKids, not (IS.member nodeIdx expanded) = (selected, IS.insert nodeIdx expanded, Nothing)+    | knLeft nav, hasKids, IS.member nodeIdx expanded = (selected, IS.delete nodeIdx expanded, Nothing)+    | knLeft nav, depth > 0 =+        case parentPosition pos depth of+          Just p -> (idxAt p, expanded, Just (widAt p))+          Nothing -> (nodeIdx, expanded, Nothing)+    | otherwise = (selected, expanded, Nothing)++toggle :: Int -> IS.IntSet -> IS.IntSet+toggle idx s = if IS.member idx s then IS.delete idx s else IS.insert idx s++treeRow :: (Ui :> es) => Int -> TreeRow -> Int -> IS.IntSet -> Eff es (Response, Maybe Int, Maybe IS.IntSet)+treeRow rowIdx (nodeIdx, depth, hasKids, lbl) selectedIdx expandedSet = do+  ctx <- askContext+  inp <- askInput+  let expanded = IS.member nodeIdx expandedSet+      selected = selectedIdx == nodeIdx+      isOdd = odd rowIdx+  resp <- selectableItem NodeTree lbl selected (tight . fillW $ defaultLayout) (treeEncodeStyle nodeIdx depth hasKids expanded isOdd)+  uiIO $ registerFocusable ctx (rawRespId resp)+  if not (rawRespClicked resp)+    then pure (resp, Nothing, Nothing)+    else uiIO $ do+      mrect <- scrollHitRect ctx (rawRespId resp)+      let mouse = inputMousePos inp+          onChevron = case mrect of+            Just rect@(Rect x y w h) ->+              rectContains (treeChevronRect (ctxFontMetrics ctx) x y w h depth) mouse+                && rectContains rect mouse+            _ -> False+      if hasKids && onChevron+        then pure (setChanged False resp, Nothing, Just (toggle nodeIdx expandedSet))+        else pure (setChanged (not selected) resp, Just nodeIdx, Nothing)++-- | Collapsible tree. Rows are numbered in pre-order; pass the selected row+-- and the result is the selection after this frame's click or arrow keys.+-- Expansion is kept by the widget. @key@ distinguishes trees in one scope.+{-# INLINE tree #-}+tree :: (Foldable f, Ui :> es) => Text -> f TreeItem -> Int -> Eff es Int+tree key items index = snd <$> tree' key items index++tree' :: (Foldable f, Ui :> es) => Text -> f TreeItem -> Int -> Eff es (Response, Int)+tree' key inputItems index =+  withKey ("tree:" <> key) $ do+    groupId <- nextId+    ctx <- askContext+    let items = toList inputItems+        groupKey = intKey groupId+        total = forestSize items+        clamped = if total <= 0 then 0 else clamp 0 (total - 1) index+    selected <- uiIO $ adoptStoreInt ctx groupId groupKey clamped+    st <- uiIO (getStore ctx)+    expandedSet <- case IM.lookup groupKey (storeIntSet st) of+      Just expanded -> pure expanded+      Nothing -> do+        let initial = parentIndices items+        uiIO $ setStore ctx (st {storeIntSet = IM.insert groupKey initial (storeIntSet st)})+        pure initial+    let rows = visibleRows expandedSet items+    columnWith (tight . gap 0 . fillW) $ do+      tagContainer groupId+      results <-+        smallArrayFromList+          <$> sequence [withKey i (treeRow rowIdx row selected expandedSet) | rowIdx <- [0 .. sizeofSmallArray rows - 1], let row@(i, _, _, _) = indexSmallArray rows rowIdx]+      let resps = mapSmallArray' (\(r, _, _) -> r) results+          afterClickSel = fromMaybe selected (foldr (\(_, idx, _) rest -> idx <|> rest) Nothing results)+          afterClickExp = fromMaybe expandedSet (foldr (\(_, _, s) rest -> s <|> rest) Nothing results)+      focus <- uiIO (getFocusId ctx)+      nav <- useKeyNav focus+      let (keySel, keyExp, mFocus) = treeKeyNav nav rows resps focus afterClickSel afterClickExp+      uiIO $ do+        writeStoreInt ctx groupId groupKey keySel+        recordStoreInt ctx groupKey keySel+      when (keyExp /= expandedSet) $ uiIO $+        modifyStore ctx (\st' -> st' {storeIntSet = IM.insert groupKey keyExp (storeIntSet st')})+      maybe (pure ()) (\wid -> uiIO $ writeIORef (ctxFocusId ctx) wid) mFocus+      pure (setChanged (keySel /= selected) (fold resps), keySel)
+ nano-ui.cabal view
@@ -0,0 +1,268 @@+cabal-version:      3.4+name:               nano-ui+version:            0.1.0.0+synopsis:           Immediate-mode GUI toolkit for Haskell+description:+    Widgets, layout, and input handling for immediate-mode interfaces. A view+    is a function that runs every frame, and widgets return what the user did.+    Pair it with a window backend such as nano-ui-sdl or nano-ui-rgfw.+license:            MIT+license-file:       LICENSE+author:             goolord+maintainer:         zacharyachurchill@gmail.com+category:           Graphics+homepage:           https://github.com/goolord/nano-ui+bug-reports:        https://github.com/goolord/nano-ui/issues+build-type:         Simple+tested-with:        GHC ==9.10.3 || ==9.14.1+extra-doc-files:+    CHANGELOG.md+    README.md++source-repository head+    type:     git+    location: https://github.com/goolord/nano-ui.git+    subdir:   packages/nano-ui++common extensions+    default-language: GHC2024+    default-extensions:+        DuplicateRecordFields+        MagicHash+        OverloadedStrings+        UnboxedTuples++common rts-options+    ghc-options:+        -rtsopts+        -threaded+        "-with-rtsopts=-N1 -A64m -T -I0"++common test-rts-options+    ghc-options: -rtsopts -threaded "-with-rtsopts=-A8m -H64m -K128m -T"++common warnings+  ghc-options:+    -Wall+    -Wextra+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wmissing-export-lists+    -Wmissing-home-modules+    -Wpartial-fields+    -Wredundant-constraints++-- Tests, benchmarks and executables build against the library and also+-- reject dependencies they never import.+common downstream+    import:           extensions+    import:           warnings+    ghc-options:      -Wunused-packages+    build-depends:+        base >=4.20 && <4.23,+        nano-ui++library+    import:           extensions+    import:           warnings+    exposed-modules:+        NanoUI+        NanoUI.Context+        NanoUI.Context.Types+        NanoUI.Debug+        NanoUI.Id+        NanoUI.Input+        NanoUI.Layout.Arena+        NanoUI.Layout.Solve+        NanoUI.Monad+        NanoUI.Emit+        NanoUI.Testing+        NanoUI.Testing.Assert+        NanoUI.Testing.Harness+        NanoUI.Testing.Runner+        NanoUI.Widgets.TextBuffer+        NanoUI.Widgets.TextCommand+        NanoUI.Widgets.TextEditor+        NanoUI.Widgets.TextField+        NanoUI.Widgets.TextArea+        NanoUI.Widgets.Combo+        NanoUI.Widgets.Custom+        NanoUI.Widgets.RichText+        NanoUI.Widgets.PaneGrid+        NanoUI.Widgets.SplitPane+        NanoUI.Store+        NanoUI.Frame.Hit+        NanoUI.Frame.TextEdit+        NanoUI.Frame.Window+        NanoUI.Runner+        NanoUI.Bidi+        NanoUI.SIMD+        NanoUI.Svg+    other-modules:+        NanoUI.Animatable+        NanoUI.Animation+        NanoUI.Atlas+        NanoUI.Compact+        NanoUI.Context.Animation+        NanoUI.Context.Core+        NanoUI.Context.Drawing+        NanoUI.Context.Overlay+        NanoUI.Context.Scroll+        NanoUI.Damage+        NanoUI.Draw+        NanoUI.Font+        NanoUI.Hooks+        NanoUI.Frame+        NanoUI.Frame.Cursor+        NanoUI.Draw.Arena+        NanoUI.Draw.Shapes+        NanoUI.Draw.Text+        NanoUI.Draw.Types+        NanoUI.Frame.Input+        NanoUI.Frame.Chrome+        NanoUI.Frame.Focus+        NanoUI.Frame.Paint+        NanoUI.Frame.Paint.Types+        NanoUI.Frame.Paint.Widgets+        NanoUI.Frame.Redraw+        NanoUI.Frame.Scroll+        NanoUI.Frame.Scroll.Geometry+        NanoUI.Frame.Select+        NanoUI.Frame.Node+        NanoUI.Frame.Overlay+        NanoUI.Frame.Spans+        NanoUI.Frame.SpanArena+        NanoUI.Frame.TextArea+        NanoUI.Frame.TextArea.Content+        NanoUI.Frame.TextArea.Geometry+        NanoUI.Frame.TextEdit.Menu+        NanoUI.Frame.TextInput+        NanoUI.Style+        NanoUI.Types+        NanoUI.WidgetText+        NanoUI.Widgets.Node+        NanoUI.Widgets.Chrome+        NanoUI.Widgets.Layout+        NanoUI.Widgets.Tabs+        NanoUI.Widgets.Radio+        NanoUI.Widgets.Tree+        NanoUI.Widgets.ColorPicker+        NanoUI.Widgets.Drawing+        NanoUI.Widgets.TextInput+        NanoUI.Widgets.NumericInput+        NanoUI.Widgets.TextCommon+        NanoUI.Widgets.Animate+        NanoUI.Widgets.Overlay+        NanoUI.Widgets.Popup+        NanoUI.Widgets.Menu+        NanoUI.Widgets.Table+        NanoUI.Widgets.Behavior+        NanoUI.Widgets.Combinators+        NanoUI.Widgets.Drop+        NanoUI.Widgets.Button+        NanoUI.Widgets.Checkbox+        NanoUI.Widgets.Display+        NanoUI.Widgets.Select+        NanoUI.Widgets.Slider+    build-depends:+        base >=4.20 && <4.23,+        bytestring >=0.11 && <0.13,+        colonnade >=1.2 && <1.3,+        containers >=0.6.7 && <0.9,+        effectful-core >=2.5 && <2.8,+        ghc-compact >=0.1 && <0.2,+        hashable >=1.4 && <1.6,+        hashtables >=1.3 && <1.5,+        hexml >=0.3.4 && <0.4,+        primitive >=0.8 && <0.10,+        text >=2.0 && <2.2,+        text-short >=0.1.5 && <0.2,+        unordered-containers >=0.2.19 && <0.3,+        vector >=0.13 && <0.14+    hs-source-dirs:   lib++benchmark nano-ui-id-bench+    import:           downstream+    import:           test-rts-options+    type:             exitcode-stdio-1.0+    main-is:          IdBench.hs+    build-depends:+        tasty-bench >=0.3 && <0.6+    hs-source-dirs:   benchmark++test-suite text-buffer-spec+    import:           downstream+    type:             exitcode-stdio-1.0+    main-is:          NanoUI/TextBufferSpec.hs+    build-depends:+        hspec >=2.10 && <2.12,+        text >=2.0 && <2.2+    hs-source-dirs:   test++test-suite nano-ui-test+    import:           downstream+    import:           test-rts-options+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    other-modules:+        Cases+        Cases.Animation+        Cases.Atlas+        Cases.Combo+        Cases.Damage+        Cases.Demo+        Cases.Grid+        Cases.HostDraw+        Cases.Keyboard+        Cases.Cache+        Cases.Runner+        Cases.RichText+        Cases.SIMD+        Cases.Shaping+        Cases.Styling+        Cases.Svg+        Cases.State+        Cases.Table+        Cases.Modal+        Cases.NoThunks+        Cases.Scroll+        Cases.Select+        Cases.Tabs+        Cases.TextInput+        Cases.NumericInput+        Cases.ContextMenu+        Cases.PointerRelease+        Cases.CustomWidget+        Cases.Tooltip+        Cases.Window+    build-depends:+        bytestring,+        containers,+        effectful >=2.5 && <2.8,+        nothunks,+        primitive >=0.8 && <0.10,+        text >=2.0 && <2.2+    hs-source-dirs:   test/integration++executable nano-ui-profile+    import:           downstream+    import:           rts-options+    main-is:          Profile.hs+    hs-source-dirs:   examples+    build-depends:+        primitive >=0.8 && <0.10,+        text >=2.0 && <2.2++-- Compile-time verification of optimization invariants (inspection-testing).+-- Assertions fail the build if GHC stops inlining or starts allocating in the+-- checked bindings, converting silent performance regressions into errors.+test-suite nano-ui-inspection+    import:           downstream+    type:             exitcode-stdio-1.0+    main-is:          Inspection.hs+    ghc-options:      -fplugin=Test.Inspection.Plugin+    build-depends:+        inspection-testing+    hs-source-dirs:   test/inspection
+ test/NanoUI/TextBufferSpec.hs view
@@ -0,0 +1,277 @@+module Main (main) where++import Data.Text qualified as T+import NanoUI.Frame.TextEdit (textWordBounds)+import NanoUI.Input (Input (..), Key (..), Modifiers (..), emptyInput, inputKeysFromList)+import NanoUI.Widgets.TextArea as TA+import NanoUI.Widgets.TextBuffer as TB+import NanoUI.Widgets.TextEditor as TE+import Test.Hspec++main :: IO ()+main = hspec spec++noMods :: Modifiers+noMods = Modifiers False False False++ctrlMods :: Modifiers+ctrlMods = Modifiers False True False++-- | One frame's typed text and keys, with modifiers held.+frameInput :: Modifiers -> T.Text -> [Key] -> Input+frameInput mods chars keys =+  emptyInput {inputChars = chars, inputKeys = inputKeysFromList keys, inputModifiers = mods}++-- | Run one frame of input on a text area.+typeArea :: Modifiers -> T.Text -> [Key] -> TA.TextAreaState -> TA.TextAreaState+typeArea mods chars keys s =+  foldl' (flip TA.runTextAreaCommand) s (TE.inputTextCommands TE.multiLineMode (frameInput mods chars keys))++-- | Run commands on a buffer.+edit :: TE.EditorMode -> [TE.TextCommand] -> TB.TextBuffer -> TB.TextBuffer+edit mode cmds buf = TE.editorBuffer (foldl' (flip (TE.runCommand mode)) (TE.editorFromBuffer buf) cmds)++spec :: Spec+spec = do+  describe "NanoUI.Widgets.TextBuffer" $ do+    it "looks up rows safely after cursor movement and decodes tabs" $ do+      let+        b = TB.withCursor (TB.Cursor 1 1) (TB.fromText "α\tβ\n猫\n")+      map (`TB.lineAt` b) [-1, 0, 1, 2, 3, maxBound]+        `shouldBe` ["", "α\tβ", "猫", "", "", ""]++    it+      "replaces a backwards selection across Unicode lines and places the caret after the insertion" $ do+      let+        b = TB.fromText "αβ\n猫犬\nend"+        start = TB.Cursor 0 1+        end = TB.Cursor 1 1+        replaced = edit TE.multiLineMode [TE.Select end start, TE.InsertText "🙂\nλ"] b+        deleted = edit TE.multiLineMode [TE.Select end start, TE.Delete TE.CharLeft] b+      TB.selectedText end start b `shouldBe` "β\n猫"+      TB.toText replaced `shouldBe` "α🙂\nλ犬\nend"+      TB.getCursor replaced `shouldBe` TB.Cursor 1 1+      TB.toText deleted `shouldBe` "α犬\nend"+      TB.getCursor deleted `shouldBe` start++    it "roundtrips a trailing newline through fromText/toText" $ do+      TB.toText (TB.fromText "a\n") `shouldBe` "a\n"+      TB.toLines (TB.fromText "a\n") `shouldBe` ["a", ""]++    it "inserts a tab that text-zipper would otherwise drop" $ do+      let+        b = edit TE.multiLineMode [TE.InsertText "\t"] TB.empty+      TB.toText b `shouldBe` "\t"+      TB.getCursor b `shouldBe` TB.Cursor 0 1++    it "inserts Unicode, tabs, and newlines while filtering control characters" $ do+      let+        b = edit TE.multiLineMode [TE.InsertText "α\t\n猫\x01"] (TB.withCursor (TB.Cursor 0 1) (TB.fromText "ab"))+      TB.toLines b `shouldBe` ["aα\t", "猫b"]+      TB.getCursor b `shouldBe` TB.Cursor 1 1++    it "empty insertion preserves the preferred column on a short line" $ do+      let+        b = TB.moveDown (TB.withCursor (TB.Cursor 0 4) (TB.fromText "12345\nx\n12345"))+      TB.getCursor (TB.moveDown (edit TE.multiLineMode [TE.InsertText ""] b)) `shouldBe` TB.Cursor 2 4++    it+      "clamps vertical motion at document boundaries without losing the preferred column" $ do+      let+        top = TB.withCursor (TB.Cursor 0 3) (TB.fromText "abcd\nx\n猫猫猫猫")+        bottom = TB.moveDown (TB.moveDown top)+      TB.getCursor (TB.moveUp top) `shouldBe` TB.Cursor 0 3+      TB.getCursor bottom `shouldBe` TB.Cursor 2 3+      TB.getCursor (TB.moveDown bottom) `shouldBe` TB.Cursor 2 3+      TB.getCursor (TB.moveUp (TB.moveUp bottom)) `shouldBe` TB.Cursor 0 3+      TB.getCursor (TB.moveDown TB.empty) `shouldBe` TB.Cursor 0 0+      -- Moving through a shorter line snaps the column and restores it after.+      let+        short = TB.withCursor (TB.Cursor 0 4) (TB.fromText "12345\n12\n12345")+      TB.getCursor (TB.moveDown short) `shouldBe` TB.Cursor 1 2+      TB.getCursor (TB.moveDown (TB.moveDown short)) `shouldBe` TB.Cursor 2 4+      TB.getCursor (TB.moveUp (TB.moveDown (TB.moveDown short))) `shouldBe` TB.Cursor 1 2++    it "finds the document end independently of the current cursor" $ do+      TB.documentEnd (TB.fromText "α\n猫🙂") `shouldBe` TB.Cursor 1 2+      TB.documentEnd (TB.fromText "α\n") `shouldBe` TB.Cursor 1 0+      TB.documentEnd TB.empty `shouldBe` TB.Cursor 0 0++    it "deleting a word left eats trailing whitespace then the previous word" $ do+      let+        deleteWordLeft = TB.toText . edit TE.multiLineMode [TE.Delete TE.WordLeft] . TB.moveToEOL . TB.fromText+      deleteWordLeft "foo " `shouldBe` ""+      deleteWordLeft "foo bar" `shouldBe` "foo "++    it "deleting a word left joins lines at beginning of line" $ do+      let+        b = edit TE.multiLineMode [TE.Delete TE.WordLeft] (TB.moveToBOL (TB.moveDown (TB.fromText "foo\nbar")))+      TB.toText b `shouldBe` "bar"++    it "deleting a word right deletes the word after the cursor" $ do+      TB.toText (edit TE.multiLineMode [TE.Delete TE.WordRight] (TB.fromText "foo bar")) `shouldBe` " bar"++    it "deleting to the line end or start removes the rest of the line on either side" $ do+      TB.toText (edit TE.multiLineMode [TE.Delete TE.LineEnd] (TB.moveRight (TB.fromText "hello"))) `shouldBe` "h"+      TB.toText (edit TE.multiLineMode [TE.Delete TE.LineStart] (TB.moveToEOL (TB.fromText "hello"))) `shouldBe` ""++  describe "NanoUI.Widgets.TextBuffer edits" $ do+    it "applies an edit across lines and inverts it back" $ do+      let+        b0 = TB.fromText "αβ\n猫犬\nend"+        e = TB.replaceEdit "🙂\nλ\nμ" (TB.Cursor 0 1) (TB.Cursor 2 1) b0+        b1 = TB.applyEdit e b0+      TB.editRemoved e `shouldBe` "β\n猫犬\ne"+      TB.toText b1 `shouldBe` "α🙂\nλ\nμnd"+      TB.getCursor b1 `shouldBe` TB.Cursor 2 1+      TB.toText (TB.applyEdit (TB.invertEdit e) b1) `shouldBe` "αβ\n猫犬\nend"++    it "edits the middle of a long document locally" $ do+      let+        doc = T.intercalate "\n" [T.pack (show i) | i <- [1 .. 20000 :: Int]]+        b0 = TB.fromText doc+        insertAt b i = let at = TB.Cursor (5000 + i) 0 in TB.applyEdit (TB.replaceEdit "x\n" at at b) b+        edited = foldl' insertAt b0 [1 .. 500 :: Int]+      TB.getLineCount edited `shouldBe` 20500+      TB.lineAt 5002 edited `shouldBe` "x"++  describe "NanoUI.Widgets.TextEditor" $ do+    let+      run mode = foldl' (flip (TE.runCommand mode))+      typeText mode t ed = run mode ed [TE.InsertText (T.singleton c) | c <- T.unpack t]+      single = TE.editorFromBuffer TB.empty+      text = TB.toText . TE.editorBuffer++    it "undoes typing a word at a time and redoes it" $ do+      let+        typed = typeText TE.singleLineMode "hello world" single+        once = TE.runCommand TE.singleLineMode TE.Undo typed+        twice = TE.runCommand TE.singleLineMode TE.Undo once+      text typed `shouldBe` "hello world"+      text once `shouldBe` "hello "+      text twice `shouldBe` ""+      text (run TE.singleLineMode twice [TE.Redo, TE.Redo]) `shouldBe` "hello world"+      TB.getCursor (TE.editorBuffer once) `shouldBe` TB.Cursor 0 6++    it "joins a run of deletes into one step and restores the selection it replaced" $ do+      let+        typed = typeText TE.singleLineMode "abcdef" single+        deleted = run TE.singleLineMode typed (replicate 3 (TE.Delete TE.CharLeft))+        selected = TE.runCommand TE.singleLineMode (TE.Select (TB.Cursor 0 1) (TB.Cursor 0 3)) deleted+        replaced = TE.runCommand TE.singleLineMode (TE.InsertText "Z") selected+        undone = TE.runCommand TE.singleLineMode TE.Undo replaced+      text deleted `shouldBe` "abc"+      text (TE.runCommand TE.singleLineMode TE.Undo deleted) `shouldBe` "abcdef"+      text replaced `shouldBe` "aZ"+      text undone `shouldBe` "abc"+      TE.editorSelection undone `shouldBe` (TB.Cursor 0 1, TB.Cursor 0 3)++    it "drops redo after a new edit and ignores no-op commands" $ do+      let+        typed = typeText TE.singleLineMode "ab" single+        undone = TE.runCommand TE.singleLineMode TE.Undo typed+        retyped = TE.runCommand TE.singleLineMode (TE.InsertText "c") undone+      TE.canRedo (TE.editorHistory undone) `shouldBe` True+      TE.canRedo (TE.editorHistory retyped) `shouldBe` False+      TE.historyDepth (TE.editorHistory (TE.runCommand TE.singleLineMode (TE.Delete TE.CharLeft) single)) `shouldBe` 0+      text (TE.runCommand TE.singleLineMode (TE.ReplaceAll "c") retyped) `shouldBe` "c"+      TE.historyDepth (TE.editorHistory (TE.runCommand TE.singleLineMode (TE.ReplaceAll "c") retyped))+        `shouldBe` TE.historyDepth (TE.editorHistory retyped)++    it "keeps line breaks out of single-line fields and bounds history depth" $ do+      text (TE.runCommand TE.singleLineMode (TE.InsertText "a\nb") single) `shouldBe` "ab"+      text (TE.runCommand TE.multiLineMode (TE.InsertText "a\r\nb") single) `shouldBe` "a\nb"+      let+        edits = run TE.multiLineMode single (concat (replicate 1000 [TE.InsertText "\n"]))+      TE.historyDepth (TE.editorHistory edits) `shouldSatisfy` (<= 550)+      text (run TE.multiLineMode edits (replicate 2000 TE.Undo)) `shouldSatisfy` (\t -> T.length t >= 450)++    it "undoes a large paste in one step without copying the document per keystroke" $ do+      let+        doc = T.intercalate "\n" (replicate 50000 "some line of text")+        pasted = TE.runCommand TE.multiLineMode (TE.InsertText doc) single+        typed = typeText TE.multiLineMode "tail" pasted+        back = run TE.multiLineMode typed [TE.Undo, TE.Undo]+      text back `shouldBe` ""+      text (run TE.multiLineMode back [TE.Redo, TE.Redo]) `shouldBe` doc <> "tail"++  describe "NanoUI.Widgets.TextArea" $ do+    it "Ctrl+Z undoes and Ctrl+Shift+Z redoes" $ do+      let+        s0 = TA.initTextAreaState ""+        typed = foldl' (\s c -> typeArea noMods (T.singleton c) [] s) s0 ("one two" :: String)+        undone = typeArea ctrlMods "z" [] typed+        redone = typeArea (Modifiers True True False) "z" [] undone+      TB.toText (TA.buffer undone) `shouldBe` "one "+      TB.toText (TA.buffer redone) `shouldBe` "one two"++    it "Ctrl+Alt types characters (AltGr) while Ctrl alone runs shortcuts" $ do+      let+        s0 = typeArea noMods "" [KeyEnd] (TA.initTextAreaState "ab")+        altGr = Modifiers False True True+      TB.toText (TA.buffer (typeArea altGr "@€" [] s0)) `shouldBe` "ab@€"+      TE.inputTextCommands TE.singleLineMode (frameInput altGr "@" [])+        `shouldBe` [TE.InsertText "@"]+      TE.inputTextCommands TE.singleLineMode (frameInput ctrlMods "a" [KeyLeft])+        `shouldBe` [TE.SelectAll, TE.Move TE.WordLeft False]++    it+      "typing and Enter replace a backwards multiline selection and collapse its anchor" $ do+      let+        selected =+          TA.setTextAreaSelection (TB.Cursor 1 1) (TB.Cursor 0 1) $+            TA.initTextAreaState "abc\ndef"+        typed = typeArea noMods "λ" [] selected+        entered = typeArea noMods "" [KeyEnter] selected+      TB.toText (TA.buffer typed) `shouldBe` "aλef"+      TB.getCursor (TA.buffer typed) `shouldBe` TB.Cursor 0 2+      TA.selectionAnchor typed `shouldBe` TB.Cursor 0 2+      TB.toText (TA.buffer entered) `shouldBe` "a\nef"+      TB.getCursor (TA.buffer entered) `shouldBe` TB.Cursor 1 0+      TA.selectionAnchor entered `shouldBe` TB.Cursor 1 0++    it "Ctrl and Alt edit and move by word" $ do+      let+        s0 = TA.initTextAreaState "foo bar"+      mapM_+        ( \mods -> do+            let+              deleted = typeArea mods "" [KeyDelete] s0+              right = typeArea mods "" [KeyRight] s0+              left = typeArea mods "" [KeyLeft] right+            TB.toText (TA.buffer deleted) `shouldBe` " bar"+            TB.getCursor (TA.buffer right) `shouldBe` TB.Cursor 0 3+            TB.getCursor (TA.buffer left) `shouldBe` TB.Cursor 0 0+        )+        [ctrlMods, Modifiers False False True]++    it "scrolls the caret into a one-line viewport" $ do+      let+        s0 =+          TA.setTextAreaViewport (80, 16) 16 $+            TA.initTextAreaState "a\nb"+        s1 = typeArea noMods "" [KeyDown] s0+      TA.scrollOffset s1 `shouldBe` (0, 16)++    it "Ctrl+A and Ctrl+a both select all" $ do+      let+        s0 = TA.initTextAreaState "hello"+        atEnd = typeArea noMods "" [KeyEnd] s0+        fromLower = typeArea ctrlMods "a" [] atEnd+        fromUpper = typeArea ctrlMods "A" [] atEnd+      TB.getCursor (TA.buffer fromLower) `shouldBe` TB.Cursor 0 5+      TA.selectionAnchor fromLower `shouldBe` TB.Cursor 0 0+      TB.getCursor (TA.buffer fromUpper) `shouldBe` TB.Cursor 0 5+      TA.selectionAnchor fromUpper `shouldBe` TB.Cursor 0 0++  describe "text word selection" $ do+    it "groups Unicode words, whitespace and punctuation by character index" $ do+      let+        text = "αβ_猫  🙂!?"+      map (textWordBounds text) [0 .. 8]+        `shouldBe` replicate 4 (0, 4) ++ replicate 2 (4, 6) ++ replicate 3 (6, 9)+    it "clamps clicks outside the text and handles empty text" $ do+      textWordBounds "" 10 `shouldBe` (0, 0)+      textWordBounds "one two" (-10) `shouldBe` (0, 3)+      textWordBounds "one two" 100 `shouldBe` (4, 7)+      textWordBounds (T.replicate 10000 "猫") 5000 `shouldBe` (0, 10000)
+ test/inspection/Inspection.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Compile-time optimization invariants for nano-ui's hot-path coding+-- patterns, checked by the inspection-testing plugin after the optimizer+-- runs. The plugin can only inspect bindings defined in this module, so+-- probes exercise the actual inline SIMD writers. If GHC stops optimizing+-- them, the build fails.+module Main+  ( main+  , solidQuadProbe+  , gradientQuadProbe+  ) where++import Data.Word (Word32, Word8)+import Foreign.Ptr (Ptr)++import Test.Inspection++import NanoUI.SIMD qualified as SIMD++main :: IO ()+main = putStrLn "inspection invariants hold"++-- Inspect actual library calls, not copies of the quad writers. Dynamic+-- offsets, coordinates, colors and indices prevent a constant-only probe from+-- hiding boxing or a failure to inline the shared vertex writer.+solidQuadProbe :: Ptr Word8 -> Ptr Word8 -> Int -> Float -> Word32 -> IO ()+solidQuadProbe vp ip offset x base =+  SIMD.pokeQuadSIMD vp offset ip offset x x x x 0 0 1 1 x x x 1 base++gradientQuadProbe :: Ptr Word8 -> Ptr Word8 -> Int -> Float -> Word32 -> IO ()+gradientQuadProbe vp ip offset x base =+  SIMD.pokeQuadGradientSIMD vp offset ip offset x x x x 0 0+    (x, 0, 0, 1) (0, x, 0, 1) (0, 0, x, 1) (x, x, x, 1) base++inspect $ 'solidQuadProbe `doesNotUse` 'SIMD.pokeQuadSIMD+inspect $ 'solidQuadProbe `doesNotUse` 'SIMD.pokeVertexSIMD+inspect $ hasNoTypeClasses 'solidQuadProbe+inspect $ 'solidQuadProbe `hasNoType` ''[]+-- NoAllocation cannot be used here: on GHC 9.14 unboxed-tuple construction+-- appears as a datacon application, which the plugin (conservatively) counts+-- as allocation. Guard the pattern with type-level checks instead: no boxed+-- tuples/pairs may appear in the inlined poke body.+inspect $ 'solidQuadProbe `hasNoType` ''(,)+inspect $ 'gradientQuadProbe `doesNotUse` 'SIMD.pokeQuadGradientSIMD+inspect $ 'gradientQuadProbe `doesNotUse` 'SIMD.pokeVertexSIMD+inspect $ hasNoTypeClasses 'gradientQuadProbe+inspect $ 'gradientQuadProbe `hasNoType` ''(,,,)
+ test/integration/Cases.hs view
@@ -0,0 +1,857 @@+module Cases+  ( runAspectLayoutTest+  , runCheckboxInitialTest+  , runDrawingTest+  , runEmbedStateTest+  , runEmptyFrameTest+  , runFitMutedWidthTest+  , runGrowSplitTest+  , runHostSlotTest+  , runHoverDamageTest+  , runIdKeyedListTest+  , runKvMultilineHeightTest+  , runImageTest+  , runImageSwapDamageTest+  , runLabelAlignEndTest+  , runLayoutReuseTest+  , runDeepNestingTest+  , runPanelPaintsTest+  , runPaneGridMixedDragTest+  , runPaneGridClippedControlTest+  , runPercentGapShrinkTest+  , runPointerCursorTest+  , runReduceClickTest+  , runReduceMessagesTest+  , runResponsiveWrapTest+  , runSliderFillWidthTest+  , runWidgetNoStringEmitTest+  , runSearchFieldClearTest+  , runSearchFieldDebounceTest+  ) where++import Control.Monad (forM_, void, when)+import Control.Concurrent (threadDelay)+import Data.ByteString qualified as BS+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import Data.Word (Word64)+import Effectful (liftIO)+import Effectful.State.Static.Local (State, evalState, get, modify)+import NanoUI+import NanoUI.Context (Context (..))+import NanoUI.Emit qualified as Emit+import NanoUI.Layout.Arena+  ( NodeType (..)+  , arenaArrays+  , foldNodesM+  , getNodeType+  , getNodeValue+  , tagNodeType+  , treeFirstChild+  , treeNextSibling+  , writeTagEnum+  , writeTree+  )+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt, runClickReduce, withInput)+import NanoUI.Testing.Harness+  ( centerOf+  , checkLabelAlignEndInk+  , clickPair+  , held+  , spanXOf+  , spanYOf+  , tabInp+  , vertUv+  , warmup2+  , warmupDraw+  , withInputOff+  )+import NanoUI.Widgets.SplitPane+  ( GridNode (..)+  , PaneDrop (..)+  , dropPreview+  , dropTargetForPane+  , layoutNode+  , topLevelDropTarget+  )++runIdKeyedListTest :: Context -> IORef Int -> IO ()+runIdKeyedListTest ctx failed = do+  let inp = withInput 200 200+      keyedIds :: [String] -> IO ([WidgetId], [FrameMsg], DrawData, Bool)+      keyedIds keys = runFrame ctx inp (column (mapM (\k -> keyed k nextId) keys))+      idFor :: String -> [String] -> [WidgetId] -> Maybe WidgetId+      idFor key keys ids = lookup key (zip keys ids)+  (idsA, _, _, _) <- keyedIds ["a", "b", "c"]+  (idsPrep, _, _, _) <- keyedIds ["x", "a", "b", "c"]+  (idsApp, _, _, _) <- keyedIds ["a", "b", "c", "y"]+  (idsRev, _, _, _) <- keyedIds ["c", "b", "a"]+  case idsA of+    [a, b, c] -> assert failed (a /= b && b /= c && a /= c)+    _ -> assert failed False+  assertEq failed (idFor "a" ["a", "b", "c"] idsA) (idFor "a" ["x", "a", "b", "c"] idsPrep)+  assertEq failed (idFor "b" ["a", "b", "c"] idsA) (idFor "b" ["a", "b", "c", "y"] idsApp)+  assertEq failed (idFor "c" ["a", "b", "c"] idsA) (idFor "c" ["c", "b", "a"] idsRev)++runFitMutedWidthTest :: Context -> IORef Int -> IO ()+runFitMutedWidthTest ctx failed = do+  let inp = withInput 400 100+      ui = columnWith tight (muted "HelloFitMuted")+  _ <- runFrame ctx inp ui+  spans <- collectTextSpans ctx+  case [w | (Rect _ _ w _, t, _, _, _) <- spans, "HelloFitMuted" `T.isInfixOf` t] of+    (w : _) -> assertGt failed w 8+    _ -> assert failed False++-- | Phase 5A: text and resize changes must invalidate the cached-layout path.+runLayoutReuseTest :: Context -> IORef Int -> IO ()+runLayoutReuseTest ctx failed = do+  let inp = withInput 400 300+      ui1 =+        columnWith (tight . gap 4 . fillW) $ do+          void (label "alpha")+          void (button "beta")+          void (label "gamma delta epsilon")+  _ <- runFrame ctx inp ui1+  -- Frame 2 takes the cached-layout path (same descriptor).+  _ <- runFrame ctx inp ui1+  s1 <- collectTextSpans ctx+  -- Text change invalidates the cached descriptor.+  let ui2 =+        columnWith (tight . gap 4 . fillW) $ do+          void (label "alpha changed")+          void (button "beta")+          void (label "gamma delta epsilon")+  _ <- runFrame ctx inp ui2+  s2 <- collectTextSpans ctx+  assert failed (s2 /= s1)+  -- Width change must not serve the cached placement for width-dependent+  -- (wrapping) layout.+  let wrapUi =+        columnWith (tight . fillW) $+          label "the quick brown fox jumps over the lazy dog repeatedly"+  _ <- runFrame ctx (withInput 600 200) wrapUi+  sw0 <- collectTextSpans ctx+  _ <- runFrame ctx (withInput 180 200) wrapUi+  sw1 <- collectTextSpans ctx+  assert failed (sw1 /= sw0)++-- | Nesting deeper than the initial snapshot-level capacity must still lay+-- out correctly (the level array grows on demand).+runDeepNestingTest :: Context -> IORef Int -> IO ()+runDeepNestingTest ctx failed = do+  let nest :: Int -> NanoUI ()+      nest 0 = void (label "deep")+      nest k = column (nest (k - 1))+  _ <- runFrame ctx (withInput 300 300) (nest 320)+  spans <- collectTextSpans ctx+  assert failed (any (\(_, t, _, _, _) -> t == "deep") spans)++-- | A responsive row stacks its children below the breakpoint and keeps them+-- side by side above it.+runResponsiveWrapTest :: Context -> IORef Int -> IO ()+runResponsiveWrapTest ctx failed = do+  let ui = responsiveRowCol 720 (tight . gap 8 . fillW) $ do+        columnWith (tight . gap 8 . fillW) (card (void (label "LeftTop")) >> card (void (label "LeftBot")))+        card (void (label "Right"))+  _ <- warmup2 ctx (withInput 520 800) ui+  narrow <- collectTextSpans ctx+  case (spanYOf "Right" narrow, spanYOf "LeftBot" narrow) of+    ([ry], [ly]) -> assertGt failed ry (ly + 1)+    _ -> assert failed False+  _ <- warmup2 ctx (withInput 1200 800) ui+  wide <- collectTextSpans ctx+  case (spanXOf "Right" wide, spanXOf "LeftTop" wide) of+    ([rx], [lx]) -> assertGt failed rx (lx + 1)+    _ -> assert failed False++runDrawingTest :: Context -> IORef Int -> IO ()+runDrawingTest ctx failed = do+  let ui =+        drawing (fixedWH 80 40) $ \r ->+          pure+            ( Stroke+                (rectX r)+                (rectY r + rectH r * 0.5)+                (rectX r + rectW r)+                (rectY r + rectH r * 0.5)+                2+                (colorRGBA 255 0 0 255)+            )+      inp = withInput 200 80+  (_, _, draw, _) <- runFrame ctx inp ui+  assert failed (drawIndexCount draw >= 6 && not (drawCmdNull draw))+  (_, _, draw2, _) <- runFrame ctx inp ui+  assert failed (drawIndexCount draw2 >= 6 && not (drawCmdNull draw2))++runPointerCursorTest :: Context -> IORef Int -> IO ()+runPointerCursorTest ctx failed = do+  let inp0 = withInput 200 100+      ui = column $ do+        btn <- button' "Click"+        (cb, _) <- checkbox' "Feature" False+        pure (btn, cb)+      wantAt inp = runFrame ctx inp ui >> pointerCursorWanted ctx inp+  (btn, cb) <- warmup2 ctx inp0 ui+  onButton <- wantAt (inp0 {inputMousePos = centerOf btn})+  assert failed onButton+  offWidgets <- wantAt (inp0 {inputMousePos = V2 (-1) (-1)})+  assert failed (not offWidgets)+  let hoverBox = inp0 {inputMousePos = centerOf cb}+  onBox <- wantAt hoverBox+  assert failed onBox+  pressBox <- wantAt (hoverBox {inputMouseDown = True, inputMousePressed = True, inputMouseReleased = False})+  assert failed pressBox++-- A frame whose UI adds no widgets is an empty frame, not a read of a node+-- that was never added: presses, wheel input, redraw and cursor queries all+-- run on the empty arena. Node 0 starts out as a container that is its own+-- child, so any read of it recurses without end. Widgets added on the next+-- frame still lay out.+runEmptyFrameTest :: Context -> IORef Int -> IO ()+runEmptyFrameTest ctx failed = do+  arrays <- arenaArrays (ctxNodeArena ctx)+  writeTagEnum arrays 0 tagNodeType NodeContainer+  writeTree arrays 0 treeFirstChild 0+  writeTree arrays 0 treeNextSibling (-1)+  let inp0 = (withInput 320 200) {inputMousePos = V2 40 40}+      press = inp0 {inputMouseDown = True, inputMousePressed = True, inputScroll = V2 0 1}+      ui = row $ do+        wid <- currentId+        image (fixedWH 40 24) (ImageId 0)+        pure wid+  _ <- runFrame ctx inp0 (pure ())+  _ <- runFrame ctx press (pure ())+  _ <- needsRedraw ctx inp0 (inp0 {inputMousePos = V2 60 60})+  _ <- uiCursorKind ctx inp0+  _ <- runFrame ctx inp0 ui+  (wid, _, _, _) <- runFrame ctx inp0 ui+  mRect <- getPrevRect ctx wid+  assert failed (maybe False (\(Rect _ _ w h) -> abs (w - 40) <= 0.5 && abs (h - 24) <= 0.5) mRect)++-- Switching an image to another id repaints the image, and only the image:+-- frames swapped inside a page must neither leave a stale frame on screen nor+-- repaint the whole page.+runImageSwapDamageTest :: Context -> IORef Int -> IO ()+runImageSwapDamageTest ctx failed = do+  let px a = BS.pack (concat (replicate 16 [a, 0, 0, 255]))+  ok1 <- registerImage ctx (ImageId 1) 4 4 (px 60)+  ok2 <- registerImage ctx (ImageId 2) 4 4 (px 120)+  assert failed (ok1 && ok2)+  frameRef <- newIORef (ImageId 1)+  let inp0 = withInputOff 320 200+      ui = fmap snd $+        scrollArea (padAll 10 . grow) $+          column $ do+            label "frames"+            wid <- currentId+            image (fixedWH 40 24) =<< uiIO (readIORef frameRef)+            pure wid+  wid <- warmup2 ctx inp0 ui+  _ <- takeDamage ctx+  writeIORef frameRef (ImageId 2)+  _ <- runFrame ctx inp0 ui+  dmg <- takeDamage ctx+  mRect <- getPrevRect ctx wid+  case (dmg, mRect) of+    (DamageClip (Rect dx dy dw dh), Just (Rect ix iy iw ih)) -> do+      assert failed (dx <= ix && dy <= iy && dx + dw >= ix + iw && dy + dh >= iy + ih)+      assert failed (dw * dh < 320 * 200 / 4)+    _ -> assert failed False++runImageTest :: Context -> IORef Int -> IO ()+runImageTest ctx failed = do+  let px a b c = BS.pack (concat (replicate 16 [a, b, c, 255]))+  ok1 <- registerImage ctx (ImageId 1) 4 4 (px 255 0 0)+  ok7 <- registerImage ctx (ImageId 7) 4 4 (px 0 0 255)+  assert failed (ok1 && ok7)+  let inp0 = withInput 320 200+      imgLayout = fixedWH 40 24+      ui = row $ do+        image imgLayout (ImageId 1)+        wid <- currentId+        image imgLayout (ImageId 7)+        pure wid+  (wid, drawData) <- warmupDraw ctx inp0 ui+  mRect <- getPrevRect ctx wid+  case mRect of+    Just (Rect _ _ w h) -> assert failed (abs (w - 40) <= 0.5 && abs (h - 24) <= 0.5)+    Nothing -> assert failed False+  let texCmds = filter (\c -> cmdTextureId c == atlasTextureId) (drawCmdElems drawData)+  assertEq failed (length texCmds) 1+  assert failed (any (\c -> cmdIndexCount c == 12) texCmds)+  (u0, _) <- vertUv drawData 0+  (u4, _) <- vertUv drawData 4+  assert failed (abs (u0 - u4) >= 1e-6)+  -- Fresh ids start above the registered ones and never repeat.+  ((fresh1, fresh2), _, _, _) <- runFrame ctx inp0 ((,) <$> freshImageId <*> freshImageId)+  assertEq failed (map unImageId [fresh1, fresh2]) [8, 9]+  let missing = image imgLayout (ImageId 0)+  _ <- runFrame ctx inp0 missing+  (_, _, missingData, _) <- runFrame ctx inp0 missing+  assert failed (not (any (\c -> cmdTextureId c == atlasTextureId) (drawCmdElems missingData)))++-- | Hover enter and press repaint only the button, and pointer motion inside+-- an already-hovered button does not request a redraw.+runHoverDamageTest :: Context -> IORef Int -> IO ()+runHoverDamageTest ctx failed = do+  let ui = column (button' "OK")+      inp0 = withInputOff 240 80+      assertSmall dmg = case dmg of+        DamageFull -> assert failed False+        DamageClip (Rect _ _ w h) -> assert failed (w * h < 240 * 80 * 0.5)+  _ <- runFrame ctx inp0 ui+  d0 <- takeDamage ctx+  assertEq failed d0 DamageFull+  (resp, _, _, _) <- runFrame ctx inp0 ui+  let V2 cx cy = centerOf resp+      inp1 = inp0 {inputMousePos = V2 cx cy}+      inp2 = inp0 {inputMousePos = V2 (cx + 1) cy}+  needEnter <- needsRedraw ctx inp0 inp1+  assert failed needEnter+  _ <- runFrame ctx inp1 ui+  assertSmall =<< takeDamage ctx+  let drain = inp1 {inputDeltaTime = 1}+  _ <- runFrame ctx drain ui+  needStay <- needsRedraw ctx drain inp2+  assert failed (not needStay)+  let inpClick = inp1 {inputMouseDown = True, inputMousePressed = True}+  needClick <- needsRedraw ctx drain inpClick+  assert failed needClick+  _ <- runFrame ctx inpClick ui+  assertSmall =<< takeDamage ctx+++-- | An unclicked checkbox must keep rendering its initial value; the frame's+-- post-UI value sync must not reset it to unchecked when no state is stored.+runCheckboxInitialTest :: Context -> IORef Int -> IO ()+runCheckboxInitialTest ctx failed = do+  checkedRef <- newIORef True+  let inp0 = withInput 200 100+      ui = column (held checkedRef (checkbox' "Opt"))+  (resp, _) <- warmup2 ctx inp0 ui+  assertCheckboxNodeValue failed ctx 1+  let Rect rx ry _ _ = respRect resp+      (press, release) = clickPair inp0 (V2 (rx + 1) (ry + 0.5))+  _ <- runFrame ctx press ui+  ((_, checked), _, _, _) <- runFrame ctx release ui+  assert failed (not checked)+  assertCheckboxNodeValue failed ctx 0+  -- The toggled value persists on an idle frame.+  ((_, idle), _, _, _) <- runFrame ctx inp0 ui+  assert failed (not idle)+  _ <- runFrame ctx press ui+  ((_, checked2), _, _, _) <- runFrame ctx release ui+  assert failed checked2+  assertCheckboxNodeValue failed ctx 1++assertCheckboxNodeValue :: IORef Int -> Context -> Float -> IO ()+assertCheckboxNodeValue failed ctx expected = do+  let na = ctxNodeArena ctx+  vals <- foldNodesM na (\acc i -> do+    nt <- getNodeType na i+    if nt == NodeCheckbox then (: acc) <$> getNodeValue na i else pure acc) []+  case vals of+    [v] -> assertEq failed v expected+    vs -> assert failed (vs == [expected])++runSliderFillWidthTest :: Context -> IORef Int -> IO ()+runSliderFillWidthTest ctx failed = do+  let inp0 = withInput 400 120+      ui = columnWith fillW (slider' 0 100 0)+  (resp, _) <- warmup2 ctx inp0 ui+  let Rect rx ry rw rh = respRect resp+  assertGt failed rw 300+  let track = sliderTrackBounds rx ry rw rh+      endDrag = V2 (rectX track + rectW track - 2) (rectY track + rectH track / 2)+  ((_, val), _, _, _) <- runFrame ctx (inp0 {inputMousePos = endDrag, inputMouseDown = True, inputMousePressed = True}) ui+  assertGt failed val 90++-- | Percent children size against the row width, and flex like CSS: two 50%+-- columns plus a gap must give back the overflow so the pair lands exactly on+-- the row width (equal halves, no spill past the row's right edge).+runPercentGapShrinkTest :: Context -> IORef Int -> IO ()+runPercentGapShrinkTest ctx failed = do+  let quarters = rowWith (fixedW 200 . tight . gap 0) $ do+        a <- labelWith' (percent 25 . tight) "A"+        b <- labelWith' (percent 75 . tight) "B"+        pure (a, b)+  (qa, qb) <- warmup2 ctx (withInput 200 80) quarters+  assert failed (abs (rectW (respRect qa) - 50) <= 1 && abs (rectW (respRect qb) - 150) <= 1)+  let inp = withInput 300 80+      ui = rowWith (fixedW 206 . tight . gap 6) $ do+        a <- labelWith' (percent 50 . tight) "A"+        b <- labelWith' (percent 50 . tight) "B"+        pure (a, b)+  (a, b) <- warmup2 ctx inp ui+  let Rect xa _ wa _ = respRect a+      Rect xb _ wb _ = respRect b+  assert failed (abs (wa - 100) <= 0.5 && abs (wb - 100) <= 0.5)+  assert failed (abs (xb - (xa + wa + 6)) <= 0.5)++-- | Grow children split the free space by factor with a min-content floor+-- (fixed-width rows, 12px per char in this context):+--+-- * equal split: two fillW labels with unequal text come out equal when both+--   fit their share;+-- * content floor: a child whose content needs more than its share takes+--   exactly its content width and the sibling re-shares what is left;+-- * lock cascade: locking the largest child shrinks the share pool, which+--   must lock the middle child on a later sweep (one sweep would give it 55);+-- * the vertical axis splits the same way. Its spacers keep a non-zero width+--   because prev-rect tracking skips zero-area rects.+runGrowSplitTest :: Context -> IORef Int -> IO ()+runGrowSplitTest ctx failed = do+  let growLabel l txt = respId <$> labelWith' (fillW . l . tight) txt+      growSpacer = currentId <* spacer (Fixed 10) (Grow 1)+      cases :: [(Input, Rect -> Float, NanoUI [WidgetId], [Float])]+      cases =+        [ ( withInput 210 40+          , rectW+          , rowWith (fixedW 210 . tight . gap 0) $+              sequence [growLabel id "A", growLabel id "AAAAA"]+          , [105, 105]+          )+        , ( withInput 200 40+          , rectW+          , rowWith (fixedW 200 . tight . gap 0) $+              sequence [growLabel id "A", growLabel id (T.replicate 15 "A")]+          , [20, 180]+          )+        , ( withInput 240 40+          , rectW+          , rowWith (fixedW 240 . tight . gap 0) $+              sequence [growLabel (minW 12) "A", growLabel (minW 60) "A", growLabel (minW 130) "A"]+          , [50, 60, 130]+          )+        , ( withInput 60 200+          , rectH+          , columnWith (fixedH 200 . tight . gap 0) $+              sequence [growSpacer, growSpacer]+          , [100, 100]+          )+        ]+  forM_ cases $ \(inp, size, ui, want) -> do+    ids <- warmup2 ctx inp ui+    got <- mapM (fmap (maybe 0 size) . getPrevRect ctx) ids+    assertEq failed (length got) (length want)+    forM_ (zip got want) $ \(g, w) -> assert failed (abs (g - w) <= 0.5)++runLabelAlignEndTest :: Context -> IORef Int -> IO ()+runLabelAlignEndTest ctx failed = do+  let+    fm = ctxFontMetrics ctx+    tw = fmAdvance fm ' ' * 2+    boxW = tw + 4+    inp = emptyInput {inputWindowSize = Size (boxW + 8) 8}+    ui =+      rowWith (fixedW boxW . tight . gap 0) $+        labelWith' (fillW . alignEnd . tight) "ab"+  _ <- runFrame ctx inp ui+  (lab, _, _, _) <- runFrame ctx inp ui+  spans <- collectTextSpans ctx+  let+    Rect bx _ bw _ = respRect lab+    hits = [r | (r, txt, _, _, _) <- spans, T.isInfixOf (T.pack "ab") txt]+  case hits of+    [] -> assert failed False+    Rect x _ w _ : _ -> do+      assert failed (abs ((x + w) - (bx + bw)) <= 0.6)+      assert failed (abs (w - tw) <= 0.6)+  checkLabelAlignEndInk failed++runAspectLayoutTest :: Context -> IORef Int -> IO ()+runAspectLayoutTest ctx failed = do+  let inp = withInput 320 240+      ui = columnWith (fixedW 160 . tight) (labelWith' (fixedAspectW 160 2 . tight) "X")+  resp <- warmup2 ctx inp ui+  let Rect _ _ w h = respRect resp+  assert failed (abs (w - 160) <= 1 && abs (h - 80) <= 1)++runHostSlotTest :: Context -> IORef Int -> IO ()+runHostSlotTest ctx failed = do+  let inp = withInput 80 80+      hostUiString = do+        _ <- column (pure ())+        askHost @String+      hostUiInt = do+        _ <- column (pure ())+        askHost @Int+  (miss, _, _, _) <- runFrame ctx inp hostUiString+  setHost ctx ("ok" :: String)+  setHost ctx (1 :: Int)+  (hitS, _, _, _) <- runFrame ctx inp hostUiString+  (hitI, _, _, _) <- runFrame ctx inp hostUiInt+  assert failed (miss == Nothing && hitS == Just "ok" && hitI == Just 1)+  _ <- compactHost ctx ([0 .. 9999] :: [Int])+  let compactUi = do+        _ <- column (pure ())+        askCompact @[Int]+  (got, _, _, _) <- runFrame ctx inp compactUi+  case got of+    Just xs | length xs == 10000 && last xs == 9999 -> pure ()+    _ -> assert failed False++runEmbedStateTest :: Context -> IORef Int -> IO ()+runEmbedStateTest ctx failed = do+  let ui :: Eff '[Ui, State Int, IOE] Int+      ui = do+        _ <- column (pure ())+        modify (+ (1 :: Int))+        modify (+ (1 :: Int))+        get+  (n, _, _, _) <- runFrameEff (runEff . evalState (0 :: Int)) ctx (withInput 80 80) ui+  assertEq failed n 2++data CounterMsg = Inc | Dec+  deriving (Eq, Show)++data Counter = Counter {counterN :: Int}+  deriving (Eq, Show)++updateCounter :: CounterMsg -> Counter -> Counter+updateCounter Inc m = m {counterN = counterN m + 1}+updateCounter Dec m = m {counterN = counterN m - 1}++runReduceMessagesTest :: Context -> IORef Int -> IO ()+runReduceMessagesTest ctx failed = do+  let inp = withInput 80 80+      model0 = Counter 0+      view _ =+        column $+          Emit.emit Inc >> Emit.emit Dec >> Emit.emit Inc >> Emit.emit ("noise" :: String)+  ((), model1, msgs, _, dirty) <- runFrameReduce updateCounter ctx inp model0 view+  assert failed (msgs == [Inc, Dec, Inc] && model1 == Counter 1 && dirty)+  -- Messages that cancel out leave the model unchanged and not dirty.+  let identity _ = column (Emit.emit Inc >> Emit.emit Dec)+  ((), model2, msgs2, _, dirty2) <- runFrameReduce updateCounter ctx inp model0 identity+  assert failed (msgs2 == [Inc, Dec] && model2 == Counter 0 && not dirty2)++runReduceClickTest :: Context -> IORef Int -> IO ()+runReduceClickTest ctx failed = do+  let inp0 = withInput 240 120+      view m = do+        resp <- button' "Go"+        when (respClicked resp) (Emit.emit Inc)+        label (T.pack (show (counterN m)))+        pure resp+  _ <- runFrameReduce updateCounter ctx inp0 (Counter 0) view+  (resp, model0, _, _, _) <- runFrameReduce updateCounter ctx inp0 (Counter 0) view+  assertEq failed model0 (Counter 0)+  (modelR, msgs, dirty) <- runClickReduce updateCounter ctx inp0 (Counter 0) view (centerOf resp)+  assert failed (msgs == [Inc] && modelR == Counter 1 && dirty)+  (_, model1, _, _, _) <- runFrameReduce updateCounter ctx inp0 modelR view+  assertEq failed model1 (Counter 1)++runWidgetNoStringEmitTest :: Context -> IORef Int -> IO ()+runWidgetNoStringEmitTest ctx failed = do+  let inp0 = withInput 240 120+  (resp, _, _, _) <- runFrame ctx inp0 (button' "Go")+  let (press, release) = clickPair inp0 (centerOf resp)+  _ <- runFrame ctx press (button "Go")+  (clicked, msgs, _, _) <- runFrame ctx release (button "Go")+  assert failed clicked+  assert failed (null msgs)++runPanelPaintsTest :: Context -> IORef Int -> IO ()+runPanelPaintsTest ctx failed = do+  let inp = withInput 200 200+      fat = padAll 16 . fillW+  (_, _, colDraw, _) <- runFrame ctx inp (columnWith fat (label "x"))+  (_, _, panDraw, _) <- runFrame ctx inp (panelWith fat (label "x"))+  assertGt failed (drawVertexCount panDraw) (drawVertexCount colDraw)++-- | Drag-drop previews must come from simulating the post-drop layout, not+-- from halving the target's pre-drop rect: in a grid mixing 'AxisV' and+-- 'AxisH' splits, dropping first removes the dragged pane, which collapses+-- its parent split and re-flows the sibling subtrees, so the naive highlight+-- lands at the wrong position and size.+runPaneGridMixedDragTest :: Context -> IORef Int -> IO ()+runPaneGridMixedDragTest ctx failed = do+  -- Model level: vertical root split with a horizontal split inside the right+  -- branch: pane 1 left, panes 2 (top right) and 3 (bottom right).+  let minSize = 40+      gutter = 4+      base = Rect 0 0 600 400+      tree0 = Split 100 AxisV 0.5 (Pane 1) (Split 101 AxisH 0.5 (Pane 2) (Pane 3))+      regions0 = fst (layoutNode minSize gutter tree0 base)+      r2 = regions0 M.! 2+      r3 = regions0 M.! 3+      preview dt = dropPreview minSize gutter tree0 1 base dt+  assertEq failed regions0 $+    M.fromList+      [ (1, Rect 0 0 298 400)+      , (2, Rect 302 0 298 198)+      , (3, Rect 302 202 298 198)+      ]+  -- Cross-axis edge drop on the bottom-right pane: removing pane 1 collapses+  -- the root split, so the right branch re-flows to the whole grid and pane 1+  -- lands in its bottom-right corner, not in a half of the target's old rect+  -- (which would be Rect 302 301 298 99).+  let dtA = dropTargetForPane r3 (V2 (rectX r3 + rectW r3 / 2) (rectY r3 + rectH r3 * 0.9)) 3+  assertEq failed dtA (DropSplit 3 AxisH False)+  assertEq failed (preview dtA) (Just (Rect 0 303 600 97, DropSplit 3 AxisH False))+  -- Edge drop on the top-right pane.+  let dtB = dropTargetForPane r2 (V2 (rectX r2 + rectW r2 * 0.9) (rectY r2 + rectH r2 / 2)) 2+  assertEq failed dtB (DropSplit 2 AxisV False)+  assertEq failed (preview dtB) (Just (Rect 302 0 298 198, DropSplit 2 AxisV False))+  -- Center drop swaps; the preview is the target's exact region.+  let dtC = dropTargetForPane r2 (V2 (rectX r2 + rectW r2 / 2) (rectY r2 + rectH r2 / 2)) 2+  assertEq failed dtC (DropSwap 2)+  assertEq failed (preview dtC) (Just (Rect 302 0 298 198, DropSwap 2))+  -- Top-level edge drops restructure the whole grid.+  assertEq failed (topLevelDropTarget 20 base (V2 5 200)) (Just (DropTop AxisV True))+  assertEq failed (topLevelDropTarget 20 base (V2 300 200)) Nothing+  let dtD = DropTop AxisV True+  assertEq failed (preview dtD) (Just (Rect 0 0 298 400, DropTop AxisV True))++  -- Widget level: build the same mixed grid through a live paneGrid, drag the+  -- left pane onto the bottom-right pane's lower edge, and check the drop+  -- lands it below that pane (tree order of the restructured grid).+  rects <- newIORef IM.empty+  closeRects <- newIORef IM.empty+  stateUpdates <- newIORef IM.empty+  paneStates <- newIORef IM.empty+  step <- newIORef (0 :: Int)+  nbRef <- newIORef (0 :: Word64)+  let inp0 = withInput 600 400+      cfg =+        defaultPaneGridConfig+          { pgLayout = fillW . fillH+          , pgMinSize = 40+          , pgSpacing = 4+          , pgViewPane = \pid pctx -> do+              liftIO (modifyIORef' rects (IM.insert (fromIntegral pid) (pgcRect pctx)))+              (value, setValue) <- useInt 0+              marker <- nextId+              updates <- liftIO (readIORef stateUpdates)+              case IM.lookup (fromIntegral pid) updates of+                Nothing -> pure ()+                Just n -> do+                  setValue n+                  liftIO (modifyIORef' stateUpdates (IM.delete (fromIntegral pid)))+              liftIO (modifyIORef' paneStates (IM.insert (fromIntegral pid) (marker, value)))+              s <- liftIO (readIORef step)+              case s of+                0 -> do+                  nb <- pgcSplit pctx AxisV+                  liftIO $ do+                    writeIORef nbRef nb+                    writeIORef step 1+                1 -> do+                  nb <- liftIO (readIORef nbRef)+                  when (pid == nb) $ do+                    _ <- pgcSplit pctx AxisH+                    liftIO (writeIORef step 2)+                _ -> pure ()+              close <- button' "x"+              liftIO (modifyIORef' closeRects (IM.insert (fromIntegral pid) (respRect close)))+              when (respClicked close) (pgcClose pctx)+              pure (PaneView "P" True Nothing)+          }+      ui = paneGrid cfg+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  (pgr0, _, _, _) <- runFrame ctx inp0 ui+  case pgrPanes pgr0 of+    [pa, pb, pc] -> do+      let expectedValues = IM.fromList [(fromIntegral p, fromIntegral p + 100) | p <- [pa, pb, pc]]+      writeIORef stateUpdates expectedValues+      _ <- warmup2 ctx inp0 ui+      initialStates <- readIORef paneStates+      assertEq failed (IM.map snd initialStates) expectedValues+      rs <- readIORef rects+      case (IM.lookup (fromIntegral pa) rs, IM.lookup (fromIntegral pc) rs) of+        (Just ra, Just rc) -> do+          -- Inside the header, only 2px from the divider: the gutter's+          -- leeway must not extend into this pane and steal the drag.+          let grab = V2 (rectX ra + rectW ra - 2) (rectY ra + 12)+              -- 30px above the grid's bottom edge: inside the pane's bottom+              -- drop zone but clear of the 20px top-level band.+              dest = V2 (rectX rc + rectW rc / 2) (rectY rc + rectH rc - 30)+              ps = IM.elems rs+              gx = minimum (map rectX ps)+              gy = minimum (map rectY ps)+              gw = maximum (map (\r -> rectX r + rectW r) ps) - gx+              gh = maximum (map (\r -> rectY r + rectH r) ps) - gy+          -- The order assert below cannot tell a pane-level split from a+          -- top-level band drop ([pb, pc, pa] either way), so pin the pointer+          -- to the pane-split path first.+          assert failed (topLevelDropTarget 20 (Rect gx gy gw gh) dest == Nothing)+          let press =+                inp0+                  { inputMousePos = grab+                  , inputMouseDown = True+                  , inputMousePressed = True+                  , inputMouseReleased = False+                  }+              hold = press {inputMousePos = dest, inputMousePressed = False}+              release = hold {inputMouseDown = False, inputMouseReleased = True}+          _ <- runFrame ctx press ui+          writeIORef rects IM.empty+          writeIORef paneStates IM.empty+          _ <- runFrame ctx hold ui+          during <- readIORef rects+          duringStates <- readIORef paneStates+          assertEq failed duringStates (IM.delete (fromIntegral pa) initialStates)+          assert failed (not (IM.member (fromIntegral pa) during))+          assertEq failed (IM.size during) 2+          assert failed (all ((== gw) . rectW) (IM.elems during))+          -- Crossing back over the original grab point must not make the+          -- pane reappear or collapse the drag back into a click.+          writeIORef rects IM.empty+          _ <- runFrame ctx (hold {inputMousePos = grab}) ui+          returned <- readIORef rects+          assert failed (not (IM.member (fromIntegral pa) returned))+          -- Releasing outside the grid restores the committed layout.+          (cancelled, _, _, _) <- runFrame ctx (release {inputMousePos = V2 (-20) (-20)}) ui+          assertEq failed (pgrPanes cancelled) [pa, pb, pc]+          writeIORef rects IM.empty+          _ <- warmup2 ctx inp0 ui+          restored <- readIORef rects+          assertEq failed restored rs+          restoredStates <- readIORef paneStates+          assertEq failed restoredStates initialStates+          _ <- runFrame ctx press ui+          _ <- runFrame ctx hold ui+          (pgr1, _, _, _) <- runFrame ctx release ui+          assertEq failed (pgrPanes pgr1) [pb, pc, pa]+          _ <- warmup2 ctx inp0 ui+          droppedStates <- readIORef paneStates+          assertEq failed droppedStates initialStates+          buttons <- readIORef closeRects+          case IM.lookup (fromIntegral pa) buttons of+            Nothing -> assert failed False+            Just closeRect -> do+              let closePos = V2 (rectX closeRect + rectW closeRect / 2) (rectY closeRect + rectH closeRect / 2)+                  closePress = press {inputMousePos = closePos}+                  closeHold = hold {inputMousePos = V2 (v2X closePos + 60) (v2Y closePos + 40)}+              _ <- runFrame ctx closePress ui+              writeIORef rects IM.empty+              _ <- runFrame ctx closeHold ui+              duringClose <- readIORef rects+              assertEq failed (IM.size duringClose) 3+              (closed, _, _, _) <- runFrame ctx (release {inputMousePos = closePos}) ui+              assertEq failed (pgrPanes closed) [pb, pc]+        _ -> assert failed False+    _ -> assert failed False+++-- A button scrolled above its viewport can geometrically overlap the header,+-- but its invisible rectangle must not claim the header's drag press.+runPaneGridClippedControlTest :: Context -> IORef Int -> IO ()+runPaneGridClippedControlTest ctx failed = do+  rendered <- newIORef False+  geometry <- newIORef Nothing+  let inp0 = withInput 300 240+      ui = paneGrid defaultPaneGridConfig+        { pgLayout = fillW . fillH+        , pgViewPane = \_ _ -> do+            liftIO (writeIORef rendered True)+            header <- labelWith' (fixedH 40 . fillW . tight) "Header"+            (sid, target) <- scrollArea (fixedH 120 . fillW . tight) $+              columnWith tight $ do+                b <- button' "Scrolled control"+                mapM_ (\_ -> void (label "Scroll content")) [1 .. 20 :: Int]+                pure b+            liftIO (writeIORef geometry (Just (respId header, sid, respId target)))+            pure (PaneView "Panel" True Nothing)+        }+  _ <- warmup2 ctx inp0 ui+  ids <- readIORef geometry+  case ids of+    Nothing -> assert failed False+    Just (headerId, sid, targetId) -> do+      headerRect <- getPrevRect ctx headerId+      targetRect <- getPrevRect ctx targetId+      case (headerRect, targetRect) of+        (Just hr, Just br) -> do+          -- Place the button's invisible center exactly in the header.+          let headerY = rectY hr + rectH hr / 2+          setScrollOffset ctx sid (rectY br + rectH br / 2 - headerY)+          _ <- warmup2 ctx inp0 ui+          hiddenRect <- getPrevRect ctx targetId+          case hiddenRect of+            Nothing -> assert failed False+            Just r -> do+              let grab = V2 (rectX r + rectW r / 2) (rectY r + rectH r / 2)+                  press = inp0 {inputMousePos = grab, inputMouseDown = True, inputMousePressed = True}+                  hold = press {inputMousePressed = False, inputMousePos = V2 (v2X grab + 30) (v2Y grab)}+              assert failed (rectContains hr grab)+              _ <- runFrame ctx press ui+              writeIORef rendered False+              _ <- runFrame ctx hold ui+              stillRendered <- readIORef rendered+              assert failed (not stillRendered)+        _ -> assert failed False++-- Clicking the embedded clear (×) must empty the field, keep focus, and fire an+-- immediate (non-debounced) change pulse.+runSearchFieldClearTest :: Context -> IORef Int -> IO ()+runSearchFieldClearTest ctx failed = do+  queryRef <- newIORef "hello world"+  let inp0 = withInput 320 100+      ui = column (held queryRef (searchField' "Search…"))+  (resp, _) <- warmup2 ctx inp0 ui+  let Rect bx by bw bh = respRect resp+      cy = by + bh / 2+      scanClear x+        | x < bx = pure Nothing+        | otherwise = do+            let probe = inp0 {inputMousePos = V2 x cy}+            _ <- runFrame ctx probe ui+            kind <- uiCursorKind ctx probe+            if kind == UiCursorPointer then pure (Just x) else scanClear (x - 2)+  mcx <- scanClear (bx + bw - 6)+  case mcx of+    Nothing -> assert failed False+    Just cx -> do+      let press = inp0 {inputMousePos = V2 cx cy, inputMouseDown = True, inputMousePressed = True, inputMouseReleased = False}+      _ <- runFrame ctx press ui+      ((r1, t1), _, _, _) <- runFrame ctx inp0 ui+      assertEq failed t1 ""+      assert failed (respChanged r1)+      ((r2, _), _, _, _) <- runFrame ctx inp0 ui+      assert failed (not (respChanged r2))++-- Typing is echoed immediately but the change pulse only fires after the text+-- has been idle for the configured debounce window.+runSearchFieldDebounceTest :: Context -> IORef Int -> IO ()+runSearchFieldDebounceTest ctx failed = do+  queryRef <- newIORef ""+  let inp0 = withInput 320 100+      ui = column (held queryRef (searchFieldConfigured' (defaultSearchFieldConfig {sfcDebounceMs = 40})))+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  ((rA, tA), _, _, _) <- runFrame ctx (inp0 {inputChars = "a"}) ui+  assertEq failed tA "a"+  assert failed (not (respChanged rA))+  ((rB, tB), _, _, _) <- runFrame ctx (inp0 {inputChars = "b"}) ui+  assertEq failed tB "ab"+  assert failed (not (respChanged rB))+  threadDelay 80000+  ((rC, tC), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed tC "ab"+  assert failed (respChanged rC)+  threadDelay 50000+  ((rD, _), _, _, _) <- runFrame ctx inp0 ui+  assert failed (not (respChanged rD))++runKvMultilineHeightTest :: Context -> IORef Int -> IO ()+runKvMultilineHeightTest ctx failed = do+  let+    inp0 = withInput 320 400+    ui = column $ do+      card $ do+        kv "Notes" "Line 1\nLine 2\nLine 3\nLine 4\nLine 5"+        kv "Tree" "0"+  _ <- warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  case (spanYOf "Line 5" spans, spanYOf "Tree" spans) of+    ([line5Y], [treeY]) ->+      assert failed (treeY > line5Y)+    _ -> assert failed False
+ test/integration/Cases/Animation.hs view
@@ -0,0 +1,208 @@+module Cases.Animation+  ( runAnimationBezierTest+  , runButtonHoverAnimTest+  , runAnimationDamageTest+  , runAnimationSettleTest+  , runAnimationSpringDtTest+  , runAnimationSpringRetargetTest+  , runAnimationStaggerTest+  , runCompositeAnimationIsolationTest+  , runSpinnerTest+  ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forM_, replicateM, replicateM_, void)+import Data.IORef (IORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert)+import NanoUI.Testing.Harness (clickPair, drawQuads, withDelta)++-- A started animation requests redraws, settles on its target, and then+-- leaves the context idle and clean.+runAnimationSettleTest :: Context -> IORef Int -> IO ()+runAnimationSettleTest ctx failed = do+  let inp = withDelta 100 100 0.1+      wid = WidgetId 99+  _ <- runFrame ctx inp (label "settle")+  startAnimation ctx wid 0 1 0.25+  need <- needsRedraw ctx inp inp+  assert failed need+  replicateM_ 4 (runFrame ctx inp (label "settle"))+  val <- getAnimationValue ctx wid+  assert failed (abs (val - 1) <= 0.01)+  live <- anyAnimating ctx+  assert failed (not live)+  needAfter <- needsRedraw ctx inp inp+  assert failed (not needAfter)+  (_, _, _, dirty) <- runFrame ctx inp (label "settle")+  assert failed (not dirty)++runAnimationDamageTest :: Context -> IORef Int -> IO ()+runAnimationDamageTest _ failed = do+  ctx <- newContext+  let idleInp = withDelta 200 100 0+      idle = label "anim"+      tweenInp = idleInp {inputDeltaTime = 0.05}+      ui = do+        t <- animateTo (Tween EaseLinear 0.4 0) 1+        void (spacer (Fixed (20 + 80 * t)) Fit)+        label "anim"+      hasMove dmg = case dmg of+        DamageFull -> True+        DamageClip r -> rectW r > 0 && rectH r > 0+  _ <- runFrame ctx idleInp idle+  _ <- runFrame ctx idleInp idle+  dIdle <- takeDamage ctx+  assert failed (dIdle /= DamageFull)+  _ <- runFrame ctx tweenInp ui+  dMid <- takeDamage ctx+  assert failed (hasMove dMid)+  ctx2 <- newContext+  let fastInp = idleInp {inputDeltaTime = 0.5}+      uiFast = do+        t <- animateTo (Tween EaseLinear 0.2 0) 1+        void (spacer (Fixed (20 + 80 * t)) Fit)+        label "anim"+  _ <- runFrame ctx2 idleInp idle+  _ <- runFrame ctx2 idleInp idle+  _ <- runFrame ctx2 fastInp uiFast+  dFast <- takeDamage ctx2+  assert failed (hasMove dFast)++-- A delayed tween holds its start value until the delay elapses and then+-- eases from there; declarative tweens stagger the same way per key.+runAnimationStaggerTest :: Context -> IORef Int -> IO ()+runAnimationStaggerTest ctx failed = do+  let inp = withDelta 200 100 0.02+      wid = WidgetId 202+      slow = inp {inputDeltaTime = 0.1}+  startAnimationEaseDelay ctx wid 0 1 0.2 EaseLinear 0.15+  _ <- runFrame ctx slow (label "delay")+  v0 <- getAnimationValue ctx wid+  assert failed (abs v0 <= 0.01)+  live0 <- anyAnimating ctx+  assert failed live0+  _ <- runFrame ctx slow (label "delay")+  v1 <- getAnimationValue ctx wid+  assert failed (abs (v1 - 0.25) <= 0.03)+  let ui = do+        _ <- withKey ("lead" :: String) (animateTo (Tween EaseLinear 0.4 0) 1)+        t <- withKey ("trail" :: String) (animateTo (Tween EaseLinear 0.4 0.08) 1)+        label (T.pack ("t=" ++ show t))+      trailVal = do+        spans <- collectTextSpans ctx+        let shown = [txt | (_, txt, _, _, _) <- spans]+            tagged = [T.drop 2 txt | txt <- shown, "t=" `T.isPrefixOf` txt]+        case tagged of+          (raw : _) -> case reads (T.unpack raw) of+            [(n, "")] -> pure (n :: Float)+            _ -> assert failed False >> pure 0+          _ -> assert failed False >> pure 0+  replicateM_ 3 (runFrame ctx inp ui)+  early <- trailVal+  assert failed (early <= 0.01)+  replicateM_ 10 (runFrame ctx inp ui)+  late <- trailVal+  assert failed (late >= 0.15)++runAnimationBezierTest :: Context -> IORef Int -> IO ()+runAnimationBezierTest _ failed = do+  let lin = applyEase (EaseCubicBezier 0 0 1 1) 0.5+      out = applyEase (EaseCubicBezier 0 0 0.58 1) 0.5+  assert failed (abs (lin - 0.5) <= 0.01)+  assert failed (out > 0.5)+  assert failed (abs (applyEase EaseInQuad 0.5 - 0.25) <= 0.01)+  assert failed (abs (applyEase (EaseCubicBezier 0.33 0 0.2 1) 0) <= 0.001)+  assert failed (abs (applyEase (EaseCubicBezier 0.33 0 0.2 1) 1 - 1) <= 0.001)++runAnimationSpringRetargetTest :: Context -> IORef Int -> IO ()+runAnimationSpringRetargetTest ctx failed = do+  let inp = withDelta 100 100 0.02+      wid = WidgetId 402+  startSpring ctx wid presetBouncy 1+  replicateM_ 5 (runFrame ctx inp (label "retarget"))+  v1 <- getAnimationValue ctx wid+  assert failed (v1 >= 0.02 && v1 <= 0.98)+  startSpring ctx wid presetBouncy 0+  v2 <- getAnimationValue ctx wid+  assert failed (abs (v2 - v1) <= 0.02)+  live <- anyAnimating ctx+  assert failed live++runAnimationSpringDtTest :: Context -> IORef Int -> IO ()+runAnimationSpringDtTest ctx failed = do+  let inp = withDelta 100 100 2+      wid = WidgetId 403+  startSpring ctx wid presetStiff 1+  _ <- runFrame ctx inp (label "dt")+  val <- getAnimationValue ctx wid+  assert failed (not (isNaN val || isInfinite val || val < 0 || val > 1.5))++-- Each composite animation owns a scope; component indices alone are not+-- unique when two vectors animate side by side in the same parent. Tweens+-- and springs both settle and stop requesting redraws.+runCompositeAnimationIsolationTest :: Context -> IORef Int -> IO ()+runCompositeAnimationIsolationTest _ failed =+  forM_ [animateToA (Tween EaseLinear 0.2 0), animateToA (Spring presetSmooth)] $ \animateVector -> do+    ctx <- newContext+    let inp = withDelta 200 100 0.05+        ui = do+          a <- animateVector (V2 1 2)+          b <- animateVector (V2 (-1) (-2))+          label (T.pack (show (a, b)))+          pure (a, b)+    replicateM_ 80 (runFrame ctx inp ui)+    ((V2 ax ay, V2 bx by), _, _, _) <- runFrame ctx inp ui+    assert failed (abs (ax - 1) < 0.05 && abs (ay - 2) < 0.05)+    assert failed (abs (bx + 1) < 0.05 && abs (by + 2) < 0.05)+    live <- anyAnimating ctx+    assert failed (not live)+    need <- needsRedraw ctx inp inp+    assert failed (not need)++-- Hovering a button eases its highlight in without dipping, and a press and+-- release over it leaves the hover animation fully on.+runButtonHoverAnimTest :: Context -> IORef Int -> IO ()+runButtonHoverAnimTest ctx failed = do+  let inp0 = withDelta 200 100 0.016+      ui = column (button "Hover")+  _ <- runFrame ctx inp0 ui+  let inp1 = inp0 {inputMousePos = V2 10 10}+  vals <- replicateM 5 (runFrame ctx inp1 ui >> getHotId ctx >>= getAnimationValue ctx)+  let decreases = any (uncurry (\a b -> b + 0.001 < a)) (zip vals (drop 1 vals))+  assert failed (not decreases)+  assert failed (last vals >= 0.4)+  let (press, release) = clickPair inp0 (V2 10 10)+  _ <- runFrame ctx press ui+  _ <- runFrame ctx release ui+  hot <- getHotId ctx+  val <- getAnimationValue ctx hot+  assert failed (hashWidgetId hot /= 0)+  assert failed (val >= 0.99)++-- A spinner keeps the loop drawing, repaints only around itself, and turns.+runSpinnerTest :: Context -> IORef Int -> IO ()+runSpinnerTest ctx failed = do+  theme <- getTheme ctx+  let inp = withDelta 400 300 0.016+      ui = column $ do+        label "Loading a long label so the window has more than the spinner"+        spinner'+  _ <- runFrame ctx inp ui+  (resp, _, draw0, _) <- runFrame ctx inp ui+  _ <- takeDamage ctx+  need <- needsRedraw ctx inp inp+  assert failed need+  quads0 <- drawQuads draw0+  assert failed (any ((== themeAccent theme) . snd) quads0)+  threadDelay 60000+  (_, _, draw1, _) <- runFrame ctx inp ui+  dmg <- takeDamage ctx+  case dmg of+    DamageClip r -> assert failed (rectW r < 80 && rectH r < 80 && rectIntersect r (respRect resp) /= Nothing)+    DamageFull -> assert failed False+  quads1 <- drawQuads draw1+  let arc qs = [q | (q, c) <- qs, c == themeAccent theme]+  assert failed (arc quads0 /= arc quads1)
+ test/integration/Cases/Atlas.hs view
@@ -0,0 +1,60 @@+module Cases.Atlas (runAtlasGrowthTest) where++import Control.Monad (forM_)+import Data.ByteString qualified as BS+import Data.IORef (IORef)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Array (peekArray)+import Foreign.Ptr (plusPtr)+import NanoUI (ImageId (..))+import NanoUI.Context (lookupImageUv)+import NanoUI.Testing (Context, atlasSnapshot, newContext, registerImage)+import NanoUI.Testing.Assert (assert, assertEq)++runAtlasGrowthTest :: Context -> IORef Int -> IO ()+runAtlasGrowthTest ctx failed = do+  let+    red = BS.pack [255, 0, 0, 255]+    blue = BS.pack [0, 0, 255, 255]+    pixels w h color = BS.concat (replicate (w * h) color)+    insert tid w h color = registerImage ctx (ImageId tid) w h (pixels w h color)+    checkPixel tid expected = do+      snapshot <- atlasSnapshot ctx >>= maybe (fail "missing atlas snapshot") pure+      uv <- lookupImageUv ctx (ImageId tid) >>= maybe (fail "missing image UV") pure+      let+        (w, h, fp, _) = snapshot+        (u0, v0, u1, v1) = uv+        xs = [round (u0 * fromIntegral w), round (u1 * fromIntegral w) - 1]+        ys = [round (v0 * fromIntegral h), round (v1 * fromIntegral h) - 1]+      forM_ [(x, y) | x <- xs, y <- ys] $ \(x, y) -> do+        actual <- withForeignPtr fp $ \ptr -> BS.pack <$> peekArray 4 (ptr `plusPtr` ((y * w + x) * 4))+        assertEq failed actual expected+  insert 1 2 2 red >>= assert failed+  initialUv <- lookupImageUv ctx (ImageId 1)+  -- A wider image grows the atlas; wrapping another image starts a new shelf.+  insert 2 300 3 blue >>= assert failed+  insert 3 400 1 red >>= assert failed+  grownUv <- lookupImageUv ctx (ImageId 1)+  assert failed (initialUv /= grownUv)+  checkPixel 1 red+  checkPixel 2 blue+  checkPixel 3 red+  -- Same-size updates retain their location and change only their pixels.+  insert 1 2 2 blue >>= assert failed+  lookupImageUv ctx (ImageId 1) >>= assertEq failed grownUv+  checkPixel 1 blue+  checkPixel 2 blue+  before <- atlasSnapshot ctx+  insert 1 3 2 red >>= assert failed . not+  atlasSnapshot ctx >>= assertEq failed before++  -- Width growth cannot rescue this insertion: neither the current shelf nor+  -- a new shelf can accommodate it within the atlas's maximum dimensions.+  full <- newContext+  registerImage full (ImageId 1) 1 3000 (BS.replicate (3000 * 4) 255)+    >>= assert failed+  fullBefore <- atlasSnapshot full+  registerImage full (ImageId 2) 4094 1100 (BS.replicate (4094 * 1100 * 4) 0)+    >>= assert failed . not+  atlasSnapshot full >>= assertEq failed fullBefore+  lookupImageUv full (ImageId 2) >>= assertEq failed Nothing
+ test/integration/Cases/Cache.hs view
@@ -0,0 +1,139 @@+module Cases.Cache+  ( runMetricCacheInvalidationTest+  , runWidgetPlacementCacheTest+  , runLayoutPaintStateTest+  ) where++import Control.Monad (forM_, void)+import Control.Exception (evaluate)+import Data.ByteString qualified as BS+import Data.IORef (IORef, readIORef, writeIORef)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (castPtr)+import NanoUI+import NanoUI.Context (Context (..))+import NanoUI.Layout.Arena+  ( NodeType (..), addNodeFromLayout, getRect, setNodeText, setNodeValue+  , setStyleIdx, setWidgetId+  )+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt)+import NanoUI.Testing.Harness (withInputOff)+import System.Mem.StableName (makeStableName)++-- Copy the mutable draw buffers before another frame can reuse them. Counts+-- alone cannot detect stale geometry, colors or translated text.+snapshotDraw :: DrawData -> IO (BS.ByteString, BS.ByteString, [DrawCmd])+snapshotDraw draw = do+  vertices <- withForeignPtr (drawVertices draw) $ \p ->+    BS.packCStringLen (castPtr p, drawVertexCount draw * vertexSize)+  indices <- withForeignPtr (drawIndices draw) $ \p ->+    BS.packCStringLen (castPtr p, drawIndexCount draw * indexSize)+  pure (vertices, indices, drawCmdElems draw)++runMetricCacheInvalidationTest :: Context -> IORef Int -> IO ()+runMetricCacheInvalidationTest ctx failed = do+  let inp = withInputOff 400 300+      width c = do+        void $ runFrame c inp (button "ABC")+        (_, _, w, _) <- getRect (ctxNodeArena c) 0+        pure w+      a = withMeasureText ctx (\_ -> pure (200, 20))+      b = withMeasureText ctx (\_ -> pure (80, 12))+  original <- width ctx+  wa <- width a+  wb <- width b+  assertGt failed wa original+  assertGt failed wa wb+  -- Both variants derive from the same parent and share mutable caches. An+  -- incremented pure Int revision would collide here; returning to A matters.+  assertEq failed wa =<< width a+  assertEq failed original =<< width ctx++  -- Each supported pure modifier must invalidate both layout and placement.+  forM_+    [ (\c -> withFontMetrics c (monospaceMetrics 24), void (button "ABC"))+    , (\c -> withMonoFontMetrics c (monospaceMetrics 24), void (labelWith fontMono "ABC"))+    , (\c -> withFontResolver c (\_ _ _ _ -> pure (monospaceMetrics 24, False))+            (\_ _ _ _ _ -> pure (200, 24)), void (labelWith (fontSize 24) "ABC"))+    ] $ \(configure, ui) -> do+      warm <- newContext+      void $ runFrame warm inp ui+      let configured = configure warm+      (_, _, draw, _) <- runFrame configured inp ui+      actual <- snapshotDraw draw+      spans <- collectTextSpans configured+      fresh <- configure <$> newContext+      (_, _, coldDraw, _) <- runFrame fresh inp ui+      expected <- snapshotDraw coldDraw+      assertEq failed actual expected+      assertEq failed spans =<< collectTextSpans fresh++-- A table header's width and style stay fixed while alignment and its parent+-- origin change independently. This exercises the placement cache's key.+header :: Context -> AlignX -> Float -> Float -> NanoUI ()+header ctx ax x y = uiIO $ do+  let na = ctxNodeArena ctx+  parent <- addNodeFromLayout na NodeContainer (-1) $+    (fixedWH 320 160 defaultLayout) {layoutPadding = Padding x 0 y 0}+  i <- addNodeFromLayout na NodeButton parent $+    (fixedWH 200 30 defaultLayout) {layoutAlignX = ax}+  setWidgetId na i (WidgetId 123)+  setNodeText na i "Header"+  setStyleIdx na i 0x80000000++runWidgetPlacementCacheTest :: Context -> IORef Int -> IO ()+runWidgetPlacementCacheTest _ctx failed =+  forM_ [1, 1.5, 2] $ \scale -> do+    base <- newContext+    let ctx = withFontMetrics base ((monospaceMetrics 12) {fmSnapScale = scale})+        inp = withInputOff 400 300+    void $ runFrame ctx inp (header ctx AlignStart 0 0)+    start <- collectTextSpans ctx+    (_, _, draw, _) <- runFrame ctx inp (header ctx AlignEnd 0 0)+    aligned <- snapshotDraw draw+    end <- collectTextSpans ctx+    assert failed (start /= end)+    freshBase <- newContext+    let fresh = withFontMetrics freshBase ((monospaceMetrics 12) {fmSnapScale = scale})+    (_, _, expectedDraw, _) <- runFrame fresh inp (header fresh AlignEnd 0 0)+    assertEq failed aligned =<< snapshotDraw expectedDraw++    cache <- readIORef (ctxWidgetTextCache ctx) >>= evaluate >>= makeStableName+    forM_ [(0.25, 0.5), (9.75, 3.25), (0, 0)] $ \(x, y) -> do+      (_, _, movedDraw, _) <- runFrame ctx inp (header ctx AlignEnd x y)+      moved <- snapshotDraw movedDraw+      cache' <- readIORef (ctxWidgetTextCache ctx) >>= evaluate >>= makeStableName+      assert failed (cache == cache')+      -- Force a fresh placement at the same origin and compare actual bytes.+      clearMeasureCache fresh+      (_, _, coldDraw, _) <- runFrame fresh inp (header fresh AlignEnd x y)+      assertEq failed moved =<< snapshotDraw coldDraw++runLayoutPaintStateTest :: Context -> IORef Int -> IO ()+runLayoutPaintStateTest ctx failed = do+  let inp = withInputOff 400 300+      ui value color = do+        column $ do+          box (fixedWH 30 30) color+          uiIO $ do+            let na = ctxNodeArena ctx+            i <- addNodeFromLayout na NodeSlider 0 (fixedWH 200 30 defaultLayout)+            setWidgetId na i (WidgetId 123)+            setNodeText na i ""+            setNodeValue na i value+          void (labelWith (fontColor color) "paint only")+      red = colorRGBA 255 0 0 255+      blue = colorRGBA 0 0 255 255+  (_, _, firstDraw, _) <- runFrame ctx inp (ui 0.2 red)+  first <- snapshotDraw firstDraw+  cache <- readIORef (ctxLayoutCache ctx) >>= evaluate >>= makeStableName+  (_, _, changedDraw, _) <- runFrame ctx inp (ui 0.8 blue)+  changed <- snapshotDraw changedDraw+  cache' <- readIORef (ctxLayoutCache ctx) >>= evaluate >>= makeStableName+  assert failed (cache == cache')+  assert failed (first /= changed)+  -- A cache hit must preserve this frame's slider value and paint colors.+  writeIORef (ctxLayoutCache ctx) Nothing+  (_, _, coldDraw, _) <- runFrame ctx inp (ui 0.8 blue)+  assertEq failed changed =<< snapshotDraw coldDraw
+ test/integration/Cases/Combo.hs view
@@ -0,0 +1,240 @@+module Cases.Combo+  ( runComboBlurCommitTest+  , runComboEscapeRevertTest+  , runComboFilterTest+  , runComboHoverHighlightTest+  , runComboKeyboardPickTest+  , runComboMousePickTest+  , runComboScrollbarDragTest+  , runComboWheelScrollTest+  ) where++import Data.IORef (IORef, newIORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness (clickPair, hasText, held, keyInp, tabInp, warmup2)++comboOpts :: [T.Text]+comboOpts = ["Alpha Sans", "Beta Serif", "Gamma Mono", "Delta Round"]++-- Enough options to overflow the dropdown's visible window (8 rows). Names+-- are zero-padded so no name is a substring of another.+comboLongOpts :: [T.Text]+comboLongOpts =+  [ "Fam " <> (if i < 10 then "0" else "") <> T.pack (show i)+  | i <- [1 .. 12 :: Int]+  ]++-- Typing filters the suggestion list case-insensitively and never selects+-- anything on its own: Enter with no highlight leaves the typed text alone.+runComboFilterTest :: Context -> IORef Int -> IO ()+runComboFilterTest ctx failed = do+  textRef <- newIORef ""+  let inp0 = withInput 320 100+      ui = held textRef (comboBox' "Font" comboOpts)+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (inp0 {inputChars = "ga"}) ui+  overlays <- collectOverlayTextSpans ctx inp0+  assert failed (hasText "Gamma Mono" overlays)+  assert failed (not (hasText "Alpha Sans" overlays))+  ((_, t), _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) ui+  assertEq failed t "ga"++-- Up/Down move the keyboard highlight (Down from nothing selects the first+-- row), and Enter commits it.+runComboKeyboardPickTest :: Context -> IORef Int -> IO ()+runComboKeyboardPickTest ctx failed = do+  let inp0 = withInput 320 100+      ui = comboBox' "Font" comboOpts ""+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (keyInp KeyDown inp0) ui+  _ <- runFrame ctx (keyInp KeyDown inp0) ui+  ((r, t), _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) ui+  assert failed (respChanged r)+  assertEq failed t "Beta Serif"+  spans <- collectTextSpans ctx+  assert failed (hasText "Beta Serif" spans)++-- Clicking a suggestion row commits its option text.+runComboMousePickTest :: Context -> IORef Int -> IO ()+runComboMousePickTest ctx failed = do+  let inp0 = withInput 320 200+      ui = comboBox' "Font" comboOpts ""+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx inp0 ui+  overlays <- collectOverlayTextSpans ctx inp0+  case [r | (r, txt, _, _, _) <- overlays, "Beta Serif" `T.isInfixOf` txt] of+    (rowRect : _) -> do+      let cx = rectX rowRect + rectW rowRect / 2+          cy = rectY rowRect + rectH rowRect / 2+          (press, release) = clickPair inp0 (V2 cx cy)+      _ <- runFrame ctx press ui+      ((r, t), _, _, _) <- runFrame ctx release ui+      assert failed (respChanged r)+      assertEq failed t "Beta Serif"+      -- Picking defocuses the field: the dropdown is visible exactly while+      -- focused, so the menu disappears with the pick.+      focus <- getFocusId ctx+      assertEq failed focus (WidgetId 0)+      overlaysClosed <- collectOverlayTextSpans ctx release+      assert failed (not (hasText "Alpha Sans" overlaysClosed))+    _ -> assert failed False++-- Hovering a suggestion row highlights it (hover paint, becomes the Enter+-- target) but never commits by itself; Enter then commits the hovered row.+runComboHoverHighlightTest :: Context -> IORef Int -> IO ()+runComboHoverHighlightTest ctx failed = do+  let inp0 = withInput 320 200+      ui = comboBox' "Font" comboOpts ""+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx inp0 ui+  overlays <- collectOverlayTextSpans ctx inp0+  case [r | (r, txt, _, _, _) <- overlays, "Delta Round" `T.isInfixOf` txt] of+    (rowRect : _) -> do+      let hover =+            inp0+              { inputMousePos = V2 (rectX rowRect + rectW rowRect / 2) (rectY rowRect + rectH rowRect / 2)+              }+      _ <- runFrame ctx hover ui+      -- Hover alone must not commit anything.+      ((r0, t0), _, _, _) <- runFrame ctx hover ui+      assert failed (not (respChanged r0) && T.null t0)+      -- Menu rows show the pointer cursor while hovered.+      ptr <- cursorKindIs ctx hover UiCursorPointer+      assert failed ptr+      -- The hovered row carries the hover background, the others do not.+      overlaysHover <- collectOverlayTextSpans ctx hover+      let bgFor needle = [bg | (_, txt, _, bg, _) <- overlaysHover, needle `T.isInfixOf` txt]+      case (bgFor "Delta Round", bgFor "Alpha Sans") of+        ([dBg], [aBg]) -> assert failed (dBg /= aBg)+        _ -> assert failed False+      -- Enter commits the hovered row.+      ((r1, t1), _, _, _) <- runFrame ctx (keyInp KeyEnter hover) ui+      assert failed (respChanged r1)+      assertEq failed t1 "Delta Round"+    _ -> assert failed False++-- Dragging the vertical scrollbar thumb scrolls the list, and releasing the+-- drag over a row must not commit it.+runComboScrollbarDragTest :: Context -> IORef Int -> IO ()+runComboScrollbarDragTest ctx failed = do+  let inp0 = withInput 320 300+      ui = comboBox' "Fonts" comboLongOpts ""+  (resp, _) <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx inp0 ui+  overlays0 <- collectOverlayTextSpans ctx inp0+  assert failed (hasText "Fam 01" overlays0)+  let Rect rx ry rw rh = respRect resp+      -- Mirrors the overlay geometry: gap 4, item 28, lane 10 wide, rows+      -- flush at the drop rect's top (no outer margin).+      dropY = ry + rh + 4+      trackX = rx + rw - 5+      press = inp0 {inputMousePos = V2 trackX (dropY + 200), inputMouseDown = True, inputMousePressed = True}+  _ <- runFrame ctx press ui+  _ <- runFrame ctx press {inputMousePressed = False} ui+  -- Release over a row position (bottom of the list): must not pick.+  let release = press {inputMouseDown = False, inputMouseReleased = True}+  ((r, t), _, _, _) <- runFrame ctx release ui+  assert failed (T.null t && not (respChanged r))+  overlays1 <- collectOverlayTextSpans ctx inp0+  assert failed (not (hasText "Fam 01" overlays1))+  assert failed (hasText "Fam 12" overlays1)++-- Typing edits the live text without committing, word-wise editing keys+-- (Ctrl+Backspace) work like in the plain text input, and losing focus+-- commits the text.+runComboBlurCommitTest :: Context -> IORef Int -> IO ()+runComboBlurCommitTest ctx failed = do+  textRef <- newIORef ""+  let inp0 = withInput 320 200+      ui = column (held textRef (comboBox' "Font" comboOpts))+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  ((rA, tA), _, _, _) <- runFrame ctx (inp0 {inputChars = "N"}) ui+  assertEq failed tA "N"+  assert failed (not (respChanged rA))+  ((rB, tB), _, _, _) <- runFrame ctx (inp0 {inputChars = "o"}) ui+  assertEq failed tB "No"+  assert failed (not (respChanged rB))+  _ <- runFrame ctx (inp0 {inputChars = " bar"}) ui+  _ <- runFrame ctx (inp0 {inputKeys = inputKeysFromList [KeyBackspace], inputModifiers = Modifiers False True False}) ui+  ((rW, tW), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed tW "No "+  assert failed (not (respChanged rW))+  _ <- runFrame ctx (keyInp KeyBackspace inp0) ui+  -- Click far away: focus clears after the UI pass, and the frame after the+  -- blur commits the typed text.+  let away = inp0 {inputMousePos = V2 310 5, inputMouseDown = True, inputMousePressed = True}+  _ <- runFrame ctx away ui+  ((rC, tC), _, _, _) <- runFrame ctx inp0 {inputMouseReleased = True} ui+  assertEq failed tC "No"+  assert failed (respChanged rC)+  ((rD, _), _, _, _) <- runFrame ctx inp0 ui+  assert failed (not (respChanged rD))++-- Unfocused, the combo is just a search field: the value is visible and no+-- dropdown overlay exists. Escape cancels an edit: the live text reverts to+-- the last committed value without a commit pulse, and the dropdown closes.+runComboEscapeRevertTest :: Context -> IORef Int -> IO ()+runComboEscapeRevertTest ctx failed = do+  textRef <- newIORef "Inter"+  let inp0 = withInput 320 200+      ui = held textRef (comboBox' "Font" comboOpts)+  (r0, t0) <- warmup2 ctx inp0 ui+  assertEq failed t0 "Inter"+  assert failed (not (respChanged r0))+  overlays0 <- collectOverlayTextSpans ctx inp0+  assert failed (not (hasText "Alpha Sans" overlays0))+  spans0 <- collectTextSpans ctx+  assert failed (hasText "Inter" spans0)+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (inp0 {inputChars = "No"}) ui+  ((r, t), _, _, _) <- runFrame ctx (keyInp KeyEscape inp0) ui+  assert failed (not (respChanged r))+  assertEq failed t "Inter"+  focus <- getFocusId ctx+  assertEq failed focus (WidgetId 0)+  overlays <- collectOverlayTextSpans ctx inp0+  assert failed (not (hasText "Alpha Sans" overlays))++-- The wheel scrolls the suggestion list while the pointer is over the open+-- dropdown: a horizontal wheel shifts rows that overflow the dropdown width+-- (clamped), and a vertical notch slides the window past the first rows.+runComboWheelScrollTest :: Context -> IORef Int -> IO ()+runComboWheelScrollTest ctx failed = do+  let inp0 = withInput 200 260+      long = "A Very Long Font Family Name That Overflows"+      ui = comboBox' "Fonts" (comboLongOpts ++ [long]) ""+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx inp0 ui+  overlays0 <- collectOverlayTextSpans ctx inp0+  assert failed (hasText "Fam 01" overlays0)+  assert failed (not (hasText "Fam 09" overlays0))+  case [r | (r, txt, _, _, _) <- overlays0, "Fam 01" `T.isInfixOf` txt] of+    (rowRect : _) -> do+      let overList = inp0 {inputMousePos = V2 (rectX rowRect + 4) (rectY rowRect + rectH rowRect / 2)}+      _ <- runFrame ctx overList ui+      _ <- runFrame ctx overList {inputScroll = V2 5 0} ui+      overlaysX <- collectOverlayTextSpans ctx overList+      case [r | (r, txt, _, _, _) <- overlaysX, "Fam 01" `T.isInfixOf` txt] of+        (after : _) -> assert failed (rectX after < rectX rowRect - 50)+        _ -> assert failed False+      -- The x-shift is clamped: a huge wheel does not push rows out of reach.+      _ <- runFrame ctx overList {inputScroll = V2 1000 0} ui+      overlaysClamped <- collectOverlayTextSpans ctx overList+      assert failed (hasText "Fam 01" overlaysClamped)+      _ <- runFrame ctx overList {inputScroll = V2 0 1} ui+      overlays1 <- collectOverlayTextSpans ctx overList+      -- One wheel notch scrolls three rows past "Fam 01".+      assert failed (not (hasText "Fam 01" overlays1))+      assert failed (hasText "Fam 04" overlays1)+      assert failed (hasText "Fam 11" overlays1)+    _ -> assert failed False
+ test/integration/Cases/ContextMenu.hs view
@@ -0,0 +1,108 @@+module Cases.ContextMenu+  ( runContextMenuOpenTest+  , runContextMenuScrollPosTest+  ) where++import Control.Monad (void)+import Data.IORef (IORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, evalUi, withInput)+import NanoUI.Testing.Harness (centerOf, clickPair, rightClickPair, spanCenter, warmup2)++menuUi :: NanoUI (Response, Maybe (Response, Response))+menuUi = column $ do+  btn <- button' "Target Button"+  mInside <- contextMenu btn $ do+    cut <- menuItem' "Cut"+    copy <- menuItem' "Copy"+    pure (cut, copy)+  pure (btn, mInside)++openMenu :: Context -> IORef Int -> Input -> IO (Response, Maybe (Response, Response))+openMenu ctx failed inp0 = do+  (btnWarm, _) <- warmup2 ctx inp0 menuUi+  let (inpRightDown, inpRightUp) = rightClickPair inp0 (centerOf btnWarm)+  ((btnDown, _), _, _, _) <- runFrame ctx inpRightDown menuUi+  assert failed (not (respRightClicked btnDown))+  ((btnUp, mInside), _, _, _) <- runFrame ctx inpRightUp menuUi+  pure (btnUp, mInside)++runContextMenuOpenTest :: Context -> IORef Int -> IO ()+runContextMenuOpenTest ctx failed = do+  let inp0 = withInput 640 480+  (btn0, mInside0) <- evalUi ctx inp0 menuUi+  assert failed (not (respRightClicked btn0))+  assert failed (case mInside0 of Nothing -> True; _ -> False)++  (btnClicked, mInsideOpen) <- openMenu ctx failed inp0+  assert failed (respRightClicked btnClicked)+  assert failed (case mInsideOpen of Just _ -> True; Nothing -> False)+  -- A left click outside dismisses the menu.+  let (pressOut, releaseOut) = clickPair inp0 (V2 500 400)+  _ <- runFrame ctx pressOut menuUi+  ((_, mAfterClick), _, _, _) <- runFrame ctx releaseOut menuUi+  assert failed (case mAfterClick of Nothing -> True; Just _ -> False)+  -- So does a right press outside.+  _ <- openMenu ctx failed inp0+  let inpRightOut = fst (rightClickPair inp0 (V2 500 400))+  _ <- runFrame ctx inpRightOut menuUi+  ((_, mAfterRight), _, _, _) <- runFrame ctx inp0 menuUi+  assert failed (case mAfterRight of Nothing -> True; Just _ -> False)++runContextMenuScrollPosTest :: Context -> IORef Int -> IO ()+runContextMenuScrollPosTest ctx failed = do+  let inp0 = withInput 200 200+      ui =+        scrollArea (fillW . fixedH 80) $+          column $ do+            mapM_ (\_ -> void (label "pad line")) [(1 :: Int) .. 40]+            btn <- button' "Menu Target"+            cut <- contextMenu btn (menuItem "Scroll Cut")+            mapM_ (\_ -> void (label "tail line")) [(1 :: Int) .. 12]+            pure (btn, cut)+  (sid, _) <- warmup2 ctx inp0 ui+  mScroll <- getPrevRect ctx sid+  case mScroll of+    Nothing -> assert failed False+    Just scrollRect@(Rect _ sy _ sh) -> do+      let hover = inp0 {inputMousePos = spanCenter scrollRect}+          wheel = hover {inputScroll = V2 0 1}+          inView btn =+            let y = rectY (respRect btn)+                h = rectH (respRect btn)+             in y >= sy + 4 && y + h + 8 <= sy + sh+          pump = do+            before <- getScrollOffset ctx sid+            _ <- runFrame ctx wheel ui+            after <- getScrollOffset ctx sid+            ((_, (btn, _)), _, _, _) <- runFrame ctx hover ui+            if inView btn || after <= before then pure (after, btn) else pump+      (off, btn1) <- pump+      assert failed (off > 0)+      let clickPos = centerOf btn1+          layoutY = rectY (respRect btn1) + off+          (inpRightDown, inpRightUp) = rightClickPair inp0 clickPos+      _ <- runFrame ctx inpRightDown ui+      _ <- runFrame ctx inpRightUp ui+      spans <- collectOverlayTextSpans ctx inpRightUp+      let hits =+            [ r+            | (r, txt, _, _, _) <- spans+            , "Scroll Cut" `T.isInfixOf` txt+            ]+      case hits of+        [] -> assert failed False+        (r : _) -> do+          let menuY = rectY r+              pick = V2 (rectX r + rectW r / 2) (rectY r + rectH r / 2)+          assert failed (abs (menuY - v2Y clickPos) <= 16)+          assert failed (abs (menuY - v2Y clickPos) < abs (menuY - layoutY))+          let (press, release) = clickPair inp0 pick+          _ <- runFrame ctx press ui+          ((_, (_, picked)), _, _, _) <- runFrame ctx release ui+          assert failed (picked == Just True)+          _ <- runFrame ctx inp0 ui+          spansAfter <- collectOverlayTextSpans ctx inp0+          assert failed (not (any (\(_, txt, _, _, _) -> "Scroll Cut" `T.isInfixOf` txt) spansAfter))
+ test/integration/Cases/CustomWidget.hs view
@@ -0,0 +1,312 @@+module Cases.CustomWidget+  ( runCustomWidgetMeasureTest+  , runCustomWidgetCursorTest+  , runCustomWidgetInteractionTest+  , runCustomWidgetQueuedClickTest+  , runCustomWidgetContentDamageTest+  , runCustomWidgetContentKeyTest+  , runReferenceKnobTest+  , runDropTargetTest+  ) where++import Control.Monad (forM_, void)+import Data.IORef (IORef, writeIORef)+import Data.Primitive.SmallArray qualified as SA+import NanoUI+import NanoUI.Context (Context (..))+import NanoUI.Testing+  ( UiCursorKind (..)+  , cursorKindIs+  , newContext+  , runFrame+  , takeDamage+  )+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness (centerOf, clickPair, drawQuads, warmup2, withInputOff)++-- | Verifies custom intrinsic layout measurement via widgetMeasure hook, and+-- that the measurement reverts once the hook is gone.+runCustomWidgetMeasureTest :: Context -> IORef Int -> IO ()+runCustomWidgetMeasureTest ctx failed = do+  let inp = withInput 400 400+      ui measure = column $ do+        fst <$> customWidget defaultCustomWidgetSpec+          { widgetMeasure = measure+          , widgetLayout = defaultLayout+          }+  resp <- warmup2 ctx inp (ui (Just $ \_ _ -> (160, 48)))+  let r = respRect resp+  assert failed (rectW r == 160 && rectH r == 48)+  plain <- warmup2 ctx inp (ui Nothing)+  let Rect _ _ pw ph = respRect plain+  assertEq failed (pw, ph) (32, 32)++-- | Verifies dynamic cursor resolution on custom widgets.+runCustomWidgetCursorTest :: Context -> IORef Int -> IO ()+runCustomWidgetCursorTest ctx failed = do+  let inp0 = withInput 300 300+      ui = column $ do+        fst <$> customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 80 defaultLayout+          , widgetCursor = Just (\_ -> UiCursorNsResize)+          }+  resp <- warmup2 ctx inp0 ui+  let Rect rx ry rw rh = respRect resp+      hoverInp = inp0 { inputMousePos = centerOf resp }+  _ <- runFrame ctx hoverInp ui+  hoverOk <- cursorKindIs ctx hoverInp UiCursorNsResize+  assert failed hoverOk++  let outInp = inp0 { inputMousePos = V2 (rx + rw + 50) (ry + rh + 50) }+  _ <- runFrame ctx outInp ui+  outOk <- cursorKindIs ctx outInp UiCursorNsResize+  assert failed (not outOk)++-- | Verifies interaction state propagation (hover, press, click) and CustomDrawContext.+runCustomWidgetInteractionTest :: Context -> IORef Int -> IO ()+runCustomWidgetInteractionTest ctx failed = do+  let inp0 = withInput 300 300+      ui = column $ do+        customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 40 defaultLayout+          , widgetInteract = \resp cdc _ -> (resp, (cdcHovered cdc, cdcPressed cdc))+          }+  (resp0, _) <- warmup2 ctx inp0 ui+  let pos = centerOf resp0+      (pressInp, releaseInp) = clickPair inp0 pos++  _ <- runFrame ctx pressInp ui+  ((respClick, (hovered, pressed)), _, _, _) <- runFrame ctx releaseInp ui+  assert failed (respClicked respClick)+  assert failed hovered+  assert failed (not pressed)++-- | A click the frame queued for a widget whose pointer hit missed still+-- reaches custom widgets (regression: their default interaction rebuilt the+-- click from hover and release alone, dropping the queued click).+runCustomWidgetQueuedClickTest :: Context -> IORef Int -> IO ()+runCustomWidgetQueuedClickTest ctx failed = do+  let inp0 = (withInput 300 300) {inputMousePos = V2 290 290}+      ui = column $ do+        fromCanvas <- canvas (fixedWH 80 40) (\_ -> pure ())+        fromSpec <- fst <$> customWidget defaultCustomWidgetSpec {widgetLayout = fixedWH 80 40 defaultLayout}+        pure [fromCanvas, fromSpec]+  warm <- warmup2 ctx inp0 ui+  forM_ (zip [0 :: Int ..] warm) $ \(i, resp0) -> do+    writeIORef (ctxClickedId ctx) (respId resp0)+    (resps, _, _, _) <- runFrame ctx inp0 ui+    assert failed (map respClicked resps == [j == i | j <- [0 .. length resps - 1]])++-- | A custom widget whose drawing reads state from outside the spec repaints+-- when that state changes, though its rect and hover/press state stay the+-- same (regression: its ops were cached on those alone, so a table header+-- kept drawing its sort arrow after another column took the sort, and the+-- frame damaged nothing).+runCustomWidgetContentDamageTest :: Context -> IORef Int -> IO ()+runCustomWidgetContentDamageTest ctx failed = do+  let inp = withInputOff 400 300+      red = colorRGBA 255 0 0 255+      blue = colorRGBA 0 0 255 255+      ui on = column $ do+        label "Other"+        fst <$> customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 40 defaultLayout+          , widgetDraw = \_ r -> runCanvas (drawRect r (if on then red else blue))+          }+  resp <- warmup2 ctx inp (ui False)+  _ <- takeDamage ctx+  (_, _, draw, _) <- runFrame ctx inp (ui True)+  dmg <- takeDamage ctx+  case dmg of+    DamageClip clip -> assert failed (coversRect clip (respRect resp))+    DamageFull -> assert failed False+  quads <- drawQuads draw+  assert failed (any ((== red) . snd) quads)+  assert failed (not (any ((== blue) . snd) quads))+  -- The built-in progress bar captures its fraction the same way.+  let bar frac = column (progressBar' frac)+  barResp <- warmup2 ctx inp (bar 0.2)+  _ <- takeDamage ctx+  _ <- runFrame ctx inp (bar 0.8)+  barDmg <- takeDamage ctx+  case barDmg of+    DamageClip clip -> assert failed (coversRect clip (respRect barResp))+    DamageFull -> assert failed False++-- | A content key is taken at its word: while it is unchanged the widget+-- neither rebuilds its ops nor repaints, a new key does both, and a theme+-- change rebuilds them even though the key did not move, since the ops can+-- read the theme.+runCustomWidgetContentKeyTest :: Context -> IORef Int -> IO ()+runCustomWidgetContentKeyTest ctx failed = do+  let inp = withInputOff 400 300+      red = colorRGBA 255 0 0 255+      blue = colorRGBA 0 0 255 255+      ui key on = column $ do+        label "Other"+        fst <$> customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 40 defaultLayout+          , widgetContent = key+          , widgetDraw = \_ r -> runCanvas (drawRect r (if on then red else blue))+          }+  resp <- warmup2 ctx inp (ui 1 False)+  _ <- takeDamage ctx++  -- Same key, different captured state: the ops it already has stand.+  (_, _, keptDraw, _) <- runFrame ctx inp (ui 1 True)+  keptDmg <- takeDamage ctx+  keptQuads <- drawQuads keptDraw+  assert failed (any ((== blue) . snd) keptQuads)+  case keptDmg of+    DamageClip clip -> assert failed (not (coversRect clip (respRect resp)))+    DamageFull -> assert failed False++  -- A new key rebuilds and repaints.+  (_, _, freshDraw, _) <- runFrame ctx inp (ui 2 True)+  freshDmg <- takeDamage ctx+  freshQuads <- drawQuads freshDraw+  assert failed (any ((== red) . snd) freshQuads)+  case freshDmg of+    DamageClip clip -> assert failed (coversRect clip (respRect resp))+    DamageFull -> assert failed False++  -- Disabling the widget repaints it: the ops rebuild in their disabled form,+  -- and disabled is not one of the roles damage already follows.+  let grey = colorRGBA 128 128 128 255+      dimmable off = column $ do+        label "Other"+        disabledWhen off $ fst <$> customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 40 defaultLayout+          , widgetContent = 4+          , widgetDraw = \cdc r -> runCanvas (drawRect r (if cdcDisabled cdc then grey else blue))+          }+  disabledCtx <- newContext+  dresp <- warmup2 disabledCtx inp (dimmable False)+  _ <- takeDamage disabledCtx+  (_, _, disabledDraw, _) <- runFrame disabledCtx inp (dimmable True)+  disabledDmg <- takeDamage disabledCtx+  disabledQuads <- drawQuads disabledDraw+  assert failed (any ((== grey) . snd) disabledQuads)+  case disabledDmg of+    DamageClip clip -> assert failed (coversRect clip (respRect dresp))+    DamageFull -> pure ()++  -- A keyed widget that only moved still draws at its new place: paint+  -- translates the ops it kept.+  let moved lead = column $ do+        spacer Fit (Fixed lead)+        fst <$> customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 40 defaultLayout+          , widgetContent = 5+          , widgetDraw = \_ r -> runCanvas (drawRect r red)+          }+  settled <- warmup2 ctx inp (moved 40)+  let Rect _ my _ _ = respRect settled+  _ <- warmup2 ctx inp (moved 10)+  (_, _, movedDraw, _) <- runFrame ctx inp (moved 40)+  movedQuads <- drawQuads movedDraw+  assert failed (any (\(Rect _ qy _ _, c) -> c == red && abs (qy - my) < 0.5) movedQuads)++  -- Swapping the theme rebuilds a keyed widget that draws from the theme,+  -- through either theme entry point.+  let accent2 = colorRGBA 7 8 9 255+      accent3 = colorRGBA 11 12 13 255+      themedUi = column $ do+        label "Other"+        fst <$> customWidget defaultCustomWidgetSpec+          { widgetLayout = fixedWH 80 40 defaultLayout+          , widgetContent = 3+          , widgetDraw = \cdc r -> runCanvas (drawRect r (themeAccent (cdcTheme cdc)))+          }+  _ <- warmup2 ctx inp themedUi+  theme0 <- getTheme ctx+  setTheme ctx theme0 {themeAccent = accent2}+  (_, _, themedDraw, _) <- runFrame ctx inp themedUi+  themedQuads <- drawQuads themedDraw+  assert failed (any ((== accent2) . snd) themedQuads)+  ctx3 <- withTheme ctx theme0 {themeAccent = accent3}+  (_, _, withThemeDraw, _) <- runFrame ctx3 inp themedUi+  withThemeQuads <- drawQuads withThemeDraw+  assert failed (any ((== accent3) . snd) withThemeQuads)+  setTheme ctx theme0++-- | Whether a damage clip covers a widget's rect.+coversRect :: Rect -> Rect -> Bool+coversRect (Rect cx cy cw ch) (Rect x y w h) =+  cx <= x && cy <= y && cx + cw >= x + w && cy + ch >= y + h++-- | Verifies the reference rotary knob widget.+runReferenceKnobTest :: Context -> IORef Int -> IO ()+runReferenceKnobTest ctx failed = do+  let inp0 = withInput 300 300+      ui = column $ knob' 0 100 25+  (resp0, val0) <- warmup2 ctx inp0 ui+  assert failed (val0 == 25)++  let pos = centerOf resp0+      dragStart = inp0 { inputMousePos = pos, inputMouseDown = True, inputMousePressed = True }+      -- Drag upward (negative dy in screen coords) to increase knob value+      dragUp = inp0 { inputMousePos = V2 (v2X pos) (v2Y pos - 30), inputMouseDown = True, inputMousePressed = False }+      release = inp0 { inputMousePos = V2 (v2X pos) (v2Y pos - 30), inputMouseDown = False, inputMouseReleased = True }++  _ <- runFrame ctx dragStart ui+  ((respDragged, valDragged), _, _, _) <- runFrame ctx dragUp ui+  assert failed (valDragged > 25)+  assert failed (respChanged respDragged)+  void $ runFrame ctx release ui++-- | Verifies the composable drag-and-drop hook: hover, file, text, and bounds.+runDropTargetTest :: Context -> IORef Int -> IO ()+runDropTargetTest ctx failed = do+  let inp0 = withInput 300 300+      bounds = Rect 10 10 100 100+      dropPoint = V2 60 60+      ui = column (useDrop bounds)+      dropsInp ds = inp0 {inputDrops = SA.smallArrayFromList ds}+  _ <- warmup2 ctx inp0 ui++  let beginInp = dropsInp [DropEvent DropBegin Nothing ""]+  (tgtBegin, _, _, _) <- runFrame ctx beginInp ui+  assert failed (not (dropHovered tgtBegin))++  let hoverInp = dropsInp [DropEvent DropPosition (Just dropPoint) ""]+  (tgtHover, _, _, _) <- runFrame ctx hoverInp ui+  assert failed (dropHovered tgtHover)+  assert failed (dropPosition tgtHover == Just dropPoint)++  -- Payload coordinates are ignored; attribution follows the last drag position.+  let dropInp =+        dropsInp+          [ DropEvent DropFile (Just dropPoint) "/tmp/a.txt"+          , DropEvent DropText (Just dropPoint) "hello"+          ]+  (tgtDrop, _, _, _) <- runFrame ctx dropInp ui+  assert failed (dropReceived tgtDrop)+  assert failed (dropFiles tgtDrop == ["/tmp/a.txt"])+  assert failed (dropTexts tgtDrop == ["hello"])++  -- A drop whose coordinates SDL reports as (0,0) (no final position seen)+  -- still lands on the target the pointer was hovering.+  let originDrop =+        dropsInp+          [ DropEvent DropFile (Just (V2 0 0)) "/tmp/origin.txt"+          , DropEvent DropComplete Nothing ""+          ]+  (tgtOrigin, _, _, _) <- runFrame ctx originDrop ui+  assert failed (dropFiles tgtOrigin == ["/tmp/origin.txt"])++  -- The completing drop clears hover state.+  (tgtDone, _, _, _) <- runFrame ctx inp0 ui+  assert failed (not (dropHovered tgtDone))++  -- A fresh drag that moves outside the target no longer delivers to it.+  _ <- runFrame ctx (dropsInp [DropEvent DropBegin Nothing ""]) ui+  _ <- runFrame ctx (dropsInp [DropEvent DropPosition (Just (V2 250 250)) ""]) ui+  let outInp =+        dropsInp+          [ DropEvent DropFile (Just (V2 250 250)) "/tmp/out.txt"+          , DropEvent DropComplete Nothing ""+          ]+  (tgtOut, _, _, _) <- runFrame ctx outInp ui+  assert failed (not (dropReceived tgtOut))+  assert failed (null (dropFiles tgtOut))
+ test/integration/Cases/Damage.hs view
@@ -0,0 +1,230 @@+module Cases.Damage+  ( runDamageBoundsResolutionTest+  , runExplicitDamageWidgetTest+  , runDamageQueueClearedPerFrameTest+  , runStateChangeDamageTest+  , runOrphanAnimationDamageSettlesTest+  , runVersionedDrawingDamageTest+  , runClipFrameBackdropTest+  , runTextAreaSelectAllDamageTest+  ) where++import Data.IORef (IORef, readIORef, writeIORef)+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness (centerOf, drawQuads, runClick, tabInp, warmup2, withInputOff)++-- | A new version on a versioned drawing repaints its rect. Paint rebuilds the+-- ops once the version moves, and nothing else damages them, so a clip frame+-- would otherwise keep the pixels it drew last time.+runVersionedDrawingDamageTest :: Context -> IORef Int -> IO ()+runVersionedDrawingDamageTest ctx failed = do+  let inp = withInput 400 300+      ui version = column $ do+        _ <- label "Other"+        drawingVersioned version (fixedWH 80 40) $ \r ->+          runCanvas (drawRect r (colorRGBA 255 0 0 255))+  resp <- warmup2 ctx inp (ui 1)+  _ <- takeDamage ctx+  _ <- runFrame ctx inp (ui 2)+  dmg <- takeDamage ctx+  case dmg of+    DamageClip clip -> assert failed (covers clip (respRect resp))+    DamageFull -> assert failed False++-- | Whether the first rect contains the second.+covers :: Rect -> Rect -> Bool+covers (Rect cx cy cw ch) (Rect x y w h) =+  cx <= x && cy <= y && cx + cw >= x + w && cy + ch >= y + h++runDamageBoundsResolutionTest :: Context -> IORef Int -> IO ()+runDamageBoundsResolutionTest _ failed = do+  let base = Rect 10 20 100 50+      rSelf = resolveDamageRect DamageSelf base+      rInflated = resolveDamageRect (DamageInflated 8.0) base+      rExact = resolveDamageRect (DamageExact (Rect 0 0 500 500)) base+      rCustom = resolveDamageRect (DamageCustom (\(Rect x y w h) -> Rect (x - 1) (y - 2) (w + 10) (h + 20))) base+      rNone = resolveDamageRect DamageNone base++  assertEq failed rSelf base+  assertEq failed rInflated (Rect 2 12 116 66)+  assertEq failed rExact (Rect 0 0 500 500)+  assertEq failed rCustom (Rect 9 18 110 70)+  assertEq failed rNone (Rect 0 0 0 0)+  assertEq failed (resolveDamageRect (DamageUnion (DamageInflated 4.0) (DamageInflated 8.0)) base)+    (rectUnion (Rect 6 16 108 58) (Rect 2 12 116 66))+  -- DamageNone is the identity of a union rather than a rect at the origin.+  assertEq failed (resolveDamageRect (DamageUnion DamageSelf DamageNone) base) base+  assertEq failed (resolveDamageRect (DamageUnion DamageNone (DamageExact base)) (Rect 0 0 0 0)) base++runExplicitDamageWidgetTest :: Context -> IORef Int -> IO ()+runExplicitDamageWidgetTest ctx failed = do+  let inp = withInput 400 300+      ui = columnWith (padAll 20) $ do+        w1 <- button' "First"+        w2 <- button' "Second"+        pure (w1, w2)+  -- Warmup to establish solved layout rects+  _ <- runFrame ctx inp ui+  ((w1, _), _, _, _) <- runFrame ctx inp ui+  _ <- takeDamage ctx++  -- Queue explicit widget damage+  let testUi = columnWith (padAll 20) $ do+        w1' <- button' "First"+        w2' <- button' "Second"+        damageWidgetNow (respId w1') (DamageInflated sliderDamageSlop)+        pure (w1', w2')+  _ <- runFrame ctx inp testUi+  dmg <- takeDamage ctx+  let Rect x1 y1 w1Len h1Len = respRect w1+      expected = rectInflate sliderDamageSlop (Rect x1 y1 w1Len h1Len)+      approxEq (Rect a b c d) (Rect e f g h) =+        abs (a - e) < 0.05 && abs (b - f) < 0.05 && abs (c - g) < 0.05 && abs (d - h) < 0.05+  case dmg of+    DamageFull -> assert failed False+    DamageClip r -> assert failed (approxEq r expected)++runDamageQueueClearedPerFrameTest :: Context -> IORef Int -> IO ()+runDamageQueueClearedPerFrameTest ctx failed = do+  let inp = withInput 400 300+      ui = column (label "Static content")+  _ <- warmup2 ctx inp ui+  _ <- takeDamage ctx++  -- Explicit damage in this frame+  let damagedUi = column $ do+        damageRectNow (Rect 5 5 20 20)+        label "Static content"+  _ <- runFrame ctx inp damagedUi+  dmg1 <- takeDamage ctx+  case dmg1 of+    DamageClip r -> assertEq failed r (Rect 5 5 20 20)+    _ -> assert failed False++  -- Next frame without damage requests: damage is empty+  _ <- runFrame ctx inp ui+  dmg2 <- takeDamage ctx+  assert failed (damageIsEmpty dmg2)++  -- Explicit full-window damage, again only for its own frame+  let fullDamagedUi = column $ do+        damageFullNow+        label "Static content"+  _ <- runFrame ctx inp fullDamagedUi+  dmg3 <- takeDamage ctx+  assertEq failed dmg3 DamageFull+  _ <- runFrame ctx inp ui+  dmg4 <- takeDamage ctx+  assert failed (damageIsEmpty dmg4)++runStateChangeDamageTest :: Context -> IORef Int -> IO ()+runStateChangeDamageTest ctx failed = do+  let inp0 = withInput 400 300+      ui = do+        (name, setName) <- useText ""+        row $ do+          label ("Left pane: " <> name)+          setName =<< textInput name++  -- Warm up and focus textInput via Tab+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- takeDamage ctx++  -- Type a character into focused textInput+  _ <- runFrame ctx (inp0 {inputChars = "a"}) ui+  dmg <- takeDamage ctx+  assertEq failed dmg DamageFull++runOrphanAnimationDamageSettlesTest :: Context -> IORef Int -> IO ()+runOrphanAnimationDamageSettlesTest ctx failed = do+  let winInp = withInput 400 300+      inp = winInp {inputDeltaTime = 0.05}+      withBar = columnWith (padAll 20) $ do+        bar <- currentId+        spacer (Fixed 40) (Fixed 20)+        pure bar+      withoutBar = columnWith (padAll 20) (pure ())+  -- Warm up: the bar widget occupies a nonzero 40x20 rect in the arena.+  (wid, _, _, _) <- runFrame ctx inp withBar+  _ <- takeDamage ctx+  -- keepAnimating-style perpetual animation on an established widget.+  startAnimation ctx wid 0 1 1e9+  -- Widget present and animating => damage is a clip over it, not a+  -- whole-window repaint.+  _ <- runFrame ctx inp withBar+  dmgAnimated <- takeDamage ctx+  case dmgAnimated of+    DamageFull -> assert failed False+    DamageClip r -> assert failed (rectW r > 0 && rectH r > 0)+  -- Widget leaves the arena (tab switch). The first absent frame may repaint+  -- its old region.+  _ <- runFrame ctx inp withoutBar+  _ <- takeDamage ctx+  -- The perpetual animation is still live, but it must not force the whole+  -- window to repaint forever after its widget is gone.+  _ <- runFrame ctx inp withoutBar+  live <- anyAnimating ctx+  assert failed live+  dmgAbsent <- takeDamage ctx+  assert failed (damageIsEmpty dmgAbsent)+  -- Guard: a freshly started animation on a widget that has never been laid+  -- out still escalates to a full repaint for its first rect-less frame.+  ctx2 <- newContext+  startAnimation ctx2 (WidgetId 777) 0 1 0.3+  _ <- runFrame ctx2 winInp (label "bare")+  dmgFresh <- takeDamage ctx2+  assertEq failed dmgFresh DamageFull+  _ <- runFrame ctx2 winInp (label "bare")+  dmgFresh2 <- takeDamage ctx2+  assert failed (dmgFresh2 /= DamageFull)++-- | A clip frame repaints its region from the window backdrop, as a full frame+-- repaints from the cleared window. An idle menu-bar title has no fill, so+-- without the backdrop the hover highlight it just lost would stay in the+-- retain texture.+runClipFrameBackdropTest :: Context -> IORef Int -> IO ()+runClipFrameBackdropTest ctx failed = do+  writeIORef (ctxPaintFull ctx) False+  let inp0 = withInputOff 400 300+      ui = rowWith (tight . fillW . fixedH 28) $ do+        file <- menuButton' "File" False+        _ <- menuButton' "Edit" False+        pure file+  file <- warmup2 ctx inp0 ui+  _ <- runFrame ctx inp0 {inputMousePos = centerOf file} ui+  (_, _, draw, _) <- runFrame ctx inp0 ui+  dmg <- takeDamage ctx+  theme <- readIORef (ctxTheme ctx)+  quads <- drawQuads draw+  case dmg of+    DamageClip clip -> do+      assert failed (covers clip (respRect file))+      case quads of+        (r, c) : _ -> do+          assert failed (covers r clip)+          assertEq failed c (themeWindow theme)+        [] -> assert failed False+    DamageFull -> assert failed False++-- | Ctrl+A repaints the text area on the frame that selects, rather than+-- leaving the highlight to a follow-up frame.+runTextAreaSelectAllDamageTest :: Context -> IORef Int -> IO ()+runTextAreaSelectAllDamageTest ctx failed = do+  -- Frame time lets the hover fade from the click finish; a live fade would+  -- damage the area anyway.+  let inp0 = (withInputOff 800 600) {inputDeltaTime = 0.5}+      ui = column $ do+        _ <- label "Notes"+        fst <$> textAreaWith' (fixedWH 200 80) "hello world"+  area <- warmup2 ctx inp0 ui+  _ <- runClick ctx inp0 ui (centerOf area)+  _ <- warmup2 ctx inp0 ui+  _ <- takeDamage ctx+  _ <- runFrame ctx inp0 {inputChars = "a", inputModifiers = Modifiers False True False} ui+  dmg <- takeDamage ctx+  case dmg of+    DamageClip clip -> assert failed (covers clip (respRect area))+    DamageFull -> assert failed False
+ test/integration/Cases/Demo.hs view
@@ -0,0 +1,297 @@+module Cases.Demo+  ( runControlsTabHeightTest+  , runBoundedRadioTest+  , runColorPickerCommitTest+  , runColorPickerChangeOnceTest+  , runColorPickerBarKeysTest+  , runColorPickerRgbaTest+  , runColorPickerEditTest+  , runColorPickerDragAfterFieldTest+  ) where++import Control.Monad (void)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness (held, keyInp, pressAt, releaseAt, runClick, spanCenter, tabInp, warmup2, withInputOff)++data DemoTab+  = Controls+  | List+  | Diagnostics+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++data DemoTheme+  = Light+  | Dark+  | System+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++newtype OffsetChoice = OffsetChoice Int+  deriving (Eq, Show)++instance Bounded OffsetChoice where+  minBound = OffsetChoice 10+  maxBound = OffsetChoice 12++instance Enum OffsetChoice where+  fromEnum (OffsetChoice n) = n+  toEnum = OffsetChoice++runBoundedRadioTest :: Context -> IORef Int -> IO ()+runBoundedRadioTest ctx failed = do+  let inp = withInputOff 300 160+      ui = boundedRadio' (T.pack . show)+  (_, initial) <- warmup2 ctx inp (ui (OffsetChoice 11))+  assertEq failed initial (OffsetChoice 11)+  spans <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans, "OffsetChoice 12" `T.isInfixOf` txt] of+    r : _ -> do+      (_, selected) <- runClick ctx inp (ui (OffsetChoice 11)) (spanCenter r)+      assertEq failed selected (OffsetChoice 12)+      ((_, retained), _, _, _) <- runFrame ctx inp (ui selected)+      assertEq failed retained selected+      ((_, reset), _, _, _) <- runFrame ctx inp (ui (OffsetChoice 10))+      assertEq failed reset (OffsetChoice 10)+    [] -> assert failed False++runControlsTabHeightTest :: Context -> IORef Int -> IO ()+runControlsTabHeightTest ctx failed = do+  let+    inp0 =+      withInputOff 1280 800+    controlsBody dumpRef = do+      heading "Controls"+      (cb, _) <- checkbox' "Feature" False+      _ <- slider 0 100 50+      _ <- select ["Low", "Medium", "High"] 1+      (cp, _) <- colorPicker' (colorRGBA 204 102 102 255)+      _ <- boundedRadio (T.pack . show) Dark+      (ti, _) <- textInput' ""+      separator+      uiIO $ writeIORef dumpRef (Just (cb, cp, ti))+    demoPage dumpRef =+      scrollWith (tight . grow) $+        columnWith (padAll 8 . gap 8 . fillW) $+          rowWith (tight . gap 8 . fillW) $ do+            columnWith (tight . gap 8 . fillW) $ do+              card $ do+                heading "State"+                kv "Feature" "off"+                kv "Volume" "50"+                kv "Quality" "Medium"+                kv "Theme" (T.pack (show Dark))+                kv "Name" "-"+                kv "Clicked" "-"+              card $ do+                heading "Gallery"+                mapM_ (\i -> void (label (T.pack ("thumb line " <> show (i :: Int))))) [1 .. 8]+            card $ do+              (demoTab, setDemoTab) <- useEnum Controls+              setDemoTab+                =<< tabs+                  demoTab+                  [ tab t (T.pack (show t)) $ case t of+                      Controls -> controlsBody dumpRef+                      List -> heading "Tree"+                      Diagnostics -> heading "Diagnostics"+                  | t <- [minBound ..]+                  ]+    -- Heights of the checkbox, colour picker and text input, in that order.+    heights c dumpRef = do+      m <- readIORef dumpRef+      case m of+        Just (cb, cp, ti) -> mapM (fmap (fmap rectH) . getPrevRect c . respId) [cb, cp, ti]+        Nothing -> pure [Nothing, Nothing, Nothing]+    spanOf lbls spans =+      let+        match txt =+          any+            (\lbl -> txt == lbl || T.drop 1 txt == lbl || T.isSuffixOf lbl txt)+            lbls+        ys =+          [ (y, y + h)+          | (Rect _ y _ h, txt, _, _, _) <- spans+          , match txt+          ]+       in+        case ys of+          [] -> 0+          _ -> maximum (map snd ys) - minimum (map fst ys)+  dumpLone <- newIORef Nothing+  ctxLone <- newPixelContext+  _ <- runFrame ctxLone inp0 (columnWith (tight . fillW) (controlsBody dumpLone))+  lone <- heights ctxLone dumpLone+  dumpPage <- newIORef Nothing+  let page = demoPage dumpPage+  _ <- runFrame ctx inp0 page+  _ <- runFrame ctx inp0 page+  page0 <- heights ctx dumpPage+  spans0 <- collectTextSpans ctx+  dumped <- readIORef dumpPage+  cbRect <- maybe (pure Nothing) (\(cb, _, _) -> getPrevRect ctx (respId cb)) dumped+  let hover = maybe inp0 (\r -> inp0 {inputMousePos = spanCenter r}) cbRect+  _ <- runFrame ctx hover page+  pageHover <- heights ctx dumpPage+  spansH <- collectTextSpans ctx+  let+    left0 = spanOf ["State", "Clicked", "Gallery"] spans0+    body0 = spanOf ["Controls"] spans0+    leftH = spanOf ["State", "Clicked", "Gallery"] spansH+    bodyH = spanOf ["Controls"] spansH+    tooTall pageH loneH = case (pageH, loneH) of+      (Just p, Just l) -> l >= 8 && p > l * 1.35+      _ -> True+    jumped a b = case (a, b) of+      (Just x, Just y) -> abs (x - y) > 1+      _ -> True+  assert failed (not (or (zipWith tooTall page0 lone)))+  assert failed (not (or (zipWith tooTall pageHover lone)))+  assert failed (not (or (zipWith jumped page0 pageHover)))+  -- Body must not fill the wrap-line height of the left column.+  assert failed (not (left0 > 80 && body0 > left0 * 0.92))+  assert failed (not (leftH > 80 && bodyH > leftH * 0.92))++-- A press on the SV field previews without committing, a held press keeps+-- sampling it without blanking the field or resetting it to white, and the+-- release commits.+runColorPickerCommitTest :: Context -> IORef Int -> IO ()+runColorPickerCommitTest ctx failed = do+  let initial = colorRGBA 204 102 102 255+  colorRef <- newIORef initial+  let inp0 = withInput 400 420+      packed c = colorToWord32 c+      ui = held colorRef colorPicker'+  (resp, _) <- warmup2 ctx inp0 ui+  let wid = respId resp+      sv = colorPickerSvSquare (respRect resp)+      pt = V2 (rectX sv + rectW sv * 0.9) (rectY sv + 2)+      press = pressAt inp0 pt+      release = releaseAt press+  _ <- runFrame ctx press ui+  storeDrag <- getStore ctx+  assertEq failed (packed (widgetStoreBaseColor storeDrag wid initial)) (packed initial)+  assert failed (packed (widgetStoreColor storeDrag wid initial) /= packed initial)+  _ <- runFrame ctx press {inputMousePressed = False} ui+  storeHold <- getStore ctx+  assertEq+    failed+    (packed (widgetStoreColor storeHold wid initial))+    (packed (widgetStoreColor storeDrag wid initial))+  _ <- runFrame ctx release ui+  storeDone <- getStore ctx+  assertEq+    failed+    (packed (widgetStoreBaseColor storeDone wid initial))+    (packed (widgetStoreColor storeDone wid initial))++runColorPickerRgbaTest :: Context -> IORef Int -> IO ()+runColorPickerRgbaTest ctx failed = do+  let inp0 = withInputOff 400 460+      ui = void (colorPickerRGBA (colorRGBA 204 102 102 128))+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  spans <- collectTextSpans ctx+  let has needle = any (\(_, t, _, _, _) -> needle `T.isInfixOf` t) spans+  assert failed (has "#cc666680")+  assert failed (has "128")+  assert failed (has "Current")+  assert failed (has "New")++-- Typing in a channel field must recolour on the same frame (live edits). The+-- fields are numeric: Up steps the focused one, and letters are dropped.+runColorPickerEditTest :: Context -> IORef Int -> IO ()+runColorPickerEditTest ctx failed = do+  let inp0 = withInput 400 460+      initial = colorRGBA 204 102 102 255+      ui = colorPicker' initial+  _ <- warmup2 ctx inp0 ui+  -- Tab past the field and the hue bar to the R field.+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (inp0 {inputKeys = inputKeysFromList [KeyBackspace, KeyBackspace, KeyBackspace]}) ui+  ((_, col), _, _, _) <- runFrame ctx (inp0 {inputChars = "10"}) ui+  assertEq failed (colorR col) 10+  assertEq failed (colorG col) 102+  ((_, stepped), _, _, _) <- runFrame ctx (keyInp KeyUp inp0) ui+  assertEq failed (colorR stepped) 11+  ((_, lettered), _, _, _) <- runFrame ctx (inp0 {inputChars = "x"}) ui+  assertEq failed (colorR lettered) 11++-- A channel field that had focus must not pull the colour back while the+-- canvas is dragged: pressing the canvas takes focus away from the field.+runColorPickerDragAfterFieldTest :: Context -> IORef Int -> IO ()+runColorPickerDragAfterFieldTest ctx failed = do+  let initial = colorRGBA 204 102 102 255+  colorRef <- newIORef initial+  let inp0 = withInput 400 460+      ui = held colorRef colorPicker'+      tabKey = tabInp inp0+  (resp, _) <- warmup2 ctx inp0 ui+  -- Tab past the field and the hue bar to the R field.+  _ <- runFrame ctx tabKey ui+  _ <- runFrame ctx tabKey ui+  _ <- runFrame ctx tabKey ui+  let sv = colorPickerSvSquare (respRect resp)+      press = pressAt inp0 (V2 (rectX sv + 2) (rectY sv + 2))+      drag =+        press+          { inputMousePressed = False+          , inputMousePos = V2 (rectX sv + rectW sv * 0.9) (rectY sv + rectH sv * 0.9)+          }+  _ <- runFrame ctx press ui+  _ <- runFrame ctx drag ui+  ((_, col), _, _, _) <- runFrame ctx drag ui+  -- Low value keeps every channel dark; a field still writing R would leave+  -- it at 204.+  assert failed (colorR col < 60)++-- respChanged fires on the frame the colour moves and not on later frames+-- (regression: it compared the colour against the initial one). A key step+-- commits at once: the base colour follows the live one.+runColorPickerChangeOnceTest :: Context -> IORef Int -> IO ()+runColorPickerChangeOnceTest ctx failed = do+  let initial = colorRGBA 204 102 102 255+  colorRef <- newIORef initial+  let inp0 = withInput 400 420+      ui = held colorRef colorPicker'+      changed inp = (\((resp, _), _, _, _) -> respChanged resp) <$> runFrame ctx inp ui+  (resp, _) <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  moved <- changed (keyInp KeyRight inp0)+  assert failed moved+  store <- getStore ctx+  let wid = respId resp+      base = colorToWord32 (widgetStoreBaseColor store wid initial)+      neu = colorToWord32 (widgetStoreColor store wid initial)+  assert failed (neu /= colorToWord32 initial)+  assertEq failed base neu+  idle <- mapM changed [inp0, inp0]+  assertEq failed idle [False, False]++-- The hue and alpha bars are focus stops after the field. An arrow moves a+-- bar's handle the way it is drawn (down raises the hue, up lowers the alpha),+-- Shift steps ten times as far, and Home / End jump to the bar's ends.+runColorPickerBarKeysTest :: Context -> IORef Int -> IO ()+runColorPickerBarKeysTest ctx failed = do+  let initial = colorRGBA 204 102 102 200+  colorRef <- newIORef initial+  let inp0 = withInput 440 460+      ui = held colorRef colorPickerRGBA'+      frame inp = (\((_, c), _, _, _) -> c) <$> runFrame ctx inp ui+      key k = inp0 {inputKeys = inputKeysFromList [k]}+  _ <- warmup2 ctx inp0 ui+  _ <- frame (key KeyTab)+  _ <- frame (key KeyTab)+  shifted <- frame ((key KeyDown) {inputModifiers = Modifiers True False False})+  assert failed (colorG shifted > colorG initial + 10)+  home <- frame (key KeyHome)+  assert failed (colorG home <= colorG initial + 1)+  _ <- frame (key KeyTab)+  opaque <- frame (key KeyEnd)+  assertEq failed (colorA opaque) 255+  lowered <- frame (key KeyUp)+  assertEq failed (colorA lowered) 254
+ test/integration/Cases/Grid.hs view
@@ -0,0 +1,116 @@+module Cases.Grid+  ( runGridColumnsWithFontColorTest+  , runNestedGridTest+  , runStaleFontColorTest+  , runFontCompositionTest+  ) where++import Control.Monad (void)+import Data.IORef (IORef)+import Data.List (nub)+import qualified Data.Text as T+import NanoUI+import NanoUI.Context (Context (..))+import NanoUI.Layout.Arena (arenaCount, getStyleIdx, getText)+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)++spanOf :: T.Text -> [(Rect, T.Text, Color, Color, Rect)] -> Maybe (Rect, Color)+spanOf txt spans =+  case [(r, fg) | (r, t, fg, _, _) <- spans, t == txt] of+    (hit : _) -> Just hit+    [] -> Nothing++-- | Font colour and grid column count once shared a node slot, so a coloured+-- grid child set after 'gridWith' collapsed the grid to one column.+runGridColumnsWithFontColorTest :: Context -> IORef Int -> IO ()+runGridColumnsWithFontColorTest ctx failed = do+  let red = colorRGBA 255 0 0 255+      cells = ["c0", "c1", "c2", "c3"]+      ui =+        gridWith 4 (fontColor red . fillW) $+          mapM_ (void . labelWith (fontColor red)) cells+  _ <- runFrame ctx (withInput 800 200) ui+  spans <- collectTextSpans ctx+  let hits = [spanOf c spans | c <- cells]+      xs = [rectX r | Just (r, _) <- hits]+      ys = [rectY r | Just (r, _) <- hits]+  assertEq failed (length xs) 4+  assertEq failed (length (nub xs)) 4+  assertEq failed (length (nub ys)) 1+  assert failed (and [fg == red | Just (_, fg) <- hits])++-- | A grid child that is itself a grid reuses the solver scratch arrays; the+-- parent must still place its remaining cells in their own columns and rows.+runNestedGridTest :: Context -> IORef Int -> IO ()+runNestedGridTest ctx failed = do+  let inner tag = gridWith 2 fillW $ mapM_ (\i -> void (label (tag <> T.pack (show i)))) [0 .. 3 :: Int]+      ui =+        gridWith 2 fillW $ do+          inner "a"+          inner "b"+          void (label "tail0")+          void (label "tail1")+  _ <- runFrame ctx (withInput 800 400) ui+  spans <- collectTextSpans ctx+  case (spanOf "a0" spans, spanOf "b0" spans, spanOf "b3" spans, spanOf "tail0" spans, spanOf "tail1" spans) of+    (Just (a0, _), Just (b0, _), Just (b3, _), Just (t0, _), Just (t1, _)) -> do+      -- Outer columns: the second inner grid sits right of the first.+      assert failed (rectX b0 > rectX a0)+      assertEq failed (rectY b0) (rectY a0)+      -- The outer second row starts below both inner grids.+      assert failed (rectY t0 > rectY b3)+      assertEq failed (rectY t1) (rectY t0)+      -- Tail cells take the outer columns, not the inner grid's columns.+      assert failed (rectX t0 < rectX b0)+      assert failed (rectX t1 > rectX b0 - 8 && rectX t1 <= rectX b0)+    _ -> assert failed False++-- | Nodes created without a layout descriptor (widgets, popups, windows) must+-- not inherit the font colour of whatever node held their index last frame.+runStaleFontColorTest :: Context -> IORef Int -> IO ()+runStaleFontColorTest ctx failed = do+  let red = colorRGBA 255 0 0 255+      inp = withInput 400 200+  _ <- runFrame ctx inp (column (void (labelWith (fontColor red) "painted")))+  _ <- runFrame ctx inp (column (void (button "plain")))+  spans <- collectTextSpans ctx+  case spanOf "plain" spans of+    Just (_, fg) -> assert failed (fg /= red)+    Nothing -> assert failed False++-- | Font size, colour, weight, style and decoration modifiers compose on one+-- label, and the bold/italic/underline helpers set the same style bits.+runFontCompositionTest :: Context -> IORef Int -> IO ()+runFontCompositionTest ctx failed = do+  let inp = withInput 800 600+      customCol = colorRGBA 12 34 56 255+      ui = column $ do+        void $ label "Standard Text"+        void $ labelWith (fontSize 24.0 . fontBold . fontItalic . fontUnderline . fontColor customCol) "Composed"+        void $ labelWith fontStrike "Strike Text"+        bold "Bold Helper"+        italic "Italic Helper"+        underline "Underline Helper"+  _ <- runFrame ctx inp ui+  spans <- collectTextSpans ctx+  case (spanOf "Standard Text" spans, spanOf "Composed" spans) of+    (Just (std, stdFg), Just (r, fg)) -> do+      assertEq failed (rectH std) 16.0+      assertEq failed (rectH r) 24.0+      assertEq failed fg customCol+      assert failed (stdFg /= customCol)+    _ -> assert failed False+  let na = ctxNodeArena ctx+  n <- arenaCount na+  styles <- mapM (\i -> (,) <$> getText na i <*> getStyleIdx na i) [0 .. n - 1]+  case mapM (`lookup` styles) ["Composed", "Strike Text", "Bold Helper", "Italic Helper", "Underline Helper"] of+    Just [composed, strike, b, i, u] -> do+      assertEq failed (textNodeFontWeight composed) WeightBold+      assertEq failed (textNodeFontStyle composed) FontStyleItalic+      assertEq failed (textNodeTextDecoration composed) DecorationUnderline+      assertEq failed (textNodeTextDecoration strike) DecorationStrikethrough+      assertEq failed (textNodeFontWeight b) WeightBold+      assertEq failed (textNodeFontStyle i) FontStyleItalic+      assertEq failed (textNodeTextDecoration u) DecorationUnderline+    _ -> assert failed False
+ test/integration/Cases/HostDraw.hs view
@@ -0,0 +1,69 @@+module Cases.HostDraw+  ( runSquareGeometryTest+  , runExternalTextTest+  ) where++import Control.Monad (forM, void)+import Data.IORef (IORef)+import Data.Word (Word32, Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peekByteOff)+import NanoUI+import NanoUI.Context (setDrawExternalText, setDrawSquareGeometry)+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)++-- | Alpha of every vertex of every indexed triangle.+triangleAlphas :: DrawData -> IO [(Float, Float, Float)]+triangleAlphas dd =+  withForeignPtr (drawVertices dd) $ \vp ->+    withForeignPtr (drawIndices dd) $ \ip ->+      forM [0, 3 .. drawIndexCount dd - 3] $ \i -> do+        a <- alphaAt vp ip i+        b <- alphaAt vp ip (i + 1)+        c <- alphaAt vp ip (i + 2)+        pure (a, b, c)+  where+    alphaAt :: Ptr Word8 -> Ptr Word8 -> Int -> IO Float+    alphaAt vp ip i = do+      vi <- peekByteOff ip (i * indexSize) :: IO Word32+      peekByteOff vp (fromIntegral vi * vertexSize + 20)++controls :: NanoUI ()+controls = column $ do+  void (button "ok")+  void (checkbox "check" True)+  void (slider 0 1 0.5)+  void (button' "menu")++-- | Rounded fills and AA strokes carry transparent fringe vertices next to+-- opaque ones. Square geometry emits only flat primitives, so every triangle+-- has a uniform alpha.+runSquareGeometryTest :: Context -> IORef Int -> IO ()+runSquareGeometryTest ctx failed = do+  let inp = withInput 300 200+      uniform (a, b, c) = a == b && b == c+  (_, _, dRound, _) <- runFrame ctx inp controls+  roundTris <- triangleAlphas dRound+  assert failed (not (all uniform roundTris))+  setDrawSquareGeometry ctx True+  (_, _, dSquare, _) <- runFrame ctx inp controls+  squareTris <- triangleAlphas dSquare+  assert failed (not (null squareTris))+  assert failed (all uniform squareTris)+  setDrawSquareGeometry ctx False++-- | External text keeps text spans but pushes no text quads, so the buffer+-- does not grow with the label length.+runExternalTextTest :: Context -> IORef Int -> IO ()+runExternalTextTest ctx failed = do+  let inp = withInput 400 100+      ui txt = column (void (label txt))+  setDrawExternalText ctx True+  (_, _, dShort, _) <- runFrame ctx inp (ui "ab")+  (_, _, dLong, _) <- runFrame ctx inp (ui "abcdefghijklmnop")+  spans <- collectTextSpans ctx+  assertEq failed (drawVertexCount dLong) (drawVertexCount dShort)+  assert failed (any (\(_, t, _, _, _) -> t == "abcdefghijklmnop") spans)+  setDrawExternalText ctx False
+ test/integration/Cases/Keyboard.hs view
@@ -0,0 +1,201 @@+module Cases.Keyboard+  ( runKeyboardButtonTest+  , runKeyboardCheckboxTest+  , runKeyboardSliderTest+  , runKeyboardRadioTest+  , runKeyboardToggleTest+  , runKeyboardTabHeaderTest+  , runKeyboardDisabledTest+  , runKeyboardModalEligibilityTest+  , runKeyboardFocusRingTest+  ) where++import Data.IORef (IORef, newIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import NanoUI+import NanoUI.Context (Context (..), getFocusVisible, intKey)+import NanoUI.Emit qualified as Emit+import NanoUI.Store (WidgetStore (..))+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt)+import NanoUI.Testing.Harness (centerOf, clickPair, held, keyInp, tabInp, warmup2, withInputOff)++-- Retaining focus while a widget becomes disabled must not bypass the same+-- guard used by pointer interaction. Exercise the shared key-navigation hook.+runKeyboardDisabledTest :: Context -> IORef Int -> IO ()+runKeyboardDisabledTest _ctx failed = do+  let inp = withInputOff 300 160+      check :: (Eq a, Show a) => NanoUI (Response, a) -> Input -> IO ()+      check widget pressed = do+        ctx <- newContext+        ((resp, before), _, _, _) <- runFrame ctx inp widget+        let wid = respId resp+        st <- getStore ctx+        writeIORef (ctxFocusId ctx) wid+        ((afterResp, after), _, _, _) <- runFrame ctx pressed (disabledWhen True widget)+        assertEq failed after before+        assert failed (not (respChanged afterResp) && not (respClicked afterResp))+        afterStore <- getStore ctx+        assertEq failed+          (IM.lookup (intKey wid) (storeText st))+          (IM.lookup (intKey wid) (storeText afterStore))+  check (checkbox' "Disabled" False) (keyInp KeyEnter inp)+  check (checkbox' "Disabled" False) (spaceInp inp)+  check (slider' 0 100 50) (keyInp KeyRight inp)+  check (toggleSwitch' False) (spaceInp inp)+  check (textInput' "initial") (inp {inputChars = "x"})+  check (textArea' "initial") (inp {inputChars = "x"})+  check (searchField' "Search" "initial") (inp {inputChars = "x"})+  check (comboBox' "Choose" ["initial", "other"] "initial") (inp {inputChars = "x"})+  check (do r <- button' "Disabled"; pure (r, respClicked r)) (keyInp KeyEnter inp)++runKeyboardModalEligibilityTest :: Context -> IORef Int -> IO ()+runKeyboardModalEligibilityTest ctx failed = do+  let inp = withInputOff 400 300+      ui = column $ do+        outside <- checkbox' "Outside" False+        (_, inside) <- modal True "Modal" (checkbox' "Inside" False)+        pure (outside, inside)+  ((outside, inside), _, _, _) <- runFrame ctx inp ui+  writeIORef (ctxFocusId ctx) (respId (fst outside))+  (((_, outsideValue), _), _, _, _) <- runFrame ctx (keyInp KeyEnter inp) ui+  assert failed (not outsideValue)+  case inside of+    Nothing -> assert failed False+    Just (resp, _) -> do+      writeIORef (ctxFocusId ctx) (respId resp)+      ((_, after), _, _, _) <- runFrame ctx (keyInp KeyEnter inp) ui+      assert failed (maybe False snd after)++-- | A space key-down frame (space arrives as a character, not a Key).+spaceInp :: Input -> Input+spaceInp inp = inp {inputChars = " "}++-- | Plain buttons activate with Enter and Space while focused.+runKeyboardButtonTest :: Context -> IORef Int -> IO ()+runKeyboardButtonTest ctx failed = do+  let inp0 = withInputOff 200 120+      ui = column $ do+        a <- button "A"+        b <- button "B"+        pure (a, b)+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  ((aEnter, _), _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) ui+  assert failed aEnter+  ((aSpace, _), _, _, _) <- runFrame ctx (spaceInp inp0) ui+  assert failed aSpace+  _ <- runFrame ctx (tabInp inp0) ui+  ((_, bEnter), _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) ui+  assert failed bEnter++-- | A focused checkbox toggles with Space and Enter, and 'Emit.checkbox'+-- emits its new value on keyboard activation.+runKeyboardCheckboxTest :: Context -> IORef Int -> IO ()+runKeyboardCheckboxTest ctx failed = do+  checkedRef <- newIORef False+  let inp0 = withInputOff 200 100+      ui = column (held checkedRef (checkbox' "Opt"))+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  ((_, checked1), _, _, _) <- runFrame ctx (spaceInp inp0) ui+  assert failed checked1+  ((_, checked2), _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) ui+  assert failed (not checked2)+  let emitUi = do+        wid <- currentId+        Emit.checkbox "Emit" False id+        pure wid+  (wid, _, _, _) <- runFrame ctx inp0 emitUi+  writeIORef (ctxFocusId ctx) wid+  (_, messages, _, _) <- runFrame ctx (keyInp KeyEnter inp0) emitUi+  assertEq failed [True] (decodeMessages messages :: [Bool])++-- | A focused slider steps with the arrow keys.+runKeyboardSliderTest :: Context -> IORef Int -> IO ()+runKeyboardSliderTest ctx failed = do+  valueRef <- newIORef 50+  let inp0 = withInputOff 300 80+      ui = column (held valueRef (slider' 0 100))+  (_, v0) <- warmup2 ctx inp0 ui+  assertEq failed v0 50+  _ <- runFrame ctx (tabInp inp0) ui+  ((_, v1), _, _, _) <- runFrame ctx (keyInp KeyRight inp0) ui+  assertGt failed v1 50+  ((_, v2), _, _, _) <- runFrame ctx (keyInp KeyLeft inp0) ui+  assertEq failed v2 50+  ((_, v3), _, _, _) <- runFrame ctx (keyInp KeyDown inp0) ui+  assertEq failed v3 49+  ((_, v4), _, _, _) <- runFrame ctx (keyInp KeyUp inp0) ui+  assertEq failed v4 50++-- | A focused radio group changes selection with the arrow keys.+runKeyboardRadioTest :: Context -> IORef Int -> IO ()+runKeyboardRadioTest ctx failed = do+  selectedRef <- newIORef 0+  let inp0 = withInputOff 200 160+      ui = column (held selectedRef (radio' ["A", "B", "C"]))+  (_, sel0) <- warmup2 ctx inp0 ui+  assertEq failed sel0 0+  _ <- runFrame ctx (tabInp inp0) ui+  ((_, sel1), _, _, _) <- runFrame ctx (keyInp KeyDown inp0) ui+  assertEq failed sel1 1+  ((_, sel2), _, _, _) <- runFrame ctx (keyInp KeyDown inp0) ui+  assertEq failed sel2 2+  ((_, sel3), _, _, _) <- runFrame ctx (keyInp KeyUp inp0) ui+  assertEq failed sel3 1++-- | A toggle switch flips with Space and Enter while focused, and on click.+runKeyboardToggleTest :: Context -> IORef Int -> IO ()+runKeyboardToggleTest ctx failed = do+  onRef <- newIORef False+  let inp0 = withInputOff 200 100+      ui = column (held onRef toggleSwitch')+  (resp0, v0) <- warmup2 ctx inp0 ui+  assert failed (not v0)+  _ <- runFrame ctx (tabInp inp0) ui+  ((_, v1), _, _, _) <- runFrame ctx (spaceInp inp0) ui+  assert failed v1+  ((_, v2), _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) ui+  assert failed (not v2)+  let (press, release) = clickPair inp0 (centerOf resp0)+  _ <- runFrame ctx press ui+  ((clicked, v3), _, _, _) <- runFrame ctx release ui+  assert failed (respClicked clicked && v3)+  _ <- runFrame ctx press ui+  ((clicked2, v4), _, _, _) <- runFrame ctx release ui+  assert failed (respClicked clicked2 && not v4)++data KB = KBA | KBB+  deriving (Eq, Show)++-- | Tab headers are focusable and switch the active tab with Enter.+runKeyboardTabHeaderTest :: Context -> IORef Int -> IO ()+runKeyboardTabHeaderTest ctx failed = do+  let inp0 = withInputOff 300 100+      ui cur =+        tabs cur+          [ tab KBA "Alpha" (label "BodyA")+          , tab KBB "Beta" (label "BodyB")+          ]+  _ <- warmup2 ctx inp0 (ui KBA)+  _ <- runFrame ctx (tabInp inp0) (ui KBA)+  (active1, _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) (ui KBA)+  assertEq failed active1 KBA+  _ <- runFrame ctx (tabInp inp0) (ui KBA)+  (active2, _, _, _) <- runFrame ctx (keyInp KeyEnter inp0) (ui KBA)+  assertEq failed active2 KBB++-- Moving focus with Tab shows the focus ring; a pointer press hides it.+runKeyboardFocusRingTest :: Context -> IORef Int -> IO ()+runKeyboardFocusRingTest ctx failed = do+  let inp = withInputOff 300 160+      ui = column (button' "Go")+  _ <- warmup2 ctx inp ui+  assert failed . not =<< getFocusVisible ctx+  _ <- runFrame ctx (tabInp inp) ui+  assert failed =<< getFocusVisible ctx+  let (press, release) = clickPair inp (V2 5 150)+  _ <- runFrame ctx press ui+  _ <- runFrame ctx release ui+  assert failed . not =<< getFocusVisible ctx
+ test/integration/Cases/Modal.hs view
@@ -0,0 +1,171 @@+module Cases.Modal+  ( runModalCloseDamageTest+  , runModalNoPhantomScrollTest+  , runModalOverlayTest+  , runModalFitsTextTest+  , runModalFractionalScaleNoScrollTest+  ) where++import Control.Monad (forM_, when)+import Data.IORef (IORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt, evalUi, withInput)+import NanoUI.Testing.Harness+  ( centerOf+  , checkIdleFullDamage+  , clickPair+  , keyInp+  , runClick+  , spanYOf+  , warmup2+  , withInputOff+  )++runModalOverlayTest :: Context -> IORef Int -> IO ()+runModalOverlayTest ctx failed = do+  let+    inp0 = withInput 320 200+    ui = column $ do+      outside <- button' "Outside"+      (dlg, mInside) <- modal True "Title" (button' "Inside")+      pure (outside, dlg, mInside)+    closedUi = column $ do+      _ <- button "Outside"+      (dlg, mInside) <- modal False "Title" (button' "Inside")+      pure (dlg, mInside)++  (dlgClosed, mInsideClosed) <- evalUi ctx inp0 closedUi+  assert failed (not (respClicked dlgClosed))+  assert failed (case mInsideClosed of Nothing -> True; _ -> False)+  closedSpans <- collectOverlayTextSpans ctx inp0+  assert failed (not (any (\(_, txt, _, _, _) -> "Title" `T.isInfixOf` txt) closedSpans))++  (_, _, mInside0) <- warmup2 ctx inp0 ui+  overlays <- collectOverlayTextSpans ctx inp0+  assert failed (any (\(_, txt, _, _, _) -> "Title" `T.isInfixOf` txt) overlays)+  assert failed (any (\(_, txt, _, _, _) -> "Inside" `T.isInfixOf` txt) overlays)+  assert failed (not (any (\(_, txt, _, _, _) -> T.strip txt == "X") overlays))++  case mInside0 of+    Nothing -> assert failed False+    Just inside -> do+      let (pressIn, releaseIn) = clickPair inp0 (centerOf inside)+      _ <- runFrame ctx pressIn ui+      ((_, _, mClicked), _, _, _) <- runFrame ctx releaseIn ui+      assert failed (maybe False respClicked mClicked)++      let (backdrop, _) = clickPair inp0 (V2 4 4)+      ((_, dlgHit, _), _, _, _) <- runFrame ctx backdrop ui+      assert failed (respClicked dlgHit)++      let esc = keyInp KeyEscape inp0+      ((_, dlgEsc, _), _, _, _) <- runFrame ctx esc ui+      assert failed (respClicked dlgEsc)+      consumed <- overlayConsumesQuit ctx esc+      assert failed consumed+      _ <- runFrame ctx esc closedUi+      leftover <- overlayConsumesQuit ctx esc+      assert failed (not leftover)++  let tallUi = modal True "Tall" $ do+        forM_ [1 .. 40 :: Int] (\i -> label (T.pack ("Row " <> show i)))+        button "Close"+  (dlgTall, _) <- warmup2 ctx inp0 tallUi+  assert failed (rectH (respRect dlgTall) <= 200)++runModalNoPhantomScrollTest :: Context -> IORef Int -> IO ()+runModalNoPhantomScrollTest ctx failed = do+  let inp0 = withInput 400 300+      ui = modal True "About" $ do+        _ <- label "Immediate-mode GUI for Haskell."+        rowWith fillW $ do+          _ <- spacer (Grow 1) Fit+          _ <- button "Close"+          pure ()+  (dlg, _) <- warmup2 ctx inp0 ui+  let Rect _ _ mw mh = respRect dlg+  assert failed (mw > 0 && mh > 0)+  off0 <- getScrollOffset ctx (respId dlg)+  let wheel = inp0 {inputMousePos = centerOf dlg, inputScroll = V2 0 1}+  _ <- runFrame ctx wheel ui+  off1 <- getScrollOffset ctx (respId dlg)+  assertEq failed off0 0+  assertEq failed off1 0++-- Opening and closing a modal each repaint the whole window on the next idle+-- frame.+runModalCloseDamageTest :: Context -> IORef Int -> IO ()+runModalCloseDamageTest ctx failed = do+  let ui = do+        (open, setOpen) <- useFlag False+        resp <- button' "Open"+        when (respClicked resp) (setOpen True)+        (dlg, _) <- modal open "Title" (label "body")+        when (respClicked dlg) (setOpen False)+        pure resp+      inp0 = withInputOff 320 240+      esc = keyInp KeyEscape inp0+      idle = inp0 {inputDeltaTime = 1}+  _ <- runFrame ctx inp0 ui+  (resp, _, _, _) <- runFrame ctx inp0 ui+  _ <- runClick ctx inp0 ui (centerOf resp)+  checkIdleFullDamage failed ctx idle idle ui+  _ <- runFrame ctx esc ui+  checkIdleFullDamage failed ctx idle idle ui++-- At a fractional display scale, a modal sized to its content does not scroll+-- when that content uses fixed sizes off the device-pixel grid (regression:+-- the solve rounded the measured sizes inside the modal before placement laid+-- it out from them, and snapping a child's origin pushed its bottom below its+-- measured bottom so content-sized parents grew level after level; the body+-- overflowed its viewport by more than the scroll tolerance).+runModalFractionalScaleNoScrollTest :: Context -> IORef Int -> IO ()+runModalFractionalScaleNoScrollTest _ failed =+  forM_ [(scale, rows, nested) | scale <- [1, 1.25, 1.5, 1.75], rows <- [4 .. 8 :: Int], nested <- [False, True]] $ \(scale, rows, nested) -> do+    base <- newContext+    let ctx = withFontMetrics base ((monospaceMetrics 12) {fmSnapScale = scale})+        inp = withInputOff 1000 1000+        field i = rowWith (fillW . fixedH 30 . alignMid) (label (T.pack ("Field " <> show i)))+        section = columnWith (fillW . gap 6) $ do+          label "Section"+          columnWith (fillW . gap 0) $ do+            spacer Fit (Fixed 3)+            forM_ [1 .. rows] field+            spacer Fit (Fixed 3)+        body = columnWith (gap 10) (section >> section >> section >> button "Close")+        -- As the arena's root, and inside other content as an app opens one.+        ui+          | nested = column (label "Behind" >> fst <$> modal True "Details" body)+          | otherwise = fst <$> modal True "Details" body+        -- Whether a wheel over the modal moves its first field.+        scrolls c i = do+          dlg <- warmup2 c i ui+          let wheel = i {inputMousePos = centerOf dlg, inputScroll = V2 0 3}+          spans0 <- collectOverlayTextSpans c i+          _ <- runFrame c wheel ui+          spans1 <- collectOverlayTextSpans c wheel+          assert failed (not (null (spanYOf "Field 1" spans0)))+          pure (spanYOf "Field 1" spans1 /= spanYOf "Field 1" spans0)+    fits <- scrolls ctx inp+    assertEq failed fits False+    -- The same body in a short window does scroll, so the check can fail.+    short <- newContext+    clipped <- scrolls (withFontMetrics short ((monospaceMetrics 12) {fmSnapScale = scale})) (withInputOff 1000 300)+    assertEq failed clipped True++-- A modal widens for a filling label instead of wrapping it, so the label+-- stays one line inside the modal (regression: the label reported no width, the+-- modal stayed at its minimum, and the wrapped body overflowed into a scroll).+runModalFitsTextTest :: Context -> IORef Int -> IO ()+runModalFitsTextTest ctx failed = do+  let inp = withInput 800 600+      sentence = T.pack "A sentence that is wider than the smallest modal allows."+      ui = fst <$> modal True "About" (muted sentence)+  dlg <- warmup2 ctx inp ui+  spans <- collectOverlayTextSpans ctx inp+  let Rect _ _ dw _ = respRect dlg+      whole = [r | (r, t, _, _, _) <- spans, t == sentence]+  assertEq failed (length whole) 1+  forM_ whole $ \(Rect _ _ tw _) -> assertGt failed (dw + 0.5) tw
+ test/integration/Cases/NoThunks.hs view
@@ -0,0 +1,58 @@+module Cases.NoThunks (runNoThunksTest) where++import Data.IORef (IORef, readIORef)+import qualified Data.IntMap.Strict as IM+import NanoUI.Context (Context (..))+import NanoUI.Store (WidgetStore (..))+import NoThunks.Class (NoThunks, noThunks)++import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, withInput)++-- | Long-lived widget state must not retain thunks in stored values. Run a+-- frame whose widgets populate several store maps, then check every stored+-- value directly with nothunks. (Container spines/lists are not checked:+-- on GHC 9.14 nothunks flags WHNF list and IntMap internals as thunks, a+-- false positive. Individual values (Text, Int, Float, Float pairs) are+-- checked precisely, which catches the strict-container WHNF trap+-- where a stored tuple's components remain unevaluated.)+runNoThunksTest :: Context -> IORef Int -> IO ()+runNoThunksTest ctx failed = do+  let inp = withInput 300 200+      ui = column $ do+        _ <- textInput "hello"+        _ <- slider 0 100 42+        pure ()+  _ <- runFrame ctx inp ui+  _ <- runFrame ctx inp ui+  store <- readIORef (ctxStore ctx)+  checkAll failed "storeText" (storeText store)+  checkAll failed "storeInt" (storeInt store)+  checkAll failed "storeFloat" (storeFloat store)+  checkAll failed "storeDouble" (storeDouble store)+  checkAll failed "storePoint" (storePoint store)+  where+    checkAll ::+      NoThunks v => IORef Int -> String -> IM.IntMap v -> IO ()+    checkAll failed' what m =+      IM.foldlWithKey'+        (\acc !k !v -> acc >> checkOne failed' what k v)+        (pure ())+        m++    checkOne :: NoThunks v => IORef Int -> String -> Int -> v -> IO ()+    checkOne failed' what k v = do+      result <- noThunks [] v+      case result of+        Nothing -> pure ()+        Just info -> do+          putStrLn+            ( "thunks retained in "+                ++ what+                ++ " at key "+                ++ show k+                ++ ": "+                ++ show info+            )+          assert failed' False
+ test/integration/Cases/NumericInput.hs view
@@ -0,0 +1,67 @@+module Cases.NumericInput+  ( runNumericInputHexTest+  , runNumericInputTest+  ) where++import Data.IORef (IORef, newIORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness (held, pressAt, releaseAt, warmup2)++-- A numeric field steps with the arrow keys (Shift steps ten times as far),+-- drops typing that is not a number, clamps to its range while typing, and+-- Enter rewrites the text as the clamped value. The stepper's lower half steps+-- down.+runNumericInputTest :: Context -> IORef Int -> IO ()+runNumericInputTest ctx failed = do+  valueRef <- newIORef 12+  let inp = withInput 320 120+      cfg = defaultNumericInputConfig {nicMin = 0, nicMax = 100}+      ui = column (held valueRef (numericInputConfigured' cfg))+      step event = (\((_, v), _, _, _) -> v) <$> runFrame ctx event ui+      key k = inp {inputKeys = inputKeysFromList [k]}+  (resp, _) <- warmup2 ctx inp ui+  _ <- step (key KeyTab)+  stepped <- step (key KeyUp)+  assertEq failed stepped 13+  steppedTen <- step ((key KeyUp) {inputModifiers = Modifiers True False False})+  assertEq failed steppedTen 23+  rejected <- step (inp {inputChars = "4x"})+  assertEq failed rejected 23+  clamped <- step (inp {inputChars = "4"})+  assertEq failed clamped 100+  assert failed =<< spanShown ctx "234"+  _ <- step (key KeyEnter)+  assert failed =<< spanShown ctx "100"+  let Rect x y w h = respRect resp+      press = pressAt inp (V2 (x + w - 4) (y + h * 0.75))+  pressed <- step press+  assertEq failed pressed 99+  released <- step (releaseAt press)+  assertEq failed released 99++-- Hexadecimal mode shows upper-case digits, takes hexadecimal typing but no+-- decimal point, and steps like decimal mode.+runNumericInputHexTest :: Context -> IORef Int -> IO ()+runNumericInputHexTest ctx failed = do+  valueRef <- newIORef 255+  let inp = withInput 320 120+      cfg = defaultNumericInputConfig {nicMin = 0, nicHex = True, nicDecimals = 2}+      ui = column (held valueRef (numericInputConfigured' cfg))+      step event = (\((_, v), _, _, _) -> v) <$> runFrame ctx event ui+      key k = inp {inputKeys = inputKeysFromList [k]}+  _ <- warmup2 ctx inp ui+  assert failed =<< spanShown ctx "FF"+  _ <- step (key KeyTab)+  typed <- step (inp {inputChars = "a"})+  assertEq failed typed 0xFFA+  point <- step (inp {inputChars = "."})+  assertEq failed point 0xFFA+  stepped <- step (key KeyUp)+  assertEq failed stepped 0xFFB+  assert failed =<< spanShown ctx "FFB"++spanShown :: Context -> T.Text -> IO Bool+spanShown ctx txt = any (\(_, t, _, _, _) -> t == txt) <$> collectTextSpans ctx
+ test/integration/Cases/PointerRelease.hs view
@@ -0,0 +1,146 @@+-- | A click belongs to the widget its press went down on. Dragging off a+-- widget and letting go over a neighbour must fire nothing.+module Cases.PointerRelease+  ( runReleaseElsewhereTest+  , runRightReleaseElsewhereTest+  , runReleaseReturnsTest+  , runOverlapPressTest+  ) where++import Control.Monad (void)+import Data.IORef (IORef, newIORef)+import Data.Maybe (isJust, isNothing)+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, withInput)+import NanoUI.Testing.Harness (centerOf, held, warmup2)++-- | Press one widget, drag onto another, release: neither one fires, this+-- frame or the next.+runReleaseElsewhereTest :: Context -> IORef Int -> IO ()+runReleaseElsewhereTest ctx failed = do+  -- The checkbox drives its own state across frames, so a stray toggle sticks+  -- and the value assertions below have something to catch.+  flag <- newIORef False+  let inp0 = withInput 320 240+      ui = column $ do+        a <- button' "Alpha"+        b <- button' "Beta"+        (cb, on) <- held flag (checkbox' "Flag")+        pure (a, b, cb, on)++  (a, b, cb, _) <- warmup2 ctx inp0 ui+  let at r = inp0 {inputMousePos = centerOf r}+      pressOn r = (at r) {inputMouseDown = True, inputMousePressed = True}+      dragTo r p = p {inputMousePos = centerOf r, inputMousePressed = False}+      releaseOn r p = (dragTo r p) {inputMouseDown = False, inputMouseReleased = True}++  -- Button to button.+  _ <- runFrame ctx (pressOn a) ui+  ((_, bDrag, _, _), _, _, _) <- runFrame ctx (dragTo b (pressOn a)) ui+  assert failed (not (respHovered bDrag) && not (respPressed bDrag))+  ((aUp, bUp, _, _), _, _, _) <- runFrame ctx (releaseOn b (pressOn a)) ui+  assert failed (not (respClicked aUp) && not (respClicked bUp))+  ((aNext, bNext, _, _), _, _, _) <- runFrame ctx (at b) ui+  assert failed (not (respClicked aNext) && not (respClicked bNext))++  -- Button to checkbox: the checkbox must not toggle.+  _ <- runFrame ctx (pressOn a) ui+  ((_, _, cbUp, _), _, _, _) <- runFrame ctx (releaseOn cb (pressOn a)) ui+  assert failed (not (respClicked cbUp))+  ((_, _, _, checked), _, _, _) <- runFrame ctx (at cb) ui+  assert failed (not checked)++  -- Checkbox to button: neither fires, and the box stays clear.+  _ <- runFrame ctx (pressOn cb) ui+  ((_, bOver, cbOff, _), _, _, _) <- runFrame ctx (releaseOn b (pressOn cb)) ui+  assert failed (not (respClicked bOver) && not (respClicked cbOff))+  ((_, _, _, stillOff), _, _, _) <- runFrame ctx (at b) ui+  assert failed (not stillOff)++-- | The same rule for the right button: a context menu opens where the right+-- press went down, not where it came up. Also covers the container path, since+-- the menu area's response comes from a container node rather than a leaf.+runRightReleaseElsewhereTest :: Context -> IORef Int -> IO ()+runRightReleaseElsewhereTest ctx failed = do+  let inp0 = withInput 320 240+      ui = column $ do+        a <- button' "Alpha"+        (lbl, menu) <-+          contextMenuArea (fixedH 60 . fillW) (label' "Area") (const (menuItem "Cut"))+        pure (a, lbl, menu)+  (a, lbl, _) <- warmup2 ctx inp0 ui+  let rightPressOn r =+        inp0+          { inputMousePos = centerOf r+          , inputMouseRightDown = True+          , inputMouseRightPressed = True+          }+      rightReleaseOn r p =+        p+          { inputMousePos = centerOf r+          , inputMouseRightPressed = False+          , inputMouseRightDown = False+          , inputMouseRightReleased = True+          }++  -- Right press on the button, release over the menu area: no menu.+  _ <- runFrame ctx (rightPressOn a) ui+  ((aUp, _, menuUp), _, _, _) <- runFrame ctx (rightReleaseOn lbl (rightPressOn a)) ui+  assert failed (not (respRightClicked aUp))+  assert failed (isNothing menuUp)++  -- Right press and release inside the area: the menu opens.+  _ <- runFrame ctx (rightPressOn lbl) ui+  ((_, _, menuSame), _, _, _) <- runFrame ctx (rightReleaseOn lbl (rightPressOn lbl)) ui+  assert failed (isJust menuSame)++-- | Leaving a widget mid-press and coming back still clicks it, and a plain+-- press-release on one widget is unaffected.+runReleaseReturnsTest :: Context -> IORef Int -> IO ()+runReleaseReturnsTest ctx failed = do+  let inp0 = withInput 320 240+      ui = column $ do+        a <- button' "Alpha"+        b <- button' "Beta"+        pure (a, b)+  (a, b) <- warmup2 ctx inp0 ui+  let at r = inp0 {inputMousePos = centerOf r}+      pressOn r = (at r) {inputMouseDown = True, inputMousePressed = True}+      moveTo r p = p {inputMousePos = centerOf r, inputMousePressed = False}+      releaseOn r p = (moveTo r p) {inputMouseDown = False, inputMouseReleased = True}++  -- Straight click.+  _ <- runFrame ctx (pressOn a) ui+  ((aUp, _), _, _, _) <- runFrame ctx (releaseOn a (pressOn a)) ui+  assert failed (respClicked aUp)++  -- Wander off and back before letting go.+  _ <- runFrame ctx (pressOn b) ui+  _ <- runFrame ctx (moveTo a (pressOn b)) ui+  ((_, bBack), _, _, _) <- runFrame ctx (releaseOn b (pressOn b)) ui+  assert failed (respClicked bBack)+  void (runFrame ctx inp0 ui)++-- | Where two widgets overlap, a held press belongs to the one hover lights+-- up: the earlier sibling, which paints on top.+runOverlapPressTest :: Context -> IORef Int -> IO ()+runOverlapPressTest ctx failed = do+  let inp0 = withInput 320 240+      ui = rowWith (gap (-30)) $ do+        a <- buttonWith' (fixedW 80) "Alpha"+        b <- buttonWith' (fixedW 80) "Beta"+        pure (a, b)+  (a, _) <- warmup2 ctx inp0 ui+  let Rect ax ay aw ah = respRect a+      overlap = inp0 {inputMousePos = V2 (ax + aw - 10) (ay + ah / 2)}+      press = overlap {inputMouseDown = True, inputMousePressed = True}+      held' = overlap {inputMouseDown = True}+  _ <- runFrame ctx overlap ui+  hot <- getHotId ctx+  assert failed (hot == respId a)+  _ <- runFrame ctx press ui+  ((aHeld, bHeld), _, _, _) <- runFrame ctx held' ui+  assert failed (respPressed aHeld && not (respPressed bHeld))+  void (runFrame ctx (overlap {inputMouseReleased = True}) ui)+  void (runFrame ctx inp0 ui)
+ test/integration/Cases/RichText.hs view
@@ -0,0 +1,66 @@+module Cases.RichText+  ( runRichTextWrapTest+  , runRichTextLinkTest+  ) where++import Control.Monad (void)+import Data.IORef (IORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Context (Context (..))+import NanoUI.Testing (UiCursorKind (..), cursorKindIs, runFrame)+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness (clickPair, drawQuads, warmup2)++-- | A paragraph wraps at its column's width, taking a line's height per line,+-- and mixed pieces share a line.+runRichTextWrapTest :: Context -> IORef Int -> IO ()+runRichTextWrapTest ctx failed = do+  let inp = withInput 400 400+      paragraph = [inlineText (T.replicate 12 "word "), strong "bold", " end"]+      ui = columnWith (fixedW 200) $ do+        one <- fst <$> richText' ["word"]+        wrapped <- fst <$> richText' paragraph+        pure (one, wrapped)+  (one, wrapped) <- warmup2 ctx inp ui+  let Rect _ _ _ lineH = respRect one+      Rect _ _ w h = respRect wrapped+  assert failed (lineH > 0)+  assert failed (w <= 200)+  -- Twelve words and two more pieces cannot fit on one 200px line.+  assert failed (h >= 2 * lineH)+  assertEq failed 0 (round h `mod` round lineH :: Int)++-- | A link reports its target when clicked and shows the pointer cursor;+-- text beside it reports nothing.+runRichTextLinkTest :: Context -> IORef Int -> IO ()+runRichTextLinkTest ctx failed = do+  let inp0 = withInput 400 400+      ui = column (richText' ["Go to ", hyperlink "docs-target" "the docs", " now"])+      fm = ctxFontMetrics ctx+  (resp, _) <- warmup2 ctx inp0 ui+  prefixW <- sum <$> mapM (lineWidthIO fm) ["Go", " ", "to", " "]+  linkW <- sum <$> mapM (lineWidthIO fm) ["the", " ", "docs"]+  let Rect rx ry _ rh = respRect resp+      onLink = V2 (rx + prefixW + linkW / 2) (ry + rh / 2)+      onText = V2 (rx + 2) (ry + rh / 2)+      clickAt pos = do+        let (press, release) = clickPair inp0 pos+        void (runFrame ctx inp0 {inputMousePos = pos} ui)+        void (runFrame ctx press ui)+        ((_, clicked), _, _, _) <- runFrame ctx release ui+        pure clicked+  linkClick <- clickAt onLink+  assertEq failed (Just "docs-target") linkClick+  pointer <- cursorKindIs ctx inp0 {inputMousePos = onLink} UiCursorPointer+  assert failed pointer+  -- The hovered link is underlined once, across its words and the space+  -- between them.+  (_, _, dd, _) <- runFrame ctx inp0 {inputMousePos = onLink} ui+  quads <- drawQuads dd+  let underlines = [r | (r@(Rect _ _ w h), _) <- quads, h < 3, abs (w - linkW) < 0.5]+  assertEq failed 1 (length underlines)+  textClick <- clickAt onText+  assertEq failed Nothing textClick+  plainCursor <- cursorKindIs ctx inp0 {inputMousePos = onText} UiCursorPointer+  assert failed (not plainCursor)
+ test/integration/Cases/Runner.hs view
@@ -0,0 +1,94 @@+module Cases.Runner (runSessionLoopTest, runDrawingLockTest) where++import Control.Exception+  ( IOException+  , MaskingState (Unmasked)+  , getMaskingState+  , throwIO+  , try+  )+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)+import NanoUI (Input (..), V2 (..), emptyInput)+import NanoUI.Debug (newDebugSampler)+import NanoUI.Runner+import NanoUI.Testing (Context, clearDirty)+import NanoUI.Testing.Assert (assertEq)++-- Exercise queued edges, a dirty follow-up frame, skipped input, and blocking+-- waits without requiring a native window or depending on wall-clock timing.+runSessionLoopTest :: Context -> IORef Int -> IO ()+runSessionLoopTest ctx failed = do+  logRef <- newIORef []+  waits <- newIORef [(-1, [1, 2]), (0, []), (-1, []), (-1, [3 :: Int])]+  draws <- newIORef (0 :: Int)+  debug <- newDebugSampler+  let+    note message = modifyIORef' logRef (<> [message])+    driver =+      SessionDriver+        { sdPollEvents = do+            note "poll"+            pure []+        , sdWaitEvents = \timeout -> do+            note ("wait " <> show timeout)+            (expected, events) <- atomicModifyIORef' waits $ \batches -> case batches of+              batch : rest -> (rest, batch)+              [] -> ([], (timeout, [3]))+            assertEq failed expected timeout+            pure events+        , sdApplyEvent = \inp event -> inp {inputMousePos = V2 (fromIntegral event) 0}+        , sdIsButtonEdge = const True+        , sdIsHardQuit = const False+        , sdIsSessionQuit = (== 3)+        , sdSyncDisplay = \c inp -> pure (c, inp)+        , sdDebug = debug+        , sdContinuous = False+        , sdPacingMs = 16+        , sdPresentPaces = pure False+        , sdAlignSec = 0+        , sdShouldDraw = \_ previous current _ _ -> do+            note ("decide " <> show (inputMousePos previous, inputMousePos current))+            pure (inputMousePos current == V2 1 0)+        , sdDraw = \_ inp _ -> do+            n <- atomicModifyIORef' draws (\n -> (n + 1, n + 1))+            note "draw"+            pure (n <= 2, inp {inputMousePos = V2 10 0})+        , sdOnCursor = \_ _ -> note "cursor"+        , sdShouldQuit = const False+        }+  -- A new context starts dirty, which would make the first wait immediate.+  clearDirty ctx+  runSessionLoop driver ctx emptyInput+  actual <- readIORef logRef+  assertEq+    failed+    [ "wait -1"+    , "decide " <> show (V2 0 0, V2 1 0)+    , "draw"+    , "cursor"+    , "draw"+    , "cursor"+    , "poll"+    , "wait 0"+    , "draw"+    , "cursor"+    , "wait -1"+    , "decide " <> show (V2 10 0, V2 10 0)+    , "cursor"+    , "wait -1"+    ]+    actual+  assertEq failed 3 =<< readIORef draws++runDrawingLockTest :: Context -> IORef Int -> IO ()+runDrawingLockTest _ failed = do+  lock <- newDrawingLock+  result <- tryWithDrawingLock lock $ do+    assertEq failed Unmasked =<< getMaskingState+    assertEq failed Nothing =<< tryWithDrawingLock lock (pure ())+  assertEq failed (Just ()) result+  failure <-+    try (tryWithDrawingLock lock (throwIO (userError "draw failed"))) ::+      IO (Either IOException (Maybe ()))+  assertEq failed True (either (const True) (const False) failure)+  assertEq failed (Just ()) =<< tryWithDrawingLock lock (pure ())
+ test/integration/Cases/SIMD.hs view
@@ -0,0 +1,66 @@+module Cases.SIMD (runSimdWritesTest) where++import Control.Monad (forM, forM_)+import Data.IORef (IORef)+import Data.Word (Word32, Word8)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Marshal.Utils (fillBytes)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peekByteOff)+import NanoUI.SIMD+import NanoUI.Testing (Context)+import NanoUI.Testing.Assert (assertEq)++-- Check the renderer's interleaved vertex ABI, triangle winding and byte+-- offsets directly. Guard bytes also catch writes beyond either buffer range.+runSimdWritesTest :: Context -> IORef Int -> IO ()+runSimdWritesTest _ failed = do+  let+    solid vp ip = pokeQuadSIMD vp 16 ip 16 2 3 5 7 0 0.25 0.5 1 1 0 0.5 1 7+    gradient vp ip =+      pokeQuadGradientSIMD+        vp+        16+        ip+        16+        2+        3+        5+        7+        0.25+        0.5+        (1, 0, 0, 1)+        (0, 1, 0, 1)+        (0, 0, 1, 1)+        (1, 1, 1, 0.5)+        7+    solidVertices =+      [ [2, 3, 1, 0, 0.5, 1, 0, 0.25]+      , [7, 3, 1, 0, 0.5, 1, 0.5, 0.25]+      , [7, 10, 1, 0, 0.5, 1, 0.5, 1]+      , [2, 10, 1, 0, 0.5, 1, 0, 1]+      ]+    gradientVertices =+      [ [2, 3, 1, 0, 0, 1, 0.25, 0.5]+      , [7, 3, 0, 1, 0, 1, 0.25, 0.5]+      , [7, 10, 0, 0, 1, 1, 0.25, 0.5]+      , [2, 10, 1, 1, 1, 0.5, 0.25, 0.5]+      ]+    checkQuad :: (Ptr Word8 -> Ptr Word8 -> IO ()) -> [[Float]] -> IO ()+    checkQuad write expected =+      allocaBytes 160 $ \vp -> allocaBytes 56 $ \ip -> do+        fillBytes vp 0xa5 160+        fillBytes ip 0xa5 56+        write vp ip+        actual <- forM [0 .. 31 :: Int] $ \i -> peekByteOff vp (16 + i * 4)+        indices <- forM [0 .. 5 :: Int] $ \i -> peekByteOff ip (16 + i * 4)+        assertEq failed (concat expected) actual+        assertEq failed ([7, 8, 9, 7, 9, 10] :: [Word32]) indices+        forM_ [(vp, 144), (ip, 40)] $ \(ptr, end) -> do+          guardBytes <- mapM (peekByteOff ptr) ([0 .. 15] ++ [end .. end + 15])+          assertEq failed (replicate 32 0xa5 :: [Word8]) guardBytes+  checkQuad solid solidVertices+  checkQuad gradient gradientVertices+  let+    expectedOffsets = ((1, 2), (4, 6), (7, 10), (10, 14))+  assertEq failed expectedOffsets (concentricOffsetsSIMD 1 2 3 4 0 1 2 3)
+ test/integration/Cases/Scroll.hs view
@@ -0,0 +1,722 @@+module Cases.Scroll+  ( runNestedScrollFocusTest+  , runNestedScrollTest+  , runScrollBarGutterTest+  , runScrollButtonClickTest+  , runScrollDamageTest+  , runScrollHoverClipTest+  , runScrollThumbCursorTest+  , runScrollTopClipTest+  , runScrolledOutImmunityTest+  , run2DPadFillOverflowTest+  , run2DPadOverflowScrollsTest+  , runScrollLockstepProbeTest+  , runPageScrollBackdropCoverageTest+  , runScrollStepTest+  , runScrollSmoothTest+  , runScrollMetricsTest+  , runScrollIntoViewTest+  , runScrollGlideClampTest+  ) where++import Control.Monad (forM, forM_, replicateM, replicateM_, void, when)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (sort)+import Data.Maybe (isJust, isNothing, listToMaybe)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (peekElemOff)+import Data.Text qualified as T+import NanoUI+import NanoUI.Context (ctxNodeArena, setDrawSnapScale)+import NanoUI.Layout.Arena+  ( NodeType (..)+  , findNodeM+  , getNodeValue+  , getNodeType+  , getRect+  , getScrollContentW+  , getWidgetId+  )+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt, withInput)+import NanoUI.Testing.Harness+  ( assertScrollGutterPad+  , centerOf+  , drawQuads+  , findGrabHover+  , runClick+  , spanCenter+  , spanYOf+  , tabInp+  , warmup2+  , withInputOff+  )++runScrollThumbCursorTest :: Context -> IORef Int -> IO ()+runScrollThumbCursorTest ctx failed = do+  let inp0 = withInput 200 120+      ui = scrollArea (fillW . fixedH 80)+             (column (replicateM 8 (label "scroll line") >> pure ()))+  ((sid, ()), _, _, _) <- runFrame ctx inp0 ui >>= \_ -> runFrame ctx inp0 ui+  mrect <- getPrevRect ctx sid+  case mrect of+    Nothing -> assert failed False+    Just (Rect rx ry rw rh) -> do+      let thumbX = rx + rw - scrollBarGutter ScrollBarList 0 / 2+          tryYs = [ry + rh * n / 8 | n <- [1 .. 7]]+      mHover <- findGrabHover ctx ui inp0 thumbX tryYs+      case mHover of+        Nothing -> assert failed False+        Just hover -> do+          kind <- uiCursorKind ctx hover+          assertEq failed kind UiCursorGrab+          let press = hover {inputMouseDown = True, inputMousePressed = True}+          _ <- runFrame ctx press ui+          grabbing <- cursorKindIs ctx press UiCursorGrabbing+          assert failed grabbing++-- The scroll content's right edge stops at the scrollbar gutter, one gap+-- before the bar. The gap matches the scroller's right padding and is never+-- under the side gap. A list bar keeps that gap to its well's edge as well;+-- a page bar sits a side gap inside the page's edge.+runScrollBarGutterTest :: Context -> IORef Int -> IO ()+runScrollBarGutterTest ctx failed = do+  let listPad = padR (layoutPadding defaultLayout)+      wideThen n = do+        r <- labelWith' fillW "Wide"+        _ <- replicateM n (label "scroll line")+        pure r+      cases =+        [ ( withInput 200 120+          , scrollArea (fillW . fixedH 60) (wideThen 8)+          , scrollBarGutter ScrollBarList listPad+          , listPad+          )+        , ( withInput 240 140+          , scrollArea (tight . grow) (wideThen 20)+          , scrollBarGutter ScrollBarPage 0+          , 0+          )+        , ( withInput 240 140+          , scrollArea (padAll 12 . grow) (wideThen 20)+          , scrollBarGutter ScrollBarPage 12+          , 12+          )+        , ( withInput 240 140+          , panelWith grow (scrollArea (tight . grow) (wideThen 20))+          , scrollBarGutter ScrollBarList 0+          , 0+          )+        ]+  forM_ cases $ \(inp0, ui, gutter, endPad) -> do+    (sid, child) <- warmup2 ctx inp0 ui+    assertScrollGutterPad failed ctx sid child gutter endPad+  -- The padded page's bar takes the pointer just inside the page's edge. The+  -- sliver past it and the gap before it stay clear.+  let inp0 = withInputOff 240 140+      page = scrollArea (padAll 12 . grow) (wideThen 20)+  (sid, _) <- warmup2 ctx inp0 page+  mrect <- getPrevRect ctx sid+  case mrect of+    Nothing -> assert failed False+    Just (Rect sx sy sw sh) -> do+      let ys = [sy + sh * n / 8 | n <- [1 .. 7]]+      let barLeft = sx + sw - scrollBarGutter ScrollBarPage 12+      onBar <- findGrabHover ctx page inp0 (barLeft + scrollBarWidth / 2) ys+      assert failed (isJust onBar)+      past <- findGrabHover ctx page inp0 (sx + sw - 1) ys+      assert failed (isNothing past)+      gapBefore <- findGrabHover ctx page inp0 (barLeft - 6) ys+      assert failed (isNothing gapBefore)++-- Each change of a scroll offset damages the scroll viewport only.+runScrollDamageTest :: Context -> IORef Int -> IO ()+runScrollDamageTest ctx failed = do+  let scrollUi =+        fmap fst $+          scrollArea (fillW . fixedH 60) $+            column (replicateM 8 (label "scroll line") >> pure ())+      inp0 = withInputOff 200 120+  sid <- warmup2 ctx inp0 scrollUi+  forM_ [24, 48] $ \off -> do+    _ <- runFrame ctx inp0 (scrollUi >> uiIO (setScrollOffset ctx sid off))+    dScroll <- takeDamage ctx+    case dScroll of+      DamageFull -> assert failed False+      DamageClip r -> assert failed (rectW r > 0 && rectH r > 0 && rectH r <= 60 + defaultDamageSlop * 2 && not (damageIsEmpty dScroll))++-- Ghosting guard: a grow×grow (page-level) scroll container paints no well,+-- so on clip frames the strip vacated by scrolled content has no covering+-- command and the retained texture would show stale pixels, a ghost of a+-- previous scroll position. Every frame must emit a full-viewport fill (the+-- window-color backdrop) so clip replay repaints the whole viewport.+runPageScrollBackdropCoverageTest :: Context -> IORef Int -> IO ()+runPageScrollBackdropCoverageTest ctx failed = do+  let inp0 = withInputOff 300 220+      ui = fmap fst $+        scrollArea+          grow+          (column (replicateM 20 (label "scroll backdrop line") >> pure ()))+  sid <- warmup2 ctx inp0 ui+  setScrollOffset ctx sid 120+  _ <- runFrame ctx inp0 ui+  (_, _, draw, _) <- runFrame ctx inp0 ui+  mRect <- getPrevRect ctx sid+  case mRect of+    Nothing -> assert failed False+    Just (Rect rx ry rw rh) -> do+      quads <- drawQuads draw+      let covered =+            any+              (\(Rect qx qy qw qh, _) ->+                abs (qx - rx) <= 0.6+                  && abs (qy - ry) <= 0.6+                  && abs (qx + qw - (rx + rw)) <= 0.6+                  && abs (qy + qh - (ry + rh)) <= 0.6)+              quads+      assert failed covered++runScrollTopClipTest :: Context -> IORef Int -> IO ()+runScrollTopClipTest ctx failed = do+  cbRef <- newIORef Nothing+  let inp0 = withInputOff 400 160+      ui = do+        scrollWith (tight . grow) $+          columnWith (padAll 8 . gap 8 . fillW) $+            card $ do+              heading "Controls"+              (cb, _) <- checkbox' "Feature" False+              _ <- slider 0 100 50+              mapM_ (\i -> void (label (T.pack ("pad line " <> show (i :: Int))))) [1 .. 16]+              uiIO $ writeIORef cbRef (Just cb)+              pure ()+      clipFits dmg = case dmg of+        DamageFull -> True+        DamageClip (Rect _ y _ h) -> y >= -1 && y + h <= 160 + 1+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  mCb <- readIORef cbRef+  case mCb of+    Nothing -> assert failed False+    Just cb -> do+      mR <- getPrevRect ctx (respId cb)+      case mR of+        Nothing -> assert failed False+        Just r -> do+          let hover = inp0 {inputMousePos = spanCenter r}+          _ <- runFrame ctx hover ui+          dHover <- takeDamage ctx+          assert failed (clipFits dHover)++runNestedScrollTest :: Context -> IORef Int -> IO ()+runNestedScrollTest ctx failed = do+  let inp0 = withInput 200 200+      ui = scrollArea (fillW . fixedH 90) $+             column $ do+               (inner, ()) <- scrollArea (fillW . fixedH 40) $+                                column (mapM_ (\i -> label (T.pack ("in " <> show (i :: Int)))) [1 .. 12])+               mapM_ (\i -> label (T.pack ("out " <> show (i :: Int)))) [1 .. 12]+               pure inner+  (outer, inner) <- warmup2 ctx inp0 ui+  mInner <- getPrevRect ctx inner+  mOuter <- getPrevRect ctx outer+  case (mInner, mOuter) of+    (Just r@(Rect ix iy iw ih), Just (Rect _ oy _ oh)) | iw > 0 && ih > 0 -> do+      let hoverInner = inp0 {inputMousePos = spanCenter r}+          wheelInner = hoverInner {inputScroll = V2 0 1}+      offI0 <- getScrollOffset ctx inner+      offO0 <- getScrollOffset ctx outer+      _ <- runFrame ctx wheelInner ui+      offI1 <- getScrollOffset ctx inner+      offO1 <- getScrollOffset ctx outer+      assertGt failed offI1 offI0+      assertEq failed offO1 offO0+      let pumpInner = do+            before <- getScrollOffset ctx inner+            _ <- runFrame ctx wheelInner ui+            after <- getScrollOffset ctx inner+            if after > before then pumpInner else pure ()+      pumpInner+      offO2 <- getScrollOffset ctx outer+      assertEq failed offO2 offO1+      -- Hit rects follow the scroll offset: a wheel just above the fully+      -- scrolled inner viewport must not reach the inner scroller.+      offIMax <- getScrollOffset ctx inner+      _ <- runFrame ctx (inp0 {inputMousePos = V2 (ix + iw / 2) (iy - 6), inputScroll = V2 0 (-1)}) ui+      offIAbove <- getScrollOffset ctx inner+      assertEq failed offIAbove offIMax+      let hoverOuterY = min (oy + oh - 4) (iy + ih + 8)+          wheelOuter = inp0 {inputMousePos = V2 (ix + iw / 2) hoverOuterY, inputScroll = V2 0 1}+      offO3 <- getScrollOffset ctx outer+      _ <- runFrame ctx wheelOuter ui+      offO4 <- getScrollOffset ctx outer+      assertGt failed offO4 offO3+    _ -> assert failed False++runScrollHoverClipTest :: Context -> IORef Int -> IO ()+runScrollHoverClipTest ctx failed = do+  let inp0 = withInput 200 200+      ui = scrollArea (fillW . fixedH 80) $+             column $ do+                mapM_ (\i -> label (T.pack ("out " <> show (i :: Int)))) [1 .. 10]+                (inner, ()) <- scrollArea (fillW . fixedH 36) $+                                 column (mapM_ (\i -> label (T.pack ("in " <> show (i :: Int)))) [1 .. 8])+                pure inner+  (_, inner) <- warmup2 ctx inp0 ui+  mInner <- getPrevRect ctx inner+  case mInner of+    Just r@(Rect _ _ iw ih) | iw > 0 && ih > 0 -> do+      let hoverHidden = inp0 {inputMousePos = spanCenter r, inputScroll = V2 0 1}+      offI0 <- getScrollOffset ctx inner+      _ <- runFrame ctx hoverHidden ui+      offI1 <- getScrollOffset ctx inner+      assert failed (offI1 <= offI0)+    _ -> assert failed False++-- A button scrolled into view inside a fixed-height or a page-level (grow)+-- scroller receives the click at its visual position.+runScrollButtonClickTest :: Context -> IORef Int -> IO ()+runScrollButtonClickTest ctx failed = do+  pixel <- newPixelContext+  forM_+    [ (ctx, withInput 240 160, fillW . fixedH 80)+    , (pixel, withInput 640 120, tight . grow)+    ] $ \(c, inp0, scrollLayout) -> do+      let ui = do+            (hit, setHit) <- useText ""+            (sid, resp) <- scrollArea scrollLayout $+                             column $ do+                               mapM_ (\_ -> void (label "pad")) [(1 :: Int) .. 6]+                               b <- button' "Target"+                               when (respClicked b) (setHit "yes")+                               pure b+            pure (sid, hit, resp)+      (sid, hit0, _) <- warmup2 c inp0 ui+      assertEq failed hit0 ""+      mScroll <- getPrevRect c sid+      case mScroll of+        Just r -> do+          let wheel = inp0 {inputMousePos = spanCenter r, inputScroll = V2 0 1}+          forM_ [(1 :: Int) .. 8] $ \_ -> void (runFrame c wheel ui)+          off <- getScrollOffset c sid+          assertGt failed off 0+          ((_, _, resp1), _, _, _) <- runFrame c inp0 ui+          (_, hit1, _) <- runClick c inp0 ui (centerOf resp1)+          assertEq failed hit1 "yes"+        _ -> assert failed False++runNestedScrollFocusTest :: Context -> IORef Int -> IO ()+runNestedScrollFocusTest ctx failed = do+  let inp0 = withInput 240 220+      ui = scrollArea (fillW . fixedH 90) $+             column $ do+               pair <- scrollArea (fillW . fixedH 50) $+                         column $ do+                           b <- button' "In"+                           mapM_ (\i -> label (T.pack ("in " <> show (i :: Int)))) [1 .. 10]+                           pure b+               mapM_ (\i -> label (T.pack ("out " <> show (i :: Int)))) [1 .. 10]+               pure pair+  (_, (inner, _)) <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  focus <- getFocusId ctx+  assert failed (focus /= WidgetId 0)+  offI0 <- getScrollOffset ctx inner+  -- Wheel events scroll only the scroller under the mouse; owning focus is not+  -- enough, so scrolling away from the inner scroller must not move it.+  let away = inp0 {inputMousePos = V2 230 210, inputScroll = V2 0 1}+  _ <- runFrame ctx away ui+  offI1 <- getScrollOffset ctx inner+  assertEq failed offI1 offI0++-- A button scrolled out of its viewport keeps its last rect, but a pointer+-- there must not hover it, show its cursor, or click it.+runScrolledOutImmunityTest :: Context -> IORef Int -> IO ()+runScrolledOutImmunityTest ctx failed = do+  let inp0 = withInput 240 160+      ui = do+        (hit, setHit) <- useText ""+        (sid, b) <- scrollArea (fillW . fixedH 8) $+                      column $ do+                        mapM_ (\_ -> void (label "pad")) [(1 :: Int) .. 40]+                        btn <- button' "Target"+                        when (respClicked btn) (setHit "yes")+                        pure btn+        pure (sid, b, hit)+  (sid, b, hit0) <- warmup2 ctx inp0 ui+  assertEq failed hit0 ""+  mScroll <- getPrevRect ctx sid+  case mScroll of+    Just r -> do+      let wheel = inp0 {inputMousePos = spanCenter r, inputScroll = V2 0 1}+      forM_ [(1 :: Int) .. 80] $ \_ -> void (runFrame ctx wheel ui)+      mBtn <- getPrevRect ctx (respId b)+      case mBtn of+        Just br -> do+          let pos = spanCenter br+              hover = inp0 {inputMousePos = pos}+          kind <- uiCursorKind ctx hover+          assertEq failed kind UiCursorDefault+          _ <- runFrame ctx hover ui+          hot <- getHotId ctx+          assert failed (hot /= respId b)+          (_, _, hit1) <- runClick ctx hover ui pos+          assertEq failed hit1 ""+        _ -> assert failed False+    _ -> assert failed False++-- | Probe for the reported scroll stair-stepping artifact. Steps a scroll+-- container through fractional offsets at a simulated display scale of 2 and+-- decodes the final (snapped) vertex buffer, comparing the per-row motion of+-- text (glyph quads) against geometry (fill quads such as separators).+-- Asserts every row's text and the adjacent geometry moved by the exact same+-- delta on every transition (text/geometry lockstep).+runScrollLockstepProbeTest :: Context -> IORef Int -> IO ()+runScrollLockstepProbeTest ctx failed = do+  setDrawSnapScale ctx 2+  let inp0 = withInput 300 220+      rows =+        [ ("Feature", "Enabled")+        , ("Volume", "50")+        , ("Quality", "High")+        , ("Accent", "#3D7EFF")+        , ("Theme", "Tomorrow at Midnight Min")+        , ("Theme radio", "Theme radio value")+        , ("Name", "Ada Lovelace")+        , ("Notes", "short note")+        , ("Tree", "1 visible item")+        , ("Table sort", "Name")+        ]+      kvRow k v =+        rowWith (tight . gap 12 . alignMid . fillW) $ do+          labelWith (minW 88 . tight) (T.pack k)+          labelWith (tight . fillW . alignEnd) (T.pack v)+      keys = map (T.pack . fst) rows+      ui =+        scrollArea+          (fillW . fixedH 200)+          (column (mapM_ (\(k, v) -> kvRow k v >> separator) rows))+  _ <- runFrame ctx inp0 ui+  ((sid, ()), _, _, _) <- runFrame ctx inp0 ui+  let steps = [0.0, 0.3, 0.6, 1.0, 1.3, 1.7, 2.0, 2.4, 2.7, 3.1, 3.4, 3.8]+  yss <- forM steps $ \off -> do+    setScrollOffset ctx sid off+    _ <- runFrame ctx inp0 ui+    (_, _, draw, _) <- runFrame ctx inp0 ui+    spans <- collectTextSpans ctx+    let keyYs = [listToMaybe (spanYOf k spans) | k <- keys]+    quads <- decodeQuads draw+    let fillTops =+          [ qy1+          | (qx1, qy1, qx2, _, u, v) <- quads+          , abs (u - whitePixelU) < 1.0e-6+          , abs (v - whitePixelV) < 1.0e-6+          , qx2 - qx1 > 60.0+          ]+    pure (keyYs, fillTops)+  forM_ (zip yss (drop 1 yss)) $ \((keyA, fillA), (keyB, fillB)) -> do+    let sKeyA = sort [y | Just y <- keyA]+        sKeyB = sort [y | Just y <- keyB]+        sFillA = sort (filter (> 1.0) fillA)+        sFillB = sort (filter (> 1.0) fillB)+        textDs = [x2 - x1 | (x1, x2) <- zip sKeyA sKeyB]+        fillDs = [x2 - x1 | (x1, x2) <- zip sFillA sFillB]+        n = min (length textDs) (length fillDs)+        t0 = case textDs of+          d : _ -> d+          [] -> 0+        f0 = case fillDs of+          d : _ -> d+          [] -> 0+        textUniform = null (take n [i | i <- textDs, abs (i - t0) > 1.0e-3])+        fillUniform = null (take n [i | i <- fillDs, abs (i - f0) > 1.0e-3])+        sync = null textDs || null fillDs || abs (t0 - f0) <= 1.0e-3+    assert failed (textUniform && fillUniform && sync)++-- | Decode the final (post-snap) quad list from a DrawData vertex buffer.+-- The harness emits each Quad as 4 consecutive vertices of 8 floats:+-- x, y, r, g, b, a, u, v at a 32 byte stride (vertexSize).+decodeQuads :: DrawData -> IO [(Float, Float, Float, Float, Float, Float)]+decodeQuads dd =+  withForeignPtr (drawVertices dd) $ \vp -> do+    let n = drawVertexCount dd `div` 4+        fptr = castPtr vp :: Ptr Float+    forM [0 .. n - 1] $ \q -> do+      let vBase = q * 8 * 4+      xs <- forM [0 .. 3] $ \k -> do+        let o = vBase + k * 8+        x <- peekElemOff fptr o+        y <- peekElemOff fptr (o + 1)+        u <- peekElemOff fptr (o + 6)+        v <- peekElemOff fptr (o + 7)+        pure (x, y, u, v)+      let x1 = minimum [x | (x, _, _, _) <- xs]+          y1 = minimum [y | (_, y, _, _) <- xs]+          x2 = maximum [x | (x, _, _, _) <- xs]+          y2 = maximum [y | (_, y, _, _) <- xs]+          (_u, _v) =+            case xs of+              (_, _, u, v) : _ -> (u, v)+              [] -> (0, 0)+      pure (x1, y1, x2, y2, _u, _v)++whitePixelU :: Float+whitePixelU = 1.5 / 1024.0++whitePixelV :: Float+whitePixelV = 1.5 / 1024.0++-- A padded 2D scroller whose fill-width child fits the viewport must not+-- report horizontal overflow: content size is measured from the content+-- origin (after the leading padding), not from the padding-box origin,+-- which double-counts the padding and makes a fitting child look padX+-- wider than the viewport every frame. Same for the main axis of a padded+-- 1D vertical scroller. Fitting content must not wheel-scroll either: the+-- trailing padding extends the scroll range only once an axis genuinely+-- overflows.+run2DPadFillOverflowTest :: Context -> IORef Int -> IO ()+run2DPadFillOverflowTest ctx failed = do+  let inp0 = withInput 320 240+      ui =+        scrollArea2D (padAll 6 . fixedH 168 . fillW) $+          columnWith (tight . fillW) $+            mapM_ (void . label) (map T.pack ["alpha", "beta", "gamma"])+  (wid, ()) <- warmup2 ctx inp0 ui+  mState <- scrollNodeState ctx wid True+  case mState of+    Nothing -> assert failed False+    Just (contentW, innerW) -> assert failed (contentW <= innerW + overflowEps)+  -- No phantom scroll range: wheeling must not move either axis.+  let wheel = inp0 {inputScroll = V2 5 5}+  _ <- runFrame ctx wheel ui+  V2 offX offY <- getScrollOffset2D ctx wid+  assert failed (offX == 0 && offY == 0)+  let ui1 = scrollArea (padAll 6 . fixedH 80 . fillW) (labelWith tight (T.pack "fits"))+  (wid1, ()) <- warmup2 ctx inp0 ui1+  mState1 <- scrollNodeState ctx wid1 False+  case mState1 of+    Nothing -> assert failed False+    Just (contentH, innerH) -> assert failed (contentH <= innerH + overflowEps)++-- Padding (padAll 6) used by the 2D pad tests, and the resulting reduction+-- of the scroller rect to the padded inner size.+padTestPx, padTestBoth :: Float+padTestPx = 6+padTestBoth = padTestPx * 2++-- Same overflow epsilon as scrollAxisOverflows / scrollAxisRange.+overflowEps :: Float+overflowEps = 0.5++scrollNodeState :: Context -> WidgetId -> Bool -> IO (Maybe (Float, Float))+scrollNodeState ctx wid is2D = do+  let na = ctxNodeArena ctx+  found <- findNodeM na $ \i -> do+    nt <- getNodeType na i+    if nt == NodeScrollContainer then (== wid) <$> getWidgetId na i else pure False+  forM found $ \i -> do+    contentMain <-+      if is2D+        then getScrollContentW na i+        else getNodeValue na i+    (_, _, rw, rh) <- getRect na i+    pure (contentMain, if is2D then rw - padTestBoth else rh - padTestBoth)++-- The other side of the pad fix: a padded 2D scroller whose child really is+-- wider and taller than the viewport must still report overflow on both+-- axes, wheel-scroll vertically, and let scrolling reach the trailing+-- padding at the end (the range extends past the last child by padB).+run2DPadOverflowScrollsTest :: Context -> IORef Int -> IO ()+run2DPadOverflowScrollsTest ctx failed = do+  let inp0 = (withInput 320 240) {inputMousePos = V2 100 100}+      ui =+        scrollArea2D (padAll 6 . fixedH 168 . fillW) $+          columnWith (tight . fillW) $ do+            labelWith (tight . fixedW 500) (T.pack "wide child")+            mapM_ (void . label) (map T.pack (replicate 30 "scroll line"))+  (wid, ()) <- warmup2 ctx inp0 ui+  mState <- scrollNodeState ctx wid True+  case mState of+    Nothing -> assert failed False+    Just (contentW, innerW) -> do+      -- The 500px child genuinely overflows the ~308px inner width.+      assertGt failed contentW (innerW + 40)+  mStateH <- scrollNodeState ctx wid False+  case mStateH of+    Nothing -> assert failed False+    Just (contentH, innerH) -> do+      assertGt failed contentH (innerH + 100)+      -- Scroll far past the end: the clamp must land on the trailing-pad+      -- extended range (content + padB - view), not the flush content - view,+      -- so the bottom padding is reachable. The horizontal bar is active+      -- (the 500px child overflows), so it takes its lane out of the vertical+      -- viewport: view = innerH - laneH.+      let laneH =+            scrollBarGutter ScrollBarList padTestPx+          wheelDown = inp0 {inputScroll = V2 0 50}+      replicateM_ 40 (runFrame ctx wheelDown ui)+      V2 _ offEnd <- getScrollOffset2D ctx wid+      assert failed (abs (offEnd - (contentH + padTestPx - (innerH - laneH))) < 1.5)++-- The wheel covers the configured step per notch: the context's by default,+-- and the scroller's own once it is given one.+runScrollStepTest :: Context -> IORef Int -> IO ()+runScrollStepTest ctx failed = do+  let inp0 = withInput 200 120+      ui = scrollArea (fillW . fixedH 80) (column (replicateM_ 16 (label "scroll line")))+  setScrollTuning ctx defaultScrollTuning {scrollWheelStep = 40}+  (sid, ()) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx sid+  case mRect of+    Nothing -> assert failed False+    Just r -> do+      let wheel = inp0 {inputMousePos = spanCenter r, inputScroll = V2 0 1}+      _ <- runFrame ctx wheel ui+      assertEq failed 40 =<< getScrollOffset ctx sid+      -- The scroller's own step overrides the context's from the next notch on.+      setScrollStep ctx sid 12+      _ <- runFrame ctx wheel ui+      assertEq failed 52 =<< getScrollOffset ctx sid+      -- Back to the context's step.+      setScrollStep ctx sid 0+      _ <- runFrame ctx wheel ui+      assertEq failed 92 =<< getScrollOffset ctx sid++-- With a glide time set, a notch eases onto its target over several frames,+-- and the frame loop counts the scroller as animating until it lands.+runScrollSmoothTest :: Context -> IORef Int -> IO ()+runScrollSmoothTest ctx failed = do+  let inp0 = withInput 200 120+      ui = scrollArea (fillW . fixedH 80) (column (replicateM_ 16 (label "scroll line")))+  setScrollTuning ctx defaultScrollTuning {scrollWheelStep = 60, scrollSmoothTime = 0.2}+  (sid, ()) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx sid+  case mRect of+    Nothing -> assert failed False+    Just r -> do+      let tick = inp0 {inputMousePos = spanCenter r, inputDeltaTime = 1 / 60}+          wheel = tick {inputScroll = V2 0 1}+      _ <- runFrame ctx wheel ui+      partial <- getScrollOffset ctx sid+      assertGt failed partial 0+      assert failed (partial < 60)+      assert failed =<< scrollGliding ctx sid+      assert failed =<< anyAnimating ctx+      -- It settles exactly on the target, and stops asking for frames there.+      replicateM_ 30 (runFrame ctx tick ui)+      assertEq failed 60 =<< getScrollOffset ctx sid+      gliding <- scrollGliding ctx sid+      assert failed (not gliding)+      -- A notch mid-glide adds to the throw instead of restarting it.+      _ <- runFrame ctx wheel ui+      _ <- runFrame ctx wheel ui+      replicateM_ 30 (runFrame ctx tick ui)+      assertEq failed 180 =<< getScrollOffset ctx sid+      -- Setting an offset outright wins over whatever was in flight.+      _ <- runFrame ctx wheel ui+      setScrollOffset ctx sid 20+      replicateM_ 5 (runFrame ctx tick ui)+      assertEq failed 20 =<< getScrollOffset ctx sid++-- The metrics a scroller publishes each frame, and the commands that read+-- them: to the end, back to the start, and by whole pages.+runScrollMetricsTest :: Context -> IORef Int -> IO ()+runScrollMetricsTest ctx failed = do+  let inp0 = withInput 200 160+      ui = scrollArea (fillW . fixedH 80) (column (replicateM_ 16 (label "scroll line")))+  (sid, ()) <- warmup2 ctx inp0 ui+  mMetrics <- getScrollMetrics ctx sid+  case mMetrics of+    Nothing -> assert failed False+    Just m -> do+      assertEq failed (scrollAxes m) ScrollAxisY+      assertEq failed (scrollOffset m) (V2 0 0)+      assertGt failed (v2Y (scrollRange m)) 0+      assertEq failed (v2X (scrollRange m)) 0+      -- The viewport is the scroller's box inside its padding and bar lane.+      mRect <- getPrevRect ctx sid+      case mRect of+        Nothing -> assert failed False+        Just r -> do+          assert failed (rectW (scrollViewport m) <= rectW r)+          assert failed (rectH (scrollViewport m) <= rectH r)+      scrollToEnd ctx sid ScrollInstant+      _ <- runFrame ctx inp0 ui+      assertEq failed (v2Y (scrollRange m)) =<< getScrollOffset ctx sid+      scrollToStart ctx sid ScrollInstant+      _ <- runFrame ctx inp0 ui+      assertEq failed 0 =<< getScrollOffset ctx sid+      scrollPages ctx sid (V2 0 1) ScrollInstant+      _ <- runFrame ctx inp0 ui+      paged <- getScrollOffset ctx sid+      assertEq failed (min (v2Y (scrollRange m)) (rectH (scrollViewport m))) paged++-- Scrolling a widget into view, by widget and by content rectangle.+runScrollIntoViewTest :: Context -> IORef Int -> IO ()+runScrollIntoViewTest ctx failed = do+  let inp0 = withInput 200 160+      ui =+        scrollArea (fillW . fixedH 80) $+          column (forM [1 .. 16 :: Int] (\i -> label' (T.pack ("line " <> show i))))+  (sid, rows) <- warmup2 ctx inp0 ui+  let target = respId (rows !! 11)+  scrollIntoView ctx sid target ScrollStart ScrollInstant+  _ <- runFrame ctx inp0 ui+  mAfter <- getScrollMetrics ctx sid+  mRow <- getPrevRect ctx target+  case (mAfter, mRow) of+    (Just m, Just r) -> do+      -- The row sits against the top of the viewport, whole.+      assert failed (abs (rectY r - rectY (scrollViewport m)) < 1.5)+      -- Already in view: the nearest alignment leaves the offset alone.+      before <- getScrollOffset ctx sid+      scrollIntoView ctx sid target ScrollNearest ScrollInstant+      _ <- runFrame ctx inp0 ui+      assertEq failed before =<< getScrollOffset ctx sid+      -- A row above the viewport comes back to the top edge.+      let above = respId (rows !! 1)+      scrollIntoView ctx sid above ScrollNearest ScrollInstant+      _ <- runFrame ctx inp0 ui+      mAbove <- getPrevRect ctx above+      case mAbove of+        Nothing -> assert failed False+        Just ra -> assert failed (abs (rectY ra - rectY (scrollViewport m)) < 1.5)+      -- A content rectangle no widget was built for (a virtualized row)+      -- lands the same way.+      let rowH = rectH r+      scrollRectIntoView ctx sid (Rect 0 (rowH * 8) 10 rowH) ScrollStart ScrollInstant+      _ <- runFrame ctx inp0 ui+      off <- getScrollOffset ctx sid+      assert failed (abs (off - rowH * 8) < 1.5)+    _ -> assert failed False++-- Content that shrinks under a glide pulls the glide back with it: the+-- scroller must not coast to an offset the shorter content cannot reach and+-- sit there showing nothing.+runScrollGlideClampTest :: Context -> IORef Int -> IO ()+runScrollGlideClampTest ctx failed = do+  rows <- newIORef (40 :: Int)+  let inp0 = withInput 200 120+      ui = do+        n <- uiIO (readIORef rows)+        scrollArea (fillW . fixedH 80) (column (replicateM_ n (label "scroll line")))+  setScrollTuning ctx defaultScrollTuning {scrollWheelStep = 60, scrollSmoothTime = 0.2}+  (sid, ()) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx sid+  case mRect of+    Nothing -> assert failed False+    Just r -> do+      let tick = inp0 {inputMousePos = spanCenter r, inputDeltaTime = 1 / 60}+          wheel = tick {inputScroll = V2 0 8}+      _ <- runFrame ctx wheel ui+      assert failed =<< scrollGliding ctx sid+      writeIORef rows 12+      replicateM_ 40 (runFrame ctx tick ui)+      mMetrics <- getScrollMetrics ctx sid+      off <- getScrollOffset ctx sid+      case mMetrics of+        Nothing -> assert failed False+        Just m -> do+          assertGt failed (v2Y (scrollRange m)) 0+          assert failed (off <= v2Y (scrollRange m) + 0.5)
+ test/integration/Cases/Select.hs view
@@ -0,0 +1,234 @@+module Cases.Select+  ( runSelectDragToSelectTest+  , runSelectKeyboardTest+  , runSelectOverlayDamageTest+  , runSelectChangeOnceTest+  , runSelectCloseKeepsFocusTest+  , runSliderCursorTest+  , runTreeKeyboardTest+  , runTreeSelectTest+  ) where++import Data.IORef (IORef, newIORef)+import Data.Text qualified as T+import NanoUI+import Data.Primitive.SmallArray qualified as SA+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, withInput)+import NanoUI.Testing.Harness+  ( assertSpansHas+  , centerOf+  , clickPair+  , hasText+  , held+  , keyInp+  , runClick+  , tabInp+  , warmup2+  )++runSliderCursorTest :: Context -> IORef Int -> IO ()+runSliderCursorTest ctx failed = do+  let inp0 = withInput 300 80+      ui = column (slider' 0 100 50)+  (resp, _) <- warmup2 ctx inp0 ui+  let Rect rx ry rw rh = respRect resp+      track = sliderTrackBounds rx ry rw rh+      trackMid = V2 (rectX track + rectW track / 2) (rectY track + rectH track / 2)+      offPos = V2 (rx + rw + 20) (ry + rh + 20)+      hoverTrack = inp0 {inputMousePos = trackMid}+  _ <- runFrame ctx hoverTrack ui+  hoverKind <- uiCursorKind ctx hoverTrack+  assertEq failed hoverKind UiCursorGrab+  let pressTrack = hoverTrack {inputMouseDown = True, inputMousePressed = True}+  _ <- runFrame ctx pressTrack ui+  grabbing <- cursorKindIs ctx pressTrack UiCursorGrabbing+  assert failed grabbing+  let dragOff = pressTrack {inputMousePos = offPos}+  _ <- runFrame ctx dragOff ui+  grabbingOff <- cursorKindIs ctx dragOff UiCursorGrabbing+  assert failed grabbingOff+  let hoverOff = inp0 {inputMousePos = offPos}+  _ <- runFrame ctx hoverOff ui+  isDefault <- cursorKindIs ctx hoverOff UiCursorDefault+  assert failed isDefault++runSelectOverlayDamageTest :: Context -> IORef Int -> IO ()+runSelectOverlayDamageTest ctx failed = do+  let ui = column (select' ["Low", "Medium", "High"] 0)+      inp0 = (withInput 320 160) {inputMousePos = V2 20 20}+  (resp, _) <- warmup2 ctx inp0 ui+  let pos = centerOf resp+      open = snd (clickPair inp0 pos)+  _ <- runClick ctx inp0 ui pos+  let idle = open {inputMouseReleased = False, inputDeltaTime = 1}+  _ <- runFrame ctx idle ui+  overlays <- collectOverlayTextSpans ctx idle+  case [rectY r | (r, txt, _, _, _) <- overlays, "High" `T.isInfixOf` txt] of+    (highY : _) -> do+      let overMenu = idle {inputMousePos = V2 (v2X pos) (highY + 0.5)}+      need <- needsRedraw ctx idle overMenu+      assert failed need+      _ <- runFrame ctx overMenu ui+      dmg <- takeDamage ctx+      assertEq failed dmg DamageFull+    [] -> assert failed False++runTreeSelectTest :: Context -> IORef Int -> IO ()+runTreeSelectTest ctx failed = do+  let inp0 = withInput 40 12+      items = [TreeItem "alpha" [], TreeItem "beta" []]+      ui = column (tree' "t" items 0)+  (resp, sel0) <- warmup2 ctx inp0 ui+  assertEq failed sel0 0+  let Rect rx ry _rh rh = respRect resp+      (press, release) = clickPair inp0 (V2 (rx + 1) (ry + rh * 0.75))+  _ <- runFrame ctx press ui+  ((_, sel), _, _, _) <- runFrame ctx release ui+  assertEq failed sel 1++-- A tree renders expanded, moves its selection with the arrow keys, and+-- Enter collapses the selected parent.+runTreeKeyboardTest :: Context -> IORef Int -> IO ()+runTreeKeyboardTest ctx failed = do+  selectedRef <- newIORef 0+  let items = SA.smallArrayFromList [TreeItem "root" [TreeItem "child" []], TreeItem "leaf" []]+      ui = column (held selectedRef (tree' "k" items))+      inp0 = withInput 40 12+  _ <- warmup2 ctx inp0 ui+  spans0 <- collectTextSpans ctx+  assert failed (hasText "root" spans0 && hasText "child" spans0 && hasText "leaf" spans0)+  _ <- runFrame ctx (tabInp inp0) ui+  ((_, sel1), _, _, _) <- runFrame ctx (keyInp KeyDown inp0) ui+  assertEq failed sel1 1+  ((_, sel0), _, _, _) <- runFrame ctx (keyInp KeyUp inp0) ui+  assertEq failed sel0 0+  _ <- runFrame ctx (keyInp KeyDown inp0) ui+  ((_, parentSel), _, _, _) <- runFrame ctx (keyInp KeyLeft inp0) ui+  assertEq failed parentSel 0+  _ <- runFrame ctx (keyInp KeyEnter inp0) ui+  _ <- runFrame ctx inp0 ui+  spans <- collectTextSpans ctx+  assert failed (not (hasText "child" spans))+  ((_, afterCollapsed), _, _, _) <- runFrame ctx (keyInp KeyDown inp0) ui+  assertEq failed afterCollapsed 2++-- Open dropdown rows show the pointer cursor on hover and press, and+-- respChanged fires on the frame the selection changes and not on later+-- frames (regression: it compared the index against the initial one, so it+-- stayed set, and Emit.select emitted, every frame after a pick).+runSelectChangeOnceTest :: Context -> IORef Int -> IO ()+runSelectChangeOnceTest ctx failed = do+  indexRef <- newIORef 1+  let inp0 = withInput 320 200+      ui = held indexRef (select' ["Low", "Medium", "High"])+  (resp, _) <- warmup2 ctx inp0 ui+  let (openPress, openRelease) = clickPair inp0 (centerOf resp)+  _ <- runFrame ctx openPress ui+  _ <- runFrame ctx openRelease ui+  overlays <- collectOverlayTextSpans ctx openRelease+  case [rectY r | (r, txt, _, _, _) <- overlays, "Low" `T.isInfixOf` txt] of+    (lowY : _) -> do+      let lowPos = V2 (v2X (centerOf resp)) (lowY + 0.5)+          hover = inp0 {inputMousePos = lowPos}+          (pickPress, pickRelease) = clickPair inp0 lowPos+          frame inp = (\((r, i), _, _, _) -> (respChanged r, i)) <$> runFrame ctx inp ui+      _ <- runFrame ctx hover ui+      hoverKind <- uiCursorKind ctx hover+      assertEq failed hoverKind UiCursorPointer+      pressed <- frame pickPress+      pressKind <- uiCursorKind ctx pickPress+      assertEq failed pressKind UiCursorPointer+      rest <- mapM frame [pickRelease, inp0, inp0, inp0]+      let results = pressed : rest+      assertEq failed (map snd rest) [0, 0, 0, 0]+      assertEq failed (length (filter fst results)) 1+      assertEq failed (map fst (drop 1 rest)) [False, False, False]+    [] -> assert failed False++runSelectDragToSelectTest :: Context -> IORef Int -> IO ()+runSelectDragToSelectTest ctx failed = do+  let inp0 = withInput 320 200+      ui = select' ["Low", "Medium", "High"] 1+  (resp, idx0) <- warmup2 ctx inp0 ui+  assertEq failed idx0 1+  let Rect sx sy sw _ = respRect resp+      btnMid = V2 (sx + sw / 2) (sy + 10)+      press = inp0 {inputMousePos = btnMid, inputMouseDown = True, inputMousePressed = True}+  -- 1. On mousedown, the menu should show up immediately+  _ <- runFrame ctx press ui+  overlaysPress <- collectOverlayTextSpans ctx press+  assert failed (any (\(_, txt, _, _, _) -> "Low" `T.isInfixOf` txt) overlaysPress)+  assert failed (any (\(_, txt, _, _, _) -> "High" `T.isInfixOf` txt) overlaysPress)+  case [rectY r | (r, txt, _, _, _) <- overlaysPress, "Low" `T.isInfixOf` txt] of+    (lowY : _) -> do+      -- 2. Move mouse over an item while still pressed+      let drag = inp0 {inputMousePos = V2 (sx + sw / 2) (lowY + 0.5), inputMouseDown = True}+      _ <- runFrame ctx drag ui+      overlaysDrag <- collectOverlayTextSpans ctx drag+      assert failed (any (\(_, txt, _, _, _) -> "Low" `T.isInfixOf` txt) overlaysDrag)+      kind <- uiCursorKind ctx drag+      assertEq failed kind UiCursorPointer+      -- 3. Mouseup over the item selects it and closes the menu+      let release = drag {inputMouseDown = False, inputMouseReleased = True}+      ((_, idx1), _, _, _) <- runFrame ctx release ui+      assertEq failed idx1 0+      overlaysClosed <- collectOverlayTextSpans ctx release+      assert failed (not (any (\(_, txt, _, _, _) -> "Low" `T.isInfixOf` txt) overlaysClosed))+      spans <- collectTextSpans ctx+      assertSpansHas failed "Low" spans+    _ -> assert failed False++runSelectKeyboardTest :: Context -> IORef Int -> IO ()+runSelectKeyboardTest ctx failed = do+  indexRef <- newIORef 1+  let inp0 = withInput 320 200+      ui = column (held indexRef (select' (SA.smallArrayFromList ["Low", "Medium", "High"])))+  (resp, idx0) <- warmup2 ctx inp0 ui+  assertEq failed idx0 1+  let (openPress, openRelease) = clickPair inp0 (centerOf resp)+  _ <- runFrame ctx openPress ui+  _ <- runFrame ctx openRelease ui+  _ <- runFrame ctx (keyInp KeyDown openRelease) ui+  ((_, idx1), _, _, _) <- runFrame ctx openRelease ui+  assertEq failed idx1 2+  _ <- runFrame ctx (keyInp KeyUp openRelease) ui+  ((_, idx2), _, _, _) <- runFrame ctx openRelease ui+  assertEq failed idx2 1+  _ <- runFrame ctx (openRelease {inputKeys = inputKeysFromList [KeyEscape], inputMouseReleased = False}) ui+  let idleAfterOpen = openRelease {inputMouseReleased = False}+  _ <- runFrame ctx idleAfterOpen ui+  overlays <- collectOverlayTextSpans ctx idleAfterOpen+  assert failed (not (any (\(_, txt, _, _, _) -> txt `elem` ["Low", "Medium", "High"]) overlays))+  _ <- runFrame ctx (tabInp inp0) ui+  focus <- getFocusId ctx+  assert failed (focus /= WidgetId 0)+  _ <- runFrame ctx (keyInp KeyRight inp0) ui+  ((_, idx3), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed idx3 2+  closedOverlays <- collectOverlayTextSpans ctx inp0+  assert failed (not (any (\(_, txt, _, _, _) -> txt `elem` ["Low", "Medium", "High"]) closedOverlays))+  _ <- runFrame ctx (keyInp KeyLeft inp0) ui+  ((_, idx4), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed idx4 1++-- Clicking an open select's own field closes the dropdown and keeps the+-- select focused (regression: the closing press cleared focus).+runSelectCloseKeepsFocusTest :: Context -> IORef Int -> IO ()+runSelectCloseKeepsFocusTest ctx failed = do+  indexRef <- newIORef 1+  let inp0 = withInput 320 200+      ui = column (held indexRef (select' (SA.smallArrayFromList ["Low", "Medium", "High"])))+      listed spans = any (\(_, txt, _, _, _) -> txt == "Low") spans+  (resp, _) <- warmup2 ctx inp0 ui+  let mid = centerOf resp+      openRelease = snd (clickPair inp0 mid)+      closeRelease = snd (clickPair openRelease mid)+  _ <- runClick ctx inp0 ui mid+  assert failed . listed =<< collectOverlayTextSpans ctx openRelease+  _ <- runClick ctx openRelease ui mid+  let idle = closeRelease {inputMouseReleased = False}+  _ <- runFrame ctx idle ui+  assert failed . not . listed =<< collectOverlayTextSpans ctx idle+  focus <- getFocusId ctx+  assertEq failed focus (respId resp)
+ test/integration/Cases/Shaping.hs view
@@ -0,0 +1,53 @@+module Cases.Shaping+  ( runBidiRunsTest+  , runShapedCaretTest+  ) where++import Data.IORef (IORef)+import Data.Primitive.PrimArray (primArrayFromList)+import NanoUI+import NanoUI.Bidi (BidiRun (..), bidiRuns, needsBidi)+import NanoUI.Testing (Context, caretX, selectionSpans, textIndexAtX)+import NanoUI.Testing.Assert (assert, assertEq)++-- | Direction runs come out in visual order, with numbers and spaces+-- resolved against their neighbours.+runBidiRunsTest :: Context -> IORef Int -> IO ()+runBidiRunsTest _ failed = do+  assert failed (not (needsBidi "plain text 123"))+  assertEq failed [] (bidiRuns "")+  assertEq failed [BidiRun 0 5 False] (bidiRuns "hello")+  -- A left-to-right line: the space before Hebrew stays with the Latin.+  assertEq failed [BidiRun 0 4 False, BidiRun 4 7 True] (bidiRuns "abc \x05D0\x05D1\x05D2")+  -- A right-to-left line puts the trailing Latin word on the left.+  assertEq failed [BidiRun 4 7 False, BidiRun 0 4 True] (bidiRuns "\x05D0\x05D1\x05D2 abc")+  -- Numbers in Hebrew read left to right, left of the word before them.+  assertEq failed [BidiRun 5 8 False, BidiRun 0 5 True] (bidiRuns "\x05E9\x05DC\x05D5\x05DD 123")+  -- Latin in the middle of an Arabic line.+  assertEq+    failed+    [BidiRun 7 10 True, BidiRun 4 7 False, BidiRun 0 4 True]+    (bidiRuns "\x0645\x0631\x062D abc\x0628\x0627\x0644")++-- | Carets, hit testing and selection spans follow a host's shaped layout,+-- including right-to-left carets that decrease.+runShapedCaretTest :: Context -> IORef Int -> IO ()+runShapedCaretTest _ failed = do+  let rtl = "\x05D0\x05D1\x05D2"+      mixed = "ab\x05D0\x05D1"+      shape t+        | t == rtl = Just (ShapedText 30 30 (primArrayFromList [30, 20, 10, 0]))+        | t == mixed = Just (ShapedText 40 40 (primArrayFromList [0, 10, 40, 30, 20]))+        | otherwise = Nothing+      fm = (monospaceMetrics 16) {fmShape = shape}+  assertEq failed 30 (caretX fm rtl 0)+  assertEq failed 0 (caretX fm rtl 3)+  assertEq failed 0 (caretX fm rtl 99)+  assertEq failed 2 (textIndexAtX fm rtl 12)+  assertEq failed 0 (textIndexAtX fm rtl 100)+  assertEq failed [(10, 30)] (selectionSpans fm rtl 0 2)+  assertEq failed [] (selectionSpans fm rtl 2 2)+  -- Selecting the Hebrew of a mixed line covers its run, not the Latin.+  assertEq failed [(20, 40)] (selectionSpans fm mixed 2 4)+  assertEq failed [(0, 10)] (selectionSpans fm mixed 0 1)+  assertEq failed 3 (textIndexAtX fm mixed 29)
+ test/integration/Cases/State.hs view
@@ -0,0 +1,142 @@+module Cases.State+  ( runControlledInputsTest+  , runControlledStateTest+  , runHookStateTest+  , runCollectionApiTest+  ) where++import Control.Monad (forM_, when)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.ByteString qualified as BS+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Data.Sequence qualified as Seq+import Data.Primitive.SmallArray qualified as SA+import NanoUI+import NanoUI.Context (Context (..), getStore, intKey, registerImages, lookupImageUv)+import NanoUI.Store (WidgetStore (..))+import NanoUI.Testing (clearDirty, collectTextSpans, isDirty, runFrame)+import NanoUI.Testing.Assert (assert, assertEq)+import NanoUI.Testing.Harness (keyInp, tabInp, warmup2, withInputOff)++runCollectionApiTest :: Context -> IORef Int -> IO ()+runCollectionApiTest ctx failed = do+  seen <- newIORef []+  _ <- runFrame ctx (withInputOff 300 100) $+    hstack (SA.smallArrayFromList [uiIO (modifyIORef' seen (key :)) | key <- [7, 2, 9 :: Int]])+  assertEq failed [9, 2, 7] =<< readIORef seen+  ((emptySelect, emptyRadio, combo), _, _, _) <- runFrame ctx (withInputOff 300 200) $+    withKey ("collection-options" :: Text) $ column $ do+      selectIndex <- select (SA.emptySmallArray :: SA.SmallArray Text) 5+      radioIndex <- radio (Seq.empty :: Seq.Seq Text) (-1)+      comboValue <- comboBox "Choose" (Seq.fromList ["Alpha", "Beta"]) "Beta"+      pure (selectIndex, radioIndex, comboValue)+  assertEq failed 0 emptySelect+  assertEq failed 0 emptyRadio+  assertEq failed "Beta" combo+  -- A failed image must not prevent later registrations in traversal order.+  ok <- registerImages ctx (Seq.fromList [(ImageId 0, 1, 1, BS.replicate 4 255), (ImageId 42, 1, 1, BS.replicate 4 255)])+  assertEq failed False ok+  registered <- lookupImageUv ctx (ImageId 42)+  assertEq failed True (case registered of Just _ -> True; Nothing -> False)++runControlledStateTest :: Context -> IORef Int -> IO ()+runControlledStateTest ctx failed = do+  callbacks <- newIORef []+  let+    inp = withInputOff 300 200+    ui checked text value = column $ do+      expectedId <- currentId+      (check, checked') <- checkbox' "Controlled" checked+      when (respChanged check) (uiIO (modifyIORef' callbacks (<> [checked'])))+      (field, _) <- textInput' text+      (range, _) <- slider' 0 100 value+      pure (expectedId, check, field, range)+  _ <- runFrame ctx inp (ui True "initial" 25)+  ((expectedId, check, field, range), _, _, _) <-+    runFrame ctx inp (ui False "replacement" 75)+  assertEq failed expectedId (respId check)+  store <- getStore ctx+  assertEq failed (Just 0) (IM.lookup (intKey (respId check)) (storeInt store))+  assertEq+    failed+    (Just "replacement")+    (IM.lookup (intKey (respId field)) (storeText store))+  assertEq failed (Just 75) (IM.lookup (intKey (respId range)) (storeFloat store))+  assertEq failed [] =<< readIORef callbacks++  -- Keyboard activation notifies the owner, which may decline the change.+  writeIORef (ctxFocusId ctx) (respId check)+  _ <-+    runFrame+      ctx+      (keyInp KeyEnter inp)+      (ui False "replacement" 75)+  assertEq failed [True] =<< readIORef callbacks+  _ <- runFrame ctx inp (ui False "replacement" 75)+  settled <- getStore ctx+  assertEq failed (Just 0) (IM.lookup (intKey (respId check)) (storeInt settled))+  assertEq failed [True] =<< readIORef callbacks++-- | Inputs show the value the caller passes: a value the caller changes+-- between frames is shown, a user edit the caller passes back is kept, and+-- one it ignores is undone on the next frame. 'runControlledStateTest' covers+-- a declined checkbox toggle.+runControlledInputsTest :: Context -> IORef Int -> IO ()+runControlledInputsTest ctx failed = do+  let+    inp = withInputOff 300 200+    ui (checked, text) = column $ do+      checked' <- checkbox "Opt" checked+      text' <- textInput text+      pure (checked', text')+  _ <- warmup2 ctx inp (ui (False, "one"))+  forM_+    [ -- The caller's new values, with no input.+      (inp, (True, "two"), (True, "two"))+    , -- Tab focuses the checkbox; Space toggles it and the caller keeps it.+      (tabInp inp, (True, "two"), (True, "two"))+    , (inp {inputChars = " "}, (True, "two"), (False, "two"))+    , (tabInp inp, (False, "two"), (False, "two"))+    , -- Tab moved focus to the field. A kept edit stays.+      (inp {inputChars = "x"}, (False, "two"), (False, "twox"))+    , (inp, (False, "twox"), (False, "twox"))+    , -- An ignored edit is undone on the following frame.+      (inp {inputChars = "y"}, (False, "twox"), (False, "twoxy"))+    , (inp, (False, "twox"), (False, "twox"))+    ]+    $ \(input, value, expected) -> do+      (result, _, _, _) <- runFrame ctx input (ui value)+      assertEq failed expected result+      spans <- collectTextSpans ctx+      assert failed (any (\(_, txt, _, _, _) -> txt == snd expected) spans)++runHookStateTest :: Context -> IORef Int -> IO ()+runHookStateTest ctx failed = do+  let+    inp = withInputOff 300 100+    check :: (Eq a, Show a) => Text -> NanoUI (a, a -> NanoUI ()) -> a -> a -> IO ()+    check key hook initial changed = do+      let+        evaluate = runNanoUI ctx inp (withKey key hook)+      (value, setValue) <- evaluate+      assertEq failed initial value+      clearDirty ctx+      runNanoUI ctx inp (setValue initial)+      assertEq failed False =<< isDirty ctx++      runNanoUI ctx inp (setValue changed)+      assertEq failed True =<< isDirty ctx+      assertEq failed changed . fst =<< evaluate++      -- Reuse the original setter: comparing against its captured initial+      -- value would incorrectly discard this update back to the initial.+      runNanoUI ctx inp (setValue initial)+      assertEq failed initial . fst =<< evaluate+  check "int" (useInt 0) 0 12+  check "float" (useFloat 0) 0 1.5+  check "text" (useText "initial") "initial" "changed"+  check "flag" (useFlag False) False True+  check "enum" (useEnum LT) LT GT+  check "dynamic" (useState (0 :: Int, False)) (0, False) (12, True)+  check "table-sort" (useTableSort (SortCol 0 SortAsc)) (SortCol 0 SortAsc) (SortCol 2 SortDesc)
+ test/integration/Cases/Styling.hs view
@@ -0,0 +1,138 @@+module Cases.Styling+  ( runDisabledPointerTest+  , runDisabledFocusOrderTest+  , runDisabledLookTest+  , runStyledPaintTest+  , runStyledNestingTest+  , runStyledDamageTest+  ) where++import Control.Monad (forM_)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import NanoUI+import NanoUI.Context (Context (..))+import NanoUI.Testing+import Data.Text (Text)+import NanoUI.Testing.Assert (assert, assertEq)+import NanoUI.Testing.Harness (centerOf, clickPair, drawQuads, held, tabInp, warmup2, warmupDraw, withInputOff)++-- | A pointer press, drag and typing on a disabled widget change nothing and+-- give it no focus.+runDisabledPointerTest :: Context -> IORef Int -> IO ()+runDisabledPointerTest _ failed = do+  let inp = withInputOff 400 200+      check :: (Eq a, Show a) => String -> a -> (a -> NanoUI (Response, a)) -> IO ()+      check name initial widget = do+        ctx <- newContext+        ref <- newIORef initial+        let ui = column (disabledWhen True (held ref widget))+        (resp, _) <- warmup2 ctx inp ui+        let V2 cx cy = centerOf resp+            (press, release) = clickPair inp (V2 cx cy)+            dragged = press {inputMousePressed = False, inputMousePos = V2 (cx + 60) cy}+        mapM_ (\i -> runFrame ctx i ui) [press, dragged, release {inputMousePos = V2 (cx + 60) cy}]+        _ <- runFrame ctx inp {inputMousePos = V2 cx cy, inputChars = "x"} ui+        (after, _, _, _) <- runFrame ctx inp ui+        value <- readIORef ref+        focus <- readIORef (ctxFocusId ctx)+        assertEqNamed name value initial+        assert failed (not (respClicked (fst after)) && not (respHovered (fst after)))+        if focus /= respId resp then pure () else putStrLn ("  disabled " <> name <> ": took focus")+        assert failed (focus /= respId resp)+      assertEqNamed :: (Eq b, Show b) => String -> b -> b -> IO ()+      assertEqNamed name a b =+        if a == b then pure () else do+          putStrLn ("  disabled " <> name <> ": " <> show a <> " /= " <> show b)+          assertEq failed a b+  check "button" False (\_ -> (\r -> (r, respClicked r)) <$> button' "Go")+  check "checkbox" False (checkbox' "Check")+  check "toggle" False toggleSwitch'+  check "slider" (50 :: Float) (slider' 0 100)+  check "knob" (50 :: Float) (knob' 0 100)+  check "radio" (0 :: Int) (radio' ["One", "Two"])+  check "select" (0 :: Int) (select' ["One", "Two"])+  check "text input" ("initial" :: Text) textInput'+  check "numeric input" (5 :: Double) numericInput'++-- | Tab skips a disabled widget.+runDisabledFocusOrderTest :: Context -> IORef Int -> IO ()+runDisabledFocusOrderTest ctx failed = do+  let inp = withInputOff 300 200+      ui = column $ do+        a <- button' "A"+        _ <- disabledWhen True (button' "B")+        c <- button' "C"+        pure (a, c)+  (a, c) <- warmup2 ctx inp ui+  writeIORef (ctxFocusId ctx) (respId a)+  _ <- runFrame ctx (tabInp inp) ui+  focus <- readIORef (ctxFocusId ctx)+  assertEq failed focus (respId c)++-- | A disabled button paints its fill faded toward the window colour.+runDisabledLookTest :: Context -> IORef Int -> IO ()+runDisabledLookTest ctx failed = do+  theme <- getTheme ctx+  let inp = withInputOff 300 200+      enabledBg = styleBg (themeButton theme)+      fadedBg = styleBg (themeButton (disabledTheme theme))+  (_, draw) <- warmupDraw ctx inp (column (disabledWhen True (button "Off")))+  quads <- drawQuads draw+  assert failed (any ((== fadedBg) . snd) quads)+  assert failed (not (any ((== enabledBg) . snd) quads))+  assert failed (fadedBg /= enabledBg)++-- | A styled scope paints only the widgets inside it with its theme.+runStyledPaintTest :: Context -> IORef Int -> IO ()+runStyledPaintTest ctx failed = do+  let inp = withInputOff 300 200+      red = colorRGBA 200 30 40 255+      ui = column $ do+        inside <- styled (buttonStyle (background red)) (button' "Red")+        outside <- button' "Plain"+        pure (inside, outside)+  ((inside, outside), draw) <- warmupDraw ctx inp ui+  quads <- drawQuads draw+  let fills r = [c | (q, c) <- quads, rectIntersect q (respRect r) /= Nothing]+  assert failed (red `elem` fills inside)+  assert failed (red `notElem` fills outside)++-- | Nested scopes modify the theme around them, and 'uiTheme' reads it.+runStyledNestingTest :: Context -> IORef Int -> IO ()+runStyledNestingTest ctx failed = do+  base <- getTheme ctx+  let inp = withInputOff 300 200+      teal = colorRGBA 20 160 150 255+  (outerAccent, innerAccent, innerRadius, afterAccent) <-+    warmup2 ctx inp $ column $ do+      (o, (i, r)) <- styled (accentColor teal) $ do+        o <- themeAccent <$> uiTheme+        ir <- styled (buttonStyle (cornerRadius 9)) $ do+          t <- uiTheme+          pure (themeAccent t, styleCornerRadius (themeButton t))+        pure (o, ir)+      a <- themeAccent <$> uiTheme+      pure (o, i, r, a)+  assertEq failed outerAccent teal+  assertEq failed innerAccent teal+  assertEq failed innerRadius 9+  assertEq failed afterAccent (themeAccent base)+  -- A primary button inside a disabled scope is still faded.+  offTheme <- warmup2 ctx inp (column (disabledWhen True (styled primary uiTheme)))+  assertEq failed (styleBg (themeButton offTheme)) (styleBg (themeButton (disabledTheme (primary base))))++-- | Changing only a scope's theme repaints.+runStyledDamageTest :: Context -> IORef Int -> IO ()+runStyledDamageTest ctx failed = do+  let inp = withInputOff 300 200+      ui c = column (styled (buttonStyle (background c)) (button "B"))+      blue = colorRGBA 30 60 200 255+      green = colorRGBA 30 200 60 255+  _ <- warmup2 ctx inp (ui blue)+  _ <- takeDamage ctx+  forM_ [green, blue] $ \c -> do+    (_, _, draw, _) <- runFrame ctx inp (ui c)+    dmg <- takeDamage ctx+    assertEq failed dmg DamageFull+    quads <- drawQuads draw+    assert failed (any ((== c) . snd) quads)
+ test/integration/Cases/Svg.hs view
@@ -0,0 +1,74 @@+module Cases.Svg+  ( runSvgRasterTest+  , runSvgIconTest+  ) where++import Data.ByteString qualified as BS+import Data.IORef (IORef)+import NanoUI+import NanoUI.Svg (rasterizeSvg, svgMonochrome)+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq)+import NanoUI.Testing.Harness (drawQuads, warmupDraw, withInputOff)++-- | Strokes, even-odd holes and transforms rasterize where they should.+runSvgRasterTest :: Context -> IORef Int -> IO ()+runSvgRasterTest _ failed = do+  let white = colorRGBA 255 255 255 255+      alphaAt w bytes x y = BS.index bytes ((y * w + x) * 4 + 3)+      pixelAt w bytes x y = [BS.index bytes ((y * w + x) * 4 + k) | k <- [0 .. 3]]+      clock =+        "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"24\" height=\"24\" viewBox=\"0 0 24 24\" fill=\"none\" \+        \stroke=\"currentColor\" stroke-width=\"2\" stroke-linecap=\"round\" stroke-linejoin=\"round\">\+        \<!-- a clock --><circle cx=\"12\" cy=\"12\" r=\"10\"/><path d=\"M12 6v6l4 2\"/></svg>"+  case parseSvg clock of+    Left err -> putStrLn err >> assert failed False+    Right doc -> do+      assert failed (svgMonochrome doc)+      assertEq failed (24, 24) (svgSize doc)+      let px = rasterizeSvg 48 48 white doc+      assertEq failed (48 * 48 * 4) (BS.length px)+      -- On the ring, on the hands, and in the empty face between them.+      assert failed (alphaAt 48 px 24 44 > 200)+      assert failed (alphaAt 48 px 24 18 > 200)+      assertEq failed 0 (alphaAt 48 px 24 36)+      assertEq failed 0 (alphaAt 48 px 1 1)+  let holed =+        "<svg viewBox='0 0 10 10'><path fill-rule='evenodd' fill='#ff0000' d='M0 0h10v10H0z M3 3h4v4H3z'/>\+        \<g transform='translate(5 0) scale(0.5)'><rect width='2' height='2' fill='rgb(0,0,255)'/></g></svg>"+  case parseSvg holed of+    Left err -> putStrLn err >> assert failed False+    Right doc -> do+      assert failed (not (svgMonochrome doc))+      let px = rasterizeSvg 10 10 white doc+      assertEq failed [255, 0, 0, 255] (pixelAt 10 px 1 8)+      assertEq failed 0 (alphaAt 10 px 5 5)+      assertEq failed [0, 0, 255, 255] (pixelAt 10 px 5 0)+  let arcs = "<svg viewBox='0 0 20 20'><path d='M2 10a8 8 0 1 1 16 0a8 8 0 1 1-16 0z'/></svg>"+  case parseSvg arcs of+    Left err -> putStrLn err >> assert failed False+    Right doc -> do+      let px = rasterizeSvg 20 20 white doc+      assertEq failed 255 (alphaAt 20 px 10 10)+      assertEq failed 0 (alphaAt 20 px 1 1)+  assert failed (either (const True) (const False) (parseSvg "<nope/>"))++-- | An icon draws its raster tinted with the text colour, and later frames+-- reuse the raster.+runSvgIconTest :: Context -> IORef Int -> IO ()+runSvgIconTest ctx failed = do+  theme <- getTheme ctx+  doc <- either fail pure (parseSvg "<svg viewBox='0 0 24 24'><rect x='2' y='2' width='20' height='20'/></svg>")+  let inp = withInputOff 200 120+      red = colorRGBA 220 40 40 255+      ui = column $ do+        svgIcon 24 doc+        svgIconWith (fixedWH 16 16 . fontColor red) doc+  (_, draw) <- warmupDraw ctx inp ui+  quads <- drawQuads draw+  let colors = map snd quads+  assert failed (styleFg (themePanel theme) `elem` colors)+  assert failed (red `elem` colors)+  (_, draw2) <- warmupDraw ctx inp ui+  quads2 <- drawQuads draw2+  assertEq failed (length quads) (length quads2)
+ test/integration/Cases/Table.hs view
@@ -0,0 +1,718 @@+module Cases.Table+  ( runPageWheelAboveTableTest+  , runTableCellPadTest+  , runTableColResizeDemoReproTest+  , runTableFillWidthTest+  , runTableFirstColWidthTest+  , runTableHBarReachTest+  , runTableReorderTest+  , runTableResizeOverflowTest+  , runTableScrollRevealTest+  , runTableSharedScrollMetricsTest+  , runTableSortTest+  , runTableWrapRowStretchTest+  ) where++import Control.Monad (forM, forM_, replicateM_, void, (<=<))+import Data.Bits ((.&.))+import Data.IORef (IORef)+import Data.IntMap.Strict qualified as IM+import Data.List (sortBy, sortOn, tails)+import Data.Maybe (isJust, listToMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Primitive.SmallArray qualified as SA+import NanoUI+import NanoUI.Context (ctxNodeArena)+import NanoUI.Layout.Arena+  ( DirTag (..)+  , NodeIdx+  , NodeType (..)+  , NodeArena+  , findNodeM+  , foldNodesM+  , getClipRect+  , getDirection+  , getNodeType+  , getParent+  , getRect+  , getScrollContentW+  , getStyleIdx+  , getWidgetId+  )+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt, withInput)+import NanoUI.Testing.Harness+  ( clickPos+  , dragPos+  , findHeader+  , requireSpan+  , spanCenter+  , warmup2+  , withInputOff+  )+import Text.Read (readMaybe)+++runTableSortTest :: Context -> IORef Int -> IO ()+runTableSortTest _ failed = do+  let+    columns = headed "Key" fst+    rows = [("b", 1), ("a", 2), ("b", 3), ("a", 4)] :: [(Text, Int)]+  assertEq+    failed+    [2, 4, 1, 3]+    (map snd (sortRows columns (SortCol 0 SortAsc) (SA.smallArrayFromList rows)))+  assertEq+    failed+    [1, 3, 2, 4]+    (map snd (sortRows columns (SortCol 0 SortDesc) rows))+  assertEq failed rows (sortRows mempty (SortCol 0 SortAsc) rows)+  assertEq failed rows (sortRows mempty (SortCol 0 SortDesc) rows)++runTableReorderTest :: Context -> IORef Int -> IO ()+runTableReorderTest ctx failed = do+  let+    input = withInputOff 500 240+    ui = simpleTable ["First", "Second", "Third"] (SA.smallArrayFromList [["a", "b", "c"], ["short"], []])+    draw inp = void (runFrame ctx inp ui)+    header name = do+      spans <- collectTextSpans ctx+      requireSpan "missing table header" (findHeader name spans)+  _ <- warmup2 ctx input ui+  first <- header "First"+  third <- header "Third"+  -- A click is not a reorder, even when its absolute x coordinate exceeds+  -- the drag threshold.+  clickPos draw input first+  clicked <- warmup2 ctx input ui+  assertEq failed [0, 1, 2] (tableColOrder clicked)+  dragPos draw input first third+  moved <- warmup2 ctx input ui+  assertEq failed [1, 0, 2] (tableColOrder moved)+  -- The released drag must not stay latched on subsequent frames.+  draw input {inputMousePos = first}+  settled <- warmup2 ctx input ui+  assertEq failed [1, 0, 2] (tableColOrder settled)++-- Row label nearest the bottom edge of the body viewport.+rowLabelIndex :: T.Text -> Maybe Int+rowLabelIndex t = readMaybe (T.unpack (T.takeWhile (/= ' ') (T.drop 4 t)))++-- Wheeling with the mouse parked well above a nested table must scroll the+-- page scroller only. Hit rects that drift by the page's scroll offset made+-- the wheel grab the table's phantom rect and scroll the table instead.+runPageWheelAboveTableTest :: Context -> IORef Int -> IO ()+runPageWheelAboveTableTest ctx failed = do+  let inp0 = withInput 320 220+      wheelAt = inp0 {inputMousePos = V2 160 80, inputScroll = V2 0 5}+      ui = scrollArea (fillW . fixedH 200 . gap 0) $ do+        mapM_ (\i -> label (T.pack ("head " <> show (i :: Int)))) [1 .. 10]+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        tableWith (fixedH 120) "people" tableScrollCols tableScrollRows tableSort+  (pageWid, _) <- warmup2 ctx inp0 ui+  _ <- runFrame ctx wheelAt ui+  _ <- runFrame ctx wheelAt ui+  pageOff <- getScrollOffset ctx pageWid+  assertGt failed pageOff 0+  spans <- collectTextSpans ctx+  let firstRowVisible = any ((== Just 1) . rowLabelIndex . sndOfSpan) spans+  assert failed firstRowVisible+  where+    sndOfSpan (_, t, _, _, _) = t++bottomRowIndex :: [(Rect, T.Text, a, b, c)] -> Maybe Int+bottomRowIndex spans =+  listToMaybe+    [ n+    | (_, t, _, _, _) <-+        sortBy+          ( \(ra, _, _, _, _) (rb, _, _, _, _) ->+              compare (rectY rb) (rectY ra)+          )+          spans+    , "row-" `T.isPrefixOf` t+    , Just n <- [rowLabelIndex t]+    ]++-- Scrolling must materialize the newly revealed row in the same frame the+-- offset lands. The scroll offset is applied after the UI pass, so a frame+-- that only translated the pre-scroll rows left the revealed strip without+-- geometry (stale pixels under the damage clip).+runTableScrollRevealTest :: Context -> IORef Int -> IO ()+runTableScrollRevealTest ctx failed = do+  let inp0 = (withInput 320 220) {inputMousePos = V2 40 80}+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableWith+              (fixedH 150)+              "people"+              tableScrollCols+              tableScrollRows+              tableSort+          )+  -- A step of one line keeps the scroll below short enough that the rows it+  -- lands on are still in ascending label order (the table sorts the labels+  -- as text, so "row-2" comes after "row-19").+  setScrollTuning ctx defaultScrollTuning {scrollWheelStep = 20}+  -- Three warmups so virtualization settles on the real viewport height.+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  spans0 <- collectTextSpans ctx+  -- Scroll six wheel lines (120px, several rows): the bottom visible row must+  -- advance because the revealed rows are materialized in the same frame.+  let scrollInp = inp0 {inputScroll = V2 0 6}+  _ <- runFrame ctx scrollInp ui+  spans1 <- collectTextSpans ctx+  case (bottomRowIndex spans0, bottomRowIndex spans1) of+    (Just lo, Just hi) -> do+      assert failed (hi > lo)+      -- The revealed band must be filled with real rows, not one clipped sliver+      -- of a stale row scrolling past the top edge.+      let+        visibleRows = [r | (r, t, _, _, _) <- spans1, "row-" `T.isPrefixOf` t]+      assert failed (length visibleRows >= 3)+    _ -> assert failed False++-- When one cell wraps to several lines the whole row grows; every other+-- cell in the row must stretch to the same height so stripe backgrounds and+-- row borders span the full row instead of leaving a gap.+runTableWrapRowStretchTest :: Context -> IORef Int -> IO ()+runTableWrapRowStretchTest ctx failed = do+  let inp0 = (withInput 700 400) {inputMousePos = V2 (-40) (-40)}+      cfg = defaultTableConfig {tableColSizes = [ColFixed 280, ColFixed 90]}+      wrapCols = headed "Name" fst <> headed "Notes" snd+      rows =+        [ ("row-" <> T.pack (show (i :: Int)), T.unwords (replicate 24 "lorem"))+        | i <- [1 .. 8]+        ]+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableConfigured+              cfg+              id+              "wrap-stretch"+              wrapCols+              rows+              tableSort+          )+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  let na = ctxNodeArena ctx+  cells <- foldNodesM na (\acc i -> do+    nt <- getNodeType na i+    if nt /= NodeText+      then pure acc+      else do+        (_, y, w, h) <- getRect na i+        -- Body cells sit below the header band and have real width (both+        -- columns are wider than 50px; the 90px Notes column wraps its long+        -- text and drives the row height).+        pure (if y > 25 && w > 50 then (y, [h]) : acc else acc)) []+  -- Cells of one row share the same top y; every row group must be uniform+  -- (all cells stretch to the row height).+  let rowBands = IM.toAscList (IM.fromListWith (++) [(round y, hs) | (y, hs) <- cells])+  forM_ rowBands $ \(_, hs) -> assert failed (length (dedup hs) == 1)+  -- And at least one row is actually wrapped (taller than the 28px minimum),+  -- otherwise the test asserts nothing.+  assert failed (any (\hs -> maximum hs > 40) (map snd rowBands))+  -- The body must start right below the header: an unconditional scrollbar+  -- lane reserve (shown even with no horizontal overflow) opens a dead gap.+  assert failed (minimum (map fst rowBands) < 40)+  where+    dedup = foldr (\x acc -> if x `elem` acc then acc else x : acc) []++-- Resizing a column past the pane's right edge overflows the body. On every+-- drag frame the header row must stay inside the row scroller's clip, with+-- no frame where the horizontal bar lane covers the header's bottom half,+-- and once the drag settles the body scroller's+-- horizontal bar drags the shared offset both ways.+runTableResizeOverflowTest :: Context -> IORef Int -> IO ()+runTableResizeOverflowTest ctx failed = do+  let inp0 = (withInput 400 300) {inputMousePos = V2 30 30}+      -- Five rows put the body just inside the vertical bar's toggle band:+      -- the bar appears exactly when the header lane spacer appears, which is+      -- the sequence that could clip the header.+      rows = take 5 tableScrollRows+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableWith+              (fixedH 180)+              "resize-lane"+              tableScrollCols+              rows+              tableSort+          )+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  hdr <- headerButtonRect ctx+  case hdr of+    Nothing -> assert failed False+    Just (Rect hx hy hw hh) -> do+      let edgeX = hx + hw+          headerY = hy + hh / 2+          pressInp = inp0 {inputMousePos = V2 (edgeX - 2) headerY, inputMouseDown = True, inputMousePressed = True}+          dragInp x = inp0 {inputMousePos = V2 x headerY, inputMouseDown = True}+          -- First drag well past the pane's right edge (lane + v-bar appear),+          -- then settle back inside the vertical-bar gutter band so the+          -- scroller viewport and the stale lane flag disagree across frames.+          steps = [edgeX + 160, edgeX + 320, edgeX + 300, edgeX + 290, edgeX + 310, edgeX + 300]+      _ <- runFrame ctx pressInp ui+      forM_ steps $ \x -> do+        _ <- runFrame ctx (dragInp x) ui+        mClip <- headerScrollerClip ctx+        mHdr <- headerButtonRect ctx+        case (mClip, mHdr) of+          (Just (Rect _ cy _ ch), Just (Rect _ hy' _ hh')) -> assert failed (hy' + hh' <= cy + ch + 0.5)+          _ -> assert failed False+      -- Release the resize drag and let the layout settle.+      _ <- runFrame ctx inp0 ui+      _ <- runFrame ctx inp0 ui+      -- The bar lives at the bottom of the body scroller: pressing its track+      -- there jumps the shared horizontal offset, and dragging moves it.+      mBody <- bodyScrollerRect ctx+      case mBody of+        Nothing -> assert failed False+        Just (Rect bx by bw bh) -> do+          let barY = by + bh - scrollBarWidth / 2+              barPress = inp0 {inputMousePos = V2 (bx + bw * 0.3) barY, inputMouseDown = True, inputMousePressed = True}+              barDrag x = inp0 {inputMousePos = V2 x barY, inputMouseDown = True}+          _ <- runFrame ctx barPress ui+          V2 off1 _ <- bodyOffset ctx+          _ <- runFrame ctx (barDrag (bx + bw * 0.95)) ui+          V2 off2 _ <- bodyOffset ctx+          assertGt failed off2 off1+          _ <- runFrame ctx (barDrag (bx + bw * 0.2)) ui+          V2 off3 _ <- bodyOffset ctx+          assert failed (off3 < off2)++-- | Leftmost table-header button rect.+headerButtonRect :: Context -> IO (Maybe Rect)+headerButtonRect ctx = listToMaybe <$> headerButtonRects ctx++-- | Content clip of the header row scroller (the Row-direction one).+headerScrollerClip :: Context -> IO (Maybe Rect)+headerScrollerClip ctx = do+  let na = ctxNodeArena ctx+  found <- findNodeM na $ \i -> do+    nt <- getNodeType na i+    if nt == NodeScrollContainer then (== DirRow) <$> getDirection na i else pure False+  maybe (pure Nothing) (getClipRect na) found++isTableHeaderStyleIdx :: Int -> Bool+isTableHeaderStyleIdx si = si .&. 0x80000000 /= 0++tableScrollCols :: Colonnade Headed TableScrollRow T.Text+tableScrollCols =+  mconcat+    [ headed "Name" tableScrollName+    , headed "Value" tableScrollVal+    ]++data TableScrollRow = TableScrollRow+  { tableScrollName :: T.Text+  , tableScrollVal :: T.Text+  }++tableScrollRows :: [TableScrollRow]+tableScrollRows =+  [ TableScrollRow ("row-" <> T.pack (show (i :: Int))) ("val-" <> T.pack (show i))+  | i <- [1 .. 20]+  ]++-- A content-sized first column fits its longest cell, and in a fit-width 2D+-- table vertical overflow must not shrink it either.+runTableFirstColWidthTest :: Context -> IORef Int -> IO ()+runTableFirstColWidthTest ctx failed = do+  let inp0 = (withInput 400 200) {inputMousePos = V2 60 80}+      cfg =+        defaultTableConfig+          { tableColSizes = [ColContent, ColStretch]+          }+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableConfigured+              cfg+              id+              "people"+              tableFirstColCols+              tableFirstColRows+              tableSort+          )+  warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  let findLabel needle =+        listToMaybe [(r, t) | (r, t, _, _, _) <- spans, needle `T.isInfixOf` t]+  case (findLabel "long-first-col", findLabel "val-1") of+    (Just (Rect cn _ cw _, _), Just (Rect vx _ _ _, _)) -> do+      assertGt failed cw 50+      assert failed (vx > cn + cw - 2)+    _ -> assert failed False+  pixel <- newPixelContext+  let fitInp = (withInput 280 180) {inputMousePos = V2 40 60}+      fitUi = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableWith+              (fixedH 100 . (\l -> l {layoutWidth = Fit}))+              "people"+              tableFirstColCols+              tableFirstColRows+              tableSort+          )+  warmup2 pixel fitInp fitUi+  fitSpans <- collectTextSpans pixel+  case [r | (r, t, _, _, _) <- fitSpans, "long-first-col" `T.isInfixOf` t] of+    Rect _ _ cw ch : _ -> do+      assertGt failed cw 50+      assert failed (ch < 40)+    [] -> assert failed False++tableFirstColCols :: Colonnade Headed TableFirstColRow T.Text+tableFirstColCols =+  mconcat+    [ headed "Name" tableFirstColName+    , headed "Value" tableFirstColVal+    ]++data TableFirstColRow = TableFirstColRow+  { tableFirstColName :: T.Text+  , tableFirstColVal :: T.Text+  }++tableFirstColRows :: [TableFirstColRow]+tableFirstColRows =+  TableFirstColRow "long-first-col" "short"+    : [ TableFirstColRow ("row-" <> T.pack (show (i :: Int))) ("val-" <> T.pack (show i))+      | i <- [1 .. 8 :: Int]+      ]++runTableFillWidthTest :: Context -> IORef Int -> IO ()+runTableFillWidthTest _ failed = do+  ctx <- newContext+  let inp0 = (withInput 500 200) {inputMousePos = V2 200 80}+      cfg =+        defaultTableConfig+          { tableColSizes =+              [ ColContent+              , ColStretch+              , ColFixed 64+              , ColStretch+              , ColContent+              ]+          }+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableConfigured+              cfg+              id+              "people"+              tableFillCols+              tableFillRows+              tableSort+          )+  warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  let findLabel needle =+        listToMaybe [(r, t) | (r, t, _, _, _) <- spans, needle `T.isInfixOf` t]+  case (findLabel "Name", findLabel "David", findLabel "Role", findLabel "Manager") of+    ( Just (Rect nx _ _ _, _)+      , Just (Rect cx _ _ _, _)+      , Just (Rect rx _ rw _, _)+      , Just (Rect mx _ mw _, _)+      ) -> do+      assert failed (abs (nx - cx) <= 1)+      assertGt failed (rx + rw) 380+      assertGt failed mw 50+      assert failed (mx >= rx - 2)+    _ -> assert failed False++-- Pixel host: Age (right) and City (left) must not sit on the shared grid+-- line. A plain table also hands its slack to the columns, so the last one+-- reaches the far side.+runTableCellPadTest :: Context -> IORef Int -> IO ()+runTableCellPadTest ctx failed = do+  let inp0 = (withInput 500 240) {inputMousePos = V2 200 80}+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void (table "people" tableFillCols tableFillRows tableSort)+  warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  let findLabel needle =+        listToMaybe [(r, t) | (r, t, _, _, _) <- spans, needle `T.isInfixOf` t]+  case (findLabel "Name", findLabel "David", findLabel "63", findLabel "Austin") of+    (Just (Rect hx _ _ _, _), Just (Rect nx _ _ _, _), Just (Rect ax _ aw _, _), Just (Rect cx _ _ _, _)) -> do+      assert failed (abs (hx - nx) <= 1)+      assertGt failed nx 4+      assertGt failed (cx - (ax + aw)) 10+    _ -> assert failed False+  -- The slack check needs all five columns in view, which the pixel font's+  -- wider glyphs do not fit in 500px; measure it on a plain host.+  plain <- newContext+  warmup2 plain ((withInput 500 200) {inputMousePos = V2 200 80}) ui+  plainSpans <- collectTextSpans plain+  case [r | (r, t, _, _, _) <- plainSpans, "Role" `T.isInfixOf` t] of+    Rect rx _ rw _ : _ -> assertGt failed (rx + rw) 420+    [] -> assert failed False++tableFillCols :: Colonnade Headed TableFillRow T.Text+tableFillCols =+  mconcat+    [ headed "Name" tableFillName+    , headed "Dept" tableFillDept+    , headed "Age" tableFillAge+    , headed "City" tableFillCity+    , headed "Role" tableFillRole+    ]++data TableFillRow = TableFillRow+  { tableFillName :: T.Text+  , tableFillDept :: T.Text+  , tableFillAge :: T.Text+  , tableFillCity :: T.Text+  , tableFillRole :: T.Text+  }++tableFillRows :: [TableFillRow]+tableFillRows =+  [ TableFillRow "David" "Eng" "63" "Austin" "Staff"+  , TableFillRow "Maya" "Ops" "41" "Tokyo" "Manager"+  , TableFillRow "Chen" "Design" "26" "Shanghai" "IC"+  ]++-- The demo's page structure (page scroller, card panel, five columns). Every+-- column boundary must raise the resize cursor and resize when grabbed, both+-- on the header cell and down in the column body.+runTableColResizeDemoReproTest :: Context -> IORef Int -> IO ()+runTableColResizeDemoReproTest _ failed =+  forM_ [False, True] $ \inBody -> do+    ctx <- newPixelContext+    let inp0 = (withInput 700 500) {inputMousePos = V2 400 100}+        ui =+          scrollWith (tight . grow) $+            columnWith (padAll 6 . gap 6 . fillW) $+              card $ do+                (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+                void+                  ( tableWith+                      (fixedH 280)+                      "people"+                      demoPeopleCols+                      demoPeopleRows+                      tableSort+                  )+    _ <- runFrame ctx inp0 ui+    _ <- runFrame ctx inp0 ui+    bodyBot <- tableBodyBottom ctx+    hdrs0 <- headerButtonRects ctx+    forM_ (zip [0 ..] hdrs0) $ \(k, _) -> do+      hdrs <- headerButtonRects ctx+      case drop k hdrs of+        Rect hx hy hw hh : _ | bodyBot > hy + hh + 20 -> do+          let edgeX = hx + hw - 2+              grabY = if inBody then (hy + hh + bodyBot) / 2 else hy + hh / 2+              hoverInp = inp0 {inputMousePos = V2 edgeX grabY}+          _ <- runFrame ctx hoverInp ui+          kind <- uiCursorKind ctx hoverInp+          assertEq failed kind UiCursorEwResize+          let pressInp = hoverInp {inputMouseDown = True, inputMousePressed = True}+              dragInp x = inp0 {inputMousePos = V2 x grabY, inputMouseDown = True}+          before <- headerButtonRects ctx+          _ <- runFrame ctx pressInp ui+          _ <- runFrame ctx (dragInp (edgeX + 60)) ui+          _ <- runFrame ctx (dragInp (edgeX + 60)) ui+          _ <- runFrame ctx (dragInp (edgeX + 60)) ui+          after <- headerButtonRects ctx+          case (drop k before, drop k after) of+            (Rect _ _ wb _ : _, Rect _ _ wa _ : _) -> assertGt failed wa (wb + 30)+            _ -> assert failed False+        _ -> assert failed False++demoPeopleCols :: Colonnade Headed (T.Text, T.Text, T.Text, T.Text, T.Text) T.Text+demoPeopleCols =+  mconcat+    [ headed "Name" (\(a, _, _, _, _) -> a)+    , headed "Dept" (\(_, b, _, _, _) -> b)+    , headed "Age" (\(_, _, c, _, _) -> c)+    , headed "City" (\(_, _, _, d, _) -> d)+    , headed "Role" (\(_, _, _, _, e) -> e)+    ]++demoPeopleRows :: [(T.Text, T.Text, T.Text, T.Text, T.Text)]+demoPeopleRows =+  [ (T.pack n, T.pack d, T.pack (show a), T.pack c, T.pack r)+  | (n, d, a, c, r) <-+      [ ("David", "Eng", 63 :: Int, "Austin", "Staff")+      , ("Ava", "Design", 34, "Berlin", "Lead")+      , ("Sonia", "Eng", 12, "Lisbon", "Intern")+      , ("Maya", "Ops", 41, "Tokyo", "Manager")+      , ("Leo", "Design", 28, "Paris", "IC")+      , ("Noah", "Eng", 37, "Seoul", "Staff")+      , ("Iris", "Ops", 19, "Austin", "IC")+      , ("Jules", "Sales", 45, "London", "Manager")+      , ("Priya", "Eng", 31, "Bengaluru", "Lead")+      , ("Chen", "Design", 26, "Shanghai", "IC")+      , ("Omar", "Ops", 52, "Cairo", "Lead")+      , ("Elena", "Sales", 39, "Madrid", "Staff")+      , ("Kai", "Eng", 23, "Oslo", "IC")+      , ("Ruth", "Ops", 47, "Boston", "Staff")+      ]+  ]++-- All table-header button rects, left to right.+headerButtonRects :: Context -> IO [Rect]+headerButtonRects ctx = do+  let na = ctxNodeArena ctx+  rects <- foldNodesM na (\acc i -> do+    header <- isHeaderButton na i+    if header then (\(x, y, w, h) -> Rect x y w h : acc) <$> getRect na i else pure acc) []+  pure (sortOn rectX rects)++isHeaderButton :: NodeArena -> NodeIdx -> IO Bool+isHeaderButton na i = do+  nt <- getNodeType na i+  if nt == NodeButton then isTableHeaderStyleIdx <$> getStyleIdx na i else pure False++-- | Bottom edge of the table pane: from the first header button, walk up to+-- the enclosing panel and return its bottom Y.+tableBodyBottom :: Context -> IO Float+tableBodyBottom ctx = do+  let na = ctxNodeArena ctx+  let walkUp i+        | i < 0 = pure 0+        | otherwise = do+            nt <- getNodeType na i+            if nt /= NodePanel+              then getParent na i >>= walkUp+              else do+                (_, py, _, ph) <- getRect na i+                pure (py + ph)+  findNodeM na (isHeaderButton na) >>= maybe (pure 0) walkUp++-- | The body (unfrozen) v-scroller: a Column-direction 2D scroller with+-- style bits "both policies Auto, clamp set" (shared predicate for the+-- rect / h-bar / offset helpers below).+isBodyScroller :: Context -> NodeIdx -> IO Bool+isBodyScroller ctx i = do+  let na = ctxNodeArena ctx+  nt <- getNodeType na i+  if nt /= NodeScrollContainer+    then pure False+    else do+      d <- getDirection na i+      if d /= DirColumn+        then pure False+        else do+          si <- getStyleIdx na i+          pure (si .&. 3 == 0 && (si `div` 4) .&. 3 == 0 && si .&. 16 /= 0)++bodyScrollerRect :: Context -> IO (Maybe Rect)+bodyScrollerRect ctx = do+  let na = ctxNodeArena ctx+  found <- findNodeM na (isBodyScroller ctx)+  forM found $ \i -> do+    (x, y, w, h) <- getRect na i+    pure (Rect x y w h)++-- | The body scroller's 2D offset.+bodyOffset :: Context -> IO V2+bodyOffset ctx = do+  let na = ctxNodeArena ctx+  found <- findNodeM na (isBodyScroller ctx)+  maybe (pure (V2 0 0)) (getScrollOffset2D ctx <=< getWidgetId na) found++-- | Horizontal reach: at the end of the horizontal scroll the last column must+-- clear the vertical scrollbar lane, not stop with its right edge under the+-- lane. The body scroller's own vertical bar shrinks the horizontal viewport,+-- so the reachable range must subtract that lane (regression: the range used+-- the full padding box, leaving the last column partly hidden).+runTableHBarReachTest :: Context -> IORef Int -> IO ()+runTableHBarReachTest ctx failed = do+  let inp0 = (withInput 700 320) {inputMousePos = V2 300 160}+      cfg = defaultTableConfig {tableColSizes = [ColFixed 500, ColFixed 500]}+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void+          ( tableConfigured+              cfg+              (fixedH 200)+              "people"+              tableScrollCols+              tableScrollRows+              tableSort+          )+  _ <- runFrame ctx inp0 ui+  _ <- runFrame ctx inp0 ui+  mBody <- bodyScrollerRect ctx+  case mBody of+    Nothing -> assert failed False+    Just (Rect bx by bw bh) -> do+      let na = ctxNodeArena ctx+      scroller <- findNodeM na (isBodyScroller ctx)+      case scroller of+        Nothing -> assert failed False+        Just i -> do+          contentW <- getScrollContentW na i+          assertGt failed contentW bw+          let wheel = inp0 {inputMousePos = spanCenter (Rect bx by bw bh), inputScroll = V2 50 0}+          replicateM_ 20 (runFrame ctx wheel ui)+          V2 offX _ <- bodyOffset ctx+          -- Reached past the naive content - viewport range: the lane's width+          -- is now part of the reachable range.+          assertGt failed offX (contentW - bw)+          -- The rightmost header cell sits fully inside the body, left of the+          -- vertical lane.+          hdrs <- headerButtonRects ctx+          case reverse hdrs of+            (Rect hx _ hw _ : _) -> do+              assert failed (hx + hw <= bx + bw + 0.5)+              assertGt failed (hx + hw) (bx + bw - 24)+            [] -> assert failed False+          -- Header and body cells scroll in lockstep.+          spans <- collectTextSpans ctx+          let xOf needle = listToMaybe [rectX r | (r, t, _, _, _) <- spans, needle `T.isInfixOf` t]+          case (xOf "Value", xOf "val-") of+            (Just headerX, Just cellX) -> assert failed (abs (headerX - cellX) <= 1)+            _ -> assert failed False++-- A table with frozen columns builds two scroll nodes under one widget id.+-- Only one of them may publish the body's geometry: if both did, every frame+-- would rewrite the store with the other pane's viewport twice a frame, for+-- as long as the table is on screen. One publishes; what it publishes is the+-- body scroller, whole, and it holds still from frame to frame.+runTableSharedScrollMetricsTest :: Context -> IORef Int -> IO ()+runTableSharedScrollMetricsTest ctx failed = do+  let inp0 = (withInput 320 220) {inputMousePos = V2 40 80}+      cfg = defaultTableConfig {tableFreezeCols = 1}+      ui = do+        (tableSort, _) <- useTableSort (SortCol 0 SortAsc)+        void (tableConfigured cfg (fixedH 150) "people" tableScrollCols tableScrollRows tableSort)+  replicateM_ 3 (runFrame ctx inp0 ui)+  bodyWid <- tableBodyScrollWid ctx+  case bodyWid of+    Nothing -> assert failed False+    Just wid -> do+      before <- getScrollMetrics ctx wid+      assert failed (isJust before)+      -- The pane that owns both scrollbars, not the frozen column's sliver.+      assertEq failed (Just ScrollAxisXY) (fmap scrollAxes before)+      _ <- runFrame ctx inp0 ui+      after <- getScrollMetrics ctx wid+      assertEq failed before after++-- The widget id shared by the table body's panes: the id of the first scroll+-- container the arena holds that another scroll container repeats.+tableBodyScrollWid :: Context -> IO (Maybe WidgetId)+tableBodyScrollWid ctx = do+  let na = ctxNodeArena ctx+  wids <- reverse <$> foldNodesM na (\acc i -> do+    nt <- getNodeType na i+    if nt == NodeScrollContainer then (: acc) <$> getWidgetId na i else pure acc) []+  pure (listToMaybe [w | w : rest <- tails wids, w `elem` rest])+
+ test/integration/Cases/Tabs.hs view
@@ -0,0 +1,388 @@+module Cases.Tabs+  ( runTabsClosableTest+  , runTabsDisabledTest+  , runTabsDamageTest+  , runTabsEmitTest+  , runTabsLazinessTest+  , runTabsScrollTest+  , runTabsStatePersistenceTest+  , runPanelBodySwapDamageTest+  , runTabResponseForwardingTest+  ) where++import Control.Monad (forM, forM_, replicateM)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.Maybe (isJust)+import Data.Text qualified as T+import Data.Sequence qualified as Seq+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, run2Frames, withInput)+import NanoUI.Testing.Harness+  ( assertSpansHas+  , clickPair+  , drawQuads+  , hasText+  , keyInp+  , runClick+  , spanCenter+  , warmup2+  , withInputOff+  )+import NanoUI.Context (Context (..))+import NanoUI.Emit qualified as Emit+import NanoUI.Layout.Arena (arenaCount, findNodeM, getRect, getText, getWidgetId)++data DummyTab = TabA | TabB | TabC+  deriving (Eq, Show)++fullWindowRect :: Input -> Rect+fullWindowRect inp =+  let Size w h = inputWindowSize inp+   in Rect 0 0 w h++-- Content replacement inside a floating window must repaint every pixel of+-- the new body: a clip that skipped any incoming row would leave the pane+-- rendering stale pixels from the previous body ("ghosting"). The stable+-- content slot and the incoming key rects (diffNew) must together cover all+-- five rows.+runPanelBodySwapDamageTest :: Context -> IORef Int -> IO ()+runPanelBodySwapDamageTest ctx failed = do+  let inp0 = withInput 400 300+      uiA = window True "TabWin" (columnWith (fixedH 300) (label "WIDE BODY ROW ONE"))+      uiB = window True "TabWin" (columnWith (fixedH 300) (column (replicateM 5 (label "row line") >> pure ())))+  _ <- warmup2 ctx inp0 uiA+  _ <- runFrame ctx inp0 uiA+  _ <- takeDamage ctx+  _ <- runFrame ctx inp0 uiB+  dmg <- takeDamage ctx+  assert failed (not (damageIsEmpty dmg))+  let dmgR = case dmg of+        DamageFull -> fullWindowRect inp0+        DamageClip r -> r+      Rect ddx ddy ddw ddh = dmgR+  spans <- collectOverlayTextSpans ctx inp0+  let rows = [(r, t) | (r, t, _, _, _) <- spans, "row line" `T.isInfixOf` t]+  assert failed (length rows == 5)+  forM_ rows $ \(Rect rx ry rw rh, _) -> do+    assert failed (rx >= ddx && ry >= ddy && rx + rw <= ddx + ddw && ry + rh <= ddy + ddh)++runTabsLazinessTest :: Context -> IORef Int -> IO ()+runTabsLazinessTest ctx failed = do+  evalCountA <- newIORef (0 :: Int)+  evalCountB <- newIORef (0 :: Int)+  evalCountC <- newIORef (0 :: Int)+  let inp = withInput 200 100+      ui = tabs TabB $ Seq.fromList+        [ tab TabA "A" (uiIO (modifyIORef' evalCountA (+ 1)) >> label "Body A")+        , tab TabB "B" (uiIO (modifyIORef' evalCountB (+ 1)) >> label "Body B")+        , tab TabC "C" (uiIO (modifyIORef' evalCountC (+ 1)) >> label "Body C")+        ]+  _ <- runFrame ctx inp ui+  cntA <- readIORef evalCountA+  cntB <- readIORef evalCountB+  cntC <- readIORef evalCountC+  assertEq failed cntA 0+  assertEq failed cntB 1+  assertEq failed cntC 0++data TabMsg = MsgSelect DummyTab | MsgClose DummyTab+  deriving (Eq, Show)++runTabsEmitTest :: Context -> IORef Int -> IO ()+runTabsEmitTest ctx failed = do+  let inp0 = withInput 300 100+      ui curTab = Emit.tabs curTab+        [ tab TabA "Alpha" (label "Body A")+        , tab TabB "Beta" (label "Body B")+        ]+        MsgSelect+  _ <- runFrame ctx inp0 (ui TabA)+  spans <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans, "Beta" `T.isInfixOf` txt] of+    (r : _) -> do+      let (press, release) = clickPair inp0 (spanCenter r)+      _ <- runFrame ctx press (ui TabA)+      (_, msgs, _, _) <- runFrame ctx release (ui TabA)+      assertEq failed (decodeMessages msgs :: [TabMsg]) [MsgSelect TabB]+    [] -> assert failed False++-- Composite responses expose every flag of their widget response+-- (regression: TabResponse dropped respSubmitted).+runTabResponseForwardingTest :: Context -> IORef Int -> IO ()+runTabResponseForwardingTest _ failed = do+  let inner = mempty {rawRespSubmitted = True, rawRespRightPressed = True, rawRespChanged = True}+      tabResp = TabResponse inner Nothing TabA+      tableResp = TableResponse inner (SortCol 0 SortAsc) [] mempty+  assert failed (respSubmitted tabResp && respRightPressed tabResp && respChanged tabResp)+  assert failed (respSubmitted tableResp && respRightPressed tableResp && respChanged tableResp)++runTabsClosableTest :: Context -> IORef Int -> IO ()+runTabsClosableTest ctx failed = do+  let inp0 = withInput 300 100+      ui curTab = tabs' curTab+        [ closableTab TabA "Alpha" (label "Body A")+        , closableTab TabB "Beta" (label "Body B")+        ]+  _ <- runFrame ctx inp0 (ui TabA)+  mClose <- findCloseButtonRect ctx+  case mClose of+    Just r -> do+      tResp <- runClick ctx inp0 (ui TabA) (spanCenter r)+      assertEq failed (tabClosed tResp) (Just TabA)+      assertEq failed (tabActive tResp) TabA+    Nothing -> assert failed False++findCloseButtonRect :: Context -> IO (Maybe Rect)+findCloseButtonRect ctx = do+  let na = ctxNodeArena ctx+  found <- findNodeM na (fmap ("\215" `T.isInfixOf`) . getText na)+  forM found $ \i -> do+    (x, y, w, h) <- getRect na i+    pure (Rect x y w h)++-- The public disabled flag covers both the header and its close control,+-- including retained keyboard focus when an enabled tab becomes disabled.+runTabsDisabledTest :: Context -> IORef Int -> IO ()+runTabsDisabledTest _ failed = forM_ [TabTop, TabLeft] $ \orientation -> do+  ctx <- newContext+  let inp = withInputOff 400 240+      ui disabled = tabsConfigured' defaultTabsConfig {tabsOrientation = orientation} TabA+        [ (closableTab TabB "Disabled" (label "Body B")) {tabDisabled = disabled}+        , tab TabA "Enabled" (label "Body A")+        ]+      check response = do+        assertEq failed (tabActive response) TabA+        assertEq failed (tabClosed response) Nothing+        assert failed (not (respClicked response) && not (respChanged response))+  _ <- warmup2 ctx inp (ui False)+  let arena = ctxNodeArena ctx+  n <- arenaCount arena+  headers <- mapM (\i -> (,) <$> getText arena i <*> getWidgetId arena i) [0 .. n - 1]+  _ <- warmup2 ctx inp (ui True)+  spans <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans, txt == "Disabled"] of+    r : _ -> check =<< runClick ctx inp (ui True) (spanCenter r)+    [] -> assert failed False+  closeRect <- findCloseButtonRect ctx+  case closeRect of+    Just r -> check =<< runClick ctx inp (ui True) (spanCenter r)+    Nothing -> assert failed False+  forM_ [wid | (txt, wid) <- headers, txt == "Disabled" || txt == "\215"] $ \wid -> do+    writeIORef (ctxFocusId ctx) wid+    (result, _, _, _) <- runFrame ctx (keyInp KeyEnter inp) (ui True)+    check result+  -- Re-enabling the same header preserves its identity and restores activation.+  _ <- warmup2 ctx inp (ui False)+  spansEnabled <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spansEnabled, txt == "Disabled"] of+    r : _ -> do+      response <- runClick ctx inp (ui False) (spanCenter r)+      assertEq failed (tabActive response) TabB+    [] -> assert failed False++runTabsStatePersistenceTest :: Context -> IORef Int -> IO ()+runTabsStatePersistenceTest ctx failed = do+  let inp0 = withInput 300 100+      ui curTab = tabs curTab+        [ tab TabA "A" $+            withKey ("tab-a" :: T.Text) $+              withKey ("flag" :: T.Text) $ do+                (flag, setFlag) <- useFlag False+                whenM (button "ToggleA") (setFlag (not flag))+                label (if flag then "FlagIsOn" else "FlagIsOff")+        , tab TabB "B" (label "OtherTab")+        ]+  _ <- runFrame ctx inp0 (ui TabA)+  spans0 <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans0, "ToggleA" `T.isInfixOf` txt] of+    (r : _) -> do+      _ <- runClick ctx inp0 (ui TabA) (spanCenter r)+      _ <- runFrame ctx inp0 (ui TabA)+      spans1 <- collectTextSpans ctx+      assertSpansHas failed "FlagIsOn" spans1++      _ <- runFrame ctx inp0 (ui TabB)+      spans2 <- collectTextSpans ctx+      assertSpansHas failed "OtherTab" spans2+      assert failed (not (hasText "FlagIsOn" spans2))++      _ <- runFrame ctx inp0 (ui TabA)+      spans3 <- collectTextSpans ctx+      assertSpansHas failed "FlagIsOn" spans3+    [] -> assert failed False++runTabsDamageTest :: Context -> IORef Int -> IO ()+runTabsDamageTest ctx failed = do+  let inp0 = withInputOff 300 100+      ui curTab = tabs' curTab+        [ tab TabA "Alpha" (label "Body A with some text")+        , tab TabB "Beta" (label "Body B different widgets")+        ]+      covers dmg (Rect rx ry rw rh) = case dmg of+        DamageFull -> True+        DamageClip (Rect dx dy dw dh) -> rx >= dx && ry >= dy && rx + rw <= dx + dw && ry + rh <= dy + dh+  _ <- runFrame ctx inp0 (ui TabA)+  _ <- takeDamage ctx+  _ <- runFrame ctx inp0 (ui TabA)+  dIdle <- takeDamage ctx+  assert failed (dIdle /= DamageFull)+  spansIdle <- collectTextSpans ctx+  assertSpansHas failed "Body A" spansIdle++  spans <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans, "Beta" `T.isInfixOf` txt] of+    (beta : _) -> do+      let (press, release) = clickPair inp0 (spanCenter beta)+      _ <- runFrame ctx press (ui TabA)+      (resp, _, _, _) <- runFrame ctx release (ui TabA)+      assert failed (respChanged resp && tabActive resp == TabB)+      spansSwitch <- collectTextSpans ctx+      assertSpansHas failed "Body B" spansSwitch+      assert failed (not (hasText "Body A" spansSwitch))+      let bodyB = [r | (r, txt, _, _, _) <- spansSwitch, "Body B" `T.isInfixOf` txt]+      dSwitch <- takeDamage ctx+      assert failed (not (null bodyB) && all (covers dSwitch) bodyB)++      _ <- runFrame ctx inp0 (ui TabB)+      dTabB <- takeDamage ctx+      assert failed (all (covers dTabB) bodyB)++      _ <- runFrame ctx inp0 (ui TabB)+      dSettled <- takeDamage ctx+      assert failed (dSettled /= DamageFull)+    [] -> assert failed False++-- Too-wide tab strips scroll instead of overflowing. The framework scroll+-- container owns the clip, the offset and the damage; the strip adds+-- chevron buttons on the left and right and pages the same offset with+-- them. Acceptance: scrolling left and right works (buttons, up/down wheel+-- notches mapped onto the horizontal offset) as well as left+right+-- (horizontal wheel, applied by the framework scroller itself); the tab+-- headers look exactly as they did before the strip could scroll (no+-- scroller well behind them); and no scrollbar appears.+runTabsScrollTest :: Context -> IORef Int -> IO ()+runTabsScrollTest _ failed = do+  let labels = ["Controls", "Graphics", "Typography", "Diagnostics", "LongestTabName"]+      mkTabs cur = tabBar cur [tab (i :: Int) l () | (i, l) <- zip [0 ..] labels]+      arrowRect ctx ch = do+        spans <- collectTextSpans ctx+        pure [r | (r, t, _, _, _) <- spans, T.any (== ch) t]+      chevrons = ['\8250', '\8249']++  -- Wide bar: everything fits and no arrows are drawn.+  wide <- newContext+  let wideInp = withInput 900 120+  _ <- runFrame wide wideInp (mkTabs 0)+  _ <- runFrame wide wideInp (mkTabs 0)+  wideSpans <- collectTextSpans wide+  forM_ labels $ \l -> assert failed (hasText l wideSpans)+  assert failed (not (T.any (`elem` chevrons) (T.concat [t | (_, t, _, _, _) <- wideSpans])))++  ctx <- newContext+  let inp = withInput 240 120+  _ <- runFrame ctx inp (mkTabs 0)+  _ <- runFrame ctx inp (mkTabs 0)+  -- The strip only pulls in its scroller once it has measured an overflow, so+  -- the arrow buttons show from the third frame on.+  _ <- runFrame ctx inp (mkTabs 0)+  spans0 <- collectTextSpans ctx+  assert failed (hasText "Controls" spans0)+  assert failed (not (hasText "LongestTabName" spans0))++  -- No scroller well: while the strip is scrollable it must not paint the+  -- input background, the input border, or any scrollbar track or thumb+  -- behind the headers. Only the tab buttons themselves (and the arrows)+  -- may paint in the bar. The checked region is the full window width and+  -- the bar's height (header 28 + 4 slack + 2 slop), derived from the input+  -- so a resize of the test window cannot silently shrink coverage.+  theme <- readIORef (ctxTheme ctx)+  (_, _, dd, _) <- run2Frames ctx inp (mkTabs 0)+  quads <- drawQuads dd+  let Size winW _ = inputWindowSize inp+      bar = Rect 0 0 winW 34+      inputSurface = themeInput theme+      forbidden =+        [ styleBg inputSurface+        , styleBorder inputSurface+        , scrollBarTrackColor inputSurface theme+        , scrollBarThumbColor inputSurface theme+        ]+      inBar = [(r, c) | (r, c) <- quads, isJust (rectIntersect r bar), c `elem` forbidden]+  assert failed (null inBar)++  -- Left and right buttons page the strip; the right arrow is pinned to the+  -- bar's far edge rather than trailing the last visible tab.+  mRight <- arrowRect ctx '\8250'+  case mRight of+    (r : _) -> do+      assert failed (rectX r + rectW r > 200)+      _ <- runClick ctx inp (mkTabs 0) (spanCenter r)+      _ <- runFrame ctx inp (mkTabs 0)+      spans1 <- collectTextSpans ctx+      assert failed (not (hasText "Controls" spans1))+      mLeft <- arrowRect ctx '\8249'+      case mLeft of+        (left : _) -> do+          _ <- runClick ctx inp (mkTabs 0) (spanCenter left)+          _ <- runFrame ctx inp (mkTabs 0)+          spans2 <- collectTextSpans ctx+          assert failed (hasText "Controls" spans2)+        _ -> assert failed False+    _ -> assert failed False++  -- Wheel up/down over the bar pages the window too (the strip maps the+  -- notches onto the horizontal offset).+  spans3 <- collectTextSpans ctx+  case [r | (r, t, _, _, _) <- spans3, "Controls" `T.isInfixOf` t] of+    (Rect cx cy cw ch : _) -> do+      let wheelDown = inp {inputMousePos = spanCenter (Rect cx cy cw ch), inputScroll = V2 0 20}+      _ <- runFrame ctx wheelDown (mkTabs 0)+      _ <- runFrame ctx inp (mkTabs 0)+      spans4 <- collectTextSpans ctx+      assert failed (not (hasText "Controls" spans4))++      -- Left+right wheel over the bar scrolls the same offset through the+      -- framework scroller. The vertical wheel pinned the offset at max, so+      -- wheeling right stays put (clamped at the end); wheeling left runs+      -- back to the start and re-shows the first tab, and further left+      -- notches clamp at zero instead of running past it. The deltas are+      -- coupled to the framework wheel step (scrollLineFor, 20px per notch+      -- on window hosts): V2 0 20 saturates at max, and +/-100 notches+      -- crosses the whole range regardless of the exact step.+      let wheelX d = inp {inputMousePos = spanCenter (Rect cx cy cw ch), inputScroll = V2 d 0}+      _ <- runFrame ctx (wheelX 10) (mkTabs 0)+      _ <- runFrame ctx inp (mkTabs 0)+      spans5 <- collectTextSpans ctx+      assert failed (not (hasText "Controls" spans5))+      _ <- runFrame ctx (wheelX (-100)) (mkTabs 0)+      _ <- runFrame ctx inp (mkTabs 0)+      spans6 <- collectTextSpans ctx+      assert failed (hasText "Controls" spans6)+      _ <- runFrame ctx (wheelX (-100)) (mkTabs 0)+      _ <- runFrame ctx inp (mkTabs 0)+      spans7 <- collectTextSpans ctx+      assert failed (hasText "Controls" spans7)+    _ -> assert failed False++  -- Tab-list changes recompute the reachable range: shrinking back under+  -- the width drops the scroller and both arrows; growing past it again+  -- re-engages them and re-clips the tail. (One header fits the 240-wide+  -- window; two would still overflow the ~180px viewport between arrows.)+  let shortLabels = ["Controls"]+      mkShort cur = tabBar cur [tab (i :: Int) l () | (i, l) <- zip [0 ..] shortLabels]+  _ <- runFrame ctx inp (mkShort 0)+  _ <- runFrame ctx inp (mkShort 0)+  _ <- runFrame ctx inp (mkShort 0)+  spansS <- collectTextSpans ctx+  forM_ shortLabels $ \l -> assert failed (hasText l spansS)+  mRightS <- arrowRect ctx '\8250'+  mLeftS <- arrowRect ctx '\8249'+  assert failed (null mRightS && null mLeftS)+  _ <- runFrame ctx inp (mkTabs 0)+  _ <- runFrame ctx inp (mkTabs 0)+  _ <- runFrame ctx inp (mkTabs 0)+  spansG <- collectTextSpans ctx+  mRightG <- arrowRect ctx '\8250'+  assert failed (not (null mRightG))+  assert failed (not (hasText "LongestTabName" spansG))
+ test/integration/Cases/TextInput.hs view
@@ -0,0 +1,1188 @@+module Cases.TextInput+  ( runTextInputClickSelectTest+  , runTextInputClipboardTest+  , runTextInputPasswordTest+  , runTextInputCursorTest+  , runTextAreaCutClearsSelectionTest+  , runTextInputCutClearsSelectionTest+  , runTextInputDirtyTest+  , runTextInputFocusSdlTest+  , runTextInputMenuTest+  , runTextInputMouseSelectionTest+  , runTextInputSelectionTest+  , runTextInputFfCaretTest+  , runTextInputScrollTest+  , runTextInputWordKeysTest+  , runTextInputBatchTest+  , runTextUndoTest+  , runTextAreaWidthTrackingTest+  , runTextAreaScrollWheelTest+  , runTextAreaZoomScrollTest+  , runTextAreaScrollDragTest+  , runTextAreaCursorOnScrollBarTest+  , runTextAreaHScrollWheelTest+  , runTextAreaHScrollDragTest+  , runTextArea2DScrollTest+  , runTextAreaScrollCursorLeavesViewportTest+  , runRefreshRedrawTest+  , runTextAreaMenuPulseTest+  , runTextCommandFocusTest+  , runTextAreaRemountScrollTest+  )+where++import Control.Monad (forM_, replicateM, replicateM_, when)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Text qualified as T+import NanoUI+import NanoUI.Context (intKey)+import NanoUI.Frame.TextEdit+  ( TextAreaHit (..)+  , TextAreaScrollBarLayouts (..)+  , resolveTextAreaFont+  , textAreaContentMetrics+  , textAreaBarLane+  , textAreaLineHeight+  , textAreaHScrollBarLayout+  , textAreaHitForWidget+  , textAreaScrollBarLayout+  , textAreaScrollBarLayouts+  )+import NanoUI.Store+  ( WidgetStore (..)+  , Slot (..)+  , slotKey+  )+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt, withInput)+import NanoUI.Testing.Harness+  ( assertSpansHas+  , centerOf+  , clickPair+  , held+  , keyInp+  , spanCenter+  , tabInp+  , warmup2+  )+import NanoUI.Widgets.TextArea+  ( buffer+  , loadTextAreaState+  , selectionAnchor+  )+import NanoUI.Widgets.TextBuffer+  ( fromText+  , getCursor+  , toLines+  , toText+  )++runTextInputBatchTest :: Context -> IORef Int -> IO ()+runTextInputBatchTest ctx failed = do+  let+    inp = withInput 320 120+    ui = column (textInput' "aOLDz")+    left = keyInp KeyLeft inp+    step event = runFrame ctx event ui+  (resp, _) <- warmup2 ctx inp ui+  _ <- step (tabInp inp)+  _ <- step left+  replicateM_ 3 (step (left {inputModifiers = Modifiers True False False}))+  let+    checkSelection cursor anchor = do+      store <- getStore ctx+      let+        key = intKey (respId resp)+      assertEq+        failed+        (IM.lookup (slotKey SlotCursor key) (storeInt store))+        (Just cursor)+      assertEq+        failed+        (IM.lookup (slotKey SlotAnchor key) (storeInt store))+        (Just anchor)+  checkSelection 1 4+  -- An event filtered to nothing must not delete the current selection.+  ((_, unchanged), _, _, _) <- step (inp {inputChars = "\n\t"})+  assertEq failed unchanged "aOLDz"+  checkSelection 1 4+  -- Navigation follows text insertion within a frame.+  ((_, committed), _, _, _) <- step (left {inputChars = "é\n世界\t"})+  assertEq failed committed "aé世界z"+  checkSelection 3 3++-- | Caption-less text area with a separate label above it (the old labelled+-- field kept the label span and geometry the tests assert against).+labeledArea :: T.Text -> T.Text -> NanoUI (Response, T.Text)+labeledArea lbl initial = do+  label lbl+  textArea' initial++labeledInput :: Ui :> es => T.Text -> T.Text -> Eff es (Response, T.Text)+labeledInput lbl initial = do+  label lbl+  textInputConfigured' defaultTextInputConfig {ticPlaceholder = "Enter " <> lbl} initial++runTextInputCursorTest :: Context -> IORef Int -> IO ()+runTextInputCursorTest ctx failed = do+  let+    inp0 = withInput 320 120+    ui = column (labeledInput "Name" "")+  _ <- warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  let+    labelPos =+      [ (rectX r + rectW r / 2, rectY r + 0.5)+      | (r, txt, _, _, _) <- spans+      , txt == "Name"+      ]+    fieldPos =+      [ (rectX r + rectW r / 2, rectY r + 0.5)+      | (r, txt, _, _, _) <- spans+      , "Enter" `T.isInfixOf` txt+      ]+  case (labelPos, fieldPos) of+    ([(lx, ly)], [(fx, fy)]) -> do+      let+        labelHover = inp0 {inputMousePos = V2 lx ly}+      _ <- runFrame ctx labelHover ui+      labelKind <- uiCursorKind ctx labelHover+      assertEq failed labelKind UiCursorDefault+      let+        fieldHover = inp0 {inputMousePos = V2 fx fy}+      _ <- runFrame ctx fieldHover ui+      fieldKind <- uiCursorKind ctx fieldHover+      assertEq failed fieldKind UiCursorText+      let+        click =+          fieldHover+            { inputMouseDown = True+            , inputMousePressed = True+            , inputMouseReleased = False+            }+      _ <- runFrame ctx click ui+      clickKind <- uiCursorKind ctx click+      assertEq failed clickKind UiCursorText+    _ -> assert failed False++runTextInputCutClearsSelectionTest :: Context -> IORef Int -> IO ()+runTextInputCutClearsSelectionTest ctx failed = do+  textRef <- newIORef "hello"+  (ctx', clipRef) <- memoryClipboard Nothing ctx+  let+    inp0 = withInput 320 120+    ui = column (held textRef textInput')+  _ <- warmup2 ctx' inp0 ui+  _ <- runFrame ctx' (tabInp inp0) ui+  let+    shiftLeft =+      inp0+        { inputKeys = inputKeysFromList [KeyLeft]+        , inputModifiers = Modifiers True False False+        }+  _ <- runFrame ctx' shiftLeft ui+  _ <-+    runFrame+      ctx'+      (inp0 {inputChars = "x", inputModifiers = Modifiers False True False})+      ui+  clip <- readIORef clipRef+  assertEq failed clip (Just "o")+  ((_, val), _, _, _) <- runFrame ctx' (inp0 {inputChars = "z"}) ui+  assertEq failed val "hellz"++-- Word-wise editing keys (Ctrl or Alt + Backspace/Delete/Left/Right) work in+-- the single-line text input like they do in the text area.+runTextInputWordKeysTest :: Context -> IORef Int -> IO ()+runTextInputWordKeysTest ctx failed = do+  textRef <- newIORef "hello world"+  let+    inp0 = withInput 320 120+    ui = column (held textRef textInput')+    ctrlMods = Modifiers False True False+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  -- Ctrl+Backspace deletes the word before the cursor ("world").+  _ <-+    runFrame+      ctx+      (inp0 {inputKeys = inputKeysFromList [KeyBackspace], inputModifiers = ctrlMods})+      ui+  ((_, v1), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed v1 "hello "+  -- Nothing right of the cursor at end of text: Ctrl+Delete is a no-op.+  _ <-+    runFrame+      ctx+      (inp0 {inputKeys = inputKeysFromList [KeyDelete], inputModifiers = ctrlMods})+      ui+  ((_, v2), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed v2 "hello "+  -- Ctrl+Left jumps to the start; typing there proves the cursor moved.+  _ <-+    runFrame+      ctx+      (inp0 {inputKeys = inputKeysFromList [KeyLeft], inputModifiers = ctrlMods})+      ui+  ((_, v3), _, _, _) <- runFrame ctx (inp0 {inputChars = "X"}) ui+  assertEq failed v3 "Xhello "+  -- Ctrl+Delete removes the word after the cursor ("hello").+  _ <-+    runFrame+      ctx+      (inp0 {inputKeys = inputKeysFromList [KeyDelete], inputModifiers = ctrlMods})+      ui+  ((_, v4), _, _, _) <- runFrame ctx inp0 ui+  assertEq failed v4 "X "++runTextAreaCutClearsSelectionTest :: Context -> IORef Int -> IO ()+runTextAreaCutClearsSelectionTest ctx failed = do+  (ctx', clipRef) <- memoryClipboard Nothing ctx+  textRef <- newIORef "hello"+  let+    inp0 = withInput 320 220+    ui = column (label "Notes" >> held textRef textArea')+  _ <- warmup2 ctx' inp0 ui+  _ <- runFrame ctx' (tabInp inp0) ui+  _ <-+    runFrame+      ctx'+      (inp0 {inputChars = "\x01", inputModifiers = Modifiers False True False})+      ui+  ((_, cutVal), _, _, _) <-+    runFrame+      ctx'+      (inp0 {inputChars = "x", inputModifiers = Modifiers False True False})+      ui+  clip <- readIORef clipRef+  assertEq failed clip (Just "hello")+  assertEq failed cutVal ""+  ((_, val), _, _, _) <- runFrame ctx' (inp0 {inputChars = "z"}) ui+  assertEq failed val "z"++runTextInputSelectionTest :: Context -> IORef Int -> IO ()+runTextInputSelectionTest ctx failed = do+  textRef <- newIORef "hello"+  let+    inp0 = withInput 320 120+    ui = column (button "Other" >> held textRef textInput')+  _ <- warmup2 ctx inp0 ui+  _ <- runFrame ctx (tabInp inp0) ui+  _ <- runFrame ctx (tabInp inp0) ui+  let+    shiftLeft =+      inp0+        { inputKeys = inputKeysFromList [KeyLeft]+        , inputModifiers = Modifiers True False False+        }+  _ <- warmup2 ctx shiftLeft ui+  ((_, valReplace), _, _, _) <- runFrame ctx (inp0 {inputChars = "X"}) ui+  assertEq failed valReplace "helX"+  -- Ctrl+A selects all whether it arrives as 'a' or as the \x01 control char.+  forM_ ["\x01", "a"] $ \selectAll -> do+    _ <- runFrame ctx (inp0 {inputChars = "abc"}) ui+    _ <-+      runFrame+        ctx+        (inp0 {inputChars = selectAll, inputModifiers = Modifiers False True False})+        ui+    ((_, valClear), _, _, _) <-+      runFrame ctx (keyInp KeyBackspace inp0) ui+    assertEq failed valClear ""++runTextInputMouseSelectionTest :: Context -> IORef Int -> IO ()+runTextInputMouseSelectionTest ctx failed = do+  let+    inp0 = withInput 320 120+    ui = column (textInput' "hello")+  _ <- warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans, txt == "hello"] of+    (Rect fx fy fw fh : _) -> do+      let+        fieldY = fy + fh / 2+      _ <-+        runFrame+          ctx+          ( inp0+              { inputMousePos = V2 (fx + 1) fieldY+              , inputMouseDown = True+              , inputMousePressed = True+              }+          )+          ui+      _ <-+        runFrame+          ctx+          (inp0 {inputMousePos = V2 (fx + fw - 1) fieldY, inputMouseDown = True})+          ui+      _ <-+        runFrame+          ctx+          ( inp0+              { inputMousePos = V2 (fx + fw - 1) fieldY+              , inputMouseDown = False+              , inputMouseReleased = True+              }+          )+          ui+      ((_, val), _, _, _) <- runFrame ctx (inp0 {inputChars = "z"}) ui+      assertEq failed val "z"+    _ -> assert failed False++-- Double-click selects a word and triple-click the whole line.+runTextInputClickSelectTest :: Context -> IORef Int -> IO ()+runTextInputClickSelectTest ctx failed = do+  allCtx <- newContext+  let+    inp0 = withInput 320 120+    -- Click n times at the start of the field showing txt, then Backspace.+    clicksThenBackspace c txt n = do+      let+        ui = column (textInput' txt)+      _ <- warmup2 c inp0 ui+      spans <- collectTextSpans c+      case [r | (r, t, _, _, _) <- spans, t == txt] of+        (Rect fx fy _ fh : _) -> do+          let+            pos = V2 (fx + 1) (fy + fh / 2)+          forM_ [1 .. n] $ \k ->+            runFrame+              c+              ( inp0+                  { inputMousePos = pos+                  , inputMouseDown = True+                  , inputMousePressed = True+                  , inputMouseClicks = k+                  }+              )+              ui+          ((_, val), _, _, _) <-+            runFrame c (keyInp KeyBackspace inp0) ui+          pure (Just val)+        _ -> pure Nothing+  word <- clicksThenBackspace ctx "hello world" 2+  assertEq failed word (Just " world")+  line <- clicksThenBackspace allCtx "hello" 3+  assertEq failed line (Just "")++runTextInputClipboardTest :: Context -> IORef Int -> IO ()+runTextInputClipboardTest ctx failed = do+  textRef <- newIORef "hello"+  (ctx', clipRef) <- memoryClipboard Nothing ctx+  let+    inp0 = withInput 320 120+    ui = column (held textRef textInput')+  _ <- warmup2 ctx' inp0 ui+  _ <- runFrame ctx' (tabInp inp0) ui+  let+    selectAll = inp0 {inputChars = "a", inputModifiers = Modifiers False True False}+    copy = inp0 {inputChars = "c", inputModifiers = Modifiers False True False}+    clear = keyInp KeyBackspace inp0+    paste = inp0 {inputChars = "v", inputModifiers = Modifiers False True False}+  _ <- runFrame ctx' selectAll ui+  _ <- runFrame ctx' copy ui+  clip <- readIORef clipRef+  assertEq failed clip (Just "hello")+  _ <- runFrame ctx' selectAll ui >> runFrame ctx' clear ui+  ((_, val), _, _, _) <- runFrame ctx' paste ui+  assertEq failed val "hello"++-- A password field displays one mask character per character, and Ctrl+C+-- leaves the clipboard untouched while the field keeps its real value.+runTextInputPasswordTest :: Context -> IORef Int -> IO ()+runTextInputPasswordTest ctx failed = do+  (ctx', clipRef) <- memoryClipboard Nothing ctx+  let+    inp0 = withInput 320 120+    ui = column (textInputConfigured' defaultTextInputConfig {ticPassword = True} "hunter2")+  _ <- warmup2 ctx' inp0 ui+  spans <- collectTextSpans ctx'+  assert failed (not (any (\(_, txt, _, _, _) -> "hunter2" `T.isInfixOf` txt) spans))+  assertSpansHas failed "*******" spans+  _ <- runFrame ctx' (tabInp inp0) ui+  let+    selectAll = inp0 {inputChars = "a", inputModifiers = Modifiers False True False}+    copy = inp0 {inputChars = "c", inputModifiers = Modifiers False True False}+  _ <- runFrame ctx' selectAll ui+  ((_, val), _, _, _) <- runFrame ctx' copy ui+  clip <- readIORef clipRef+  assertEq failed clip Nothing+  assertEq failed val "hunter2"++-- The text input's context menu offers Paste even while unfocused, and its+-- Paste and Cut entries edit the field through the clipboard. The menu edits+-- the field between frames, so each edit must survive the caller passing back+-- the result of the frame before it.+runTextInputMenuTest :: Context -> IORef Int -> IO ()+runTextInputMenuTest ctx failed = do+  textRef <- newIORef "hello"+  (ctx', clipRef) <- memoryClipboard (Just "pasted") ctx+  let+    inp0 = withInput 320 160+    ui = column (held textRef textInput')+  _ <- warmup2 ctx' inp0 ui+  spans <- collectTextSpans ctx'+  case [r | (r, txt, _, _, _) <- spans, txt == "hello"] of+    (Rect fx fy _ fh : _) -> do+      let+        menuOpen =+          inp0+            { inputMousePos = V2 (fx + 1) (fy + fh / 2)+            , inputMouseRightDown = True+            , inputMouseRightPressed = True+            }+        pick entry = do+          _ <- runFrame ctx' menuOpen ui+          overlays <- collectOverlayTextSpans ctx' menuOpen+          case [r | (r, txt, _, _, _) <- overlays, txt == entry] of+            (r : _) -> do+              let+                (pickPress, pickRelease) = clickPair inp0 (spanCenter r)+              _ <- runFrame ctx' pickPress ui >> runFrame ctx' pickRelease ui+              ((_, val), _, _, _) <- runFrame ctx' inp0 ui+              pure (Just val)+            _ -> pure Nothing+      pasted <- pick "Paste"+      assertEq failed pasted (Just "hellopasted")+      cut <- pick "Cut"+      clip <- readIORef clipRef+      assertEq failed clip (Just "hellopasted")+      assertEq failed cut (Just "")+      overlaysAfter <- collectOverlayTextSpans ctx' inp0+      assert failed (not (any (\(_, txt, _, _, _) -> txt == "Cut") overlaysAfter))+    _ -> assert failed False++runTextInputFocusSdlTest :: Context -> IORef Int -> IO ()+runTextInputFocusSdlTest ctx failed = do+  let+    inp0 = withInput 320 120+    ui = column (labeledInput "Name" "")+  (resp, _) <- warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  case [ (rectX r + rectW r / 2, rectY r + 0.5)+       | (r, txt, _, _, _) <- spans+       , "Enter" `T.isInfixOf` txt+       ] of+    [(fx, fy)] -> do+      let+        inp1 =+          inp0 {inputMousePos = V2 fx fy, inputMouseDown = True, inputMousePressed = True}+      _ <- runFrame ctx inp1 ui+      focus <- getFocusId ctx+      assertEq failed focus (respId resp)+      let+        idle = inp0 {inputMousePos = V2 fx fy}+      samples <- replicateM 5 (runFrame ctx idle ui >> getFocusId ctx)+      assertEq failed samples (replicate 5 (respId resp))+    _ -> assert failed False++runTextInputDirtyTest :: Context -> IORef Int -> IO ()+runTextInputDirtyTest ctx failed = do+  let+    ui = column (textInput' "")+    inp0 = (withInput 200 100) {inputMousePos = V2 20 20}+  (resp, _) <- warmup2 ctx inp0 ui+  let+    Rect rx ry _ _ = respRect resp+    (press, release) = clickPair inp0 (V2 (rx + 1) (ry + 0.5))+  _ <- runFrame ctx press ui+  _ <- runFrame ctx release ui+  let+    idle = release {inputMouseReleased = False, inputDeltaTime = 1}+  _ <- runFrame ctx idle ui+  needFocus <- needsRedraw ctx idle idle+  assert failed needFocus++runTextInputFfCaretTest :: Context -> IORef Int -> IO ()+runTextInputFfCaretTest ctx failed = do+  let+    fm = ctxFontMetrics ctx+    fs = T.replicate 6 "f"+    adv = fmAdvance fm 'f'+  assertEq failed (lineWidth fm fs) (6 * adv)+  assertEq failed (textIndexAtX fm fs (lineWidth fm fs)) 6+  assertEq failed (textIndexAtX fm fs (lineWidth fm (T.take 3 fs))) 3+  let+    inp0 = withInput 320 120+    ui = column (textInput' fs)+  _ <- warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  assertSpansHas failed fs spans+  case [r | (r, txt, _, _, _) <- spans, txt == fs] of+    (Rect fx fy _ fh : _) -> do+      let+        pos = V2 (fx + lineWidth fm (T.take 3 fs)) (fy + fh / 2)+        (press, release) = clickPair inp0 pos+      _ <- runFrame ctx press ui+      _ <- runFrame ctx release ui+      ((_, val), _, _, _) <-+        runFrame ctx (inp0 {inputMousePos = pos, inputChars = "x"}) ui+      assertEq failed val "fffxfff"+    _ -> assert failed False++runTextInputScrollTest :: Context -> IORef Int -> IO ()+runTextInputScrollTest ctx failed = do+  let+    longText = "VeryLongTextEnteredIntoTheFieldThatExceedsTheWidth"+    inp0 = withInput 200 120+    ui = column (textInput' longText)+  (resp, _) <- warmup2 ctx inp0 ui+  spans0 <- collectTextSpans ctx+  case [r | (r, txt, _, _, _) <- spans0, txt == longText] of+    (Rect fx fy _ fh : _) -> do+      let+        pos = V2 (fx + 50) (fy + fh / 2)+        (press, release) = clickPair inp0 pos+      _ <- runFrame ctx press ui+      _ <- runFrame ctx release ui+      let+        atEnd = keyInp KeyEnd inp0+      _ <- runFrame ctx atEnd ui+      store <- getStore ctx+      let+        key = intKey (respId resp)+        scrollEnd = IM.findWithDefault 0 (slotKey SlotTextInputScroll key) (storeFloat store)+      assert failed (scrollEnd > 0)+      let+        atHome = keyInp KeyHome inp0+      _ <- runFrame ctx atHome ui+      storeHome <- getStore ctx+      let+        scrollHome = IM.findWithDefault 0 (slotKey SlotTextInputScroll key) (storeFloat storeHome)+      assertEq failed scrollHome 0+    _ -> assert failed False++runTextAreaScrollWheelTest :: Context -> IORef Int -> IO ()+runTextAreaScrollWheelTest ctx failed = do+  let+    longText = T.unlines ["Line " <> T.pack (show (i :: Int)) | i <- [1 .. 40]]+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" longText)+    uiShort = column (keyed (1 :: Int) (labeledArea "Short" "Line 1\nLine 2"))+    fieldCenter = pure . spanCenter+  -- Text that fits the viewport does not wheel-scroll.+  (respShort, _) <- warmup2 ctx inp0 uiShort+  mRectShort <- getPrevRect ctx (respId respShort)+  case mRectShort of+    Just r -> do+      pos <- fieldCenter r+      _ <- runFrame ctx (inp0 {inputMousePos = pos, inputScroll = V2 0 1}) uiShort+      offShort <- getScrollOffset ctx (respId respShort)+      assertEq failed offShort 0+    _ -> assert failed False+  (resp, _) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx (respId resp)+  case mRect of+    Just r -> do+      pos <- fieldCenter r+      let+        wheelDown = inp0 {inputMousePos = pos, inputScroll = V2 0 1}+      off0 <- getScrollOffset ctx (respId resp)+      assertEq failed off0 0+      -- Scroll down 1 notch+      _ <- runFrame ctx wheelDown ui+      off1 <- getScrollOffset ctx (respId resp)+      assertGt failed off1 off0+      -- Scroll down 3 more notches+      let+        wheelDownMore = inp0 {inputMousePos = pos, inputScroll = V2 0 3}+      _ <- runFrame ctx wheelDownMore ui+      off2 <- getScrollOffset ctx (respId resp)+      assertGt failed off2 off1+      -- Scroll up beyond top to check clamping to 0+      let+        wheelUp = inp0 {inputMousePos = pos, inputScroll = V2 0 (-10)}+      _ <- runFrame ctx wheelUp ui+      off3 <- getScrollOffset ctx (respId resp)+      assertEq failed off3 0+      -- Text buffer should remain completely unmodified+      store <- getStore ctx+      let+        key = intKey (respId resp)+        st = loadTextAreaState store key longText+      assertEq failed (toText (buffer st)) longText+    _ -> assert failed False++runTextAreaZoomScrollTest :: Context -> IORef Int -> IO ()+runTextAreaZoomScrollTest ctx failed = do+  let+    longText = T.unlines ["Line " <> T.pack (show (i :: Int)) | i <- [1 .. 40]]+    inp0 = withInput 320 220+    ui = column $ textAreaWith' (fontSize 32) longText+  (resp, _) <- warmup2 ctx inp0 ui+  mHit <- textAreaHitForWidget ctx (respId resp)+  case mHit of+    Nothing -> assert failed False+    Just hit -> do+      fm <- resolveTextAreaFont ctx (tahNodeIdx hit)+      let+        field = tahFieldRect hit+        lineH = tahLineH hit+        lineCount = max 1 (length (toLines (fromText longText)))+        contentH = fromIntegral lineCount * lineH+        contentW = maximum (0 : [lineWidth fm l | l <- T.lines longText])+        (ix, iy) = widgetContentInset fm+        innerW = rectW field - 2 * ix+        innerH = rectH field - 2 * iy+        barLaneW = textAreaBarLane+        barLaneH = textAreaBarLane+        hasV0 = contentH > innerH+        hasH = contentW > (if hasV0 then max 0 (innerW - barLaneW) else innerW)+        availH = if hasH then max 0 (innerH - barLaneH) else innerH+        expectedMaxY = max 0 (contentH - availH)+        pos = V2 (rectX field + rectW field / 2) (rectY field + rectH field / 2)+        wheelDown = inp0 {inputMousePos = pos, inputScroll = V2 0 100}+      _ <- runFrame ctx wheelDown ui+      off <- getScrollOffset ctx (respId resp)+      assert failed (abs (off - expectedMaxY) < 0.5)++runTextAreaScrollDragTest :: Context -> IORef Int -> IO ()+runTextAreaScrollDragTest ctx failed = do+  let+    longText = T.unlines ["Line " <> T.pack (show (i :: Int)) | i <- [1 .. 40]]+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" longText)+  (resp, _) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx (respId resp)+  case mRect of+    Just (Rect rx ry rw rh) -> do+      let+        fm = ctxFontMetrics ctx+        field = Rect rx ry rw rh+        contentH = 40 * textAreaLineHeight fm+      off0 <- getScrollOffset ctx (respId resp)+      assertEq failed off0 0+      case textAreaScrollBarLayout fm field contentH off0 of+        Nothing -> assert failed False+        Just layout -> do+          let+            thumb = sbThumb layout+            thumbCenter = V2 (rectX thumb + rectW thumb / 2) (rectY thumb + rectH thumb / 2)+            press =+              inp0+                { inputMousePos = thumbCenter+                , inputMouseDown = True+                , inputMousePressed = True+                }+          _ <- runFrame ctx press ui+          -- Drag the thumb down by 30 pixels+          let+            drag =+              press+                { inputMousePressed = False+                , inputMousePos = V2 (v2X thumbCenter) (v2Y thumbCenter + 30)+                }+          _ <- runFrame ctx drag ui+          off1 <- getScrollOffset ctx (respId resp)+          assertGt failed off1 off0+          -- Release the mouse+          let+            release = drag {inputMouseDown = False, inputMouseReleased = True}+          _ <- runFrame ctx release ui+          -- Clicking/dragging scrollbar must not initiate text selection or alter buffer+          store <- getStore ctx+          let+            key = intKey (respId resp)+            st = loadTextAreaState store key longText+          assertEq failed (toText (buffer st)) longText+          assert failed (selectionAnchor st == getCursor (buffer st))+    _ -> assert failed False++runTextAreaCursorOnScrollBarTest :: Context -> IORef Int -> IO ()+runTextAreaCursorOnScrollBarTest ctx failed = do+  let+    longText = T.unlines ["Line " <> T.pack (show (i :: Int)) | i <- [1 .. 40]]+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" longText)+  (resp, _) <- warmup2 ctx inp0 ui+  spans <- collectTextSpans ctx+  let+    labelPos =+      [ (rectX r + rectW r / 2, rectY r + 0.5)+      | (r, txt, _, _, _) <- spans+      , txt == "Notes"+      ]+  mRect <- getPrevRect ctx (respId resp)+  case (labelPos, mRect) of+    ([(lx, ly)], Just (Rect rx ry rw rh)) -> do+      let+        fm = ctxFontMetrics ctx+        field = Rect rx ry rw rh+        contentH = 40 * textAreaLineHeight fm+      -- Hover over label -> UiCursorDefault+      let+        labelHover = inp0 {inputMousePos = V2 lx ly}+      _ <- runFrame ctx labelHover ui+      labelKind <- uiCursorKind ctx labelHover+      assertEq failed labelKind UiCursorDefault++      -- Hover over text field area (left side) -> UiCursorText+      let+        textHover = inp0 {inputMousePos = V2 (rectX field + 20) (rectY field + 20)}+      _ <- runFrame ctx textHover ui+      textKind <- uiCursorKind ctx textHover+      assertEq failed textKind UiCursorText++      -- Hover over scrollbar thumb -> UiCursorGrab+      case textAreaScrollBarLayout fm field contentH 0 of+        Nothing -> assert failed False+        Just layout -> do+          let+            thumb = sbThumb layout+            thumbCenter = V2 (rectX thumb + rectW thumb / 2) (rectY thumb + rectH thumb / 2)+            thumbHover = inp0 {inputMousePos = thumbCenter}+          _ <- runFrame ctx thumbHover ui+          thumbKind <- uiCursorKind ctx thumbHover+          assertEq failed thumbKind UiCursorGrab++          -- Press down on scrollbar thumb -> UiCursorGrabbing+          let+            thumbPress = thumbHover {inputMouseDown = True, inputMousePressed = True}+          _ <- runFrame ctx thumbPress ui+          grabbing <- cursorKindIs ctx thumbPress UiCursorGrabbing+          assert failed grabbing+    _ -> assert failed False++runTextAreaHScrollWheelTest :: Context -> IORef Int -> IO ()+runTextAreaHScrollWheelTest ctx failed = do+  let+    longLine = T.replicate 15 "0123456789"+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" longLine)+  (resp, _) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx (respId resp)+  case mRect of+    Just (Rect rx ry rw rh) -> do+      let+        fm = ctxFontMetrics ctx+        field = Rect rx ry rw rh+        pos = V2 (rectX field + rectW field / 2) (rectY field + rectH field / 2)+        wheelRight = inp0 {inputMousePos = pos, inputScroll = V2 1 0}+      V2 offX0 offY0 <- getScrollOffset2D ctx (respId resp)+      assertEq failed offX0 0+      assertEq failed offY0 0+      _ <- runFrame ctx wheelRight ui+      V2 offX1 offY1 <- getScrollOffset2D ctx (respId resp)+      assertGt failed offX1 offX0+      assertEq failed offY1 0+      let+        wheelRightMore = inp0 {inputMousePos = pos, inputScroll = V2 3 0}+      _ <- runFrame ctx wheelRightMore ui+      V2 offX2 _ <- getScrollOffset2D ctx (respId resp)+      assertGt failed offX2 offX1+      -- A click in the scrolled text lands on the column under the pointer,+      -- counting the horizontal offset.+      let+        (ix, iy) = widgetContentInset fm+        clickX = 30+        textClick =+          inp0+            { inputMousePos = V2 (rectX field + ix + clickX) (rectY field + iy + 5)+            , inputMouseDown = True+            , inputMousePressed = True+            }+      _ <- runFrame ctx textClick ui+      _ <- runFrame ctx textClick {inputMouseDown = False, inputMousePressed = False, inputMouseReleased = True} ui+      store <- getStore ctx+      let+        key = intKey (respId resp)+        Cursor _ col = getCursor (buffer (loadTextAreaState store key longLine))+      assert failed (abs (fromIntegral col - (offX2 + clickX) / fmAdvance fm '0') <= 1)+      let+        wheelLeft = inp0 {inputMousePos = pos, inputScroll = V2 (-10) 0}+      _ <- runFrame ctx wheelLeft ui+      V2 offX3 _ <- getScrollOffset2D ctx (respId resp)+      assertEq failed offX3 0+      -- The horizontal thumb shows the grab cursors.+      case textAreaHScrollBarLayout fm field (lineWidth fm longLine) 0 of+        Nothing -> assert failed False+        Just layout -> do+          let+            thumb = sbThumb layout+            thumbHover = inp0 {inputMousePos = V2 (rectX thumb + rectW thumb / 2) (rectY thumb + rectH thumb / 2)}+          _ <- runFrame ctx thumbHover ui+          thumbKind <- uiCursorKind ctx thumbHover+          assertEq failed thumbKind UiCursorGrab+          let+            thumbPress = thumbHover {inputMouseDown = True, inputMousePressed = True}+          _ <- runFrame ctx thumbPress ui+          grabbing <- cursorKindIs ctx thumbPress UiCursorGrabbing+          assert failed grabbing+    _ -> assert failed False++runTextAreaHScrollDragTest :: Context -> IORef Int -> IO ()+runTextAreaHScrollDragTest ctx failed = do+  let+    longLine = T.replicate 15 "0123456789"+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" longLine)+  (resp, _) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx (respId resp)+  case mRect of+    Just (Rect rx ry rw rh) -> do+      let+        fm = ctxFontMetrics ctx+        field = Rect rx ry rw rh+        contentW = lineWidth fm longLine+      V2 offX0 _ <- getScrollOffset2D ctx (respId resp)+      assertEq failed offX0 0+      case textAreaHScrollBarLayout fm field contentW offX0 of+        Nothing -> assert failed False+        Just layout -> do+          let+            thumb = sbThumb layout+            thumbCenter = V2 (rectX thumb + rectW thumb / 2) (rectY thumb + rectH thumb / 2)+            press =+              inp0+                { inputMousePos = thumbCenter+                , inputMouseDown = True+                , inputMousePressed = True+                }+          _ <- runFrame ctx press ui+          let+            drag =+              press+                { inputMousePressed = False+                , inputMousePos = V2 (v2X thumbCenter + 30) (v2Y thumbCenter)+                }+          _ <- runFrame ctx drag ui+          V2 offX1 _ <- getScrollOffset2D ctx (respId resp)+          assertGt failed offX1 offX0+          let+            release = drag {inputMouseDown = False, inputMouseReleased = True}+          _ <- runFrame ctx release ui+          store <- getStore ctx+          let+            key = intKey (respId resp)+            st = loadTextAreaState store key longLine+          assertEq failed (toText (buffer st)) longLine+          assert failed (selectionAnchor st == getCursor (buffer st))+    _ -> assert failed False++runTextArea2DScrollTest :: Context -> IORef Int -> IO ()+runTextArea2DScrollTest ctx failed = do+  let+    lines2D =+      [ T.pack (show (i :: Int)) <> " - " <> T.replicate 10 "abcdefghij"+      | i <- [1 .. 40]+      ]+    text2D = T.unlines lines2D+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" text2D)+  (resp, _) <- warmup2 ctx inp0 ui+  mRect <- getPrevRect ctx (respId resp)+  case mRect of+    Just (Rect rx ry rw rh) -> do+      let+        fm = ctxFontMetrics ctx+        field = Rect rx ry rw rh+        contentH = 40 * textAreaLineHeight fm+        contentW = maximum (0 : [lineWidth fm l | l <- lines2D])+        barLaneW = textAreaBarLane+        barLaneH = textAreaBarLane+        layouts = textAreaScrollBarLayouts fm field contentW contentH 0 0+      case (tasbVertical layouts, tasbHorizontal layouts) of+        (Just vLayout, Just hLayout) -> do+          let+            vTrack = sbTrack vLayout+            hTrack = sbTrack hLayout+          assert+            failed+            (rectY vTrack + rectH vTrack <= rectY field + rectH field - barLaneH + 1)+          assert+            failed+            (rectX hTrack + rectW hTrack <= rectX field + rectW field - barLaneW + 1)+          let+            pos = V2 (rectX field + rectW field / 2) (rectY field + rectH field / 2)+            wheel2D = inp0 {inputMousePos = pos, inputScroll = V2 2 3}+          _ <- runFrame ctx wheel2D ui+          V2 offX offY <- getScrollOffset2D ctx (respId resp)+          assertGt failed offX 0+          assertGt failed offY 0+        _ -> assert failed False+    _ -> assert failed False++runTextAreaScrollCursorLeavesViewportTest :: Context -> IORef Int -> IO ()+runTextAreaScrollCursorLeavesViewportTest ctx failed = do+  let+    longText = T.unlines ["Line " <> T.pack (show (i :: Int)) | i <- [1 .. 40]]+    inp0 = withInput 320 220+    ui = column (labeledArea "Notes" longText)+  (resp, _) <- warmup2 ctx inp0 ui+  -- Focus the textarea via Tab+  _ <- runFrame ctx (tabInp inp0) ui+  mRect <- getPrevRect ctx (respId resp)+  case mRect of+    Just (Rect rx ry rw rh) -> do+      let+        field = Rect rx ry rw rh+        pos = V2 (rectX field + rectW field / 2) (rectY field + rectH field / 2)+        key = intKey (respId resp)++      -- Verify cursor is at top (line 0, col 0) and scroll is 0+      store0 <- getStore ctx+      let+        st0 = loadTextAreaState store0 key longText+        Cursor r0 c0 = getCursor (buffer st0)+      assertEq failed (r0, c0) (0, 0)+      off0 <- getScrollOffset ctx (respId resp)+      assertEq failed off0 0++      -- Scroll down while focused: caret stays at line 0, but viewport scrolls down+      let+        wheelDown = inp0 {inputMousePos = pos, inputScroll = V2 0 5}+      _ <- runFrame ctx wheelDown ui+      off1 <- getScrollOffset ctx (respId resp)+      assertGt failed off1 0++      -- Run an idle frame while textarea remains focused to ensure scroll offset does not snap back!+      _ <- runFrame ctx inp0 ui+      offIdle <- getScrollOffset ctx (respId resp)+      assertEq failed offIdle off1++      -- Verify caret in buffer is still at (0, 0) even though viewport scrolled down+      store1 <- getStore ctx+      let+        st1 = loadTextAreaState store1 key longText+        Cursor r1 c1 = getCursor (buffer st1)+      assertEq failed (r1, c1) (0, 0)++      -- Now send keyboard input: typing or navigating MUST bring the cursor back into view!+      let+        typeChar = inp0 {inputChars = "!"}+      _ <- runFrame ctx typeChar ui+      offAfterKey <- getScrollOffset ctx (respId resp)+      -- Cursor is at (0, 1), so ensureCaretVisible brings scroll offset back to 0+      assertEq failed offAfterKey 0+      store2 <- getStore ctx+      let+        st2 = loadTextAreaState store2 key longText+        Cursor r2 c2 = getCursor (buffer st2)+      assertEq failed (r2, c2) (0, 1)+    _ -> assert failed False++-- | A backend-requested redraw (expose/restore, dialog-completion wake) must+-- request a frame even though no user input changed. Regression: the file+-- dialog's completion wake was skipped, so the result waited for the next+-- unrelated event before it painted.+runRefreshRedrawTest :: Context -> IORef Int -> IO ()+runRefreshRedrawTest ctx failed = do+  let+    idle = emptyInput {inputWindowSize = Size 320 200}+    refreshed = idle {inputWindowRedraw = True}+  need <- needsRedraw ctx idle refreshed+  assert failed need++-- | A context-menu Cut/Paste edits the document without any keys or chars on+-- the frame, so the change must surface as a 'respChanged' pulse through the+-- text-area store flag, or callers (the notepad's dirty tracking) never learn+-- the document changed. Covers the hadInput guard in 'textAreaWith'. The+-- caller holds the text, so the cut must also survive the+-- release frame, where the caller still passes back the pre-cut result.+runTextAreaMenuPulseTest :: Context -> IORef Int -> IO ()+runTextAreaMenuPulseTest ctx failed = do+  textRef <- newIORef "abc"+  let+    inp0 = withInput 320 220+    ui = column (held textRef (textAreaWith' grow))+  (resp0, initial) <- warmup2 ctx inp0 ui+  assertEq failed initial "abc"+  mHit <- textAreaHitForWidget ctx (respId resp0)+  case mHit of+    Nothing -> assert failed False+    Just hit -> do+      let+        field = tahFieldRect hit+        mid = V2 (rectX field + rectW field / 2) (rectY field + rectH field / 2)+      -- Focus the editor, as a menu pick would.+      let+        (focusPress, focusRelease) = clickPair inp0 mid+      _ <- runFrame ctx focusPress ui >> runFrame ctx focusRelease ui+      -- Selection-only actions do not pulse: no text delta.+      _ <- runFrame ctx inp0 (runTextCommand (respId resp0) SelectAll)+      ((respSel, valSel), _, _, _) <- runFrame ctx inp0 ui+      assert failed (not (respChanged respSel))+      assertEq failed valSel "abc"+      let+        menuOpen =+          inp0+            { inputMousePos = mid+            , inputMouseRightDown = True+            , inputMouseRightPressed = True+            }+      _ <- runFrame ctx menuOpen ui+      overlays <- collectOverlayTextSpans ctx menuOpen+      case [r | (r, txt, _, _, _) <- overlays, txt == "Cut"] of+        (r : _) -> do+          -- The Cut runs through the field's command path on the press+          -- frame; the very next frame (release) must deliver the pulse and+          -- the emptied text, then go quiet again.+          let+            (pickPress, pickRelease) = clickPair inp0 (spanCenter r)+          _ <- runFrame ctx pickPress ui+          ((resp, val), _, _, _) <- runFrame ctx pickRelease ui+          assert failed (respChanged resp)+          assertEq failed val ""+          ((respIdle, valIdle), _, _, _) <- runFrame ctx inp0 ui+          assert failed (not (respChanged respIdle))+          assertEq failed valIdle ""+        _ -> assert failed False++-- | A command run from a button elsewhere (an app's Edit menu) focuses the+-- field it edits, so Select All followed by typing replaces the text.+-- Regression: the press on the button cleared focus and 'runTextCommand' no+-- longer restored it, so the typing went nowhere.+runTextCommandFocusTest :: Context -> IORef Int -> IO ()+runTextCommandFocusTest ctx failed = do+  ref <- newIORef "abc"+  let+    inp = withInput 320 220+    ui = column $ do+      (area, _) <- held ref (textAreaWith' (fixedH 80))+      selectAll <- button' "Select All"+      when (respClicked selectAll) (runTextCommand (respId area) SelectAll)+      pure selectAll+  selectAll <- warmup2 ctx inp ui+  let+    (press, release) = clickPair inp (centerOf selectAll)+  mapM_ (\i -> runFrame ctx i ui) [press, release, inp, inp {inputChars = "Z"}, inp]+  assertEq failed "Z" =<< readIORef ref++-- | After the editor is remounted under a new key (the notepad remounts on file+-- load), wheel-on-hover with no focus must still scroll. Regression: the+-- remounted editor could not be scrolled until it was focused.+runTextAreaRemountScrollTest :: Context -> IORef Int -> IO ()+runTextAreaRemountScrollTest ctx failed = do+  let+    longText = T.unlines ["Line " <> T.pack (show (i :: Int)) | i <- [1 .. 40]]+    inp0 = withInput 320 220+    mkUi k = column $ keyed k $ textAreaWith' grow longText+  _ <- warmup2 ctx inp0 (mkUi (1 :: Int))+  (resp, _) <- warmup2 ctx inp0 (mkUi (2 :: Int))+  mHit <- textAreaHitForWidget ctx (respId resp)+  case mHit of+    Nothing -> assert failed False+    Just hit -> do+      let+        field = tahFieldRect hit+        pos = V2 (rectX field + rectW field / 2) (rectY field + rectH field / 2)+        -- Large delta so hover animations settle within the warm-up frames+        -- and the idle frame below reports no damage of its own.+        settleDt = 1.0+        hover = inp0 {inputMousePos = pos, inputDeltaTime = settleDt}+        warmupFrames = 4 :: Int+      -- Park the pointer over the editor first, so the wheel frame does not+      -- also change the hot widget (whose damage would mask a missing scroll+      -- repaint).+      replicateM_ warmupFrames (runFrame ctx hover (mkUi (2 :: Int)))+      dmgIdle <- takeDamage ctx+      assert failed (damageIsEmpty dmgIdle)+      off0 <- getScrollOffset ctx (respId resp)+      _ <- runFrame ctx hover {inputScroll = V2 0 1} (mkUi (2 :: Int))+      off1 <- getScrollOffset ctx (respId resp)+      assertGt failed off1 off0+      -- The scroll offset must also damage the editor, or nothing repaints.+      dmg <- takeDamage ctx+      assert failed (not (damageIsEmpty dmg))++-- | Ctrl+Z and Ctrl+Shift+Z undo and redo typing in a field; commands run from+-- outside the frame edit it and pulse 'respChanged'; replacing the value the+-- field is passed clears its history.+runTextUndoTest :: Context -> IORef Int -> IO ()+runTextUndoTest ctx failed = do+  ref <- newIORef ""+  commands <- newIORef []+  let+    inp = withInput 320 120+    -- Commands queued by the test run after the field, as an app's menu+    -- would; the field's undo state is read the same way.+    ui = column $ do+      (resp, _) <- held ref textInput'+      pending <- uiIO (readIORef commands)+      uiIO (writeIORef commands [])+      mapM_ (runTextCommand (respId resp)) pending+      (,) resp <$> textCanUndo (respId resp)+    ctrl = Modifiers False True False+    ctrlShift = Modifiers True True False+    frame i = (\(a, _, _, _) -> a) <$> runFrame ctx i ui+  _ <- warmup2 ctx inp ui+  _ <- frame (tabInp inp)+  mapM_ (\c -> frame inp {inputChars = T.singleton c}) ("red fox" :: String)+  assertEq failed "red fox" =<< readIORef ref+  (_, canUndo) <- frame inp+  assert failed canUndo+  _ <- frame inp {inputChars = "z", inputModifiers = ctrl}+  assertEq failed "red " =<< readIORef ref+  _ <- frame inp {inputChars = "z", inputModifiers = ctrl}+  assertEq failed "" =<< readIORef ref+  _ <- frame inp {inputChars = "z", inputModifiers = ctrlShift}+  assertEq failed "red " =<< readIORef ref+  _ <- frame inp {inputChars = "y", inputModifiers = ctrl}+  assertEq failed "red fox" =<< readIORef ref+  -- A command from outside the field's frame edits it and pulses it once.+  writeIORef commands [InsertText "!"]+  _ <- frame inp+  (pulsed, _) <- frame inp+  assert failed (respChanged pulsed)+  assertEq failed "red fox!" =<< readIORef ref+  (quiet, _) <- frame inp+  assert failed (not (respChanged quiet))+  writeIORef commands [Undo]+  _ <- frame inp+  _ <- frame inp+  assertEq failed "red fox" =<< readIORef ref+  -- The caller replacing the value drops the history recorded against the+  -- old text.+  writeIORef ref "something else"+  _ <- frame inp+  (_, stillUndoable) <- frame inp+  assert failed (not stillUndoable)++-- | The content width a text area keeps up to date line by line matches a+-- fresh measurement after edits that widen, move and shorten its widest line.+runTextAreaWidthTrackingTest :: Context -> IORef Int -> IO ()+runTextAreaWidthTrackingTest ctx failed = do+  ref <- newIORef (T.intercalate "\n" (replicate 200 "short line" ++ ["the widest line of them all"] ++ replicate 200 "short line"))+  let+    inp = withInput 400 300+    ui = column (held ref (textAreaWith' grow))+    frame i = (\(a, _, _, _) -> a) <$> runFrame ctx i ui+    ctrl = Modifiers False True False+    check = do+      (resp, _) <- frame inp+      mHit <- textAreaHitForWidget ctx (respId resp)+      case mHit of+        Nothing -> assert failed False+        Just hit -> do+          (tracked, _) <- textAreaContentMetrics ctx (tahNodeIdx hit)+          text <- readIORef ref+          fm <- resolveTextAreaFont ctx (tahNodeIdx hit)+          widths <- mapM (lineWidthIO fm) (T.splitOn "\n" text)+          assertEq failed (maximum widths) tracked+  _ <- warmup2 ctx inp ui+  _ <- frame (tabInp inp)+  check+  -- Widen a short line past the widest.+  mapM_ (\_ -> frame (keyInp KeyDown inp)) [1 .. 10 :: Int]+  mapM_ (\c -> frame inp {inputChars = T.singleton c}) (replicate 40 'x')+  check+  -- Shorten it again, so the old widest line wins.+  mapM_ (\_ -> frame (keyInp KeyBackspace inp)) [1 .. 40 :: Int]+  check+  -- Delete the widest line itself.+  mapM_ (\_ -> frame (keyInp KeyDown inp)) [1 .. 190 :: Int]+  _ <- frame inp {inputKeys = inputKeysFromList [KeyHome, KeyEnd], inputModifiers = Modifiers True False False}+  _ <- frame (keyInp KeyBackspace inp)+  check+  -- Undo brings it back.+  _ <- frame inp {inputChars = "z", inputModifiers = ctrl}+  check++-- | The context with a clipboard kept in memory, starting with @initial@, and+-- a reference to its contents.+memoryClipboard :: Maybe T.Text -> Context -> IO (Context, IORef (Maybe T.Text))+memoryClipboard initial ctx = do+  clipRef <- newIORef initial+  pure (withClipboard ctx (readIORef clipRef) (\s -> writeIORef clipRef (Just s) >> pure True), clipRef)
+ test/integration/Cases/Tooltip.hs view
@@ -0,0 +1,113 @@+module Cases.Tooltip+  ( runTooltipHoverTest+  , runTooltipIdStableTest+  , runTooltipScrollPosTest+  ) where++import Control.Monad (void)+import Data.IORef (IORef)+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, evalUi, withInput)+import NanoUI.Testing.Harness+  ( centerOf+  , hasText+  , spanCenter+  , warmup2+  )++-- Hovering shows a text tooltip, and a widget tooltip only evaluates its body+-- while hovered.+runTooltipHoverTest :: Context -> IORef Int -> IO ()+runTooltipHoverTest ctx failed = do+  let inp0 = withInput 640 480+      ui = rowWith fillW $ do+        help <- button' "Help Target"+        tooltip help "Helpful advice here"+        _ <- spacer (Grow 1) Fit+        rich <- button' "Rich Info"+        body <- tooltipWidget rich $ do+          row $ do+            void (label "[Icon]")+            label "Rich tooltip body text"+        pure (help, rich, body)++  -- Unhovered: no tooltip overlay, and the widget body is not evaluated+  (help, rich, body0) <- warmup2 ctx inp0 ui+  spans0 <- collectOverlayTextSpans ctx inp0+  assert failed (not (hasText "Helpful advice" spans0))+  assert failed (case body0 of Nothing -> True; _ -> False)++  -- Hovered: tooltip overlay present+  let hoverHelp = inp0 {inputMousePos = centerOf help}+  _ <- runFrame ctx hoverHelp ui+  _ <- runFrame ctx hoverHelp ui+  spans1 <- collectOverlayTextSpans ctx hoverHelp+  assert failed (hasText "Helpful advice" spans1)++  let hoverRich = inp0 {inputMousePos = centerOf rich}+  _ <- runFrame ctx hoverRich ui+  ((_, _, body1), _, _, _) <- runFrame ctx hoverRich ui+  assert failed (case body1 of Just _ -> True; Nothing -> False)++runTooltipIdStableTest :: Context -> IORef Int -> IO ()+runTooltipIdStableTest ctx failed = do+  let inp0 = withInput 640 480+      ui = column $ do+        a <- button' "Help Target"+        tooltip a "tip"+        b <- button' "After"+        pure (a, b)+  (a0, b0) <- evalUi ctx inp0 ui+  let hoverInp = inp0 {inputMousePos = centerOf a0}+  _ <- runFrame ctx hoverInp ui+  ((_, b1), _, _, _) <- runFrame ctx hoverInp ui+  assert failed (respId b0 == respId b1)++runTooltipScrollPosTest :: Context -> IORef Int -> IO ()+runTooltipScrollPosTest ctx failed = do+  let inp0 = withInput 200 200+      ui =+        scrollArea (fillW . fixedH 80) $+          column $ do+            mapM_ (\_ -> void (label "pad line")) [(1 :: Int) .. 40]+            btn <- button' "Tip Target"+            tooltip btn "Scrolled tip text"+            mapM_ (\_ -> void (label "tail line")) [(1 :: Int) .. 12]+            pure btn+  (sid, _) <- warmup2 ctx inp0 ui+  mScroll <- getPrevRect ctx sid+  case mScroll of+    Nothing -> assert failed False+    Just scrollRect@(Rect _ sy _ sh) -> do+      let hover = inp0 {inputMousePos = spanCenter scrollRect}+          wheel = hover {inputScroll = V2 0 1}+          inView btn =+            let y = rectY (respRect btn)+                h = rectH (respRect btn)+             in y >= sy + 4 && y + h + 16 <= sy + sh+          pump = do+            before <- getScrollOffset ctx sid+            _ <- runFrame ctx wheel ui+            after <- getScrollOffset ctx sid+            ((_, btn), _, _, _) <- runFrame ctx hover ui+            if inView btn || after <= before then pure (after, btn) else pump+      (off, btn1) <- pump+      assert failed (off > 0)+      let hoverInp = inp0 {inputMousePos = centerOf btn1}+          visualBottom = rectY (respRect btn1) + rectH (respRect btn1)+          layoutBottom = visualBottom + off+      _ <- runFrame ctx hoverInp ui+      _ <- runFrame ctx hoverInp ui+      spans <- collectOverlayTextSpans ctx hoverInp+      let ys =+            [ rectY r+            | (r, txt, _, _, _) <- spans+            , "Scrolled tip" `T.isInfixOf` txt+            ]+      case ys of+        [] -> assert failed False+        (tipY : _) -> do+          assert failed (abs (tipY - visualBottom) <= 16)+          assert failed (abs (tipY - visualBottom) < abs (tipY - layoutBottom))
+ test/integration/Cases/Window.hs view
@@ -0,0 +1,504 @@+module Cases.Window+  ( runFitHeaderNoShrinkTest+  , runOverlayClickThroughTest+  , runOverlayPanelLiveTest+  , runOverlaySiblingStateTest+  , runSeparatorSpanTest+  , runWindowCloseDamageTest+  , runWindowDragTest+  , runWindowOverlayTest+  , runWindowResizeHaloHitTest+  , runWindowResizeTest+  , runWindowScrollGutterTest+  , runPageWindowScrollTest+  , runWindowScrollOnlyDamageTest+  , runWindowContentChurnTest+  , runScrolledDebugToggleTest+  , runHeadingMonoTruncateTest+  ) where++import Control.Monad (forM_, replicateM, void, when)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.Text qualified as T+import NanoUI+import NanoUI.Testing+import NanoUI.Testing.Assert (assert, assertEq, assertGt, assertLt, withInput)+import NanoUI.Testing.Harness+  ( assertWheelTitlePinned+  , centerOf+  , clickPair+  , dragWindowEdge+  , keyInp+  , runClick+  , runDragFrom+  , spanYOf+  , warmup2+  , windowTitleGrab+  , withInputOff+  )++runWindowScrollGutterTest :: Context -> IORef Int -> IO ()+runWindowScrollGutterTest ctx failed = do+  let inp0 = withInput 640 360+      long = T.pack (replicate 48 'M')+      ui = window True "GutterWin" $ do+        wide <- labelWith' fillW "WWWW"+        kv "Key" long+        mapM_ (\i -> label (T.pack ("line " <> show (i :: Int)))) [1 .. 24]+        pure wide+  (win, mwide) <- warmup2 ctx inp0 ui+  let Rect wx _ ww _ = respRect win+      -- The body's content keeps the window's side padding before the bar.+      contentRight = wx + ww - padR windowPad - scrollBarGutter ScrollBarWindow 0+  spans <- collectOverlayTextSpans ctx inp0+  let titleYs = [rectY r | (r, txt, _, _, _) <- spans, "GutterWin" `T.isInfixOf` txt]+  assert failed (not (null titleYs))+  case mwide of+    Nothing -> assert failed False+    Just wide -> do+      let Rect cx _ cw _ = respRect wide+      assert failed (cx + cw >= contentRight - 0.5 && cx + cw <= contentRight + 0.01)++runWindowCloseDamageTest :: Context -> IORef Int -> IO ()+runWindowCloseDamageTest ctx failed = do+  let ui open = void (window open "Debug" (label "Body"))+      inp0 = withInput 640 400+  _ <- warmup2 ctx inp0 (ui True)+  _ <- runFrame ctx inp0 (ui False)+  dmg <- takeDamage ctx+  assertEq failed dmg DamageFull+  need <- needsRedraw ctx inp0 (inp0 {inputDeltaTime = 1})+  assert failed need++runOverlayPanelLiveTest :: Context -> IORef Int -> IO ()+runOverlayPanelLiveTest _ failed = do+  let inp = withInputOff 320 240+      checkStatic ui = do+        ctx <- newContext+        _ <- warmup2 ctx inp ui+        need <- needsRedraw ctx inp inp+        assert failed (not need)+        _ <- runFrame ctx inp ui+        dmg <- takeDamage ctx+        assert failed (damageIsEmpty dmg)+      checkDirtyWake ui = do+        ctx <- newContext+        _ <- runFrame ctx inp ui+        markDirty ctx+        need <- needsRedraw ctx inp inp+        assert failed need+        _ <- runFrame ctx inp ui+        dmg <- takeDamage ctx+        assertEq failed dmg DamageFull+  checkStatic (void (window True "Debug" (label "fps 0")))+  checkStatic (void (modal True "About" (label "body")))+  checkDirtyWake (void (modal True "About" (label "body")))++-- Opening a modal or window must not shift the ids, and so the stored state,+-- of the widgets after it.+runOverlaySiblingStateTest :: Context -> IORef Int -> IO ()+runOverlaySiblingStateTest _ failed = do+  let inp = withInput 640 400+      ui overlay open edit = do+        _ <- overlay open "About" (label "body")+        (txt, setTxt) <- useText "start"+        when edit (setTxt "edited")+        textInput txt+  forM_ [modal, window] $ \overlay -> do+    ctx <- newContext+    _ <- runFrame ctx inp (ui overlay False True)+    closed <- warmup2 ctx inp (ui overlay False False)+    assertEq failed closed "edited"+    opened <- warmup2 ctx inp (ui overlay True False)+    assertEq failed opened "edited"++runFitHeaderNoShrinkTest :: Context -> IORef Int -> IO ()+runFitHeaderNoShrinkTest ctx failed = do+  let header = panelWith (padXY 16 12 . fillW) (label' "nano-ui SDL3 demo")+      only = columnWith (padAll 12 . grow) header+      withBody = columnWith (padAll 12 . gap 8 . grow) $ do+        h <- header+        scrollWith (tight . grow) $+          columnWith fillW (mapM_ (label . T.pack . show) [1 .. 40 :: Int])+        pure h+      tall = withInput 400 800+      short = withInput 400 200+  _ <- runFrame ctx tall only+  (r0, _, _, _) <- runFrame ctx tall only+  _ <- runFrame ctx short withBody+  (r1, _, _, _) <- runFrame ctx short withBody+  assert failed (rectH (respRect r1) + 0.5 >= rectH (respRect r0))++runWindowOverlayTest :: Context -> IORef Int -> IO ()+runWindowOverlayTest ctx failed = do+  let inp0 = withInput 640 400+      ui = do+        outside <- button' "Outside"+        (win, mBody) <- window True "Debug" (label "Body")+        pure (outside, win, mBody)+      closedUi = do+        _ <- button "Outside"+        (win, mBody) <- window False "Debug" (label "Body")+        pure (win, mBody)+  do+    ((win, mBody), _, _, _) <- runFrame ctx inp0 closedUi+    assert failed (not (respClicked win))+    assert failed (case mBody of Nothing -> True; _ -> False)+    closedSpans <- collectOverlayTextSpans ctx inp0+    assert failed (not (any (\(_, txt, _, _, _) -> "Debug" `T.isInfixOf` txt) closedSpans))+  (outside0, win0, mBody0) <- warmup2 ctx inp0 ui+  panels <- floatingPanelRects ctx+  overlays <- collectOverlayTextSpans ctx inp0+  assert failed (any (\(_, txt, _, _, _) -> "Debug" `T.isInfixOf` txt) overlays)+  assert failed (any (\(_, txt, _, _, _) -> "Body" `T.isInfixOf` txt) overlays)+  assert failed (not (any (\(_, txt, _, _, _) -> T.strip txt == "X") overlays))+  let Rect wx wy ww wh = respRect win0+  assert failed (ww >= 100 && wh >= 20)+  assert failed (case mBody0 of Just _ -> True; _ -> False)+  let (pressOut, releaseOut) = clickPair inp0 (V2 (rectX (respRect outside0) + 8) (rectY (respRect outside0) + 8))+  _ <- runFrame ctx pressOut ui+  ((outsideHit, _, _), _, _, _) <- runFrame ctx releaseOut ui+  assert failed (respClicked outsideHit)+  let (clickWin, _) = clickPair inp0 (V2 (wx + ww / 2) (wy + wh * 0.7))+  ((outsideMid, _, _), _, _, _) <- runFrame ctx clickWin ui+  assert failed (not (respClicked outsideMid))+  let esc = keyInp KeyEscape inp0+  ((_, winEsc, _), _, _, _) <- runFrame ctx esc ui+  assert failed (not (respClicked winEsc))+  let Rect px py pw _ =+        case map snd (IM.toList panels) of+          (r : _) -> r+          _ -> respRect win0+      closeAt = V2 (px + pw - padR windowPad - 12.5) (py + padT windowPad + 19.5)+      (clickClose, releaseClose) = clickPair inp0 closeAt+  _ <- runFrame ctx clickClose ui+  ((_, winClose, _), _, _, _) <- runFrame ctx releaseClose ui+  assert failed (respClicked winClose)++runOverlayClickThroughTest :: Context -> IORef Int -> IO ()+runOverlayClickThroughTest ctx failed = do+  let+    inp0 = withInput 300 220+    windowUi = do+      outsides <- column (replicateM 10 (button' "Outside"))+      (win, mInside) <-+        window True "Cover" $ do+          button' "Inside"+      pure (outsides, win, mInside)+    modalUi = do+      outsides <- column (replicateM 10 (button' "Outside"))+      (dlg, mInside) <-+        modal True "Cover" $ do+          button' "Inside"+      pure (outsides, dlg, mInside)+    stackedUi = do+      (lo, mLo) <- window True "Low" (button' "LowBtn")+      (hi, mHi) <- window True "High" (button' "HighBtn")+      pure (lo, mLo, hi, mHi)+    childSafePoint cover childRects =+      let+        Rect x y w h = cover+        titleSkip = 40+        cands =+          [ V2 (x + 6) (y + h * 0.72)+          , V2 (x + w - 6) (y + h * 0.72)+          , V2 (x + w / 2) (y + h - 6)+          , V2 (x + 6) (y + h - 6)+          , V2 (x + w - 6) (y + titleSkip + 6)+          ]+        inCover p = rectContains cover p+        missesKids p = not (any (`rectContains` p) childRects)+       in+        case filter (\p -> inCover p && missesKids p) cands of+          (p : _) -> Just p+          [] -> Nothing+    clickNone clicked u pos = do+      let (press, release) = clickPair inp0 pos+      _ <- runFrame ctx press u+      runFrame ctx release u >>= \(hit, _, _, _) -> assert failed (not (clicked hit))+    runCovered u = do+      _ <- warmup2 ctx inp0 u+      ((_, cover0, mInside0), _, _, _) <- runFrame ctx inp0 u+      let coverRect = respRect cover0+      assert failed (rectW coverRect > 0 && rectH coverRect > 0)+      case mInside0 of+        Nothing -> assert failed False+        Just inside0 -> do+          let kids = [respRect inside0]+          case childSafePoint coverRect kids of+            Nothing -> assert failed False+            Just pos -> do+              let (press, release) = clickPair inp0 pos+              _ <- runFrame ctx press u+              ((outsidesHit, _, _), _, _, _) <- runFrame ctx release u+              assert failed (not (any respClicked outsidesHit))+          let ir = respRect inside0+              ip = V2 (rectX ir + rectW ir / 2) (rectY ir + rectH ir / 2)+          assert failed (rectW ir > 0 && rectH ir > 0)+          let (ipress, irelease) = clickPair inp0 ip+          _ <- runFrame ctx ipress u+          ((_, _, mInsideHit), _, _, _) <- runFrame ctx irelease u+          assert failed (maybe False respClicked mInsideHit)+    runStacked = do+      _ <- warmup2 ctx inp0 stackedUi+      ((_, mLo0, hi0, mHi0), _, _, _) <- runFrame ctx inp0 stackedUi+      case (mLo0, mHi0) of+        (Just loBtn, Just hiBtn) -> do+          let cover = respRect hi0+              kids = [respRect loBtn, respRect hiBtn]+          assert failed (rectW cover > 0 && rectH cover > 0)+          case childSafePoint cover kids of+            Nothing -> assert failed False+            Just pos -> clickNone (\(_, loHit, _, _) -> maybe False respClicked loHit) stackedUi pos+          let hp = V2 (rectX (respRect hiBtn) + rectW (respRect hiBtn) / 2) (rectY (respRect hiBtn) + rectH (respRect hiBtn) / 2)+              (hpress, hrelease) = clickPair inp0 hp+          _ <- runFrame ctx hpress stackedUi+          ((_, _, _, mHiHit), _, _, _) <- runFrame ctx hrelease stackedUi+          assert failed (maybe False respClicked mHiHit)+        _ -> assert failed False+  runCovered windowUi+  runCovered modalUi+  runStacked++runWindowDragTest :: Context -> IORef Int -> IO ()+runWindowDragTest ctx failed = do+  let inp0 = withInput 640 400+      ui = fmap fst (window True "Debug" (label "Body"))+  win0 <- warmup2 ctx inp0 ui+  let r0 = respRect win0+      x0 = rectX r0+      y0 = rectY r0+      dest = V2 (x0 + 24 - 50) (y0 + 22 + 30)+  runDragFrom ctx inp0 ui (windowTitleGrab r0) dest+  dmg <- takeDamage ctx+  assertEq failed dmg DamageFull+  (win1, _, _, _) <- runFrame ctx (inp0 {inputMousePos = dest}) ui+  let Rect x1 y1 _ _ = respRect win1+  assert failed (x1 < x0 - 10)+  assert failed (y1 > y0 + 10)++-- Wheeling over a window's body scrolls the window, not the page, whether the+-- window is declared inside a page scroll area or beside one.+runPageWindowScrollTest :: Context -> IORef Int -> IO ()+runPageWindowScrollTest _ failed = do+  let line1 = T.pack "line 1"+      title = T.pack "Debug"+      debugWindow =+        fmap fst $+          window True "Debug" $+            column $+              mapM_ (\i -> label (T.pack ("line " <> show (i :: Int)))) [1 .. 30]+      nested = do+        (_, win) <- scrollArea (tight . grow) $ do+          void (button "OK")+          debugWindow+        pure win+      sibling = do+        scrollWith (tight . grow) $ void (label "page")+        debugWindow+  forM_ [(withInput 320 220, nested), (withInput 640 400, sibling)] $ \(inp0, ui) -> do+    ctx <- newContext+    win <- warmup2 ctx inp0 ui+    let Rect wx _ ww _ = respRect win+    spans0 <- collectOverlayTextSpans ctx inp0+    case spanYOf line1 spans0 of+      [] -> assert failed False+      b0 : _ -> do+        let wheelAt = V2 (wx + ww / 2) (b0 + 2)+        assertWheelTitlePinned failed ctx inp0 ui title line1 wheelAt Nothing++runWindowScrollOnlyDamageTest :: Context -> IORef Int -> IO ()+runWindowScrollOnlyDamageTest ctx failed = do+  let inp0 = withInput 640 400+      ui =+        fmap fst $+          window True "Debug" $+            column $+              mapM_ (\i -> label (T.pack ("line " <> show (i :: Int)))) [1 .. 30]+  win <- warmup2 ctx inp0 ui+  let wheel =+        inp0+          { inputMousePos = centerOf win+          , inputScroll = V2 0 1+          }+  _ <- runFrame ctx wheel ui+  dmg <- takeDamage ctx+  case dmg of+    DamageClip r ->+      assert failed (maybe False (\i -> rectW i > 0 && rectH i > 0) (rectIntersect r (respRect win)))+    _ -> assert failed False++runWindowContentChurnTest :: Context -> IORef Int -> IO ()+runWindowContentChurnTest ctx failed = do+  let inp0 = withInput 640 400+      ui k = do+        _ <- button "Outside"+        fst <$> window True "Debug" (columnWith (tight . gap 4 . minW 300 . fillW) $ do+          void $ label (T.pack (replicate (1 + (k `mod` 9)) 'M'))+          void $ label "static row"+          )+  _ <- warmup2 ctx inp0 (ui 0)+  counter <- newIORef (1 :: Int)+  allClip <- replicateM 30 $ do+    k <- readIORef counter+    writeIORef counter (k + 1)+    _ <- runFrame ctx inp0 (ui k)+    dmg <- takeDamage ctx+    case dmg of+      DamageClip _ -> pure True+      _ -> pure False+  assert failed (and allClip)++runScrolledDebugToggleTest :: Context -> IORef Int -> IO ()+runScrolledDebugToggleTest ctx failed = do+  let inp0 = withInput 640 400+      title = T.pack "Debug"+      ui = do+        (open, setOpen) <- useFlag False+        (_, dbgBtn) <- scrollArea (tight . grow) $ do+          b <- button' "Debug"+          when (respClicked b) (setOpen (not open))+          pure b+        when open $ void (window True "Debug" (label "fps"))+        pure dbgBtn+  dbgBtn <- warmup2 ctx inp0 ui+  let pos = centerOf dbgBtn+  _ <- runClick ctx inp0 ui pos+  spans <- collectOverlayTextSpans ctx inp0+  let titles = [t | (_, t, _, _, _) <- spans, title `T.isInfixOf` t]+  assert failed (not (null titles))+  _ <- runFrame ctx inp0 ui+  spansAfter <- collectOverlayTextSpans ctx inp0+  let titlesAfter = [t | (_, t, _, _, _) <- spansAfter, title `T.isInfixOf` t]+  assert failed (not (null titlesAfter))++runWindowResizeTest :: Context -> IORef Int -> IO ()+runWindowResizeTest ctx failed = do+  let inp0 = withInput 640 400+      ui = fmap fst (window True "Resize" (label "Body"))+  _ <- runFrame ctx inp0 ui+  (win0, _, _, _) <- runFrame ctx inp0 ui+  mrect0 <- getPrevRect ctx (respId win0)+  case mrect0 of+    Nothing -> assert failed False+    Just (Rect x0 y0 w0 h0) -> do+      assert failed (w0 > 0 && h0 > 0)+      let hoverAt p = inp0 {inputMousePos = p}+          expectCursor p kind = do+            k <- uiCursorKind ctx (hoverAt p)+            assertEq failed k kind+      expectCursor (V2 (x0 + w0 + 4) (y0 + h0 + 4)) UiCursorNwseResize+      expectCursor (V2 (x0 - 4) (y0 - 4)) UiCursorNwseResize+      expectCursor (V2 (x0 + w0 + 4) (y0 - 4)) UiCursorNeswResize+      expectCursor (V2 (x0 - 4) (y0 + h0 + 4)) UiCursorNeswResize+      expectCursor (V2 (x0 + w0 / 2) (y0 - 4)) UiCursorNsResize+      expectCursor (V2 (x0 + w0 / 2) (y0 + h0 + 4)) UiCursorNsResize+      expectCursor (V2 (x0 - 4) (y0 + h0 / 2)) UiCursorEwResize+      expectCursor (V2 (x0 + w0 + 4) (y0 + h0 / 2)) UiCursorEwResize+      expectCursor (V2 (x0 + w0 - 5) (y0 + h0 / 2)) UiCursorEwResize+      insideKind <- uiCursorKind ctx (hoverAt (V2 (x0 + w0 - padR windowPad - 4) (y0 + h0 / 2)))+      assert failed (insideKind /= UiCursorEwResize)+      mSe <- dragWindowEdge ctx inp0 ui (V2 (x0 + w0 + 4) (y0 + h0 + 4)) (V2 (x0 + w0 + 40) (y0 + h0 + 30))+      case mSe of+        Nothing -> assert failed False+        Just (Rect x1 y1 w1 h1) -> do+          assertGt failed w1 (w0 + 20)+          assertGt failed h1 (h0 + 15)+          mW <- dragWindowEdge ctx inp0 ui (V2 (x1 - 4) (y1 + h1 / 2)) (V2 (x1 - 36) (y1 + h1 / 2))+          case mW of+            Nothing -> assert failed False+            Just (Rect xw yw ww hw) -> do+              assertGt failed ww (w1 + 15)+              assertLt failed xw (x1 - 10)+              mN <- dragWindowEdge ctx inp0 ui (V2 (xw + ww / 2) (yw - 4)) (V2 (xw + ww / 2) (yw - 20))+              case mN of+                Nothing -> assert failed False+                Just (Rect xn yn wn hn) -> do+                  assertGt failed hn (hw + 8)+                  assertLt failed yn (yw - 5)+                  let minTitleH = 39 + padT windowPad + padB windowPad+                  mShort <- dragWindowEdge ctx inp0 ui (V2 (xn + wn / 2) (yn + hn + 4)) (V2 (xn + wn / 2) (yn + 4))+                  case mShort of+                    Nothing -> assert failed False+                    Just (Rect _ _ _ hMin) -> assert failed (hMin + 0.01 >= minTitleH)++runWindowResizeHaloHitTest :: Context -> IORef Int -> IO ()+runWindowResizeHaloHitTest ctx failed = do+  let inp0 = withInput 640 400+      ui = do+        btn <- button' "Hit"+        (win, _) <- window True "Resize" (label "Body")+        pure (btn, win)+  (btn0, win0) <- warmup2 ctx inp0 ui+  let Rect bx by bw bh = respRect btn0+      Rect x0 y0 _ _ = respRect win0+      grab = V2 (x0 + 24) (y0 + 22)+      destX = bx + bw + 4+      press = inp0 {inputMousePos = grab, inputMouseDown = True, inputMousePressed = True}+  _ <- runFrame ctx press ui+  let moved = press {inputMousePos = V2 (destX + 24) (y0 + 22), inputMousePressed = False}+  _ <- runFrame ctx moved ui+  ((_, win1), _, _, _) <- runFrame ctx (inp0 {inputMousePos = V2 destX (y0 + 22)}) ui+  let Rect x1 y1 _ h1 = respRect win1+      hit = V2 (bx + bw - 2) (by + bh - 2)+      inHalo = let s = 12+                in (v2X hit < x1 && v2X hit >= x1 - s)+                    && v2Y hit >= y1 - s+                    && v2Y hit <= y1 + h1 + s+      isResize k = k == UiCursorEwResize || k == UiCursorNsResize || k == UiCursorNwseResize || k == UiCursorNeswResize+  kind <- uiCursorKind ctx (inp0 {inputMousePos = hit})+  assert failed (abs (x1 - destX) <= 8)+  assert failed inHalo+  assert failed (not (isResize kind))++runSeparatorSpanTest :: Context -> IORef Int -> IO ()+runSeparatorSpanTest ctx failed = do+  let inp = withInput 200 120+      ui = columnWith fillW $ do+        label "A"+        sid <- currentId+        separator+        label "B"+        pure sid+  _ <- runFrame ctx inp ui+  (sid, _, _, _) <- runFrame ctx inp ui+  mRect <- getPrevRect ctx sid+  case mRect of+    Just (Rect _ _ w h) -> do+      assert failed (w >= 100)+      assert failed (h <= 2)+    Nothing -> assert failed False++runHeadingMonoTruncateTest :: Context -> IORef Int -> IO ()+runHeadingMonoTruncateTest ctx failed = do+  let inp = withInput 1600 600+      longPath = T.pack "C:\\Users\\zach\\AppData\\Local\\Microsoft\\Windows\\Fonts\\JetBrainsMono-Regular.ttf"+      ui = fst <$> window True "Debug" (do+        heading "Draw"+        _ <- label "NormalLabel"+        kvMono "font" longPath)+  win <- warmup2 ctx inp ui+  let Rect wx wy ww wh = respRect win+      contentRight = wx + ww - padR windowPad+  spans <- collectOverlayTextSpans ctx inp+  let fontSpans = [(r, t) | (r, t, _, _, _) <- spans, "JetBrainsMono" `T.isInfixOf` t || "..." `T.isInfixOf` t]+  case fontSpans of+    [(Rect fx _ fw _, t)] -> do+      assert failed ("..." `T.isSuffixOf` t)+      assert failed (abs (fx + fw - contentRight) < 2.0)+    _ -> assert failed False+  mWide <- dragWindowEdge ctx inp ui (V2 (wx - 4) (wy + wh / 2)) (V2 (wx - 1100) (wy + wh / 2))+  case mWide of+    Nothing -> assert failed False+    Just (Rect wxWide _ wwWide _) -> do+      assertGt failed wwWide (ww + 800)+      spansWide <- collectOverlayTextSpans ctx inp+      let fontSpansWide = [(r, t) | (r, t, _, _, _) <- spansWide, "JetBrainsMono" `T.isInfixOf` t || "..." `T.isInfixOf` t]+      case fontSpansWide of+        [(Rect fx2 _ fw2 _, t2)] -> do+          assert failed (t2 == longPath)+          assert failed (not ("..." `T.isSuffixOf` t2))+          let contentRightWide = wxWide + wwWide - padR windowPad+          assert failed (abs (fx2 + fw2 - contentRightWide) < 2.0)+        _ -> assert failed False
+ test/integration/Main.hs view
@@ -0,0 +1,295 @@+module Main (main) where++import Cases+import Cases.Animation+import Cases.Atlas+import Cases.Cache+import Cases.Combo+import Cases.ContextMenu+import Cases.CustomWidget+import Cases.Damage+import Cases.Demo+import Cases.Grid+import Cases.HostDraw+import Cases.Keyboard+import Cases.Modal+import Cases.NoThunks+import Cases.NumericInput+import Cases.PointerRelease+import Cases.RichText+import Cases.Runner+import Cases.SIMD+import Cases.Scroll+import Cases.Select+import Cases.Shaping+import Cases.State+import Cases.Styling+import Cases.Svg+import Cases.Table+import Cases.Tabs+import Cases.TextInput+import Cases.Tooltip+import Cases.Window+import Data.IORef (IORef)+import NanoUI.Testing (Context, newContext, newPixelContext)+import NanoUI.Testing.Runner (runTests)++data TestSpec+  = TestSpec+  { specName :: String+  , specSdl :: Bool+  , specRun :: Context -> IORef Int -> IO ()+  }++main :: IO ()+main =+  runTests+    [ (specName, if specSdl then newPixelContext else newContext, specRun)+    | TestSpec {specName, specSdl, specRun} <- testSpecs+    ]++testSpecs :: [TestSpec]+testSpecs =+  -- Runner, state and messages+  [ TestSpec "session-loop" False runSessionLoopTest+  , TestSpec "drawing-lock" False runDrawingLockTest+  , TestSpec "simd-writes" False runSimdWritesTest+  , TestSpec "no-thunks" False runNoThunksTest+  , TestSpec "controlled-state" False runControlledStateTest+  , TestSpec "controlled-inputs" False runControlledInputsTest+  , TestSpec "hook-state" False runHookStateTest+  , TestSpec "collection-api" False runCollectionApiTest+  , TestSpec "embed-state" False runEmbedStateTest+  , TestSpec "host-slot" False runHostSlotTest+  , TestSpec "reduce-messages" False runReduceMessagesTest+  , TestSpec "reduce-click" False runReduceClickTest+  , TestSpec "widget-no-string-emit" False runWidgetNoStringEmitTest+  -- Ids, layout and caches+  , TestSpec "id-keyed-list" False runIdKeyedListTest+  , TestSpec "fit-muted-width" False runFitMutedWidthTest+  , TestSpec "fit-header-no-shrink" False runFitHeaderNoShrinkTest+  , TestSpec "layout-reuse" False runLayoutReuseTest+  , TestSpec "metric-cache-invalidation" False runMetricCacheInvalidationTest+  , TestSpec "widget-placement-cache" False runWidgetPlacementCacheTest+  , TestSpec "layout-cache-paint-state" False runLayoutPaintStateTest+  , TestSpec "deep-nesting" False runDeepNestingTest+  , TestSpec "grow-split" False runGrowSplitTest+  , TestSpec "percent-gap-shrink" False runPercentGapShrinkTest+  , TestSpec "aspect-layout" False runAspectLayoutTest+  , TestSpec "label-align-end" True runLabelAlignEndTest+  , TestSpec "responsive-wrap" True runResponsiveWrapTest+  , TestSpec "kv-multiline-height" True runKvMultilineHeightTest+  , TestSpec "separator-span" False runSeparatorSpanTest+  , TestSpec "panel-paints" False runPanelPaintsTest+  , TestSpec "grid-columns-font-color" False runGridColumnsWithFontColorTest+  , TestSpec "grid-nested" False runNestedGridTest+  , TestSpec "stale-font-color" False runStaleFontColorTest+  , TestSpec "font-composition" True runFontCompositionTest+  -- Drawing+  , TestSpec "draw-square-geometry" False runSquareGeometryTest+  , TestSpec "draw-external-text" False runExternalTextTest+  , TestSpec "drawing" False runDrawingTest+  , TestSpec "image" False runImageTest+  , TestSpec "rich-text-wrap" False runRichTextWrapTest+  , TestSpec "rich-text-link" False runRichTextLinkTest+  , TestSpec "bidi-runs" False runBidiRunsTest+  , TestSpec "shaped-carets" False runShapedCaretTest+  , TestSpec "svg-raster" False runSvgRasterTest+  , TestSpec "svg-icon" False runSvgIconTest+  , TestSpec "empty-frame" False runEmptyFrameTest+  , TestSpec "image-swap-damage" False runImageSwapDamageTest+  , TestSpec "atlas-growth" False runAtlasGrowthTest+  -- Pointer, redraw and damage+  , TestSpec "pointer-cursor" False runPointerCursorTest+  , TestSpec "hover-damage" False runHoverDamageTest+  , TestSpec "damage-bounds-resolution" False runDamageBoundsResolutionTest+  , TestSpec "damage-widget-explicit" False runExplicitDamageWidgetTest+  , TestSpec "damage-queue-cleared" False runDamageQueueClearedPerFrameTest+  , TestSpec "damage-state-change" False runStateChangeDamageTest+  , TestSpec "damage-orphan-anim-settles" False runOrphanAnimationDamageSettlesTest+  , TestSpec "versioned-drawing-damage" False runVersionedDrawingDamageTest+  , TestSpec "clip-frame-backdrop" False runClipFrameBackdropTest+  , TestSpec "textarea-select-all-damage" False runTextAreaSelectAllDamageTest+  , TestSpec "panel-body-swap-damage" False runPanelBodySwapDamageTest+  , TestSpec "refresh-forces-redraw" False runRefreshRedrawTest+  -- Animation+  , TestSpec "animation-settle" False runAnimationSettleTest+  , TestSpec "animation-damage" False runAnimationDamageTest+  , TestSpec "animation-stagger" False runAnimationStaggerTest+  , TestSpec "animation-bezier" False runAnimationBezierTest+  , TestSpec "animation-spring-retarget" False runAnimationSpringRetargetTest+  , TestSpec "animation-spring-dt" False runAnimationSpringDtTest+  , TestSpec+      "composite-animation-isolation"+      False+      runCompositeAnimationIsolationTest+  , TestSpec "button-hover-anim" False runButtonHoverAnimTest+  , TestSpec "spinner" False runSpinnerTest+  -- Keyboard+  , TestSpec "keyboard-disabled" False runKeyboardDisabledTest+  , TestSpec "disabled-pointer" False runDisabledPointerTest+  , TestSpec "disabled-focus-order" False runDisabledFocusOrderTest+  , TestSpec "disabled-look" False runDisabledLookTest+  , TestSpec "styled-paint" False runStyledPaintTest+  , TestSpec "styled-nesting" False runStyledNestingTest+  , TestSpec "styled-damage" False runStyledDamageTest+  , TestSpec "text-undo" False runTextUndoTest+  , TestSpec "text-area-width-tracking" False runTextAreaWidthTrackingTest+  , TestSpec "keyboard-modal-eligibility" False runKeyboardModalEligibilityTest+  , TestSpec "keyboard-focus-ring" False runKeyboardFocusRingTest+  , TestSpec "keyboard-button" False runKeyboardButtonTest+  , TestSpec "keyboard-checkbox" False runKeyboardCheckboxTest+  , TestSpec "keyboard-slider" True runKeyboardSliderTest+  , TestSpec "keyboard-radio" False runKeyboardRadioTest+  , TestSpec "keyboard-toggle" False runKeyboardToggleTest+  , TestSpec "keyboard-tab-header" False runKeyboardTabHeaderTest+  -- Controls+  , TestSpec "checkbox-initial" False runCheckboxInitialTest+  , TestSpec "slider-cursor" True runSliderCursorTest+  , TestSpec "slider-fill-width" True runSliderFillWidthTest+  , TestSpec "search-field-clear" False runSearchFieldClearTest+  , TestSpec "search-field-debounce" False runSearchFieldDebounceTest+  , TestSpec "select-drag-to-select" False runSelectDragToSelectTest+  , TestSpec "select-keyboard" False runSelectKeyboardTest+  , TestSpec "select-change-once" False runSelectChangeOnceTest+  , TestSpec "select-close-keeps-focus" False runSelectCloseKeepsFocusTest+  , TestSpec "select-overlay-damage" False runSelectOverlayDamageTest+  , TestSpec "tree-select" False runTreeSelectTest+  , TestSpec "tree-keyboard" False runTreeKeyboardTest+  , TestSpec "combo-filter" False runComboFilterTest+  , TestSpec "combo-keyboard-pick" False runComboKeyboardPickTest+  , TestSpec "combo-mouse-pick" False runComboMousePickTest+  , TestSpec "combo-blur-commit" False runComboBlurCommitTest+  , TestSpec "combo-escape-revert" False runComboEscapeRevertTest+  , TestSpec "combo-hover-highlight" False runComboHoverHighlightTest+  , TestSpec "combo-scrollbar-drag" False runComboScrollbarDragTest+  , TestSpec "combo-wheel-scroll" False runComboWheelScrollTest+  , TestSpec "color-picker-commit" True runColorPickerCommitTest+  , TestSpec "color-picker-rgba" True runColorPickerRgbaTest+  , TestSpec "color-picker-edit" True runColorPickerEditTest+  , TestSpec "color-picker-change-once" True runColorPickerChangeOnceTest+  , TestSpec "color-picker-bar-keys" True runColorPickerBarKeysTest+  , TestSpec "color-picker-drag-after-field" True runColorPickerDragAfterFieldTest+  , TestSpec "controls-tab-height" True runControlsTabHeightTest+  , TestSpec "bounded-radio-offset" True runBoundedRadioTest+  -- Text input and text area+  , TestSpec "text-input-cursor" False runTextInputCursorTest+  , TestSpec "text-input-batch" False runTextInputBatchTest+  , TestSpec "text-input-selection" False runTextInputSelectionTest+  , TestSpec "text-input-mouse-selection" False runTextInputMouseSelectionTest+  , TestSpec "text-input-click-select" False runTextInputClickSelectTest+  , TestSpec "text-input-word-keys" False runTextInputWordKeysTest+  , TestSpec+      "text-input-cut-clears-selection"+      False+      runTextInputCutClearsSelectionTest+  , TestSpec "text-input-clipboard" False runTextInputClipboardTest+  , TestSpec "text-input-password" False runTextInputPasswordTest+  , TestSpec "numeric-input" False runNumericInputTest+  , TestSpec "numeric-input-hex" False runNumericInputHexTest+  , TestSpec "text-input-menu" False runTextInputMenuTest+  , TestSpec "text-input-ff-caret" False runTextInputFfCaretTest+  , TestSpec "text-input-focus-sdl" True runTextInputFocusSdlTest+  , TestSpec "text-input-scroll" True runTextInputScrollTest+  , TestSpec "text-input-dirty" False runTextInputDirtyTest+  , TestSpec+      "text-area-cut-clears-selection"+      False+      runTextAreaCutClearsSelectionTest+  , TestSpec "text-area-scroll-wheel" True runTextAreaScrollWheelTest+  , TestSpec "text-area-zoom-scroll" True runTextAreaZoomScrollTest+  , TestSpec "text-area-remount-scroll" True runTextAreaRemountScrollTest+  , TestSpec "text-area-menu-pulse" True runTextAreaMenuPulseTest+  , TestSpec "text-command-focus" False runTextCommandFocusTest+  , TestSpec "text-area-scroll-drag" True runTextAreaScrollDragTest+  , TestSpec "text-area-cursor-on-scrollbar" True runTextAreaCursorOnScrollBarTest+  , TestSpec "text-area-hscroll-wheel" True runTextAreaHScrollWheelTest+  , TestSpec "text-area-hscroll-drag" True runTextAreaHScrollDragTest+  , TestSpec "text-area-2d-scroll" True runTextArea2DScrollTest+  , TestSpec+      "text-area-scroll-cursor-leaves-viewport"+      True+      runTextAreaScrollCursorLeavesViewportTest+  -- Scrolling+  , TestSpec "scroll-thumb-cursor" False runScrollThumbCursorTest+  , TestSpec "scroll-bar-gutter" True runScrollBarGutterTest+  , TestSpec "window-scroll-gutter" True runWindowScrollGutterTest+  , TestSpec "scroll-damage" False runScrollDamageTest+  , TestSpec "scroll-top-clip" True runScrollTopClipTest+  , TestSpec "nested-scroll" False runNestedScrollTest+  , TestSpec "nested-scroll-focus" False runNestedScrollFocusTest+  , TestSpec "scroll-hover-clip" False runScrollHoverClipTest+  , TestSpec "scroll-button-click" False runScrollButtonClickTest+  , TestSpec "scroll-scrolled-out" False runScrolledOutImmunityTest+  , TestSpec "scroll-lockstep-probe" False runScrollLockstepProbeTest+  , TestSpec "page-scroll-backdrop-coverage" False runPageScrollBackdropCoverageTest+  , TestSpec "scroll-2d-pad-fill-overflow" True run2DPadFillOverflowTest+  , TestSpec "scroll-2d-pad-overflow-scrolls" True run2DPadOverflowScrollsTest+  , TestSpec "scroll-step" True runScrollStepTest+  , TestSpec "scroll-smooth" True runScrollSmoothTest+  , TestSpec "scroll-metrics" True runScrollMetricsTest+  , TestSpec "scroll-into-view" True runScrollIntoViewTest+  , TestSpec "scroll-glide-clamp" True runScrollGlideClampTest+  -- Tables+  , TestSpec "table-sort" False runTableSortTest+  , TestSpec "table-reorder" True runTableReorderTest+  , TestSpec "table-scroll-reveal" True runTableScrollRevealTest+  , TestSpec "table-shared-scroll-metrics" True runTableSharedScrollMetricsTest+  , TestSpec "page-wheel-above-table" True runPageWheelAboveTableTest+  , TestSpec "table-wrap-row-stretch" True runTableWrapRowStretchTest+  , TestSpec "table-first-col" False runTableFirstColWidthTest+  , TestSpec "table-fill-width" False runTableFillWidthTest+  , TestSpec "table-cell-pad" True runTableCellPadTest+  , TestSpec "table-resize-overflow" True runTableResizeOverflowTest+  , TestSpec "table-col-resize-body" False runTableColResizeDemoReproTest+  , TestSpec "table-hbar-reach" True runTableHBarReachTest+  -- Tabs+  , TestSpec "tabs-laziness" False runTabsLazinessTest+  , TestSpec "tabs-emit" False runTabsEmitTest+  , TestSpec "tabs-closable" False runTabsClosableTest+  , TestSpec "tabs-disabled" True runTabsDisabledTest+  , TestSpec "tabs-scroll" False runTabsScrollTest+  , TestSpec "tabs-state-persistence" False runTabsStatePersistenceTest+  , TestSpec "tabs-damage" False runTabsDamageTest+  , TestSpec "tab-response-forwarding" False runTabResponseForwardingTest+  -- Modals, windows and panes+  , TestSpec "modal-overlay" False runModalOverlayTest+  , TestSpec "modal-fits-text" False runModalFitsTextTest+  , TestSpec "modal-no-phantom-scroll" False runModalNoPhantomScrollTest+  , TestSpec "modal-close-damage" False runModalCloseDamageTest+  , TestSpec "modal-fractional-scale-no-scroll" False runModalFractionalScaleNoScrollTest+  , TestSpec "window-overlay" False runWindowOverlayTest+  , TestSpec "overlay-sibling-state" False runOverlaySiblingStateTest+  , TestSpec "overlay-click-through" False runOverlayClickThroughTest+  , TestSpec "overlay-panel-live" False runOverlayPanelLiveTest+  , TestSpec "window-drag" False runWindowDragTest+  , TestSpec "window-close-damage" False runWindowCloseDamageTest+  , TestSpec "page-window-scroll" False runPageWindowScrollTest+  , TestSpec "window-scroll-only-damage" False runWindowScrollOnlyDamageTest+  , TestSpec "window-content-churn" False runWindowContentChurnTest+  , TestSpec "scrolled-debug-toggle" False runScrolledDebugToggleTest+  , TestSpec "window-resize" False runWindowResizeTest+  , TestSpec "window-resize-halo-hit" False runWindowResizeHaloHitTest+  , TestSpec "heading-mono-truncate" False runHeadingMonoTruncateTest+  , TestSpec "pane-grid-mixed-drag" False runPaneGridMixedDragTest+  , TestSpec "pane-grid-clipped-control" False runPaneGridClippedControlTest+  -- Context menus and tooltips+  , TestSpec "context-menu-open" False runContextMenuOpenTest+  , TestSpec "context-menu-scroll-pos" False runContextMenuScrollPosTest+  , TestSpec "release-elsewhere" False runReleaseElsewhereTest+  , TestSpec "right-release-elsewhere" False runRightReleaseElsewhereTest+  , TestSpec "release-returns" False runReleaseReturnsTest+  , TestSpec "overlap-press" False runOverlapPressTest+  , TestSpec "tooltip-hover" False runTooltipHoverTest+  , TestSpec "tooltip-id-stable" False runTooltipIdStableTest+  , TestSpec "tooltip-scroll-pos" False runTooltipScrollPosTest+  -- Custom widgets+  , TestSpec "custom-widget-measure" False runCustomWidgetMeasureTest+  , TestSpec "custom-widget-cursor" False runCustomWidgetCursorTest+  , TestSpec "custom-widget-interaction" False runCustomWidgetInteractionTest+  , TestSpec "custom-widget-queued-click" False runCustomWidgetQueuedClickTest+  , TestSpec "custom-widget-content-damage" False runCustomWidgetContentDamageTest+  , TestSpec "custom-widget-content-key" False runCustomWidgetContentKeyTest+  , TestSpec "custom-widget-knob" False runReferenceKnobTest+  , TestSpec "drop-target" False runDropTargetTest+  ]