diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/benchmark/IdBench.hs b/benchmark/IdBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/IdBench.hs @@ -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 + ] + ] diff --git a/examples/Profile.hs b/examples/Profile.hs new file mode 100644 --- /dev/null +++ b/examples/Profile.hs @@ -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 = + "\ + \" + +starIcon :: Text +starIcon = + "" + +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) diff --git a/lib/NanoUI.hs b/lib/NanoUI.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI.hs @@ -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') diff --git a/lib/NanoUI/Animatable.hs b/lib/NanoUI/Animatable.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Animatable.hs @@ -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) diff --git a/lib/NanoUI/Animation.hs b/lib/NanoUI/Animation.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Animation.hs @@ -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 diff --git a/lib/NanoUI/Atlas.hs b/lib/NanoUI/Atlas.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Atlas.hs @@ -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) diff --git a/lib/NanoUI/Bidi.hs b/lib/NanoUI/Bidi.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Bidi.hs @@ -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] diff --git a/lib/NanoUI/Compact.hs b/lib/NanoUI/Compact.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Compact.hs @@ -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) diff --git a/lib/NanoUI/Context.hs b/lib/NanoUI/Context.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context.hs @@ -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) diff --git a/lib/NanoUI/Context/Animation.hs b/lib/NanoUI/Context/Animation.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context/Animation.hs @@ -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)} diff --git a/lib/NanoUI/Context/Core.hs b/lib/NanoUI/Context/Core.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context/Core.hs @@ -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) diff --git a/lib/NanoUI/Context/Drawing.hs b/lib/NanoUI/Context/Drawing.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context/Drawing.hs @@ -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) diff --git a/lib/NanoUI/Context/Overlay.hs b/lib/NanoUI/Context/Overlay.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context/Overlay.hs @@ -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) diff --git a/lib/NanoUI/Context/Scroll.hs b/lib/NanoUI/Context/Scroll.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context/Scroll.hs @@ -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 diff --git a/lib/NanoUI/Context/Types.hs b/lib/NanoUI/Context/Types.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Context/Types.hs @@ -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 diff --git a/lib/NanoUI/Damage.hs b/lib/NanoUI/Damage.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Damage.hs @@ -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 diff --git a/lib/NanoUI/Debug.hs b/lib/NanoUI/Debug.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Debug.hs @@ -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 diff --git a/lib/NanoUI/Draw.hs b/lib/NanoUI/Draw.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Draw.hs @@ -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 diff --git a/lib/NanoUI/Draw/Arena.hs b/lib/NanoUI/Draw/Arena.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Draw/Arena.hs @@ -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 diff --git a/lib/NanoUI/Draw/Shapes.hs b/lib/NanoUI/Draw/Shapes.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Draw/Shapes.hs @@ -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) diff --git a/lib/NanoUI/Draw/Text.hs b/lib/NanoUI/Draw/Text.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Draw/Text.hs @@ -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 diff --git a/lib/NanoUI/Draw/Types.hs b/lib/NanoUI/Draw/Types.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Draw/Types.hs @@ -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 diff --git a/lib/NanoUI/Emit.hs b/lib/NanoUI/Emit.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Emit.hs @@ -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)) diff --git a/lib/NanoUI/Font.hs b/lib/NanoUI/Font.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Font.hs @@ -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 <> "...") diff --git a/lib/NanoUI/Frame.hs b/lib/NanoUI/Frame.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame.hs @@ -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)) diff --git a/lib/NanoUI/Frame/Chrome.hs b/lib/NanoUI/Frame/Chrome.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Chrome.hs @@ -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 diff --git a/lib/NanoUI/Frame/Cursor.hs b/lib/NanoUI/Frame/Cursor.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Cursor.hs @@ -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 diff --git a/lib/NanoUI/Frame/Focus.hs b/lib/NanoUI/Frame/Focus.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Focus.hs @@ -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 () diff --git a/lib/NanoUI/Frame/Hit.hs b/lib/NanoUI/Frame/Hit.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Hit.hs @@ -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 diff --git a/lib/NanoUI/Frame/Input.hs b/lib/NanoUI/Frame/Input.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Input.hs @@ -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 diff --git a/lib/NanoUI/Frame/Node.hs b/lib/NanoUI/Frame/Node.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Node.hs @@ -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 diff --git a/lib/NanoUI/Frame/Overlay.hs b/lib/NanoUI/Frame/Overlay.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Overlay.hs @@ -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) diff --git a/lib/NanoUI/Frame/Paint.hs b/lib/NanoUI/Frame/Paint.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Paint.hs @@ -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) diff --git a/lib/NanoUI/Frame/Paint/Types.hs b/lib/NanoUI/Frame/Paint/Types.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Paint/Types.hs @@ -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 diff --git a/lib/NanoUI/Frame/Paint/Widgets.hs b/lib/NanoUI/Frame/Paint/Widgets.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Paint/Widgets.hs @@ -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 diff --git a/lib/NanoUI/Frame/Redraw.hs b/lib/NanoUI/Frame/Redraw.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Redraw.hs @@ -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 diff --git a/lib/NanoUI/Frame/Scroll.hs b/lib/NanoUI/Frame/Scroll.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Scroll.hs @@ -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)}) diff --git a/lib/NanoUI/Frame/Scroll/Geometry.hs b/lib/NanoUI/Frame/Scroll/Geometry.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Scroll/Geometry.hs @@ -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)) diff --git a/lib/NanoUI/Frame/Select.hs b/lib/NanoUI/Frame/Select.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Select.hs @@ -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] diff --git a/lib/NanoUI/Frame/SpanArena.hs b/lib/NanoUI/Frame/SpanArena.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/SpanArena.hs @@ -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 diff --git a/lib/NanoUI/Frame/Spans.hs b/lib/NanoUI/Frame/Spans.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Spans.hs @@ -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 diff --git a/lib/NanoUI/Frame/TextArea.hs b/lib/NanoUI/Frame/TextArea.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/TextArea.hs @@ -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) diff --git a/lib/NanoUI/Frame/TextArea/Content.hs b/lib/NanoUI/Frame/TextArea/Content.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/TextArea/Content.hs @@ -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) diff --git a/lib/NanoUI/Frame/TextArea/Geometry.hs b/lib/NanoUI/Frame/TextArea/Geometry.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/TextArea/Geometry.hs @@ -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) diff --git a/lib/NanoUI/Frame/TextEdit.hs b/lib/NanoUI/Frame/TextEdit.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/TextEdit.hs @@ -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 () diff --git a/lib/NanoUI/Frame/TextEdit/Menu.hs b/lib/NanoUI/Frame/TextEdit/Menu.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/TextEdit/Menu.hs @@ -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 diff --git a/lib/NanoUI/Frame/TextInput.hs b/lib/NanoUI/Frame/TextInput.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/TextInput.hs @@ -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 diff --git a/lib/NanoUI/Frame/Window.hs b/lib/NanoUI/Frame/Window.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Frame/Window.hs @@ -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 diff --git a/lib/NanoUI/Hooks.hs b/lib/NanoUI/Hooks.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Hooks.hs @@ -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)) diff --git a/lib/NanoUI/Id.hs b/lib/NanoUI/Id.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Id.hs @@ -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 diff --git a/lib/NanoUI/Input.hs b/lib/NanoUI/Input.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Input.hs @@ -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 + } diff --git a/lib/NanoUI/Layout/Arena.hs b/lib/NanoUI/Layout/Arena.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Layout/Arena.hs @@ -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 diff --git a/lib/NanoUI/Layout/Solve.hs b/lib/NanoUI/Layout/Solve.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Layout/Solve.hs @@ -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 diff --git a/lib/NanoUI/Monad.hs b/lib/NanoUI/Monad.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Monad.hs @@ -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 diff --git a/lib/NanoUI/Runner.hs b/lib/NanoUI/Runner.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Runner.hs @@ -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 diff --git a/lib/NanoUI/SIMD.hs b/lib/NanoUI/SIMD.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/SIMD.hs @@ -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) + ) diff --git a/lib/NanoUI/Store.hs b/lib/NanoUI/Store.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Store.hs @@ -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} diff --git a/lib/NanoUI/Style.hs b/lib/NanoUI/Style.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Style.hs @@ -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 + } diff --git a/lib/NanoUI/Svg.hs b/lib/NanoUI/Svg.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Svg.hs @@ -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 = " 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 " 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 "&" "&" . T.replace "<" "<" . T.replace ">" ">" . T.replace """ "\"" . T.replace "'" "'" + +-------------------------------------------------------------------------------- +-- 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)) diff --git a/lib/NanoUI/Testing.hs b/lib/NanoUI/Testing.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Testing.hs @@ -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 diff --git a/lib/NanoUI/Testing/Assert.hs b/lib/NanoUI/Testing/Assert.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Testing/Assert.hs @@ -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) diff --git a/lib/NanoUI/Testing/Harness.hs b/lib/NanoUI/Testing/Harness.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Testing/Harness.hs @@ -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) diff --git a/lib/NanoUI/Testing/Runner.hs b/lib/NanoUI/Testing/Runner.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Testing/Runner.hs @@ -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" diff --git a/lib/NanoUI/Types.hs b/lib/NanoUI/Types.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Types.hs @@ -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 " + 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) diff --git a/lib/NanoUI/WidgetText.hs b/lib/NanoUI/WidgetText.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/WidgetText.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Animate.hs b/lib/NanoUI/Widgets/Animate.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Animate.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Behavior.hs b/lib/NanoUI/Widgets/Behavior.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Behavior.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Button.hs b/lib/NanoUI/Widgets/Button.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Button.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Checkbox.hs b/lib/NanoUI/Widgets/Checkbox.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Checkbox.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Chrome.hs b/lib/NanoUI/Widgets/Chrome.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Chrome.hs @@ -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 diff --git a/lib/NanoUI/Widgets/ColorPicker.hs b/lib/NanoUI/Widgets/ColorPicker.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/ColorPicker.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Combinators.hs b/lib/NanoUI/Widgets/Combinators.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Combinators.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Combo.hs b/lib/NanoUI/Widgets/Combo.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Combo.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Custom.hs b/lib/NanoUI/Widgets/Custom.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Custom.hs @@ -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 + } diff --git a/lib/NanoUI/Widgets/Display.hs b/lib/NanoUI/Widgets/Display.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Display.hs @@ -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)) + ) diff --git a/lib/NanoUI/Widgets/Drawing.hs b/lib/NanoUI/Widgets/Drawing.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Drawing.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Drop.hs b/lib/NanoUI/Widgets/Drop.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Drop.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Layout.hs b/lib/NanoUI/Widgets/Layout.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Layout.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Menu.hs b/lib/NanoUI/Widgets/Menu.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Menu.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Node.hs b/lib/NanoUI/Widgets/Node.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Node.hs @@ -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 () diff --git a/lib/NanoUI/Widgets/NumericInput.hs b/lib/NanoUI/Widgets/NumericInput.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/NumericInput.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Overlay.hs b/lib/NanoUI/Widgets/Overlay.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Overlay.hs @@ -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 diff --git a/lib/NanoUI/Widgets/PaneGrid.hs b/lib/NanoUI/Widgets/PaneGrid.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/PaneGrid.hs @@ -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)} diff --git a/lib/NanoUI/Widgets/Popup.hs b/lib/NanoUI/Widgets/Popup.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Popup.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Radio.hs b/lib/NanoUI/Widgets/Radio.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Radio.hs @@ -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) diff --git a/lib/NanoUI/Widgets/RichText.hs b/lib/NanoUI/Widgets/RichText.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/RichText.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Select.hs b/lib/NanoUI/Widgets/Select.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Select.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Slider.hs b/lib/NanoUI/Widgets/Slider.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Slider.hs @@ -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) diff --git a/lib/NanoUI/Widgets/SplitPane.hs b/lib/NanoUI/Widgets/SplitPane.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/SplitPane.hs @@ -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) diff --git a/lib/NanoUI/Widgets/Table.hs b/lib/NanoUI/Widgets/Table.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Table.hs @@ -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 + ] diff --git a/lib/NanoUI/Widgets/Tabs.hs b/lib/NanoUI/Widgets/Tabs.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Tabs.hs @@ -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) diff --git a/lib/NanoUI/Widgets/TextArea.hs b/lib/NanoUI/Widgets/TextArea.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextArea.hs @@ -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 diff --git a/lib/NanoUI/Widgets/TextBuffer.hs b/lib/NanoUI/Widgets/TextBuffer.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextBuffer.hs @@ -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)) diff --git a/lib/NanoUI/Widgets/TextCommand.hs b/lib/NanoUI/Widgets/TextCommand.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextCommand.hs @@ -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) + diff --git a/lib/NanoUI/Widgets/TextCommon.hs b/lib/NanoUI/Widgets/TextCommon.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextCommon.hs @@ -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)) diff --git a/lib/NanoUI/Widgets/TextEditor.hs b/lib/NanoUI/Widgets/TextEditor.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextEditor.hs @@ -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 diff --git a/lib/NanoUI/Widgets/TextField.hs b/lib/NanoUI/Widgets/TextField.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextField.hs @@ -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 diff --git a/lib/NanoUI/Widgets/TextInput.hs b/lib/NanoUI/Widgets/TextInput.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/TextInput.hs @@ -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 diff --git a/lib/NanoUI/Widgets/Tree.hs b/lib/NanoUI/Widgets/Tree.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Widgets/Tree.hs @@ -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) diff --git a/nano-ui.cabal b/nano-ui.cabal new file mode 100644 --- /dev/null +++ b/nano-ui.cabal @@ -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 diff --git a/test/NanoUI/TextBufferSpec.hs b/test/NanoUI/TextBufferSpec.hs new file mode 100644 --- /dev/null +++ b/test/NanoUI/TextBufferSpec.hs @@ -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) diff --git a/test/inspection/Inspection.hs b/test/inspection/Inspection.hs new file mode 100644 --- /dev/null +++ b/test/inspection/Inspection.hs @@ -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` ''(,,,) diff --git a/test/integration/Cases.hs b/test/integration/Cases.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases.hs @@ -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 diff --git a/test/integration/Cases/Animation.hs b/test/integration/Cases/Animation.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Animation.hs @@ -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) diff --git a/test/integration/Cases/Atlas.hs b/test/integration/Cases/Atlas.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Atlas.hs @@ -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 diff --git a/test/integration/Cases/Cache.hs b/test/integration/Cases/Cache.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Cache.hs @@ -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 diff --git a/test/integration/Cases/Combo.hs b/test/integration/Cases/Combo.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Combo.hs @@ -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 diff --git a/test/integration/Cases/ContextMenu.hs b/test/integration/Cases/ContextMenu.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/ContextMenu.hs @@ -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)) diff --git a/test/integration/Cases/CustomWidget.hs b/test/integration/Cases/CustomWidget.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/CustomWidget.hs @@ -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)) diff --git a/test/integration/Cases/Damage.hs b/test/integration/Cases/Damage.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Damage.hs @@ -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 diff --git a/test/integration/Cases/Demo.hs b/test/integration/Cases/Demo.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Demo.hs @@ -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 diff --git a/test/integration/Cases/Grid.hs b/test/integration/Cases/Grid.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Grid.hs @@ -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 diff --git a/test/integration/Cases/HostDraw.hs b/test/integration/Cases/HostDraw.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/HostDraw.hs @@ -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 diff --git a/test/integration/Cases/Keyboard.hs b/test/integration/Cases/Keyboard.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Keyboard.hs @@ -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 diff --git a/test/integration/Cases/Modal.hs b/test/integration/Cases/Modal.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Modal.hs @@ -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 diff --git a/test/integration/Cases/NoThunks.hs b/test/integration/Cases/NoThunks.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/NoThunks.hs @@ -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 diff --git a/test/integration/Cases/NumericInput.hs b/test/integration/Cases/NumericInput.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/NumericInput.hs @@ -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 diff --git a/test/integration/Cases/PointerRelease.hs b/test/integration/Cases/PointerRelease.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/PointerRelease.hs @@ -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) diff --git a/test/integration/Cases/RichText.hs b/test/integration/Cases/RichText.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/RichText.hs @@ -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) diff --git a/test/integration/Cases/Runner.hs b/test/integration/Cases/Runner.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Runner.hs @@ -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 ()) diff --git a/test/integration/Cases/SIMD.hs b/test/integration/Cases/SIMD.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/SIMD.hs @@ -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) diff --git a/test/integration/Cases/Scroll.hs b/test/integration/Cases/Scroll.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Scroll.hs @@ -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) diff --git a/test/integration/Cases/Select.hs b/test/integration/Cases/Select.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Select.hs @@ -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) diff --git a/test/integration/Cases/Shaping.hs b/test/integration/Cases/Shaping.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Shaping.hs @@ -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) diff --git a/test/integration/Cases/State.hs b/test/integration/Cases/State.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/State.hs @@ -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) diff --git a/test/integration/Cases/Styling.hs b/test/integration/Cases/Styling.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Styling.hs @@ -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) diff --git a/test/integration/Cases/Svg.hs b/test/integration/Cases/Svg.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Svg.hs @@ -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 = + "\ + \" + 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 = + "\ + \" + 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 = "" + 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 "")) + +-- | 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 "") + 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) diff --git a/test/integration/Cases/Table.hs b/test/integration/Cases/Table.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Table.hs @@ -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]) + diff --git a/test/integration/Cases/Tabs.hs b/test/integration/Cases/Tabs.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Tabs.hs @@ -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)) diff --git a/test/integration/Cases/TextInput.hs b/test/integration/Cases/TextInput.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/TextInput.hs @@ -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) diff --git a/test/integration/Cases/Tooltip.hs b/test/integration/Cases/Tooltip.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Tooltip.hs @@ -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)) diff --git a/test/integration/Cases/Window.hs b/test/integration/Cases/Window.hs new file mode 100644 --- /dev/null +++ b/test/integration/Cases/Window.hs @@ -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 diff --git a/test/integration/Main.hs b/test/integration/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/Main.hs @@ -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 + ]