diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,52 @@ # Revision history for reflex-vty +## 1.0.0.0 + +* *Breaking change*: Add `HasColorProfile` class (with `colorProfile`/`localColorProfile` and a `ColorProfileReader` transformer) to `Reflex.Vty.Widget`. Widgets can call `colorProfile` to make decisions based on terminal capability. +* *Breaking change*: `CheckboxConfig._checkboxConfig_attributes` removed; `checkbox` reads from `HasTheme`. +* *Breaking change*: `HasDisplayRegion` now has `askViewport` and `localLayoutRegion` methods, separating layout height (inflated inside `scrollable`) from viewport height (real terminal size). Rendering widgets use `viewportWidth`/`viewportHeight`; layout system uses `displayWidth`/`displayHeight`. +* *Breaking change*: `HasTheme` now has a structured `Theme` record (in `Reflex.Vty.Theme`) instead of `Behavior t V.Attr`. Use `themeAttr` to get the `V.Attr`, or `theme` for the full record. +* *Breaking change*: `Reflex.Vty.Style.render` border attr now inherits from the content `baseAttr` instead of `transparentAttr`, so borders pick up themed foreground/background unless `withBorderForeground`/`withBorderBackground` is explicitly set. +* *Breaking change*: `Reflex.Vty.Style` re-exports color constants (`red`/`yellow`/`white`/etc.) from `Reflex.Vty`. +* *Breaking change*: `ScrollableConfig` has a new field `_scrollableConfig_scrollbarVisibility :: ScrollbarVisibility`. +* *Breaking change*: `TextInputConfig` has a new field, `_textInputConfig_alignment :: TextAlignment`, controlling how entered text is aligned within the input region. `def` uses `TextAlignment_Left`. +* *Breaking change*: `boxTitle` now takes a `Behavior t TextAlignment` as its first argument, controlling title alignment within the top border. Pass `pure TextAlignment_Center` to preserve the old behavior. `box` and `boxStatic` are unchanged. +* *Breaking change*: `scrollable` and `scrollableText` now require `PerformEvent t m`, `TriggerEvent t m`, and `MonadIO (Performable m)` constraints (needed for `ScrollbarWhileScrolling` debounce). +* *Breaking change*: `Reflex.Vty.Host.runVtyAppWithHandle`, `runVtyApp`, and `Reflex.Vty.Widget.mainWidget`/`mainWidgetWithHandle` now take a `VtyAppConfig` as their first argument. Use `def` (a `Default` instance) or `defaultVtyAppConfig` for the defaults. `_vtyConfig_eventQueueCapacity` configures the bounded event-queue capacity used to backpressure fast external producers. +* *Breaking change*: `Reflex.Vty.Widget.Input.Mouse.Drag` replaces the `_drag_end :: Bool` field with `_drag_state :: DragState`, where `DragState` is `DragStart | Dragging | DragEnd`. This distinguishes the start of a drag from its continuation ([#87](https://github.com/reflex-frp/reflex-vty/issues/87)). Migrate `_drag_end d` to `_drag_state d == DragEnd`. The pure state machine is now exposed as `stepDrag` for testing. +* Add `Reflex.Vty.Canvas` module: per-cell compositing with transparency. `Canvas` type (sparse `Map` of cells), `placeCanvas`, `translate`, `stack`, `imageToCanvas`/`canvasToImage` conversions. +* Add `Reflex.Vty.ColorProfile` module: `ColorProfile` datatype (`TrueColor`/`Ansi256`/`Ansi16`/`Ascii`/`NoTTY`), `detectColorProfile`/`colorProfileFromVty` to read the terminal's capability from vty handle, `convertColor` for downsampling, and `applyProfile` to downsample an entire `V.Attr` (resets colors/style to `Default` for `Ascii`/`NoTTY`). +* Add `Reflex.Vty.Color` module: `RGB` color type with `darken`, `lighten`, `complementary`, `mix`, `alpha` operations; `Gradient1D` (n-stop linear interpolation) and `Gradient2D` (bilinear corner interpolation); `toRGB`/`fromRGB` conversions to/from vty `Color`. +* Add `Reflex.Vty.Style.mergeAttr`: overlay one `V.Attr` on another, where `SetTo` fields take precedence and `Default`/`KeepCurrent` fall through. +* Add `Reflex.Vty.Style` border presets: `innerHalfBorder` (▀▄▌▐), `outerHalfBlockBorder` (▔▁▏▕). +* Add `Reflex.Vty.Style` image composition: `joinHorizontal`, `joinVertical`, `placeHorizontal`, `placeVertical`, `place`. +* Add `Reflex.Vty.Style` setters: `withTransform` (text transform), `withTabWidth` (tab expansion), `withMarginBackground` (colored margin), `withInline` (skip margin/padding/border), `withColorWhitespace` (toggle fill coloring), `withBorderTopForeground`/`withBorderBottomBackground`/etc (per-side border colors, 8 setters). +* Add `Reflex.Vty.Style` text utilities: `truncateWith` (ellipsis truncation respecting display width), `textHeight`, `textSize`. +* Add `Reflex.Vty.Style`: Lip Gloss-inspired declarative styling. +* Add `Reflex.Vty.Theme.darkTheme`. +* Add `Reflex.Vty.Theme` presets: `charmTheme`, `draculaTheme`, `nordTheme`, `zenburnTheme`, `gruvboxTheme`. +* Add `Reflex.Vty.Widget.Box.alignText`, a general-purpose text alignment function. +* Add `Reflex.Vty.Widget.Text.textWithAlignment`, an alignable version of `text`. `text` is now a synonym for `textWithAlignment TextAlignment_Left`. +* Add visual scrollbar to `Reflex.Vty.Widget.Scroll.scrollable` with four visibility modes: `ScrollbarAlways` (gutter + thumb), `ScrollbarThumbOnly` (thumb only), `ScrollbarWhileScrolling` (thumb appears while scrolling, hides via `debounce`), `ScrollbarHidden`. Default is `ScrollbarThumbOnly`. Controlled via `_scrollableConfig_scrollbarVisibility` on `ScrollableConfig`. +* Change `Reflex.Vty.Theme.darkTheme`: specify colors directly (`green` on `black`) instead of using `reverseVideo`. +* Fix `Reflex.Vty.Style.measure`: uses `textWidth` (wcwidth) and splits on newlines for correct multi-line and wide-character dimensions. +* Fix `Reflex.Vty.Style.render`: now handles multi-line text via `V.vertCat` per-line rendering. +* Fix `Reflex.Vty.Widget.Input.link`: now uses `_theme_link` on ambient `themeAttr` instead of `V.defAttr` to preserve themed background. +* Fix `Reflex.Vty.Widget.Text.richText`: now merges config attrs on `themeAttr` via `mergeAttr`, so `RichTextConfig def` inherits the ambient theme. +* Fix `textButton` centering: now uses `textWithAlignment TextAlignment_Center`. +* Fix `textInput` cursor: uses `_theme_textInputCursor` instead of hardcoded `reverseVideo`. +* Fix `Data.Text.Zipper.displayLinesWithAlignment`: the cursor is now rendered as a blank highlighted cell when it sits past the last character of a line or on an empty line. +* Fix space leak in `Reflex.Vty.Host.runVtyAppWithHandle`: an application that fired external triggers (e.g. a hot `performEventAsync` callback) faster than the host could process would grow the host's event channel without limit. The host now backpressures producers via a bounded, closeable event queue, and drains every available batch each frame (firing each in its own Reflex frame, redrawing once), so memory is bounded and no event occurrences are dropped. The bounded capacity is configurable via the new `VtyAppConfig` (see the breaking-change entry above; default 4096). +* Behavior change: external event triggers (`performEventAsync`, `newTriggerEvent`, etc.) may now block when the host's event queue is full, throttling a producer that fires faster than the host can process to the host's own rate. This is the intended flow-control; shutdown closes the queue so any blocked producer is released. +* Debounce terminal resize events (50ms) to reduce lag and flicker during window drag. +* Enable terminal focus tracking mode by default. Add `gainedFocus` and `lostFocus` helpers to `Reflex.Vty.Widget`. +* Enable bracketed paste by default. Add `paste` helper to `Reflex.Vty.Widget`. `textInput` now handles paste events. +* Add `mousePosition` helper to `Reflex.Vty.Widget.Input.Mouse` — tracks last known mouse coordinates from click/release events. True hover (motion without button) deferred — requires terminal mode 1003 which vty does not expose. +* Add terminal cursor control: `CursorStyle`, `CursorVisibility`, `CursorState`, and the `HasCursor` capability with `setCursor`/`tellCursor` helpers. +* Add alternate screen support: `ScreenMode`, `setScreenMode`, and the `HasScreenMode` capability with `tellScreenMode`/`enterAlternateScreen`/`exitAlternateScreen` helpers. The host restores normal screen on shutdown. +* *Breaking change*: `VtyApp` now takes a third argument, `Event t Signal`, exposing POSIX signals (SIGINT, SIGTERM, SIGHUP). SIGINT and SIGTERM automatically trigger clean shutdown, replacing the old Ctrl-C key detection. +* Install POSIX signal handlers (SIGINT, SIGTERM, SIGHUP) in `runVtyAppWithHandle`. Add `unix` dependency. + ## 0.6.2.1 * Update dependency version bounds diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,56 @@ +
+ # reflex-vty -[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-vty.svg)](https://hackage.haskell.org/package/reflex-vty) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex-vty/blob/master/LICENSE) +**Build terminal user interfaces with functional reactive programming.** -Build terminal applications using functional reactive programming (FRP) with [Reflex FRP](https://reflex-frp.org). +reflex-vty provides a [Reflex FRP](https://reflex-frp.org) host and a library of reactive widgets for [Vty](https://hackage.haskell.org/package/vty) terminal applications: layout, text input and editing, boxes, scrolling, mouse support, focus management, and theming. -![Example Animation](https://i.imgur.com/FULQNtu.gif) +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-vty.svg)](https://hackage.haskell.org/package/reflex-vty) [![Github CI](https://github.com/reflex-frp/reflex-vty/actions/workflows/haskell.yml/badge.svg)](https://github.com/reflex-frp/reflex-vty/actions) [![Obsidian](https://img.shields.io/badge/Obsidian-Systems-white)](https://obsidian.systems) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) -Feature requests, pull requests, and other feedback are welcome and appreciated (see the [contribution guide](CONTRIBUTING.md)). This library -is still experimental, so big changes are possible! +reflex-vty example walkthrough: gradient menu, to-do list, scrollbar modes, and styling showcase + +
+ +### A minimal app + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Reflex.Vty + +main :: IO () +main = mainWidget def $ do + text "Hello, reflex-vty! Press Ctrl+C to quit." + ctrlc +``` + +`mainWidget` takes a `VtyAppConfig` (`def` for the defaults) and runs a widget until the `Event t ()` it returns fires. Here that is `ctrlc`, which fires when the user presses Ctrl+C. Docs are available on [Hackage](https://hackage.haskell.org/package/reflex-vty/docs/Reflex-Vty.html). + +### Features + +- **Layout**: arrange widgets into rows and columns (`tile` / `grout`) with fixed or proportional (stretch) size constraints. +- **Focus**: tab-cycling focus management across the focusable widgets in a layout (`tabNavigation`). +- **Text**: word-wrapped text display, rich text with per-span attributes, and single- or multi-line text input backed by a zipper that handles wide characters, tabs, and wrapping. +- **Inputs**: clickable buttons, hyperlinks, and checkboxes. +- **Boxes**: single, thick, double, rounded, ASCII, inner-half, and outer-half border styles, with optional titles and horizontal rules. +- **Scrolling**: scrollable containers with programmatic scrolling, auto-scroll-to-bottom mode, and a visual scrollbar with four visibility modes (always, thumb-only, while-scrolling, hidden). +- **Split panes**: fixed horizontal and vertical splits, plus a mouse-draggable splitter you can resize at runtime (`splitVDrag`). +- **Mouse**: button clicks, drags (with from/to/button/modifier tracking), scroll-wheel events, and last-known mouse-position tracking. +- **Keyboard**: individual key and key-combo events, plus input filtering. +- **Runtime**: alternate-screen mode, terminal cursor control (shape, visibility, and position), bracketed paste, terminal focus tracking, resize, and POSIX signal handling. +- **Theming**: a `Theme` record with presets (default, dark, charm, dracula, nord, zenburn, gruvbox). Widgets inherit the ambient theme and can override locally. +- **Declarative styling**: Lip Gloss-inspired `Style` type with foreground/background colors, text attributes (bold/italic/underline/etc.), padding, margin, borders with per-side colors, width/height constraints, alignment, text transforms, tab expansion, inline mode, whitespace coloring, and border presets. +- **Color**: `RGB` color type, operations (`darken`, `lighten`, `complementary`, `mix`, `alpha`), and gradients (`Gradient1D`, `Gradient2D`). +- **Compositing**: `Reflex.Vty.Canvas` module with per-cell transparency for overlays and layered rendering. +- **Image composition**: `joinHorizontal`/`joinVertical`/`place` utilities for composing rendered images. +- **Color profiles**: automatic terminal color-capability detection (`TrueColor`/`Ansi256`/`Ansi16`/`Ascii`/`NoTTY`) with downsampling. + +Run the bundled demo with `cabal run example` to see many of these in action: a text editor, a to-do list, scrollable text, clickable buttons, a live CPU-usage display with a true-color gradient bar, a scrollbar-modes demo, a terminal-cursor demo, and a little styling showcase featuring gradients, color operations, a canvas overlay, border presets, theming, and color-profile downsampling. + +Feature requests, pull requests, and other feedback are welcome and appreciated (see the [contribution guide](CONTRIBUTING.md)). This library is still experimental, so big changes are possible. + ### How to Build #### With reflex-platform @@ -20,22 +63,22 @@ ``` From within the nix-shell you can: -* Run the example: `cabal repl example` +* Run the example: `cabal run example` * Load the library in the repl: `cabal repl reflex-vty` * Build the example executable: `cabal build example` * Build the docs: `cabal haddock` -* Run ghcid for immediate compiler feedback when you save a .hs file: `ghcid -c "cabal repl reflex-vty --ghc-options=-Wall"` +* Run ghcid for immediate compiler feedback when you save a .hs file: `ghcid -c "cabal repl library:reflex-vty executable:example test:reflex-vty-test --ghc-options=-Wall" -o ghcid-output.txt` * etc. ##### Selecting a compiler -When entering the nix-shell, you can select from the following compilers: ghc-8.10.7 and ghc-9.4.3. By default, ghc-8.10.7 is selected. To enter a shell with ghc-9.4.3, run: +`nix-shell` defaults to GHC 9.8. The other compilers defined in `release.nix` are `ghc94`, `ghc96`, and `ghc98`. To enter a shell with one of them, pass it as the `compiler` argument: ```bash -nix-shell --argstr compiler ghc943 +nix-shell --argstr compiler ghc96 ``` -You may need to run `cabal clean` and `cabal configure -w ghc-9.4.3` if you were previously working on the project with a different compiler. +If you were previously building with a different compiler, you may need to run `cabal clean` first. #### With cabal @@ -46,8 +89,21 @@ ```bash # nix-shell -p cabal-install binutils icu # for nix users -cabal new-configure -cabal new-build # to build the library and example -cabal new-repl # to enter a repl for the library -cabal new-repl example # to enter a repl for the example executable +cabal build # to build the library, example, and test suite +cabal repl # to enter a multi-repl covering all components +cabal repl example # to enter a repl for the example executable only ``` + +## About Obsidian Systems + +reflex-vty is built and maintained by **[Obsidian Systems](https://obsidian.systems)**. We provide frontier engineering for high-assurance systems: we build production software in Haskell and Nix, and we're long-time stewards of open-source tooling like [Obelisk](https://github.com/obsidiansystems/obelisk), [Reflex](https://reflex-frp.org/), and [nix-thunk](https://github.com/obsidiansystems/nix-thunk). + +If you're working with Reflex, terminal or web UIs in Haskell, or Nix and want a partner to help design, build, or ship it, we'd love to hear from you. + +- Website: +- Blog: +- GitHub: + +## License + +reflex-vty is released under the [BSD-3-Clause License](LICENSE), © 2018 Obsidian Systems LLC. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/reflex-vty.cabal b/reflex-vty.cabal --- a/reflex-vty.cabal +++ b/reflex-vty.cabal @@ -1,24 +1,25 @@ +cabal-version: 3.0 name: reflex-vty -version: 0.6.2.1 +version: 1.0.0.0 synopsis: Reflex FRP host and widgets for VTY applications description: Build terminal applications using functional reactive programming (FRP) with Reflex FRP (). . <> -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Obsidian Systems LLC maintainer: maintainer@obsidian.systems copyright: 2020 Obsidian Systems LLC category: FRP build-type: Simple -cabal-version: 1.18 extra-source-files: README.md +extra-doc-files: + doc/tasks.png ChangeLog.md -extra-doc-files: doc/tasks.png tested-with: - GHC ==8.10.7 || ==9.4.5 || ==9.6.1 || ==9.8.4 || ==9.10.1 || == 9.12.2 + GHC ==9.8.4 || ==9.10.1 || == 9.12.2 source-repository head type: git @@ -26,7 +27,12 @@ library exposed-modules: Reflex.Vty + , Reflex.Vty.Canvas + , Reflex.Vty.Color + , Reflex.Vty.ColorProfile , Reflex.Vty.Host + , Reflex.Vty.Style + , Reflex.Vty.Theme , Reflex.Vty.Widget , Reflex.Vty.Widget.Box , Reflex.Vty.Widget.Input @@ -37,11 +43,12 @@ , Reflex.Vty.Widget.Split , Reflex.Vty.Widget.Text , Data.Text.Zipper - , Reflex.Spider.Orphans , Control.Monad.NodeId + other-modules: Reflex.Vty.Host.Trigger build-depends: base >= 4.10.0 && < 4.22, bimap >= 0.3.3 && < 0.6, + bytestring >= 0.12.1 && < 0.13, containers >= 0.5.0 && < 0.8, mtl >= 2.2.2 && < 2.4, transformers >= 0.5.5 && < 0.7, @@ -58,6 +65,7 @@ ref-tf >= 0.4.0 && < 0.6, reflex >= 0.9.2 && < 1, time >= 1.8.0 && < 1.15, + unix >= 2.7 && < 2.10, vty >= 6.0 && < 6.5, vty-crossplatform >= 0.1 && < 0.5 hs-source-dirs: src @@ -94,6 +102,11 @@ TypeOperators TypeFamilies +flag leaktest + description: Build the space-leak profiling repro (src-bin/leaktest.hs) + manual: True + default: False + executable example hs-source-dirs: src-bin main-is: example.hs @@ -139,6 +152,24 @@ TypeApplications TypeFamilies +executable leaktest + if !flag(leaktest) + buildable: False + hs-source-dirs: src-bin + main-is: leaktest.hs + ghc-options: -threaded -Wall -rtsopts + build-depends: + base, + async >= 2.2.6 && < 2.3, + reflex, + reflex-vty, + text, + transformers, + vty + default-language: Haskell2010 + default-extensions: + LambdaCase + OverloadedStrings test-suite reflex-vty-test hs-source-dirs: test @@ -147,12 +178,28 @@ ghc-options: -threaded other-modules: Data.Text.ZipperSpec + Reflex.Vty.CanvasSpec + Reflex.Vty.ColorProfileSpec + Reflex.Vty.ColorSpec + Reflex.Vty.HostSpec + Reflex.Vty.StyleSpec + Reflex.Vty.StyleJoinSpec + Reflex.Vty.Test.Snapshot + Reflex.Vty.Test.SnapshotSpec + Reflex.Vty.Test.GoldenSpec + Reflex.Vty.Widget.BoxSpec + Reflex.Vty.Widget.CursorSpec + Reflex.Vty.Widget.MouseSpec + Reflex.Vty.Widget.ScrollSpec build-depends: base, reflex, containers, + directory, + filepath, reflex-vty, text, extra, - hspec >= 2.7 && < 2.12 + hspec >= 2.7 && < 2.12, + vty default-language: Haskell2010 diff --git a/src-bin/Example/CPU.hs b/src-bin/Example/CPU.hs --- a/src-bin/Example/CPU.hs +++ b/src-bin/Example/CPU.hs @@ -1,34 +1,34 @@ -{-| - Description: A CPU usage indicator --} +-- | +-- Description: A CPU usage indicator module Example.CPU where import Control.Exception import Control.Monad.Fix import Control.Monad.IO.Class import Data.Ratio +import qualified Data.Text as T import Data.Time import Data.Word -import qualified Data.Text as T import qualified Graphics.Vty as V +import Reflex import Text.Printf -import Reflex +import Data.Text.Zipper (TextAlignment (..)) import Reflex.Vty -- | Each constructor represents a cpu statistic column as presented in @/proc/stat@ data CpuStat - = CpuStat_User - | CpuStat_Nice - | CpuStat_System - | CpuStat_Idle - | CpuStat_Iowait - | CpuStat_Irq - | CpuStat_Softirq - | CpuStat_Steal - | CpuStat_Guest - | CpuStat_GuestNice - deriving (Show, Read, Eq, Ord, Enum, Bounded) + = CpuStat_User + | CpuStat_Nice + | CpuStat_System + | CpuStat_Idle + | CpuStat_Iowait + | CpuStat_Irq + | CpuStat_Softirq + | CpuStat_Steal + | CpuStat_Guest + | CpuStat_GuestNice + deriving (Bounded, Enum, Eq, Ord, Read, Show) -- | Read @/proc/stat@ getCpuStat :: IO (Maybe (CpuStat -> Word64)) @@ -85,7 +85,6 @@ -- > ║█████████████████████████████║ -- > ║█████████████████████████████║ -- > ╚═════════════════════════════╝ --- cpuStats :: ( Reflex t , MonadFix m @@ -100,17 +99,19 @@ , HasLayout t m , HasFocus t m , HasInput t m - , HasFocusReader t m, HasTheme t m + , HasFocusReader t m + , HasTheme t m ) => m () cpuStats = do tick <- tickLossy 0.25 =<< liftIO getCurrentTime cpuStat :: Event t (Word64, Word64) <- fmap (fmapMaybe id) $ - performEvent $ ffor tick $ \_ -> do - get <- liftIO getCpuStat - pure $ case get of - Nothing -> Nothing - Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats) + performEvent $ + ffor tick $ \_ -> do + get <- liftIO getCpuStat + pure $ case get of + Nothing -> Nothing + Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats) active <- foldDyn cpuPercentStep ((0, 0), 0) cpuStat let pct = fmap snd active chart pct @@ -123,84 +124,51 @@ , HasImageWriter t m , HasInput t m , HasDisplayRegion t m - , HasFocusReader t m, HasTheme t m + , HasFocusReader t m + , HasTheme t m ) => Dynamic t (Ratio Word64) -> m () chart pct = do - let title = ffor pct $ \x -> mconcat - [ " CPU Usage: " - , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int)) - , "% " - ] - boxTitle (pure doubleBoxStyle) (current title) $ col $ do - grout flex blank - dh <- displayHeight - let heights = calcRowHeights <$> dh <*> pct - quarters = fst <$> heights - eighths = snd <$> heights - eighthRow = ffor eighths $ \x -> if x == 0 then 0 else 1 - grout (fixed eighthRow) $ fill' (current $ eighthBlocks <$> eighths) $ current $ - ffor quarters $ \q -> - if | _quarter_fourth q > 0 -> red - | _quarter_third q > 0 -> orange - | _quarter_second q > 0 -> yellow - | otherwise -> white - grout (fixed $ _quarter_fourth <$> quarters) $ fill' (pure '█') (pure red) - grout (fixed $ _quarter_third <$> quarters) $ fill' (pure '█') (pure orange) - grout (fixed $ _quarter_second <$> quarters) $ fill' (pure '█') (pure yellow) - grout (fixed $ _quarter_first <$> quarters) $ fill' (pure '█') (pure white) - where - -- Calculate number of full rows, height of partial row - calcRowHeights :: Int -> Ratio Word64 -> (Quarter Int, Int) - calcRowHeights h r = - let (full, leftovers) = divMod (numerator r * fromIntegral h) (denominator r) - partial = ceiling $ 8 * (leftovers % denominator r) - quarter = ceiling $ fromIntegral h / (4 :: Double) - n = fromIntegral full - in if | n <= quarter -> - (Quarter n 0 0 0, partial) - | n <= (2 * quarter) -> - (Quarter quarter (n - quarter) 0 0, partial) - | n <= (3 * quarter) -> - (Quarter quarter quarter (n - (2 * quarter)) 0, partial) - | otherwise -> - (Quarter quarter quarter quarter (n - (3 * quarter)), partial) - fill' bc attr = do - dw <- displayWidth + let title = ffor pct $ \x -> + mconcat + [ " CPU Usage: " + , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int)) + , "% " + ] + boxTitle (pure TextAlignment_Center) (pure doubleBoxStyle) (current title) $ + grout flex $ do dh <- displayHeight - let fillImg = - (\w h c a -> [V.charFill a c w h]) - <$> current dw - <*> current dh - <*> bc - <*> attr - tellImages fillImg - color :: Int -> Int -> Int -> V.Color - color = V.rgbColor - red = V.withForeColor V.defAttr $ color 255 0 0 - orange = V.withForeColor V.defAttr $ color 255 165 0 - yellow = V.withForeColor V.defAttr $ color 255 255 0 - white = V.withForeColor V.defAttr $ color 255 255 255 - -data Quarter a = Quarter - { _quarter_first :: a - , _quarter_second :: a - , _quarter_third :: a - , _quarter_fourth :: a - } + dw <- displayWidth + let grad = gradient1D [(0.0, RGB 50 205 50), (0.4, RGB 255 220 0), (0.7, RGB 255 140 0), (1.0, RGB 220 40 40)] + chartImgs h w r = + let filledF = fromIntegral (numerator r) * fromIntegral h / fromIntegral (denominator r) :: Double + filled = min h $ floor filledF + frac = filledF - fromIntegral filled + partial = if frac > 0 && filled < h then ceiling (8 * frac) :: Int else 0 + rowColor i = V.withForeColor V.defAttr $ fromRGB $ sampleGradient1D grad (fromIntegral i / fromIntegral (max 1 (h - 1))) + fullImgs = + [ V.translate 0 (h - 1 - i) $ V.charFill (rowColor i) '█' w 1 + | i <- [0 .. filled - 1] + ] + partialImg = + if partial > 0 && filled < h + then [V.translate 0 (h - 1 - filled) $ V.text' (rowColor filled) (T.replicate w (T.singleton $ eighthBlocks partial))] + else [] + in fullImgs ++ partialImg + tellImages $ chartImgs <$> current dh <*> current dw <*> current pct eighthBlocks :: (Eq a, Num a, Ord a) => a -> Char eighthBlocks n = if - | n <= 0 -> ' ' - | n == 1 -> '▁' - | n == 2 -> '▂' - | n == 3 -> '▃' - | n == 4 -> '▄' - | n == 5 -> '▅' - | n == 6 -> '▆' - | n == 7 -> '▇' - | otherwise -> '█' + | n <= 0 -> ' ' + | n == 1 -> '▁' + | n == 2 -> '▂' + | n == 3 -> '▃' + | n == 4 -> '▄' + | n == 5 -> '▅' + | n == 6 -> '▆' + | n == 7 -> '▇' + | otherwise -> '█' -- | Determine the current percentage usage according to this algorithm: -- diff --git a/src-bin/example.hs b/src-bin/example.hs --- a/src-bin/example.hs +++ b/src-bin/example.hs @@ -10,14 +10,15 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Zipper as TZ import Data.Time (getCurrentTime) import qualified Graphics.Vty as V import Reflex import Reflex.Network -import Reflex.Vty +import Data.Text.Zipper (TextAlignment (..)) +import qualified Data.Text.Zipper as TZ import Example.CPU +import Reflex.Vty type VtyExample t m = ( MonadFix m @@ -29,6 +30,9 @@ , HasFocus t m , HasFocusReader t m , HasTheme t m + , HasColorProfile t m + , HasCursor t m + , HasScreenMode t m ) type Manager t m = @@ -36,13 +40,16 @@ , HasFocus t m ) -data Example = Example_TextEditor - | Example_Todo - | Example_ScrollableTextDisplay - | Example_ClickButtonsGetEmojis - | Example_CPUStat - | Example_Scrollable - deriving (Show, Read, Eq, Ord, Enum, Bounded) +data Example + = Example_TextEditor + | Example_Todo + | Example_ScrollableTextDisplay + | Example_ClickButtonsGetEmojis + | Example_CPUStat + | Example_Scrollbar + | Example_Cursor + | Example_Showcase + deriving (Bounded, Enum, Eq, Ord, Read, Show) withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ()) withCtrlC f = do @@ -52,39 +59,112 @@ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just () _ -> Nothing -darkTheme :: V.Attr -darkTheme = V.Attr { - V.attrStyle = V.SetTo V.standout - , V.attrForeColor = V.SetTo V.black - , V.attrBackColor = V.SetTo V.green - , V.attrURL = V.Default -} +-- * Shared styling helpers +-- | The brand accent color (cyan), matching the bright end of 'brandGradient'. +accent :: Color +accent = rgbColor 0 200 230 + +-- | A pink → violet → cyan true-color gradient used for the brand banner. +brandGradient :: Gradient1D +brandGradient = + gradient1D + [ (0.0, RGB 255 64 160) + , (0.5, RGB 150 90 255) + , (1.0, RGB 0 200 230) + ] + +-- | Emit a single line of bold text whose characters are colored along a +-- horizontal 1D gradient. Shows off true-color 'Gradient1D' sampling. +gradientText + :: (Reflex t, HasImageWriter t m) + => Gradient1D -> Text -> m () +gradientText grad txt = tellImages $ pure [img] + where + cs = T.unpack txt + n = length cs + img = + V.horizCat + [ V.char (V.withStyle (V.withForeColor V.defAttr (fromRGB (sampleGradient1D grad p))) V.bold) c + | (i, c) <- zip [0 :: Int ..] cs + , let p = fromIntegral i / fromIntegral (max 1 (n - 1)) + ] + +-- | A line of text tinted with an accent foreground color (used for the +-- short instructional headers above each example). +accentText + :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) + => Color -> Text -> m () +accentText c t = + localTheme (const (pure (defTheme {_theme_default = withForeground c def}))) $ + text (pure t) + +-- | A titled box whose border and title are tinted with an accent color, +-- while its content stays in the default theme so body text remains +-- readable. +accentBox + :: ( MonadFix m + , MonadHold t m + , HasDisplayRegion t m + , HasImageWriter t m + , HasInput t m + , HasFocusReader t m + , HasTheme t m + ) + => Color -> BoxStyle -> Text -> m a -> m a +accentBox c style title child = + localTheme (const (pure (defTheme {_theme_default = withForeground c def}))) $ + boxTitle (pure TextAlignment_Center) (pure style) (pure title) $ + localTheme (const (pure defTheme)) child + +-- | A theme transformer that reverse-videos the default style while the +-- given dynamic is True. Used to highlight a focused widget (e.g. the +-- checkbox in a to-do row). +highlightFocus + :: Reflex t + => Dynamic t Bool -> Behavior t Theme -> Behavior t Theme +highlightFocus d thB = + (\th foc -> if foc then th {_theme_default = withReverse (_theme_default th)} else th) + <$> thB + <*> current d + main :: IO () -main = mainWidget $ withCtrlC $ do +main = mainWidget def $ withCtrlC $ do + enterAlternateScreen initManager_ $ do tabNavigation let gf = grout . fixed t = tile (fixed 3) - buttons = col $ do - gf 3 $ col $ do - gf 1 $ text "Select an example." - gf 1 $ text "Esc will bring you back here." - gf 1 $ text "Ctrl+c to quit." - a <- t $ textButtonStatic def "Todo List" - b <- t $ textButtonStatic def "Text Editor" - c <- t $ textButtonStatic def "Scrollable text display" - d <- t $ textButtonStatic def "Clickable buttons" - e <- t $ textButtonStatic def "CPU Usage" - f <- t $ textButtonStatic def "Scrollable" - return $ leftmost - [ Left Example_Todo <$ a - , Left Example_TextEditor <$ b - , Left Example_ScrollableTextDisplay <$ c - , Left Example_ClickButtonsGetEmojis <$ d - , Left Example_CPUStat <$ e - , Left Example_Scrollable <$ f - ] + buttons = do + (_, ev) <- + scrollable def $ + col $ do + gf 3 $ col $ do + gf 1 $ gradientText brandGradient "reflex-vty · functional reactive terminal UIs" + gf 1 $ text "Select an example." + gf 1 $ text "Esc brings you back here · Ctrl+C quits." + a <- t $ textButtonStatic def "Todo List" + b <- t $ textButtonStatic def "Text Editor" + c <- t $ textButtonStatic def "Scrollable text display" + d <- t $ textButtonStatic def "Clickable buttons" + e <- t $ textButtonStatic def "CPU Usage" + f <- t $ textButtonStatic def "Scrollbar modes" + g <- t $ textButtonStatic def "Cursor" + h <- t $ textButtonStatic def "Showcase" + pure + ( never + , leftmost + [ Left Example_Todo <$ a + , Left Example_TextEditor <$ b + , Left Example_ScrollableTextDisplay <$ c + , Left Example_ClickButtonsGetEmojis <$ d + , Left Example_CPUStat <$ e + , Left Example_Scrollbar <$ f + , Left Example_Cursor <$ g + , Left Example_Showcase <$ h + ] + ) + pure ev let escapable w = do void w i <- input @@ -97,60 +177,103 @@ Left Example_ScrollableTextDisplay -> escapable scrolling Left Example_ClickButtonsGetEmojis -> escapable easyExample Left Example_CPUStat -> escapable cpuStats - Left Example_Scrollable -> escapable scrollingWithLayout + Left Example_Scrollbar -> escapable scrollbarDemo + Left Example_Cursor -> escapable cursorDemo + Left Example_Showcase -> escapable showcaseDemo Right () -> buttons return () -scrollingWithLayout - :: forall t m. - ( VtyExample t m - , HasInput t m - , MonadHold t m - , Manager t m - , PostBuild t m - , MonadIO (Performable m) - , TriggerEvent t m - , PerformEvent t m - ) => m () -scrollingWithLayout = col $ do - (s, x) <- tile flex $ boxTitle (constant def) (constant "Tracks") $ scrollable def $ do - result <- do - forM_ [(0::Int)..10] $ \n -> do - tile (fixed 5) $ do - tile (fixed 4) $ textButtonStatic def $ T.pack (show n) - askRegion - pure (never, result) - grout (fixed 1) $ - text $ ("Total Lines: "<>) . T.pack . show <$> _scrollable_totalLines s - grout (fixed 1) $ - text $ ("Scroll Pos: "<>) . T.pack . show <$> _scrollable_scrollPosition s - grout (fixed 1) $ - text $ ("Scroll Height: "<>) . T.pack . show <$> _scrollable_scrollHeight s - pure () +scrollbarDemo :: (VtyExample t m, Manager t m, MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => m () +scrollbarDemo = col $ do + grout (fixed 1) $ accentText accent "Four scrollbar modes. Use arrow keys or mouse wheel to scroll each panel:" + grout flex $ row $ do + grout flex $ void $ sbPanel "Always" ScrollbarAlways + grout flex $ void $ sbPanel "Thumb Only" ScrollbarThumbOnly + grout flex $ void $ sbPanel "While Scrolling" ScrollbarWhileScrolling + grout flex $ void $ sbPanel "Hidden" ScrollbarHidden + where + sampleText = T.unlines $ map (\n -> "Line " <> T.pack (show n)) [(1 :: Int) .. 50] + sbPanel label vis = + boxTitle (pure TextAlignment_Center) (pure singleBoxStyle) (pure label) $ + scrollableText (def {_scrollableConfig_scrollbarVisibility = vis}) (constDyn sampleText) +-- * Terminal cursor demo +cursorDemo :: (VtyExample t m, Manager t m, MonadHold t m, PostBuild t m) => m () +cursorDemo = col $ do + grout (fixed 1) $ accentText accent "Arrows: move | s: style | v: visibility | f: alt-screen | Esc: back" + let styles = [CursorStyleBlock, CursorStyleUnderline, CursorStyleBar] + upE <- key V.KUp + downE <- key V.KDown + leftE <- key V.KLeft + rightE <- key V.KRight + sE <- key (V.KChar 's') + vE <- key (V.KChar 'v') + fE <- key (V.KChar 'f') + posDyn <- foldDyn move (0, 0) $ leftmost [upE, downE, leftE, rightE] + idxDyn <- foldDyn (\_ n -> (n + 1) `mod` length styles) 0 sE + visDyn <- foldDyn (\_ b -> not b) True vE + altDyn <- foldDyn (\_ b -> not b) True fE + tellScreenMode $ (\b -> if b then ScreenAlternate else ScreenNormal) <$> updated altDyn + let styleDyn = (styles !!) <$> idxDyn + cursorDyn = + (\(x, y) s v -> CursorState (if v then CursorVisible else CursorHidden) s (x, y)) + <$> posDyn + <*> styleDyn + <*> visDyn + setCursor cursorDyn + grout flex $ + text $ + current $ + ( \(x, y) s v a -> + "Position: " + <> T.pack (show x) + <> "," + <> T.pack (show y) + <> " | Style: " + <> T.pack (show s) + <> " | Visible: " + <> (if v then "on" else "off") + <> " | Alt-screen: " + <> (if a then "on" else "off") + ) + <$> posDyn + <*> styleDyn + <*> visDyn + <*> altDyn + where + move (k, _) (x, y) = case k of + V.KUp -> (x, max 0 (y - 1)) + V.KDown -> (x, y + 1) + V.KLeft -> (max 0 (x - 1), y) + V.KRight -> (x + 1, y) + _ -> (x, y) + -- * Mouse button and emojis example easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ()) easyExample = do row $ grout (fixed 39) $ col $ do - (a1,b1,c1) <- grout (fixed 3) $ row $ do + (a1, b1, c1) <- grout (fixed 3) $ row $ do a <- tile flex $ btn "POTATO" b <- tile flex $ btn "TOMATO" c <- tile flex $ btn "EGGPLANT" - return (a,b,c) - (a2,b2,c2) <- grout (fixed 3) $ row $ do + return (a, b, c) + (a2, b2, c2) <- grout (fixed 3) $ row $ do a <- tile flex $ btn "CHEESE" b <- tile flex $ btn "BEES" c <- tile flex $ btn "MY KNEES" - return (a,b,c) - (a3,b3,c3) <- grout (fixed 3) $ row $ do + return (a, b, c) + (a3, b3, c3) <- grout (fixed 3) $ row $ do a <- tile flex $ btn "TIME" b <- tile flex $ btn "RHYME" c <- tile flex $ btn "A BIG CRIME" - return (a,b,c) - tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do - outputDyn <- foldDyn (<>) "" $ mergeWith (<>) - [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"] + return (a, b, c) + tile (fixed 7) $ accentBox accent roundedBoxStyle "CLICK BUTTONS TO DRAW*" $ do + outputDyn <- + foldDyn (<>) "" $ + mergeWith + (<>) + [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"] text (current outputDyn) tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map." inp <- input @@ -159,12 +282,14 @@ _ -> Nothing where btn label = do - let cfg = def { _buttonConfig_focusStyle = pure doubleBoxStyle } + let cfg = def {_buttonConfig_focusStyle = pure doubleBoxStyle} buttonClick <- textButtonStatic cfg label - keyPress <- keyCombos $ Set.fromList - [ (V.KEnter, []) - , (V.KChar ' ', []) - ] + keyPress <- + keyCombos $ + Set.fromList + [ (V.KEnter, []) + , (V.KChar ' ', []) + ] pure $ leftmost [() <$ buttonClick, () <$ keyPress] -- * Task list example @@ -172,6 +297,7 @@ :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m) => m () taskList = col $ do + grout (fixed 1) $ accentText accent "To-Do · Tab to move · Ctrl+T toggles · Enter adds a task" let todos0 = [ Todo "Find reflex-vty" True , Todo "Become functional reactive" False @@ -187,13 +313,16 @@ { _todo_label :: Text , _todo_done :: Bool } - deriving (Show, Read, Eq, Ord) + deriving (Eq, Ord, Read, Show) data TodoOutput t = TodoOutput { _todoOutput_todo :: Dynamic t Todo , _todoOutput_delete :: Event t () , _todoOutput_height :: Dynamic t Int , _todoOutput_focusId :: FocusId + , _todoOutput_focused :: Dynamic t Bool + -- ^ Whether any element of this row (checkbox or text field) is focused. + -- Used to insert a newly added task directly beneath the active row. } todo @@ -201,38 +330,55 @@ => Todo -> m (TodoOutput t) todo t0 = row $ do - let toggleKeys = Set.fromList - [ (V.KChar ' ', [V.MCtrl]) - , (V.KChar '@', [V.MCtrl]) - ] + let toggleKeys = Set.singleton (V.KChar 't', [V.MCtrl]) anyChildFocused $ \focused -> do toggleE <- keyCombos toggleKeys filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do - rec let cfg = def - { _checkboxConfig_setValue = setVal - } - value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0 + rec -- Which sub-element of this row has focus: the row is focused + -- when either the checkbox or the text input is, so the + -- checkbox is focused if the row is focused and the text isn't. + textFocused <- isFocused fid + let cbFocused = (\f tf -> f && not tf) <$> focused <*> textFocused + -- A caret in a left gutter marks which to-do row is active. + grout (fixed 2) $ + tellImages $ + ffor (current focused) $ \f -> + [V.text' (V.withStyle (V.withForeColor V.defAttr accent) V.bold) (if f then "▸ " else " ")] + let cfg = + def + { _checkboxConfig_setValue = setVal + } + value <- + tile (fixed 4) $ + localTheme (highlightFocus cbFocused) $ + checkbox cfg $ + _todo_done t0 let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE (fid, (ti, d)) <- tile' flex $ do i <- input - v <- textInput $ def - { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 } + v <- + textInput $ + def + { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 + } let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i return (v, deleteSelf) - return $ TodoOutput - { _todoOutput_todo = Todo <$> _textInput_value ti <*> value - , _todoOutput_delete = d - , _todoOutput_height = _textInput_lines ti - , _todoOutput_focusId = fid - } + return $ + TodoOutput + { _todoOutput_todo = Todo <$> _textInput_value ti <*> value + , _todoOutput_delete = d + , _todoOutput_height = _textInput_lines ti + , _todoOutput_focusId = fid + , _todoOutput_focused = focused + } where backspaceOnEmpty v = \case V.EvKey V.KBS _ | T.null v -> Just () _ -> Nothing todos - :: forall t m. - ( MonadHold t m + :: forall t m + . ( MonadHold t m , Manager t m , VtyExample t m , Adjustable t m @@ -240,9 +386,9 @@ ) => [Todo] -> Event t () - -> m (Dynamic t (Map Int (TodoOutput t))) + -> m (Dynamic t (Map Rational (TodoOutput t))) todos todos0 newTodo = do - let todosMap0 = Map.fromList $ zip [0..] todos0 + let todosMap0 = Map.fromList $ zip [0 ..] todos0 rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do to <- todo t let sel = select selectOnDelete $ Const2 k @@ -251,18 +397,37 @@ pure to let delete = flip Map.singleton Nothing <$> todoDelete todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut - insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of - Nothing -> Map.singleton 0 $ Just $ Todo "" False - Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False + -- The key of the row that currently holds focus, if any. + focusedKey = + fmap (fmap fst . Map.lookupMin . Map.filter id) $ + joinDynThroughMap $ + fmap _todoOutput_focused <$> listOut + -- Insert the new task directly beneath the focused row by choosing a + -- key halfway between it and the next row (so existing rows keep + -- their keys and edit state). With no focus, or when the focused row + -- is last, append at the end. + insert = ffor (attach (current todosMap) (tag (current focusedKey) newTodo)) $ \(m, mfk) -> + let newKey = case mfk of + Just fk -> case Map.lookupGT fk m of + Just (knext, _) -> (fk + knext) / 2 + Nothing -> fk + 1 + Nothing -> maybe 0 ((+ 1) . fst) (Map.lookupMax m) + in Map.singleton newKey $ Just $ Todo "" False updates = leftmost [insert, delete] - todoDelete = switch . current $ - leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut + todoDelete = + switch . current $ + leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut - selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe - (\m k -> let (before, after) = Map.split k m - in fmap fst $ Map.lookupMax before <|> Map.lookupMin after) - (current todosMap) - todoDelete + selectOnDelete = + fanMap $ + (`Map.singleton` ()) + <$> attachWithMaybe + ( \m k -> + let (before, after) = Map.split k m + in fmap fst $ Map.lookupMax before <|> Map.lookupMin after + ) + (current todosMap) + todoDelete return listOut -- * Scrollable text example @@ -279,13 +444,14 @@ => m () scrolling = col $ do grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:" - (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText def $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant." + (fid, out) <- tile' (fixed 5) $ accentBox accent roundedBoxStyle " De Bello Gallico " $ scrollableText def $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant." pb <- getPostBuild requestFocus $ Refocus_Id fid <$ pb - grout (fixed 1) $ text $ ffor (_scrollable_scrollPosition out) $ \p -> "Scrolled to " <> case p of - ScrollPos_Top -> "top" - ScrollPos_Bottom -> "bottom" - ScrollPos_Line n -> "line " <> T.pack (show n) + grout (fixed 1) $ text $ ffor (_scrollable_scrollPosition out) $ \p -> + "Scrolled to " <> case p of + ScrollPos_Top -> "top" + ScrollPos_Bottom -> "bottom" + ScrollPos_Line n -> "line " <> T.pack (show n) e <- performEventAsync $ ffor pb $ \_ cb -> liftIO $ void $ forkIO $ forever $ do threadDelay 1000000 t <- getCurrentTime @@ -294,10 +460,11 @@ grout (fixed 3) blank tile (fixed 10) $ col $ do grout (fixed 1) $ text "This one scrolls automatically as the output grows:" - Scrollable pos total h <- tile flex $ - scrollableText (ScrollableConfig never never ScrollPos_Bottom (pure $ Just ScrollToBottom_Maintain)) $ - T.unlines <$> xs - grout (fixed 5) $ boxStatic def $ do + Scrollable pos total h <- + tile flex $ + scrollableText (ScrollableConfig never never ScrollPos_Bottom (pure $ Just ScrollToBottom_Maintain) ScrollbarAlways) $ + T.unlines <$> xs + grout (fixed 5) $ accentBox accent singleBoxStyle " Scroll state " $ do grout (fixed 1) $ row $ do grout (fixed 8) (text "Height:") grout flex $ display h @@ -319,25 +486,23 @@ let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2) region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3) pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput - _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $ - let cfg = def - { _textInputConfig_initialValue = - "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them." - } - textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $ - multilineTextInput cfg - dragBox = boxStatic roundedBoxStyle dragTest - in splitVDrag (hRule doubleBoxStyle) textBox dragBox + _ <- + pane region2 (constDyn True) . boxStatic singleBoxStyle $ + let cfg = + def + { _textInputConfig_initialValue = + "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them." + } + textBox = + boxTitle (pure TextAlignment_Center) (pure roundedBoxStyle) "Text Edit" $ + multilineTextInput cfg + dragBox = boxStatic roundedBoxStyle dragTest + in splitVDrag (hRule doubleBoxStyle) textBox dragBox return () where div' :: (Integral a, Applicative f) => f a -> f a -> f a div' = liftA2 div -debugFocus :: (VtyExample t m) => m () -debugFocus = do - f <- focus - text $ T.pack . show <$> current f - debugInput :: (VtyExample t m, MonadHold t m) => m () debugInput = do lastEvent <- hold "No event yet" . fmap show =<< input @@ -348,6 +513,147 @@ lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft text $ T.pack <$> lastEvent -testStringBox :: VtyExample t m => m () -testStringBox = boxStatic singleBoxStyle . - text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z']) +-- * Showcase: one screen showing off all styling, theming, and color + +-- profiling. Tab cycles the predefined themes; the whole screen is +-- rendered under the current theme. +showcaseDemo :: (VtyExample t m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), HasLayout t m, HasColorProfile t m) => m () +showcaseDemo = do + tab <- key (V.KChar '\t') + nDyn <- foldDyn (\_ n -> n + 1) 0 tab + prof <- colorProfile + let themes = + cycle + [ ("default", defTheme) + , ("dark", darkTheme) + , ("charm", charmTheme) + , ("dracula", draculaTheme) + , ("nord", nordTheme) + , ("zenburn", zenburnTheme) + , ("gruvbox", gruvboxTheme) + ] + pick n = drop (n `mod` 7) themes + curTheme n = case pick n of + (_, th) : _ -> th + [] -> defTheme + curLabel n = case pick n of + (label, _) : _ -> label + [] -> "" + themeBeh = curTheme <$> current nDyn + focusGainedE <- gainedFocus + focusLostE <- lostFocus + focusedDyn <- holdDyn True $ leftmost [True <$ focusGainedE, False <$ focusLostE] + mousePosDyn <- mousePosition + let headerBeh = + (\n p f (mx, my) -> T.pack (curLabel n <> " | " <> show p <> " | Focus: " <> (if f then "●" else "○") <> " | Mouse: " <> show mx <> "," <> show my <> " | Tab/Esc")) + <$> current nDyn + <*> prof + <*> current focusedDyn + <*> current mousePosDyn + localTheme (const themeBeh) $ do + fill (pure ' ') + col $ do + grout (fixed 1) $ text headerBeh + grout flex $ void $ scrollable def $ do + row $ do + -- Left column: style samples + grout flex $ col $ do + grout (fixed 1) $ text "Borders:" + grout (fixed 3) $ row $ do + grout flex $ styledImage "single" (withBorder singleBorder def) + grout flex $ styledImage "rounded" (withBorder roundedBorder def) + grout flex $ styledImage "thick" (withBorder thickBorder def) + grout flex $ styledImage "double" (withBorder doubleBorder def) + grout flex $ styledImage "ascii" (withBorder asciiBorder def) + grout (fixed 1) $ text "Padding/Margin:" + grout (fixed 3) $ row $ do + grout flex $ styledImage "pad 1" (withPadding 1 1 1 1 def) + grout flex $ styledImage "pad 2" (withPadding 2 2 2 2 def) + grout flex $ styledImage "margin 1" (withMargin 1 1 1 1 def) + grout (fixed 1) $ text "Colors:" + grout (fixed 3) $ row $ do + grout flex $ styledImage "red fg" (withForeground red def) + grout flex $ styledImage "blue bg" (withBackground blue def) + grout flex $ styledImage "rgb" (withForeground (rgbColor 200 100 50) def) + grout (fixed 1) $ text "Color ops:" + grout (fixed 3) $ row $ do + grout flex $ styledImage "darken" (withForeground (fromRGB (darken 0.4 (RGB 255 128 0))) def) + grout flex $ styledImage "lighten" (withForeground (fromRGB (lighten 0.5 (RGB 100 0 200))) def) + grout flex $ styledImage "mix" (withForeground (fromRGB (mix 0.5 (RGB 255 0 0) (RGB 0 0 255))) def) + grout flex $ styledImage "complement" (withForeground (fromRGB (complementary (RGB 255 128 0))) def) + grout (fixed 1) $ text "Gradient (1D):" + grout (fixed 3) $ gradientSwatch + grout (fixed 1) $ text "Canvas overlay:" + grout (fixed 3) $ canvasOverlayDemo + grout (fixed 1) $ text "Transforms:" + grout (fixed 3) $ row $ do + grout flex $ styledImage "bold" (withBold def) + grout flex $ styledImage "italic" (withItalic def) + grout flex $ styledImage "underline" (withUnderline UnderlineSingle def) + grout flex $ styledImage "reverse" (withReverse def) + grout (fixed 1) $ text "Alignment:" + grout (fixed 3) $ row $ do + grout flex $ styledImage "left" (withAlignH HAlignLeft . withWidth 20 $ def) + grout flex $ styledImage "center" (withAlignH HAlignCenter . withWidth 20 $ def) + grout flex $ styledImage "right" (withAlignH HAlignRight . withWidth 20 $ def) + grout (fixed 1) $ text "Combined & Hyperlink:" + grout (fixed 5) $ row $ do + grout flex $ + styledImage + "combined" + ( withBorder roundedBorder + . withPadding 1 2 1 2 + . withForeground brightGreen + . withBorderForeground brightMagenta + $ def + ) + grout flex $ + styledImage + "link" + (withHyperlink "https://reflex-frp.org" . withUnderline UnderlineSingle $ def) + -- Right column: themed widgets + color profile swatches + grout flex $ col $ do + grout (fixed 1) $ text "Themed Widgets:" + void $ grout (fixed 3) $ textButtonStatic def "A button" + void $ grout (fixed 3) $ checkbox def False + void $ grout (fixed 3) $ linkStatic "A link" + void $ grout (fixed 3) $ textInput def + grout (fixed 1) $ text "Color Profile Swatches:" + grout (fixed 2) $ row $ do + grout flex $ profileSwatch "TrueColor" ColorProfile_TrueColor + grout flex $ profileSwatch "Ansi256" ColorProfile_Ansi256 + grout flex $ profileSwatch "Ansi16" ColorProfile_Ansi16 + grout flex $ profileSwatch "Ascii" ColorProfile_Ascii + grout flex $ profileSwatch "NoTTY" ColorProfile_NoTTY + pure (never, ()) + where + orange = rgbColor 200 100 50 + styledImage label s = do + th <- theme + tellImages $ (\t -> [render (inherit (_theme_default t) s) label]) <$> th + profileSwatch label prof = do + bt <- themeAttr + tellImages $ (\a -> [V.text' (applyProfile prof (V.withForeColor a orange)) (label <> " ")]) <$> bt + gradientSwatch = do + th <- theme + dw <- displayWidth + let grad = gradient1D [(0.0, RGB 255 0 0), (0.5, RGB 0 255 0), (1.0, RGB 0 0 255)] + sampleAt w i = sampleGradient1D grad (fromIntegral i / fromIntegral (max 1 (w - 1))) + bar t w = [V.horizCat $ map (\i -> render (inherit (_theme_default t) (withBackground (fromRGB (sampleAt w i)) def)) " ") [0 .. max 1 (w - 1)]] + tellImages $ bar <$> th <*> current dw + canvasOverlayDemo = do + th <- theme + let bgText = "background text shows through around the overlay" + mkCanvas t = + let bgBase = applyAttr (inherit (_theme_default t) def) V.defAttr + bgRow = V.text' bgBase bgText + bg = imageToCanvas $ V.vertCat [bgRow, bgRow, bgRow] + overlayStyle = + withBorder roundedBorder + . withBackground (fromRGB (RGB 40 42 54)) + . withForeground (fromRGB (RGB 255 184 108)) + $ def + overlayCanvas = imageToCanvas $ render overlayStyle " Overlay " + result = placeCanvas 3 0 overlayCanvas bg + in [canvasToImage result] + tellImages $ mkCanvas <$> th diff --git a/src-bin/leaktest.hs b/src-bin/leaktest.hs new file mode 100644 --- /dev/null +++ b/src-bin/leaktest.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Space-leak repro for profiling. A streaming producer fires into the FRP +-- network as fast as possible via 'performEventAsync'; the only buffer in +-- play is the reflex host's event channel. The program self-terminates after +-- a short delay via 'exitSuccess' so the RTS flushes profiling output. +-- +-- Uses @forever@ (not @forM_ [1..n]@) so the producer itself doesn't +-- materialize a list -- keeping the profile focused on the host's event +-- channel rather than the producer's enumeration. +-- +-- Run under the threaded RTS with >=2 capabilities, e.g.: +-- leaktest +RTS -N2 -hy -p -M4000m -RTS +module Main (main) where + +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as Async +import Control.Monad (forever, void) +import Control.Monad.IO.Class (liftIO) +import Data.Text (pack) +import qualified Graphics.Vty as V +import Reflex +import System.Exit (exitSuccess) + +import Data.Text.Zipper (TextAlignment (..)) +import Reflex.Vty + +main :: IO () +main = do + void $ Async.async (threadDelay 2000000 >> exitSuccess) + mainWidget def $ initManager_ $ do + setupE <- getPostBuild + inp <- input + sE <- + performEventAsync $ + ffor setupE $ + \() fire -> liftIO . void . Async.async $ forever (fire (0 :: Int)) + sB <- current <$> holdDyn 0 sE + col $ + grout (fixed 17) $ + boxTitle (constant TextAlignment_Left) (constant doubleBoxStyle) "" $ + grout (fixed 1) $ + text (pack . show <$> sB) + pure $ fforMaybe inp $ \case + V.EvKey (V.KChar 'c') [V.MCtrl] -> Just () + _ -> Nothing diff --git a/src/Control/Monad/NodeId.hs b/src/Control/Monad/NodeId.hs --- a/src/Control/Monad/NodeId.hs +++ b/src/Control/Monad/NodeId.hs @@ -1,8 +1,8 @@ -{-| -Module: Control.Monad.NodeId -Description: Monad providing a supply of unique identifiers --} -{-# Language UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Control.Monad.NodeId +-- Description: Monad providing a supply of unique identifiers module Control.Monad.NodeId ( NodeId , MonadNodeId (..) @@ -10,13 +10,12 @@ , runNodeIdT ) where -import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask) -import Control.Monad.Morph +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix +import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.Ref import Data.IORef - import Reflex import Reflex.Host.Class @@ -33,26 +32,26 @@ getNextNodeId = lift getNextNodeId -- | A monad transformer that internally keeps track of the next 'NodeId' -newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a } +newtype NodeIdT m a = NodeIdT {unNodeIdT :: ReaderT (IORef NodeId) m a} deriving - ( Functor - , Applicative + ( Applicative + , Functor , MFunctor , Monad + , MonadCatch , MonadFix , MonadHold t , MonadIO + , MonadMask , MonadRef , MonadReflexCreateTrigger t , MonadSample t + , MonadThrow , MonadTrans , NotReady t , PerformEvent t , PostBuild t , TriggerEvent t - , MonadCatch - , MonadThrow - , MonadMask ) instance MonadNodeId m => MonadNodeId (ReaderT x m) diff --git a/src/Data/Text/Zipper.hs b/src/Data/Text/Zipper.hs --- a/src/Data/Text/Zipper.hs +++ b/src/Data/Text/Zipper.hs @@ -1,33 +1,28 @@ -{-| -Module: Data.Text.Zipper -Description: A zipper for text documents that allows convenient editing and navigation - -'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position. - -'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper. - --} +-- | +-- Module: Data.Text.Zipper +-- Description: A zipper for text documents that allows convenient editing and navigation +-- +-- 'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position. +-- +-- 'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper. module Data.Text.Zipper where import Control.Exception (assert) import Control.Monad import Control.Monad.State (evalState, get, put) import Data.Char (isSpace) -import Data.Map (Map) -import Data.String - import qualified Data.List as L +import Data.Map (Map) import qualified Data.Map as Map +import Data.String import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Internal (Text(..), text) +import Data.Text.Internal (Text (..), text) import Data.Text.Internal.Fusion (stream) -import Data.Text.Internal.Fusion.Types (Step(..), Stream(..)) +import Data.Text.Internal.Fusion.Types (Step (..), Stream (..)) import Data.Text.Unsafe - import Graphics.Text.Width (wcwidth) - -- | A zipper of the logical text input contents (the "document"). The lines -- before the line containing the cursor are stored in reverse order. -- The cursor is logically between the "before" and "after" text. @@ -40,19 +35,20 @@ , _textZipper_after :: Text -- The cursor is on top of the first character of this text , _textZipper_linesAfter :: [Text] } - deriving (Show, Eq) + deriving (Eq, Show) instance IsString TextZipper where fromString = fromText . T.pack -- | Map a replacement function over the characters in a 'TextZipper' mapZipper :: (Char -> Char) -> TextZipper -> TextZipper -mapZipper f (TextZipper lb b a la) = TextZipper - { _textZipper_linesBefore = fmap (T.map f) lb - , _textZipper_before = T.map f b - , _textZipper_after = T.map f a - , _textZipper_linesAfter = fmap (T.map f) la - } +mapZipper f (TextZipper lb b a la) = + TextZipper + { _textZipper_linesBefore = fmap (T.map f) lb + , _textZipper_before = T.map f b + , _textZipper_after = T.map f a + , _textZipper_linesAfter = fmap (T.map f) la + } -- | Move the cursor left one character, if possible left :: TextZipper -> TextZipper @@ -65,10 +61,10 @@ if T.length b >= n then let n' = T.length b - n - in TextZipper lb (T.take n' b) (T.drop n' b <> a) la + in TextZipper lb (T.take n' b) (T.drop n' b <> a) la else case lb of - [] -> home z - (l:ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la) + [] -> home z + (l : ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la) -- | Move the cursor right one character, if possible right :: TextZipper -> TextZipper @@ -81,14 +77,14 @@ if T.length a >= n then TextZipper lb (b <> T.take n a) (T.drop n a) la else case la of - [] -> end z - (l:ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls + [] -> end z + (l : ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls -- | Move the cursor up one logical line, if possible up :: TextZipper -> TextZipper up z@(TextZipper lb b a la) = case lb of [] -> z - (l:ls) -> + (l : ls) -> let (b', a') = T.splitAt (T.length b) l in TextZipper ls b' a' ((b <> a) : la) @@ -96,21 +92,23 @@ down :: TextZipper -> TextZipper down z@(TextZipper lb b a la) = case la of [] -> z - (l:ls) -> + (l : ls) -> let (b', a') = T.splitAt (T.length b) l in TextZipper ((b <> a) : lb) b' a' ls -- | Move the cursor up by the given number of lines pageUp :: Int -> TextZipper -> TextZipper -pageUp pageSize z = if pageSize <= 0 - then z - else pageUp (pageSize - 1) $ up z +pageUp pageSize z = + if pageSize <= 0 + then z + else pageUp (pageSize - 1) $ up z -- | Move the cursor down by the given number of lines pageDown :: Int -> TextZipper -> TextZipper -pageDown pageSize z = if pageSize <= 0 - then z - else pageDown (pageSize - 1) $ down z +pageDown pageSize z = + if pageSize <= 0 + then z + else pageDown (pageSize - 1) $ down z -- | Move the cursor to the beginning of the current logical line home :: TextZipper -> TextZipper @@ -124,7 +122,7 @@ top :: TextZipper -> TextZipper top (TextZipper lb b a la) = case reverse lb of [] -> TextZipper [] "" (b <> a) la - (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la) + (start : rest) -> TextZipper [] "" start (rest <> [b <> a] <> la) -- | Insert a character at the current cursor position insertChar :: Char -> TextZipper -> TextZipper @@ -132,18 +130,18 @@ -- | Insert text at the current cursor position insert :: Text -> TextZipper -> TextZipper -insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of +insert i z@(TextZipper lb b a la) = case T.split (== '\n') i of [] -> z - (start:rest) -> case reverse rest of + (start : rest) -> case reverse rest of [] -> TextZipper lb (b <> start) a la - (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la + (l : ls) -> TextZipper (ls <> [b <> start] <> lb) l a la -- | Delete the character to the left of the cursor -deleteLeft :: TextZipper-> TextZipper +deleteLeft :: TextZipper -> TextZipper deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of Nothing -> case lb of [] -> z - (l:ls) -> TextZipper ls l a la + (l : ls) -> TextZipper ls l a la Just (b', _) -> TextZipper lb b' a la -- | Delete the character under/to the right of the cursor @@ -151,7 +149,7 @@ deleteRight z@(TextZipper lb b a la) = case T.uncons a of Nothing -> case la of [] -> z - (l:ls) -> TextZipper lb b l ls + (l : ls) -> TextZipper lb b l ls Just (_, a') -> TextZipper lb b a' la -- | Delete a word to the left of the cursor. Deletes all whitespace until it @@ -160,11 +158,11 @@ deleteLeftWord :: TextZipper -> TextZipper deleteLeftWord (TextZipper lb b a la) = let b' = T.dropWhileEnd isSpace b - in if T.null b' - then case lb of - [] -> TextZipper [] b' a la - (l:ls) -> deleteLeftWord $ TextZipper ls l a la - else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la + in if T.null b' + then case lb of + [] -> TextZipper [] b' a la + (l : ls) -> deleteLeftWord $ TextZipper ls l a la + else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la -- | Insert up to n spaces to get to the next logical column that is a multiple of n tab :: Int -> TextZipper -> TextZipper @@ -173,10 +171,13 @@ -- | The plain text contents of the zipper value :: TextZipper -> Text -value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb - , [b <> a] - , la - ] +value (TextZipper lb b a la) = + T.intercalate "\n" $ + mconcat + [ reverse lb + , [b <> a] + , la + ] -- | The empty zipper empty :: TextZipper @@ -193,8 +194,8 @@ deriving (Eq, Show) -- | Text alignment type -data TextAlignment = - TextAlignment_Left +data TextAlignment + = TextAlignment_Left | TextAlignment_Right | TextAlignment_Center deriving (Eq, Show) @@ -208,18 +209,21 @@ -- | Helper type representing a single visual line that may be part of a wrapped logical line data WrappedLine = WrappedLine { _wrappedLines_text :: Text - , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character - , _wrappedLines_offset :: Int -- ^ offset from beginning of line + , _wrappedLines_hiddenWhitespace :: Bool + -- ^ 'True' if this line ends with a deleted whitespace character + , _wrappedLines_offset :: Int + -- ^ offset from beginning of line } deriving (Eq, Show) -- | Information about the document as it is displayed (i.e., post-wrapping) -data DisplayLines tag = DisplayLines { - _displayLines_spans :: [[Span tag]] - -- ^ NOTE this will contain a dummy space character if the cursor is at the end - , _displayLines_offsetMap :: OffsetMapWithAlignment - -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line - , _displayLines_cursorPos :: (Int, Int) -- ^ cursor position relative to upper left hand corner +data DisplayLines tag = DisplayLines + { _displayLines_spans :: [[Span tag]] + -- ^ NOTE this will contain a dummy space character if the cursor is at the end + , _displayLines_offsetMap :: OffsetMapWithAlignment + -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line + , _displayLines_cursorPos :: (Int, Int) + -- ^ cursor position relative to upper left hand corner } deriving (Eq, Show) @@ -230,10 +234,11 @@ -- because the first character has a width of two (see 'charWidth' for more on that). splitAtWidth :: Int -> Text -> (Text, Text) splitAtWidth n t@(Text arr off len) - | n <= 0 = (T.empty, t) - | n >= textWidth t = (t, T.empty) - | otherwise = let k = characterIndexFromWidth n t - in (text arr off k, text arr (off+k) (len-k)) + | n <= 0 = (T.empty, t) + | n >= textWidth t = (t, T.empty) + | otherwise = + let k = characterIndexFromWidth n t + in (text arr off k, text arr (off + k) (len - k)) -- | Convert a physical width index to a character index. For example, the -- physical index 3 of the string "ᄀabc" corresponds to the character index 2, @@ -247,14 +252,15 @@ -> Int -- The accumulated physical width -> Int -- The new logical index loop !bytes !li !cumw - -- if we've gone past the last byte - | bytes >= len' = li-1 - -- if we hit our target - | cumw + w > n' = li - -- advance one character - | otherwise = loop (bytes+byteWidth) (li+1) (cumw + w) - where Iter c byteWidth = iter t' bytes - w = charWidth c + -- if we've gone past the last byte + | bytes >= len' = li - 1 + -- if we hit our target + | cumw + w > n' = li + -- advance one character + | otherwise = loop (bytes + byteWidth) (li + 1) (cumw + w) + where + Iter c byteWidth = iter t' bytes + w = charWidth c -- | Takes the given number of columns of characters. For example -- @@ -300,27 +306,25 @@ -- fullwidth unicode forms. widthI :: Stream Char -> Int widthI (Stream next s0 _len) = loop_length 0 s0 - where - loop_length !z s = case next s of - Done -> z - Skip s' -> loop_length z s' - Yield c s' -> loop_length (z + charWidth c) s' -{-# INLINE[0] widthI #-} + where + loop_length !z s = case next s of + Done -> z + Skip s' -> loop_length z s' + Yield c s' -> loop_length (z + charWidth c) s' +{-# INLINE [0] widthI #-} -- | Compute the logical index position of a stream of characters from a visual -- position taking into account fullwidth unicode forms. charIndexAt :: Int -> Stream Char -> Int charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0 - where - loop_length i !z s = case next s of - Done -> i - Skip s' -> loop_length i z s' - Yield c s' -> if w > pos then i else loop_length (i+1) w s' where - w = z + charWidth c -{-# INLINE[0] charIndexAt #-} - - - + where + loop_length i !z s = case next s of + Done -> i + Skip s' -> loop_length i z s' + Yield c s' -> if w > pos then i else loop_length (i + 1) w s' + where + w = z + charWidth c +{-# INLINE [0] charIndexAt #-} -- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...]) -- 'Char's representing white space. @@ -328,43 +332,50 @@ wordsWithWhitespace t@(Text arr off len) = loop 0 0 False where loop !start !n !wasSpace - | n >= len = [Text arr (start+off) (n-start) | not (start == n)] - | isSpace c = loop start (n+d) True - | wasSpace = Text arr (start+off) (n-start) : loop n n False - | otherwise = loop start (n+d) False - where Iter c d = iter t n + | n >= len = [Text arr (start + off) (n - start) | not (start == n)] + | isSpace c = loop start (n + d) True + | wasSpace = Text arr (start + off) (n - start) : loop n n False + | otherwise = loop start (n + d) False + where + Iter c d = iter t n {-# INLINE wordsWithWhitespace #-} -- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)] -splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where - appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)] - appendOut [] t b = [(t,b)] - appendOut ((t',_):ts') t b = (t'<>t,b) : ts' - - -- remove the last whitespace in output - modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)] - modifyOutForNewLine [] = error "should never happen" - modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of - Nothing -> error "should never happen" - Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace +splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] + where + appendOut :: [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)] + appendOut [] t b = [(t, b)] + appendOut ((t', _) : ts') t b = (t' <> t, b) : ts' - loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)] - loop [] _ out = out - loop (x:xs) cumw out = r where - newWidth = textWidth x + cumw - r = if newWidth > maxWidth - then if isSpace $ T.index x (characterIndexFromWidth (maxWidth - cumw) x) - -- if line runs over but character of splitting is whitespace then split on the whitespace - then let (t1,t2) = splitAtWidth (maxWidth - cumw) x - in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True - else if cumw == 0 - -- single word exceeds max width, so just split on the word - then let (t1,t2) = splitAtWidth (maxWidth - cumw) x - in loop (t2:xs) 0 [] <> appendOut out t1 False - -- otherwise start a new line - else loop (x:xs) 0 [] <> modifyOutForNewLine out - else loop xs newWidth $ appendOut out x False + -- remove the last whitespace in output + modifyOutForNewLine :: [(Text, Bool)] -> [(Text, Bool)] + modifyOutForNewLine [] = error "should never happen" + modifyOutForNewLine ((t', _) : ts) = case T.unsnoc t' of + Nothing -> error "should never happen" + Just (t, lastChar) -> assert (isSpace lastChar) $ (t, True) : ts -- assume last char is whitespace + loop :: [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)] + loop [] _ out = out + loop (x : xs) cumw out = r + where + newWidth = textWidth x + cumw + r = + if newWidth > maxWidth + then + if isSpace $ T.index x (characterIndexFromWidth (maxWidth - cumw) x) + -- if line runs over but character of splitting is whitespace then split on the whitespace + then + let (t1, t2) = splitAtWidth (maxWidth - cumw) x + in loop (T.drop 1 t2 : xs) 0 [] <> appendOut out t1 True + else + if cumw == 0 + -- single word exceeds max width, so just split on the word + then + let (t1, t2) = splitAtWidth (maxWidth - cumw) x + in loop (t2 : xs) 0 [] <> appendOut out t1 False + -- otherwise start a new line + else loop (x : xs) 0 [] <> modifyOutForNewLine out + else loop xs newWidth $ appendOut out x False -- | Calculate the offset that will result in rendered text being aligned left, -- right, or center @@ -374,8 +385,8 @@ -> Text -> Int alignmentOffset alignment maxWidth t = case alignment of - TextAlignment_Left -> 0 - TextAlignment_Right -> (maxWidth - l) + TextAlignment_Left -> 0 + TextAlignment_Right -> (maxWidth - l) TextAlignment_Center -> (maxWidth - l) `div` 2 where l = textWidth t @@ -385,37 +396,43 @@ -- lines are not. wrapWithOffsetAndAlignment :: TextAlignment - -> Int -- ^ Maximum width - -> Int -- ^ Offset for first line - -> Text -- ^ Text to be wrapped + -> Int + -- ^ Maximum width + -> Int + -- ^ Offset for first line + -> Text + -- ^ Text to be wrapped -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line) wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = [] -wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where - r' = if T.null txt - then [("",False)] - -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't) - -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere) - else splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt) - fmapfn (t,b) = WrappedLine t b $ alignmentOffset alignment maxWidth t - r'' = case r' of - [] -> [] - (x,b):xs -> (T.drop n x,b):xs - r = fmap fmapfn r'' +wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r + where + r' = + if T.null txt + then [("", False)] + -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't) + -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere) + else splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace (T.replicate n "." <> txt) + fmapfn (t, b) = WrappedLine t b $ alignmentOffset alignment maxWidth t + r'' = case r' of + [] -> [] + (x, b) : xs -> (T.drop n x, b) : xs + r = fmap fmapfn r'' -- | converts deleted eol spaces into logical lines eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]] -eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b)) +eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a, c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b)) offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines offsetMapWithAlignment - :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines + :: [[(Text, Int)]] + -- ^ The outer list represents logical lines, inner list represents wrapped lines -> OffsetMapWithAlignment offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0) where offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do - maps <- forM x $ \(line,align) -> do + maps <- forM x $ \(line, align) -> do let l = T.length line (dl, o) <- get put (dl + 1, o + l) @@ -423,8 +440,7 @@ (dl, o) <- get put (dl, o + 1) -- add additional offset to last line in wrapped lines (for newline char) - return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps - + return $ Map.adjust (\(align, _) -> (align, o + 1)) dl $ Map.unions maps -- | Given a width and a 'TextZipper', produce a list of display lines -- (i.e., lines of wrapped text) with special attributes applied to @@ -433,14 +449,17 @@ -- offset displayLinesWithAlignment :: TextAlignment - -> Int -- ^ Width, used for wrapping - -> tag -- ^ Metadata for normal characters - -> tag -- ^ Metadata for the cursor - -> TextZipper -- ^ The text input contents and cursor state + -> Int + -- ^ Width, used for wrapping + -> tag + -- ^ Metadata for normal characters + -> tag + -- ^ Metadata for the cursor + -> TextZipper + -- ^ The text input contents and cursor state -> DisplayLines tag displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) = - let - linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line + let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la @@ -448,17 +467,19 @@ -- simulate trailing cursor character when computing OffsetMap afterWithCursor = if T.null a then " " else a offsets :: OffsetMapWithAlignment - offsets = offsetMapWithAlignmentInternal $ mconcat - [ linesBefore - , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor] - , linesAfter - ] + offsets = + offsetMapWithAlignmentInternal $ + mconcat + [ linesBefore + , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor] + , linesAfter + ] flattenLines = concatMap (fmap _wrappedLines_text) - spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore - spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter + spansBefore = map ((: []) . Span tag) $ flattenLines linesBefore + spansAfter = map ((: []) . Span tag) $ flattenLines linesAfter -- Separate the spans before the cursor into - -- * spans that are on earlier display lines (though on the same logical line), and - -- * spans that are on the same display line + -- \* spans that are on earlier display lines (though on the same logical line), and + -- \* spans that are on the same display line -- do the current line curlinetext = b <> a @@ -467,54 +488,68 @@ -- map to spans and highlight the cursor -- accumulator type (accumulated text length, Either (current y position) (cursor y and x position)) - --mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag]) - mapaccumlfn (acclength, ecpos) (WrappedLine t dwseol xoff) = r where - tlength = T.length t - -- how many words we've gone through - nextacclength = acclength + tlength + if dwseol then 1 else 0 - nextacc = (nextacclength, nextecpos) - cursoroncurspan = nextacclength >= blength && (blength >= acclength) - charsbeforecursor = blength-acclength - ctlength = textWidth $ T.take charsbeforecursor t - cursorx = xoff + ctlength - nextecpos = case ecpos of - Left y -> if cursoroncurspan - then if ctlength == width - -- cursor wraps to next line case - then Right (y+1, 0) - else Right (y, cursorx) - else Left (y+1) - Right x -> Right x + -- mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag]) + mapaccumlfn (acclength, ecpos) (WrappedLine t dwseol xoff) = r + where + tlength = T.length t + -- how many words we've gone through + nextacclength = acclength + tlength + if dwseol then 1 else 0 + nextacc = (nextacclength, nextecpos) + cursoroncurspan = nextacclength >= blength && (blength >= acclength) + charsbeforecursor = blength - acclength + ctlength = textWidth $ T.take charsbeforecursor t + cursorx = xoff + ctlength + nextecpos = case ecpos of + Left y -> + if cursoroncurspan + then + if ctlength == width + -- cursor wraps to next line case + then Right (y + 1, 0) + else Right (y, cursorx) + else Left (y + 1) + Right x -> Right x - beforecursor = T.take charsbeforecursor t - cursortext = T.take 1 $ T.drop charsbeforecursor t - aftercursor = T.drop (charsbeforecursor+1) t + beforecursor = T.take charsbeforecursor t + cursortext = T.take 1 $ T.drop charsbeforecursor t + aftercursor = T.drop (charsbeforecursor + 1) t - cursorspans = [Span tag beforecursor, Span cursorTag cursortext] <> if T.null aftercursor then [] else [Span tag aftercursor] + -- When the cursor goes past the last character of the current + -- logical line (@a@ is empty), there is no character under it to + -- highlight, so we render a blank cell carrying the cursor tag. This + -- keeps the cursor visible at the end of the text. We only do this + -- at the true end of the line, never at a soft-wrap boundary (which + -- would double the cursor). + cursorcell = if T.null cursortext && T.null a then " " else cursortext + cursorspans = [Span tag beforecursor, Span cursorTag cursorcell] <> if T.null aftercursor then [] else [Span tag aftercursor] - r = if cursoroncurspan - then (nextacc, cursorspans) - else (nextacc, [Span tag t]) - ((_, ecpos_out), curlinespans) = if T.null curlinetext - -- manually handle empty case because mapaccumlfn doesn't handle it - then ((0, Right (0, alignmentOffset alignment width "")), [[Span cursorTag ""]]) - else L.mapAccumL mapaccumlfn (0, Left 0) curwrappedlines + r = + if cursoroncurspan + then (nextacc, cursorspans) + else (nextacc, [Span tag t]) + ((_, ecpos_out), curlinespans) = + if T.null curlinetext + -- Manually handle empty case. Render a blank cursor cell (a space) + -- so the cursor stays visible on an empty line instead of collapsing + -- to nothing. + then ((0, Right (0, alignmentOffset alignment width "")), [[Span cursorTag " "]]) + else L.mapAccumL mapaccumlfn (0, Left 0) curwrappedlines (cursorY', cursorX) = case ecpos_out of - Right (y,x) -> (y,x) + Right (y, x) -> (y, x) -- if we never hit the cursor position, this means it's at the beginning of the next line - Left y -> (y+1, alignmentOffset alignment width "") + Left y -> (y + 1, alignmentOffset alignment width "") cursorY = cursorY' + length spansBefore - - in DisplayLines - { _displayLines_spans = concat - [ spansBefore - , curlinespans - , spansAfter - ] - , _displayLines_offsetMap = offsets - , _displayLines_cursorPos = (cursorX, cursorY) - } + in DisplayLines + { _displayLines_spans = + concat + [ spansBefore + , curlinespans + , spansAfter + ] + , _displayLines_offsetMap = offsets + , _displayLines_cursorPos = (cursorX, cursorY) + } -- | Move the cursor of the given 'TextZipper' to the logical position indicated -- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment' @@ -523,15 +558,14 @@ goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper goToDisplayLinePosition x y dl tz = let offset = Map.lookup y $ _displayLines_offsetMap dl - in case offset of - Nothing -> tz - Just (alignOff,o) -> - let - trueX = max 0 (x - alignOff) - moveRight = case drop y $ _displayLines_spans dl of - [] -> 0 - (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s - in rightN (o + moveRight) $ top tz + in case offset of + Nothing -> tz + Just (alignOff, o) -> + let trueX = max 0 (x - alignOff) + moveRight = case drop y $ _displayLines_spans dl of + [] -> 0 + (s : _) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s + in rightN (o + moveRight) $ top tz -- | Given a width and a 'TextZipper', produce a list of display lines -- (i.e., lines of wrapped text) with special attributes applied to @@ -539,10 +573,14 @@ -- y-coordinate of the cursor and a mapping from display line number to text -- offset displayLines - :: Int -- ^ Width, used for wrapping - -> tag -- ^ Metadata for normal characters - -> tag -- ^ Metadata for the cursor - -> TextZipper -- ^ The text input contents and cursor state + :: Int + -- ^ Width, used for wrapping + -> tag + -- ^ Metadata for normal characters + -> tag + -- ^ Metadata for the cursor + -> TextZipper + -- ^ The text input contents and cursor state -> DisplayLines tag displayLines = displayLinesWithAlignment TextAlignment_Left @@ -550,8 +588,11 @@ -- wrapped line is offset by the number of columns provided. Subsequent wrapped -- lines are not. wrapWithOffset - :: Int -- ^ Maximum width - -> Int -- ^ Offset for first line - -> Text -- ^ Text to be wrapped + :: Int + -- ^ Maximum width + -> Int + -- ^ Offset for first line + -> Text + -- ^ Text to be wrapped -> [Text] wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs diff --git a/src/Reflex/Spider/Orphans.hs b/src/Reflex/Spider/Orphans.hs deleted file mode 100644 --- a/src/Reflex/Spider/Orphans.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-| -Module: Reflex.Spider.Orphans -Description: Orphan instances for SpiderTimeline and SpiderHost --} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Reflex.Spider.Orphans where - -#if MIN_VERSION_reflex(0,6,3) -#else -import Reflex -import Reflex.Spider.Internal - -instance NotReady (SpiderTimeline x) (SpiderHost x) where - notReadyUntil _ = pure () - notReady = pure () - -instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where - notReadyUntil _ = pure () - notReady = pure () -#endif diff --git a/src/Reflex/Vty.hs b/src/Reflex/Vty.hs --- a/src/Reflex/Vty.hs +++ b/src/Reflex/Vty.hs @@ -1,18 +1,21 @@ -{-| -Module: Reflex.Vty -Description: A library for building vty apps with reflex -Copyright : (c) Obsidian Systems LLC -License : GPL-3 -Maintainer : maintainer@obsidian.systems -Stability : experimental -Portability : POSIX - -<<./doc/tasks.png>> - --} +-- | +-- Module: Reflex.Vty +-- Description: A library for building vty apps with reflex +-- Copyright : (c) Obsidian Systems LLC +-- License : BSD-3 +-- Maintainer : maintainer@obsidian.systems +-- Stability : experimental +-- Portability : POSIX +-- +-- <<./doc/tasks.png>> module Reflex.Vty ( module Reflex + , module Reflex.Vty.Canvas + , module Reflex.Vty.Color + , module Reflex.Vty.ColorProfile , module Reflex.Vty.Host + , module Reflex.Vty.Style + , module Reflex.Vty.Theme , module Reflex.Vty.Widget , module Reflex.Vty.Widget.Box , module Reflex.Vty.Widget.Input @@ -24,7 +27,14 @@ ) where import Reflex + +import Control.Monad.NodeId +import Reflex.Vty.Canvas +import Reflex.Vty.Color +import Reflex.Vty.ColorProfile import Reflex.Vty.Host +import Reflex.Vty.Style +import Reflex.Vty.Theme import Reflex.Vty.Widget import Reflex.Vty.Widget.Box import Reflex.Vty.Widget.Input @@ -32,5 +42,3 @@ import Reflex.Vty.Widget.Scroll import Reflex.Vty.Widget.Split import Reflex.Vty.Widget.Text - -import Control.Monad.NodeId diff --git a/src/Reflex/Vty/Canvas.hs b/src/Reflex/Vty/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Canvas.hs @@ -0,0 +1,176 @@ +-- | +-- Module: Reflex.Vty.Canvas +-- Description: Per-cell compositing with transparency +-- +-- A 'Canvas' is a 2D grid of @Maybe (Char, Attr)@ cells where 'Nothing' +-- means transparent. This allows compositing visual layers with +-- per-cell transparency — something 'V.Image' cannot do. +-- +-- Typical usage: capture a child widget's images via 'captureImages', +-- convert to a 'Canvas' with 'imageToCanvas', composite overlay +-- 'Canvas'es on top with 'stack', then convert back to an 'Image' with +-- 'canvasToImage' and emit via 'tellImages'. +module Reflex.Vty.Canvas + ( Canvas (..) + , canvasCellAt + , blankCanvas + , placeCanvas + , translate + , stack + , imageToCanvas + , canvasToImage + ) where + +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Graphics.Text.Width (wcwidth) +import qualified Graphics.Vty as V +import Graphics.Vty.Image.Internal (Image (BGFill, Crop, EmptyImage, HorizJoin, HorizText, VertJoin)) + +-- | A 2D grid of cells. Cells not in the 'Map' are transparent +-- ('Nothing'). The 'Map' is keyed by @(x, y)@ where @(0,0)@ is the +-- top-left corner. +data Canvas = Canvas + { canvasWidth :: !Int + , canvasHeight :: !Int + , canvasCells :: !(Map (Int, Int) (Char, V.Attr)) + } + deriving (Eq, Show) + +-- | A fully transparent canvas of the given dimensions. +blankCanvas :: Int -> Int -> Canvas +blankCanvas w h = Canvas w h Map.empty + +-- | Look up the cell at @(x, y)@. Returns 'Nothing' for transparent cells. +canvasCellAt :: Int -> Int -> Canvas -> Maybe (Char, V.Attr) +canvasCellAt x y (Canvas _ _ cells) = Map.lookup (x, y) cells + +-- | Place a source canvas onto a destination at offset @(dx, dy)@. +-- Transparent cells in the source do not overwrite the destination. +-- Cells outside the destination bounds are clipped. +placeCanvas :: Int -> Int -> Canvas -> Canvas -> Canvas +placeCanvas dx dy src dst = + dst {canvasCells = foldl' insert (canvasCells dst) visibleCells} + where + insert m (pos, cell) = Map.insert pos cell m + visibleCells = + [ ((dx + sx, dy + sy), cell) + | ((sx, sy), cell) <- Map.toList (canvasCells src) + , dx + sx >= 0 + , dy + sy >= 0 + , dx + sx < canvasWidth dst + , dy + sy < canvasHeight dst + ] + +-- | Shift a canvas by @(dx, dy)@. Dimensions are preserved; cells that +-- move outside bounds are lost, and newly empty cells are transparent. +translate :: Int -> Int -> Canvas -> Canvas +translate dx dy src = + src {canvasCells = Map.mapKeys (\(x, y) -> (x + dx, y + dy)) clipped} + where + clipped = Map.filterWithKey keep (canvasCells src) + keep (x, y) _ = + x + dx >= 0 + && y + dy >= 0 + && x + dx < canvasWidth src + && y + dy < canvasHeight src + +-- | Stack canvases in z-order (last = topmost). All canvases must have +-- the same dimensions; later canvases overlay earlier ones. +stack :: [Canvas] -> Canvas +stack [] = blankCanvas 0 0 +stack (c : cs) = foldl' (\dst src -> placeCanvas 0 0 src dst) c cs + +---------------------------------------------------------------------------- +-- Conversions +---------------------------------------------------------------------------- + +-- | An attr with all fields 'KeepCurrent', used for transparent cells +-- when converting to an 'Image'. +transparentAttr :: V.Attr +transparentAttr = + V.Attr + { V.attrStyle = V.KeepCurrent + , V.attrForeColor = V.KeepCurrent + , V.attrBackColor = V.KeepCurrent + , V.attrURL = V.KeepCurrent + } + +-- | Convert a vty 'Image' to an opaque 'Canvas'. Every cell in the +-- image becomes a concrete @(Char, Attr)@ in the canvas; there are no +-- transparent cells. +imageToCanvas :: Image -> Canvas +imageToCanvas img = + Canvas + { canvasWidth = V.imageWidth img + , canvasHeight = V.imageHeight img + , canvasCells = walkImage img 0 0 Map.empty + } + +-- | Convert a 'Canvas' to a vty 'Image'. Transparent cells (not in the +-- 'Map') are rendered as spaces with 'transparentAttr' (KeepCurrent), +-- allowing underlying vty layers to show through. +canvasToImage :: Canvas -> Image +canvasToImage (Canvas w h cells) + | w <= 0 || h <= 0 = EmptyImage + | otherwise = V.vertCat (map renderRow [0 .. h - 1]) + where + renderRow y = V.horizCat (map (uncurry V.text') (rowRuns y)) + rowRuns y = mergeRuns [0 .. w - 1] + where + cellAt x = Map.findWithDefault (' ', transparentAttr) (x, y) cells + mergeRuns [] = [] + mergeRuns (x : xs) = go (cellAt x) [fst (cellAt x)] xs + go (_, attr) chars (x : xs) + | attr == snd (cellAt x) = go (cellAt x) (fst (cellAt x) : chars) xs + | otherwise = (attr, T.pack (reverse chars)) : mergeRuns (x : xs) + go (_, attr) chars [] = [(attr, T.pack (reverse chars))] + +---------------------------------------------------------------------------- +-- Internal: Image tree walker +---------------------------------------------------------------------------- + +type CellMap = Map (Int, Int) (Char, V.Attr) + +walkImage :: Image -> Int -> Int -> CellMap -> CellMap +walkImage img x y acc = + case img of + HorizText attr displayText _ _ -> + placeText attr (TL.unpack displayText) x y acc + HorizJoin partLeft partRight _ _ -> + let acc' = walkImage partLeft x y acc + in walkImage partRight (x + V.imageWidth partLeft) y acc' + VertJoin partTop partBottom _ _ -> + let acc' = walkImage partTop x y acc + in walkImage partBottom x (y + V.imageHeight partTop) acc' + BGFill outputWidth outputHeight -> + foldl' + (\m (dx, dy) -> Map.insertWith (\_ old -> old) (x + dx, y + dy) (' ', V.defAttr) m) + acc + [(dx, dy) | dx <- [0 .. outputWidth - 1], dy <- [0 .. outputHeight - 1]] + Crop croppedImage leftSkip topSkip outputWidth outputHeight -> + let innerCells = walkImage croppedImage 0 0 Map.empty + visible = + [ ((x + kx - leftSkip, y + ky - topSkip), cell) + | ((kx, ky), cell) <- Map.toList innerCells + , kx >= leftSkip + , kx < leftSkip + outputWidth + , ky >= topSkip + , ky < topSkip + outputHeight + ] + in foldl' (\m (pos, cell) -> Map.insert pos cell m) acc visible + EmptyImage -> acc + +placeText :: V.Attr -> String -> Int -> Int -> CellMap -> CellMap +placeText attr chars x y = + go chars 0 + where + go [] _ acc = acc + go (c : cs) dx acc = + let w = wcwidth c + in if w <= 0 + then go cs dx acc + else go cs (dx + w) (Map.insert (x + dx, y) (c, attr) acc) diff --git a/src/Reflex/Vty/Color.hs b/src/Reflex/Vty/Color.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Color.hs @@ -0,0 +1,162 @@ +-- | +-- Module: Reflex.Vty.Color +-- Description: Color manipulation and gradient utilities +module Reflex.Vty.Color + ( -- * RGB color type + RGB (..) + , toRGB + , fromRGB + + -- * Color operations + , darken + , lighten + , complementary + , mix + , alpha + + -- * Gradients + , Gradient1D (..) + , gradient1D + , sampleGradient1D + , Gradient2D (..) + , gradient2D + , sampleGradient2D + ) where + +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Word (Word8) +import qualified Graphics.Vty as V + +---------------------------------------------------------------------------- +-- RGB color type +---------------------------------------------------------------------------- + +-- | An sRGB color triplet. This is the working type for all color +-- operations; convert to\/from vty's 'V.Color' with 'toRGB' \/ 'fromRGB'. +data RGB = RGB + { rgbRed :: !Word8 + , rgbGreen :: !Word8 + , rgbBlue :: !Word8 + } + deriving (Eq, Ord, Show) + +-- | Extract 'RGB' components from a vty 'V.Color'. Returns 'Nothing' for +-- 'ISOColor' and 'Color240' (which require a palette lookup). +toRGB :: V.Color -> Maybe RGB +toRGB (V.RGBColor r g b) = Just (RGB r g b) +toRGB _ = Nothing + +-- | Convert an 'RGB' triplet to a vty 'V.Color' as an 'RGBColor'. +fromRGB :: RGB -> V.Color +fromRGB (RGB r g b) = V.RGBColor r g b + +---------------------------------------------------------------------------- +-- Color operations +---------------------------------------------------------------------------- + +-- | Darken a color by a factor. +-- @darken 0.0@ = black, @darken 1.0@ = unchanged. +darken :: Double -> RGB -> RGB +darken factor (RGB r g b) = + RGB (scale r) (scale g) (scale b) + where + scale c = clampByte (fromIntegral c * clamp01 factor) + +-- | Lighten a color by a factor (towards white). +-- @lighten 0.0@ = unchanged, @lighten 1.0@ = white. +lighten :: Double -> RGB -> RGB +lighten factor (RGB r g b) = + RGB (lift r) (lift g) (lift b) + where + f = clamp01 factor + lift c = clampByte (fromIntegral c + (255 - fromIntegral c) * f) + +-- | Complementary color (RGB inversion). +complementary :: RGB -> RGB +complementary (RGB r g b) = + RGB (255 - r) (255 - g) (255 - b) + +-- | Mix two colors. +-- @mix 0.0 a b@ = @a@, @mix 1.0 a b@ = @b@, @mix 0.5 a b@ = average. +mix :: Double -> RGB -> RGB -> RGB +mix t (RGB r1 g1 b1) (RGB r2 g2 b2) = + RGB (blend r1 r2) (blend g1 g2) (blend b1 b2) + where + f = clamp01 t + blend a b = clampByte (fromIntegral a * (1 - f) + fromIntegral b * f) + +-- | Alpha-blend a foreground over a background. +-- @alpha 0.0 fg bg@ = @bg@ (transparent), @alpha 1.0 fg bg@ = @fg@ (opaque). +alpha :: Double -> RGB -> RGB -> RGB +alpha t fg bg = mix t bg fg + +---------------------------------------------------------------------------- +-- Gradients (1D) +---------------------------------------------------------------------------- + +-- | A 1D gradient defined by color stops at positions [0, 1]. +data Gradient1D = Gradient1D + { gradient1DStops :: [(Double, RGB)] + -- ^ Sorted list of (position, color) pairs. + } + +-- | Create a 1D gradient from a list of stops. Stops are sorted by +-- position. Positions should be in [0, 1]. +gradient1D :: [(Double, RGB)] -> Gradient1D +gradient1D = Gradient1D . sortBy (comparing fst) + +-- | Sample a 1D gradient at the given position [0, 1]. +-- Linearly interpolates between the two nearest stops. +sampleGradient1D :: Gradient1D -> Double -> RGB +sampleGradient1D (Gradient1D stops) pos + | null stops = RGB 0 0 0 + | pos <= 0 = snd (headStops stops) + | pos >= 1 = snd (last stops) + | otherwise = go stops + where + headStops :: [(Double, RGB)] -> (Double, RGB) + headStops ((_, c) : _) = (0, c) + headStops [] = (0, RGB 0 0 0) + go ((p1, c1) : rest@((p2, c2) : _)) + | pos <= p2 = lerp (pos - p1) (p2 - p1) c1 c2 + | otherwise = go rest + go [(_, c)] = c + go [] = RGB 0 0 0 + +---------------------------------------------------------------------------- +-- Gradients (2D) +---------------------------------------------------------------------------- + +-- | A 2D gradient defined by four corner colors. +data Gradient2D = Gradient2D + { gradient2DTopLeft :: !RGB + , gradient2DTopRight :: !RGB + , gradient2DBottomLeft :: !RGB + , gradient2DBottomRight :: !RGB + } + +-- | Create a 2D gradient from four corner colors (TL, TR, BL, BR). +gradient2D :: RGB -> RGB -> RGB -> RGB -> Gradient2D +gradient2D = Gradient2D + +-- | Sample a 2D gradient at the given (x, y) position, each in [0, 1]. +-- Uses bilinear interpolation between the four corners. +sampleGradient2D :: Gradient2D -> Double -> Double -> RGB +sampleGradient2D (Gradient2D tl tr bl br) x y = + mix y (mix x tl tr) (mix x bl br) + +---------------------------------------------------------------------------- +-- Internal helpers +---------------------------------------------------------------------------- + +lerp :: Double -> Double -> RGB -> RGB -> RGB +lerp t range c1 c2 + | range <= 0 = c2 + | otherwise = mix (t / range) c1 c2 + +clamp01 :: Double -> Double +clamp01 = max 0 . min 1 + +clampByte :: Double -> Word8 +clampByte x = fromIntegral (round (max 0 (min (255 :: Double) x)) :: Int) diff --git a/src/Reflex/Vty/ColorProfile.hs b/src/Reflex/Vty/ColorProfile.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/ColorProfile.hs @@ -0,0 +1,156 @@ +-- | +-- Module: Reflex.Vty.ColorProfile +-- Description: Terminal color-capability detection and downsampling +-- +-- A 'ColorProfile' describes how many colors the terminal can display. +-- 'detectColorProfile' reads the capability from a vty +-- 'Graphics.Vty.Output.Output' handle, and 'applyProfile' downsamples an +-- 'Graphics.Vty.Attr' so that colors and styles the terminal cannot render are +-- replaced with the closest approximation (or dropped entirely for +-- 'ColorProfile_Ascii' and 'ColorProfile_NoTTY'). +-- +-- Widgets build with 'Graphics.Vty.Attributes.Color.RGBColor' (which is true +-- color) and the host downsamples once per frame at the 'Graphics.Vty.Picture' +-- boundary, so widget code never needs to worry about terminal capability. +module Reflex.Vty.ColorProfile + ( ColorProfile (..) + , colorProfileFromColorMode + , colorProfileFromVty + , detectColorProfile + , convertColor + , applyProfile + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.List (minimumBy) +import Data.Ord (comparing) +import qualified Graphics.Vty as V +import qualified Graphics.Vty.Attributes.Color as V.Color +import qualified Graphics.Vty.Attributes.Color240 as V.Color240 +import qualified Graphics.Vty.Output as V.Output + +-- | The color rendering capability of a terminal. Ordered from richest to +-- poorest; see 'applyProfile' for how each profile affects an 'V.Attr'. +data ColorProfile + = -- | 24-bit RGB; any color renders verbatim. + ColorProfile_TrueColor + | -- | 8-bit (216-color cube + 24 greys); 'V.Color.RGBColor' is downsampled + -- to 'V.Color.Color240'. + ColorProfile_Ansi256 + | -- | 4-bit (the 16 ANSI colors); 'V.Color.RGBColor' and 'V.Color.Color240' + -- are downsampled to the nearest 'V.Color.ISOColor'. + ColorProfile_Ansi16 + | -- | No color support; all colors are stripped. + ColorProfile_Ascii + | -- | Not a TTY at all; all ANSI escapes (colors /and/ styles) are stripped. + ColorProfile_NoTTY + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | Map vty's 'V.Color.ColorMode' to a 'ColorProfile'. 'V.Color.ColorMode240' +-- maps to 'ColorProfile_Ansi256'; 'V.Color.FullColor' to 'ColorProfile_TrueColor'; +-- 'V.Color.ColorMode16' to 'ColorProfile_Ansi16'; 'V.Color.ColorMode8' to +-- 'ColorProfile_Ansi16' as well (the 8 ANSI colors are a subset of the 16); +-- 'V.Color.NoColor' to 'ColorProfile_Ascii'. +colorProfileFromColorMode :: V.Color.ColorMode -> ColorProfile +colorProfileFromColorMode = \case + V.Color.NoColor -> ColorProfile_Ascii + V.Color.ColorMode8 -> ColorProfile_Ansi16 + V.Color.ColorMode16 -> ColorProfile_Ansi16 + V.Color.ColorMode240 {} -> ColorProfile_Ansi256 + V.Color.FullColor -> ColorProfile_TrueColor + +-- | Read the color profile from a vty 'V.Output.Output' by inspecting its +-- 'V.Output.outputColorMode'. +colorProfileFromVty :: V.Vty -> ColorProfile +colorProfileFromVty = colorProfileFromColorMode . V.Output.outputColorMode . V.outputIface + +-- | 'colorProfileFromVty' in 'MonadIO' for convenience at call sites that +-- are already lifted. Reads from the 'V.Vty' handle's output interface. +detectColorProfile :: MonadIO m => V.Vty -> m ColorProfile +detectColorProfile = pure . colorProfileFromVty + +-- | Downsample a single 'V.Color' to the closest representation the profile +-- can render. For 'ColorProfile_Ascii' and 'ColorProfile_NoTTY' the color is +-- returned unchanged: callers should use 'applyProfile' to set the +-- surrounding 'V.Attr' field to 'V.Default' instead, since those profiles +-- have no color representation at all. +convertColor :: ColorProfile -> V.Color.Color -> V.Color.Color +convertColor = \case + ColorProfile_TrueColor -> id + ColorProfile_Ansi256 -> \case + V.Color.RGBColor r g b -> V.Color.Color240 (V.Color240.rgbColorToColor240 r g b) + c -> c + ColorProfile_Ansi16 -> nearestIso + ColorProfile_Ascii -> id + ColorProfile_NoTTY -> id + +-- | Downsample an entire 'V.Attr' for the profile: colors via 'convertColor', +-- and for 'ColorProfile_Ascii' / 'ColorProfile_NoTTY' the foreground, +-- background, and style are all reset to 'V.Default' so no color or style +-- escapes are emitted. The URL field is preserved (hyperlinks are not color). +applyProfile :: ColorProfile -> V.Attr -> V.Attr +applyProfile profile attr = case profile of + ColorProfile_NoTTY -> + attr {V.attrStyle = V.Default, V.attrForeColor = V.Default, V.attrBackColor = V.Default} + ColorProfile_Ascii -> + attr {V.attrForeColor = V.Default, V.attrBackColor = V.Default} + _ -> + attr + { V.attrForeColor = downsampleColorField V.attrForeColor + , V.attrBackColor = downsampleColorField V.attrBackColor + } + where + downsampleColorField sel = case sel attr of + V.SetTo c -> V.SetTo (convertColor profile c) + other -> other + +-- | Perceptual nearest-neighbor mapping from any 'V.Color' to the closest of +-- the 16 ANSI 'V.Color.ISOColor' values. Uses the standard xterm 16-color +-- RGB table and the redmean weighted distance, which approximates human +-- color perception better than naive Euclidean RGB distance. +nearestIso :: V.Color.Color -> V.Color.Color +nearestIso c = case c of + V.Color.ISOColor {} -> c + V.Color.Color240 i -> case V.Color240.color240CodeToRGB i of + Nothing -> c + Just rgb3 -> nearestIsoRGB rgb3 + V.Color.RGBColor r g b -> nearestIsoRGB (fromIntegral r, fromIntegral g, fromIntegral b) + +-- | The 16 ANSI colors paired with their standard xterm RGB coordinates. +isoRgbTable :: [(V.Color.Color, (Int, Int, Int))] +isoRgbTable = + [ (V.Color.black, (0, 0, 0)) + , (V.Color.red, (205, 0, 0)) + , (V.Color.green, (0, 205, 0)) + , (V.Color.yellow, (205, 205, 0)) + , (V.Color.blue, (0, 0, 205)) + , (V.Color.magenta, (205, 0, 205)) + , (V.Color.cyan, (0, 205, 205)) + , (V.Color.white, (229, 229, 229)) + , (V.Color.brightBlack, (127, 127, 127)) + , (V.Color.brightRed, (255, 0, 0)) + , (V.Color.brightGreen, (0, 255, 0)) + , (V.Color.brightYellow, (255, 255, 0)) + , (V.Color.brightBlue, (0, 0, 255)) + , (V.Color.brightMagenta, (255, 0, 255)) + , (V.Color.brightCyan, (0, 255, 255)) + , (V.Color.brightWhite, (255, 255, 255)) + ] + +-- | Redmean weighted distance between two RGB triples. Approximates +-- human color perception: green matters most, then red, then blue. +rgbDistanceSq :: (Int, Int, Int) -> (Int, Int, Int) -> Int +rgbDistanceSq (r1, g1, b1) (r2, g2, b2) = + ((512 + rmean) * dr * dr) `div` 256 + + 4 * dg * dg + + ((512 + 255 - rmean) * db * db) `div` 256 + where + rmean = (r1 + r2) `div` 2 + dr = r1 - r2 + dg = g1 - g2 + db = b1 - b2 + +-- | Find the nearest ANSI-16 color to the given RGB value. +nearestIsoRGB :: (Int, Int, Int) -> V.Color.Color +nearestIsoRGB target = + fst $ minimumBy (comparing (rgbDistanceSq target . snd)) isoRgbTable diff --git a/src/Reflex/Vty/Host.hs b/src/Reflex/Vty/Host.hs --- a/src/Reflex/Vty/Host.hs +++ b/src/Reflex/Vty/Host.hs @@ -1,10 +1,17 @@ -{-| -Module: Reflex.Vty.Host -Description: Scaffolding for running a reflex-vty application --} +-- | +-- Module: Reflex.Vty.Host +-- Description: Scaffolding for running a reflex-vty application module Reflex.Vty.Host ( VtyApp - , VtyResult(..) + , VtyResult (..) + , VtyAppConfig (..) + , defaultVtyAppConfig + , CursorStyle (..) + , CursorVisibility (..) + , setCursorStyle + , ScreenMode (..) + , setScreenMode + , Signal , getDefaultVty , runVtyApp , runVtyAppWithHandle @@ -13,26 +20,40 @@ ) where import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.Chan (newChan, readChan, writeChan) +import Control.Concurrent.STM (atomically) import Control.Exception (onException) import Control.Monad (forM, forM_, forever) -import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix (MonadFix, fix) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.Identity (Identity(..)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Identity (Identity (..)) import Control.Monad.Primitive (PrimMonad) import Control.Monad.Ref (MonadRef, Ref, readRef) +import Data.Default (Default (..)) import Data.Dependent.Sum (DSum ((:=>))) import Data.IORef (IORef, readIORef) import Data.Maybe (catMaybes) - -import Reflex -import Reflex.Host.Class -import Reflex.Spider.Orphans () +import Graphics.Vty (DisplayRegion) import qualified Graphics.Vty as V import qualified Graphics.Vty.CrossPlatform as V +import Reflex +import Reflex.Host.Class +import System.Posix.Signals + ( Handler (..) + , Signal + , installHandler + , sigHUP + , sigINT + , sigTERM + ) -import Graphics.Vty (DisplayRegion) +import Reflex.Vty.Host.Trigger + ( closeBoundedEventQueue + , drainBoundedEventQueue + , newBoundedEventQueue + , runBoundedTriggerT + , writeBoundedEventQueue + ) -- | A synonym for the underlying vty event type from 'Graphics.Vty'. This should -- probably ultimately be replaced by something defined in this library. @@ -42,7 +63,7 @@ data VtyResult t = VtyResult { _vtyResult_picture :: Behavior t V.Picture -- ^ The current vty output. 'runVtyAppWithHandle' samples this value every time an - -- event fires and updates the display. + -- event fires and updates the display. , _vtyResult_shutdown :: Event t () -- ^ An event that requests application termination. } @@ -74,33 +95,59 @@ ) -- | A functional reactive vty application. -type VtyApp t m = MonadVtyApp t m +type VtyApp t m = + MonadVtyApp t m => DisplayRegion -- ^ The initial display size (updates to this come as events) -> Event t V.Event -- ^ Vty input events. + -> Event t Signal + -- ^ POSIX signal events (SIGINT, SIGTERM, SIGHUP). All three automatically + -- trigger shutdown; apps can observe them for custom handling before exit. -> m (VtyResult t) -- ^ The output of the 'VtyApp'. The application runs in a context that, - -- among other things, allows new events to be created and triggered - -- ('TriggerEvent'), provides access to an event that fires immediately upon - -- app instantiation ('PostBuild'), and allows actions to be run upon - -- occurrences of events ('PerformEvent'). + -- among other things, allows new events to be created and triggered + -- ('TriggerEvent'), provides access to an event that fires immediately upon + -- app instantiation ('PostBuild'), and allows actions to be run upon + -- occurrences of events ('PerformEvent'). +-- | Configuration for running a 'VtyApp'. +data VtyAppConfig = VtyAppConfig + { _vtyConfig_eventQueueCapacity :: !Int + -- ^ Maximum number of pending external trigger invocations the host will + -- buffer before backpressuring producers (e.g. a hot + -- 'Reflex.performEventAsync' callback). When the buffer is full, a + -- producer's @fire@ blocks until the host catches up, bounding memory + -- without dropping any occurrences. See 'defaultVtyAppConfig'. + } + +-- | A sensible default 'VtyAppConfig': an event-queue capacity of 4096, which +-- is large enough to absorb any realistic burst (a large paste, a flappy +-- mouse, network callbacks) without throttling, while keeping worst-case +-- per-frame fire work and memory modest (~530 KB ceiling). +instance Default VtyAppConfig where + def = VtyAppConfig {_vtyConfig_eventQueueCapacity = 4096} + +-- | The default 'VtyAppConfig' (identical to 'def'). +defaultVtyAppConfig :: VtyAppConfig +defaultVtyAppConfig = def + -- | Runs a 'VtyApp' in a given 'Graphics.Vty.Vty'. runVtyAppWithHandle - :: V.Vty + :: VtyAppConfig + -- ^ Host configuration (event-queue capacity, etc.). Use + -- 'defaultVtyAppConfig' for defaults. + -> V.Vty -- ^ A 'Graphics.Vty.Vty' handle. -> (forall t m. VtyApp t m) -- ^ A functional reactive vty application. -> IO () -runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $ - +runVtyAppWithHandle cfg vty vtyGuest = flip onException (V.shutdown vty) $ -- We are using the 'Spider' implementation of reflex. Running the host -- allows us to take actions on the FRP timeline. The scoped type signature -- specifies that our host runs on the Global timeline. -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'. (runSpiderHost :: SpiderHost Global a -> IO a) $ do - -- Create an 'Event' and a "trigger" reference for that event. The trigger -- reference can be used to determine whether anyone is "subscribed" to -- that 'Event' and, therefore, whether we need to bother performing any @@ -112,34 +159,42 @@ -- once, when the application starts. (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef - -- Create a queue to which we will write 'Event's that need to be - -- processed. - events <- liftIO newChan + -- Create an 'Event' for POSIX signals. + (signalEvent, signalTriggerRef) <- newEventWithTriggerRef + -- A bounded, closeable queue into which external triggers write their + -- pending invocations. Boundedness gives us backpressure (a producer that + -- fires faster than the host can process has its @fire@ block when the + -- queue is full), which bounds memory without dropping occurrences. The + -- guest runs in 'BoundedTriggerT' below so that its 'TriggerEvent' + -- methods (and hence 'Reflex.performEventAsync') route writes through + -- this queue. + pending <- + liftIO $ + newBoundedEventQueue (fromIntegral (max 1 (_vtyConfig_eventQueueCapacity cfg))) + displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty -- Run the vty "guest" application, providing the appropriate context. The -- result is a 'VtyResult', and a 'FireCommand' that will be used to -- trigger events. (vtyResult, fc@(FireCommand fire)) <- do - hostPerformEventT $ -- Allows the guest app to run - -- 'performEvent', so that actions - -- (e.g., IO actions) can be run when - -- 'Event's fire. - - flip runPostBuildT postBuild $ -- Allows the guest app to access to - -- a "post-build" 'Event' - - flip runTriggerEventT events $ -- Allows the guest app to create new - -- events and triggers and writes - -- those triggers to a channel from - -- which they will be read and - -- processed. - - vtyGuest displayRegion0 vtyEvent - -- The guest app is provided the - -- initial display region and an - -- 'Event' of vty inputs. + hostPerformEventT $ -- Allows the guest app to run + -- 'performEvent', so that actions + -- (e.g., IO actions) can be run when + -- 'Event's fire. + flip runPostBuildT postBuild $ -- Allows the guest app to access to + -- a "post-build" 'Event' + flip runBoundedTriggerT pending $ -- Allows the guest app to create new + -- events and triggers; writes route + -- through the bounded queue above so + -- that hot producers backpressure + -- instead of leaking. + vtyGuest displayRegion0 vtyEvent signalEvent + -- The guest app is provided the + -- initial display region, an + -- 'Event' of vty inputs, and an + -- 'Event' of POSIX signals. -- Reads the current value of the 'Picture' behavior and updates the -- display with it. This will be called whenever we determine that a @@ -162,8 +217,10 @@ -- Subscribe to an 'Event' of that the guest application can use to -- request application shutdown. We'll check whether this 'Event' is firing - -- to determine whether to terminate. - shutdown <- subscribeEvent $ _vtyResult_shutdown vtyResult + -- to determine whether to terminate. SIGINT, SIGTERM, and SIGHUP from the + -- host also trigger shutdown. + let sigShutdown = () <$ ffilter (\s -> s == sigINT || s == sigTERM || s == sigHUP) signalEvent + shutdown <- subscribeEvent $ leftmost [_vtyResult_shutdown vtyResult, sigShutdown] -- Fork a thread and continuously get the next vty input event, and then -- write the input event to our channel of FRP 'Event' triggers. @@ -179,32 +236,64 @@ -- if nobody is subscribed to the 'Event'. triggerInvocation = TriggerInvocation ne $ return () -- Write our input event's 'EventTrigger' with the newly created - -- 'TriggerInvocation' value to the queue of events. - writeChan events [triggerRef :=> triggerInvocation] + -- 'TriggerInvocation' value to the queue of events. (Like all external + -- triggers, this is subject to backpressure if the queue is full; in + -- practice input never saturates it.) + atomically $ writeBoundedEventQueue pending [triggerRef :=> triggerInvocation] - -- The main application loop. We wait for new events, fire those that - -- have subscribers, and update the display. If we detect a shutdown - -- request, the application terminates. - fix $ \loop -> do - -- Read the next event (blocking). - ers <- liftIO $ readChan events - stop <- do - -- Fire events that have subscribers. - fireEventTriggerRefs fc ers $ - -- Check if the shutdown 'Event' is firing. - readEvent shutdown >>= \case - Nothing -> return False - Just _ -> return True - if or stop - then liftIO $ do -- If we received a shutdown 'Event' - killThread nextEventThread -- then stop reading input events and - V.shutdown vty -- call the 'Graphics.Vty.Vty's shutdown command. + -- Install POSIX signal handlers. Each handler writes the signal value + -- into the bounded FRP event queue. The RTS runs 'Catch' actions in a + -- separate thread, so the STM write is safe here. + liftIO $ forM_ [sigINT, sigTERM, sigHUP] $ \sig -> + installHandler sig (Catch $ atomically $ writeBoundedEventQueue pending [EventTriggerRef signalTriggerRef :=> TriggerInvocation sig (return ())]) Nothing - else do -- Otherwise, update the display and loop. - updateVty - loop + -- The main application loop. We block until at least one batch of events + -- is available, then drain every other batch that has accumulated in the + -- meantime, fire each batch in its own Reflex frame, and redraw once. + -- + -- Draining the whole queue each frame keeps the host from falling behind + -- under bursts, while the queue's bounded capacity (see 'VtyAppConfig') + -- backpressures a producer that fires faster than the host can process, + -- bounding memory without dropping occurrences. Firing each batch in its + -- own frame preserves every occurrence even when many firings of the same + -- trigger land in one drain (Reflex collapses simultaneous same-trigger + -- firings, so merging them into one frame would drop occurrences); drawing + -- only once per drain decouples the display rate from the event rate. + fix $ \loop -> do + -- Block until at least one batch is available, then atomically drain + -- every other batch that has accumulated. + mBatches <- liftIO $ drainBoundedEventQueue pending + case mBatches of + -- Queue was closed and empty (e.g. another thread triggered + -- shutdown); stop the loop. + Nothing -> return () + Just batches -> do + -- Fire each batch in its own frame, stopping early if the shutdown + -- event fires. + let fireUntilShutdown [] = return False + fireUntilShutdown (b : bs) = do + stops <- + fireEventTriggerRefs fc b $ + readEvent shutdown >>= \case + Nothing -> return False + Just _ -> return True + if or stops then return True else fireUntilShutdown bs + stop <- fireUntilShutdown batches + if stop + then liftIO $ do + -- If we received a shutdown 'Event', close the queue first so + -- any producer blocked on a full queue is released, then stop + -- reading input, restore the primary screen, and shut vty down. + closeBoundedEventQueue pending + killThread nextEventThread + setScreenMode (V.outputIface vty) ScreenNormal + V.shutdown vty + else do + -- Otherwise, update the display and loop. + updateVty + loop where - -- | Use the given 'FireCommand' to fire events that have subscribers + -- \| Use the given 'FireCommand' to fire events that have subscribers -- and call the callback for the 'TriggerInvocation' of each. fireEventTriggerRefs :: (Monad (ReadPhase m), MonadIO m) @@ -223,17 +312,80 @@ -- | Run a 'VtyApp' with a 'Graphics.Vty.Vty' handle with a standard configuration. runVtyApp - :: (forall t m. VtyApp t m) + :: VtyAppConfig + -> (forall t m. VtyApp t m) -> IO () -runVtyApp app = do +runVtyApp cfg app = do vty <- getDefaultVty - runVtyAppWithHandle vty app + runVtyAppWithHandle cfg vty app --- | Returns the standard vty configuration with mouse mode enabled. +-- | Terminal cursor shape. Not all terminals support all styles; the +-- fallback is always a block cursor. Set via DECSCUSR escape sequences +-- (not part of vty 6.2's API). +data CursorStyle + = -- | Restore the terminal's default cursor shape. + CursorStyleDefault + | -- | Steady block cursor. + CursorStyleBlock + | -- | Steady underline cursor. + CursorStyleUnderline + | -- | Steady vertical bar cursor (xterm extension). + CursorStyleBar + | CursorStyleBlinkingBlock + | CursorStyleSteadyBlock + | CursorStyleBlinkingUnderline + | CursorStyleSteadyUnderline + | -- | Blinking vertical bar (xterm extension). + CursorStyleBlinkingBar + | -- | Steady vertical bar (xterm extension). + CursorStyleSteadyBar + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | Whether the terminal cursor should be rendered. +data CursorVisibility + = CursorVisible + | CursorHidden + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | Set the terminal cursor shape by emitting DECSCUSR escape sequences +-- directly to the output byte buffer. +setCursorStyle :: V.Output -> CursorStyle -> IO () +setCursorStyle out style = + V.outputByteBuffer out (toSeq style) + where + toSeq CursorStyleDefault = "\ESC[0 q" + toSeq CursorStyleBlock = "\ESC[2 q" + toSeq CursorStyleUnderline = "\ESC[4 q" + toSeq CursorStyleBar = "\ESC[6 q" + toSeq CursorStyleBlinkingBlock = "\ESC[1 q" + toSeq CursorStyleSteadyBlock = "\ESC[2 q" + toSeq CursorStyleBlinkingUnderline = "\ESC[3 q" + toSeq CursorStyleSteadyUnderline = "\ESC[4 q" + toSeq CursorStyleBlinkingBar = "\ESC[5 q" + toSeq CursorStyleSteadyBar = "\ESC[6 q" + +-- | Which screen buffer to use. Most full-screen TUI apps use the +-- alternate screen so the terminal restores prior content on exit. +data ScreenMode + = ScreenNormal + | ScreenAlternate + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | Enter or exit the alternate screen buffer by emitting DECSET/DECRST +-- escape sequences (1049) directly to the output byte buffer. +setScreenMode :: V.Output -> ScreenMode -> IO () +setScreenMode out = \case + ScreenNormal -> V.outputByteBuffer out "\ESC[?1049l" + ScreenAlternate -> V.outputByteBuffer out "\ESC[?1049h" + +-- | Returns the standard vty configuration with mouse, focus tracking, +-- and bracketed paste enabled. getDefaultVty :: IO V.Vty getDefaultVty = do cfg <- V.userConfig vty <- V.mkVty cfg - liftIO $ V.setMode (V.outputIface vty) V.Mouse True + liftIO $ do + V.setMode (V.outputIface vty) V.Mouse True + V.setMode (V.outputIface vty) V.Focus True + V.setMode (V.outputIface vty) V.BracketedPaste True return vty - diff --git a/src/Reflex/Vty/Host/Trigger.hs b/src/Reflex/Vty/Host/Trigger.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Host/Trigger.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Reflex.Vty.Host.Trigger +-- Description: A bounded 'TriggerEvent' layer that backpressures hot producers +-- +-- This is an internal module used by "Reflex.Vty.Host". It provides a drop-in +-- replacement for reflex's @'Reflex.TriggerEvent.Base.TriggerEventT'@ whose +-- underlying queue is bounded and closeable. External triggers +-- ('Reflex.performEventAsync', 'Reflex.newTriggerEvent', etc.) write into a +-- fixed-capacity queue, so a producer that fires faster than the host can +-- process is throttled (its @fire@ callback blocks when the queue is full) +-- rather than allowed to exhaust memory. Because the producer's own write +-- blocks, no event occurrences are dropped. +-- +-- The queue is also closeable: on shutdown the host closes it, which releases +-- any producer currently blocked on a full queue. +module Reflex.Vty.Host.Trigger + ( -- * Bounded event queue + BoundedEventQueue + , newBoundedEventQueue + , closeBoundedEventQueue + , writeBoundedEventQueue + , drainBoundedEventQueue + + -- * TriggerEvent transformer + , BoundedTriggerT + , runBoundedTriggerT + ) where + +import Control.Concurrent.STM + ( STM + , TBQueue + , TMVar + , atomically + , flushTBQueue + , newEmptyTMVarIO + , newTBQueueIO + , orElse + , readTBQueue + , readTMVar + , tryPutTMVar + , writeTBQueue + ) +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Morph (MFunctor (hoist)) +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Ref (MonadAtomicRef (..), MonadRef (..), Ref) +import Control.Monad.Trans (MonadTrans, lift) +import Data.Coerce (coerce) +import Data.Dependent.Sum (DSum ((:=>))) +import Numeric.Natural (Natural) +import Reflex +import Reflex.Host.Class (MonadReflexCreateTrigger (..), newEventWithTriggerRef) + +-- | A pending batch of trigger invocations. Each external @fire@ enqueues one +-- such batch (almost always a singleton). +type Batch t = [DSum (EventTriggerRef t) TriggerInvocation] + +-- | A bounded, closeable queue of pending trigger invocations. +-- +-- * Writes ('writeBoundedEventQueue') block when the queue is full +-- (backpressure to the producer). +-- * Once closed, writes return immediately without enqueueing, so producers +-- blocked at shutdown are released. +-- * Reads ('drainBoundedEventQueue') block until at least one batch is +-- available (or the queue is closed), then drain everything currently +-- queued. +data BoundedEventQueue t = BoundedEventQueue + { _beqQueue :: !(TBQueue (Batch t)) + , _beqClosed :: !(TMVar ()) + -- ^ Full when the queue has been closed. + } + +-- | Create a bounded event queue with the given capacity. Capacity must be at +-- least 1; smaller values are clamped to 1. +newBoundedEventQueue :: Natural -> IO (BoundedEventQueue t) +newBoundedEventQueue cap = + BoundedEventQueue + <$> newTBQueueIO (max 1 cap) + <*> newEmptyTMVarIO + +-- | Close a queue. Idempotent. After this call, blocked and future writers +-- return immediately without enqueueing. +closeBoundedEventQueue :: BoundedEventQueue t -> IO () +closeBoundedEventQueue q = atomically $ void $ tryPutTMVar (_beqClosed q) () + +-- | Enqueue a batch, blocking if the queue is full. Becomes a no-op once the +-- queue is closed (so a producer blocked here unblocks on shutdown). +writeBoundedEventQueue :: BoundedEventQueue t -> Batch t -> STM () +writeBoundedEventQueue q batch = + -- If there is room, write. Otherwise retry until there is room /or/ the + -- queue is closed (in which case silently drop). + writeTBQueue (_beqQueue q) batch `orElse` void (readTMVar (_beqClosed q)) + +-- | Block until at least one batch is available, then return it together with +-- every other batch currently queued, as a list of distinct batches (NOT +-- concatenated). The host fires each batch in its own frame so that multiple +-- occurrences of the same trigger that landed in the same drain are preserved +-- (Reflex collapses simultaneous same-trigger firings, so firing them as one +-- batch would drop occurrences). Returns 'Nothing' if the queue is closed and +-- empty. +drainBoundedEventQueue :: BoundedEventQueue t -> IO (Maybe [Batch t]) +drainBoundedEventQueue q = + atomically $ + let readFirst = Just <$> readTBQueue (_beqQueue q) + waitClosed = Nothing <$ readTMVar (_beqClosed q) + in do + mFirst <- readFirst `orElse` waitClosed + case mFirst of + Nothing -> return Nothing + Just first -> do + rest <- flushTBQueue (_beqQueue q) + return $ Just (first : rest) + +---------------------------------------------------------------------------- +-- TriggerEvent transformer +---------------------------------------------------------------------------- + +-- | A 'TriggerEvent' implementation that writes external triggers into a +-- 'BoundedEventQueue', applying backpressure when the queue is full. It is a +-- drop-in replacement for @TriggerEventT@ (same instance set); only its +-- 'TriggerEvent' instance differs, routing writes through +-- 'writeBoundedEventQueue'. +newtype BoundedTriggerT t m a = BoundedTriggerT + { unBoundedTriggerT :: ReaderT (BoundedEventQueue t) m a + } + deriving + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadFix + , MonadIO + , MonadMask + , MonadThrow + ) + +-- | Run a 'BoundedTriggerT' action against a particular 'BoundedEventQueue'. +runBoundedTriggerT :: BoundedTriggerT t m a -> BoundedEventQueue t -> m a +runBoundedTriggerT = runReaderT . unBoundedTriggerT + +instance MonadTrans (BoundedTriggerT t) where + lift = BoundedTriggerT . lift + +instance MFunctor (BoundedTriggerT t) where + hoist f = BoundedTriggerT . hoist f . unBoundedTriggerT + +instance PrimMonad m => PrimMonad (BoundedTriggerT t m) where + type PrimState (BoundedTriggerT t m) = PrimState m + primitive = lift . primitive + +instance PerformEvent t m => PerformEvent t (BoundedTriggerT t m) where + type Performable (BoundedTriggerT t m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance PostBuild t m => PostBuild t (BoundedTriggerT t m) where + getPostBuild = lift getPostBuild + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BoundedTriggerT t m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance NotReady t m => NotReady t (BoundedTriggerT t m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance MonadRef m => MonadRef (BoundedTriggerT t m) where + type Ref (BoundedTriggerT t m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (BoundedTriggerT t m) where + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadSample t m => MonadSample t (BoundedTriggerT t m) where + sample = lift . sample + +instance MonadHold t m => MonadHold t (BoundedTriggerT t m) where + hold v0 v' = lift $ hold v0 v' + holdDyn v0 v' = lift $ holdDyn v0 v' + holdIncremental v0 v' = lift $ holdIncremental v0 v' + buildDynamic a0 = lift . buildDynamic a0 + headE = lift . headE + now = lift now + +instance Adjustable t m => Adjustable t (BoundedTriggerT t m) where + runWithReplace (BoundedTriggerT a0) a' = BoundedTriggerT $ runWithReplace a0 (coerceEvent a') + traverseIntMapWithKeyWithAdjust f dm0 dm' = + BoundedTriggerT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm' + traverseDMapWithKeyWithAdjust f dm0 dm' = + BoundedTriggerT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm' + traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = + BoundedTriggerT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm' + +instance + ( Monad m + , MonadRef m + , Ref m ~ Ref IO + , MonadReflexCreateTrigger t m + ) + => TriggerEvent t (BoundedTriggerT t m) + where + newTriggerEvent = do + (e, t) <- newTriggerEventWithOnComplete + return (e, \a -> t a $ return ()) + newTriggerEventWithOnComplete = do + q <- BoundedTriggerT ask + (eResult, reResultTrigger) <- lift newEventWithTriggerRef + return . (,) eResult $ \a cb -> + atomically $ writeBoundedEventQueue q [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb] + newEventWithLazyTriggerWithOnComplete f = do + q <- BoundedTriggerT ask + lift . newEventWithTrigger $ \t -> + f $ \a cb -> do + reResultTrigger <- newRef $ Just t + atomically $ writeBoundedEventQueue q [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb] diff --git a/src/Reflex/Vty/Style.hs b/src/Reflex/Vty/Style.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Style.hs @@ -0,0 +1,1116 @@ +-- | +-- Module: Reflex.Vty.Style +-- Description: Lip Gloss-inspired declarative styling for vty images +-- +-- A 'Style' is a record of presentation rules (foreground/background color, text +-- transforms and variants, padding, margin, borders, dimensions, and alignment) +-- that can be rendered to 'Graphics.Vty.Image'. Styles support inheritance: +-- 'inherit' fills only the fields that are unset in the child, and the 'with*' +-- setters replace fields. +-- +-- Use 'render' or 'renderB' to produce an 'Image' from a 'Style' and some text. +module Reflex.Vty.Style + ( -- * Types + Style (..) + , def + + -- ** Sub-types + , Color + , UnderlineStyle (..) + , BorderStyle (..) + , HAlign (..) + , VAlign (..) + , Padding (..) + , Margin (..) + + -- * Color constants + , black + , red + , green + , yellow + , blue + , magenta + , cyan + , white + , brightBlack + , brightRed + , brightGreen + , brightYellow + , brightBlue + , brightMagenta + , brightCyan + , brightWhite + , rgbColor + + -- * Border style presets + , singleBorder + , roundedBorder + , thickBorder + , doubleBorder + , asciiBorder + , markdownBorder + , noBorder + , innerHalfBorder + , outerHalfBlockBorder + + -- * Setters + + -- ** Color + , withForeground + , withBackground + + -- ** Text transforms + , withBold + , withItalic + , withFaint + , withBlink + , withStrikethrough + , withReverse + + -- ** Underline + , withUnderline + , withUnderlineColor + + -- ** Hyperlink + , withHyperlink + + -- ** Padding and margin + , withPadding + , withPaddingTop + , withPaddingRight + , withPaddingBottom + , withPaddingLeft + , withMargin + , withMarginTop + , withMarginRight + , withMarginBottom + , withMarginLeft + + -- ** Border + , withBorder + , withBorderForeground + , withBorderBackground + , withBorderTop + , withBorderBottom + , withBorderLeft + , withBorderRight + + -- ** Dimensions + , withWidth + , withHeight + , withMaxWidth + , withMaxHeight + + -- ** Alignment + , withAlignH + , withAlignV + + -- ** Whitespace + , withWhitespace + + -- ** Text transform + , withTransform + + -- ** Tab width + , withTabWidth + + -- ** Margin background + , withMarginBackground + + -- ** Inline mode + , withInline + + -- ** Color whitespace + , withColorWhitespace + + -- ** Per-side border colors + , withBorderTopForeground + , withBorderTopBackground + , withBorderBottomForeground + , withBorderBottomBackground + , withBorderLeftForeground + , withBorderLeftBackground + , withBorderRightForeground + , withBorderRightBackground + + -- * Composition + , inherit + + -- * Rendering + , render + , renderB + , applyAttr + , mergeAttr + , measure + + -- * Image composition + , joinHorizontal + , joinVertical + , placeHorizontal + , placeVertical + , place + + -- * Text utilities + , truncateWith + , textHeight + , textSize + ) where + +import Control.Applicative ((<|>)) +import Data.Default (Default (..)) +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Graphics.Vty as V +import Reflex (Behavior, Reflex) + +import Data.Text.Zipper (charWidth, textWidth) + +-- | A terminal color. Currently an alias for vty's 'V.Color'; this keeps the +-- public API stable if vty's representation changes later. +type Color = V.Color + +-- | Underline decoration variants. vty only supports a single +-- 'V.underline' style bit, so 'UnderlineSingle' is the only one rendered +-- distinctly; the others are accepted for API compatibility with Lip Gloss +-- and degrade to single underline (or none) at render time. +data UnderlineStyle + = UnderlineNone + | UnderlineSingle + | UnderlineDouble + | UnderlineCurly + | UnderlineDotted + | UnderlineDashed + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | Horizontal alignment within the available width. +data HAlign = HAlignLeft | HAlignCenter | HAlignRight + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | Vertical alignment within the available height. +data VAlign = VAlignTop | VAlignMiddle | VAlignBottom + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | Padding on the four sides (top, right, bottom, left), in cells. +data Padding = Padding + { _padding_top :: !Int + , _padding_right :: !Int + , _padding_bottom :: !Int + , _padding_left :: !Int + } + deriving (Eq, Ord, Show) + +instance Default Padding where + def = Padding 0 0 0 0 + +-- | Margin on the four sides (top, right, bottom, left), in cells. Margin +-- is drawn outside the border using the same whitespace character as +-- padding. +data Margin = Margin + { _margin_top :: !Int + , _margin_right :: !Int + , _margin_bottom :: !Int + , _margin_left :: !Int + } + deriving (Eq, Ord, Show) + +instance Default Margin where + def = Margin 0 0 0 0 + +-- | The eight characters that make up a box border. 'Nothing' on a side +-- means the side is not drawn; 'Nothing' on a corner means the corner is +-- not drawn when both adjacent sides are present. +data BorderStyle = BorderStyle + { _border_top :: !(Maybe Char) + , _border_bottom :: !(Maybe Char) + , _border_left :: !(Maybe Char) + , _border_right :: !(Maybe Char) + , _border_topLeft :: !(Maybe Char) + , _border_topRight :: !(Maybe Char) + , _border_bottomLeft :: !(Maybe Char) + , _border_bottomRight :: !(Maybe Char) + } + deriving (Eq, Ord, Show) + +-- | A declarative presentational style, modelled on Lip Gloss's @Style@. +-- Every field is 'Maybe' so that 'inherit' can fill only the gaps; use the +-- 'with*' setters to populate fields and 'def' for an empty style. +data Style = Style + { _style_foreground :: !(Maybe Color) + , _style_background :: !(Maybe Color) + , _style_bold :: !(Maybe Bool) + , _style_italic :: !(Maybe Bool) + , _style_faint :: !(Maybe Bool) + , _style_blink :: !(Maybe Bool) + , _style_strikethrough :: !(Maybe Bool) + , _style_reverse :: !(Maybe Bool) + , _style_underline :: !(Maybe UnderlineStyle) + , _style_underlineColor :: !(Maybe Color) + , _style_hyperlink :: !(Maybe Text) + , _style_padding :: !Padding + , _style_margin :: !Margin + , _style_border :: !(Maybe BorderStyle) + , _style_borderTop :: !(Maybe Bool) + , _style_borderBottom :: !(Maybe Bool) + , _style_borderLeft :: !(Maybe Bool) + , _style_borderRight :: !(Maybe Bool) + , _style_borderForeground :: !(Maybe Color) + , _style_borderBackground :: !(Maybe Color) + , _style_width :: !(Maybe Int) + , _style_height :: !(Maybe Int) + , _style_maxWidth :: !(Maybe Int) + , _style_maxHeight :: !(Maybe Int) + , _style_alignHorizontal :: !(Maybe HAlign) + , _style_alignVertical :: !(Maybe VAlign) + , _style_whitespaceChar :: !(Maybe Char) + , _style_transform :: !(Maybe (Text -> Text)) + , _style_tabWidth :: !(Maybe Int) + , _style_marginBackground :: !(Maybe Color) + , _style_inline :: !(Maybe Bool) + , _style_colorWhitespace :: !(Maybe Bool) + , _style_borderTopForeground :: !(Maybe Color) + , _style_borderTopBackground :: !(Maybe Color) + , _style_borderBottomForeground :: !(Maybe Color) + , _style_borderBottomBackground :: !(Maybe Color) + , _style_borderLeftForeground :: !(Maybe Color) + , _style_borderLeftBackground :: !(Maybe Color) + , _style_borderRightForeground :: !(Maybe Color) + , _style_borderRightBackground :: !(Maybe Color) + } + +instance Default Style where + def = + Style + { _style_foreground = Nothing + , _style_background = Nothing + , _style_bold = Nothing + , _style_italic = Nothing + , _style_faint = Nothing + , _style_blink = Nothing + , _style_strikethrough = Nothing + , _style_reverse = Nothing + , _style_underline = Nothing + , _style_underlineColor = Nothing + , _style_hyperlink = Nothing + , _style_padding = def + , _style_margin = def + , _style_border = Nothing + , _style_borderTop = Nothing + , _style_borderBottom = Nothing + , _style_borderLeft = Nothing + , _style_borderRight = Nothing + , _style_borderForeground = Nothing + , _style_borderBackground = Nothing + , _style_width = Nothing + , _style_height = Nothing + , _style_maxWidth = Nothing + , _style_maxHeight = Nothing + , _style_alignHorizontal = Nothing + , _style_alignVertical = Nothing + , _style_whitespaceChar = Nothing + , _style_transform = Nothing + , _style_tabWidth = Nothing + , _style_marginBackground = Nothing + , _style_inline = Nothing + , _style_colorWhitespace = Nothing + , _style_borderTopForeground = Nothing + , _style_borderTopBackground = Nothing + , _style_borderBottomForeground = Nothing + , _style_borderBottomBackground = Nothing + , _style_borderLeftForeground = Nothing + , _style_borderLeftBackground = Nothing + , _style_borderRightForeground = Nothing + , _style_borderRightBackground = Nothing + } + +-- | Fill the gaps in @child@ with values from @parent@. Only 'Nothing' +-- fields (and zero padding/margin) are inherited; non-'Nothing' fields in +-- @child@ are kept. This mirrors Lip Gloss's @Inherit@ semantics. +inherit :: Style -> Style -> Style +inherit parent child = + Style + { _style_foreground = pick _style_foreground + , _style_background = pick _style_background + , _style_bold = pick _style_bold + , _style_italic = pick _style_italic + , _style_faint = pick _style_faint + , _style_blink = pick _style_blink + , _style_strikethrough = pick _style_strikethrough + , _style_reverse = pick _style_reverse + , _style_underline = pick _style_underline + , _style_underlineColor = pick _style_underlineColor + , _style_hyperlink = pick _style_hyperlink + , _style_padding = inheritPadding (_style_padding parent) (_style_padding child) + , _style_margin = inheritMargin (_style_margin parent) (_style_margin child) + , _style_border = pick _style_border + , _style_borderTop = pick _style_borderTop + , _style_borderBottom = pick _style_borderBottom + , _style_borderLeft = pick _style_borderLeft + , _style_borderRight = pick _style_borderRight + , _style_borderForeground = pick _style_borderForeground + , _style_borderBackground = pick _style_borderBackground + , _style_width = pick _style_width + , _style_height = pick _style_height + , _style_maxWidth = pick _style_maxWidth + , _style_maxHeight = pick _style_maxHeight + , _style_alignHorizontal = pick _style_alignHorizontal + , _style_alignVertical = pick _style_alignVertical + , _style_whitespaceChar = pick _style_whitespaceChar + , _style_transform = pick _style_transform + , _style_tabWidth = pick _style_tabWidth + , _style_marginBackground = pick _style_marginBackground + , _style_inline = pick _style_inline + , _style_colorWhitespace = pick _style_colorWhitespace + , _style_borderTopForeground = pick _style_borderTopForeground + , _style_borderTopBackground = pick _style_borderTopBackground + , _style_borderBottomForeground = pick _style_borderBottomForeground + , _style_borderBottomBackground = pick _style_borderBottomBackground + , _style_borderLeftForeground = pick _style_borderLeftForeground + , _style_borderLeftBackground = pick _style_borderLeftBackground + , _style_borderRightForeground = pick _style_borderRightForeground + , _style_borderRightBackground = pick _style_borderRightBackground + } + where + pick :: forall a. (Style -> Maybe a) -> Maybe a + pick f = case f child of + Just x -> Just x + Nothing -> f parent + +inheritPadding :: Padding -> Padding -> Padding +inheritPadding parent child = + Padding + { _padding_top = nz (_padding_top child) (_padding_top parent) + , _padding_right = nz (_padding_right child) (_padding_right parent) + , _padding_bottom = nz (_padding_bottom child) (_padding_bottom parent) + , _padding_left = nz (_padding_left child) (_padding_left parent) + } + where + nz c p = if c /= 0 then c else p + +inheritMargin :: Margin -> Margin -> Margin +inheritMargin parent child = + Margin + { _margin_top = nz (_margin_top child) (_margin_top parent) + , _margin_right = nz (_margin_right child) (_margin_right parent) + , _margin_bottom = nz (_margin_bottom child) (_margin_bottom parent) + , _margin_left = nz (_margin_left child) (_margin_left parent) + } + where + nz c p = if c /= 0 then c else p + +---------------------------------------------------------------------------- +-- Color constants (re-exported from vty for convenience) +---------------------------------------------------------------------------- + +black, red, green, yellow, blue, magenta, cyan, white :: Color +black = V.black +red = V.red +green = V.green +yellow = V.yellow +blue = V.blue +magenta = V.magenta +cyan = V.cyan +white = V.white + +brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite :: Color +brightBlack = V.brightBlack +brightRed = V.brightRed +brightGreen = V.brightGreen +brightYellow = V.brightYellow +brightBlue = V.brightBlue +brightMagenta = V.brightMagenta +brightCyan = V.brightCyan +brightWhite = V.brightWhite + +-- | Construct a true-color 'Color' from sRGB components. Unlike vty's +-- 'V.rgbColor' (which downsamples to the 256-color cube at construction), this +-- preserves the full 24-bit 'V.RGBColor' so the host can downsample once per +-- frame based on the detected 'Reflex.Vty.ColorProfile.ColorProfile'. +rgbColor :: Int -> Int -> Int -> Color +rgbColor = V.srgbColor + +---------------------------------------------------------------------------- +-- Border style presets +---------------------------------------------------------------------------- + +-- | Single-line box-drawing border: @┌─┐│┘─└│@. +singleBorder :: BorderStyle +singleBorder = + BorderStyle + (Just '─') + (Just '─') + (Just '│') + (Just '│') + (Just '┌') + (Just '┐') + (Just '└') + (Just '┘') + +-- | Rounded-corner single-line border: @╭─╮│╯─╰│@. +roundedBorder :: BorderStyle +roundedBorder = + BorderStyle + (Just '─') + (Just '─') + (Just '│') + (Just '│') + (Just '╭') + (Just '╮') + (Just '╰') + (Just '╯') + +-- | Thick single-line border: @┏━┓┃┛━┗┃@. +thickBorder :: BorderStyle +thickBorder = + BorderStyle + (Just '━') + (Just '━') + (Just '┃') + (Just '┃') + (Just '┏') + (Just '┓') + (Just '┗') + (Just '┛') + +-- | Double-line border: @╔═╗║╝═╚║@. +doubleBorder :: BorderStyle +doubleBorder = + BorderStyle + (Just '═') + (Just '═') + (Just '║') + (Just '║') + (Just '╔') + (Just '╗') + (Just '╚') + (Just '╝') + +-- | ASCII-only border using @-|+@. +asciiBorder :: BorderStyle +asciiBorder = + BorderStyle + (Just '-') + (Just '-') + (Just '|') + (Just '|') + (Just '+') + (Just '+') + (Just '+') + (Just '+') + +-- | Markdown-table border using @-|@ with no corners. +markdownBorder :: BorderStyle +markdownBorder = + BorderStyle + (Just '-') + (Just '-') + (Just '|') + (Just '|') + Nothing + Nothing + Nothing + Nothing + +-- | A border with all sides absent. Useful as a base to enable only +-- specific sides via 'withBorderTop' etc. +noBorder :: BorderStyle +noBorder = BorderStyle Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Inner half-block border using half-block characters: @▀▄▌▐@. +innerHalfBorder :: BorderStyle +innerHalfBorder = + BorderStyle + (Just '▀') + (Just '▄') + (Just '▌') + (Just '▐') + (Just '▀') + (Just '▀') + (Just '▄') + (Just '▄') + +-- | Outer half-block border using lower-eighth block characters: @▔▁@. +outerHalfBlockBorder :: BorderStyle +outerHalfBlockBorder = + BorderStyle + (Just '▔') + (Just '▁') + (Just '▏') + (Just '▕') + (Just '▔') + (Just '▔') + (Just '▁') + (Just '▁') + +---------------------------------------------------------------------------- +-- Setters +---------------------------------------------------------------------------- + +withForeground :: Color -> Style -> Style +withForeground c s = s {_style_foreground = Just c} + +withBackground :: Color -> Style -> Style +withBackground c s = s {_style_background = Just c} + +withBold :: Style -> Style +withBold s = s {_style_bold = Just True} + +withItalic :: Style -> Style +withItalic s = s {_style_italic = Just True} + +withFaint :: Style -> Style +withFaint s = s {_style_faint = Just True} + +withBlink :: Style -> Style +withBlink s = s {_style_blink = Just True} + +withStrikethrough :: Style -> Style +withStrikethrough s = s {_style_strikethrough = Just True} + +withReverse :: Style -> Style +withReverse s = s {_style_reverse = Just True} + +withUnderline :: UnderlineStyle -> Style -> Style +withUnderline u s = s {_style_underline = Just u} + +withUnderlineColor :: Color -> Style -> Style +withUnderlineColor c s = s {_style_underlineColor = Just c} + +withHyperlink :: Text -> Style -> Style +withHyperlink url s = s {_style_hyperlink = Just url} + +withPadding :: Int -> Int -> Int -> Int -> Style -> Style +withPadding t r b l s = s {_style_padding = Padding t r b l} + +withPaddingTop :: Int -> Style -> Style +withPaddingTop n s = s {_style_padding = (_style_padding s) {_padding_top = n}} + +withPaddingRight :: Int -> Style -> Style +withPaddingRight n s = s {_style_padding = (_style_padding s) {_padding_right = n}} + +withPaddingBottom :: Int -> Style -> Style +withPaddingBottom n s = s {_style_padding = (_style_padding s) {_padding_bottom = n}} + +withPaddingLeft :: Int -> Style -> Style +withPaddingLeft n s = s {_style_padding = (_style_padding s) {_padding_left = n}} + +withMargin :: Int -> Int -> Int -> Int -> Style -> Style +withMargin t r b l s = s {_style_margin = Margin t r b l} + +withMarginTop :: Int -> Style -> Style +withMarginTop n s = s {_style_margin = (_style_margin s) {_margin_top = n}} + +withMarginRight :: Int -> Style -> Style +withMarginRight n s = s {_style_margin = (_style_margin s) {_margin_right = n}} + +withMarginBottom :: Int -> Style -> Style +withMarginBottom n s = s {_style_margin = (_style_margin s) {_margin_bottom = n}} + +withMarginLeft :: Int -> Style -> Style +withMarginLeft n s = s {_style_margin = (_style_margin s) {_margin_left = n}} + +withBorder :: BorderStyle -> Style -> Style +withBorder b s = s {_style_border = Just b} + +withBorderForeground :: Color -> Style -> Style +withBorderForeground c s = s {_style_borderForeground = Just c} + +withBorderBackground :: Color -> Style -> Style +withBorderBackground c s = s {_style_borderBackground = Just c} + +withBorderTop :: Bool -> Style -> Style +withBorderTop b s = s {_style_borderTop = Just b} + +withBorderBottom :: Bool -> Style -> Style +withBorderBottom b s = s {_style_borderBottom = Just b} + +withBorderLeft :: Bool -> Style -> Style +withBorderLeft b s = s {_style_borderLeft = Just b} + +withBorderRight :: Bool -> Style -> Style +withBorderRight b s = s {_style_borderRight = Just b} + +withWidth :: Int -> Style -> Style +withWidth n s = s {_style_width = Just n} + +withHeight :: Int -> Style -> Style +withHeight n s = s {_style_height = Just n} + +withMaxWidth :: Int -> Style -> Style +withMaxWidth n s = s {_style_maxWidth = Just n} + +withMaxHeight :: Int -> Style -> Style +withMaxHeight n s = s {_style_maxHeight = Just n} + +withAlignH :: HAlign -> Style -> Style +withAlignH a s = s {_style_alignHorizontal = Just a} + +withAlignV :: VAlign -> Style -> Style +withAlignV a s = s {_style_alignVertical = Just a} + +withWhitespace :: Char -> Style -> Style +withWhitespace c s = s {_style_whitespaceChar = Just c} + +withTransform :: (Text -> Text) -> Style -> Style +withTransform fn s = s {_style_transform = Just fn} + +withTabWidth :: Int -> Style -> Style +withTabWidth w s = s {_style_tabWidth = Just w} + +withMarginBackground :: Color -> Style -> Style +withMarginBackground c s = s {_style_marginBackground = Just c} + +withInline :: Bool -> Style -> Style +withInline b s = s {_style_inline = Just b} + +withColorWhitespace :: Bool -> Style -> Style +withColorWhitespace b s = s {_style_colorWhitespace = Just b} + +withBorderTopForeground :: Color -> Style -> Style +withBorderTopForeground c s = s {_style_borderTopForeground = Just c} + +withBorderTopBackground :: Color -> Style -> Style +withBorderTopBackground c s = s {_style_borderTopBackground = Just c} + +withBorderBottomForeground :: Color -> Style -> Style +withBorderBottomForeground c s = s {_style_borderBottomForeground = Just c} + +withBorderBottomBackground :: Color -> Style -> Style +withBorderBottomBackground c s = s {_style_borderBottomBackground = Just c} + +withBorderLeftForeground :: Color -> Style -> Style +withBorderLeftForeground c s = s {_style_borderLeftForeground = Just c} + +withBorderLeftBackground :: Color -> Style -> Style +withBorderLeftBackground c s = s {_style_borderLeftBackground = Just c} + +withBorderRightForeground :: Color -> Style -> Style +withBorderRightForeground c s = s {_style_borderRightForeground = Just c} + +withBorderRightBackground :: Color -> Style -> Style +withBorderRightBackground c s = s {_style_borderRightBackground = Just c} + +---------------------------------------------------------------------------- +-- Rendering +---------------------------------------------------------------------------- + +-- | An attr where every field is 'V.KeepCurrent', so painted cells inherit +-- the underlying layer's value for any attribute the 'Style' doesn't +-- explicitly set. Used as the base for 'render' so themed backgrounds +-- show through where the 'Style' has no explicit color. +transparentAttr :: V.Attr +transparentAttr = + V.Attr + { V.attrStyle = V.KeepCurrent + , V.attrForeColor = V.KeepCurrent + , V.attrBackColor = V.KeepCurrent + , V.attrURL = V.KeepCurrent + } + +-- | Merge the color and text-transform fields of a 'Style' onto an +-- existing 'V.Attr'. Fields that are 'Nothing' in the 'Style' are left +-- unchanged (the existing 'V.Attr' value is kept). Padding, margin, +-- border, dimensions, and alignment are not handled here: those are +-- layout concerns handled by 'render'. This is used by widgets that want +-- to layer a 'Style' on top of the ambient 'HasTheme' attribute. +applyAttr :: Style -> V.Attr -> V.Attr +applyAttr s attr0 = + applyUnderline $ + applyHyperlink $ + applyReverse $ + applyStrikethrough $ + applyBlink $ + applyFaint $ + applyItalic $ + applyBold $ + applyBackground $ + applyForeground attr0 + where + applyForeground a = maybe a (V.withForeColor a) (_style_foreground s) + applyBackground a = maybe a (V.withBackColor a) (_style_background s) + applyFlag field st a = case field s of + Just True -> V.withStyle a st + _ -> a + applyBold = applyFlag _style_bold V.bold + applyItalic = applyFlag _style_italic V.italic + applyFaint = applyFlag _style_faint V.dim + applyBlink = applyFlag _style_blink V.blink + applyStrikethrough = applyFlag _style_strikethrough V.strikethrough + applyReverse = applyFlag _style_reverse V.reverseVideo + applyUnderline a = case _style_underline s of + Nothing -> a + Just UnderlineNone -> a + Just _ -> V.withStyle a V.underline + applyHyperlink a = maybe a (V.withURL a) (_style_hyperlink s) + +-- | Overlay one 'V.Attr' on top of another. Fields in the overlay that +-- are 'V.SetTo' take precedence; 'V.Default' and 'V.KeepCurrent' fall +-- through to the base. Used by 'Reflex.Vty.Widget.Text.richText' to layer +-- custom attributes on top of the ambient theme attr, so that unset fields +-- inherit the theme rather than falling back to terminal defaults. +mergeAttr :: V.Attr -> V.Attr -> V.Attr +mergeAttr base overlay = + V.Attr + { V.attrStyle = pick (V.attrStyle base) (V.attrStyle overlay) + , V.attrForeColor = pick (V.attrForeColor base) (V.attrForeColor overlay) + , V.attrBackColor = pick (V.attrBackColor base) (V.attrBackColor overlay) + , V.attrURL = pick (V.attrURL base) (V.attrURL overlay) + } + where + pick _ (V.SetTo v) = V.SetTo v + pick b _ = b + +-- | Render some 'Text' with a 'Style' to a vty 'V.Image'. Applies text +-- transforms and colors (via 'applyAttr'), pads and aligns the content, +-- draws the border, applies margin, and finally enforces width/height +-- minimums and max-width/max-height clipping. +render :: Style -> Text -> V.Image +render s content = + if fromMaybe False (_style_inline s) + then applyMaxSize contentImage + else applyMaxSize $ applySize $ applyMargin $ applyBorder $ applyPadding $ contentImage + where + ws = fromMaybe ' ' (_style_whitespaceChar s) + -- Use KeepCurrent for all unset attrs so underlying layers (e.g. the + -- themed fill) show through where the Style doesn't explicitly set a + -- color or style. + baseAttr = applyAttr s transparentAttr + -- Attr for whitespace fills: use transparent when colorWhitespace is False. + fillAttr = if fromMaybe True (_style_colorWhitespace s) then baseAttr else transparentAttr + -- Per-side border attrs, falling back to the generic border fg/bg, + -- layered on top of the content attr. + borderAttrTop = applyAttr (borderSideStyle (_style_borderTopForeground s) (_style_borderTopBackground s)) baseAttr + borderAttrBottom = applyAttr (borderSideStyle (_style_borderBottomForeground s) (_style_borderBottomBackground s)) baseAttr + borderAttrLeft = applyAttr (borderSideStyle (_style_borderLeftForeground s) (_style_borderLeftBackground s)) baseAttr + borderAttrRight = applyAttr (borderSideStyle (_style_borderRightForeground s) (_style_borderRightBackground s)) baseAttr + borderSideStyle perSideFg perSideBg = + def + { _style_foreground = perSideFg <|> _style_borderForeground s + , _style_background = perSideBg <|> _style_borderBackground s + } + -- Render text with newlines + contentImage = V.vertCat $ map (V.text' baseAttr) (T.split (== '\n') processedContent) + processedContent = expandTabs $ case _style_transform s of + Just fn -> fn content + Nothing -> content + expandTabs txt = case _style_tabWidth s of + Just w -> T.replace "\t" (T.replicate w " ") txt + Nothing -> txt + -- Whitespace fill of a given width/height using the whitespace char. + fillImage :: V.Attr -> Int -> Int -> V.Image + fillImage a w h + | w <= 0 || h <= 0 = V.emptyImage + | otherwise = V.charFill a ws w h + -- Horizontal alignment of an image within a width. + placeH :: V.Attr -> Int -> V.Image -> V.Image + placeH a w img + | imgW >= w = img + | otherwise = V.horizCat [leftPad, img, rightPad] + where + imgW = V.imageWidth img + imgH = V.imageHeight img + slack = w - imgW + leftPad = case fromMaybe HAlignLeft (_style_alignHorizontal s) of + HAlignLeft -> V.emptyImage + HAlignCenter -> fillImage a (slack `div` 2) imgH + HAlignRight -> fillImage a slack imgH + rightPad = case fromMaybe HAlignLeft (_style_alignHorizontal s) of + HAlignLeft -> fillImage a slack imgH + HAlignCenter -> fillImage a (slack - slack `div` 2) imgH + HAlignRight -> V.emptyImage + -- Vertical alignment of an image within a height. + placeV :: V.Attr -> Int -> V.Image -> V.Image + placeV a h img + | imgH >= h = img + | otherwise = V.vertCat [topPad, img, bottomPad] + where + imgH = V.imageHeight img + imgW = V.imageWidth img + slack = h - imgH + topPad = case fromMaybe VAlignTop (_style_alignVertical s) of + VAlignTop -> V.emptyImage + VAlignMiddle -> fillImage a imgW (slack `div` 2) + VAlignBottom -> fillImage a imgW slack + bottomPad = case fromMaybe VAlignTop (_style_alignVertical s) of + VAlignTop -> fillImage a imgW slack + VAlignMiddle -> fillImage a imgW (slack - slack `div` 2) + VAlignBottom -> V.emptyImage + -- Width/height minimums: pad the image out to the requested size. + applySize img = + let w = fromMaybe (V.imageWidth img) (_style_width s) + h = fromMaybe (V.imageHeight img) (_style_height s) + img' = + if V.imageWidth img < w + then placeH fillAttr w img + else img + img'' = + if V.imageHeight img' < h + then placeV fillAttr h img' + else img' + in img'' + -- Padding. + applyPadding img = + let p = _style_padding s + top = fillImage fillAttr (innerW img) (_padding_top p) + bottom = fillImage fillAttr (innerW img) (_padding_bottom p) + left = fillImage fillAttr (_padding_left p) (innerH img) + right = fillImage fillAttr (_padding_right p) (innerH img) + innerW = V.imageWidth + innerH = V.imageHeight + in V.vertCat + [ top + , V.horizCat [left, img, right] + , bottom + ] + -- Border. + applyBorder img = + case _style_border s of + Nothing -> img + Just b -> + drawBorder + borderAttrTop + borderAttrBottom + borderAttrLeft + borderAttrRight + b + (_style_borderTop s) + (_style_borderBottom s) + (_style_borderLeft s) + (_style_borderRight s) + img + -- Margin. Uses colored fill when _style_marginBackground is set, + -- otherwise transparent pad so underlying layers show through. + applyMargin img = + let m = _style_margin s + in case _style_marginBackground s of + Nothing -> V.pad (_margin_left m) (_margin_top m) (_margin_right m) (_margin_bottom m) img + Just _ -> + let marginAttr = applyAttr (borderStyleAttr s {_style_border = Nothing, _style_borderForeground = _style_marginBackground s}) baseAttr + w = V.imageWidth img + h = V.imageHeight img + leftPad = fillImage marginAttr (_margin_left m) h + rightPad = fillImage marginAttr (_margin_right m) h + topW = w + _margin_left m + _margin_right m + topPad = fillImage marginAttr topW (_margin_top m) + bottomPad = fillImage marginAttr topW (_margin_bottom m) + in V.vertCat [topPad, V.horizCat [leftPad, img, rightPad], bottomPad] + -- Max-width / max-height clipping. + applyMaxSize img = + let clipW = maybe img (\w -> V.crop w (V.imageHeight img) img) (_style_maxWidth s) + clipH = maybe clipW (\h -> V.crop (V.imageWidth clipW) h clipW) (_style_maxHeight s) + in clipH + +-- | A 'Style' that carries only the border color fields, for use as the +-- 'V.Attr' when drawing border characters. +borderStyleAttr :: Style -> Style +borderStyleAttr s = + def + { _style_foreground = _style_borderForeground s + , _style_background = _style_borderBackground s + } + +-- | Draw a border around an image, respecting per-side toggles. A side is +-- drawn when the 'BorderStyle' has a character for it and the +-- per-side toggle (if set) is 'True'. When a side's toggle is 'Nothing', +-- the side is drawn iff the 'BorderStyle' defines it. Corners are drawn +-- when both adjacent sides are present and the 'BorderStyle' defines the +-- corner. +drawBorder + :: V.Attr + -- ^ top attr + -> V.Attr + -- ^ bottom attr + -> V.Attr + -- ^ left attr + -> V.Attr + -- ^ right attr + -> BorderStyle + -> Maybe Bool + -- ^ top toggle + -> Maybe Bool + -- ^ bottom toggle + -> Maybe Bool + -- ^ left toggle + -> Maybe Bool + -- ^ right toggle + -> V.Image + -> V.Image +drawBorder topA bottomA leftA rightA b mTop mBot mLeft mRight img = + V.vertCat [topRow, middleRow, bottomRow] + where + w = V.imageWidth img + topOn = sideOn _border_top mTop + bottomOn = sideOn _border_bottom mBot + leftOn = sideOn _border_left mLeft + rightOn = sideOn _border_right mRight + sideOn f mt = maybe (isJust (f b)) id mt + hFillTop c n = V.charFill topA c (max 0 n) 1 + hFillBottom c n = V.charFill bottomA c (max 0 n) 1 + vFillLeft c n = V.charFill leftA c 1 (max 0 n) + vFillRight c n = V.charFill rightA c 1 (max 0 n) + topChar = _border_top b >>= \c -> if topOn then Just c else Nothing + bottomChar = _border_bottom b >>= \c -> if bottomOn then Just c else Nothing + leftChar = _border_left b >>= \c -> if leftOn then Just c else Nothing + rightChar = _border_right b >>= \c -> if rightOn then Just c else Nothing + topLeftChar = _border_topLeft b >>= \c -> if topOn && leftOn then Just (V.char topA c) else Nothing + topRightChar = _border_topRight b >>= \c -> if topOn && rightOn then Just (V.char topA c) else Nothing + bottomLeftChar = _border_bottomLeft b >>= \c -> if bottomOn && leftOn then Just (V.char bottomA c) else Nothing + bottomRightChar = _border_bottomRight b >>= \c -> if bottomOn && rightOn then Just (V.char bottomA c) else Nothing + topRow = + V.horizCat $ + maybe [] (: []) topLeftChar + ++ maybe [] (\c -> [hFillTop c w]) topChar + ++ maybe [] (: []) topRightChar + middleRow = + V.horizCat $ + maybe [] (\c -> [vFillLeft c (V.imageHeight img)]) leftChar + ++ [img] + ++ maybe [] (\c -> [vFillRight c (V.imageHeight img)]) rightChar + bottomRow = + V.horizCat $ + maybe [] (: []) bottomLeftChar + ++ maybe [] (\c -> [hFillBottom c w]) bottomChar + ++ maybe [] (: []) bottomRightChar + +-- | Reactive variant of 'render' for the common widget case. +renderB :: Reflex t => Behavior t Style -> Behavior t Text -> Behavior t V.Image +renderB bs bt = render <$> bs <*> bt + +-- | The width and height (in terminal cells) that 'render' will produce +-- for the given 'Style' and 'Text', /before/ max-width/max-height +-- clipping. Useful for layout-sensitive widgets that need to measure +-- before rendering. +measure :: Style -> Text -> (Int, Int) +measure s content = + (totalW, totalH) + where + contentLines = T.split (== '\n') processedContent + processedContent = case _style_tabWidth s of + Just w -> T.replace "\t" (T.replicate w " ") $ case _style_transform s of + Just fn -> fn content + Nothing -> content + Nothing -> case _style_transform s of + Just fn -> fn content + Nothing -> content + contentW = maximum (0 : map textWidth contentLines) + contentH = length contentLines + p = _style_padding s + m = _style_margin s + borderWidth = if hasBorder then 2 else 0 + borderHeight = if hasBorder then 2 else 0 + hasBorder = + maybe False (const True) (_style_border s) + || any + id + [ fromMaybe False (_style_borderTop s) + , fromMaybe False (_style_borderBottom s) + , fromMaybe False (_style_borderLeft s) + , fromMaybe False (_style_borderRight s) + ] + minW = fromMaybe 0 (_style_width s) + minH = fromMaybe 0 (_style_height s) + innerW = max minW contentW + _padding_left p + _padding_right p + innerH = max minH contentH + _padding_top p + _padding_bottom p + totalW = innerW + borderWidth + _margin_left m + _margin_right m + totalH = innerH + borderHeight + _margin_top m + _margin_bottom m + +---------------------------------------------------------------------------- +-- Image composition +---------------------------------------------------------------------------- + +-- | Join images horizontally, aligning them vertically by the given +-- 'VAlign'. Shorter images are padded with spaces to match the tallest. +joinHorizontal :: VAlign -> [V.Image] -> V.Image +joinHorizontal _ [] = V.emptyImage +joinHorizontal align imgs = V.horizCat (map pad imgs) + where + maxH = maximum (map V.imageHeight imgs) + pad img = placeVertical align maxH img + +-- | Join images vertically, aligning them horizontally by the given +-- 'HAlign'. Narrower images are padded with spaces to match the widest. +joinVertical :: HAlign -> [V.Image] -> V.Image +joinVertical _ [] = V.emptyImage +joinVertical align imgs = V.vertCat (map pad imgs) + where + maxW = maximum (map V.imageWidth imgs) + pad img = placeHorizontal align maxW img + +-- | Place an image within a target width, horizontally aligned. +-- Pads with spaces on the appropriate side(s). +placeHorizontal :: HAlign -> Int -> V.Image -> V.Image +placeHorizontal align targetW img + | imgW >= targetW = img + | otherwise = V.horizCat [leftPad, img, rightPad] + where + imgW = V.imageWidth img + slack = targetW - imgW + (leftW, rightW) = case align of + HAlignLeft -> (0, slack) + HAlignCenter -> (slack `div` 2, slack - slack `div` 2) + HAlignRight -> (slack, 0) + leftPad = padImg leftW (V.imageHeight img) + rightPad = padImg rightW (V.imageHeight img) + +-- | Place an image within a target height, vertically aligned. +-- Pads with spaces above and/or below. +placeVertical :: VAlign -> Int -> V.Image -> V.Image +placeVertical align targetH img + | imgH >= targetH = img + | otherwise = V.vertCat [topPad, img, bottomPad] + where + imgH = V.imageHeight img + slack = targetH - imgH + (topH, bottomH) = case align of + VAlignTop -> (0, slack) + VAlignMiddle -> (slack `div` 2, slack - slack `div` 2) + VAlignBottom -> (slack, 0) + topPad = padImg (V.imageWidth img) topH + bottomPad = padImg (V.imageWidth img) bottomH + +-- | Place an image within a target @(width, height)@ with both +-- horizontal and vertical alignment. +place :: HAlign -> VAlign -> Int -> Int -> V.Image -> V.Image +place hAlign vAlign targetW targetH = + placeHorizontal hAlign targetW . placeVertical vAlign targetH + +padImg :: Int -> Int -> V.Image +padImg w h + | w <= 0 || h <= 0 = V.emptyImage + | otherwise = V.charFill V.defAttr ' ' w h + +---------------------------------------------------------------------------- +-- Text utilities +---------------------------------------------------------------------------- + +-- | Truncate text to fit within a display width, using the given +-- character as an ellipsis if truncation is needed. Wide characters +-- are handled correctly via 'textWidth'. +truncateWith :: Char -> Int -> Text -> Text +truncateWith ellipsis maxWidth txt + | textWidth txt <= maxWidth = txt + | maxWidth <= 0 = "" + | otherwise = takeToWidth (maxWidth - charWidth ellipsis) txt <> T.singleton ellipsis + +-- | Number of lines in the text (counting newlines + 1). +textHeight :: Text -> Int +textHeight = length . T.split (== '\n') + +-- | Display width and height of the text. +textSize :: Text -> (Int, Int) +textSize txt = (maximum (0 : map textWidth (T.split (== '\n') txt)), textHeight txt) + +---------------------------------------------------------------------------- +-- Internal helpers for truncateWith +---------------------------------------------------------------------------- + +takeToWidth :: Int -> Text -> Text +takeToWidth targetW txt = go 0 (T.unpack txt) + where + go _ [] = "" + go w (c : cs) + | w >= targetW = "" + | w + cw > targetW = "" + | otherwise = T.singleton c <> go (w + cw) cs + where + cw = max 1 (charWidth c) diff --git a/src/Reflex/Vty/Theme.hs b/src/Reflex/Vty/Theme.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Theme.hs @@ -0,0 +1,131 @@ +-- | +-- Module: Reflex.Vty.Theme +-- Description: Structured theme record for reflex-vty widgets +-- +-- A 'Theme' is a record of 'Style's for each part of the UI. 'HasTheme' delivers +-- the ambient 'Theme' to widgets; 'localTheme' overrides it for a subtree. +module Reflex.Vty.Theme + ( Theme (..) + , defTheme + , darkTheme + , charmTheme + , draculaTheme + , nordTheme + , zenburnTheme + , gruvboxTheme + , themeToAttr + ) where + +import Data.Default (Default (..)) +import qualified Graphics.Vty as V +import Reflex (Behavior, Reflex) + +import Reflex.Vty.Style + +-- | A structured theme: one 'Style' per UI element. +data Theme = Theme + { _theme_default :: Style + , _theme_border :: Style + , _theme_title :: Style + , _theme_link :: Style + , _theme_buttonFocused :: Style + , _theme_buttonUnfocused :: Style + , _theme_checkbox :: Style + , _theme_textInput :: Style + , _theme_textInputCursor :: Style + } + +instance Default Theme where + def = defTheme + +-- | The default theme: no colors, no transforms, links underlined. +defTheme :: Theme +defTheme = + Theme + { _theme_default = def + , _theme_border = def + , _theme_title = withBold def + , _theme_link = withUnderline UnderlineSingle def + , _theme_buttonFocused = def + , _theme_buttonUnfocused = def + , _theme_checkbox = def + , _theme_textInput = def + , _theme_textInputCursor = withReverse def + } + +-- | A dark-background theme matching the legacy @darkTheme :: V.Attr@. +darkTheme :: Theme +darkTheme = + defTheme + { _theme_default = withForeground green . withBackground black $ def + } + +-- | The Charm theme: magenta/purple accents on a dark background. +charmTheme :: Theme +charmTheme = + defTheme + { _theme_default = withForeground white . withBackground (rgbColor 22 18 30) $ def + , _theme_border = withForeground magenta def + , _theme_title = withForeground magenta . withBold $ def + , _theme_link = withForeground magenta . withUnderline UnderlineSingle $ def + , _theme_buttonFocused = withForeground magenta . withBold $ def + , _theme_buttonUnfocused = withForeground white def + , _theme_textInputCursor = withReverse def + } + +-- | The Dracula theme: pink/cyan/green on a dark background. +draculaTheme :: Theme +draculaTheme = + defTheme + { _theme_default = withForeground white . withBackground (rgbColor 40 42 54) $ def + , _theme_border = withForeground (rgbColor 98 114 164) def + , _theme_title = withForeground (rgbColor 255 184 108) . withBold $ def + , _theme_link = withForeground (rgbColor 139 233 253) . withUnderline UnderlineSingle $ def + , _theme_buttonFocused = withForeground (rgbColor 189 147 249) . withBold $ def + , _theme_buttonUnfocused = withForeground white def + , _theme_textInputCursor = withReverse def + } + +-- | The Nord theme: blues and cool greys on a dark slate background. +nordTheme :: Theme +nordTheme = + defTheme + { _theme_default = withForeground (rgbColor 216 222 233) . withBackground (rgbColor 46 52 64) $ def + , _theme_border = withForeground (rgbColor 76 86 106) def + , _theme_title = withForeground (rgbColor 136 192 208) . withBold $ def + , _theme_link = withForeground (rgbColor 143 188 187) . withUnderline UnderlineSingle $ def + , _theme_buttonFocused = withForeground (rgbColor 136 192 208) . withBold $ def + , _theme_buttonUnfocused = withForeground (rgbColor 216 222 233) def + , _theme_textInputCursor = withReverse def + } + +-- | The Zenburn theme: muted greens and warm browns on a dark background. +zenburnTheme :: Theme +zenburnTheme = + defTheme + { _theme_default = withForeground (rgbColor 220 220 204) . withBackground (rgbColor 64 64 64) $ def + , _theme_border = withForeground (rgbColor 102 153 153) def + , _theme_title = withForeground (rgbColor 233 233 191) . withBold $ def + , _theme_link = withForeground (rgbColor 159 159 95) . withUnderline UnderlineSingle $ def + , _theme_buttonFocused = withForeground (rgbColor 159 159 95) . withBold $ def + , _theme_buttonUnfocused = withForeground (rgbColor 220 220 204) def + , _theme_textInputCursor = withReverse def + } + +-- | The Gruvbox theme: warm earthy tones on a dark background. +gruvboxTheme :: Theme +gruvboxTheme = + defTheme + { _theme_default = withForeground (rgbColor 235 219 178) . withBackground (rgbColor 40 40 40) $ def + , _theme_border = withForeground (rgbColor 152 151 26) def + , _theme_title = withForeground (rgbColor 250 189 47) . withBold $ def + , _theme_link = withForeground (rgbColor 131 165 152) . withUnderline UnderlineSingle $ def + , _theme_buttonFocused = withForeground (rgbColor 214 93 14) . withBold $ def + , _theme_buttonUnfocused = withForeground (rgbColor 235 219 178) def + , _theme_textInputCursor = withReverse def + } + +-- | Convenience: extract the ambient 'V.Attr' from the theme's +-- '_theme_default' 'Style'. Most widgets only need this. +themeToAttr :: Reflex t => Behavior t Theme -> Behavior t V.Attr +themeToAttr = fmap (flip applyAttr V.defAttr . _theme_default) diff --git a/src/Reflex/Vty/Widget.hs b/src/Reflex/Vty/Widget.hs --- a/src/Reflex/Vty/Widget.hs +++ b/src/Reflex/Vty/Widget.hs @@ -1,68 +1,97 @@ -{-| -Module: Reflex.Vty.Widget -Description: Basic set of widgets and building blocks for reflex-vty applications --} -{-# Language ScopedTypeVariables #-} -{-# Language UndecidableInstances #-} -{-# Language PolyKinds #-} -{-# Language RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module: Reflex.Vty.Widget +-- Description: Basic set of widgets and building blocks for reflex-vty applications module Reflex.Vty.Widget where -import Control.Applicative (liftA2) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix (MonadFix) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Morph (MFunctor(..)) -import Control.Monad.NodeId -import Control.Monad.Reader (ReaderT(..), ask, local, runReaderT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Morph (MFunctor (..)) +import Control.Monad.Reader (ReaderT (..), ask, local, runReaderT) import Control.Monad.Ref import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.State.Strict +import qualified Data.ByteString as BS +import Data.Default (Default (..)) +import Data.Kind (Type) +import Data.Semigroup (Last (..)) import Data.Set (Set) import qualified Data.Set as Set import Graphics.Vty (Image) import qualified Graphics.Vty as V import Reflex import Reflex.Class () -import Reflex.Host.Class (MonadReflexCreateTrigger) +import Reflex.Host.Class + +import Control.Monad.NodeId +import Reflex.Vty.ColorProfile import Reflex.Vty.Host +import Reflex.Vty.Theme (Theme (..), defTheme, themeToAttr) -- * Running a vty application -- | Sets up the top-level context for a vty widget and runs it with that context mainWidgetWithHandle - :: V.Vty - -> (forall t m. - ( MonadVtyApp t m - , HasImageWriter t m - , MonadNodeId m - , HasDisplayRegion t m - , HasFocusReader t m - , HasInput t m - , HasTheme t m - ) => m (Event t ())) + :: VtyAppConfig + -> V.Vty + -> ( forall t m + . ( MonadVtyApp t m + , HasImageWriter t m + , MonadNodeId m + , HasDisplayRegion t m + , HasFocusReader t m + , HasInput t m + , HasTheme t m + , HasColorProfile t m + , HasCursor t m + , HasScreenMode t m + ) + => m (Event t ()) + ) -> IO () -mainWidgetWithHandle vty child = - runVtyAppWithHandle vty $ \dr0 inp -> do - size <- holdDyn dr0 $ fforMaybe inp $ \case - V.EvResize w h -> Just (w, h) - _ -> Nothing +mainWidgetWithHandle cfg vty child = + runVtyAppWithHandle cfg vty $ \dr0 inp _sigs -> do + let profile = colorProfileFromVty vty + let resizeRaw = fforMaybe inp $ \case + V.EvResize w h -> Just (w, h) + _ -> Nothing + resizeDebounced <- debounce 0.05 resizeRaw + size <- holdDyn dr0 resizeDebounced let inp' = fforMaybe inp $ \case V.EvResize {} -> Nothing x -> Just x - (shutdown, images) <- runThemeReader (constant V.defAttr) $ - runFocusReader (pure True) $ - runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $ - runImageWriter $ - runNodeIdT $ - runInput inp' $ do - tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h] - child - return $ VtyResult - { _vtyResult_picture = fmap (V.picForLayers . reverse) images - , _vtyResult_shutdown = shutdown - } + (((shutdown, images), cursorUpdates), screenModeUpdates) <- runThemeReader (constant defTheme) $ + runColorProfileReader (constant profile) $ + runFocusReader (pure True) $ + runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $ + runScreenModeWriter $ + runCursorWriter $ + runImageWriter $ + runNodeIdT $ + runInput inp' $ do + tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h] + child + let cursorStates = getLast <$> cursorUpdates + cursorState <- holdDyn defaultCursorState cursorStates + performEvent_ $ ffor cursorStates $ \st -> + liftIO $ setCursorStyle (V.outputIface vty) (_cursorState_style st) + performEvent_ $ ffor (getLast <$> screenModeUpdates) $ \mode -> + liftIO $ setScreenMode (V.outputIface vty) mode + return $ + VtyResult + { _vtyResult_picture = makePicture <$> current cursorState <*> images + , _vtyResult_shutdown = shutdown + } + where + makePicture cursorState layers = + (V.picForLayers $ reverse layers) + { V.picCursor = cursorStateToVtyCursor cursorState + } -- | The output of a vty widget data VtyWidgetOut t = VtyWidgetOut @@ -71,19 +100,25 @@ -- | Like 'mainWidgetWithHandle', but uses a default vty configuration mainWidget - :: (forall t m. - ( MonadVtyApp t m - , HasImageWriter t m - , MonadNodeId m - , HasDisplayRegion t m - , HasFocusReader t m - , HasTheme t m - , HasInput t m - ) => m (Event t ())) + :: VtyAppConfig + -> ( forall t m + . ( MonadVtyApp t m + , HasImageWriter t m + , MonadNodeId m + , HasDisplayRegion t m + , HasFocusReader t m + , HasTheme t m + , HasColorProfile t m + , HasInput t m + , HasCursor t m + , HasScreenMode t m + ) + => m (Event t ()) + ) -> IO () -mainWidget child = do +mainWidget cfg child = do vty <- getDefaultVty - mainWidgetWithHandle vty child + mainWidgetWithHandle cfg vty child -- * Input Events @@ -92,8 +127,9 @@ input :: m (Event t VtyEvent) default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent) input = lift input + -- | User input events that the widget's parent chooses to share. These will generally - -- be filtered for relevance. + -- be filtered for relevance. localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a localInput f = hoist (localInput f) @@ -105,24 +141,26 @@ -- | A widget that can receive input events. See 'Graphics.Vty.Event' newtype Input t m a = Input { unInput :: ReaderT (Event t VtyEvent) m a - } deriving - ( Functor - , Applicative + } + deriving + ( Applicative + , Functor , Monad - , MonadSample t - , MonadHold t + , MonadCatch , MonadFix + , MonadHold t , MonadIO + , MonadMask , MonadRef - , MonadCatch + , MonadSample t , MonadThrow - , MonadMask ) instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a' - traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $ - traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm' + traverseIntMapWithKeyWithAdjust f dm0 dm' = + Input $ + traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm' traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm' traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do @@ -184,16 +222,23 @@ keyCombos ks = do i <- input return $ fforMaybe i $ \case - V.EvKey k m -> if Set.member (k, m) ks - then Just (k, m) - else Nothing + V.EvKey k m -> + if Set.member (k, m) ks + then Just (k, m) + else Nothing _ -> Nothing -- | Filter the keyboard input that a child widget may receive filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a -filterKeys f x = localInput (ffilter (\case - V.EvKey k mods -> f (k, mods) - _ -> True)) x +filterKeys f x = + localInput + ( ffilter + ( \case + V.EvKey k mods -> f (k, mods) + _ -> True + ) + ) + x -- | Filter mouse input events based on whether they target a particular region -- and translate them to the internal coordinate system of that region. @@ -206,18 +251,21 @@ _ -> Just e where mouse con x y - | or [ x < l - , y < t - , x >= l + w - , y >= t + h ] = Nothing + | or + [ x < l + , y < t + , x >= l + w + , y >= t + h + ] = + Nothing | otherwise = - Just (con (x - l) (y - t)) + Just (con (x - l) (y - t)) -- | -- * 'Tracking' state means actively tracking the current stream of mouse events -- * 'NotTracking' state means not tracking the current stream of mouse events -- * 'WaitingForInput' means state will be set on next 'EvMouseDown' event -data MouseTrackingState = Tracking V.Button | NotTracking | WaitingForInput deriving (Show, Eq) +data MouseTrackingState = Tracking V.Button | NotTracking | WaitingForInput deriving (Eq, Show) -- | Filter mouse input outside the current display region -- keyboard input is reported only if the region is focused @@ -226,50 +274,74 @@ -- EXCEPT mouse drag sequences that start OFF the region are NOT reported -- AND mouse drag sequences that start ON the region and drag off ARE reported inputInFocusedRegion - :: forall t m. (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasInput t m) + :: forall t m + . (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasInput t m) => m (Event t VtyEvent) inputInFocusedRegion = do inp <- input regBeh <- current <$> askRegion foc <- current <$> focus - let - trackMouse :: - VtyEvent - -> (MouseTrackingState, Maybe VtyEvent) - -> PushM t (Maybe (MouseTrackingState, Maybe VtyEvent)) - trackMouse e (tracking, _) = do - -- sampling (as oppose to using attachPromptlyDyn) is necessary here as the focus may change from the event produced here - focused <- sample foc - -- strictly speaking the same could also happen here too - reg@(Region l t _ _) <- sample regBeh - return $ case e of + let trackMouse + :: VtyEvent + -> (MouseTrackingState, Maybe VtyEvent) + -> PushM t (Maybe (MouseTrackingState, Maybe VtyEvent)) + trackMouse e (tracking, _) = do + -- sampling (as oppose to using attachPromptlyDyn) is necessary here as the focus may change from the event produced here + focused <- sample foc + -- strictly speaking the same could also happen here too + reg@(Region l t _ _) <- sample regBeh + return $ case e of + -- filter keyboard input if region is not focused + V.EvKey _ _ | not focused -> Nothing + -- filter scroll wheel input based on mouse position + V.EvMouseDown x y btn m | btn == V.BScrollUp || btn == V.BScrollDown -> case tracking of + trck@(Tracking _) -> Just (trck, Nothing) + _ -> Just (WaitingForInput, if withinRegion reg x y then Just (V.EvMouseDown (x - l) (y - t) btn m) else Nothing) + -- only do tracking for l/m/r mouse buttons + V.EvMouseDown x y btn m -> + if tracking == Tracking btn || (tracking == WaitingForInput && withinRegion reg x y) + then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m) + else Just (NotTracking, Nothing) + V.EvMouseUp x y mbtn -> case mbtn of + Nothing -> case tracking of + Tracking _ -> Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn) + _ -> Just (WaitingForInput, Nothing) + Just btn -> + if tracking == Tracking btn + -- NOTE we only report EvMouseUp for the button we are tracking + -- vty has mouse buttons override others (seems to be based on ordering of Button) when multiple are pressed. + -- so it IS possible for child widget to miss out on a 'EvMouseUp' event with this current implementation + then Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn) + else Just (WaitingForInput, Nothing) + _ -> Just (tracking, Just e) + dynInputEvTracking <- foldDynMaybeM trackMouse (WaitingForInput, Nothing) $ inp + return (fmapMaybe snd $ updated dynInputEvTracking) - -- filter keyboard input if region is not focused - V.EvKey _ _ | not focused -> Nothing +-- | Fires when the terminal window gains focus (requires focus tracking +-- mode, which is enabled by default via 'getDefaultVty'). +gainedFocus :: (Monad m, Reflex t, HasInput t m) => m (Event t ()) +gainedFocus = do + inp <- input + return $ fforMaybe inp $ \case + V.EvGainedFocus -> Just () + _ -> Nothing - -- filter scroll wheel input based on mouse position - ev@(V.EvMouseDown x y btn m) | btn == V.BScrollUp || btn == V.BScrollDown -> case tracking of - trck@(Tracking _) -> Just (trck, Nothing) - _ -> Just (WaitingForInput, if withinRegion reg x y then Just (V.EvMouseDown (x - l) (y - t) btn m) else Nothing) +-- | Fires when the terminal window loses focus. +lostFocus :: (Monad m, Reflex t, HasInput t m) => m (Event t ()) +lostFocus = do + inp <- input + return $ fforMaybe inp $ \case + V.EvLostFocus -> Just () + _ -> Nothing - -- only do tracking for l/m/r mouse buttons - V.EvMouseDown x y btn m -> - if tracking == Tracking btn || (tracking == WaitingForInput && withinRegion reg x y) - then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m) - else Just (NotTracking, Nothing) - V.EvMouseUp x y mbtn -> case mbtn of - Nothing -> case tracking of - Tracking _ -> Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn) - _ -> Just (WaitingForInput, Nothing) - Just btn -> if tracking == Tracking btn - -- NOTE we only report EvMouseUp for the button we are tracking - -- vty has mouse buttons override others (seems to be based on ordering of Button) when multiple are pressed. - -- so it IS possible for child widget to miss out on a 'EvMouseUp' event with this current implementation - then Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn) - else Just (WaitingForInput, Nothing) - _ -> Just (tracking, Just e) - dynInputEvTracking <- foldDynMaybeM trackMouse (WaitingForInput, Nothing) $ inp - return (fmapMaybe snd $ updated dynInputEvTracking) +-- | Fires when text is pasted (bracketed paste mode). Carries the pasted +-- bytes. Enable bracketed paste via 'getDefaultVty' (on by default). +paste :: (Monad m, Reflex t, HasInput t m) => m (Event t BS.ByteString) +paste = do + inp <- input + return $ fforMaybe inp $ \case + V.EvPaste bs -> Just bs + _ -> Nothing -- * Getting and setting the display region @@ -280,7 +352,7 @@ , _region_width :: Int , _region_height :: Int } - deriving (Show, Read, Eq, Ord) + deriving (Eq, Ord, Read, Show) -- | A region that occupies no space. nilRegion :: Region @@ -298,13 +370,235 @@ -> Int -- ^ y-coordinate -> Bool -withinRegion (Region l t w h) x y = not . or $ - [ x < l - , y < t - , x >= l + w - , y >= t + h - ] +withinRegion (Region l t w h) x y = + not . or $ + [ x < l + , y < t + , x >= l + w + , y >= t + h + ] +-- * Terminal cursor state + +-- | Complete terminal cursor state. +-- +-- Coordinates are interpreted relative to the current viewport by 'setCursor'. +-- Use 'tellCursor' only when supplying absolute terminal coordinates. +data CursorState = CursorState + { _cursorState_visibility :: CursorVisibility + -- ^ Whether the cursor should be visible. + , _cursorState_style :: CursorStyle + -- ^ Shape to request from the terminal. + , _cursorState_position :: (Int, Int) + -- ^ Cursor position as @(x, y)@. + } + deriving (Eq, Ord, Show) + +-- | The default cursor state: hidden, terminal-default shape, at @(0, 0)@. +defaultCursorState :: CursorState +defaultCursorState = CursorState CursorHidden CursorStyleDefault (0, 0) + +instance Default CursorState where + def = defaultCursorState + +-- | A class for widgets that can request terminal cursor updates. +class (Reflex t, Monad m) => HasCursor t m | m -> t where + -- | Request an absolute terminal cursor state update. + tellCursor :: Event t CursorState -> m () + default tellCursor :: (f m' ~ m, MonadTrans f, HasCursor t m') => Event t CursorState -> m () + tellCursor = lift . tellCursor + +-- | Keep the terminal cursor synchronized with a dynamic state. +-- +-- The cursor position is relative to the current viewport. If a visible cursor +-- is outside the viewport, it is hidden until it comes back into bounds. +setCursor + :: (HasCursor t m, HasDisplayRegion t m, PostBuild t m) + => Dynamic t CursorState + -> m () +setCursor cursorState = do + viewport <- askViewport + postBuild <- getPostBuild + let absoluteCursorState = zipDynWith translateCursorState viewport cursorState + tellCursor $ leftmost [tag (current absoluteCursorState) postBuild, updated absoluteCursorState] + +-- | Translate a viewport-relative cursor state to an absolute terminal cursor +-- state, hiding visible cursors that are outside the viewport. +translateCursorState :: Region -> CursorState -> CursorState +translateCursorState (Region left top width height) (CursorState visibility style (x, y)) = + let absolute = CursorState visibility style (left + x, top + y) + in case visibility of + CursorHidden -> absolute + CursorVisible + | withinRegion (Region 0 0 width height) x y -> absolute + | otherwise -> absolute {_cursorState_visibility = CursorHidden} + +-- | Convert reflex-vty cursor state to vty's picture cursor. +cursorStateToVtyCursor :: CursorState -> V.Cursor +cursorStateToVtyCursor (CursorState CursorHidden _ _) = V.NoCursor +cursorStateToVtyCursor (CursorState CursorVisible _ (x, y)) = V.Cursor x y + +instance HasCursor t m => HasCursor t (ReaderT x m) +instance HasCursor t m => HasCursor t (BehaviorWriterT t x m) +instance HasCursor t m => HasCursor t (DynamicWriterT t x m) +instance HasCursor t m => HasCursor t (EventWriterT t x m) +instance HasCursor t m => HasCursor t (NodeIdT m) +instance HasCursor t m => HasCursor t (Input t m) +instance HasCursor t m => HasCursor t (ImageWriter t m) +instance HasCursor t m => HasCursor t (DisplayRegion t m) +instance HasCursor t m => HasCursor t (FocusReader t m) +instance HasCursor t m => HasCursor t (ThemeReader t m) +instance HasCursor t m => HasCursor t (ColorProfileReader t m) + +-- | A widget transformer that collects cursor updates from child widgets. +newtype CursorWriter t m a = CursorWriter + {unCursorWriter :: EventWriterT t (Last CursorState) m a} + deriving + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadFix + , MonadHold t + , MonadIO + , MonadMask + , MonadRef + , MonadSample t + , MonadThrow + ) + +instance MonadTrans (CursorWriter t) where + lift = CursorWriter . lift + +instance MFunctor (CursorWriter t) where + hoist f = CursorWriter . hoist f . unCursorWriter + +instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (CursorWriter t m) where + runWithReplace (CursorWriter a) e = CursorWriter $ runWithReplace a $ fmap unCursorWriter e + traverseIntMapWithKeyWithAdjust f m e = CursorWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unCursorWriter $ f k v) m e + traverseDMapWithKeyWithAdjust f m e = CursorWriter $ traverseDMapWithKeyWithAdjust (\k v -> unCursorWriter $ f k v) m e + traverseDMapWithKeyWithAdjustWithMove f m e = CursorWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unCursorWriter $ f k v) m e + +deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (CursorWriter t m) +deriving instance NotReady t m => NotReady t (CursorWriter t m) +deriving instance PerformEvent t m => PerformEvent t (CursorWriter t m) +deriving instance PostBuild t m => PostBuild t (CursorWriter t m) +deriving instance TriggerEvent t m => TriggerEvent t (CursorWriter t m) + +instance (Monad m, Reflex t) => HasCursor t (CursorWriter t m) where + tellCursor = CursorWriter . tellEvent . fmap Last + +instance HasImageWriter t m => HasImageWriter t (CursorWriter t m) where + captureImages (CursorWriter x) = CursorWriter $ do + ((a, cursorUpdates), images) <- lift $ captureImages $ runEventWriterT x + tellEvent cursorUpdates + pure (a, images) + +instance HasDisplayRegion t m => HasDisplayRegion t (CursorWriter t m) +instance HasFocusReader t m => HasFocusReader t (CursorWriter t m) +instance HasTheme t m => HasTheme t (CursorWriter t m) +instance HasColorProfile t m => HasColorProfile t (CursorWriter t m) +instance MonadNodeId m => MonadNodeId (CursorWriter t m) + +-- | Run a widget that can request terminal cursor updates. +runCursorWriter + :: (Reflex t, Monad m) + => CursorWriter t m a + -> m (a, Event t (Last CursorState)) +runCursorWriter = runEventWriterT . unCursorWriter + +-- * Screen mode (alt-screen) + +-- | A class for widgets that can request terminal screen mode changes. +class (Reflex t, Monad m) => HasScreenMode t m | m -> t where + -- | Request a screen mode change. + tellScreenMode :: Event t ScreenMode -> m () + default tellScreenMode :: (f m' ~ m, MonadTrans f, HasScreenMode t m') => Event t ScreenMode -> m () + tellScreenMode = lift . tellScreenMode + +instance HasScreenMode t m => HasScreenMode t (ReaderT x m) +instance HasScreenMode t m => HasScreenMode t (BehaviorWriterT t x m) +instance HasScreenMode t m => HasScreenMode t (DynamicWriterT t x m) +instance HasScreenMode t m => HasScreenMode t (EventWriterT t x m) +instance HasScreenMode t m => HasScreenMode t (NodeIdT m) +instance HasScreenMode t m => HasScreenMode t (Input t m) +instance HasScreenMode t m => HasScreenMode t (ImageWriter t m) +instance HasScreenMode t m => HasScreenMode t (DisplayRegion t m) +instance HasScreenMode t m => HasScreenMode t (FocusReader t m) +instance HasScreenMode t m => HasScreenMode t (ThemeReader t m) +instance HasScreenMode t m => HasScreenMode t (ColorProfileReader t m) +instance HasScreenMode t m => HasScreenMode t (CursorWriter t m) + +-- | Enter alternate screen mode immediately (on post-build). +enterAlternateScreen :: (HasScreenMode t m, PostBuild t m) => m () +enterAlternateScreen = do + pb <- getPostBuild + tellScreenMode $ ScreenAlternate <$ pb + +-- | Return to normal screen mode immediately (on post-build). +exitAlternateScreen :: (HasScreenMode t m, PostBuild t m) => m () +exitAlternateScreen = do + pb <- getPostBuild + tellScreenMode $ ScreenNormal <$ pb + +-- | A widget transformer that collects screen mode requests from child widgets. +newtype ScreenModeWriter t m a = ScreenModeWriter + {unScreenModeWriter :: EventWriterT t (Last ScreenMode) m a} + deriving + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadFix + , MonadHold t + , MonadIO + , MonadMask + , MonadRef + , MonadSample t + , MonadThrow + ) + +instance MonadTrans (ScreenModeWriter t) where + lift = ScreenModeWriter . lift + +instance MFunctor (ScreenModeWriter t) where + hoist f = ScreenModeWriter . hoist f . unScreenModeWriter + +instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (ScreenModeWriter t m) where + runWithReplace (ScreenModeWriter a) e = ScreenModeWriter $ runWithReplace a $ fmap unScreenModeWriter e + traverseIntMapWithKeyWithAdjust f m e = ScreenModeWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unScreenModeWriter $ f k v) m e + traverseDMapWithKeyWithAdjust f m e = ScreenModeWriter $ traverseDMapWithKeyWithAdjust (\k v -> unScreenModeWriter $ f k v) m e + traverseDMapWithKeyWithAdjustWithMove f m e = ScreenModeWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unScreenModeWriter $ f k v) m e + +deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ScreenModeWriter t m) +deriving instance NotReady t m => NotReady t (ScreenModeWriter t m) +deriving instance PerformEvent t m => PerformEvent t (ScreenModeWriter t m) +deriving instance PostBuild t m => PostBuild t (ScreenModeWriter t m) +deriving instance TriggerEvent t m => TriggerEvent t (ScreenModeWriter t m) + +instance (Monad m, Reflex t) => HasScreenMode t (ScreenModeWriter t m) where + tellScreenMode = ScreenModeWriter . tellEvent . fmap Last + +instance HasImageWriter t m => HasImageWriter t (ScreenModeWriter t m) where + captureImages (ScreenModeWriter x) = ScreenModeWriter $ do + ((a, modeUpdates), images) <- lift $ captureImages $ runEventWriterT x + tellEvent modeUpdates + pure (a, images) + +instance HasDisplayRegion t m => HasDisplayRegion t (ScreenModeWriter t m) +instance HasFocusReader t m => HasFocusReader t (ScreenModeWriter t m) +instance HasTheme t m => HasTheme t (ScreenModeWriter t m) +instance HasColorProfile t m => HasColorProfile t (ScreenModeWriter t m) +instance HasCursor t m => HasCursor t (ScreenModeWriter t m) +instance MonadNodeId m => MonadNodeId (ScreenModeWriter t m) + +-- | Run a widget that can request screen mode changes. +runScreenModeWriter + :: (Reflex t, Monad m) + => ScreenModeWriter t m a + -> m (a, Event t (Last ScreenMode)) +runScreenModeWriter = runEventWriterT . unScreenModeWriter + -- | Produces an 'Image' that fills a region with space characters regionBlankImage :: V.Attr -> Region -> Image regionBlankImage attr r@(Region _ _ width height) = @@ -312,15 +606,35 @@ -- | A class for things that know their own display size dimensions class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where - -- | Retrieve the display region + -- | Retrieve the display region. This is the "layout region" — the + -- space the layout system uses to distribute among children. Inside + -- 'scrollable', this may be larger than the actual viewport. askRegion :: m (Dynamic t Region) default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region) askRegion = lift askRegion - -- | Run an action in a local region, by applying a transformation to the region + + -- | Run an action in a local region, by applying a transformation to + -- the region. Affects both layout and viewport. localRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a localRegion f = hoist (localRegion f) + -- | The actual on-screen viewport region. May differ from 'askRegion' + -- inside containers that inflate the layout region (e.g. 'scrollable'). + -- Use this for rendering decisions: how many rows\/cols to fill, how + -- tall to draw a box, etc. + askViewport :: m (Dynamic t Region) + default askViewport :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region) + askViewport = lift askViewport + + -- | Run an action with a modified layout region only, leaving the + -- viewport unchanged. Used by 'scrollable' to give children more + -- layout height than is visible, while widgets still know the real + -- viewport size for rendering. + localLayoutRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a + default localLayoutRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a + localLayoutRegion f = hoist (localLayoutRegion f) + -- | Retrieve the display width displayWidth :: HasDisplayRegion t m => m (Dynamic t Int) displayWidth = fmap _region_width <$> askRegion @@ -329,6 +643,14 @@ displayHeight :: HasDisplayRegion t m => m (Dynamic t Int) displayHeight = fmap _region_height <$> askRegion +-- | Retrieve the viewport width (actual on-screen width) +viewportWidth :: HasDisplayRegion t m => m (Dynamic t Int) +viewportWidth = fmap _region_width <$> askViewport + +-- | Retrieve the viewport height (actual on-screen height) +viewportHeight :: HasDisplayRegion t m => m (Dynamic t Int) +viewportHeight = fmap _region_height <$> askViewport + instance HasDisplayRegion t m => HasDisplayRegion t (ReaderT x m) instance HasDisplayRegion t m => HasDisplayRegion t (BehaviorWriterT t x m) instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m) @@ -337,24 +659,26 @@ -- | A widget that has access to a particular region of the vty display newtype DisplayRegion t m a = DisplayRegion - { unDisplayRegion :: ReaderT (Dynamic t Region) m a } + {unDisplayRegion :: ReaderT (Dynamic t (Region, Region)) m a} deriving - ( Functor - , Applicative + ( Applicative + , Functor , Monad + , MonadCatch , MonadFix , MonadHold t , MonadIO + , MonadMask , MonadRef , MonadSample t - , MonadCatch , MonadThrow - , MonadMask ) instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where - askRegion = DisplayRegion ask - localRegion f = DisplayRegion . local f . unDisplayRegion + askRegion = DisplayRegion $ fmap fst <$> ask + localRegion f = DisplayRegion . local (\dr -> (,) <$> f (fst <$> dr) <*> f (snd <$> dr)) . unDisplayRegion + askViewport = DisplayRegion $ fmap snd <$> ask + localLayoutRegion f = DisplayRegion . local (\dr -> (,) <$> f (fst <$> dr) <*> (snd <$> dr)) . unDisplayRegion deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m) deriving instance NotReady t m => NotReady t (DisplayRegion t m) @@ -364,7 +688,8 @@ instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m) where captureImages x = do reg <- askRegion - lift $ captureImages $ runDisplayRegion reg x + vp <- askViewport + lift $ captureImages $ runDisplayRegionBoth reg vp x instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m) instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where @@ -381,14 +706,27 @@ instance MonadNodeId m => MonadNodeId (DisplayRegion t m) --- | Run a 'DisplayRegion' action with a given 'Region' +-- | Run a 'DisplayRegion' action with a given 'Region'. Sets both the +-- layout region and viewport to the same value. runDisplayRegion :: (Reflex t, Monad m) => Dynamic t Region -> DisplayRegion t m a -> m a -runDisplayRegion r = flip runReaderT r . unDisplayRegion +runDisplayRegion r = runDisplayRegionBoth r r +-- | Run a 'DisplayRegion' action with separate layout and viewport regions. +runDisplayRegionBoth + :: (Reflex t, Monad m) + => Dynamic t Region + -- ^ Layout region (what 'askRegion' returns) + -> Dynamic t Region + -- ^ Viewport region (what 'askViewport' returns) + -> DisplayRegion t m a + -> m a +runDisplayRegionBoth layout viewport = + flip runReaderT ((,) <$> layout <*> viewport) . unDisplayRegion + -- * Getting focus state -- | A class for things that can dynamically gain and lose focus @@ -408,19 +746,19 @@ -- | A widget that has access to information about whether it is focused newtype FocusReader t m a = FocusReader - { unFocusReader :: ReaderT (Dynamic t Bool) m a } + {unFocusReader :: ReaderT (Dynamic t Bool) m a} deriving - ( Functor - , Applicative + ( Applicative + , Functor , Monad + , MonadCatch , MonadFix , MonadHold t , MonadIO + , MonadMask , MonadRef , MonadSample t - , MonadCatch , MonadThrow - , MonadMask ) instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where @@ -462,38 +800,40 @@ -- * "Image" output -- | A class for widgets that can produce images to draw to the display -class (Reflex t, Monad m) => HasImageWriter (t :: *) m | m -> t where +class (Reflex t, Monad m) => HasImageWriter (t :: Type) m | m -> t where -- | Send images upstream for rendering tellImages :: Behavior t [Image] -> m () default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m () tellImages = lift . tellImages + -- | Apply a transformation to the images produced by the child actions mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a mapImages f = hoist (mapImages f) + -- | Capture images, preventing them from being drawn captureImages :: m a -> m (a, Behavior t [Image]) -- | A widget that can produce images to draw onto the display newtype ImageWriter t m a = ImageWriter - { unImageWriter :: BehaviorWriterT t [Image] m a } + {unImageWriter :: BehaviorWriterT t [Image] m a} deriving - ( Functor - , Applicative + ( Applicative + , Functor , Monad + , MonadCatch , MonadFix , MonadHold t , MonadIO + , MonadMask , MonadRef , MonadReflexCreateTrigger t , MonadSample t + , MonadThrow , NotReady t , PerformEvent t , PostBuild t , TriggerEvent t - , MonadCatch - , MonadThrow - , MonadMask ) instance MonadTrans (ImageWriter t) where @@ -535,7 +875,7 @@ instance HasImageWriter t m => HasImageWriter t (NodeIdT m) where captureImages x = NodeIdT $ do ref <- ask - lift $ captureImages $ flip runReaderT ref . unNodeIdT $ x + lift $ captureImages $ flip runReaderT ref . unNodeIdT $ x instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where tellImages = ImageWriter . tellBehavior @@ -546,7 +886,6 @@ captureImages (ImageWriter x) = ImageWriter $ do lift $ runBehaviorWriterT x - instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m) instance HasFocusReader t m => HasFocusReader t (ImageWriter t m) @@ -561,11 +900,18 @@ -- | A class for things that can be visually styled class (Reflex t, Monad m) => HasTheme t m | m -> t where - theme :: m (Behavior t V.Attr) - default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr) + theme :: m (Behavior t Theme) + default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t Theme) theme = lift theme - localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a - default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a + + -- | Convenience: the ambient 'V.Attr' from '_theme_default'. Most widgets + -- only need this. + themeAttr :: m (Behavior t V.Attr) + default themeAttr :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr) + themeAttr = lift themeAttr + + localTheme :: (Behavior t Theme -> Behavior t Theme) -> m a -> m a + default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t Theme -> Behavior t Theme) -> m a -> m a localTheme f = hoist (localTheme f) instance HasTheme t m => HasTheme t (ReaderT x m) @@ -580,23 +926,24 @@ -- | A widget that has access to theme information newtype ThemeReader t m a = ThemeReader - { unThemeReader :: ReaderT (Behavior t V.Attr) m a } + {unThemeReader :: ReaderT (Behavior t Theme) m a} deriving - ( Functor - , Applicative + ( Applicative + , Functor , Monad + , MonadCatch , MonadFix , MonadHold t , MonadIO + , MonadMask , MonadRef , MonadSample t - , MonadCatch , MonadThrow - , MonadMask ) instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where theme = ThemeReader ask + themeAttr = Reflex.Vty.Theme.themeToAttr <$> ThemeReader ask localTheme f = ThemeReader . local f . unThemeReader deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m) @@ -623,15 +970,95 @@ instance MonadNodeId m => MonadNodeId (ThemeReader t m) --- | Run a 'ThemeReader' action with the given focus value +-- | Run a 'ThemeReader' action with the given theme runThemeReader :: (Reflex t, Monad m) - => Behavior t V.Attr + => Behavior t Theme -> ThemeReader t m a -> m a runThemeReader b = flip runReaderT b . unThemeReader +-- * Color profile +-- | A class for widgets that need to know the terminal's color capability. +-- Widgets build with true-color 'V.Attr's and the host downsamples via +-- 'Reflex.Vty.ColorProfile.applyProfile' at the 'V.Picture' boundary, so +-- most widgets never need to call 'colorProfile' directly: it is useful +-- when a widget wants to make a structural decision based on capability +-- (e.g. choosing a different glyph for an 8-color terminal). +class (Reflex t, Monad m) => HasColorProfile t m | m -> t where + colorProfile :: m (Behavior t ColorProfile) + default colorProfile :: (f m' ~ m, Monad m', MonadTrans f, HasColorProfile t m') => m (Behavior t ColorProfile) + colorProfile = lift colorProfile + localColorProfile :: (Behavior t ColorProfile -> Behavior t ColorProfile) -> m a -> m a + default localColorProfile :: (f m' ~ m, Monad m', MFunctor f, HasColorProfile t m') => (Behavior t ColorProfile -> Behavior t ColorProfile) -> m a -> m a + localColorProfile f = hoist (localColorProfile f) + +instance HasColorProfile t m => HasColorProfile t (ReaderT x m) +instance HasColorProfile t m => HasColorProfile t (BehaviorWriterT t x m) +instance HasColorProfile t m => HasColorProfile t (DynamicWriterT t x m) +instance HasColorProfile t m => HasColorProfile t (EventWriterT t x m) +instance HasColorProfile t m => HasColorProfile t (NodeIdT m) +instance HasColorProfile t m => HasColorProfile t (Input t m) +instance HasColorProfile t m => HasColorProfile t (ImageWriter t m) +instance HasColorProfile t m => HasColorProfile t (DisplayRegion t m) +instance HasColorProfile t m => HasColorProfile t (FocusReader t m) +instance HasColorProfile t m => HasColorProfile t (ThemeReader t m) + +-- | A widget that has access to the terminal's 'ColorProfile'. +newtype ColorProfileReader t m a = ColorProfileReader + {unColorProfileReader :: ReaderT (Behavior t ColorProfile) m a} + deriving + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadFix + , MonadHold t + , MonadIO + , MonadMask + , MonadRef + , MonadSample t + , MonadThrow + ) + +instance (Monad m, Reflex t) => HasColorProfile t (ColorProfileReader t m) where + colorProfile = ColorProfileReader ask + localColorProfile f = ColorProfileReader . local f . unColorProfileReader + +deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ColorProfileReader t m) +deriving instance NotReady t m => NotReady t (ColorProfileReader t m) +deriving instance PerformEvent t m => PerformEvent t (ColorProfileReader t m) +deriving instance PostBuild t m => PostBuild t (ColorProfileReader t m) +deriving instance TriggerEvent t m => TriggerEvent t (ColorProfileReader t m) +instance HasImageWriter t m => HasImageWriter t (ColorProfileReader t m) where + captureImages x = ColorProfileReader $ do + a <- ask + lift $ captureImages $ flip runReaderT a $ unColorProfileReader x +instance HasTheme t m => HasTheme t (ColorProfileReader t m) + +instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ColorProfileReader t m) where + runWithReplace (ColorProfileReader a) e = ColorProfileReader $ runWithReplace a $ fmap unColorProfileReader e + traverseIntMapWithKeyWithAdjust f m e = ColorProfileReader $ traverseIntMapWithKeyWithAdjust (\k v -> unColorProfileReader $ f k v) m e + traverseDMapWithKeyWithAdjust f m e = ColorProfileReader $ traverseDMapWithKeyWithAdjust (\k v -> unColorProfileReader $ f k v) m e + traverseDMapWithKeyWithAdjustWithMove f m e = ColorProfileReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unColorProfileReader $ f k v) m e + +instance MonadTrans (ColorProfileReader t) where + lift = ColorProfileReader . lift + +instance MFunctor (ColorProfileReader t) where + hoist f = ColorProfileReader . hoist f . unColorProfileReader + +instance MonadNodeId m => MonadNodeId (ColorProfileReader t m) + +-- | Run a 'ColorProfileReader' action with the given profile. +runColorProfileReader + :: (Reflex t, Monad m) + => Behavior t ColorProfile + -> ColorProfileReader t m a + -> m a +runColorProfileReader b = flip runReaderT b . unColorProfileReader + -- ** Manipulating images -- | Translates and crops an 'Image' so that it is contained by @@ -665,13 +1092,15 @@ pane :: (MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m) => Dynamic t Region - -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is. + -> Dynamic t Bool + -- ^ Whether the widget should be focused when the parent is. -> m a -> m a -pane dr foc child = localRegion (const dr) $ - mapImages (imagesInRegion $ current dr) $ - localFocus (const foc) $ - inputInFocusedRegion >>= \e -> localInput (const e) child +pane dr foc child = + localRegion (const dr) $ + mapImages (imagesInRegion $ current dr) $ + localFocus (const foc) $ + inputInFocusedRegion >>= \e -> localInput (const e) child -- * Misc diff --git a/src/Reflex/Vty/Widget/Box.hs b/src/Reflex/Vty/Widget/Box.hs --- a/src/Reflex/Vty/Widget/Box.hs +++ b/src/Reflex/Vty/Widget/Box.hs @@ -1,6 +1,5 @@ -{-| - Description: Drawing boxes in various styles --} +-- | +-- Description: Drawing boxes in various styles module Reflex.Vty.Widget.Box where import Control.Monad.Fix (MonadFix) @@ -10,6 +9,8 @@ import Graphics.Vty (Image) import qualified Graphics.Vty as V import Reflex + +import Data.Text.Zipper (TextAlignment (..), textWidth) import Reflex.Vty.Widget import Reflex.Vty.Widget.Text @@ -55,31 +56,33 @@ roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│' -- | Draws a titled box in the provided style and a child widget inside of that box -boxTitle :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m) - => Behavior t BoxStyle - -> Behavior t Text - -> m a - -> m a -boxTitle boxStyle title child = do - dh <- displayHeight - dw <- displayWidth - bt <- theme +boxTitle + :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m) + => Behavior t TextAlignment + -> Behavior t BoxStyle + -> Behavior t Text + -> m a + -> m a +boxTitle align boxStyle title child = do + dh <- viewportHeight + dw <- viewportWidth + bt <- themeAttr let boxReg = Region 0 0 <$> dw <*> dh innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh) - tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg) + tellImages (boxImages <$> bt <*> align <*> title <*> boxStyle <*> current boxReg) tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r])) pane innerReg (pure True) child where - boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image] - boxImages attr title' style (Region left top width height) = + boxImages :: V.Attr -> TextAlignment -> Text -> BoxStyle -> Region -> [Image] + boxImages attr align' title' style (Region left top width height) = let right = left + width - 1 bottom = top + height - 1 sides = [ withinImage (Region (left + 1) top (width - 2) 1) $ V.text' attr $ - centerText title' (_boxStyle_n style) (width - 2) + alignText align' title' (_boxStyle_n style) (width - 2) , withinImage (Region right (top + 1) 1 (height - 2)) $ V.charFill attr (_boxStyle_e style) 1 (height - 2) , withinImage (Region (left + 1) bottom (width - 2) 1) $ @@ -99,29 +102,49 @@ ] in sides ++ if width > 1 && height > 1 then corners else [] --- | Pad text on the left and right with the given character so that it is --- centered -centerText - :: T.Text -- ^ Text to center - -> Char -- ^ Padding character - -> Int -- ^ Width - -> T.Text -- ^ Padded text -centerText t c l = if lt >= l - then t - else left <> t <> right +-- | Pad text on the left and right with the given character so that it +-- fills the given width, aligned according to the 'TextAlignment'. +alignText + :: TextAlignment + -- ^ Alignment + -> T.Text + -- ^ Text to align + -> Char + -- ^ Padding character + -> Int + -- ^ Target width + -> T.Text + -- ^ Aligned text +alignText align t c l + | tw >= l = t + | otherwise = case align of + TextAlignment_Left -> t <> pad delta + TextAlignment_Right -> pad delta <> t + TextAlignment_Center -> pad ((delta + 1) `div` 2) <> t <> pad (delta `div` 2) where - lt = T.length t - delta = l - lt - mkHalf n = T.replicate (n `div` 2) (T.singleton c) - left = mkHalf $ delta + 1 - right = mkHalf delta + tw = textWidth t + delta = l - tw + pad n = T.replicate n (T.singleton c) +-- | Specialized 'alignText' for center alignment. +centerText + :: T.Text + -- ^ Text to center + -> Char + -- ^ Padding character + -> Int + -- ^ Width + -> T.Text + -- ^ Padded text +centerText = alignText TextAlignment_Center + -- | A box without a title -box :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m) - => Behavior t BoxStyle - -> m a - -> m a -box boxStyle = boxTitle boxStyle mempty +box + :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m) + => Behavior t BoxStyle + -> m a + -> m a +box boxStyle = boxTitle (pure TextAlignment_Center) boxStyle mempty -- | A box whose style is static boxStatic diff --git a/src/Reflex/Vty/Widget/Input.hs b/src/Reflex/Vty/Widget/Input.hs --- a/src/Reflex/Vty/Widget/Input.hs +++ b/src/Reflex/Vty/Widget/Input.hs @@ -1,25 +1,26 @@ -{-| -Module: Reflex.Vty.Widget.Input -Description: User input widgets for reflex-vty --} +-- | +-- Module: Reflex.Vty.Widget.Input +-- Description: User input widgets for reflex-vty module Reflex.Vty.Widget.Input ( module Export , module Reflex.Vty.Widget.Input ) where - -import Reflex.Vty.Widget.Input.Mouse as Export -import Reflex.Vty.Widget.Input.Text as Export - import Control.Monad (join) import Control.Monad.Fix (MonadFix) -import Data.Default (Default(..)) +import Data.Default (Default (..)) import Data.List (foldl') import Data.Text (Text) import qualified Graphics.Vty as V import Reflex + +import Data.Text.Zipper (TextAlignment (..)) +import Reflex.Vty.Style (applyAttr) +import Reflex.Vty.Theme (Theme (..)) import Reflex.Vty.Widget import Reflex.Vty.Widget.Box +import Reflex.Vty.Widget.Input.Mouse as Export +import Reflex.Vty.Widget.Input.Text as Export import Reflex.Vty.Widget.Text -- * Buttons @@ -57,7 +58,7 @@ => ButtonConfig t -> Behavior t Text -> m (Event t ()) -textButton cfg = button cfg . text -- TODO Centering etc. +textButton cfg = button cfg . textWithAlignment TextAlignment_Center -- | A button widget that displays a static bit of text textButtonStatic @@ -75,11 +76,11 @@ => Behavior t Text -> m (Event t MouseUp) link t = do - bt <- theme - let cfg = RichTextConfig - { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt - } - richText cfg t + th <- theme + bt <- themeAttr + let linkStyle = fmap _theme_link th + attrs = applyAttr <$> linkStyle <*> bt + richText (RichTextConfig attrs) t mouseUp -- | A clickable link widget with a static label @@ -102,32 +103,32 @@ -- | This checkbox style uses an "x" to indicate the checked state checkboxStyleX :: CheckboxStyle -checkboxStyleX = CheckboxStyle - { _checkboxStyle_unchecked = "[ ]" - , _checkboxStyle_checked = "[x]" - } +checkboxStyleX = + CheckboxStyle + { _checkboxStyle_unchecked = "[ ]" + , _checkboxStyle_checked = "[x]" + } -- | This checkbox style uses a unicode tick mark to indicate the checked state checkboxStyleTick :: CheckboxStyle -checkboxStyleTick = CheckboxStyle - { _checkboxStyle_unchecked = "[ ]" - , _checkboxStyle_checked = "[✓]" - } +checkboxStyleTick = + CheckboxStyle + { _checkboxStyle_unchecked = "[ ]" + , _checkboxStyle_checked = "[✓]" + } -- | Configuration options for a checkbox data CheckboxConfig t = CheckboxConfig { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle - -- TODO DELETE and use HasTheme instead - , _checkboxConfig_attributes :: Behavior t V.Attr , _checkboxConfig_setValue :: Event t Bool } -instance (Reflex t) => Default (CheckboxConfig t) where - def = CheckboxConfig - { _checkboxConfig_checkboxStyle = pure def - , _checkboxConfig_attributes = pure V.defAttr - , _checkboxConfig_setValue = never - } +instance Reflex t => Default (CheckboxConfig t) where + def = + CheckboxConfig + { _checkboxConfig_checkboxStyle = pure def + , _checkboxConfig_setValue = never + } -- | A checkbox widget checkbox @@ -140,19 +141,22 @@ mu <- mouseUp space <- key (V.KChar ' ') f <- focus - v <- foldDyn ($) v0 $ leftmost - [ not <$ mu - , not <$ space - , const <$> _checkboxConfig_setValue cfg - ] - depressed <- hold V.defaultStyleMask $ leftmost - [ V.bold <$ md - , V.defaultStyleMask <$ mu - ] + v <- + foldDyn ($) v0 $ + leftmost + [ not <$ mu + , not <$ space + , const <$> _checkboxConfig_setValue cfg + ] + depressed <- + hold V.defaultStyleMask $ + leftmost + [ V.bold <$ md + , V.defaultStyleMask <$ mu + ] let focused = ffor (current f) $ \x -> if x then V.bold else V.defaultStyleMask - let attrs = combineStyles - <$> _checkboxConfig_attributes cfg - <*> sequence [depressed, focused] + bt <- themeAttr + let attrs = combineStyles <$> bt <*> sequence [depressed, focused] richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked -> if checked then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg diff --git a/src/Reflex/Vty/Widget/Input/Mouse.hs b/src/Reflex/Vty/Widget/Input/Mouse.hs --- a/src/Reflex/Vty/Widget/Input/Mouse.hs +++ b/src/Reflex/Vty/Widget/Input/Mouse.hs @@ -1,23 +1,70 @@ -{-| - Description: Mouse clicks, drags, and scrolls --} +-- | +-- Description: Mouse clicks, drags, and scrolls module Reflex.Vty.Widget.Input.Mouse where import Control.Monad.Fix import qualified Graphics.Vty as V import Reflex + import Reflex.Vty.Widget +-- | The phase of a drag operation. A drag is a sequence of events that begins +-- with a 'DragStart' (the button is pressed), continues with zero or more +-- 'Dragging' events (the mouse moves with the button held), and finishes with +-- a 'DragEnd' (the button is released). +data DragState + = -- | The button was just pressed; this is the first event of the drag. + DragStart + | -- | The mouse is moving with the button held down. + Dragging + | -- | The button was released; this is the last event of the drag. + DragEnd + deriving (Bounded, Enum, Eq, Ord, Read, Show) + -- | Information about a drag operation data Drag = Drag - { _drag_from :: (Int, Int) -- ^ Where the drag began - , _drag_to :: (Int, Int) -- ^ Where the mouse currently is - , _drag_button :: V.Button -- ^ Which mouse button is dragging - , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held - , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released) + { _drag_from :: (Int, Int) + -- ^ Where the drag began + , _drag_to :: (Int, Int) + -- ^ Where the mouse currently is + , _drag_button :: V.Button + -- ^ Which mouse button is dragging + , _drag_modifiers :: [V.Modifier] + -- ^ What modifiers are held + , _drag_state :: DragState + -- ^ Which phase of the drag this event represents. Use this to tell the + -- start of a drag ('DragStart') apart from its continuation ('Dragging') + -- and its end ('DragEnd'). } deriving (Eq, Ord, Show) +-- | Pure state transition driving 'drag'. Given the button being tracked, the +-- previous 'Drag' state (if any), and an incoming vty event, produce the next +-- 'Drag' or 'Nothing' if the event is irrelevant. The first relevant mouse-down +-- yields a 'DragStart', subsequent moves yield 'Dragging', and the button +-- release yields 'DragEnd'; a mouse-down after a 'DragEnd' starts a fresh drag. +stepDrag :: V.Button -> Maybe Drag -> V.Event -> Maybe Drag +stepDrag btn = \case + Nothing -> \case + V.EvMouseDown x y btn' mods + | btn == btn' -> Just $ Drag (x, y) (x, y) btn' mods DragStart + | otherwise -> Nothing + _ -> Nothing + Just (Drag from _ _ mods st) -> \case + V.EvMouseDown x y btn' mods' + | st == DragEnd && btn == btn' -> Just $ Drag (x, y) (x, y) btn' mods' DragStart + | btn == btn' -> Just $ Drag from (x, y) btn mods' Dragging + | otherwise -> Nothing -- Ignore other buttons. + V.EvMouseUp x y (Just btn') + | st == DragEnd -> Nothing + | btn == btn' -> Just $ Drag from (x, y) btn mods DragEnd + | otherwise -> Nothing + V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button, + -- assume it's the right one. + | st == DragEnd -> Nothing + | otherwise -> Just $ Drag from (x, y) btn mods DragEnd + _ -> Nothing + -- | Converts raw vty mouse drag events into an event stream of 'Drag's drag :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m) @@ -25,27 +72,7 @@ -> m (Event t Drag) drag btn = do inp <- input - let f :: Maybe Drag -> V.Event -> Maybe Drag - f Nothing = \case - V.EvMouseDown x y btn' mods - | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False - | otherwise -> Nothing - _ -> Nothing - f (Just (Drag from _ _ mods end)) = \case - V.EvMouseDown x y btn' mods' - | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False - | btn == btn' -> Just $ Drag from (x,y) btn mods' False - | otherwise -> Nothing -- Ignore other buttons. - V.EvMouseUp x y (Just btn') - | end -> Nothing - | btn == btn' -> Just $ Drag from (x,y) btn mods True - | otherwise -> Nothing - V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button, - -- assume it's the right one. - | end -> Nothing - | otherwise -> Just $ Drag from (x,y) btn mods True - _ -> Nothing - rec let newDrag = attachWithMaybe f (current dragD) inp + rec let newDrag = attachWithMaybe (stepDrag btn) (current dragD) inp dragD <- holdDyn Nothing $ Just <$> newDrag return (fmapMaybe id $ updated dragD) @@ -57,9 +84,10 @@ mouseDown btn = do i <- input return $ fforMaybe i $ \case - V.EvMouseDown x y btn' mods -> if btn == btn' - then Just $ MouseDown btn' (x, y) mods - else Nothing + V.EvMouseDown x y btn' mods -> + if btn == btn' + then Just $ MouseDown btn' (x, y) mods + else Nothing _ -> Nothing -- | Mouse up events for a particular mouse button @@ -98,9 +126,22 @@ mouseScroll = do up <- mouseDown V.BScrollUp down <- mouseDown V.BScrollDown - return $ leftmost - [ ScrollDirection_Up <$ up - , ScrollDirection_Down <$ down - ] - + return $ + leftmost + [ ScrollDirection_Up <$ up + , ScrollDirection_Down <$ down + ] +-- | Track the last known mouse position from any mouse event (down or up). +-- Note: true hover (motion without a button held) requires terminal mode +-- 1003, which vty 6.2 does not expose. Position updates only on click/release. +mousePosition + :: (Reflex t, MonadHold t m, HasInput t m) + => m (Dynamic t (Int, Int)) +mousePosition = do + inp <- input + let posEvent = fforMaybe inp $ \case + V.EvMouseDown x y _ _ -> Just (x, y) + V.EvMouseUp x y _ -> Just (x, y) + _ -> Nothing + holdDyn (0, 0) posEvent diff --git a/src/Reflex/Vty/Widget/Input/Text.hs b/src/Reflex/Vty/Widget/Input/Text.hs --- a/src/Reflex/Vty/Widget/Input/Text.hs +++ b/src/Reflex/Vty/Widget/Input/Text.hs @@ -1,7 +1,6 @@ -{-| -Module: Reflex.Vty.Widget.Input.Text -Description: Widgets for accepting text input from users and manipulating text within those inputs --} +-- | +-- Module: Reflex.Vty.Widget.Input.Text +-- Description: Widgets for accepting text input from users and manipulating text within those inputs module Reflex.Vty.Widget.Input.Text ( module Reflex.Vty.Widget.Input.Text , def @@ -9,52 +8,59 @@ import Control.Monad (join) import Control.Monad.Fix (MonadFix) -import Data.Default (Default(..)) +import Data.Default (Default (..)) import Data.Function ((&)) import Data.Text (Text) -import Data.Text.Zipper +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) import qualified Graphics.Vty as V import Reflex +import Data.Text.Zipper +import Reflex.Vty.Style (applyAttr) +import Reflex.Vty.Theme (Theme (..)) import Reflex.Vty.Widget -import Reflex.Vty.Widget.Layout import Reflex.Vty.Widget.Input.Mouse +import Reflex.Vty.Widget.Layout -- | Configuration options for a 'textInput'. For more information on -- 'TextZipper', see 'Data.Text.Zipper'. data TextInputConfig t = TextInputConfig { _textInputConfig_initialValue :: TextZipper -- ^ Initial value. This is a 'TextZipper' because it is more flexible - -- than plain 'Text'. For example, this allows to set the Cursor position, - -- by choosing appropriate values for '_textZipper_before' and '_textZipper_after'. + -- than plain 'Text'. For example, this allows to set the Cursor position, + -- by choosing appropriate values for '_textZipper_before' and '_textZipper_after'. , _textInputConfig_modify :: Event t (TextZipper -> TextZipper) -- ^ Event to update the value of the 'textInput'. -- - -- Event is applied after other Input sources have been applied to the 'TextZipper', - -- thus you may modify the final value that is displayed to the user. + -- Event is applied after other Input sources have been applied to the 'TextZipper', + -- thus you may modify the final value that is displayed to the user. -- - -- You may set the value of the displayed text in 'textInput' by ignoring the input parameter. + -- You may set the value of the displayed text in 'textInput' by ignoring the input parameter. -- - -- Additionally, you can modify the updated value before displaying it to the user. - -- For example, the following 'TextInputConfig' inserts an additional 'a' - -- when the letter 'b' is entered into 'textInput': + -- Additionally, you can modify the updated value before displaying it to the user. + -- For example, the following 'TextInputConfig' inserts an additional 'a' + -- when the letter 'b' is entered into 'textInput': -- - -- @ + -- @ -- i <- input -- textInput def -- { _textInputConfig_modify = fforMaybe i $ \case -- V.EvKey (V.KChar 'b') _ -> Just (insert "a") -- _ -> Nothing -- } - -- @ + -- @ , _textInputConfig_tabWidth :: Int , _textInputConfig_display :: Dynamic t (Char -> Char) -- ^ Transform the characters in a text input before displaying them. This is useful, e.g., for - -- masking characters when entering passwords. + -- masking characters when entering passwords. + , _textInputConfig_alignment :: TextAlignment + -- ^ How to align the entered text within the input region. Defaults to + -- 'TextAlignment_Left'. See 'Data.Text.Zipper.displayLinesWithAlignment'. } instance Reflex t => Default (TextInputConfig t) where - def = TextInputConfig empty never 4 (pure id) + def = TextInputConfig empty never 4 (pure id) TextAlignment_Left -- | The output produced by text input widgets, including the text -- value and the number of display lines (post-wrapping). Note that some @@ -64,8 +70,8 @@ -- ^ The current value of the textInput as Text. , _textInput_userInput :: Event t TextZipper -- ^ UI Event updates with the current 'TextZipper'. - -- This does not include Events added by '_textInputConfig_setValue', but - -- it does include '_textInputConfig_modify' Events. + -- This does not include Events added by '_textInputConfig_setValue', but + -- it does include '_textInputConfig_modify' Events. , _textInput_lines :: Dynamic t Int } @@ -77,35 +83,44 @@ textInput cfg = do i <- input f <- focus - dh <- displayHeight - dw <- displayWidth - bt <- theme + dh <- viewportHeight + dw <- viewportWidth + bt <- themeAttr + th <- theme attr0 <- sample bt - rec - -- we split up the events from vty and the one users provide to avoid cyclical + cursorStyle0 <- sample (fmap _theme_textInputCursor th) + rec -- we split up the events from vty and the one users provide to avoid cyclical -- update dependencies. This way, users may subscribe only to UI updates. let valueChangedByCaller = _textInputConfig_modify cfg - let valueChangedByUI = mergeWith (.) - [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i - , let displayInfo = (,) <$> current rows <*> scrollTop - in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) -> - goToDisplayLinePosition mx (st + my) dl + let valueChangedByUI = + mergeWith + (.) + [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i + , let displayInfo = (,) <$> current rows <*> scrollTop + in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) -> + goToDisplayLinePosition mx (st + my) dl + , fforMaybe i $ \case + V.EvPaste bs -> Just (insert (TE.decodeUtf8With lenientDecode bs)) + _ -> Nothing + ] + v <- + foldDyn ($) (_textInputConfig_initialValue cfg) $ + mergeWith + (.) + [ valueChangedByCaller + , valueChangedByUI ] - v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.) - [ valueChangedByCaller - , valueChangedByUI - ] click <- mouseDown V.BLeft - -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg) - let toCursorAttrs attr = V.withStyle attr V.reverseVideo - rowInputDyn = (,,) - <$> dw - <*> (mapZipper <$> _textInputConfig_display cfg <*> v) - <*> f - toDisplayLines attr (w, s, x) = + let toCursorAttrs attr = applyAttr cursorStyle0 attr + rowInputDyn = + (,,) + <$> dw + <*> (mapZipper <$> _textInputConfig_display cfg <*> v) + <*> f + toDisplayLines attr (w, s, x) = let c = if x then toCursorAttrs attr else attr - in displayLines w attr c s + in displayLinesWithAlignment (_textInputConfig_alignment cfg) w attr c s attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn) let rows = ffor2 attrDyn rowInputDyn toDisplayLines img = images . _displayLines_spans <$> rows @@ -117,12 +132,13 @@ | otherwise = st let hy = attachWith newScrollTop scrollTop $ updated $ zipDyn dh y scrollTop <- hold 0 hy - tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop - return $ TextInput - { _textInput_value = value <$> v - , _textInput_userInput = attachWith (&) (current v) valueChangedByUI - , _textInput_lines = length . _displayLines_spans <$> rows - } + tellImages $ (\imgs st -> (: []) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop + return $ + TextInput + { _textInput_value = value <$> v + , _textInput_userInput = attachWith (&) (current v) valueChangedByUI + , _textInput_lines = length . _displayLines_spans <$> rows + } -- | A widget that allows multiline text input multilineTextInput @@ -131,14 +147,17 @@ -> m (TextInput t) multilineTextInput cfg = do i <- input - textInput $ cfg - { _textInputConfig_modify = mergeWith (.) - [ fforMaybe i $ \case - V.EvKey V.KEnter [] -> Just $ insert "\n" - _ -> Nothing - , _textInputConfig_modify cfg - ] - } + textInput $ + cfg + { _textInputConfig_modify = + mergeWith + (.) + [ fforMaybe i $ \case + V.EvKey V.KEnter [] -> Just $ insert "\n" + _ -> Nothing + , _textInputConfig_modify cfg + ] + } -- | Wraps a 'textInput' or 'multilineTextInput' in a tile. Uses -- the computed line count to greedily size the tile when vertically @@ -170,10 +189,14 @@ -- | Default vty event handler for text inputs updateTextZipper - :: Int -- ^ Tab width - -> Int -- ^ Page size - -> V.Event -- ^ The vty event to handle - -> TextZipper -- ^ The zipper to modify + :: Int + -- ^ Tab width + -> Int + -- ^ Page size + -> V.Event + -- ^ The vty event to handle + -> TextZipper + -- ^ The zipper to modify -> TextZipper updateTextZipper tabWidth pageSize ev = case ev of -- Special characters diff --git a/src/Reflex/Vty/Widget/Layout.hs b/src/Reflex/Vty/Widget/Layout.hs --- a/src/Reflex/Vty/Widget/Layout.hs +++ b/src/Reflex/Vty/Widget/Layout.hs @@ -1,34 +1,34 @@ -{-| -Module: Reflex.Vty.Widget.Layout -Description: Monad transformer and tools for arranging widgets and building screen layouts --} -{-# Language UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module: Reflex.Vty.Widget.Layout +-- Description: Monad transformer and tools for arranging widgets and building screen layouts module Reflex.Vty.Widget.Layout where -import Control.Applicative (liftA2) -import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask) -import Control.Monad.Morph -import Control.Monad.NodeId (MonadNodeId(..), NodeId) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix +import Control.Monad.Morph import Control.Monad.Reader import Data.List (mapAccumL) import Data.Map.Ordered (OMap) import qualified Data.Map.Ordered as OMap import Data.Maybe (fromMaybe, isNothing) import Data.Ratio ((%)) -import Data.Semigroup (First(..)) +import Data.Semigroup (First (..)) import Data.Set.Ordered (OSet) import qualified Data.Set.Ordered as OSet import qualified Graphics.Vty as V - import Reflex import Reflex.Host.Class (MonadReflexCreateTrigger) + +import Control.Monad.NodeId (MonadNodeId (..), NodeId) import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse -- * Focus + -- + -- $focus -- -- The focus monad tracks which element is currently focused and processes @@ -48,7 +48,7 @@ -- | An ordered set of focus identifiers. The order here determines the order -- in which focus cycles between focusable elements. -newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId } +newtype FocusSet = FocusSet {unFocusSet :: OSet FocusId} instance Semigroup FocusSet where FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b @@ -63,9 +63,13 @@ -- ** Changing focus state -- | Operations that change the currently focused element. -data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS') - | Refocus_Id FocusId -- ^ Focus a particular element - | Refocus_Clear -- ^ Remove focus from all elements +data Refocus + = -- | Shift the focus by a certain number of positions (see 'shiftFS') + Refocus_Shift Int + | -- | Focus a particular element + Refocus_Id FocusId + | -- | Remove focus from all elements + Refocus_Clear -- | Given a 'FocusSet', a currently focused element, and a number of positions -- to move by, determine the newly focused element. @@ -81,43 +85,52 @@ class (Monad m, Reflex t) => HasFocus t m | m -> t where -- | Create a focusable element. makeFocus :: m FocusId + -- | Emit an 'Event' of requests to change the focus. requestFocus :: Event t Refocus -> m () + -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused. isFocused :: FocusId -> m (Dynamic t Bool) + -- | Run an action, additionally returning the focusable elements it produced. subFoci :: m a -> m (a, Dynamic t FocusSet) + -- | Get a 'Dynamic' of the currently focused element identifier. focusedId :: m (Dynamic t (Maybe FocusId)) -- | A monad transformer that keeps track of the set of focusable elements and -- which, if any, are currently focused, and allows focus requests. newtype Focus t m a = Focus - { unFocus :: DynamicWriterT t FocusSet - (ReaderT (Dynamic t (Maybe FocusId)) - (EventWriterT t (First Refocus) m)) a + { unFocus + :: DynamicWriterT + t + FocusSet + ( ReaderT + (Dynamic t (Maybe FocusId)) + (EventWriterT t (First Refocus) m) + ) + a } deriving - ( Functor - , Applicative + ( Applicative + , Functor + , HasDisplayRegion t , Monad + , MonadCatch + , MonadFix , MonadHold t + , MonadIO + , MonadMask + , MonadNodeId + , MonadReflexCreateTrigger t , MonadSample t - , MonadFix - , TriggerEvent t - , PerformEvent t + , MonadThrow , NotReady t - , MonadReflexCreateTrigger t - , HasDisplayRegion t + , PerformEvent t , PostBuild t - , MonadNodeId - , MonadIO - , MonadCatch - , MonadThrow - , MonadMask + , TriggerEvent t ) - instance MonadTrans (Focus t) where lift = Focus . lift . lift . lift @@ -144,6 +157,12 @@ instance (HasTheme t m, Monad m) => HasTheme t (Focus t m) +instance (HasColorProfile t m, Monad m) => HasColorProfile t (Focus t m) + +instance HasCursor t m => HasCursor t (Focus t m) + +instance HasScreenMode t m => HasScreenMode t (Focus t m) + instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where makeFocus = do fid <- FocusId <$> lift getNextNodeId @@ -173,9 +192,10 @@ f (fs, rf) mf = case getFirst rf of Refocus_Clear -> Nothing Refocus_Id fid -> Just fid - Refocus_Shift n -> if n < 0 && isNothing mf - then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n - else shiftFS fs mf n + Refocus_Shift n -> + if n < 0 && isNothing mf + then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n + else shiftFS fs mf n -- | Runs an action in the focus monad, providing it with information about -- whether any of the foci created within it are focused. @@ -186,9 +206,14 @@ anyChildFocused f = do fid <- focusedId rec (a, fs) <- subFoci (f b) - let b = liftA2 (\foc s -> case foc of - Nothing -> False - Just f' -> OSet.member f' $ unFocusSet s) fid fs + let b = + liftA2 + ( \foc s -> case foc of + Nothing -> False + Just f' -> OSet.member f' $ unFocusSet s + ) + fid + fs pure a -- ** Focus controls @@ -202,7 +227,9 @@ requestFocus $ Refocus_Shift <$> leftmost [fwd, back] -- * Layout + -- + -- $layout -- The layout monad keeps track of a tree of elements, each having its own -- layout constraints and orientation. Given the available rendering space, it @@ -213,16 +240,16 @@ -- -- - 'axis', which lays out its children in a particular orientation, and -- - 'region', which "claims" some part of the screen according to its constraints --- -- ** Layout restrictions -- *** Constraints -- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation') -data Constraint = Constraint_Fixed Int - | Constraint_Min Int - deriving (Show, Read, Eq, Ord) +data Constraint + = Constraint_Fixed Int + | Constraint_Min Int + deriving (Eq, Ord, Read, Show) -- | Shorthand for constructing a fixed constraint fixed @@ -247,9 +274,10 @@ -- *** Orientation -- | The main-axis orientation of a 'Layout' widget -data Orientation = Orientation_Column - | Orientation_Row - deriving (Show, Read, Eq, Ord) +data Orientation + = Orientation_Column + | Orientation_Row + deriving (Eq, Ord, Read, Show) -- | Create a row-oriented 'axis' row @@ -275,7 +303,7 @@ -- | An ordered, indexed collection of 'LayoutTree's representing information -- about the children of some widget. -newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) } +newtype LayoutForest a = LayoutForest {unLayoutForest :: OMap NodeId (LayoutTree a)} deriving (Show) instance Semigroup (LayoutForest a) where @@ -317,15 +345,22 @@ Orientation_Row -> _region_width r0 Orientation_Column -> _region_height r0 sizes = computeEdges $ computeSizes extent a - chunks = [ (nodeId, solve o1 r1 f) - | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes - , let r1 = chunk o0 r0 sz - ] + chunks = + [ (nodeId, solve o1 r1 f) + | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes + , let r1 = chunk o0 r0 sz + ] in LayoutTree (r0, o0) $ fromListLF chunks where computeEdges :: [(a, Int)] -> [(a, (Int, Int))] - computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) -> - (((a, (offset, sz)) :) . m, sz + offset)) (id, 0) + computeEdges = + ($ []) + . fst + . foldl + ( \(m, offset) (a, sz) -> + (((a, (offset, sz)) :) . m, sz + offset) + ) + (id, 0) computeSizes :: Int -> [(a, Constraint)] @@ -336,22 +371,27 @@ let minTotal = sum $ ffor constraints $ \case (_, Constraint_Fixed n) -> n (_, Constraint_Min n) -> n - -- The leftover space is the area we can allow stretchable items to - -- expand into + -- The leftover space is the area we can allow stretchable items to + -- expand into leftover = max 0 (available - minTotal) - -- The number of stretchable items that will try to share some of the - -- leftover space + -- The number of stretchable items that will try to share some of the + -- leftover space numStretch = length $ filter (isMin . snd) constraints - -- Space to allocate to the stretchable items (this is the same for all - -- items and there may still be additional leftover space that will have - -- to be unevenly distributed) + -- Space to allocate to the stretchable items (this is the same for all + -- items and there may still be additional leftover space that will have + -- to be unevenly distributed) szStretch = floor $ leftover % max numStretch 1 - -- Remainder of available space after even distribution. This extra space - -- will be distributed to as many stretchable widgets as possible. + -- Remainder of available space after even distribution. This extra space + -- will be distributed to as many stretchable widgets as possible. adjustment = max 0 $ available - minTotal - szStretch * numStretch - in snd $ mapAccumL (\adj (a, c) -> case c of - Constraint_Fixed n -> (adj, (a, n)) - Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints + in snd $ + mapAccumL + ( \adj (a, c) -> case c of + Constraint_Fixed n -> (adj, (a, n)) + Constraint_Min n -> (max 0 (adj - 1), (a, n + szStretch + signum adj)) + ) + adjustment + constraints isMin (Constraint_Min _) = True isMin _ = False @@ -359,53 +399,61 @@ -- and main-axis size of the chunk. chunk :: Orientation -> Region -> (Int, Int) -> Region chunk o r (offset, sz) = case o of - Orientation_Column -> r - { _region_top = _region_top r + offset - , _region_height = sz - } - Orientation_Row -> r - { _region_left = _region_left r + offset - , _region_width = sz - } + Orientation_Column -> + r + { _region_top = _region_top r + offset + , _region_height = sz + } + Orientation_Row -> + r + { _region_left = _region_left r + offset + , _region_width = sz + } -- ** The layout monad -- | A class of operations for creating screen layouts. class Monad m => HasLayout t m | m -> t where -- | Starts a parent element in the current layout with the given size - -- constraint, which lays out its children according to the provided - -- orientation. + -- constraint, which lays out its children according to the provided + -- orientation. axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a + -- | Creates a child element in the current layout with the given size - -- constraint, returning the 'Region' that the child element is allocated. + -- constraint, returning the 'Region' that the child element is allocated. region :: Dynamic t Constraint -> m (Dynamic t Region) + -- | Returns the orientation of the containing 'axis'. askOrientation :: m (Dynamic t Orientation) -- | A monad transformer that collects layout constraints and provides a layout -- solution that satisfies those constraints. newtype Layout t m a = Layout - { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation)) - (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a + { unLayout + :: DynamicWriterT + t + (LayoutForest (Constraint, Orientation)) + (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) + a } deriving - ( Functor - , Applicative + ( Applicative + , Functor , HasDisplayRegion t , Monad + , MonadCatch , MonadFix , MonadHold t , MonadIO + , MonadMask , MonadNodeId , MonadReflexCreateTrigger t , MonadSample t + , MonadThrow , NotReady t , PerformEvent t , PostBuild t , TriggerEvent t - , MonadCatch - , MonadThrow - , MonadMask ) instance MonadTrans (Layout t) where @@ -451,6 +499,12 @@ instance (HasTheme t m, Monad m) => HasTheme t (Layout t m) +instance (HasColorProfile t m, Monad m) => HasColorProfile t (Layout t m) + +instance HasCursor t m => HasCursor t (Layout t m) + +instance HasScreenMode t m => HasScreenMode t (Layout t m) + instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where axis o c (Layout x) = Layout $ do nodeId <- getNextNodeId @@ -498,7 +552,9 @@ runLayout (pure Orientation_Column) r f -- * The tile "window manager" + -- + -- $tiling -- Generally HasLayout and HasFocus are used together to build a user -- interface. These functions check the available screen size and initialize diff --git a/src/Reflex/Vty/Widget/Scroll.hs b/src/Reflex/Vty/Widget/Scroll.hs --- a/src/Reflex/Vty/Widget/Scroll.hs +++ b/src/Reflex/Vty/Widget/Scroll.hs @@ -1,24 +1,39 @@ -{-| Description: Widgets that scroll when their contents don't fit --} +-- | Description: Widgets that scroll when their contents don't fit module Reflex.Vty.Widget.Scroll where import Control.Monad.Fix +import Control.Monad.IO.Class import Data.Default +import Data.Functor (void) import Data.List (foldl') import qualified Graphics.Vty as V import Reflex + import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse -- | Configuration options for automatic scroll-to-bottom behavior data ScrollToBottom - = ScrollToBottom_Always - -- ^ Always scroll to the bottom on new output - | ScrollToBottom_Maintain - -- ^ Scroll down with new output only when, prior to the new output being - -- added, the widget was scrolled all the way to the bottom. + = -- | Always scroll to the bottom on new output + ScrollToBottom_Always + | -- | Scroll down with new output only when, prior to the new output being + -- added, the widget was scrolled all the way to the bottom. + ScrollToBottom_Maintain deriving (Eq, Ord, Show) +-- | Controls when the scrollbar is visible. +data ScrollbarVisibility + = -- | Always show gutter (track) + thumb when content overflows + ScrollbarAlways + | -- | Show thumb only (no gutter) when content overflows + ScrollbarThumbOnly + | -- | Show thumb only while actively scrolling; hides on the next + -- non-scroll input. No gutter. + ScrollbarWhileScrolling + | -- | Never show scrollbar; child gets full width + ScrollbarHidden + deriving (Eq, Ord, Show) + -- | Configuration for the scrollable element. Controls scroll behavior. data ScrollableConfig t = ScrollableConfig { _scrollableConfig_scrollBy :: Event t Int @@ -29,14 +44,16 @@ -- ^ The initial scroll position , _scrollableConfig_scrollToBottom :: Behavior t (Maybe ScrollToBottom) -- ^ How the scroll position should be adjusted as new content is added + , _scrollableConfig_scrollbarVisibility :: ScrollbarVisibility + -- ^ When to show the scrollbar } instance Reflex t => Default (ScrollableConfig t) where - def = ScrollableConfig never never ScrollPos_Top (pure Nothing) + def = ScrollableConfig never never ScrollPos_Top (pure Nothing) ScrollbarThumbOnly -- | The scroll position data ScrollPos = ScrollPos_Top | ScrollPos_Line Int | ScrollPos_Bottom - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show) -- | The output of a 'scrollable', indicating its current scroll position. data Scrollable t = Scrollable @@ -48,54 +65,92 @@ -- | Scrollable widget. The output exposes the current scroll position and -- total number of lines (including those that are hidden) scrollable - :: forall t m a. - ( Reflex t, MonadHold t m, MonadFix m - , HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m) + :: forall t m a + . ( Reflex t + , MonadHold t m + , MonadFix m + , PerformEvent t m + , TriggerEvent t m + , MonadIO (Performable m) + , HasDisplayRegion t m + , HasInput t m + , HasImageWriter t m + , HasTheme t m + ) => ScrollableConfig t -> (m (Event t (), a)) -> m (Scrollable t, a) -scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do +scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend sbVisibility) mkImg = do dh <- displayHeight + dw <- displayWidth + bt <- themeAttr kup <- key V.KUp kdown <- key V.KDown m <- mouseScroll let requestedScroll :: Event t Int - requestedScroll = leftmost - [ 1 <$ kdown - , (-1) <$ kup - , ffor m $ \case - ScrollDirection_Up -> (-1) - ScrollDirection_Down -> 1 - , scrollBy - ] - rec - ((update, a), imgs) <- captureImages $ localInput (translateMouseEvents translation) $ mkImg - let sz = foldl' max 0 . fmap V.imageHeight <$> imgs - lineIndex <- foldDynMaybe ($) startingPos $ leftmost - [ (\(totalLines, (h, d)) sp -> Just $ scrollByLines sp totalLines h d) <$> attach sz (attachPromptlyDyn dh requestedScroll) - , (\(totalLines, (h, newScrollPosition)) _ -> Just $ case newScrollPosition of - ScrollPos_Line n -> scrollToLine totalLines h n - ScrollPos_Top -> ScrollPos_Top - ScrollPos_Bottom -> ScrollPos_Bottom - ) <$> attach sz (attachPromptlyDyn dh scrollTo) - , (\cfg sp -> case cfg of - Just ScrollToBottom_Always -> case sp of - ScrollPos_Bottom -> Nothing - _ -> Just ScrollPos_Bottom - _ -> Nothing) <$> tag onAppend update - ] - let translation = calculateTranslation - <$> current dh - <*> current lineIndex - <*> sz + requestedScroll = + leftmost + [ 1 <$ kdown + , (-1) <$ kup + , ffor m $ \case + ScrollDirection_Up -> (-1) + ScrollDirection_Down -> 1 + , scrollBy + ] + widthTransform = case sbVisibility of + ScrollbarHidden -> id + _ -> fmap shrinkRegionForScrollbar + heightTransform = fmap (\r -> r {_region_height = largeScrollHeight}) + where + largeScrollHeight = 10000 + scrollingNow <- case sbVisibility of + ScrollbarWhileScrolling -> do + let scrollActivity = void requestedScroll + hideAfterQuiet <- debounce 1.5 scrollActivity + hold False $ leftmost [True <$ scrollActivity, False <$ hideAfterQuiet] + _ -> pure (pure True) + rec ((update, a), imgs) <- captureImages $ localLayoutRegion heightTransform $ localRegion widthTransform $ localInput (translateMouseEvents translation) $ mkImg + let sz = foldl' max 0 . fmap V.imageHeight <$> imgs + lineIndex <- + foldDynMaybe ($) startingPos $ + leftmost + [ (\(totalLines, (h, d)) sp -> Just $ scrollByLines sp totalLines h d) <$> attach sz (attachPromptlyDyn dh requestedScroll) + , ( \(totalLines, (h, newScrollPosition)) _ -> Just $ case newScrollPosition of + ScrollPos_Line n -> scrollToLine totalLines h n + ScrollPos_Top -> ScrollPos_Top + ScrollPos_Bottom -> ScrollPos_Bottom + ) + <$> attach sz (attachPromptlyDyn dh scrollTo) + , ( \cfg sp -> case cfg of + Just ScrollToBottom_Always -> case sp of + ScrollPos_Bottom -> Nothing + _ -> Just ScrollPos_Bottom + _ -> Nothing + ) + <$> tag onAppend update + ] + let translation = + calculateTranslation + <$> current dh + <*> current lineIndex + <*> sz let cropImages dy images = cropFromTop dy <$> images tellImages $ cropImages <$> translation <*> imgs - return $ (,a) $ Scrollable - { _scrollable_scrollPosition = current lineIndex - , _scrollable_totalLines = sz - , _scrollable_scrollHeight = current dh - } + let sbImgs = scrollbarImages sbVisibility <$> bt <*> current dh <*> sz <*> translation <*> current dw + sbGated = case sbVisibility of + ScrollbarWhileScrolling -> + (\vis imgs' -> if vis then imgs' else []) <$> scrollingNow <*> sbImgs + _ -> sbImgs + tellImages sbGated + return $ + (,a) $ + Scrollable + { _scrollable_scrollPosition = current lineIndex + , _scrollable_totalLines = sz + , _scrollable_scrollHeight = current dh + } where + shrinkRegionForScrollbar (Region l t w h) = Region l t (max 0 (w - 1)) h cropFromTop :: Int -> V.Image -> V.Image cropFromTop rows i = V.cropTop (max 0 $ V.imageHeight i - rows) i @@ -104,11 +159,11 @@ ScrollPos_Top -> 0 ScrollPos_Line n -> max 0 n translateMouseEvents translation vtyEvent = - let e = attach translation vtyEvent - in ffor e $ \case - (dy, V.EvMouseDown x y btn mods) -> V.EvMouseDown x (y + dy) btn mods - (dy, V.EvMouseUp x y btn) -> V.EvMouseUp x (y + dy) btn - (_, otherEvent) -> otherEvent + let e = attach translation vtyEvent + in ffor e $ \case + (dy, V.EvMouseDown x y btn mods) -> V.EvMouseDown x (y + dy) btn mods + (dy, V.EvMouseUp x y btn) -> V.EvMouseUp x (y + dy) btn + (_, otherEvent) -> otherEvent -- | Modify the scroll position by the given number of lines scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos @@ -122,8 +177,47 @@ -- | Scroll to a particular line scrollToLine :: Int -> Int -> Int -> ScrollPos -scrollToLine totalLines height newPos = if - | totalLines <= height -> ScrollPos_Top - | newPos == 0 -> ScrollPos_Top - | newPos + height >= totalLines -> ScrollPos_Bottom - | otherwise -> ScrollPos_Line newPos +scrollToLine totalLines height newPos = + if + | totalLines <= height -> ScrollPos_Top + | newPos == 0 -> ScrollPos_Top + | newPos + height >= totalLines -> ScrollPos_Bottom + | otherwise -> ScrollPos_Line newPos + +-- | Build the scrollbar images (gutter + thumb). Returns empty list when +-- the scrollbar is hidden, the content fits within the viewport, or the +-- viewport is too narrow. In 'ScrollbarThumbOnly' and +-- 'ScrollbarWhileScrolling' modes, only the thumb is drawn (no gutter). +scrollbarImages + :: ScrollbarVisibility + -> V.Attr + -- ^ Attribute for both gutter and thumb + -> Int + -- ^ Viewport height + -> Int + -- ^ Total content lines + -> Int + -- ^ Current scroll offset (lines scrolled from top) + -> Int + -- ^ Viewport width + -> [V.Image] +scrollbarImages visibility attr vpHeight totalLines scrollLine vpWidth + | visibility == ScrollbarHidden = [] + | totalLines <= vpHeight = [] + | vpWidth <= 1 = [] + | otherwise = + let maxScroll = max 1 (totalLines - vpHeight) + thumbLen = max 1 (vpHeight * vpHeight `div` totalLines) + thumbTrack = vpHeight - thumbLen + thumbTop = min thumbTrack (scrollLine * thumbTrack `div` maxScroll) + gutterCol = vpWidth - 1 + thumbImg = + withinImage (Region gutterCol thumbTop 1 thumbLen) $ + V.charFill attr '█' 1 thumbLen + gutterImgs = case visibility of + ScrollbarAlways -> + [ withinImage (Region gutterCol 0 1 vpHeight) $ + V.charFill attr '░' 1 vpHeight + ] + _ -> [] + in gutterImgs ++ [thumbImg] diff --git a/src/Reflex/Vty/Widget/Split.hs b/src/Reflex/Vty/Widget/Split.hs --- a/src/Reflex/Vty/Widget/Split.hs +++ b/src/Reflex/Vty/Widget/Split.hs @@ -1,45 +1,47 @@ -{-| - Description: Widgets that split the display vertically or horizontally. --} +-- | +-- Description: Widgets that split the display vertically or horizontally. module Reflex.Vty.Widget.Split where -import Control.Applicative import Control.Monad.Fix import Graphics.Vty as V import Reflex + import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse -- | A split of the available space into two parts with a draggable separator. -- Starts with half the space allocated to each, and the first pane has focus. -- Clicking in a pane switches focus. -splitVDrag :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) +splitVDrag + :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) => m () -> m a -> m b - -> m (a,b) + -> m (a, b) splitVDrag wS wA wB = do - dh <- displayHeight - dw <- displayWidth + dh <- viewportHeight + dw <- viewportWidth h0 <- sample $ current dh -- TODO dragE <- drag V.BLeft let splitter0 = h0 `div` 2 rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter] splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter] - splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) -> + splitterFrac <- holdDyn ((1 :: Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) -> fromIntegral x / max 1 (fromIntegral h) let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $ - \(splitterY, Drag (_, fromY) (_, toY) _ _ end) -> - if splitterY == fromY then Just (toY, end) else Nothing + \(splitterY, Drag (_, fromY) (_, toY) _ _ st) -> + if splitterY == fromY then Just (toY, st == DragEnd) else Nothing regA = Region 0 0 <$> dw <*> splitterPos regS = Region 0 <$> splitterPos <*> dw <*> 1 regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1) resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $ \(frac, h) -> round (frac * fromIntegral h) - focA <- holdDyn True $ leftmost - [ True <$ mA - , False <$ mB - ] + focA <- + holdDyn True $ + leftmost + [ True <$ mA + , False <$ mB + ] (mA, rA) <- pane regA focA $ withMouseDown wA pane regS (pure False) wS (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB @@ -52,40 +54,42 @@ -- | A plain split of the available space into vertically stacked panes. -- No visual separator is built in here. -splitV :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) - => Dynamic t (Int -> Int) - -- ^ Function used to determine size of first pane based on available size - -> Dynamic t (Bool, Bool) - -- ^ How to focus the two sub-panes, given that we are focused. - -> m a - -- ^ Widget for first pane - -> m b - -- ^ Widget for second pane - -> m (a,b) +splitV + :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) + => Dynamic t (Int -> Int) + -- ^ Function used to determine size of first pane based on available size + -> Dynamic t (Bool, Bool) + -- ^ How to focus the two sub-panes, given that we are focused. + -> m a + -- ^ Widget for first pane + -> m b + -- ^ Widget for second pane + -> m (a, b) splitV sizeFunD focD wA wB = do - dw <- displayWidth - dh <- displayHeight + dw <- viewportWidth + dh <- viewportHeight let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh) regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA) ra <- pane regA (fst <$> focD) wA rb <- pane regB (snd <$> focD) wB - return (ra,rb) + return (ra, rb) -- | A plain split of the available space into horizontally stacked panes. -- No visual separator is built in here. -splitH :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) - => Dynamic t (Int -> Int) - -- ^ Function used to determine size of first pane based on available size - -> Dynamic t (Bool, Bool) - -- ^ How to focus the two sub-panes, given that we are focused. - -> m a - -- ^ Widget for first pane - -> m b - -- ^ Widget for second pane - -> m (a,b) +splitH + :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) + => Dynamic t (Int -> Int) + -- ^ Function used to determine size of first pane based on available size + -> Dynamic t (Bool, Bool) + -- ^ How to focus the two sub-panes, given that we are focused. + -> m a + -- ^ Widget for first pane + -> m b + -- ^ Widget for second pane + -> m (a, b) splitH sizeFunD focD wA wB = do - dw <- displayWidth - dh <- displayHeight + dw <- viewportWidth + dh <- viewportHeight let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB) diff --git a/src/Reflex/Vty/Widget/Text.hs b/src/Reflex/Vty/Widget/Text.hs --- a/src/Reflex/Vty/Widget/Text.hs +++ b/src/Reflex/Vty/Widget/Text.hs @@ -1,30 +1,32 @@ -{-| - Description: Text- and character-rendering widgets --} +-- | +-- Description: Text- and character-rendering widgets module Reflex.Vty.Widget.Text where import Control.Monad.Fix +import Control.Monad.IO.Class import Data.Default import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Zipper as TZ import qualified Graphics.Vty as V import Reflex + +import Data.Text.Zipper as TZ +import Reflex.Vty.Style (mergeAttr) import Reflex.Vty.Widget import Reflex.Vty.Widget.Scroll -- | Fill the background with a particular character. fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m () fill bc = do - dw <- displayWidth - dh <- displayHeight - bt <- theme + dw <- viewportWidth + dh <- viewportHeight + bt <- themeAttr let fillImg = (\attr w h c -> [V.charFill attr c w h]) - <$> bt - <*> current dw - <*> current dh - <*> bc + <$> bt + <*> current dw + <*> current dh + <*> bc tellImages fillImg -- | Configuration options for displaying "rich" text @@ -35,8 +37,6 @@ instance Reflex t => Default (RichTextConfig t) where def = RichTextConfig $ pure V.defAttr - --- TODO delete this and use new local theming -- | A widget that displays text with custom time-varying attributes richText :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) @@ -45,25 +45,54 @@ -> m () richText cfg t = do dw <- displayWidth - let img = (\w a s -> [wrapText w a s]) - <$> current dw - <*> _richTextConfig_attributes cfg - <*> t + bt <- themeAttr + let attrs = mergeAttr <$> bt <*> _richTextConfig_attributes cfg + img = + (\w a s -> [wrapTextImage TextAlignment_Left w a s]) + <$> current dw + <*> attrs + <*> t tellImages img - where - wrapText maxWidth attrs = V.vertCat - . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0) - . T.split (=='\n') -- | Renders text, wrapped to the container width text :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Text -> m () -text t = do - bt <- theme - richText (RichTextConfig bt) t +text = textWithAlignment TextAlignment_Left +-- | Like 'text' but with explicit 'TextAlignment'. The alignment is +-- applied to each logical line after wrapping; see +-- 'Data.Text.Zipper.wrapWithOffsetAndAlignment' for details. +textWithAlignment + :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) + => TextAlignment + -> Behavior t Text + -> m () +textWithAlignment alignment t = do + dw <- displayWidth + bt <- themeAttr + let img = + (\w a s -> [wrapTextImage alignment w a s]) + <$> current dw + <*> bt + <*> t + tellImages img + +-- | Pure helper: wrap a 'Text' to the given width with the given +-- 'TextAlignment' and render it as a single 'V.Image' using the supplied +-- 'V.Attr'. Newlines split logical lines; each logical line is wrapped and +-- aligned independently. +wrapTextImage :: TextAlignment -> Int -> V.Attr -> Text -> V.Image +wrapTextImage alignment maxWidth attrs = + V.vertCat + . concatMap (fmap (V.string attrs . T.unpack) . wrapLine) + . T.split (== '\n') + where + wrapLine = + map _wrappedLines_text + . wrapWithOffsetAndAlignment alignment maxWidth 0 + -- | Renders any behavior whose value can be converted to -- 'String' as text display @@ -75,7 +104,8 @@ -- | Scrollable text widget. The output exposes the current scroll position and -- total number of lines (including those that are hidden) scrollableText - :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m, PostBuild t m) + :: forall t m + . (Reflex t, MonadHold t m, MonadFix m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m, PostBuild t m) => ScrollableConfig t -> Dynamic t Text -> m (Scrollable t) diff --git a/test/Data/Text/ZipperSpec.hs b/test/Data/Text/ZipperSpec.hs --- a/test/Data/Text/ZipperSpec.hs +++ b/test/Data/Text/ZipperSpec.hs @@ -1,18 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.Text.ZipperSpec ( - spec -) where - -import Prelude - -import Test.Hspec +module Data.Text.ZipperSpec + ( spec + ) where -import qualified Data.Map as Map -import qualified Data.Text as T import Control.Monad +import qualified Data.Map as Map +import qualified Data.Text as T +import Test.Hspec +import Prelude -import Data.Text.Zipper +import Data.Text.Zipper someSentence :: T.Text someSentence = "12345 1234 12" @@ -26,112 +24,106 @@ spec :: Spec spec = describe "Zipper" $ do - it "wordsWithWhitespace" $ do - wordsWithWhitespace "" `shouldBe` [] - wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"] - wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"] - wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "] - it "splitWordsAtDisplayWidth" $ do - fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"] - fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"] - fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"] - fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"] - fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 "," 56"] - fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4","5 6 7 8", "9 1"] - it "wrapWithOffsetAndAlignment" $ do - wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] - wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)] - wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)] - wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] - - it "eolSpacesToLogicalLines" $ do - eolSpacesToLogicalLines - [ - [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ] - , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ] - ] - `shouldBe` - [ - [ ("😱",1) ] - , [ ("😱",2), ("😱",3) ] - , [ ("aa",1) ] - , [ ("aa",2) ] - , [ ("aa",3) ] - ] - it "offsetMapWithAlignmentInternal" $ do - offsetMapWithAlignmentInternal - [ - [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ] - , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ] - ] - `shouldBe` - Map.fromList - [ (0, (1,0)) - , (1, (2,2)) -- jump by 1 for char and 1 for space - , (2, (3,3)) -- jump by 1 for char - , (3, (1,5)) -- jump by 1 for char and 1 for newline - , (4, (2,8)) -- jump by 2 for char and 1 for space - , (5, (3,11)) -- jump by 2 for char and 1 for space - ] - it "displayLinesWithAlignment - spans" $ do - let - makespans = fmap (fmap (Span ())) - insertcharnewlinesentence = insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ fromText "" - cursorspan = [[Span () " "]] - -- newline cases - dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText newlineSentence) - dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\naoeu") - dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "\n\n\naoeu") - dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\n") - dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (empty) - - - insertcharnewlinesentence `shouldBe` fromText newlineSentence - - -- NOTE last " " is the generated cursor span char - _displayLines_spans dl0 `shouldBe` makespans [[""],[""],[""],[""],[""],[""]] - _displayLines_spans dl1 `shouldBe` makespans [["aoeu"],[""],[""],["aoeu", ""]] - _displayLines_spans dl2 `shouldBe` makespans [[""],[""],[""],["aoeu", ""]] - _displayLines_spans dl3 `shouldBe` makespans [["aoeu"],[""],[""],[""]] - _displayLines_spans dl4 `shouldBe` makespans [[""]] + it "wordsWithWhitespace" $ do + wordsWithWhitespace "" `shouldBe` [] + wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"] + wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ", "efgf ", "f"] + wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "] + it "splitWordsAtDisplayWidth" $ do + fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345", "6"] + fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345", "6"] + fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234", "56"] + fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345", "67891", "2345"] + fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 ", " 56"] + fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4", "5 6 7 8", "9 1"] + it "wrapWithOffsetAndAlignment" $ do + wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] + wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)] + wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)] + wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] - - it "displayLinesWithAlignment - cursor tag" $ do - let - dl0 = displayLinesWithAlignment TextAlignment_Right 10 0 1 (fromText "abc") - dl1 = displayLinesWithAlignment TextAlignment_Right 10 0 1 empty - _displayLines_spans dl0 `shouldBe` [[Span 0 "abc", Span 1 ""]] - _displayLines_spans dl1 `shouldBe` [[Span 1 ""]] + it "eolSpacesToLogicalLines" $ do + eolSpacesToLogicalLines + [ [(WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3)] + , [(WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3)] + ] + `shouldBe` [ [("😱", 1)] + , [("😱", 2), ("😱", 3)] + , [("aa", 1)] + , [("aa", 2)] + , [("aa", 3)] + ] + it "offsetMapWithAlignmentInternal" $ do + offsetMapWithAlignmentInternal + [ [(WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3)] + , [(WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3)] + ] + `shouldBe` Map.fromList + [ (0, (1, 0)) + , (1, (2, 2)) -- jump by 1 for char and 1 for space + , (2, (3, 3)) -- jump by 1 for char + , (3, (1, 5)) -- jump by 1 for char and 1 for newline + , (4, (2, 8)) -- jump by 2 for char and 1 for space + , (5, (3, 11)) -- jump by 2 for char and 1 for space + ] + it "displayLinesWithAlignment - spans" $ do + let makespans = fmap (fmap (Span ())) + insertcharnewlinesentence = insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ fromText "" + cursorspan = [[Span () " "]] + -- newline cases + dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText newlineSentence) + dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\naoeu") + dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "\n\n\naoeu") + dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\n") + dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (empty) + insertcharnewlinesentence `shouldBe` fromText newlineSentence + -- NOTE the trailing " " is the generated cursor cell: when the cursor + -- sits past the last character of its line, it is rendered as a blank + -- cell carrying the cursor tag so it stays visible. + _displayLines_spans dl0 `shouldBe` makespans [[""], [""], [""], [""], [""], [" "]] + _displayLines_spans dl1 `shouldBe` makespans [["aoeu"], [""], [""], ["aoeu", " "]] + _displayLines_spans dl2 `shouldBe` makespans [[""], [""], [""], ["aoeu", " "]] + _displayLines_spans dl3 `shouldBe` makespans [["aoeu"], [""], [""], [" "]] + _displayLines_spans dl4 `shouldBe` makespans [[" "]] + it "displayLinesWithAlignment - cursor tag" $ do + let dl0 = displayLinesWithAlignment TextAlignment_Right 10 0 1 (fromText "abc") + dl1 = displayLinesWithAlignment TextAlignment_Right 10 0 1 empty + -- cursor moved left into the text: it lands on a real character + dl2 = displayLinesWithAlignment TextAlignment_Right 10 0 1 (left (fromText "abc")) + -- cursor at end of text and on an empty line render a blank cursor cell + -- so the cursor remains visible (see Data.Text.Zipper cursorcell) + _displayLines_spans dl0 `shouldBe` [[Span 0 "abc", Span 1 " "]] + _displayLines_spans dl1 `shouldBe` [[Span 1 " "]] + -- when the cursor is over a character, that character carries the tag + _displayLines_spans dl2 `shouldBe` [[Span 0 "ab", Span 1 "c"]] - it "displayLines - cursorPos" $ do - let - dl0 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "") - dl1 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu") - dl2 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu\n") - dl3 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "0123456789") - dl4 = displayLinesWithAlignment TextAlignment_Left 10 () () (insertChar 'a' $ fromText "aoeu") - dl5 = displayLinesWithAlignment TextAlignment_Left 10 () () (left $ insertChar 'a' $ fromText "aoeu") - dl6 = displayLinesWithAlignment TextAlignment_Left 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu") - dl7 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "") + it "displayLines - cursorPos" $ do + let dl0 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "") + dl1 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu") + dl2 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu\n") + dl3 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "0123456789") + dl4 = displayLinesWithAlignment TextAlignment_Left 10 () () (insertChar 'a' $ fromText "aoeu") + dl5 = displayLinesWithAlignment TextAlignment_Left 10 () () (left $ insertChar 'a' $ fromText "aoeu") + dl6 = displayLinesWithAlignment TextAlignment_Left 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu") + dl7 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "") - _displayLines_cursorPos dl0 `shouldBe` (0,0) - _displayLines_cursorPos dl1 `shouldBe` (4,0) - _displayLines_cursorPos dl2 `shouldBe` (0,1) - _displayLines_cursorPos dl3 `shouldBe` (0,1) - _displayLines_cursorPos dl4 `shouldBe` (5,0) - _displayLines_cursorPos dl5 `shouldBe` (4,0) - _displayLines_cursorPos dl6 `shouldBe` (4,0) - _displayLines_cursorPos dl7 `shouldBe` (10,0) - it "displayLinesWithAlignment - spans" $ do - let - someText = top $ fromText "0123456789abcdefgh" - -- outer span length should be invariant when changing TextAlignment and CursorPosition - --print $ displayLinesWithAlignment TextAlignment_Left 5 () () someText - forM_ [0..4] $ \x -> do - forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do - let t = rightN x $ someText - length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4 - length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2 + _displayLines_cursorPos dl0 `shouldBe` (0, 0) + _displayLines_cursorPos dl1 `shouldBe` (4, 0) + _displayLines_cursorPos dl2 `shouldBe` (0, 1) + _displayLines_cursorPos dl3 `shouldBe` (0, 1) + _displayLines_cursorPos dl4 `shouldBe` (5, 0) + _displayLines_cursorPos dl5 `shouldBe` (4, 0) + _displayLines_cursorPos dl6 `shouldBe` (4, 0) + _displayLines_cursorPos dl7 `shouldBe` (10, 0) + it "displayLinesWithAlignment - spans" $ do + let someText = top $ fromText "0123456789abcdefgh" + -- outer span length should be invariant when changing TextAlignment and CursorPosition + -- print $ displayLinesWithAlignment TextAlignment_Left 5 () () someText + forM_ [0 .. 4] $ \x -> do + forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do + let t = rightN x $ someText + length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4 + length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2 diff --git a/test/Reflex/Vty/CanvasSpec.hs b/test/Reflex/Vty/CanvasSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/CanvasSpec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.CanvasSpec (spec) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Canvas + +spec :: Spec +spec = describe "Reflex.Vty.Canvas" $ do + let red = V.withForeColor V.defAttr (V.ISOColor 1) + blue = V.withForeColor V.defAttr (V.ISOColor 4) + fromList = Map.fromList :: [((Int, Int), (Char, V.Attr))] -> Map (Int, Int) (Char, V.Attr) + + describe "blankCanvas" $ do + it "creates a transparent canvas" $ do + let c = blankCanvas 5 3 + canvasWidth c `shouldBe` 5 + canvasHeight c `shouldBe` 3 + canvasCells c `shouldBe` mempty + + it "cellAt returns Nothing for blank" $ do + let c = blankCanvas 3 3 + canvasCellAt 1 1 c `shouldBe` Nothing + + describe "placeCanvas" $ do + it "overlays opaque cells" $ do + let dst = blankCanvas 5 3 + src = Canvas 2 1 (fromList [((0, 0), ('X', red))]) + result = placeCanvas 1 0 src dst + canvasCellAt 1 0 result `shouldBe` Just ('X', red) + + it "transparent source cells don't overwrite" $ do + let dst = Canvas 3 1 (fromList [((0, 0), ('A', blue))]) + src = blankCanvas 3 1 + result = placeCanvas 0 0 src dst + canvasCellAt 0 0 result `shouldBe` Just ('A', blue) + + it "clips cells outside destination bounds" $ do + let dst = blankCanvas 3 3 + src = Canvas 2 1 (fromList [((0, 0), ('X', red))]) + result = placeCanvas 5 5 src dst + canvasCells result `shouldBe` mempty + + describe "translate" $ do + it "shifts cells by offset" $ do + let c = Canvas 5 5 (fromList [((0, 0), ('X', red))]) + result = translate 2 3 c + canvasCellAt 2 3 result `shouldBe` Just ('X', red) + canvasCellAt 0 0 result `shouldBe` Nothing + + it "drops cells that move outside bounds" $ do + let c = Canvas 3 3 (fromList [((0, 0), ('X', red))]) + result = translate 5 0 c + canvasCells result `shouldBe` mempty + + describe "stack" $ do + it "later canvases overlay earlier ones" $ do + let bottom = Canvas 3 1 (fromList [((0, 0), ('A', red))]) + top = Canvas 3 1 (fromList [((0, 0), ('B', blue))]) + result = stack [bottom, top] + canvasCellAt 0 0 result `shouldBe` Just ('B', blue) + + it "transparent cells in top layer show bottom" $ do + let bottom = Canvas 3 1 (fromList [((0, 0), ('A', red))]) + top = Canvas 3 1 (fromList [((1, 0), ('B', blue))]) + result = stack [bottom, top] + canvasCellAt 0 0 result `shouldBe` Just ('A', red) + canvasCellAt 1 0 result `shouldBe` Just ('B', blue) + + it "empty list returns blank" $ do + let result = stack [] + canvasWidth result `shouldBe` 0 + + describe "imageToCanvas" $ do + it "converts plain text" $ do + let img = V.text' red "AB" + c = imageToCanvas img + canvasWidth c `shouldBe` 2 + canvasHeight c `shouldBe` 1 + canvasCellAt 0 0 c `shouldBe` Just ('A', red) + canvasCellAt 1 0 c `shouldBe` Just ('B', red) + + it "converts charFill" $ do + let img = V.charFill red 'X' 3 2 + c = imageToCanvas img + canvasWidth c `shouldBe` 3 + canvasHeight c `shouldBe` 2 + canvasCellAt 0 0 c `shouldBe` Just ('X', red) + canvasCellAt 2 1 c `shouldBe` Just ('X', red) + + describe "canvasToImage" $ do + it "round-trips through imageToCanvas for opaque content" $ do + let img = V.text' red "Hello" + c = imageToCanvas img + img' = canvasToImage c + V.imageWidth img' `shouldBe` 5 + V.imageHeight img' `shouldBe` 1 + + it "preserves dimensions for transparent canvas" $ do + let c = blankCanvas 4 2 + img = canvasToImage c + V.imageWidth img `shouldBe` 4 + V.imageHeight img `shouldBe` 2 diff --git a/test/Reflex/Vty/ColorProfileSpec.hs b/test/Reflex/Vty/ColorProfileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/ColorProfileSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.ColorProfileSpec (spec) where + +import qualified Graphics.Vty as V +import qualified Graphics.Vty.Attributes.Color as V.Color +import Test.Hspec + +import Reflex.Vty.ColorProfile + +spec :: Spec +spec = describe "Reflex.Vty.ColorProfile" $ do + describe "colorProfileFromColorMode" $ do + it "maps NoColor to Ascii" $ + colorProfileFromColorMode V.Color.NoColor `shouldBe` ColorProfile_Ascii + it "maps ColorMode8 to Ansi16" $ + colorProfileFromColorMode V.Color.ColorMode8 `shouldBe` ColorProfile_Ansi16 + it "maps ColorMode16 to Ansi16" $ + colorProfileFromColorMode V.Color.ColorMode16 `shouldBe` ColorProfile_Ansi16 + it "maps ColorMode240 to Ansi256" $ + colorProfileFromColorMode (V.Color.ColorMode240 0) `shouldBe` ColorProfile_Ansi256 + it "maps FullColor to TrueColor" $ + colorProfileFromColorMode V.Color.FullColor `shouldBe` ColorProfile_TrueColor + + describe "convertColor" $ do + it "is identity for TrueColor" $ + convertColor ColorProfile_TrueColor (V.Color.RGBColor 10 20 30) + `shouldBe` V.Color.RGBColor 10 20 30 + it "downsamples RGB to Color240 for Ansi256" $ + convertColor ColorProfile_Ansi256 (V.Color.RGBColor 10 20 30) + `shouldSatisfy` \case + V.Color.Color240 {} -> True + _ -> False + it "is identity for ISOColor under Ansi16" $ + convertColor ColorProfile_Ansi16 V.Color.red `shouldBe` V.Color.red + it "maps pure black RGB to the black ISO color under Ansi16" $ + convertColor ColorProfile_Ansi16 (V.Color.RGBColor 0 0 0) + `shouldBe` V.Color.black + it "maps pure white RGB to the white ISO color under Ansi16" $ + convertColor ColorProfile_Ansi16 (V.Color.RGBColor 255 255 255) + `shouldBe` V.Color.brightWhite + + describe "applyProfile" $ do + let redAttr = V.withForeColor V.defAttr V.Color.red + it "preserves the foreground color under TrueColor" $ do + V.attrForeColor (applyProfile ColorProfile_TrueColor redAttr) + `shouldBe` V.SetTo V.Color.red + it "resets the foreground to Default under Ascii" $ do + V.attrForeColor (applyProfile ColorProfile_Ascii redAttr) + `shouldBe` V.Default + it "resets foreground, background, and style to Default under NoTTY" $ do + let attr = V.withStyle (V.withForeColor (V.withBackColor V.defAttr V.Color.blue) V.Color.red) V.bold + applied = applyProfile ColorProfile_NoTTY attr + V.attrForeColor applied `shouldBe` V.Default + V.attrBackColor applied `shouldBe` V.Default + V.attrStyle applied `shouldBe` V.Default + it "preserves the URL field under NoTTY" $ do + let attr = V.withURL V.defAttr "https://example.com" + V.attrURL (applyProfile ColorProfile_NoTTY attr) + `shouldBe` V.SetTo "https://example.com" diff --git a/test/Reflex/Vty/ColorSpec.hs b/test/Reflex/Vty/ColorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/ColorSpec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.ColorSpec (spec) where + +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Color + +spec :: Spec +spec = describe "Reflex.Vty.Color" $ do + let black = RGB 0 0 0 + white = RGB 255 255 255 + red = RGB 255 0 0 + blue = RGB 0 0 255 + + describe "toRGB / fromRGB" $ do + it "extracts RGB from RGBColor" $ do + toRGB (V.RGBColor 10 20 30) `shouldBe` Just (RGB 10 20 30) + it "returns Nothing for ISOColor" $ do + toRGB (V.ISOColor 1) `shouldBe` Nothing + it "returns Nothing for Color240" $ do + toRGB (V.Color240 100) `shouldBe` Nothing + it "round-trips RGB through fromRGB . toRGB" $ do + fromRGB red `shouldBe` V.RGBColor 255 0 0 + + describe "darken" $ do + it "black at 0.0 stays black" $ do + darken 0.0 white `shouldBe` black + it "white at 1.0 stays white" $ do + darken 1.0 white `shouldBe` white + it "halves all channels" $ do + darken 0.5 (RGB 200 100 50) `shouldBe` RGB 100 50 25 + + describe "lighten" $ do + it "black at 0.0 stays black" $ do + lighten 0.0 black `shouldBe` black + it "black at 1.0 becomes white" $ do + lighten 1.0 black `shouldBe` white + it "lightens by half towards white" $ do + lighten 0.5 (RGB 0 0 0) `shouldBe` RGB 128 128 128 + + describe "complementary" $ do + it "inverts all channels" $ do + complementary (RGB 100 200 50) `shouldBe` RGB 155 55 205 + it "complement of black is white" $ do + complementary black `shouldBe` white + + describe "mix" $ do + it "at 0.0 returns first color" $ do + mix 0.0 red blue `shouldBe` red + it "at 1.0 returns second color" $ do + mix 1.0 red blue `shouldBe` blue + it "at 0.5 averages channels" $ do + mix 0.5 red blue `shouldBe` RGB 128 0 128 + + describe "alpha" $ do + it "at 0.0 returns background" $ do + alpha 0.0 red blue `shouldBe` blue + it "at 1.0 returns foreground" $ do + alpha 1.0 red blue `shouldBe` red + + describe "Gradient1D" $ do + let grad = gradient1D [(0.0, black), (1.0, white)] + it "samples first stop at 0.0" $ do + sampleGradient1D grad 0.0 `shouldBe` black + it "samples last stop at 1.0" $ do + sampleGradient1D grad 1.0 `shouldBe` white + it "interpolates at 0.5" $ do + sampleGradient1D grad 0.5 `shouldBe` RGB 128 128 128 + it "clamps below 0.0 to first stop" $ do + sampleGradient1D grad (-0.5) `shouldBe` black + it "clamps above 1.0 to last stop" $ do + sampleGradient1D grad 1.5 `shouldBe` white + + it "handles three stops with correct interpolation" $ do + let grad3 = gradient1D [(0.0, red), (0.5, white), (1.0, blue)] + sampleGradient1D grad3 0.25 `shouldBe` RGB 255 128 128 + sampleGradient1D grad3 0.75 `shouldBe` RGB 128 128 255 + + it "returns black for empty gradient" $ do + sampleGradient1D (gradient1D []) 0.5 `shouldBe` black + + describe "Gradient2D" $ do + let g2 = gradient2D black white red blue + it "samples corners exactly" $ do + sampleGradient2D g2 0 0 `shouldBe` black + sampleGradient2D g2 1 0 `shouldBe` white + sampleGradient2D g2 0 1 `shouldBe` red + sampleGradient2D g2 1 1 `shouldBe` blue + it "interpolates center" $ do + sampleGradient2D g2 0.5 0.5 `shouldBe` RGB 128 64 128 diff --git a/test/Reflex/Vty/HostSpec.hs b/test/Reflex/Vty/HostSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/HostSpec.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Description: Host event-channel regression + backpressure tests. +module Reflex.Vty.HostSpec (spec) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad (forever, replicateM_, void) +import Control.Monad.IO.Class (liftIO) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import qualified Graphics.Vty as V +import Graphics.Vty.Attributes.Color (ColorMode (..)) +import Reflex +import System.Timeout (timeout) +import Test.Hspec + +import Reflex.Vty.Host + ( VtyApp + , VtyResult (..) + , defaultVtyAppConfig + , runVtyAppWithHandle + ) + +---------------------------------------------------------------------------- +-- Constants +---------------------------------------------------------------------------- + +-- | Burst size for the regression test: large enough that the old +-- one-batch-per-frame host loop would not reach the shutdown request within +-- 'shutdownTimeout' (it would need one redraw per item). +burstN :: Int +burstN = 10000 + +-- | Burst size for the occurrence-preservation test. Deliberately far larger +-- than the default queue capacity (4096) so that backpressure provably engages +-- and the producer is throttled rather than able to dump everything at once. +overloadN :: Int +overloadN = 50000 + +-- | Time the host is allowed to take. The fixed host drains the whole burst in +-- a single frame, so this is ample; the old host (one batch per frame) would +-- need @burstN * redrawDelay@ microseconds and time out. +shutdownTimeout :: Int +shutdownTimeout = 6 * 1000000 + +-- | Generous timeout for the occurrence-preservation test: under backpressure +-- the producer is throttled to the host's processing rate, so @overloadN@ +-- ticks take a little while to drain. +overloadTimeout :: Int +overloadTimeout = 30 * 1000000 + +-- | Per-redraw delay modelled by the mock vty. Simulates the cost of a real +-- 'V.update'. +redrawDelay :: Int +redrawDelay = 2000 + +spec :: Spec +spec = describe "Reflex.Vty.Host" $ do + describe "runVtyAppWithHandle" $ do + it "drains a burst of external triggers each frame and does not leak (regression)" $ do + vty <- mockVty (\_ -> threadDelay redrawDelay) + result <- timeout shutdownTimeout $ runVtyAppWithHandle defaultVtyAppConfig vty guest + -- The host must shut down within the timeout. With the old loop it would + -- stall behind @burstN@ backlogged batches (one redraw each) and time out. + result `shouldBe` Just () + + it "preserves every occurrence of an overloaded external trigger (backpressure)" $ do + -- A producer firing faster than the host can process must be backpressured + -- (no dropped occurrences) rather than allowed to exhaust memory. + counter <- newIORef (0 :: Int) + vty <- mockVty (\_ -> threadDelay redrawDelay) + result <- timeout overloadTimeout $ runVtyAppWithHandle defaultVtyAppConfig vty (countingGuest counter) + result `shouldBe` Just () + final <- readIORef counter + -- Every one of the @overloadN@ ticks must be counted: backpressure throttles + -- the producer but never drops an occurrence. + final `shouldBe` overloadN + +---------------------------------------------------------------------------- +-- Guests +---------------------------------------------------------------------------- + +-- | Fires a burst of events into the FRP network (exactly the pattern that +-- backed up the host's event channel) and then requests shutdown. Both the +-- ticks and the shutdown request travel through the same 'TriggerEvent' +-- channel, so the only way the host reaches shutdown promptly is by draining +-- the whole channel each frame. +guest :: VtyApp t m +guest _region _input _sigs = do + setupE <- getPostBuild + (tickE, fireTick) <- newTriggerEvent + (shutdownE, fireShutdown) <- newTriggerEvent + -- Subscribe to the ticks so each occurrence does real work in the network. + _d <- holdDyn (0 :: Int) tickE + performEvent_ $ + ffor setupE $ \() -> + liftIO $ + void $ + forkIO $ do + replicateM_ burstN (fireTick (0 :: Int)) + fireShutdown () + return $ + VtyResult + { _vtyResult_picture = pure (V.picForImage V.emptyImage) + , _vtyResult_shutdown = shutdownE + } + +-- | Like 'guest' but increments an 'IORef' on every tick occurrence, so the +-- test can assert that no occurrences were dropped under backpressure. +countingGuest :: IORef Int -> (forall t m. VtyApp t m) +countingGuest counter _region _input _sigs = do + setupE <- getPostBuild + (tickE, fireTick) <- newTriggerEvent + (shutdownE, fireShutdown) <- newTriggerEvent + performEvent_ $ ffor tickE $ \_ -> liftIO $ modifyIORef' counter (+ 1) + performEvent_ $ + ffor setupE $ \() -> + liftIO $ + void $ + forkIO $ do + replicateM_ overloadN (fireTick (0 :: Int)) + fireShutdown () + return $ + VtyResult + { _vtyResult_picture = pure (V.picForImage V.emptyImage) + , _vtyResult_shutdown = shutdownE + } + +---------------------------------------------------------------------------- +-- Mock vty (no real terminal) +---------------------------------------------------------------------------- + +-- | A 'V.Vty' whose 'update' action runs the given @IO@ (to model redraw +-- cost) and whose 'nextEvent' blocks forever; the network is driven entirely +-- via 'TriggerEvent'. Only the fields the host actually touches are real; +-- the rest are never forced (the mock's @update@ never dereferences the +-- unused 'V.Output' fields). +mockVty :: (V.Picture -> IO ()) -> IO V.Vty +mockVty updateAction = do + out <- mockOutput + pure + V.Vty + { V.update = updateAction + , V.nextEvent = forever (threadDelay 1000000) + , V.nextEventNonblocking = pure Nothing + , V.inputIface = mockInput + , V.outputIface = out + , V.refresh = pure () + , V.shutdown = pure () + , V.isShutdown = pure False + } + +mockInput :: V.Input +mockInput = + V.Input + { V.eventChannel = error "mockInput: eventChannel unused" + , V.shutdownInput = pure () + , V.restoreInputState = pure () + , V.inputLogMsg = \_ -> pure () + } + +mockOutput :: IO V.Output +mockOutput = + pure + V.Output + { V.terminalID = "mock" + , V.releaseTerminal = pure () + , V.reserveDisplay = pure () + , V.releaseDisplay = pure () + , V.setDisplayBounds = \_ -> pure () + , V.displayBounds = pure (80, 24) + , V.outputByteBuffer = \_ -> pure () + , V.supportsCursorVisibility = True + , V.supportsMode = const False + , V.setMode = \_ _ -> pure () + , V.getModeStatus = \_ -> pure False + , V.assumedStateRef = error "mockOutput: assumedStateRef unused" + , V.mkDisplayContext = \_ _ -> error "mockOutput: mkDisplayContext unused" + , V.ringTerminalBell = pure () + , V.supportsBell = pure True + , V.supportsItalics = pure True + , V.supportsStrikethrough = pure True + , V.outputColorMode = FullColor + , V.setOutputWindowTitle = \_ -> pure () + } diff --git a/test/Reflex/Vty/StyleJoinSpec.hs b/test/Reflex/Vty/StyleJoinSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/StyleJoinSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.StyleJoinSpec (spec) where + +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Style + +spec :: Spec +spec = describe "Image composition" $ do + let imgA = V.text' V.defAttr "AB" + imgB = V.text' V.defAttr "XYZ" + + describe "joinHorizontal" $ do + it "concatenates images side by side" $ do + let result = joinHorizontal VAlignTop [imgA, imgB] + V.imageWidth result `shouldBe` 5 + + it "returns empty for empty list" $ do + V.imageWidth (joinHorizontal VAlignTop []) `shouldBe` 0 + + it "pads shorter images to match tallest" $ do + let tall = V.charFill V.defAttr 'X' 2 3 + short = V.text' V.defAttr "AB" + result = joinHorizontal VAlignTop [short, tall] + V.imageHeight result `shouldBe` 3 + + it "top-aligns (shorter gets bottom padding)" $ do + let tall = V.charFill V.defAttr 'X' 2 3 + short = V.text' V.defAttr "AB" + result = joinHorizontal VAlignTop [short, tall] + V.imageHeight result `shouldBe` 3 + + it "bottom-aligns (shorter gets top padding)" $ do + let tall = V.charFill V.defAttr 'X' 2 3 + short = V.text' V.defAttr "AB" + result = joinHorizontal VAlignBottom [short, tall] + V.imageHeight result `shouldBe` 3 + + describe "joinVertical" $ do + it "stacks images vertically" $ do + let result = joinVertical HAlignLeft [imgA, imgB] + V.imageHeight result `shouldBe` 2 + + it "returns empty for empty list" $ do + V.imageHeight (joinVertical HAlignLeft []) `shouldBe` 0 + + it "pads narrower images to match widest" $ do + let wide = V.charFill V.defAttr 'X' 5 1 + narrow = V.text' V.defAttr "AB" + result = joinVertical HAlignLeft [narrow, wide] + V.imageWidth result `shouldBe` 5 + + describe "placeHorizontal" $ do + it "left-aligns within target width" $ do + let result = placeHorizontal HAlignLeft 5 imgA + V.imageWidth result `shouldBe` 5 + + it "right-aligns within target width" $ do + let result = placeHorizontal HAlignRight 5 imgA + V.imageWidth result `shouldBe` 5 + + it "center-aligns within target width" $ do + let result = placeHorizontal HAlignCenter 6 imgA + V.imageWidth result `shouldBe` 6 + + it "returns image as-is when already at target width" $ do + let result = placeHorizontal HAlignLeft 2 imgA + V.imageWidth result `shouldBe` 2 + + describe "placeVertical" $ do + it "top-aligns within target height" $ do + let result = placeVertical VAlignTop 3 imgA + V.imageHeight result `shouldBe` 3 + + it "bottom-aligns within target height" $ do + let result = placeVertical VAlignBottom 3 imgA + V.imageHeight result `shouldBe` 3 + + describe "place" $ do + it "places within both dimensions" $ do + let result = place HAlignCenter VAlignMiddle 6 3 imgA + V.imageWidth result `shouldBe` 6 + V.imageHeight result `shouldBe` 3 diff --git a/test/Reflex/Vty/StyleSpec.hs b/test/Reflex/Vty/StyleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/StyleSpec.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.StyleSpec (spec) where + +import Data.Maybe (isJust) +import qualified Data.Text as T +import qualified Graphics.Vty as V +import qualified Graphics.Vty.Attributes.Color as V.Color +import qualified Graphics.Vty.Image as V.Image +import Test.Hspec + +import Reflex.Vty.Style + +spec :: Spec +spec = describe "Reflex.Vty.Style" $ do + describe "def" $ do + it "has no foreground" $ + _style_foreground def `shouldBe` Nothing + it "has no border" $ + _style_border def `shouldBe` Nothing + it "has zero padding" $ + _style_padding def `shouldBe` Padding 0 0 0 0 + it "has zero margin" $ + _style_margin def `shouldBe` Margin 0 0 0 0 + + describe "per-side setters" $ do + it "withPaddingTop sets only top" $ do + let s = withPaddingTop 3 def + _padding_top (_style_padding s) `shouldBe` 3 + _padding_right (_style_padding s) `shouldBe` 0 + it "withPaddingRight sets only right" $ do + let s = withPaddingRight 2 def + _padding_right (_style_padding s) `shouldBe` 2 + _padding_top (_style_padding s) `shouldBe` 0 + it "withPaddingBottom sets only bottom" $ do + let s = withPaddingBottom 4 def + _padding_bottom (_style_padding s) `shouldBe` 4 + it "withPaddingLeft sets only left" $ do + let s = withPaddingLeft 1 def + _padding_left (_style_padding s) `shouldBe` 1 + it "withMarginTop sets only top" $ do + let s = withMarginTop 2 def + _margin_top (_style_margin s) `shouldBe` 2 + _margin_right (_style_margin s) `shouldBe` 0 + it "withMarginLeft sets only left" $ do + let s = withMarginLeft 3 def + _margin_left (_style_margin s) `shouldBe` 3 + it "withBorderTop enables only top toggle" $ do + let s = withBorderTop True def + _style_borderTop s `shouldBe` Just True + _style_borderBottom s `shouldBe` Nothing + it "withBorderForeground sets border color" $ do + let s = withBorderForeground red def + _style_borderForeground s `shouldBe` Just red + it "withBorderBackground sets border bg" $ do + let s = withBorderBackground blue def + _style_borderBackground s `shouldBe` Just blue + + describe "inherit" $ do + let parent = withForeground red . withBold . withWidth 10 $ def + it "keeps the child's foreground when set" $ do + let child = withForeground blue def + _style_foreground (inherit parent child) `shouldBe` Just blue + it "inherits the parent's foreground when the child's is Nothing" $ do + let child = def + _style_foreground (inherit parent child) `shouldBe` Just red + it "keeps the child's width when set" $ do + let child = withWidth 5 def + _style_width (inherit parent child) `shouldBe` Just 5 + it "inherits the parent's width when the child's is Nothing" $ do + let child = def + _style_width (inherit parent child) `shouldBe` Just 10 + it "inherits the parent's bold flag when the child's is Nothing" $ do + let child = def + _style_bold (inherit parent child) `shouldBe` Just True + + describe "applyAttr" $ do + it "applies the foreground color" $ do + let s = withForeground red def + V.attrForeColor (applyAttr s V.defAttr) `shouldBe` V.SetTo red + it "applies the background color" $ do + let s = withBackground blue def + V.attrBackColor (applyAttr s V.defAttr) `shouldBe` V.SetTo blue + it "applies bold when Just True" $ do + let s = withBold def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.bold `shouldBe` True + it "does not apply bold when Nothing" $ do + V.hasStyle (V.styleMask (applyAttr def V.defAttr)) V.bold `shouldBe` False + it "applies underline for UnderlineSingle" $ do + let s = withUnderline UnderlineSingle def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.underline `shouldBe` True + it "does not apply underline for UnderlineNone" $ do + let s = withUnderline UnderlineNone def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.underline `shouldBe` False + it "applies italic" $ do + let s = withItalic def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.italic `shouldBe` True + it "applies faint (dim)" $ do + let s = withFaint def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.dim `shouldBe` True + it "applies blink" $ do + let s = withBlink def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.blink `shouldBe` True + it "applies strikethrough" $ do + let s = withStrikethrough def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.strikethrough `shouldBe` True + it "applies reverse video" $ do + let s = withReverse def + V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.reverseVideo `shouldBe` True + it "applies the hyperlink URL" $ do + let s = withHyperlink "https://example.com" def + V.attrURL (applyAttr s V.defAttr) `shouldBe` V.SetTo "https://example.com" + it "leaves the base attr unchanged for def" $ do + applyAttr def V.defAttr `shouldBe` V.defAttr + + describe "mergeAttr" $ do + let base = V.defAttr `V.withForeColor` red `V.withBackColor` blue + it "uses overlay's SetTo fields over the base" $ do + let overlay = V.defAttr `V.withForeColor` green + result = mergeAttr base overlay + V.attrForeColor result `shouldBe` V.SetTo green + V.attrBackColor result `shouldBe` V.SetTo blue + it "falls through to base when overlay is Default" $ do + let overlay = V.defAttr + result = mergeAttr base overlay + V.attrForeColor result `shouldBe` V.SetTo red + V.attrBackColor result `shouldBe` V.SetTo blue + it "falls through to base when overlay is KeepCurrent" $ do + let overlay = V.Attr {V.attrStyle = V.KeepCurrent, V.attrForeColor = V.KeepCurrent, V.attrBackColor = V.KeepCurrent, V.attrURL = V.KeepCurrent} + result = mergeAttr base overlay + V.attrForeColor result `shouldBe` V.SetTo red + + describe "border style presets" $ do + it "singleBorder has all sides and corners" $ do + all + (isJust . ($ singleBorder)) + [ _border_top + , _border_bottom + , _border_left + , _border_right + , _border_topLeft + , _border_topRight + , _border_bottomLeft + , _border_bottomRight + ] + `shouldBe` True + it "noBorder has no sides or corners" $ do + any + (isJust . ($ noBorder)) + [ _border_top + , _border_bottom + , _border_left + , _border_right + , _border_topLeft + , _border_topRight + , _border_bottomLeft + , _border_bottomRight + ] + `shouldBe` False + it "markdownBorder has sides but no corners" $ do + let b = markdownBorder + _border_top b `shouldSatisfy` isJust + _border_topLeft b `shouldBe` Nothing + it "roundedBorder has all sides and corners" $ do + all + (isJust . ($ roundedBorder)) + [ _border_top + , _border_bottom + , _border_left + , _border_right + , _border_topLeft + , _border_topRight + , _border_bottomLeft + , _border_bottomRight + ] + `shouldBe` True + it "thickBorder has all sides and corners" $ do + all + (isJust . ($ thickBorder)) + [ _border_top + , _border_bottom + , _border_left + , _border_right + , _border_topLeft + , _border_topRight + , _border_bottomLeft + , _border_bottomRight + ] + `shouldBe` True + it "doubleBorder has all sides and corners" $ do + all + (isJust . ($ doubleBorder)) + [ _border_top + , _border_bottom + , _border_left + , _border_right + , _border_topLeft + , _border_topRight + , _border_bottomLeft + , _border_bottomRight + ] + `shouldBe` True + it "asciiBorder uses ASCII characters" $ do + _border_top asciiBorder `shouldBe` Just '-' + _border_left asciiBorder `shouldBe` Just '|' + _border_topLeft asciiBorder `shouldBe` Just '+' + + describe "render" $ do + it "produces a non-empty image for plain text" $ do + let img = render def "hello" + V.Image.imageWidth img `shouldSatisfy` (> 0) + V.Image.imageHeight img `shouldBe` 1 + it "respects withWidth by padding" $ do + let img = render (withWidth 10 def) "hi" + V.Image.imageWidth img `shouldBe` 10 + it "respects withHeight by padding" $ do + let img = render (withHeight 3 def) "hi" + V.Image.imageHeight img `shouldBe` 3 + it "respects withMaxWidth by clipping" $ do + let img = render (withMaxWidth 3 def) "hello" + V.Image.imageWidth img `shouldBe` 3 + it "respects withMaxHeight by clipping" $ do + let img = render (withMaxHeight 1 def) "hello" + V.Image.imageHeight img `shouldBe` 1 + it "adds padding around content" $ do + let s = withPadding 1 1 1 1 def + img = render s "hi" + V.Image.imageWidth img `shouldBe` 4 + V.Image.imageHeight img `shouldBe` 3 + it "adds a border around content" $ do + let s = withBorder singleBorder def + img = render s "hi" + V.Image.imageWidth img `shouldBe` 4 + V.Image.imageHeight img `shouldBe` 3 + it "adds margin outside content" $ do + let s = withMargin 1 1 1 1 def + img = render s "hi" + V.Image.imageWidth img `shouldBe` 4 + V.Image.imageHeight img `shouldBe` 3 + it "renders multi-line text with correct height" $ do + let img = render def "hello\nworld" + V.Image.imageHeight img `shouldBe` 2 + it "renders multi-line text width as longest line" $ do + let img = render def "hello\nhi" + V.Image.imageWidth img `shouldBe` 5 + it "renders wide characters at correct width" $ do + let img = render def "文" + V.Image.imageWidth img `shouldBe` 2 + + describe "measure" $ do + it "matches render's width for plain text" $ do + let s = def + fst (measure s "hello") `shouldBe` V.Image.imageWidth (render s "hello") + it "accounts for padding" $ do + let s = withPadding 2 3 2 3 def + fst (measure s "hi") `shouldBe` 2 + 3 + 3 + it "accounts for border" $ do + let s = withBorder singleBorder def + fst (measure s "hi") `shouldBe` 2 + 2 + it "accounts for margin" $ do + let s = withMargin 1 1 1 1 def + fst (measure s "hi") `shouldBe` 2 + 2 + it "measures multi-line text with correct height" $ do + snd (measure def "hello\nworld") `shouldBe` 2 + it "measures multi-line text with correct width" $ do + fst (measure def "hello\nhi") `shouldBe` 5 + it "measures multi-line text with matching render dimensions" $ do + let s = withBorder singleBorder def + (w, h) = measure s "hello\nworld" + img = render s "hello\nworld" + w `shouldBe` V.Image.imageWidth img + h `shouldBe` V.Image.imageHeight img + it "measures wide characters at display width" $ do + fst (measure def "文") `shouldBe` 2 + it "measures mixed wide and narrow characters" $ do + fst (measure def "a文b") `shouldBe` 4 + it "measures empty content as zero width, one line" $ do + measure def "" `shouldBe` (0, 1) + + describe "withTransform" $ do + it "applies transform before rendering" $ do + let img = render (withTransform T.toUpper def) "hello" + V.Image.imageWidth img `shouldBe` 5 + + it "renders transformed text" $ do + let img = render (withTransform (T.replace "a" "AA") def) "cat" + V.Image.imageWidth img `shouldBe` 4 + + describe "withTabWidth" $ do + it "expands tabs to spaces" $ do + let img = render (withTabWidth 4 def) "a\tb" + V.Image.imageWidth img `shouldBe` 6 + + it "does not expand tabs when not set" $ do + let img = render def "a\tb" + V.Image.imageWidth img `shouldSatisfy` (< 6) + + describe "withMarginBackground" $ do + it "produces correct dimensions with margin background" $ do + let s = withMarginBackground red . withMargin 1 1 1 1 $ def + (w, h) = measure s "hi" + w `shouldBe` 4 + h `shouldBe` 3 + + describe "new border presets" $ do + it "innerHalfBorder has all sides" $ do + _border_top innerHalfBorder `shouldBe` Just '▀' + _border_left innerHalfBorder `shouldBe` Just '▌' + it "outerHalfBlockBorder has all sides" $ do + _border_top outerHalfBlockBorder `shouldBe` Just '▔' + _border_left outerHalfBlockBorder `shouldBe` Just '▏' + it "renders innerHalfBorder" $ do + let img = render (withBorder innerHalfBorder def) "X" + V.Image.imageWidth img `shouldBe` 3 + V.Image.imageHeight img `shouldBe` 3 diff --git a/test/Reflex/Vty/Test/GoldenSpec.hs b/test/Reflex/Vty/Test/GoldenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Test/GoldenSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.Test.GoldenSpec (spec) where + +import Test.Hspec + +import Reflex.Vty.Style +import Reflex.Vty.Test.Snapshot + +spec :: Spec +spec = describe "Golden snapshots" $ do + -- Borders + golden "border_single" $ render (withBorder singleBorder def) "Box" + golden "border_rounded" $ render (withBorder roundedBorder def) "Box" + golden "border_thick" $ render (withBorder thickBorder def) "Box" + golden "border_double" $ render (withBorder doubleBorder def) "Box" + golden "border_ascii" $ render (withBorder asciiBorder def) "Box" + + -- Padding & Margin + golden "padding_1" $ render (withPadding 1 1 1 1 def) "pad" + golden "padding_2" $ render (withPadding 2 2 2 2 def) "pad" + golden "margin_1" $ render (withMargin 1 1 1 1 def) "m" + + -- Colors + golden "color_red_fg" $ render (withForeground red def) "Red" + golden "color_blue_bg" $ render (withBackground blue def) "Blue" + golden "color_rgb" $ render (withForeground (rgbColor 200 100 50) def) "RGB" + + -- Transforms + golden "transform_bold" $ render (withBold def) "Bold" + golden "transform_italic" $ render (withItalic def) "Italic" + golden "transform_underline" $ render (withUnderline UnderlineSingle def) "UL" + golden "transform_reverse" $ render (withReverse def) "Rev" + + -- Alignment + golden "align_left" $ render (withAlignH HAlignLeft . withWidth 20 $ def) "Left" + golden "align_center" $ render (withAlignH HAlignCenter . withWidth 20 $ def) "Center" + golden "align_right" $ render (withAlignH HAlignRight . withWidth 20 $ def) "Right" + + -- Combined + golden "combined" $ + render + ( withBorder roundedBorder + . withPadding 1 2 1 2 + . withForeground brightGreen + . withBorderForeground brightMagenta + $ def + ) + "Combined" + + -- Multi-line + golden "multiline" $ render def "Hello\nWorld" + + -- Wide chars + golden "wide_chars" $ render def "a文b" + + -- Plain text (baseline) + golden "plain" $ render def "hello" + where + golden name img = + it name $ + assertGolden name $ + renderGrid $ + imageToGrid img diff --git a/test/Reflex/Vty/Test/Snapshot.hs b/test/Reflex/Vty/Test/Snapshot.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Test/Snapshot.hs @@ -0,0 +1,265 @@ +-- | +-- Description: Rendering snapshot harness for testing vty Image output +-- +-- Converts a 'V.Image' into a 2D grid of cells, each carrying the display +-- character and its 'V.Attr'. This lets tests assert on rendered output +-- without a real terminal — useful for golden-file comparison and precise +-- cell-level checks. +-- +-- Golden file format (produced by 'renderGrid'): +-- +-- > 4x3 +-- > ┌──┐ +-- > │hi│ +-- > └──┘ +-- > --- attrs --- +-- > 1,1 'h' fg=red style=bold +-- +-- The text grid is always shown. The @--- attrs ---@ section appears only +-- when at least one cell has an explicit ('SetTo') attribute, keeping +-- goldens clean for unstyled output. +module Reflex.Vty.Test.Snapshot + ( Cell (..) + , Grid + , imageToGrid + , imageText + , renderGrid + , gridEquals + , assertGolden + ) where + +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as TL +import Graphics.Text.Width (wcwidth) +import qualified Graphics.Vty as V +import Graphics.Vty.Image.Internal (Image (BGFill, Crop, EmptyImage, HorizJoin, HorizText, VertJoin)) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath ((<.>), ()) +import Test.Hspec (Expectation, shouldBe) + +-- | A single rendered cell: the display character and its vty attribute. +data Cell = Cell + { cellChar :: !Char + , cellAttr :: !V.Attr + } + deriving (Eq, Show) + +-- | A grid is a list of rows (top-to-bottom), each a list of cells (left-to-right). +type Grid = [[Cell]] + +-- | Render a vty 'Image' to a 'Grid'. The grid dimensions match +-- 'V.imageWidth' × 'V.imageHeight'. Any cell not explicitly written by +-- the image (e.g. gaps in a sparse layout) defaults to a space with +-- 'V.defAttr'. +imageToGrid :: Image -> Grid +imageToGrid img = + let w = V.imageWidth img + h = V.imageHeight img + cells = walkImage img 0 0 Map.empty + in [ [ Map.findWithDefault blankCell (x, y) cells + | x <- [0 .. max 0 (w - 1)] + ] + | y <- [0 .. max 0 (h - 1)] + ] + where + blankCell = Cell ' ' V.defAttr + +-- | Extract just the visible text from an image, one string per row. +-- Useful for quick visual inspection in test failures. +imageText :: Image -> [String] +imageText img = map (map cellChar) (imageToGrid img) + +-- | Pretty-print a grid for debugging or golden-file comparison. +-- Format: +-- +-- @ +-- x +-- +-- --- attrs --- -- only if any cell has explicit attrs +-- , '' +-- @ +-- +-- Only cells with at least one 'V.SetTo' attribute appear in the attrs +-- section. Cells with pure 'V.Default' or 'V.KeepCurrent' attrs are +-- omitted, keeping goldens clean for unstyled output. +renderGrid :: Grid -> String +renderGrid grid = + unlines (header : textRows) ++ attrsSection + where + h = length grid + w = case grid of + [] -> 0 + r : _ -> length r + header = show w ++ "x" ++ show h + textRows = map (map cellChar) grid + explicitCells = + [ (row, col, c) + | (row, line) <- zip [0 ..] grid + , (col, c) <- zip [0 ..] line + , hasExplicitAttr (cellAttr c) + ] + attrsSection + | null explicitCells = "" + | otherwise = + unlines $ + "--- attrs ---" + : [ show row ++ "," ++ show col ++ " '" ++ [cellChar c] ++ "' " ++ showAttr (cellAttr c) + | (row, col, c) <- explicitCells + ] + +-- | True if any field of the attr is 'V.SetTo' (i.e. explicitly set). +hasExplicitAttr :: V.Attr -> Bool +hasExplicitAttr a = + isSetTo (V.attrStyle a) + || isSetTo (V.attrForeColor a) + || isSetTo (V.attrBackColor a) + || isSetTo (V.attrURL a) + where + isSetTo (V.SetTo _) = True + isSetTo _ = False + +-- | Check whether two grids are equal. Returns 'Nothing' if they match, +-- or a description of the first differing cell. +gridEquals :: Grid -> Grid -> Maybe String +gridEquals a b + | length a /= length b = Just $ "row count: " ++ show (length a) ++ " vs " ++ show (length b) + | otherwise = go 0 a b + where + go _ [] [] = Nothing + go row (ra : ras) (rb : rbs) + | length ra /= length rb = + Just $ "row " ++ show row ++ " width: " ++ show (length ra) ++ " vs " ++ show (length rb) + | otherwise = + case findCellDiff row 0 ra rb of + Just d -> Just d + Nothing -> go (row + 1) ras rbs + findCellDiff _ _ [] [] = Nothing + findCellDiff row col (ca : cas) (cb : cbs) + | ca /= cb = + Just $ + "cell (" + ++ show (row, col) + ++ "): '" + ++ [cellChar ca] + ++ "' " + ++ showAttr (cellAttr ca) + ++ " vs '" + ++ [cellChar cb] + ++ "' " + ++ showAttr (cellAttr cb) + | otherwise = findCellDiff row (col + 1) cas cbs + +---------------------------------------------------------------------------- +-- Internal: tree walker +---------------------------------------------------------------------------- + +type CellMap = Map (Int, Int) Cell + +walkImage :: Image -> Int -> Int -> CellMap -> CellMap +walkImage img x y acc = + case img of + HorizText attr displayText _ _ -> + let chars = TL.unpack displayText + in placeText attr chars x y acc + HorizJoin partLeft partRight _ _ -> + let acc' = walkImage partLeft x y acc + in walkImage partRight (x + V.imageWidth partLeft) y acc' + VertJoin partTop partBottom _ _ -> + let acc' = walkImage partTop x y acc + in walkImage partBottom x (y + V.imageHeight partTop) acc' + BGFill outputWidth outputHeight -> + foldl' + (\m (dx, dy) -> Map.insertWith (\_ old -> old) (x + dx, y + dy) blank m) + acc + [ (dx, dy) + | dx <- [0 .. outputWidth - 1] + , dy <- [0 .. outputHeight - 1] + ] + where + blank = Cell ' ' V.defAttr + Crop croppedImage leftSkip topSkip outputWidth outputHeight -> + let innerCells = walkImage croppedImage 0 0 Map.empty + visible = + [ ( (x + kx - leftSkip, y + ky - topSkip) + , cell + ) + | ((kx, ky), cell) <- Map.toList innerCells + , kx >= leftSkip + , kx < leftSkip + outputWidth + , ky >= topSkip + , ky < topSkip + outputHeight + ] + in foldl' (\m (pos, cell) -> Map.insert pos cell m) acc visible + EmptyImage -> acc + +placeText :: V.Attr -> String -> Int -> Int -> CellMap -> CellMap +placeText attr chars x y = + go chars 0 + where + go [] _ acc = acc + go (c : cs) dx acc = + let w = wcwidth c + in if w <= 0 + then go cs dx acc + else + go cs (dx + w) $ + Map.insert (x + dx, y) (Cell c attr) acc + +---------------------------------------------------------------------------- +-- Internal: attr serialization +---------------------------------------------------------------------------- + +showAttr :: V.Attr -> String +showAttr a = + concat + [ "fg=" + , showMD V.attrForeColor + , " bg=" + , showMD V.attrBackColor + , " style=" + , showStyle + , " url=" + , showMD V.attrURL + ] + where + showMD f = case f a of + V.Default -> "default" + V.KeepCurrent -> "keep" + V.SetTo v -> show v + styleMask = V.styleMask a + showStyle = + let styles = + [ ("bold", V.bold) + , ("underline", V.underline) + , ("reverse", V.reverseVideo) + , ("blink", V.blink) + , ("dim", V.dim) + , ("italic", V.italic) + , ("strikethrough", V.strikethrough) + ] + active = [name | (name, s) <- styles, V.hasStyle styleMask s] + in if null active then "none" else unwords active + +---------------------------------------------------------------------------- +-- Golden file comparison +---------------------------------------------------------------------------- + +-- | Directory where golden files are stored. +goldenDir :: FilePath +goldenDir = "test" "goldens" + +-- | Compare actual output against a golden file. If the file doesn't +-- exist yet, it is created (first-run golden creation). If it exists but +-- differs, the test fails with a unified diff. +assertGolden :: String -> String -> Expectation +assertGolden name actual = do + let path = goldenDir name <.> "txt" + createDirectoryIfMissing True goldenDir + exists <- doesFileExist path + if not exists + then writeFile path actual + else do + expected <- readFile path + actual `shouldBe` expected diff --git a/test/Reflex/Vty/Test/SnapshotSpec.hs b/test/Reflex/Vty/Test/SnapshotSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Test/SnapshotSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.Test.SnapshotSpec (spec) where + +import Data.List (isInfixOf) +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Style + ( Color + , Style + , def + , render + , singleBorder + , withBorder + , withForeground + ) +import qualified Reflex.Vty.Style as Style (red) +import Reflex.Vty.Test.Snapshot + +spec :: Spec +spec = describe "Reflex.Vty.Test.Snapshot" $ do + describe "imageToGrid" $ do + it "renders plain text as a single row" $ do + let img = render def "hello" + grid = imageToGrid img + length grid `shouldBe` 1 + case grid of + [row] -> map cellChar row `shouldBe` "hello" + _ -> expectationFailure "expected exactly one row" + + it "renders multi-line text with correct rows" $ do + let img = render def "ab\ncd" + grid = imageToGrid img + length grid `shouldBe` 2 + map cellChar (grid !! 0) `shouldBe` "ab" + map cellChar (grid !! 1) `shouldBe` "cd" + + it "preserves attributes from the style" $ do + let img = render (withForeground Style.red def) "X" + grid = imageToGrid img + case grid of + ((c : _) : _) -> V.attrForeColor (cellAttr c) `shouldBe` V.SetTo Style.red + _ -> expectationFailure "expected at least one cell" + + it "renders borders as box-drawing characters" $ do + let img = render (withBorder singleBorder def) "hi" + grid = imageToGrid img + case grid of + (topRow : _) -> do + map cellChar topRow `shouldStartWith` "\9484" -- ┌ + last (map cellChar topRow) `shouldBe` '\9488' -- ┐ + [] -> expectationFailure "expected at least one row" + + describe "imageText" $ do + it "extracts text content from image" $ do + let img = render def "hello" + imageText img `shouldBe` ["hello"] + + it "handles multi-line content" $ do + let img = render def "foo\nbar" + imageText img `shouldBe` ["foo", "bar"] + + describe "gridEquals" $ do + it "returns Nothing for identical grids" $ do + let grid = imageToGrid $ render def "hi" + gridEquals grid grid `shouldBe` Nothing + + it "reports mismatched cells" $ do + let g1 = imageToGrid $ render def "hi" + g2 = imageToGrid $ render def "ho" + gridEquals g1 g2 `shouldSatisfy` (/= Nothing) + + describe "renderGrid" $ do + it "includes text representation" $ do + let txt = renderGrid $ imageToGrid $ render def "X" + txt `shouldSatisfy` ("X" `isInfixOf`) diff --git a/test/Reflex/Vty/Widget/BoxSpec.hs b/test/Reflex/Vty/Widget/BoxSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Widget/BoxSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.Widget.BoxSpec (spec) where + +import qualified Data.Text as T +import Test.Hspec + +import Data.Text.Zipper (TextAlignment (..)) +import Reflex.Vty.Widget.Box (alignText, centerText) + +spec :: Spec +spec = describe "Reflex.Vty.Widget.Box" $ do + describe "alignText" $ do + it "left-aligns by padding on the right" $ do + alignText TextAlignment_Left "hi" '-' 5 `shouldBe` "hi---" + + it "right-aligns by padding on the left" $ do + alignText TextAlignment_Right "hi" '-' 5 `shouldBe` "---hi" + + it "center-aligns with left bias for odd slack" $ do + alignText TextAlignment_Center "hi" '-' 5 `shouldBe` "--hi-" + + it "center-aligns evenly for even slack" $ do + alignText TextAlignment_Center "hi" '-' 6 `shouldBe` "--hi--" + + it "returns text unchanged when it fills the width" $ do + alignText TextAlignment_Left "hello" '-' 3 `shouldBe` "hello" + + it "returns text unchanged when it exceeds the width" $ do + alignText TextAlignment_Center "hello" '-' 2 `shouldBe` "hello" + + it "measures wide characters correctly" $ do + alignText TextAlignment_Left "文" '-' 4 `shouldBe` "文--" + + it "handles empty text" $ do + alignText TextAlignment_Center "" '-' 3 `shouldBe` "---" + + describe "centerText" $ do + it "is a specialization of alignText" $ do + centerText "hi" '-' 5 `shouldBe` alignText TextAlignment_Center "hi" '-' 5 diff --git a/test/Reflex/Vty/Widget/CursorSpec.hs b/test/Reflex/Vty/Widget/CursorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Widget/CursorSpec.hs @@ -0,0 +1,48 @@ +module Reflex.Vty.Widget.CursorSpec (spec) where + +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Host +import Reflex.Vty.Widget + +spec :: Spec +spec = describe "Reflex.Vty.Widget cursor" $ do + describe "defaultCursorState" $ + it "starts hidden with terminal-default style" $ + defaultCursorState `shouldBe` CursorState CursorHidden CursorStyleDefault (0, 0) + + describe "translateCursorState" $ do + it "translates visible viewport-relative positions to absolute positions" $ + translateCursorState + (Region 10 20 5 3) + (CursorState CursorVisible CursorStyleBar (2, 1)) + `shouldBe` CursorState CursorVisible CursorStyleBar (12, 21) + + it "hides visible cursors outside the viewport" $ + translateCursorState + (Region 10 20 5 3) + (CursorState CursorVisible CursorStyleBlock (5, 1)) + `shouldBe` CursorState CursorHidden CursorStyleBlock (15, 21) + + it "translates hidden cursor positions without changing visibility" $ + translateCursorState + (Region 10 20 5 3) + (CursorState CursorHidden CursorStyleUnderline (7, 4)) + `shouldBe` CursorState CursorHidden CursorStyleUnderline (17, 24) + + describe "cursorStateToVtyCursor" $ do + it "maps hidden cursor state to NoCursor" $ + cursorStateToVtyCursor (CursorState CursorHidden CursorStyleBlock (2, 3)) + `shouldBe` V.NoCursor + + it "maps visible cursor state to a vty cursor position" $ + cursorStateToVtyCursor (CursorState CursorVisible CursorStyleBlock (2, 3)) + `shouldBe` V.Cursor 2 3 + + describe "ScreenMode" $ do + it "has two constructors" $ + [ScreenNormal ..] `shouldBe` [ScreenNormal, ScreenAlternate] + + it "ScreenNormal /= ScreenAlternate" $ + ScreenNormal `shouldNotBe` ScreenAlternate diff --git a/test/Reflex/Vty/Widget/MouseSpec.hs b/test/Reflex/Vty/Widget/MouseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Widget/MouseSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.Widget.MouseSpec (spec) where + +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Widget.Input.Mouse + +-- | Replay a list of vty events through 'stepDrag', keeping the previous drag +-- state when an event is irrelevant (mirroring how 'drag' holds its state). +-- Returns the 'Drag' emitted for each relevant event, in order. +runDrag :: V.Button -> [V.Event] -> [Drag] +runDrag btn = go Nothing + where + go _ [] = [] + go prev (e : es) = case stepDrag btn prev e of + Just d -> d : go (Just d) es + Nothing -> go prev es + +down :: Int -> Int -> V.Button -> V.Event +down x y b = V.EvMouseDown x y b [] + +up :: Int -> Int -> Maybe V.Button -> V.Event +up x y b = V.EvMouseUp x y b + +spec :: Spec +spec = describe "Reflex.Vty.Widget.Input.Mouse" $ do + describe "Drag" $ do + it "has correct field types" $ do + let d = Drag (0, 0) (1, 1) V.BLeft [] DragStart + _drag_from d `shouldBe` (0, 0) + _drag_to d `shouldBe` (1, 1) + _drag_button d `shouldBe` V.BLeft + _drag_state d `shouldBe` DragStart + + describe "DragState" $ do + it "enumerates start, dragging, end in order" $ + [minBound .. maxBound] `shouldBe` [DragStart, Dragging, DragEnd] + + describe "stepDrag" $ do + it "starts a drag on the first matching mouse-down" $ + stepDrag V.BLeft Nothing (down 3 4 V.BLeft) + `shouldBe` Just (Drag (3, 4) (3, 4) V.BLeft [] DragStart) + + it "ignores a mouse-down for a different button" $ + stepDrag V.BLeft Nothing (down 3 4 V.BRight) `shouldBe` Nothing + + it "ignores non-mouse events" $ + stepDrag V.BLeft Nothing (V.EvKey (V.KChar 'a') []) `shouldBe` Nothing + + it "continues as Dragging on subsequent moves, preserving the origin" $ do + let start = Drag (3, 4) (3, 4) V.BLeft [] DragStart + stepDrag V.BLeft (Just start) (down 5 6 V.BLeft) + `shouldBe` Just (Drag (3, 4) (5, 6) V.BLeft [] Dragging) + + it "ends the drag on mouse-up (button specified)" $ do + let dragging = Drag (3, 4) (5, 6) V.BLeft [] Dragging + stepDrag V.BLeft (Just dragging) (up 7 8 (Just V.BLeft)) + `shouldBe` Just (Drag (3, 4) (7, 8) V.BLeft [] DragEnd) + + it "ends the drag on mouse-up (button unspecified)" $ do + let dragging = Drag (3, 4) (5, 6) V.BLeft [] Dragging + stepDrag V.BLeft (Just dragging) (up 7 8 Nothing) + `shouldBe` Just (Drag (3, 4) (7, 8) V.BLeft [] DragEnd) + + it "ignores a stray mouse-up after the drag already ended" $ do + let ended = Drag (3, 4) (7, 8) V.BLeft [] DragEnd + stepDrag V.BLeft (Just ended) (up 9 9 (Just V.BLeft)) `shouldBe` Nothing + + it "starts a fresh drag on a mouse-down after the previous one ended" $ do + let ended = Drag (3, 4) (7, 8) V.BLeft [] DragEnd + stepDrag V.BLeft (Just ended) (down 1 1 V.BLeft) + `shouldBe` Just (Drag (1, 1) (1, 1) V.BLeft [] DragStart) + + it "produces Start -> Dragging -> End across a full drag" $ do + let ds = runDrag V.BLeft [down 1 1 V.BLeft, down 2 2 V.BLeft, down 3 3 V.BLeft, up 3 3 (Just V.BLeft)] + map _drag_state ds `shouldBe` [DragStart, Dragging, Dragging, DragEnd] + map _drag_from ds `shouldBe` replicate 4 (1, 1) + _drag_to (last ds) `shouldBe` (3, 3) + + it "tracks two consecutive drags, each with its own Start and End" $ do + let evs = + [ down 1 1 V.BLeft + , up 1 1 (Just V.BLeft) + , down 5 5 V.BLeft + , down 6 6 V.BLeft + , up 6 6 Nothing + ] + map _drag_state (runDrag V.BLeft evs) + `shouldBe` [DragStart, DragEnd, DragStart, Dragging, DragEnd] + + describe "MouseDown" $ do + it "stores button, coordinates, and modifiers" $ do + let md = MouseDown V.BLeft (5, 10) [V.MShift] + _mouseDown_button md `shouldBe` V.BLeft + _mouseDown_coordinates md `shouldBe` (5, 10) + _mouseDown_modifiers md `shouldBe` [V.MShift] + + describe "MouseUp" $ do + it "stores optional button and coordinates" $ do + let mu = MouseUp (Just V.BLeft) (3, 7) + _mouseUp_button mu `shouldBe` Just V.BLeft + _mouseUp_coordinates mu `shouldBe` (3, 7) + + describe "ScrollDirection" $ do + it "has up and down constructors" $ do + ScrollDirection_Up `shouldNotBe` ScrollDirection_Down diff --git a/test/Reflex/Vty/Widget/ScrollSpec.hs b/test/Reflex/Vty/Widget/ScrollSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Widget/ScrollSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reflex.Vty.Widget.ScrollSpec (spec) where + +import qualified Graphics.Vty as V +import Test.Hspec + +import Reflex.Vty.Test.Snapshot +import Reflex.Vty.Widget.Scroll + ( ScrollbarVisibility (..) + , scrollbarImages + ) + +spec :: Spec +spec = describe "Reflex.Vty.Widget.Scroll" $ do + describe "scrollbarImages" $ do + let attr = V.defAttr + + it "returns empty when hidden" $ do + scrollbarImages ScrollbarHidden attr 10 50 0 20 `shouldBe` [] + + it "returns empty when content fits viewport" $ do + scrollbarImages ScrollbarAlways attr 10 5 0 20 `shouldBe` [] + + it "returns empty when viewport too narrow" $ do + scrollbarImages ScrollbarAlways attr 10 50 0 1 `shouldBe` [] + + it "produces a thumb for ScrollbarAlways" $ do + let imgs = scrollbarImages ScrollbarAlways attr 10 50 0 20 + length imgs `shouldBe` 2 -- gutter + thumb + it "produces only a thumb for ScrollbarThumbOnly" $ do + let imgs = scrollbarImages ScrollbarThumbOnly attr 10 50 0 20 + length imgs `shouldBe` 1 -- thumb only + it "produces only a thumb for ScrollbarWhileScrolling" $ do + let imgs = scrollbarImages ScrollbarWhileScrolling attr 10 50 0 20 + length imgs `shouldBe` 1 -- thumb only + it "places thumb at top when scrollLine is 0" $ do + let imgs = scrollbarImages ScrollbarThumbOnly attr 10 50 0 20 + grid = imageToGrid $ V.vertCat imgs + -- Thumb should be at the top of the rightmost column + (row0, _) = case grid of + (r : _) -> (map cellChar r, 0) + [] -> ("", 0) + last row0 `shouldBe` '█' + + it "places thumb lower when scrolled down" $ do + let imgsAtTop = scrollbarImages ScrollbarThumbOnly attr 10 50 0 20 + imgsScrolled = scrollbarImages ScrollbarThumbOnly attr 10 50 20 20 + topGrid = imageToGrid $ V.vertCat imgsAtTop + scrolledGrid = imageToGrid $ V.vertCat imgsScrolled + topChar (row : _) = last (map cellChar row) + topChar [] = ' ' + -- The thumb at position 0 should differ from thumb at position 20 + topChar topGrid `shouldBe` '█' + -- When scrolled, the first row should not have the thumb + topChar scrolledGrid `shouldSatisfy` (/= '█') + + it "thumb size is proportional to viewport/total ratio" $ do + let attr = V.defAttr + -- vpHeight=10, totalLines=100 → thumbLen = max 1 (100/100) = 1 + imgs1 = scrollbarImages ScrollbarThumbOnly attr 10 100 0 20 + -- vpHeight=10, totalLines=20 → thumbLen = max 1 (100/20) = 5 + imgs2 = scrollbarImages ScrollbarThumbOnly attr 10 20 0 20 + heightOf [] = 0 + heightOf (img : _) = V.imageHeight img + heightOf imgs1 `shouldBe` 1 + heightOf imgs2 `shouldBe` 5 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,14 +2,37 @@ -- does not work with current CircleCI image so instead we do it manually for now -- {-# OPTIONS_GHC -F -pgmF hspec-discover #-} - import Test.Hspec import qualified Data.Text.ZipperSpec +import qualified Reflex.Vty.CanvasSpec +import qualified Reflex.Vty.ColorProfileSpec +import qualified Reflex.Vty.ColorSpec +import qualified Reflex.Vty.HostSpec +import qualified Reflex.Vty.StyleJoinSpec +import qualified Reflex.Vty.StyleSpec +import qualified Reflex.Vty.Test.GoldenSpec +import qualified Reflex.Vty.Test.SnapshotSpec +import qualified Reflex.Vty.Widget.BoxSpec +import qualified Reflex.Vty.Widget.CursorSpec +import qualified Reflex.Vty.Widget.MouseSpec +import qualified Reflex.Vty.Widget.ScrollSpec main :: IO () main = hspec spec spec :: Spec spec = do - describe "Data.Text.ZipperSpec" Data.Text.ZipperSpec.spec + describe "Data.Text.ZipperSpec" Data.Text.ZipperSpec.spec + describe "Reflex.Vty.CanvasSpec" Reflex.Vty.CanvasSpec.spec + describe "Reflex.Vty.ColorProfileSpec" Reflex.Vty.ColorProfileSpec.spec + describe "Reflex.Vty.ColorSpec" Reflex.Vty.ColorSpec.spec + describe "Reflex.Vty.HostSpec" Reflex.Vty.HostSpec.spec + describe "Reflex.Vty.StyleSpec" Reflex.Vty.StyleSpec.spec + describe "Reflex.Vty.StyleJoinSpec" Reflex.Vty.StyleJoinSpec.spec + describe "Reflex.Vty.Test.SnapshotSpec" Reflex.Vty.Test.SnapshotSpec.spec + describe "Reflex.Vty.Test.GoldenSpec" Reflex.Vty.Test.GoldenSpec.spec + describe "Reflex.Vty.Widget.BoxSpec" Reflex.Vty.Widget.BoxSpec.spec + describe "Reflex.Vty.Widget.CursorSpec" Reflex.Vty.Widget.CursorSpec.spec + describe "Reflex.Vty.Widget.MouseSpec" Reflex.Vty.Widget.MouseSpec.spec + describe "Reflex.Vty.Widget.ScrollSpec" Reflex.Vty.Widget.ScrollSpec.spec