on 9960d46 help sign in
.github/workflows/haskell.ymldeleted−41
since splitsnapshots
unifiedsplit
@@ -1,41 +0,0 @@
1−name: github-action
2−
3−on: [push, pull_request]
4−
5−jobs:
6− build:
7− strategy:
8− matrix:
9− ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
10− os: ['ubuntu-latest', 'macos-latest']
11− runs-on: ${{ matrix.os }}
12−
13− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
14− steps:
15− - uses: actions/checkout@v2
16− - uses: actions/setup-haskell@v1
17− with:
18− ghc-version: ${{ matrix.ghc }}
19− - name: Cache
20− uses: actions/cache@v1
21− env:
22− cache-name: cache-cabal
23− with:
24− path: ~/.cabal
25− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
26− restore-keys: |
27− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
28− ${{ runner.os }}-${{ matrix.ghc }}-build-
29− ${{ runner.os }}-${{ matrix.ghc }}-
30− ${{ runner.os }}
31−
32− - name: Install dependencies
33− run: |
34− cabal update
35− cabal build --only-dependencies --enable-tests --enable-benchmarks
36− - name: Build
37− run: cabal build --enable-tests --enable-benchmarks all
38− - name: Run tests
39− run: cabal test all
40− - name: Build Docs
41− run: cabal haddock
.gitignore−1
@@ -1,3 +1,2 @@
1tags
1tags
2dist/
2dist/
3−dist-newstyle/
.travis.ymlnew file+109
@@ -0,0 +1,109 @@
1+# This Travis job script has been generated by a script via
2+#
3+# haskell-ci 'reflex-vty.cabal' '--output' '.travis.yml'
4+#
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.3
8+#
9+language: c
10+dist: xenial
11+
12+git:
13+ submodules: false # whether to recursively clone submodules
14+
15+cache:
16+ directories:
17+ - $HOME/.cabal/packages
18+ - $HOME/.cabal/store
19+
20+before_cache:
21+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
22+ # remove files that are regenerated by 'cabal update'
23+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
26+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
27+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
28+
29+ - rm -rfv $CABALHOME/packages/head.hackage
30+
31+matrix:
32+ include:
33+ - compiler: "ghc-8.6.5"
34+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}
35+ - compiler: "ghc-8.4.4"
36+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}
37+
38+before_install:
39+ - HC=/opt/ghc/bin/${CC}
40+ - HCPKG=${HC/ghc/ghc-pkg}
41+ - unset CC
42+ - CABAL=/opt/ghc/bin/cabal
43+ - CABALHOME=$HOME/.cabal
44+ - export PATH="$CABALHOME/bin:$PATH"
45+ - ROOTDIR=$(pwd)
46+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
47+ - echo $HCNUMVER
48+
49+install:
50+ - ${CABAL} --version
51+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
52+ - TEST=--enable-tests
53+ - BENCH=--enable-benchmarks
54+ - GHCHEAD=${GHCHEAD-false}
55+ - travis_retry ${CABAL} update -v
56+ - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config
57+ - rm -fv cabal.project cabal.project.local
58+ - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'
59+ - rm -f cabal.project
60+ - touch cabal.project
61+ - "printf 'packages: \".\"\\n' >> cabal.project"
62+ - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
63+ - touch cabal.project.local
64+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(reflex-vty)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
65+ - cat cabal.project || true
66+ - cat cabal.project.local || true
67+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
68+ - rm -f cabal.project.freeze
69+ - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry
70+ - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
71+ - rm "cabal.project.freeze"
72+ - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
73+ - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
74+ - rm -rf .ghc.environment.* "."/dist
75+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
76+
77+# Here starts the actual work to be performed for the package under test;
78+# any command which exits with a non-zero exit code causes the build to fail.
79+script:
80+ # test that source-distributions can be generated
81+ - ${CABAL} new-sdist all
82+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
83+ - cd ${DISTDIR} || false
84+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
85+ - rm -f cabal.project
86+ - touch cabal.project
87+ - "printf 'packages: \"reflex-vty-*/*.cabal\"\\n' >> cabal.project"
88+ - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
89+ - touch cabal.project.local
90+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(reflex-vty)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
91+ - cat cabal.project || true
92+ - cat cabal.project.local || true
93+ # this builds all libraries and executables (without tests/benchmarks)
94+ - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all
95+
96+ # build & run tests, build benchmarks
97+ - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all
98+
99+ # cabal check
100+ - (cd reflex-vty-* && ${CABAL} check)
101+
102+ # haddock
103+ - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all
104+
105+ # Build without installed constraints for packages in global-db
106+ - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all
107+
108+# REGENDATA ["reflex-vty.cabal","--output",".travis.yml"]
109+# EOF
ChangeLog.md+17−113
@@ -1,128 +1,32 @@
1# Revision history for reflex-vty
1# Revision history for reflex-vty
2
2
3−## 0.2.0.0
3+## 0.1.3.1
4−
5−* _Module Reorganization_: The following modules have been added (and are all re-exported by Reflex.Vty):
6− * Reflex.Vty.Widget.Box for all the box functions and datatypes
7− * Reflex.Vty.Widget.Input.Mouse for clicking, dragging, and scrolling
8− * Reflex.Vty.Widget.Split contains `splitV`, `splitH`, etc
9− * Reflex.Vty.Widget.Text contains text rendering functions like `text` and `display`
10−* _Bugfixes_:
11− * Remove text-icu dependency and switch to `wcwidth` from vty package to compute character width in `Data.Text.Zipper`.
12− * `goToDisplayLinePosition` in `Data.Text.Zipper` correctly accounts for character width now.
13− * [#37](https://github.com/reflex-frp/reflex-vty/issues/37) `Layout` should support focus changes through nested layouts (thanks @pdlla for getting this started -- see entry on Layout and Focus below).
14− * Fix distribution of available space when it cannot be evenly distributed. Previously, all leftover space would be allocated to the first stretchable widget.
15−* _Breaking Changes_:
16− * Layout and focus have been substantially refactored to fix [#37](https://github.com/reflex-frp/reflex-vty/issues/37) and support a wider variety of layouts and focus switching requirements.
17− * Added a new `HasFocus` class (the old one is now `HasFocusReader`) to produce focusable elements, and manage focus state. See the "Focus" section of the Reflex.Vty.Widget.Layout module documentation.
18− * `Layout` no longer has any focus-tracking responsibility. See the "Layout" section of the Reflex.Vty.Widget.Layout module documentation.
19− * `tile` no longer takes a configuration record and no longer requires that its child widget return a focus request event. Focus requests are instead handled using calls to `requestFocus` in the child widget.
20− * Calls to `fixed` and `stretch` must now be replaced with `tile . fixed` and `tile . stretch`
21− * `stretch` now takes a minimum size argument
22− * Added `flex` which is equivalent to `stretch 0`
23− * `tabNavigation` no longer returns an `Event`. Instead it calls `requestFocus` directly with the appropriate `Refocus_Shift` value.
24− * Added `axis` (in `HasLayout`), a lower-level primitive which is used to implement `row` and `col`.
25− * Added `region` (in `HasLayout`), which is used to claim screen real estate and used to implement `tile` and `grout`
26− * Added `grout`, a container element that is not itself focusable (though its children can be)
27− * Removed `VtyWidget` and replaced it with a number of separate classes and monad transformers
28− * Replace `HasDisplaySize` with `HasDisplayRegion` which carries around a region instead of just a width and height. `displayWidth` and `displayHeight` are now functions implemented in terms of `askRegion` instead of class methods.
29− * Add a `DisplayRegion` monad transformer
30− * Rename `ImageWriter` to `HasImageWriter`
31− * Introduce an `ImageWriter` monad transformer
32− * Rename `HasFocus` to `HasFocusReader`
33− * Introduce a `FocusReader` monad transformer
34− * Replace `HasVtyInput` with `HasInput`
35− * Introduce an `Input` monad transformer
36− * Introduce `HasTheme` reader class to allow setting Vty attributes of all built-in widgets
37− * Introduce `ThemeReader` monad transformer
38− * Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.
39− * `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.
40− * `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.
41− * `HasInput` (formerly `HasVtyInput`) now has a method `localInput` for filtering the input a child widget may receive
42− * `HasImageWriter` now has a method `mapImages` for transforming the images emitted by a child widget
43− * `boxTitle` now takes a `Behavior t Text` as its title, instead of a plain `Text`
44− * `fill` now takes a `Behavior t Char` instead of a `Char`
45− * The following functions are no longer specialized to `VtyWidget`:
46− * `pane`: Now requires `HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m`
47− * `drag`: Now requires `HasInput`
48− * `mouseDown`: Now requires `HasInput`
49− * `mouseUp`: Now requires `HasInput`
50− * `mouseScroll`: Now requires `HasInput`
51− * `key`: Now requires `HasInput`
52− * `keys`: Now requires `HasInput`
53− * `keyCombo`: Now requires `HasInput`
54− * `keyCombos`: Now requires `HasInput`
55− * `splitV`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
56− * `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
57− * `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
58− * `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`
59− * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
60− * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
61− * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
62− * `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`
63− * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
64− * `blank`: Now requires `Monad`
65− * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
66− * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
67− * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
68− * `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
69− * `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
70− * TextZipper interface changes
71− * `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`
72− * `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position
73− * some exposed methods intended for internal use only have been removed
74− * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
75− * `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
76− * `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, `HasTheme`, and `HasFocus`
77−* _Misc_:
78− * (#40 Add alignment support to TextZipper)[https://github.com/reflex-frp/reflex-vty/pull/40]
79− * Add alignment (left/center/right) support to TextZipper
80− * Add basic unit tests for newly created alignment methods in TextZipper
81− * Add default instances for `HasInput`, `HasFocus`, and `HasImageWriter`
82− * Export `withinImage` and add `imagesInRegion` to crop images to a region
83− * Add `anyChildFocused`, which provides information about whether subwidgets are focused
84− * Add `filterKeys`, which is the same as `localInput` but only cares about keyboard events
85− * Add `hoistRunLayout` to apply a transformation to the context of a `Layout` action and run that action
86− * Add various `MFunctor` instances
87− * Add a CPU usage indicator to the example executable
88−
89−## 0.1.4.2
90−
91−* Wider bounds for GHC 8.10 support
92−
93−## 0.1.4.1
94−
95−## 0.1.4.1
96−* Migrate to new dependent-sum / dependent-map (after the "some" package split)
97−
98−## 0.1.4.0
99−* ([#15](https://github.com/reflex-frp/reflex-vty/pull/15)) Add `PostBuild` instance for `Layout`.
100−* ([#17](https://github.com/reflex-frp/reflex-vty/pull/17)) Add `splitH` to implement horizontal functionality of `splitV`.
101−* ([#19](https://github.com/reflex-frp/reflex-vty/pull/19)) Add `boxTitle`: a box with a title.
4+* Add `boxTitle`: a box with a title
102−* ([#19](https://github.com/reflex-frp/reflex-vty/pull/19)) Update the text editing example to use `boxTitle`.
5+* Update the text editing example to use `boxTitle`
103−* ([#21](https://github.com/reflex-frp/reflex-vty/pull/21)) Fix bug in `drag` that caused dragging with different mouse button to trigger the click event.
104−* ([#22](https://github.com/reflex-frp/reflex-vty/pull/22)) Add support for GHC 8.8.
105
6
106## 0.1.3.0
7## 0.1.3.0
107−* Add `mouseScroll` to capture scroll wheel events.
8+* Add `mouseScroll` to capture scroll wheel events
108−* Add `scrollableText`: a text display widget that can be scrolled using the mouse or keyboard.
9+* Add `scrollableText`: a text display widget that can be scrolled using the mouse or keyboard
109−* Add widget to the example executable that displays scrollable text.
10+* Add widget to the example executable that displays scrollable text
110
11
111## 0.1.2.1
12## 0.1.2.1
112−* Add `keyCombo` function (single-key-combination version of `keyCombos`).
13+* Add `keyCombo` function (single-key-combination version of `keyCombos`)
113−* Use upstream `NotReady` instances instead of orphans defined in this package if reflex-0.6.3 is available.
14+* Use upstream `NotReady` instances instead of orphans defined in this package if reflex-0.6.3 is available
114
15
115## 0.1.2.0
16## 0.1.2.0
116−* Allow `TextZipper` contents to be transformed before being displayed.
17+* Allow TextZipper contents to be tranformed before being displayed
117−* Fix bug in `row` orientation.
18+* Fix bug in `row` orientation
118−* Handle wrapping of lines containing full-width unicode characters in `textInput`.
19+* Handle wrapping of lines containing fullwidth unicode characters in `textInput`
119
20
120## 0.1.1.1
21## 0.1.1.1
22+
121−* Bump minimum version of reflex.
23+* Bump minimum version of reflex
122
24
123## 0.1.1.0
25## 0.1.1.0
26+
124−* Set version bounds in cabal file.
27+* Set version bounds in cabal file
125−* Add travis CI config.
28+* Add travis CI config
126
29
127## 0.1.0.0
30## 0.1.0.0
31+
128* Initial release
32* Initial release
README.md+8−8
@@ -1,10 +1,8 @@
1−# reflex-vty
1+# reflex-vty [![hackage](https://img.shields.io/hackage/v/reflex-vty.svg)](https://hackage.haskell.org/package/reflex-vty) [![hackage-ci](https://matrix.hackage.haskell.org/api/v2/packages/reflex-vty/badge)](https://matrix.hackage.haskell.org/#/package/reflex-vty) [![travis-ci](https://api.travis-ci.org/reflex-frp/reflex-vty.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-vty)
2
2
3−[![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) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex-vty/badge)](https://matrix.hackage.haskell.org/#/package/reflex-vty) [![Travis CI](https://api.travis-ci.org/reflex-frp/reflex-vty.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-vty) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex-vty/blob/master/LICENSE)
3+## A library for building functional reactive terminal applications
4
4
5−Build terminal applications using functional reactive programming (FRP) with [Reflex FRP](https://reflex-frp.org).
5+![reflex-vty example animation](doc/welcome.gif)
6−
7−![Example Animation](https://i.imgur.com/FULQNtu.gif)
8
6
9Feature requests, pull requests, and other feedback are welcome and appreciated (see the [contribution guide](CONTRIBUTING.md)). This library
7Feature requests, pull requests, and other feedback are welcome and appreciated (see the [contribution guide](CONTRIBUTING.md)). This library
10is still experimental, so big changes are possible!
8is still experimental, so big changes are possible!
@@ -14,9 +12,10 @@ is still experimental, so big changes are possible!
14
12
15Enter a nix-shell for the project:
13Enter a nix-shell for the project:
16```bash
14```bash
17−git clone https://github.com/reflex-frp/reflex-vty.git
15+git clone git@github.com:reflex-frp/reflex-platform
16+git clone git@github.com:reflex-frp/reflex-vty
18cd reflex-vty
17cd reflex-vty
19−nix-shell
18+../reflex-platform/scripts/work-on ghc ./.
20```
19```
21
20
22From within the nix-shell you can:
21From within the nix-shell you can:
@@ -34,9 +33,10 @@ Please see the `tested-with` field of the cabal file for known-compatible versio
34From the reflex-vty project directory:
33From the reflex-vty project directory:
35
34
36```bash
35```bash
37−# nix-shell -p cabal-install binutils icu # for nix users
38cabal new-configure
36cabal new-configure
39cabal new-build # to build the library and example
37cabal new-build # to build the library and example
40cabal new-repl # to enter a repl for the library
38cabal new-repl # to enter a repl for the library
41cabal new-repl example # to enter a repl for the example executable
39cabal new-repl example # to enter a repl for the example executable
42```
40```
41+
42+
doc/qa.mddeleted−41
@@ -1,41 +0,0 @@
1−# QA Guide
2−
3−This QA guide takes you through the process of testing `reflex-vty` from a visual observer's perspective. The goal is to ensure that `reflex-vty` does not contain bugs/regressions that are visual in nature, which are hard to detect with automated testing. This guide assumes you have Nix installed.
4−
5−## Steps
6−
7−Clone and examples
8−
9−```bash
10−nix-shell -p git
11−cd $(mktemp -d)
12−git clone https://github.com/reflex-frp/reflex-vty.git --branch develop
13−nix run -f reflex-vty/release.nix reflex-vty --command example
14−```
15−
16−The build may take a while to complete.
17−
18−Once it's done you can test the following:
19−
20− * Make sure that resizing your terminal window causes the editor to resize as well.
21−
22− * Click on `Todo List`.
23− * Make sure you can check tasks, uncheck tasks, add new tasks, and edit the text of tasks.
24− * Make sure that resizing your terminal window causes the editor to resize as well.
25− * Type <kbd>Esc</kbd>.
26−
27− * Click on `Text Editor`.
28− * Make sure you can edit text in the "Text Edit" box. Try entering lots of text so that it doesn't all fit. It should scroll down as you type. Using they arrow keys on your keyboard should move the cursor and let you go back up and see text that was out of view before.
29− * Make sure that clicking, right-clicking, using the scroll-wheel on your mouse, and dragging in the "Text Edit" box updates the message in the box lying above and behind the "Text Edit" box.
30− * Make sure that dragging your mouse cursor around inside the lowest box causes the message to update. This should update only when dragging *inside* that box, not outside of it.
31− * Make sure that resizing your terminal window causes the boxes to resize as well.
32− * Type <kbd>Esc</kbd>.
33−
34− * Click on `Scrollable text display`.
35− * Make sure that you can scroll up and down through the small box of text with your mouse's scroll wheel.
36− * Make sure that resizing your terminal window causes the boxes to resize as well.
37− * Type <kbd>Esc</kbd>.
38−
39− * Type <kbd>Ctrl</kbd>+<kbd>C</kbd> to quit.
40−
41−There should be only 3 examples to cover. If there are more or less than this then this QA guide is out of date and QA should fail.
doc/welcome.gifnew file

Binary file not shown.

reflex-platform/default.nixdeleted−2
@@ -1,2 +0,0 @@
1−# DO NOT HAND-EDIT THIS FILE
2−import (import ./thunk.nix)
reflex-platform/github.jsondeleted−8
@@ -1,8 +0,0 @@
1−{
2− "owner": "reflex-frp",
3− "repo": "reflex-platform",
4− "branch": "develop",
5− "private": false,
6− "rev": "f019863c21ee85498e6a6e0072e617b2462b70ed",
7− "sha256": "146xfjqdwd55s9jg1ggi6akcxxxd5c0pvc4bpjx3whwiikpcv8y4"
8−}
reflex-platform/stable/default.nixnew file+7
@@ -0,0 +1,7 @@
1+# DO NOT HAND-EDIT THIS FILE
2+import ((import <nixpkgs> {}).fetchFromGitHub (
3+ let json = builtins.fromJSON (builtins.readFile ./github.json);
4+ in { inherit (json) owner repo rev sha256;
5+ private = json.private or false;
6+ }
7+))
reflex-platform/stable/github.jsonnew file+7
@@ -0,0 +1,7 @@
1+{
2+ "owner": "reflex-frp",
3+ "repo": "reflex-platform",
4+ "branch": "master",
5+ "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
6+ "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
7+}
reflex-platform/thunk.nixdeleted−9
@@ -1,9 +0,0 @@
1−# DO NOT HAND-EDIT THIS FILE
2−let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3− if !fetchSubmodules && !private then builtins.fetchTarball {
4− url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5− } else (import <nixpkgs> {}).fetchFromGitHub {
6− inherit owner repo rev sha256 fetchSubmodules private;
7− };
8− json = builtins.fromJSON (builtins.readFile ./github.json);
9−in fetch json
reflex-platform/unstable/default.nixnew file+7
@@ -0,0 +1,7 @@
1+# DO NOT HAND-EDIT THIS FILE
2+import ((import <nixpkgs> {}).fetchFromGitHub (
3+ let json = builtins.fromJSON (builtins.readFile ./github.json);
4+ in { inherit (json) owner repo rev sha256;
5+ private = json.private or false;
6+ }
7+))
reflex-platform/unstable/github.jsonnew file+7
@@ -0,0 +1,7 @@
1+{
2+ "owner": "reflex-frp",
3+ "repo": "reflex-platform",
4+ "branch": "ghc865-nixpkgs1903",
5+ "rev": "02389f2a709a3f28ae2f3224d2c8ba81cc64c40b",
6+ "sha256": "10g2yhf4la929aa1km0184asikmn0kayzlra16mqmni2f684v3z3"
7+}
reflex-vty.cabal+32−113
@@ -1,10 +1,11 @@
1name: reflex-vty
1name: reflex-vty
2−version: 0.2.0.0
2+version: 0.1.3.0
3−synopsis: Reflex FRP host and widgets for VTY applications
3+synopsis: Reflex FRP host and widgets for vty applications
4description:
4description:
5− Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).
5+ Host and widget library for Reflex-based FRP applications
6 .
6 .
7 <<https://i.imgur.com/FULQNtu.gif>>
7 <<https://i.imgur.com/FULQNtu.gif>>
8+ .
8license: BSD3
9license: BSD3
9license-file: LICENSE
10license-file: LICENSE
10author: Obsidian Systems LLC
11author: Obsidian Systems LLC
@@ -12,88 +13,50 @@ maintainer: maintainer@obsidian.systems
12copyright: 2020 Obsidian Systems LLC
13copyright: 2020 Obsidian Systems LLC
13category: FRP
14category: FRP
14build-type: Simple
15build-type: Simple
15−cabal-version: 1.18
16+cabal-version: >=1.18
16−extra-source-files:
17+extra-source-files: README.md
17− README.md
18− ChangeLog.md
18+ ChangeLog.md
19−extra-doc-files: doc/tasks.png
19+extra-doc-files: doc/welcome.gif
20+ , doc/tasks.png
20−tested-with:
21+tested-with: GHC ==8.8.3 || ==8.6.5 || ==8.4.4
21− GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
22−
23−source-repository head
24− type: git
25− location: https://github.com/reflex-frp/reflex-vty
26
22
27library
23library
28 exposed-modules: Reflex.Vty
24 exposed-modules: Reflex.Vty
29 , Reflex.Vty.Host
25 , Reflex.Vty.Host
30 , Reflex.Vty.Widget
26 , Reflex.Vty.Widget
31− , Reflex.Vty.Widget.Box
32 , Reflex.Vty.Widget.Input
27 , Reflex.Vty.Widget.Input
33− , Reflex.Vty.Widget.Input.Mouse
34 , Reflex.Vty.Widget.Input.Text
28 , Reflex.Vty.Widget.Input.Text
35 , Reflex.Vty.Widget.Layout
29 , Reflex.Vty.Widget.Layout
36− , Reflex.Vty.Widget.Split
37− , Reflex.Vty.Widget.Text
38 , Data.Text.Zipper
30 , Data.Text.Zipper
31+ , Reflex.Class.Switchable
39 , Reflex.Spider.Orphans
32 , Reflex.Spider.Orphans
40 , Control.Monad.NodeId
33 , Control.Monad.NodeId
41 build-depends:
34 build-depends:
42− base >= 4.10.0 && < 4.15,
35+ base >= 4.10.0 && < 4.14,
43− bimap >= 0.3.3 && < 0.5,
36+ bimap >= 0.3.3 && < 0.4,
44− containers >= 0.5.0 && < 0.7,
37+ containers >= 0.5.0 && < 0.7,
45− mtl >= 2.2.2 && < 2.3,
38+ mtl >= 2.2.2 && < 2.3,
46− transformers >= 0.5.5 && < 0.6,
39+ transformers >= 0.5.5 && < 0.6,
47− stm >= 2.4 && < 2.6,
40+ stm >= 2.4 && < 2.6,
48− data-default >= 0.7.1 && < 0.8,
41+ data-default >= 0.7.1 && < 0.8,
49− dependent-map >= 0.4 && < 0.5,
42+ dependent-map >= 0.2.4 && < 0.4,
50− text >= 1.2.3 && < 1.3,
43+ text >= 1.2.3 && < 1.3,
44+ text-icu >= 0.7 && < 0.8,
51− dependent-sum >= 0.7 && < 0.8,
45+ dependent-sum >= 0.3 && < 0.7,
52− exception-transformers >= 0.4.0 && < 0.5,
46+ exception-transformers >= 0.4.0 && < 0.5,
53− mmorph >= 1.1 && < 1.2,
54− ordered-containers >= 0.2.2 && < 0.3,
55− primitive >= 0.6.3 && < 0.8,
47+ primitive >= 0.6.3 && < 0.8,
56− ref-tf >= 0.4.0 && < 0.5,
48+ ref-tf >= 0.4.0 && < 0.5,
57− reflex >= 0.8 && < 0.9,
49+ reflex >= 0.6.2 && < 0.8,
58− time >= 1.8.0 && < 1.10,
50+ time >= 1.8.0 && < 1.10,
59− vty >= 5.28 && < 5.29
51+ vty >= 5.21 && < 5.29
60 hs-source-dirs: src
52 hs-source-dirs: src
61 default-language: Haskell2010
53 default-language: Haskell2010
62 ghc-options: -Wall
54 ghc-options: -Wall
63− default-extensions:
64− BangPatterns
65− ConstraintKinds
66− CPP
67− DataKinds
68− DefaultSignatures
69− DeriveFunctor
70− DeriveGeneric
71− FlexibleContexts
72− FlexibleInstances
73− FunctionalDependencies
74− GADTs
75− GeneralizedNewtypeDeriving
76− KindSignatures
77− LambdaCase
78− MultiParamTypeClasses
79− MultiWayIf
80− OverloadedStrings
81− PatternGuards
82− PolyKinds
83− QuasiQuotes
84− RankNTypes
85− RecursiveDo
86− ScopedTypeVariables
87− StandaloneDeriving
88− TemplateHaskell
89− TupleSections
90− TypeApplications
91− TypeFamilies
92
55
93executable example
56executable example
94 hs-source-dirs: src-bin
57 hs-source-dirs: src-bin
95 main-is: example.hs
58 main-is: example.hs
96− ghc-options: -threaded -Wall
59+ ghc-options: -threaded
97 build-depends:
60 build-depends:
98 base,
61 base,
99 containers,
62 containers,
@@ -104,51 +67,7 @@ executable example
104 transformers,
67 transformers,
105 vty
68 vty
106 default-language: Haskell2010
69 default-language: Haskell2010
107− other-modules: Example.CPU
108− default-extensions:
109− BangPatterns
110− ConstraintKinds
111− CPP
112− DataKinds
113− DefaultSignatures
114− DeriveFunctor
115− DeriveGeneric
116− FlexibleContexts
117− FlexibleInstances
118− FunctionalDependencies
119− GADTs
120− GeneralizedNewtypeDeriving
121− KindSignatures
122− LambdaCase
123− MultiParamTypeClasses
124− MultiWayIf
125− OverloadedStrings
126− PatternGuards
127− PolyKinds
128− QuasiQuotes
129− RankNTypes
130− RecursiveDo
131− ScopedTypeVariables
132− StandaloneDeriving
133− TemplateHaskell
134− TupleSections
135− TypeApplications
136− TypeFamilies
137−
138
70
139−test-suite reflex-vty-test
71+source-repository head
140− hs-source-dirs: test
72+ type: git
141− main-is: Spec.hs
73+ location: https://github.com/reflex-frp/reflex-vty
142− type: exitcode-stdio-1.0
143− ghc-options: -threaded
144− other-modules:
145− Data.Text.ZipperSpec
146− build-depends:
147− base,
148− reflex,
149− containers,
150− reflex-vty,
151− text,
152− extra,
153− hspec >= 2.7 && < 2.8
154− default-language: Haskell2010
release.nix+5−15
@@ -1,16 +1,6 @@
1−{ reflex-platform ? import ./reflex-platform {}
1+{ p ? import ./reflex-platform/stable {}
2}:
2}:
3+let
3−let inherit (reflex-platform.nixpkgs.haskell) lib;
4+ inherit (p.nixpkgs) lib;
4− ghc = reflex-platform.ghc.override {
5+ platforms = p.thunkSet ./reflex-platform;
5− overrides = self: super: {
6− vty = self.callHackage "vty" "5.28" {};
7− ansi-terminal = self.callHackage "ansi-terminal" "0.10.3" {};
8− ansi-wl-pprint = self.callHackage "ansi-wl-pprint" "0.6.9" {};
9− test-framework = lib.doJailbreak super.test-framework;
10− };
11− };
12−in
13−{
14− reflex-vty =
15− ghc.callCabal2nix "reflex-vty" ./. {};
6+in (lib.mapAttrs (name: platform: (import platform {}).ghc.callCabal2nix "reflex-vty" ./. {})) platforms
16−}
shell.nixdeleted−1
@@ -1 +0,0 @@
1−(import ./release.nix {}).reflex-vty.env
src-bin/Example/CPU.hsdeleted−231
@@ -1,231 +0,0 @@
1−{-|
2− Description: A CPU usage indicator
3−-}
4−module Example.CPU where
5−
6−import Control.Exception
7−import Control.Monad.Fix
8−import Control.Monad.IO.Class
9−import Data.Ratio
10−import Data.Time
11−import Data.Word
12−import qualified Data.Text as T
13−import qualified Graphics.Vty as V
14−import Text.Printf
15−
16−import Reflex
17−import Reflex.Vty
18−
19−-- | Each constructor represents a cpu statistic column as presented in @/proc/stat@
20−data CpuStat
21− = CpuStat_User
22− | CpuStat_Nice
23− | CpuStat_System
24− | CpuStat_Idle
25− | CpuStat_Iowait
26− | CpuStat_Irq
27− | CpuStat_Softirq
28− | CpuStat_Steal
29− | CpuStat_Guest
30− | CpuStat_GuestNice
31− deriving (Show, Read, Eq, Ord, Enum, Bounded)
32−
33−-- | Read @/proc/stat@
34−getCpuStat :: IO (Maybe (CpuStat -> Word64))
35−getCpuStat = do
36− s <- readFile "/proc/stat"
37− _ <- evaluate $ length s -- Make readFile strict
38− pure $ do
39− cpuSummaryLine : _ <- pure $ lines s
40− [user, nice, system, idle, iowait, irq, softirq, steal, guest, guestNice] <- pure $ map read $ words $ drop 4 cpuSummaryLine
41− pure $ \case
42− CpuStat_User -> user
43− CpuStat_Nice -> nice
44− CpuStat_System -> system
45− CpuStat_Idle -> idle
46− CpuStat_Iowait -> iowait
47− CpuStat_Irq -> irq
48− CpuStat_Softirq -> softirq
49− CpuStat_Steal -> steal
50− CpuStat_Guest -> guest
51− CpuStat_GuestNice -> guestNice
52−
53−sumStats :: (CpuStat -> Word64) -> [CpuStat] -> Word64
54−sumStats get stats = sum $ get <$> stats
55−
56−-- | user + nice + system + irq + softirq + steal
57−nonIdleStats :: [CpuStat]
58−nonIdleStats =
59− [ CpuStat_User
60− , CpuStat_Nice
61− , CpuStat_System
62− , CpuStat_Irq
63− , CpuStat_Softirq
64− , CpuStat_Steal
65− ]
66−
67−-- | idle + iowait
68−idleStats :: [CpuStat]
69−idleStats =
70− [ CpuStat_Idle
71− , CpuStat_Iowait
72− ]
73−
74−-- | Draws the cpu usage percent as a live-updating bar graph. The output should look like:
75−--
76−-- > ╔══════ CPU Usage: 38% ══════╗
77−-- > ║ ║
78−-- > ║ ║
79−-- > ║ ║
80−-- > ║ ║
81−-- > ║ ║
82−-- > ║ ║
83−-- > ║█████████████████████████████║
84−-- > ║█████████████████████████████║
85−-- > ║█████████████████████████████║
86−-- > ║█████████████████████████████║
87−-- > ╚═════════════════════════════╝
88−--
89−cpuStats
90− :: ( Reflex t
91− , MonadFix m
92− , MonadHold t m
93− , MonadIO (Performable m)
94− , MonadIO m
95− , PerformEvent t m
96− , PostBuild t m
97− , TriggerEvent t m
98− , HasDisplayRegion t m
99− , HasImageWriter t m
100− , HasLayout t m
101− , HasFocus t m
102− , HasInput t m
103− , HasFocusReader t m, HasTheme t m
104− )
105− => m ()
106−cpuStats = do
107− tick <- tickLossy 0.25 =<< liftIO getCurrentTime
108− cpuStat :: Event t (Word64, Word64) <- fmap (fmapMaybe id) $
109− performEvent $ ffor tick $ \_ -> do
110− get <- liftIO getCpuStat
111− pure $ case get of
112− Nothing -> Nothing
113− Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats)
114− active <- foldDyn cpuPercentStep ((0, 0), 0) cpuStat
115− let pct = fmap snd active
116− chart pct
117−
118−chart
119− :: ( MonadFix m
120− , HasFocus t m
121− , HasLayout t m
122− , HasImageWriter t m
123− , HasInput t m
124− , HasDisplayRegion t m
125− , HasFocusReader t m, HasTheme t m
126− )
127− => Dynamic t (Ratio Word64) -> m ()
128−chart pct = do
129− let title = ffor pct $ \x -> mconcat
130− [ " CPU Usage: "
131− , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int))
132− , "% "
133− ]
134− boxTitle (pure doubleBoxStyle) (current title) $ col $ do
135− grout flex blank
136− dh <- displayHeight
137− let heights = calcRowHeights <$> dh <*> pct
138− quarters = fst <$> heights
139− eighths = snd <$> heights
140− eighthRow = ffor eighths $ \x -> if x == 0 then 0 else 1
141− grout (fixed eighthRow) $ fill' (current $ eighthBlocks <$> eighths) $ current $
142− ffor quarters $ \q ->
143− if | _quarter_fourth q > 0 -> red
144− | _quarter_third q > 0 -> orange
145− | _quarter_second q > 0 -> yellow
146− | otherwise -> white
147− grout (fixed $ _quarter_fourth <$> quarters) $ fill' (pure '█') (pure red)
148− grout (fixed $ _quarter_third <$> quarters) $ fill' (pure '█') (pure orange)
149− grout (fixed $ _quarter_second <$> quarters) $ fill' (pure '█') (pure yellow)
150− grout (fixed $ _quarter_first <$> quarters) $ fill' (pure '█') (pure white)
151− where
152− -- Calculate number of full rows, height of partial row
153− calcRowHeights :: Int -> Ratio Word64 -> (Quarter Int, Int)
154− calcRowHeights h r =
155− let (full, leftovers) = divMod (numerator r * fromIntegral h) (denominator r)
156− partial = ceiling $ 8 * (leftovers % denominator r)
157− quarter = ceiling $ fromIntegral h / (4 :: Double)
158− n = fromIntegral full
159− in if | n <= quarter ->
160− (Quarter n 0 0 0, partial)
161− | n <= (2 * quarter) ->
162− (Quarter quarter (n - quarter) 0 0, partial)
163− | n <= (3 * quarter) ->
164− (Quarter quarter quarter (n - (2 * quarter)) 0, partial)
165− | otherwise ->
166− (Quarter quarter quarter quarter (n - (3 * quarter)), partial)
167− fill' bc attr = do
168− dw <- displayWidth
169− dh <- displayHeight
170− let fillImg =
171− (\w h c a -> [V.charFill a c w h])
172− <$> current dw
173− <*> current dh
174− <*> bc
175− <*> attr
176− tellImages fillImg
177− color :: Int -> Int -> Int -> V.Color
178− color = V.rgbColor
179− red = V.withForeColor V.defAttr $ color 255 0 0
180− orange = V.withForeColor V.defAttr $ color 255 165 0
181− yellow = V.withForeColor V.defAttr $ color 255 255 0
182− white = V.withForeColor V.defAttr $ color 255 255 255
183−
184−data Quarter a = Quarter
185− { _quarter_first :: a
186− , _quarter_second :: a
187− , _quarter_third :: a
188− , _quarter_fourth :: a
189− }
190−
191−eighthBlocks :: (Eq a, Num a, Ord a) => a -> Char
192−eighthBlocks n =
193− if
194− | n <= 0 -> ' '
195− | n == 1 -> '▁'
196− | n == 2 -> '▂'
197− | n == 3 -> '▃'
198− | n == 4 -> '▄'
199− | n == 5 -> '▅'
200− | n == 6 -> '▆'
201− | n == 7 -> '▇'
202− | otherwise -> '█'
203−
204−-- | Determine the current percentage usage according to this algorithm:
205−--
206−-- PrevIdle = previdle + previowait
207−-- Idle = idle + iowait
208−--
209−-- PrevNonIdle = prevuser + prevnice + prevsystem + previrq + prevsoftirq + prevsteal
210−-- NonIdle = user + nice + system + irq + softirq + steal
211−--
212−-- PrevTotal = PrevIdle + PrevNonIdle
213−-- Total = Idle + NonIdle
214−--
215−-- totald = Total - PrevTotal
216−-- idled = Idle - PrevIdle
217−--
218−-- CPU_Percentage = (totald - idled)/totald
219−--
220−-- Source: https://stackoverflow.com/questions/23367857/accurate-calculation-of-cpu-usage-given-in-percentage-in-linux
221−cpuPercentStep
222− :: (Word64, Word64) -- Current active, Current idle
223− -> ((Word64, Word64), Ratio Word64) -- (Previous idle, Previous total), previous percent
224− -> ((Word64, Word64), Ratio Word64) -- (New idle, new total), percent
225−cpuPercentStep (nonidle, idle) ((previdle, prevtotal), _) =
226− let total = idle + nonidle
227− idled = idle - previdle
228− totald = total - prevtotal
229− in ( (idle, total)
230− , (totald - idled) % totald
231− )
src-bin/example.hs+151−213
@@ -1,151 +1,130 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE RecursiveDo #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# OPTIONS_GHC -threaded #-}
11+
1import Control.Applicative
12import Control.Applicative
2import Control.Monad
13import Control.Monad
3import Control.Monad.Fix
14import Control.Monad.Fix
4−import Data.Functor
15+import Control.Monad.NodeId
5import Data.Functor.Misc
16import Data.Functor.Misc
6import Data.Map (Map)
17import Data.Map (Map)
18+import Data.Maybe
7import qualified Data.Map as Map
19import qualified Data.Map as Map
8−import qualified Data.Set as Set
9import Data.Text (Text)
20import Data.Text (Text)
10import qualified Data.Text as T
21import qualified Data.Text as T
11import qualified Data.Text.Zipper as TZ
22import qualified Data.Text.Zipper as TZ
12import qualified Graphics.Vty as V
23import qualified Graphics.Vty as V
13import Reflex
24import Reflex
14import Reflex.Network
25import Reflex.Network
26+import Reflex.Class.Switchable
15import Reflex.Vty
27import Reflex.Vty
16
28
17−import Example.CPU
18−
19−type VtyExample t m =
20− ( MonadFix m
21− , Reflex t
22− , HasInput t m
23− , HasImageWriter t m
24− , HasDisplayRegion t m
25− , HasFocus t m
26− , HasFocusReader t m, HasTheme t m
27− )
28−
29−type Manager t m =
30− ( HasLayout t m
31− , HasFocus t m
32− )
33−
34data Example = Example_TextEditor
29data Example = Example_TextEditor
35 | Example_Todo
30 | Example_Todo
36 | Example_ScrollableTextDisplay
31 | Example_ScrollableTextDisplay
37− | Example_ClickButtonsGetEmojis
38− | Example_CPUStat
39 deriving (Show, Read, Eq, Ord, Enum, Bounded)
32 deriving (Show, Read, Eq, Ord, Enum, Bounded)
40
33
41−withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
42−withCtrlC f = do
43− inp <- input
44− f
45− return $ fforMaybe inp $ \case
46− V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
47− _ -> Nothing
48−
49−darkTheme :: V.Attr
50−darkTheme = V.Attr {
51− V.attrStyle = V.SetTo V.standout
52− , V.attrForeColor = V.SetTo V.black
53− , V.attrBackColor = V.Default
54− , V.attrURL = V.Default
55−}
56−
57main :: IO ()
34main :: IO ()
58−main = mainWidget $ withCtrlC $ do
35+main = mainWidget $ do
59− initManager_ $ do
60− tabNavigation
61− let gf = grout . fixed
62− t = tile flex
63− buttons = col $ do
64− gf 3 $ col $ do
65− gf 1 $ text "Select an example."
66− gf 1 $ text "Esc will bring you back here."
67− gf 1 $ text "Ctrl+c to quit."
68− a <- t $ textButtonStatic def "Todo List"
69− b <- t $ textButtonStatic def "Text Editor"
70− c <- t $ textButtonStatic def "Scrollable text display"
71− d <- t $ textButtonStatic def "Clickable buttons"
72− e <- t $ textButtonStatic def "CPU Usage"
73− return $ leftmost
74− [ Left Example_Todo <$ a
75− , Left Example_TextEditor <$ b
76− , Left Example_ScrollableTextDisplay <$ c
77− , Left Example_ClickButtonsGetEmojis <$ d
78− , Left Example_CPUStat <$ e
79− ]
80− let escapable w = do
81− void w
82− i <- input
83− return $ fforMaybe i $ \case
84− V.EvKey V.KEsc [] -> Just $ Right ()
85− _ -> Nothing
86− rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
87− Left Example_Todo -> escapable taskList
88− Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
89− Left Example_ScrollableTextDisplay -> escapable scrolling
90− Left Example_ClickButtonsGetEmojis -> escapable easyExample
91− Left Example_CPUStat -> escapable cpuStats
92− Right () -> buttons
93− return ()
94−
95−-- * Mouse button and emojis example
96−easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
97−easyExample = do
98− row $ grout (fixed 39) $ col $ do
99− (a1,b1,c1) <- grout (fixed 3) $ row $ do
100− a <- tile flex $ btn "POTATO"
101− b <- tile flex $ btn "TOMATO"
102− c <- tile flex $ btn "EGGPLANT"
103− return (a,b,c)
104− (a2,b2,c2) <- grout (fixed 3) $ row $ do
105− a <- tile flex $ btn "CHEESE"
106− b <- tile flex $ btn "BEES"
107− c <- tile flex $ btn "MY KNEES"
108− return (a,b,c)
109− (a3,b3,c3) <- grout (fixed 3) $ row $ do
110− a <- tile flex $ btn "TIME"
111− b <- tile flex $ btn "RHYME"
112− c <- tile flex $ btn "A BIG CRIME"
113− return (a,b,c)
114− tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do
115− outputDyn <- foldDyn (<>) "" $ mergeWith (<>)
116− [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
117− text (current outputDyn)
118− tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map."
119 inp <- input
36 inp <- input
37+ let buttons = col $ do
38+ fixed 4 $ col $ do
39+ fixed 1 $ text "Select an example."
40+ fixed 1 $ text "Esc will bring you back here."
41+ fixed 1 $ text "Ctrl+c to quit."
42+ a <- fixed 5 $ textButtonStatic def "Todo List"
43+ b <- fixed 5 $ textButtonStatic def "Text Editor"
44+ c <- fixed 5 $ textButtonStatic def "Scrollable text display"
45+ return $ leftmost
46+ [ Left Example_Todo <$ a
47+ , Left Example_TextEditor <$ b
48+ , Left Example_ScrollableTextDisplay <$ c
49+ ]
50+ escapable w = do
51+ void w
52+ i <- input
53+ return $ fforMaybe i $ \case
54+ V.EvKey V.KEsc [] -> Just $ Right ()
55+ _ -> Nothing
56+ rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
57+ Left Example_TextEditor -> escapable testBoxes
58+ Left Example_Todo -> escapable taskList
59+ Left Example_ScrollableTextDisplay -> escapable scrolling
60+ Right () -> buttons
120 return $ fforMaybe inp $ \case
61 return $ fforMaybe inp $ \case
121 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
62 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
122 _ -> Nothing
63 _ -> Nothing
123− where
64+
124− btn label = do
125− let cfg = def { _buttonConfig_focusStyle = pure doubleBoxStyle }
126− buttonClick <- textButtonStatic cfg label
127− keyPress <- keyCombos $ Set.fromList
128− [ (V.KEnter, [])
129− , (V.KChar ' ', [])
130− ]
131− pure $ leftmost [() <$ buttonClick, () <$ keyPress]
132−
133−-- * Task list example
134taskList
65taskList
135− :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
66+ :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
136− => m ()
67+ => VtyWidget t m ()
137−taskList = col $ do
68+taskList = do
69+ let btn = textButtonStatic def "Add another task"
70+ inp <- input
138 let todos0 =
71 let todos0 =
139 [ Todo "Find reflex-vty" True
72 [ Todo "Find reflex-vty" True
140 , Todo "Become functional reactive" False
73 , Todo "Become functional reactive" False
141 , Todo "Make vty apps" False
74 , Todo "Make vty apps" False
142 ]
75 ]
143− btn = textButtonStatic def "Add another task"
76+ rec let todos' = todos todos0 $ leftmost
144− enter <- fmap (const ()) <$> key V.KEnter
77+ [ () <$ e
145− rec void $ grout flex $ todos todos0 $ enter <> click
78+ , fforMaybe inp $ \case
146− click <- tile (fixed 3) btn
79+ V.EvKey V.KEnter [] -> Just ()
80+ _ -> Nothing
81+ ]
82+ (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
83+ splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
147 return ()
84 return ()
148
85
86+testBoxes
87+ :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
88+ => VtyWidget t m ()
89+testBoxes = do
90+ dw <- displayWidth
91+ dh <- displayHeight
92+ let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
93+ region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
94+ pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
95+ _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
96+ let cfg = def
97+ { _textInputConfig_initialValue =
98+ "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."
99+ }
100+ textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
101+ multilineTextInput cfg
102+ dragBox = boxStatic roundedBoxStyle dragTest
103+ in splitVDrag (hRule doubleBoxStyle) textBox dragBox
104+ return ()
105+ where
106+ div' :: (Integral a, Applicative f) => f a -> f a -> f a
107+ div' = liftA2 div
108+
109+debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
110+debugFocus = do
111+ f <- focus
112+ text $ T.pack . show <$> current f
113+
114+debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
115+debugInput = do
116+ lastEvent <- hold "No event yet" . fmap show =<< input
117+ text $ T.pack <$> lastEvent
118+
119+dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
120+dragTest = do
121+ lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
122+ text $ T.pack <$> lastEvent
123+
124+testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()
125+testStringBox = boxStatic singleBoxStyle .
126+ text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
127+
149data Todo = Todo
128data Todo = Todo
150 { _todo_label :: Text
129 { _todo_label :: Text
151 , _todo_done :: Bool
130 , _todo_done :: Bool
@@ -156,128 +135,87 @@ data TodoOutput t = TodoOutput
156 { _todoOutput_todo :: Dynamic t Todo
135 { _todoOutput_todo :: Dynamic t Todo
157 , _todoOutput_delete :: Event t ()
136 , _todoOutput_delete :: Event t ()
158 , _todoOutput_height :: Dynamic t Int
137 , _todoOutput_height :: Dynamic t Int
159− , _todoOutput_focusId :: FocusId
160 }
138 }
161
139
140+instance Reflex t => Switchable t (TodoOutput t) where
141+ switching t0 e = TodoOutput
142+ <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
143+ <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
144+ <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)
145+
162todo
146todo
163− :: (VtyExample t m, Manager t m, MonadHold t m)
147+ :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
164 => Todo
148 => Todo
165− -> m (TodoOutput t)
149+ -> VtyWidget t m (TodoOutput t)
166−todo t0 = row $ do
150+todo t0 = do
167− let toggleKeys = Set.fromList
151+ w <- displayWidth
168− [ (V.KChar ' ', [V.MCtrl])
152+ rec let checkboxWidth = 3
169− , (V.KChar '@', [V.MCtrl])
153+ checkboxRegion = DynRegion 0 0 checkboxWidth 1
170− ]
154+ labelHeight = _textInput_lines ti
171− anyChildFocused $ \focused -> do
155+ labelWidth = w - 1 - checkboxWidth
172− toggleE <- keyCombos toggleKeys
156+ labelLeft = checkboxWidth + 1
173− filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do
157+ labelTop = constDyn 0
174− rec let cfg = def
158+ labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
175− { _checkboxConfig_setValue = setVal
176− }
177− value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0
159+ value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
178− let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE
160+ (ti, d) <- pane labelRegion (pure True) $ do
179− (fid, (ti, d)) <- tile' flex $ do
180− i <- input
161+ i <- input
181− v <- textInput $ def
182− { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
162+ v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
183− let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
163+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
184− return (v, deleteSelf)
164+ return (v, deleteSelf)
185− return $ TodoOutput
165+ return $ TodoOutput
186− { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
166+ { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
187− , _todoOutput_delete = d
167+ , _todoOutput_delete = d
188− , _todoOutput_height = _textInput_lines ti
168+ , _todoOutput_height = _textInput_lines ti
189− , _todoOutput_focusId = fid
190− }
169+ }
191 where
170 where
192 backspaceOnEmpty v = \case
171 backspaceOnEmpty v = \case
193 V.EvKey V.KBS _ | T.null v -> Just ()
172 V.EvKey V.KBS _ | T.null v -> Just ()
194 _ -> Nothing
173 _ -> Nothing
195
174
175+scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m ()
176+scrolling = col $ do
177+ fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:"
178+ out <- fixed 5 $ boxStatic def $ scrollableText never $ "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."
179+ fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
180+
196todos
181todos
197 :: forall t m.
182 :: forall t m.
198 ( MonadHold t m
183 ( MonadHold t m
199− , Manager t m
184+ , MonadFix m
200− , VtyExample t m
185+ , Reflex t
201 , Adjustable t m
186 , Adjustable t m
187+ , NotReady t m
202 , PostBuild t m
188 , PostBuild t m
189+ , MonadNodeId m
203 )
190 )
204 => [Todo]
191 => [Todo]
205 -> Event t ()
192 -> Event t ()
206− -> m (Dynamic t (Map Int (TodoOutput t)))
193+ -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
207todos todos0 newTodo = do
194todos todos0 newTodo = do
208 let todosMap0 = Map.fromList $ zip [0..] todos0
195 let todosMap0 = Map.fromList $ zip [0..] todos0
196+ rec tabNav <- tabNavigation
197+ let insertNav = 1 <$ insert
198+ nav = leftmost [tabNav, insertNav]
199+ tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1}
200+ listOut <- runLayout (pure Orientation_Column) 0 nav $
209− rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
201+ listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do
210− to <- todo t
211− let sel = select selectOnDelete $ Const2 k
202+ let sel = select selectOnDelete $ Const2 k
203+ click <- void <$> mouseDown V.BLeft
212− pb <- getPostBuild
204+ pb <- getPostBuild
213− requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
205+ let focusMe = leftmost [ click, sel, pb ]
214− pure to
206+ r <- todo t
215− let delete = flip Map.singleton Nothing <$> todoDelete
207+ return (focusMe, r)
216− todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
208+ let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
217− insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
218− Nothing -> Map.singleton 0 $ Just $ Todo "" False
219− Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
220 updates = leftmost [insert, delete]
209 updates = leftmost [insert, delete]
221 todoDelete = switch . current $
210 todoDelete = switch . current $
222 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
211 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
223−
212+ todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
213+ insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
214+ Nothing -> Map.singleton 0 $ Just $ Todo "" False
215+ Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
224 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
216 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
225 (\m k -> let (before, after) = Map.split k m
217 (\m k -> let (before, after) = Map.split k m
226 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
218 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
227 (current todosMap)
219 (current todosMap)
228 todoDelete
220 todoDelete
229 return listOut
221 return listOut
230−
231−-- * Scrollable text example
232−
233−scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
234−scrolling = col $ do
235− grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
236− (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "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."
237− pb <- getPostBuild
238− requestFocus $ Refocus_Id fid <$ pb
239− grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
240−
241−-- * Text editor example with resizable boxes
242−
243−testBoxes
244− :: (MonadHold t m, VtyExample t m)
245− => m ()
246−testBoxes = do
247− dw <- displayWidth
248− dh <- displayHeight
249− let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
250− region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
251− pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
252− _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
253− let cfg = def
254− { _textInputConfig_initialValue =
255− "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."
256− }
257− textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
258− multilineTextInput cfg
259− dragBox = boxStatic roundedBoxStyle dragTest
260− in splitVDrag (hRule doubleBoxStyle) textBox dragBox
261− return ()
262− where
263− div' :: (Integral a, Applicative f) => f a -> f a -> f a
264− div' = liftA2 div
265−
266−debugFocus :: (VtyExample t m) => m ()
267−debugFocus = do
268− f <- focus
269− text $ T.pack . show <$> current f
270−
271−debugInput :: (VtyExample t m, MonadHold t m) => m ()
272−debugInput = do
273− lastEvent <- hold "No event yet" . fmap show =<< input
274− text $ T.pack <$> lastEvent
275−
276−dragTest :: (VtyExample t m, MonadHold t m) => m ()
277−dragTest = do
278− lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
279− text $ T.pack <$> lastEvent
280−
281−testStringBox :: VtyExample t m => m ()
282−testStringBox = boxStatic singleBoxStyle .
283− text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
src/Control/Monad/NodeId.hs+7−4
@@ -2,7 +2,12 @@
2Module: Control.Monad.NodeId
2Module: Control.Monad.NodeId
3Description: Monad providing a supply of unique identifiers
3Description: Monad providing a supply of unique identifiers
4-}
4-}
5+{-# LANGUAGE DefaultSignatures #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# Language UndecidableInstances #-}
10+{-# LANGUAGE UndecidableInstances #-}
6module Control.Monad.NodeId
11module Control.Monad.NodeId
7 ( NodeId
12 ( NodeId
8 , MonadNodeId (..)
13 , MonadNodeId (..)
@@ -10,7 +15,6 @@ module Control.Monad.NodeId
10 , runNodeIdT
15 , runNodeIdT
11 ) where
16 ) where
12
17
13−import Control.Monad.Morph
14import Control.Monad.Reader
18import Control.Monad.Reader
15import Control.Monad.Ref
19import Control.Monad.Ref
16import Data.IORef
20import Data.IORef
@@ -35,12 +39,10 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
35 deriving
39 deriving
36 ( Functor
40 ( Functor
37 , Applicative
41 , Applicative
38− , MFunctor
39 , Monad
42 , Monad
40 , MonadFix
43 , MonadFix
41 , MonadHold t
44 , MonadHold t
42 , MonadIO
45 , MonadIO
43− , MonadRef
44 , MonadReflexCreateTrigger t
46 , MonadReflexCreateTrigger t
45 , MonadSample t
47 , MonadSample t
46 , MonadTrans
48 , MonadTrans
@@ -48,6 +50,7 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
48 , PerformEvent t
50 , PerformEvent t
49 , PostBuild t
51 , PostBuild t
50 , TriggerEvent t
52 , TriggerEvent t
53+ , MonadRef
51 )
54 )
52
55
53instance MonadNodeId m => MonadNodeId (ReaderT x m)
56instance MonadNodeId m => MonadNodeId (ReaderT x m)
src/Data/Text/Zipper.hs+156−291
@@ -7,27 +7,26 @@ Description: A zipper for text documents that allows convenient editing and navi
7'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.
7'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.
8
8
9-}
9-}
10+{-# LANGUAGE BangPatterns #-}
11+{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE LambdaCase #-}
13+{-# LANGUAGE OverloadedStrings #-}
10module Data.Text.Zipper where
14module Data.Text.Zipper where
11
15
12−import Prelude
13−
14−import Control.Exception (assert)
15−import Control.Monad.State (evalState, forM, get, put)
16import Data.Char (isSpace)
16import Data.Char (isSpace)
17import Data.Map (Map)
17import Data.Map (Map)
18+import qualified Data.Map as Map
18import Data.Maybe (fromMaybe)
19import Data.Maybe (fromMaybe)
19import Data.String
20import Data.String
21+import Control.Monad.State (evalState, forM, get, put)
22+
20import Data.Text (Text)
23import Data.Text (Text)
24+import qualified Data.Text as T
25+import Data.Text.ICU.Char
21import Data.Text.Internal (Text(..), text)
26import Data.Text.Internal (Text(..), text)
22import Data.Text.Internal.Fusion (stream)
27import Data.Text.Internal.Fusion (stream)
23import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
28import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
24import Data.Text.Unsafe
29import Data.Text.Unsafe
25−import qualified Data.List as L
26−import qualified Data.Map as Map
27−import qualified Data.Text as T
28−
29−import Graphics.Text.Width (wcwidth)
30−
31
30
32-- | A zipper of the logical text input contents (the "document"). The lines
31-- | A zipper of the logical text input contents (the "document"). The lines
33-- before the line containing the cursor are stored in reverse order.
32-- before the line containing the cursor are stored in reverse order.
@@ -170,7 +169,7 @@ deleteLeftWord (TextZipper lb b a la) =
170-- | Insert up to n spaces to get to the next logical column that is a multiple of n
169-- | Insert up to n spaces to get to the next logical column that is a multiple of n
171tab :: Int -> TextZipper -> TextZipper
170tab :: Int -> TextZipper -> TextZipper
172tab n z@(TextZipper _ b _ _) =
171tab n z@(TextZipper _ b _ _) =
173− insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z
172+ insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z
174
173
175-- | The plain text contents of the zipper
174-- | The plain text contents of the zipper
176value :: TextZipper -> Text
175value :: TextZipper -> Text
@@ -193,319 +192,186 @@ fromText = flip insert empty
193data Span tag = Span tag Text
192data Span tag = Span tag Text
194 deriving (Show)
193 deriving (Show)
195
194
196−-- | Text alignment type
197−data TextAlignment =
198− TextAlignment_Left
199− | TextAlignment_Right
200− | TextAlignment_Center
201− deriving (Eq, Show)
202−
203−-- A map from the index (row) of display line to (fst,snd)
204−-- fst: leading empty spaces from left (may be negative) to adjust for alignment
205−-- snd: the text offset from the beginning of the document
206−-- to the first character of the display line
207−type OffsetMapWithAlignment = Map Int (Int, Int)
208−
209−-- helper type representing a single visual line that may be part of a wrapped logical line
210−data WrappedLine = WrappedLine
211− { _wrappedLines_text :: Text
212− , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character
213− , _wrappedLines_offset :: Int -- ^ offset from beginning of line
214− }
215− deriving (Eq, Show)
216−
217-- | Information about the document as it is displayed (i.e., post-wrapping)
195-- | Information about the document as it is displayed (i.e., post-wrapping)
218data DisplayLines tag = DisplayLines
196data DisplayLines tag = DisplayLines
219 { _displayLines_spans :: [[Span tag]]
197 { _displayLines_spans :: [[Span tag]]
220− , _displayLines_offsetMap :: OffsetMapWithAlignment
198+ , _displayLines_offsetMap :: Map Int Int
221− , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
199+ , _displayLines_cursorY :: Int
222 }
200 }
223 deriving (Show)
201 deriving (Show)
224
202
225−-- | Split a 'Text' at the given column index. For example
226−--
227−-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
228−--
229−-- because the first character has a width of two (see 'charWidth' for more on that).
230−splitAtWidth :: Int -> Text -> (Text, Text)
231−splitAtWidth n t@(Text arr off len)
232− | n <= 0 = (T.empty, t)
233− | n >= textWidth t = (t, T.empty)
234− | otherwise = let k = toLogicalIndex n t
235− in (text arr off k, text arr (off+k) (len-k))
236−
237−toLogicalIndex :: Int -> Text -> Int
238−toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
239− where loop !i !cnt
240− | i >= len' || cnt + w > n' = i
241− | otherwise = loop (i+d) (cnt + w)
242− where Iter c d = iter t' i
243− w = charWidth c
244−
245−-- | Takes the given number of columns of characters. For example
246−--
247−-- > takeWidth 3 "ᄀabc" == "ᄀa"
248−--
249−-- because the first character has a width of 2 (see 'charWidth' for more on that).
250−-- This function will not take a character if its width exceeds the width it seeks to take.
251−takeWidth :: Int -> Text -> Text
252−takeWidth n = fst . splitAtWidth n
253−
254−-- | Drops the given number of columns of characters. For example
255−--
256−-- > dropWidth 2 "ᄀabc" == "abc"
257−--
258−-- because the first character has a width of 2 (see 'charWidth' for more on that).
259−-- This function will not drop a character if its width exceeds the width it seeks to drop.
260−dropWidth :: Int -> Text -> Text
261−dropWidth n = snd . splitAtWidth n
262−
263−-- | Get the display width of a 'Char'. "Full width" and "wide" characters
264−-- take two columns and everything else takes a single column. See
265−-- <https://www.unicode.org/reports/tr11/> for more information
266−-- This is implemented using wcwidth from Vty such that it matches what will
267−-- be displayed on the terminal. Note that this method can change depending
268−-- on how vty is configed. Please see vty documentation for details.
269−charWidth :: Char -> Int
270−charWidth = wcwidth
271−
272−-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
273−spansWidth :: [Span tag] -> Int
274−spansWidth = sum . map (\(Span _ t) -> textWidth t)
275−
276−-- | Get the length (number of characters) of the text in a set of 'Span's
277−spansLength :: [Span tag] -> Int
278−spansLength = sum . map (\(Span _ t) -> T.length t)
279−
280−-- | Compute the width of some 'Text', taking into account fullwidth
281−-- unicode forms.
282−textWidth :: Text -> Int
283−textWidth t = widthI (stream t)
284−
285−-- | Compute the width of a stream of characters, taking into account
286−-- fullwidth unicode forms.
287−widthI :: Stream Char -> Int
288−widthI (Stream next s0 _len) = loop_length 0 s0
289− where
290− loop_length !z s = case next s of
291− Done -> z
292− Skip s' -> loop_length z s'
293− Yield c s' -> loop_length (z + charWidth c) s'
294−{-# INLINE[0] widthI #-}
295−
296−-- | Compute the logical index position of a stream of characters from a visual
297−-- position taking into account fullwidth unicode forms.
298−charIndexAt :: Int -> Stream Char -> Int
299−charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
300− where
301− loop_length i !z s = case next s of
302− Done -> i
303− Skip s' -> loop_length i z s'
304− Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
305− w = z + charWidth c
306−{-# INLINE[0] charIndexAt #-}
307−
308−
309−
310−
311−-- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
312−-- 'Char's representing white space.
313−wordsWithWhitespace :: Text -> [Text]
314−wordsWithWhitespace t@(Text arr off len) = loop 0 0 False
315− where
316− loop !start !n !wasSpace
317− | n >= len = [Text arr (start+off) (n-start) | not (start == n)]
318− | isSpace c = loop start (n+d) True
319− | wasSpace = Text arr (start+off) (n-start) : loop n n False
320− | otherwise = loop start (n+d) False
321− where Iter c d = iter t n
322−{-# INLINE wordsWithWhitespace #-}
323−
324−-- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted
325−splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
326−splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
327− appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
328− appendOut [] t b = [(t,b)]
329− appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
330−
331− -- remove the last whitespace in output
332− modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
333− modifyOutForNewLine [] = error "should never happen"
334− modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
335− Nothing -> error "should never happen"
336− Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace
337−
338− loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
339− loop [] _ out = out
340− loop (x:xs) cumw out = r where
341− newWidth = textWidth x + cumw
342− r = if newWidth > maxWidth
343− then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)
344− -- if line runs over but character of splitting is whitespace then split on the whitespace
345− then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
346− in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True
347− else if cumw == 0
348− -- single word exceeds max width, so just split on the word
349− then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
350− in loop (t2:xs) 0 [] <> appendOut out t1 False
351− -- otherwise start a new line
352− else loop (x:xs) 0 [] <> modifyOutForNewLine out
353− else loop xs newWidth $ appendOut out x False
354−
355−
356−
357−-- | Wraps a logical line of text to fit within the given width. The first
358−-- wrapped line is offset by the number of columns provided. Subsequent wrapped
359−-- lines are not.
360−wrapWithOffsetAndAlignment
361− :: TextAlignment
362− -> Int -- ^ Maximum width
363− -> Int -- ^ Offset for first line
364− -> Text -- ^ Text to be wrapped
365− -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)
366−wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
367−wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where
368− -- we pad by offset amount with any non-space character which we will remove later so that no changes need to be made to splitWordsAtDisplayWidth
369− r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)
370− fmapfn (t,b) = case alignment of
371− TextAlignment_Left -> WrappedLine t b 0
372− TextAlignment_Right -> WrappedLine t b (maxWidth-l)
373− TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)
374− where l = textWidth t
375− r'' = case r' of
376− [] -> []
377− (x,b):xs -> (T.drop n x,b):xs
378− r = fmap fmapfn r''
379−
380−-- converts deleted eol spaces into logical lines
381−eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
382−eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))
383−
384−offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
385−offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
386−
387−offsetMapWithAlignment
388− :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines
389− -> OffsetMapWithAlignment
390−offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)
391− where
392− offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
393− maps <- forM x $ \(line,align) -> do
394− let l = T.length line
395− (dl, o) <- get
396− put (dl + 1, o + l)
397− return $ Map.singleton dl (align, o)
398− (dl, o) <- get
399− put (dl, o + 1)
400− -- add additional offset to last line in wrapped lines (for newline char)
401− return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps
402−
403−
404-- | Given a width and a 'TextZipper', produce a list of display lines
203-- | Given a width and a 'TextZipper', produce a list of display lines
405-- (i.e., lines of wrapped text) with special attributes applied to
204-- (i.e., lines of wrapped text) with special attributes applied to
406-- certain segments (e.g., the cursor). Additionally, produce the current
205-- certain segments (e.g., the cursor). Additionally, produce the current
407-- y-coordinate of the cursor and a mapping from display line number to text
206-- y-coordinate of the cursor and a mapping from display line number to text
408-- offset
207-- offset
409−displayLinesWithAlignment
208+displayLines
410− :: TextAlignment
411− -> Int -- ^ Width, used for wrapping
209+ :: Int -- ^ Width, used for wrapping
412 -> tag -- ^ Metadata for normal characters
210 -> tag -- ^ Metadata for normal characters
413 -> tag -- ^ Metadata for the cursor
211 -> tag -- ^ Metadata for the cursor
414 -> TextZipper -- ^ The text input contents and cursor state
212 -> TextZipper -- ^ The text input contents and cursor state
415 -> DisplayLines tag
213 -> DisplayLines tag
416−displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
214+displayLines width tag cursorTag (TextZipper lb b a la) =
417− let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
215+ let linesBefore :: [[Text]] -- The wrapped lines before the cursor line
418− linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
216+ linesBefore = map (wrapWithOffset width 0) $ reverse lb
419− linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
217+ linesAfter :: [[Text]] -- The wrapped lines after the cursor line
420− linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
218+ linesAfter = map (wrapWithOffset width 0) la
421−
219+ offsets :: Map Int Int
422− -- simulate trailing cursor character when computing OffsetMap
220+ offsets = offsetMap $ mconcat
423− afterWithCursor = if T.null a then " " else a
424− offsets :: OffsetMapWithAlignment
425− offsets = offsetMapWithAlignmentInternal $ mconcat
426 [ linesBefore
221 [ linesBefore
427− , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]
222+ , [wrapWithOffset width 0 $ b <> a]
428 , linesAfter
223 , linesAfter
429 ]
224 ]
430− flattenLines = concatMap (fmap _wrappedLines_text)
431− spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore
225+ spansBefore = map ((:[]) . Span tag) $ concat linesBefore
432− spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter
226+ spansAfter = map ((:[]) . Span tag) $ concat linesAfter
433 -- Separate the spans before the cursor into
227 -- Separate the spans before the cursor into
434 -- * spans that are on earlier display lines (though on the same logical line), and
228 -- * spans that are on earlier display lines (though on the same logical line), and
435 -- * spans that are on the same display line
229 -- * spans that are on the same display line
436−
437 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
230 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
438− initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b)
231+ initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)
439 -- Calculate the number of columns on the cursor's display line before the cursor
232 -- Calculate the number of columns on the cursor's display line before the cursor
440 curLineOffset = spansWidth spansCurLineBefore
233 curLineOffset = spansWidth spansCurLineBefore
441 -- Check whether the spans on the current display line are long enough that
234 -- Check whether the spans on the current display line are long enough that
442 -- the cursor has to go to the next line
235 -- the cursor has to go to the next line
443 cursorAfterEOL = curLineOffset == width
236 cursorAfterEOL = curLineOffset == width
444 cursorCharWidth = case T.uncons a of
237 cursorCharWidth = case T.uncons a of
445− Nothing -> 1
238+ Nothing -> 1
446 Just (c, _) -> charWidth c
239 Just (c, _) -> charWidth c
447−
448 -- Separate the span after the cursor into
240 -- Separate the span after the cursor into
449 -- * spans that are on the same display line, and
241 -- * spans that are on the same display line, and
450 -- * spans that are on later display lines (though on the same logical line)
242 -- * spans that are on later display lines (though on the same logical line)
451−
452 (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
243 (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
453 headTail $ case T.uncons a of
244 headTail $ case T.uncons a of
454 Nothing -> [[Span cursorTag " "]]
245 Nothing -> [[Span cursorTag " "]]
455 Just (c, rest) ->
246 Just (c, rest) ->
456 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
247 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
457 cursor = Span cursorTag (T.singleton c)
248 cursor = Span cursorTag (T.singleton c)
458− in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of
249+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
459− [] -> [[cursor]]
250+ [] -> [[cursor]]
460 (l:ls) -> (cursor : l) : ls
251 (l:ls) -> (cursor : l) : ls
461−
462− curLineSpanNormalCase = if cursorAfterEOL
463− then [ spansCurLineBefore, spansCurLineAfter ]
464− else [ spansCurLineBefore <> spansCurLineAfter ]
465−
466− -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position
467− curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL
468− then case reverse spansCurLineBefore of
469− [] -> curLineSpanNormalCase
470− (Span _ x):xs -> case spansCurLineAfter of
471− [] -> error "should not be possible" -- curLineSpanNormalCase
472− (Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]
473− else curLineSpanNormalCase
474−
475− cursorY = sum
476− [ length spansBefore
477− , length spansCurrentBefore
478− , if cursorAfterEOL then 1 else 0
479− ]
480− -- a little silly to convert back to text but whatever, it works
481− cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)
482−
483 in DisplayLines
252 in DisplayLines
484 { _displayLines_spans = concat
253 { _displayLines_spans = concat
485 [ spansBefore
254 [ spansBefore
486 , spansCurrentBefore
255 , spansCurrentBefore
487− , curLineSpan
256+ , if cursorAfterEOL
257+ then [ spansCurLineBefore, spansCurLineAfter ]
258+ else [ spansCurLineBefore <> spansCurLineAfter ]
488 , spansCurrentAfter
259 , spansCurrentAfter
489 , spansAfter
260 , spansAfter
490 ]
261 ]
491 , _displayLines_offsetMap = offsets
262 , _displayLines_offsetMap = offsets
492− , _displayLines_cursorPos = (cursorX, cursorY)
263+ , _displayLines_cursorY = sum
264+ [ length spansBefore
265+ , length spansCurrentBefore
266+ , if cursorAfterEOL then cursorCharWidth else 0
267+ ]
493 }
268 }
494 where
269 where
495 initLast :: [a] -> Maybe ([a], a)
270 initLast :: [a] -> Maybe ([a], a)
496 initLast = \case
271 initLast = \case
497 [] -> Nothing
272 [] -> Nothing
498 (x:xs) -> case initLast xs of
273 (x:xs) -> case initLast xs of
499− Nothing -> Just ([], x)
274+ Nothing -> Just ([], x)
500 Just (ys, y) -> Just (x:ys, y)
275 Just (ys, y) -> Just (x:ys, y)
501 headTail :: [a] -> Maybe (a, [a])
276 headTail :: [a] -> Maybe (a, [a])
502 headTail = \case
277 headTail = \case
503 [] -> Nothing
278 [] -> Nothing
504 x:xs -> Just (x, xs)
279 x:xs -> Just (x, xs)
505
280
281+-- | Wraps a logical line of text to fit within the given width. The first
282+-- wrapped line is offset by the number of columns provided. Subsequent wrapped
283+-- lines are not.
284+wrapWithOffset
285+ :: Int -- ^ Maximum width
286+ -> Int -- ^ Offset for first line
287+ -> Text -- ^ Text to be wrapped
288+ -> [Text]
289+wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
290+wrapWithOffset maxWidth n xs =
291+ let (firstLine, rest) = splitAtWidth (maxWidth - n) xs
292+ in firstLine : (fmap (takeWidth maxWidth) . takeWhile (not . T.null) . iterate (dropWidth maxWidth) $ rest)
293+
294+-- | Split a 'Text' at the given column index. For example
295+--
296+-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
297+--
298+-- because the first character has a width of two (see 'charWidth' for more on that).
299+splitAtWidth :: Int -> Text -> (Text, Text)
300+splitAtWidth n t@(Text arr off len)
301+ | n <= 0 = (T.empty, t)
302+ | n >= textWidth t = (t, T.empty)
303+ | otherwise = let k = iterNWidth n t
304+ in (text arr off k, text arr (off+k) (len-k))
305+ where
306+ iterNWidth :: Int -> Text -> Int
307+ iterNWidth n' t'@(Text _ _ len') = loop 0 0
308+ where loop !i !cnt
309+ | i >= len' || cnt + w > n' = i
310+ | otherwise = loop (i+d) (cnt + w)
311+ where Iter c d = iter t' i
312+ w = charWidth c
313+
314+-- | Takes the given number of columns of characters. For example
315+--
316+-- > takeWidth 3 "ᄀabc" == "ᄀa"
317+--
318+-- because the first character has a width of 2 (see 'charWidth' for more on that).
319+-- This function will not take a character if its width exceeds the width it seeks to take.
320+takeWidth :: Int -> Text -> Text
321+takeWidth n = fst . splitAtWidth n
322+
323+-- | Drops the given number of columns of characters. For example
324+--
325+-- > dropWidth 2 "ᄀabc" == "abc"
326+--
327+-- because the first character has a width of 2 (see 'charWidth' for more on that).
328+-- This function will not drop a character if its width exceeds the width it seeks to drop.
329+dropWidth :: Int -> Text -> Text
330+dropWidth n = snd . splitAtWidth n
331+
332+-- | Get the display width of a 'Char'. "Full width" and "wide" characters
333+-- take two columns and everything else takes a single column. See
334+-- <https://www.unicode.org/reports/tr11/> for more information.
335+charWidth :: Char -> Int
336+charWidth c = case property EastAsianWidth c of
337+ EAFull -> 2
338+ EAWide -> 2
339+ _ -> 1
340+
341+-- | For a given set of wrapped logical lines, computes a map
342+-- from display line index to text offset in the original text.
343+-- This is used to help determine how interactions with the displayed
344+-- text map back to the original text.
345+-- For example, given the document @\"AA\\nBBB\\nCCCCCCCC\\n\"@ wrapped to 5 columns,
346+-- this function will compute the offset in the original document of each character
347+-- in column 1:
348+--
349+-- > AA... (0, 0)
350+-- > BBB.. (1, 3)
351+-- > CCCCC (2, 7) -- (this line wraps to the next row)
352+-- > CCC.. (3, 12)
353+-- > ..... (4, 16)
354+offsetMap
355+ :: [[Text]] -- ^ The outer list represents logical lines, and the
356+ -- inner list represents the display lines into which
357+ -- the logical line has been wrapped
358+ -> Map Int Int -- ^ A map from the index (row) of display line to
359+ -- the text offset from the beginning of the document
360+ -- to the first character of the display line
361+offsetMap ts = evalState (offsetMap' ts) (0, 0)
362+ where
363+ offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
364+ maps <- forM x $ \line -> do
365+ let l = T.length line
366+ (dl, o) <- get
367+ put (dl + 1, o + l)
368+ return $ Map.singleton dl o
369+ (dl, o) <- get
370+ put (dl, o + 1)
371+ return $ Map.insert dl (o + 1) $ Map.unions maps
506
372
507-- | Move the cursor of the given 'TextZipper' to the logical position indicated
373-- | Move the cursor of the given 'TextZipper' to the logical position indicated
508−-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
374+-- by the given display line coordinates, using the provided 'DisplayLines'
509-- information. If the x coordinate is beyond the end of a line, the cursor is
375-- information. If the x coordinate is beyond the end of a line, the cursor is
510-- moved to the end of the line.
376-- moved to the end of the line.
511goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
377goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
@@ -513,33 +379,32 @@ goToDisplayLinePosition x y dl tz =
513 let offset = Map.lookup y $ _displayLines_offsetMap dl
379 let offset = Map.lookup y $ _displayLines_offsetMap dl
514 in case offset of
380 in case offset of
515 Nothing -> tz
381 Nothing -> tz
516− Just (alignOff,o) ->
382+ Just o ->
517− let
518− trueX = max 0 (x - alignOff)
519− moveRight = case drop y $ _displayLines_spans dl of
383+ let displayLineLength = case drop y $ _displayLines_spans dl of
520− [] -> 0
384+ [] -> x
521− (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
385+ (s:_) -> spansWidth s
522− in rightN (o + moveRight) $ top tz
386+ in rightN (o + min displayLineLength x) $ top tz
523
387
524−-- | Given a width and a 'TextZipper', produce a list of display lines
388+-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
525−-- (i.e., lines of wrapped text) with special attributes applied to
389+spansWidth :: [Span tag] -> Int
526−-- certain segments (e.g., the cursor). Additionally, produce the current
390+spansWidth = sum . map (\(Span _ t) -> textWidth t)
527−-- y-coordinate of the cursor and a mapping from display line number to text
528−-- offset
529−displayLines
530− :: Int -- ^ Width, used for wrapping
531− -> tag -- ^ Metadata for normal characters
532− -> tag -- ^ Metadata for the cursor
533− -> TextZipper -- ^ The text input contents and cursor state
534− -> DisplayLines tag
535−displayLines = displayLinesWithAlignment TextAlignment_Left
536
391
537−-- | Wraps a logical line of text to fit within the given width. The first
392+-- | Get the length (number of characters) of the text in a set of 'Span's
538−-- wrapped line is offset by the number of columns provided. Subsequent wrapped
393+spansLength :: [Span tag] -> Int
539−-- lines are not.
394+spansLength = sum . map (\(Span _ t) -> T.length t)
540−wrapWithOffset
395+
541− :: Int -- ^ Maximum width
396+-- | Compute the width of some 'Text', taking into account fullwidth
542− -> Int -- ^ Offset for first line
397+-- unicode forms.
543− -> Text -- ^ Text to be wrapped
398+textWidth :: Text -> Int
544− -> [Text]
399+textWidth t = widthI (stream t)
545−wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs
400+
401+-- | Compute the width of a stream of characters, taking into account
402+-- fullwidth unicode forms.
403+widthI :: Stream Char -> Int
404+widthI (Stream next s0 _len) = loop_length 0 s0
405+ where
406+ loop_length !z s = case next s of
407+ Done -> z
408+ Skip s' -> loop_length z s'
409+ Yield c s' -> loop_length (z + charWidth c) s'
410+{-# INLINE[0] widthI #-}
src/Reflex/Class/Switchable.hsnew file+30
@@ -0,0 +1,30 @@
1+{-|
2+Module: Reflex.Class.Switchable
3+Description: A class for things that can be switched on the firing of an event
4+-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+module Reflex.Class.Switchable where
10+
11+import Control.Monad
12+import Reflex
13+
14+-- | Class representing things that can be switched when the provided event occurs
15+class Reflex t => Switchable t w | w -> t where
16+ switching :: MonadHold t m => w -> Event t w -> m w
17+
18+instance Reflex t => Switchable t (Event t a) where
19+ switching = switchHold
20+
21+instance Reflex t => Switchable t (Dynamic t a) where
22+ switching a e = fmap join $ holdDyn a e
23+
24+instance Reflex t => Switchable t (Behavior t a) where
25+ switching = switcher
26+
27+instance (Reflex t, Switchable t a, Switchable t b) => Switchable t (a, b) where
28+ switching (a, b) e = (,)
29+ <$> (switching a $ fmap fst e)
30+ <*> (switching b $ fmap snd e)
src/Reflex/Spider/Orphans.hs+3
@@ -2,6 +2,9 @@
2Module: Reflex.Spider.Orphans
2Module: Reflex.Spider.Orphans
3Description: Orphan instances for SpiderTimeline and SpiderHost
3Description: Orphan instances for SpiderTimeline and SpiderHost
4-}
4-}
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
5{-# OPTIONS_GHC -fno-warn-orphans #-}
8{-# OPTIONS_GHC -fno-warn-orphans #-}
6module Reflex.Spider.Orphans where
9module Reflex.Spider.Orphans where
7
10
src/Reflex/Vty.hs−6
@@ -14,21 +14,15 @@ module Reflex.Vty
14 ( module Reflex
14 ( module Reflex
15 , module Reflex.Vty.Host
15 , module Reflex.Vty.Host
16 , module Reflex.Vty.Widget
16 , module Reflex.Vty.Widget
17− , module Reflex.Vty.Widget.Box
18 , module Reflex.Vty.Widget.Input
17 , module Reflex.Vty.Widget.Input
19 , module Reflex.Vty.Widget.Layout
18 , module Reflex.Vty.Widget.Layout
20− , module Reflex.Vty.Widget.Split
21− , module Reflex.Vty.Widget.Text
22 , module Control.Monad.NodeId
19 , module Control.Monad.NodeId
23 ) where
20 ) where
24
21
25import Reflex
22import Reflex
26import Reflex.Vty.Host
23import Reflex.Vty.Host
27import Reflex.Vty.Widget
24import Reflex.Vty.Widget
28−import Reflex.Vty.Widget.Box
29import Reflex.Vty.Widget.Input
25import Reflex.Vty.Widget.Input
30import Reflex.Vty.Widget.Layout
26import Reflex.Vty.Widget.Layout
31−import Reflex.Vty.Widget.Split
32−import Reflex.Vty.Widget.Text
33
27
34import Control.Monad.NodeId
28import Control.Monad.NodeId
src/Reflex/Vty/Host.hs+11−3
@@ -2,6 +2,12 @@
2Module: Reflex.Vty.Host
2Module: Reflex.Vty.Host
3Description: Scaffolding for running a reflex-vty application
3Description: Scaffolding for running a reflex-vty application
4-}
4-}
5+{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE LambdaCase #-}
9+{-# LANGUAGE RankNTypes #-}
10+
5module Reflex.Vty.Host
11module Reflex.Vty.Host
6 ( VtyApp
12 ( VtyApp
7 , VtyResult(..)
13 , VtyResult(..)
@@ -22,7 +28,8 @@ import Control.Monad.Identity (Identity(..))
22import Control.Monad.Primitive (PrimMonad)
28import Control.Monad.Primitive (PrimMonad)
23import Control.Monad.Ref (MonadRef, Ref, readRef)
29import Control.Monad.Ref (MonadRef, Ref, readRef)
24import Data.Dependent.Sum (DSum ((:=>)))
30import Data.Dependent.Sum (DSum ((:=>)))
25−import Data.IORef (IORef, readIORef)
31+import Data.IORef (IORef)
32+import Data.IORef (readIORef)
26import Data.Maybe (catMaybes)
33import Data.Maybe (catMaybes)
27
34
28import Reflex
35import Reflex
@@ -69,7 +76,7 @@ type MonadVtyApp t m =
69type VtyApp t m = MonadVtyApp t m
76type VtyApp t m = MonadVtyApp t m
70 => DisplayRegion
77 => DisplayRegion
71 -- ^ The initial display size (updates to this come as events)
78 -- ^ The initial display size (updates to this come as events)
72− -> Event t V.Event
79+ -> Event t (V.Event)
73 -- ^ Vty input events.
80 -- ^ Vty input events.
74 -> m (VtyResult t)
81 -> m (VtyResult t)
75 -- ^ The output of the 'VtyApp'. The application runs in a context that,
82 -- ^ The output of the 'VtyApp'. The application runs in a context that,
@@ -172,7 +179,7 @@ runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $
172 triggerInvocation = TriggerInvocation ne $ return ()
179 triggerInvocation = TriggerInvocation ne $ return ()
173 -- Write our input event's 'EventTrigger' with the newly created
180 -- Write our input event's 'EventTrigger' with the newly created
174 -- 'TriggerInvocation' value to the queue of events.
181 -- 'TriggerInvocation' value to the queue of events.
175− writeChan events [triggerRef :=> triggerInvocation]
182+ writeChan events $ [triggerRef :=> triggerInvocation]
176
183
177 -- The main application loop. We wait for new events, fire those that
184 -- The main application loop. We wait for new events, fire those that
178 -- have subscribers, and update the display. If we detect a shutdown
185 -- have subscribers, and update the display. If we detect a shutdown
@@ -196,6 +203,7 @@ runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $
196 updateVty
203 updateVty
197 loop
204 loop
198 where
205 where
206+ -- TODO Some part of this is probably general enough to belong in reflex
199 -- | Use the given 'FireCommand' to fire events that have subscribers
207 -- | Use the given 'FireCommand' to fire events that have subscribers
200 -- and call the callback for the 'TriggerInvocation' of each.
208 -- and call the callback for the 'TriggerInvocation' of each.
201 fireEventTriggerRefs
209 fireEventTriggerRefs
src/Reflex/Vty/Widget.hs+619−471
@@ -2,41 +2,160 @@
2Module: Reflex.Vty.Widget
2Module: Reflex.Vty.Widget
3Description: Basic set of widgets and building blocks for reflex-vty applications
3Description: Basic set of widgets and building blocks for reflex-vty applications
4-}
4-}
5+{-# LANGUAGE DefaultSignatures #-}
6+{-# LANGUAGE DeriveFunctor #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE FunctionalDependencies #-}
10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11+{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE RecursiveDo #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE StandaloneDeriving #-}
16+{-# LANGUAGE TupleSections #-}
17+{-# LANGUAGE TypeFamilies #-}
5−{-# Language UndecidableInstances #-}
18+{-# LANGUAGE UndecidableInstances #-}
6−
19+
7−module Reflex.Vty.Widget where
20+module Reflex.Vty.Widget
21+ ( VtyWidgetCtx(..)
22+ , VtyWidget(..)
23+ , VtyWidgetOut(..)
24+ , ImageWriter(..)
25+ , runVtyWidget
26+ , mainWidget
27+ , mainWidgetWithHandle
28+ , HasDisplaySize(..)
29+ , HasFocus(..)
30+ , HasVtyInput(..)
31+ , DynRegion(..)
32+ , currentRegion
33+ , Region(..)
34+ , regionSize
35+ , regionBlankImage
36+ , Drag(..)
37+ , drag
38+ , MouseDown(..)
39+ , MouseUp(..)
40+ , mouseDown
41+ , mouseUp
42+ , ScrollDirection(..)
43+ , mouseScroll
44+ , pane
45+ , splitV
46+ , splitVDrag
47+ , boxTitle
48+ , box
49+ , boxStatic
50+ , RichTextConfig(..)
51+ , richText
52+ , text
53+ , scrollableText
54+ , display
55+ , BoxStyle(..)
56+ , hyphenBoxStyle
57+ , singleBoxStyle
58+ , roundedBoxStyle
59+ , thickBoxStyle
60+ , doubleBoxStyle
61+ , fill
62+ , hRule
63+ , KeyCombo
64+ , key
65+ , keys
66+ , keyCombo
67+ , keyCombos
68+ , blank
69+ ) where
8
70
9import Control.Applicative (liftA2)
71import Control.Applicative (liftA2)
10import Control.Monad.Fix (MonadFix)
72import Control.Monad.Fix (MonadFix)
11−import Control.Monad.IO.Class (MonadIO)
73+import Control.Monad.Reader
12−import Control.Monad.Morph
13−import Control.Monad.NodeId
14−import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
15−import Control.Monad.Ref
16−import Control.Monad.Trans (MonadTrans, lift)
74+import Control.Monad.Trans (lift)
75+import Data.Default (Default(..))
17import Data.Set (Set)
76import Data.Set (Set)
18import qualified Data.Set as Set
77import qualified Data.Set as Set
78+import Data.Text (Text)
79+import qualified Data.Text as T
80+import qualified Data.Text.Zipper as TZ
19import Graphics.Vty (Image)
81import Graphics.Vty (Image)
20import qualified Graphics.Vty as V
82import qualified Graphics.Vty as V
21import Reflex
83import Reflex
22import Reflex.Class ()
84import Reflex.Class ()
23import Reflex.Host.Class (MonadReflexCreateTrigger)
85import Reflex.Host.Class (MonadReflexCreateTrigger)
86+
24import Reflex.Vty.Host
87import Reflex.Vty.Host
25
88
26−-- * Running a vty application
89+import Control.Monad.NodeId
90+
91+-- | The context within which a 'VtyWidget' runs
92+data VtyWidgetCtx t = VtyWidgetCtx
93+ { _vtyWidgetCtx_width :: Dynamic t Int
94+ -- ^ The width of the region allocated to the widget.
95+ , _vtyWidgetCtx_height :: Dynamic t Int
96+ -- ^ The height of the region allocated to the widget.
97+ , _vtyWidgetCtx_focus :: Dynamic t Bool
98+ -- ^ Whether the widget should behave as if it has focus for keyboard input.
99+ , _vtyWidgetCtx_input :: Event t VtyEvent
100+ -- ^ User input events that the widget's parent chooses to share. These will generally
101+ -- be filtered for relevance:
102+ -- * Keyboard inputs are restricted to focused widgets
103+ -- * Mouse inputs are restricted to the region in which the widget resides and are
104+ -- translated into its internal coordinates.
105+ }
106+
107+-- | The output of a 'VtyWidget'
108+data VtyWidgetOut t = VtyWidgetOut
109+ { _vtyWidgetOut_shutdown :: Event t ()
110+ }
111+
112+instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where
113+ runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'
114+ traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $
115+ traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
116+ traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do
117+ traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
118+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do
119+ traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'
120+
121+-- | A widget that can read its context and produce image output
122+newtype VtyWidget t m a = VtyWidget
123+ { unVtyWidget :: BehaviorWriterT t [Image] (ReaderT (VtyWidgetCtx t) m) a
124+ } deriving
125+ ( Functor
126+ , Applicative
127+ , Monad
128+ , MonadSample t
129+ , MonadHold t
130+ , MonadFix
131+ , NotReady t
132+ , ImageWriter t
133+ , PostBuild t
134+ , TriggerEvent t
135+ , MonadReflexCreateTrigger t
136+ , MonadIO
137+ )
138+
139+deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
140+instance MonadTrans (VtyWidget t) where
141+ lift f = VtyWidget $ lift $ lift f
142+
143+instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
144+ getNextNodeId = VtyWidget $ do
145+ lift $ lift $ getNextNodeId
146+
147+-- | Runs a 'VtyWidget' with a given context
148+runVtyWidget
149+ :: (Reflex t, MonadNodeId m)
150+ => VtyWidgetCtx t
151+ -> VtyWidget t m a
152+ -> m (a, Behavior t [Image])
153+runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx
27
154
28−-- | Sets up the top-level context for a vty widget and runs it with that context
155+-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context
29mainWidgetWithHandle
156mainWidgetWithHandle
30 :: V.Vty
157 :: V.Vty
31− -> (forall t m.
32− ( MonadVtyApp t m
158+ -> (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
33− , HasImageWriter t m
34− , MonadNodeId m
35− , HasDisplayRegion t m
36− , HasFocusReader t m
37− , HasInput t m
38− , HasTheme t m
39− ) => m (Event t ()))
40 -> IO ()
159 -> IO ()
41mainWidgetWithHandle vty child =
160mainWidgetWithHandle vty child =
42 runVtyAppWithHandle vty $ \dr0 inp -> do
161 runVtyAppWithHandle vty $ \dr0 inp -> do
@@ -46,178 +165,71 @@ mainWidgetWithHandle vty child =
46 let inp' = fforMaybe inp $ \case
165 let inp' = fforMaybe inp $ \case
47 V.EvResize {} -> Nothing
166 V.EvResize {} -> Nothing
48 x -> Just x
167 x -> Just x
49− (shutdown, images) <- runThemeReader (constant V.defAttr) $
168+ let ctx = VtyWidgetCtx
50− runFocusReader (pure True) $
169+ { _vtyWidgetCtx_width = fmap fst size
51− runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
170+ , _vtyWidgetCtx_height = fmap snd size
52− runImageWriter $
171+ , _vtyWidgetCtx_input = inp'
53− runNodeIdT $
172+ , _vtyWidgetCtx_focus = constDyn True
54− runInput inp' $ do
173+ }
174+ (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do
55− tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
175+ tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
56− child
176+ child
57 return $ VtyResult
177 return $ VtyResult
58 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
178 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
59 , _vtyResult_shutdown = shutdown
179 , _vtyResult_shutdown = shutdown
60 }
180 }
61
181
62−-- | The output of a vty widget
63−data VtyWidgetOut t = VtyWidgetOut
64− { _vtyWidgetOut_shutdown :: Event t ()
65− }
66−
67-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
182-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
68mainWidget
183mainWidget
69− :: (forall t m.
70− ( MonadVtyApp t m
184+ :: (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
71− , HasImageWriter t m
72− , MonadNodeId m
73− , HasDisplayRegion t m
74− , HasFocusReader t m
75− , HasTheme t m
76− , HasInput t m
77− ) => m (Event t ()))
78 -> IO ()
185 -> IO ()
79mainWidget child = do
186mainWidget child = do
80 vty <- getDefaultVty
187 vty <- getDefaultVty
81 mainWidgetWithHandle vty child
188 mainWidgetWithHandle vty child
82
189
83−-- * Input Events
190+-- | A class for things that know their own display size dimensions
191+class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
192+ -- | Retrieve the display width (columns)
193+ displayWidth :: m (Dynamic t Int)
194+ default displayWidth :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
195+ displayWidth = lift displayWidth
196+ -- | Retrieve the display height (rows)
197+ displayHeight :: m (Dynamic t Int)
198+ default displayHeight :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
199+ displayHeight = lift displayHeight
200+
201+instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
202+ displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width
203+ displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height
204+
205+instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)
206+instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)
207+instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)
208+instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)
209+
210+instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)
84
211
85-- | A class for things that can receive vty events as input
212-- | A class for things that can receive vty events as input
86−class HasInput t m | m -> t where
213+class HasVtyInput t m | m -> t where
87 input :: m (Event t VtyEvent)
214 input :: m (Event t VtyEvent)
88− default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)
89− input = lift input
90− -- | User input events that the widget's parent chooses to share. These will generally
91− -- be filtered for relevance.
92− localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
93− default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
94− localInput f = hoist (localInput f)
95−
96−instance (Reflex t, Monad m) => HasInput t (Input t m) where
97− input = Input ask
98− localInput f (Input m) = Input $ local f m
99−
100−-- | A widget that can receive input events. See 'Graphics.Vty.Event'
101−newtype Input t m a = Input
102− { unInput :: ReaderT (Event t VtyEvent) m a
103− } deriving
104− ( Functor
105− , Applicative
106− , Monad
107− , MonadSample t
108− , MonadHold t
109− , MonadFix
110− , MonadIO
111− , MonadRef
112− )
113−
114−instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where
115− runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a'
116− traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $
117− traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
118− traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do
119− traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
120− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do
121− traverseDMapWithKeyWithAdjustWithMove (\k v -> unInput (f k v)) dm0 dm'
122−
123−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Input t m)
124−deriving instance NotReady t m => NotReady t (Input t m)
125−deriving instance PerformEvent t m => PerformEvent t (Input t m)
126−deriving instance PostBuild t m => PostBuild t (Input t m)
127−deriving instance TriggerEvent t m => TriggerEvent t (Input t m)
128−instance HasImageWriter t m => HasImageWriter t (Input t m)
129−instance HasDisplayRegion t m => HasDisplayRegion t (Input t m)
130−instance HasFocusReader t m => HasFocusReader t (Input t m)
131−
132−instance MonadTrans (Input t) where
133− lift f = Input $ lift f
134−
135−instance MFunctor (Input t) where
136− hoist f = Input . hoist f . unInput
137−
138−instance MonadNodeId m => MonadNodeId (Input t m)
139−
140−-- | Runs an 'Input' with a given context
141−runInput
142− :: Reflex t
143− => Event t VtyEvent
144− -> Input t m a
145− -> m a
146−runInput e w = runReaderT (unInput w) e
147−
148−-- ** Filtering input
149
215
150−-- | Type synonym for a key and modifier combination
216+instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
151−type KeyCombo = (V.Key, [V.Modifier])
217+ input = VtyWidget . lift $ asks _vtyWidgetCtx_input
152−
153−-- | Emits an event that fires on a particular key press (without modifiers)
154−key :: (Monad m, Reflex t, HasInput t m) => V.Key -> m (Event t KeyCombo)
155−key = keyCombos . Set.singleton . (,[])
156
218
157−-- | Emits an event that fires on particular key presses (without modifiers)
219+-- | A class for things that can dynamically gain and lose focus
158−keys :: (Monad m, Reflex t, HasInput t m) => [V.Key] -> m (Event t KeyCombo)
220+class HasFocus t m | m -> t where
159−keys = keyCombos . Set.fromList . fmap (,[])
221+ focus :: m (Dynamic t Bool)
160−
161−-- | Emit an event that fires whenever the provided key combination occurs
162−keyCombo
163− :: (Reflex t, Monad m, HasInput t m)
164− => KeyCombo
165− -> m (Event t KeyCombo)
166−keyCombo = keyCombos . Set.singleton
167
222
168−-- | Emit an event that fires whenever any of the provided key combinations occur
223+instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
169−keyCombos
224+ focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
170− :: (Reflex t, Monad m, HasInput t m)
171− => Set KeyCombo
172− -> m (Event t KeyCombo)
173−keyCombos ks = do
174− i <- input
175− return $ fforMaybe i $ \case
176− V.EvKey k m -> if Set.member (k, m) ks
177− then Just (k, m)
178− else Nothing
179− _ -> Nothing
180
225
181−-- | Filter the keyboard input that a child widget may receive
226+-- | A class for widgets that can produce images to draw to the display
182−filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a
227+class (Reflex t, Monad m) => ImageWriter t m | m -> t where
183−filterKeys f x = localInput (ffilter (\case
228+ -- | Send images upstream for rendering
184− V.EvKey k mods -> f (k, mods)
229+ tellImages :: Behavior t [Image] -> m ()
185− _ -> True)) x
186−
187−-- | Filter mouse input events based on whether they target a particular region
188−-- and translate them to the internal coordinate system of that region.
189−--
190−-- NB: Non-mouse events are passed through unfiltered and unchanged
191−mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent
192−mouseInRegion (Region l t w h) e = case e of
193− V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
194− V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
195− _ -> Just e
196− where
197− mouse con x y
198− | or [ x < l
199− , y < t
200− , x >= l + w
201− , y >= t + h ] = Nothing
202− | otherwise =
203− Just (con (x - l) (y - t))
204−
205−-- | Filter mouse input outside the current display region and
206−-- all input if the region is not focused
207−inputInFocusedRegion
208− :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
209− => m (Event t VtyEvent)
210−inputInFocusedRegion = do
211− inp <- input
212− reg <- current <$> askRegion
213− foc <- current <$> focus
214− pure $ fmapMaybe id $ attachWith filterInput ((,) <$> reg <*> foc) inp
215− where
216− filterInput (r, f) = \case
217− V.EvKey {} | not f -> Nothing
218− x -> mouseInRegion r x
219
230
220−-- * Getting and setting the display region
231+instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
232+ tellImages = tellBehavior
221
233
222-- | A chunk of the display area
234-- | A chunk of the display area
223data Region = Region
235data Region = Region
@@ -228,334 +240,470 @@ data Region = Region
228 }
240 }
229 deriving (Show, Read, Eq, Ord)
241 deriving (Show, Read, Eq, Ord)
230
242
231−-- | A region that occupies no space.
243+-- | A dynamic chunk of the display area
232−nilRegion :: Region
244+data DynRegion t = DynRegion
233−nilRegion = Region 0 0 0 0
245+ { _dynRegion_left :: Dynamic t Int
246+ , _dynRegion_top :: Dynamic t Int
247+ , _dynRegion_width :: Dynamic t Int
248+ , _dynRegion_height :: Dynamic t Int
249+ }
234
250
235-- | The width and height of a 'Region'
251-- | The width and height of a 'Region'
236regionSize :: Region -> (Int, Int)
252regionSize :: Region -> (Int, Int)
237regionSize (Region _ _ w h) = (w, h)
253regionSize (Region _ _ w h) = (w, h)
238
254
239-- | Produces an 'Image' that fills a region with space characters
255-- | Produces an 'Image' that fills a region with space characters
240−regionBlankImage :: V.Attr -> Region -> Image
256+regionBlankImage :: Region -> Image
241−regionBlankImage attr r@(Region _ _ width height) =
257+regionBlankImage r@(Region _ _ width height) =
242− withinImage r $ V.charFill attr ' ' width height
258+ withinImage r $ V.charFill V.defAttr ' ' width height
243
259
244−-- | A class for things that know their own display size dimensions
260+-- | A behavior of the current display area represented by a 'DynRegion'
245−class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
261+currentRegion :: Reflex t => DynRegion t -> Behavior t Region
246− -- | Retrieve the display region
262+currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h
247− askRegion :: m (Dynamic t Region)
248− default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)
249− askRegion = lift askRegion
250− -- | Run an action in a local region, by applying a transformation to the region
251− localRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a
252− default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a
253− localRegion f = hoist (localRegion f)
254−
255−-- | Retrieve the display width
256−displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
257−displayWidth = fmap _region_width <$> askRegion
258−
259−-- | Retrieve the display height
260−displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)
261−displayHeight = fmap _region_height <$> askRegion
262−
263−instance HasDisplayRegion t m => HasDisplayRegion t (ReaderT x m)
264−instance HasDisplayRegion t m => HasDisplayRegion t (BehaviorWriterT t x m)
265−instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)
266−instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)
267−instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)
268−
269−-- | A widget that has access to a particular region of the vty display
270−newtype DisplayRegion t m a = DisplayRegion
271− { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
272− deriving
273− ( Functor
274− , Applicative
275− , Monad
276− , MonadFix
277− , MonadHold t
278− , MonadIO
279− , MonadRef
280− , MonadSample t
281− )
282−
283−instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where
284− askRegion = DisplayRegion ask
285− localRegion f = DisplayRegion . local f . unDisplayRegion
286−
287−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m)
288−deriving instance NotReady t m => NotReady t (DisplayRegion t m)
289−deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
290−deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
291−deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
292−instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
293−instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)
294−
295−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
296− runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e
297− traverseIntMapWithKeyWithAdjust f m e = DisplayRegion $ traverseIntMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
298− traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
299− traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
300−
301−instance MonadTrans (DisplayRegion t) where
302− lift = DisplayRegion . lift
303−
304−instance MFunctor (DisplayRegion t) where
305− hoist f = DisplayRegion . hoist f . unDisplayRegion
306
263
307−instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
264+-- | Translates and crops an 'Image' so that it is contained by
265+-- the given 'Region'.
266+withinImage
267+ :: Region
268+ -> Image
269+ -> Image
270+withinImage (Region left top width height)
271+ | width < 0 || height < 0 = withinImage (Region left top 0 0)
272+ | otherwise = V.translate left top . V.crop width height
308
273
309−-- | Run a 'DisplayRegion' action with a given 'Region'
274+-- | Low-level widget combinator that runs a child 'VtyWidget' within
310−runDisplayRegion
275+-- a given region and context. This widget filters and modifies the input
276+-- that the child widget receives such that:
277+-- * unfocused widgets receive no key events
278+-- * mouse inputs outside the region are ignored
279+-- * mouse inputs inside the region have their coordinates translated such
280+-- that (0,0) is the top-left corner of the region
281+pane
282+ :: (Reflex t, Monad m, MonadNodeId m)
283+ => DynRegion t
284+ -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
285+ -> VtyWidget t m a
286+ -> VtyWidget t m a
287+pane dr foc child = VtyWidget $ do
288+ ctx <- lift ask
289+ let reg = currentRegion dr
290+ let ctx' = VtyWidgetCtx
291+ { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.
292+ [ fmapMaybe id $
293+ attachWith (\(r,f) e -> filterInput r f e)
294+ (liftA2 (,) reg (current foc))
295+ (_vtyWidgetCtx_input ctx)
296+ ]
297+ , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
298+ , _vtyWidgetCtx_width = _dynRegion_width dr
299+ , _vtyWidgetCtx_height = _dynRegion_height dr
300+ }
301+ (result, images) <- lift . lift $ runVtyWidget ctx' child
302+ let images' = liftA2 (\r is -> map (withinImage r) is) reg images
303+ tellImages images'
304+ return result
305+ where
306+ filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
307+ filterInput (Region l t w h) focused e = case e of
308+ V.EvKey _ _ | not focused -> Nothing
309+ V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
310+ V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
311+ _ -> Just e
312+ where
313+ mouse con x y
314+ | or [ x < l
315+ , y < t
316+ , x >= l + w
317+ , y >= t + h ] = Nothing
318+ | otherwise =
319+ Just (con (x - l) (y - t))
320+
321+-- | Information about a drag operation
322+data Drag = Drag
323+ { _drag_from :: (Int, Int) -- ^ Where the drag began
324+ , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
325+ , _drag_button :: V.Button -- ^ Which mouse button is dragging
326+ , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
327+ , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
328+ }
329+ deriving (Eq, Ord, Show)
330+
331+-- | Converts raw vty mouse drag events into an event stream of 'Drag's
332+drag
333+ :: (Reflex t, MonadFix m, MonadHold t m)
334+ => V.Button
335+ -> VtyWidget t m (Event t Drag)
336+drag btn = do
337+ inp <- input
338+ let f :: Maybe Drag -> V.Event -> Maybe Drag
339+ f Nothing = \case
340+ V.EvMouseDown x y btn' mods
341+ | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
342+ | otherwise -> Nothing
343+ _ -> Nothing
344+ f (Just (Drag from _ _ mods end)) = \case
345+ V.EvMouseDown x y btn' mods'
346+ | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
347+ | btn == btn' -> Just $ Drag from (x,y) btn mods' False
348+ | otherwise -> Nothing -- Ignore other buttons.
349+ V.EvMouseUp x y (Just btn')
350+ | end -> Nothing
351+ | btn == btn' -> Just $ Drag from (x,y) btn mods True
352+ | otherwise -> Nothing
353+ V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
354+ -- assume it's the right one.
355+ | end -> Nothing
356+ | otherwise -> Just $ Drag from (x,y) btn mods True
357+ _ -> Nothing
358+ rec let newDrag = attachWithMaybe f (current dragD) inp
359+ dragD <- holdDyn Nothing $ Just <$> newDrag
360+ return (fmapMaybe id $ updated dragD)
361+
362+-- | Mouse down events for a particular mouse button
363+mouseDown
311 :: (Reflex t, Monad m)
364 :: (Reflex t, Monad m)
312− => Dynamic t Region
365+ => V.Button
313− -> DisplayRegion t m a
366+ -> VtyWidget t m (Event t MouseDown)
314− -> m a
367+mouseDown btn = do
315−runDisplayRegion r = flip runReaderT r . unDisplayRegion
368+ i <- input
316−
369+ return $ fforMaybe i $ \case
317−-- * Getting focus state
370+ V.EvMouseDown x y btn' mods -> if btn == btn'
318−
371+ then Just $ MouseDown btn' (x, y) mods
319−-- | A class for things that can dynamically gain and lose focus
372+ else Nothing
320−class (Reflex t, Monad m) => HasFocusReader t m | m -> t where
373+ _ -> Nothing
321− focus :: m (Dynamic t Bool)
322− default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocusReader t m') => m (Dynamic t Bool)
323− focus = lift focus
324− localFocus :: (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
325− default localFocus :: (f m' ~ m, Monad m', MFunctor f, HasFocusReader t m') => (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
326− localFocus f = hoist (localFocus f)
327−
328−instance HasFocusReader t m => HasFocusReader t (ReaderT x m)
329−instance HasFocusReader t m => HasFocusReader t (BehaviorWriterT t x m)
330−instance HasFocusReader t m => HasFocusReader t (DynamicWriterT t x m)
331−instance HasFocusReader t m => HasFocusReader t (EventWriterT t x m)
332−instance HasFocusReader t m => HasFocusReader t (NodeIdT m)
333−
334−-- | A widget that has access to information about whether it is focused
335−newtype FocusReader t m a = FocusReader
336− { unFocusReader :: ReaderT (Dynamic t Bool) m a }
337− deriving
338− ( Functor
339− , Applicative
340− , Monad
341− , MonadFix
342− , MonadHold t
343− , MonadIO
344− , MonadRef
345− , MonadSample t
346− )
347−
348−instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where
349− focus = FocusReader ask
350− localFocus f = FocusReader . local f . unFocusReader
351−
352−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (FocusReader t m)
353−deriving instance NotReady t m => NotReady t (FocusReader t m)
354−deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)
355−deriving instance PostBuild t m => PostBuild t (FocusReader t m)
356−deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)
357−instance HasImageWriter t m => HasImageWriter t (FocusReader t m)
358−
359−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where
360− runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e
361− traverseIntMapWithKeyWithAdjust f m e = FocusReader $ traverseIntMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
362− traverseDMapWithKeyWithAdjust f m e = FocusReader $ traverseDMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
363− traverseDMapWithKeyWithAdjustWithMove f m e = FocusReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocusReader $ f k v) m e
364−
365−instance MonadTrans (FocusReader t) where
366− lift = FocusReader . lift
367−
368−instance MFunctor (FocusReader t) where
369− hoist f = FocusReader . hoist f . unFocusReader
370−
371−instance MonadNodeId m => MonadNodeId (FocusReader t m)
372
374
373−-- | Run a 'FocusReader' action with the given focus value
375+-- | Mouse up events for a particular mouse button
374−runFocusReader
376+mouseUp
375 :: (Reflex t, Monad m)
377 :: (Reflex t, Monad m)
376− => Dynamic t Bool
378+ => VtyWidget t m (Event t MouseUp)
377− -> FocusReader t m a
379+mouseUp = do
378− -> m a
380+ i <- input
379−runFocusReader b = flip runReaderT b . unFocusReader
381+ return $ fforMaybe i $ \case
380−
382+ V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
381−-- * "Image" output
383+ _ -> Nothing
382−
383−-- | A class for widgets that can produce images to draw to the display
384−class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
385− -- | Send images upstream for rendering
386− tellImages :: Behavior t [Image] -> m ()
387− default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()
388− tellImages = lift . tellImages
389− -- | Apply a transformation to the images produced by the child actions
390− mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
391− default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
392− mapImages f = hoist (mapImages f)
393−
394−-- | A widget that can produce images to draw onto the display
395−newtype ImageWriter t m a = ImageWriter
396− { unImageWriter :: BehaviorWriterT t [Image] m a }
397− deriving
398− ( Functor
399− , Applicative
400− , Monad
401− , MonadFix
402− , MonadHold t
403− , MonadIO
404− , MonadRef
405− , MonadReflexCreateTrigger t
406− , MonadSample t
407− , NotReady t
408− , PerformEvent t
409− , PostBuild t
410− , TriggerEvent t
411− )
412−
413−instance MonadTrans (ImageWriter t) where
414− lift = ImageWriter . lift
415−
416−instance MFunctor (ImageWriter t) where
417− hoist f = ImageWriter . (hoist f) . unImageWriter
418−
419−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ImageWriter t m) where
420− runWithReplace (ImageWriter a) e = ImageWriter $ runWithReplace a $ fmap unImageWriter e
421− traverseIntMapWithKeyWithAdjust f m e = ImageWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
422− traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
423− traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e
424
384
425−instance HasImageWriter t m => HasImageWriter t (ReaderT x m)
385+-- | Information about a mouse down event
426−instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)
386+data MouseDown = MouseDown
427−instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)
387+ { _mouseDown_button :: V.Button
428−instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)
388+ , _mouseDown_coordinates :: (Int, Int)
429−instance HasImageWriter t m => HasImageWriter t (NodeIdT m)
389+ , _mouseDown_modifiers :: [V.Modifier]
390+ }
391+ deriving (Eq, Ord, Show)
430
392
431−instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
393+-- | Information about a mouse up event
432− tellImages = ImageWriter . tellBehavior
394+data MouseUp = MouseUp
433− mapImages f (ImageWriter x) = ImageWriter $ do
395+ { _mouseUp_button :: Maybe V.Button
434− (a, images) <- lift $ runBehaviorWriterT x
396+ , _mouseUp_coordinates :: (Int, Int)
435− tellBehavior $ f images
397+ }
436− pure a
398+ deriving (Eq, Ord, Show)
437
399
438−instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
400+-- | Mouse scroll direction
439−instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
401+data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
402+ deriving (Eq, Ord, Show)
440
403
441−-- | Run a widget that can produce images
404+-- | Produce an event that fires when the mouse wheel is scrolled
442−runImageWriter
405+mouseScroll
443 :: (Reflex t, Monad m)
406 :: (Reflex t, Monad m)
444− => ImageWriter t m a
407+ => VtyWidget t m (Event t ScrollDirection)
445− -> m (a, Behavior t [Image])
408+mouseScroll = do
446−runImageWriter = runBehaviorWriterT . unImageWriter
409+ up <- mouseDown V.BScrollUp
447−
410+ down <- mouseDown V.BScrollDown
448−-- * Theming
411+ return $ leftmost
449−
412+ [ ScrollDirection_Up <$ up
450−-- | A class for things that can be visually styled
413+ , ScrollDirection_Down <$ down
451−class (Reflex t, Monad m) => HasTheme t m | m -> t where
414+ ]
452− theme :: m (Behavior t V.Attr)
453− default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)
454− theme = lift theme
455− localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
456− default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
457− localTheme f = hoist (localTheme f)
458−
459−instance HasTheme t m => HasTheme t (ReaderT x m)
460−instance HasTheme t m => HasTheme t (BehaviorWriterT t x m)
461−instance HasTheme t m => HasTheme t (DynamicWriterT t x m)
462−instance HasTheme t m => HasTheme t (EventWriterT t x m)
463−instance HasTheme t m => HasTheme t (NodeIdT m)
464−instance HasTheme t m => HasTheme t (Input t m)
465−instance HasTheme t m => HasTheme t (ImageWriter t m)
466−instance HasTheme t m => HasTheme t (DisplayRegion t m)
467−instance HasTheme t m => HasTheme t (FocusReader t m)
468−
469−-- | A widget that has access to theme information
470−newtype ThemeReader t m a = ThemeReader
471− { unThemeReader :: ReaderT (Behavior t V.Attr) m a }
472− deriving
473− ( Functor
474− , Applicative
475− , Monad
476− , MonadFix
477− , MonadHold t
478− , MonadIO
479− , MonadRef
480− , MonadSample t
481− )
482−
483−instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where
484− theme = ThemeReader ask
485− localTheme f = ThemeReader . local f . unThemeReader
486−
487−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)
488−deriving instance NotReady t m => NotReady t (ThemeReader t m)
489−deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)
490−deriving instance PostBuild t m => PostBuild t (ThemeReader t m)
491−deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)
492−instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)
493−
494−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where
495− runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e
496− traverseIntMapWithKeyWithAdjust f m e = ThemeReader $ traverseIntMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
497− traverseDMapWithKeyWithAdjust f m e = ThemeReader $ traverseDMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
498− traverseDMapWithKeyWithAdjustWithMove f m e = ThemeReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unThemeReader $ f k v) m e
499
415
500−instance MonadTrans (ThemeReader t) where
416+-- | Type synonym for a key and modifier combination
501− lift = ThemeReader . lift
417+type KeyCombo = (V.Key, [V.Modifier])
502
418
503−instance MFunctor (ThemeReader t) where
419+-- | Emits an event that fires on a particular key press (without modifiers)
504− hoist f = ThemeReader . hoist f . unThemeReader
420+key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)
421+key = keyCombos . Set.singleton . (,[])
505
422
506−instance MonadNodeId m => MonadNodeId (ThemeReader t m)
423+-- | Emits an event that fires on particular key presses (without modifiers)
424+keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)
425+keys = keyCombos . Set.fromList . fmap (,[])
507
426
508−-- | Run a 'ThemeReader' action with the given focus value
427+-- | Emit an event that fires whenever the provided key combination occurs
509−runThemeReader
428+keyCombo
510 :: (Reflex t, Monad m)
429 :: (Reflex t, Monad m)
511− => Behavior t V.Attr
430+ => KeyCombo
512− -> ThemeReader t m a
431+ -> VtyWidget t m (Event t KeyCombo)
513− -> m a
432+keyCombo = keyCombos . Set.singleton
514−runThemeReader b = flip runReaderT b . unThemeReader
515
433
434+-- | Emit an event that fires whenever any of the provided key combinations occur
435+keyCombos
436+ :: (Reflex t, Monad m)
437+ => Set KeyCombo
438+ -> VtyWidget t m (Event t KeyCombo)
439+keyCombos ks = do
440+ i <- input
441+ return $ fforMaybe i $ \case
442+ V.EvKey k m -> if Set.member (k, m) ks
443+ then Just (k, m)
444+ else Nothing
445+ _ -> Nothing
516
446
517−-- ** Manipulating images
447+-- | A plain split of the available space into vertically stacked panes.
448+-- No visual separator is built in here.
449+splitV :: (Reflex t, Monad m, MonadNodeId m)
450+ => Dynamic t (Int -> Int)
451+ -- ^ Function used to determine size of first pane based on available size
452+ -> Dynamic t (Bool, Bool)
453+ -- ^ How to focus the two sub-panes, given that we are focused.
454+ -> VtyWidget t m a
455+ -- ^ Widget for first pane
456+ -> VtyWidget t m b
457+ -- ^ Widget for second pane
458+ -> VtyWidget t m (a,b)
459+splitV sizeFunD focD wA wB = do
460+ dw <- displayWidth
461+ dh <- displayHeight
462+ let regA = DynRegion
463+ { _dynRegion_left = pure 0
464+ , _dynRegion_top = pure 0
465+ , _dynRegion_width = dw
466+ , _dynRegion_height = sizeFunD <*> dh
467+ }
468+ regB = DynRegion
469+ { _dynRegion_left = pure 0
470+ , _dynRegion_top = _dynRegion_height regA
471+ , _dynRegion_width = dw
472+ , _dynRegion_height = liftA2 (-) dh (_dynRegion_height regA)
473+ }
474+ ra <- pane regA (fst <$> focD) wA
475+ rb <- pane regB (snd <$> focD) wB
476+ return (ra,rb)
477+
478+-- | A split of the available space into two parts with a draggable separator.
479+-- Starts with half the space allocated to each, and the first pane has focus.
480+-- Clicking in a pane switches focus.
481+splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
482+ => VtyWidget t m ()
483+ -> VtyWidget t m a
484+ -> VtyWidget t m b
485+ -> VtyWidget t m (a,b)
486+splitVDrag wS wA wB = do
487+ dh <- displayHeight
488+ dw <- displayWidth
489+ h0 <- sample $ current dh -- TODO
490+ dragE <- drag V.BLeft
491+ let splitter0 = h0 `div` 2
492+ rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
493+ splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
494+ splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
495+ fromIntegral x / (max 1 (fromIntegral h))
496+ let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
497+ \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
498+ if splitterY == fromY then Just (toY, end) else Nothing
499+ regA = DynRegion 0 0 dw splitterPos
500+ regS = DynRegion 0 splitterPos dw 1
501+ regB = DynRegion 0 (splitterPos + 1) dw (dh - splitterPos - 1)
502+ resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
503+ \(frac, h) -> round (frac * fromIntegral h)
504+ focA <- holdDyn True $ leftmost
505+ [ True <$ mA
506+ , False <$ mB
507+ ]
508+ (mA, rA) <- pane regA focA $ withMouseDown wA
509+ pane regS (pure False) wS
510+ (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
511+ return (rA, rB)
512+ where
513+ withMouseDown x = do
514+ m <- mouseDown V.BLeft
515+ x' <- x
516+ return (m, x')
517+
518+-- | Fill the background with a particular character.
519+fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
520+fill c = do
521+ dw <- displayWidth
522+ dh <- displayHeight
523+ let fillImg = current $ liftA2 (\w h -> [V.charFill V.defAttr c w h]) dw dh
524+ tellImages fillImg
525+
526+-- | Fill the background with the bottom
527+hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
528+hRule boxStyle = fill (_boxStyle_s boxStyle)
529+
530+-- | Defines a set of symbols to use to draw the outlines of boxes
531+-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character
532+data BoxStyle = BoxStyle
533+ { _boxStyle_nw :: Char
534+ , _boxStyle_n :: Char
535+ , _boxStyle_ne :: Char
536+ , _boxStyle_e :: Char
537+ , _boxStyle_se :: Char
538+ , _boxStyle_s :: Char
539+ , _boxStyle_sw :: Char
540+ , _boxStyle_w :: Char
541+ }
518
542
519−-- | Translates and crops an 'Image' so that it is contained by
543+instance Default BoxStyle where
520−-- the given 'Region'.
544+ def = singleBoxStyle
521−withinImage
545+
522− :: Region
546+-- | A box style that uses hyphens and pipe characters. Doesn't handle
523− -> Image
547+-- corners very well.
524− -> Image
548+hyphenBoxStyle :: BoxStyle
525−withinImage (Region left top width height)
549+hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
526− | width < 0 || height < 0 = withinImage (Region left top 0 0)
550+
527− | otherwise = V.translate left top . V.crop width height
551+-- | A single line box style
552+singleBoxStyle :: BoxStyle
553+singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
554+
555+-- | A thick single line box style
556+thickBoxStyle :: BoxStyle
557+thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
558+
559+-- | A double line box style
560+doubleBoxStyle :: BoxStyle
561+doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
562+
563+-- | A single line box style with rounded corners
564+roundedBoxStyle :: BoxStyle
565+roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
566+
567+-- | Draws a titled box in the provided style and a child widget inside of that box
568+boxTitle :: (Monad m, Reflex t, MonadNodeId m)
569+ => Behavior t BoxStyle
570+ -> Text
571+ -> VtyWidget t m a
572+ -> VtyWidget t m a
573+boxTitle boxStyle title child = do
574+ dh <- displayHeight
575+ dw <- displayWidth
576+ let boxReg = DynRegion (pure 0) (pure 0) dw dh
577+ innerReg = DynRegion (pure 1) (pure 1) (subtract 2 <$> dw) (subtract 2 <$> dh)
578+ tellImages (boxImages <$> boxStyle <*> currentRegion boxReg)
579+ tellImages (fmap (\r -> [regionBlankImage r]) (currentRegion innerReg))
580+ pane innerReg (pure True) child
581+ where
582+ boxImages :: BoxStyle -> Region -> [Image]
583+ boxImages style (Region left top width height) =
584+ let right = left + width - 1
585+ bottom = top + height - 1
586+ sides =
587+ [ withinImage (Region (left + 1) top (width - 2) 1) $
588+ V.text' V.defAttr $
589+ hPadText title (_boxStyle_n style) (width - 2)
590+ , withinImage (Region right (top + 1) 1 (height - 2)) $
591+ V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)
592+ , withinImage (Region (left + 1) bottom (width - 2) 1) $
593+ V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1
594+ , withinImage (Region left (top + 1) 1 (height - 2)) $
595+ V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)
596+ ]
597+ corners =
598+ [ withinImage (Region left top 1 1) $
599+ V.char V.defAttr (_boxStyle_nw style)
600+ , withinImage (Region right top 1 1) $
601+ V.char V.defAttr (_boxStyle_ne style)
602+ , withinImage (Region right bottom 1 1) $
603+ V.char V.defAttr (_boxStyle_se style)
604+ , withinImage (Region left bottom 1 1) $
605+ V.char V.defAttr (_boxStyle_sw style)
606+ ]
607+ in sides ++ if width > 1 && height > 1 then corners else []
608+ hPadText :: T.Text -> Char -> Int -> T.Text
609+ hPadText t c l = if lt >= l
610+ then t
611+ else left <> t <> right
612+ where
613+ lt = T.length t
614+ delta = l - lt
615+ mkHalf n = T.replicate (n `div` 2) (T.singleton c)
616+ left = mkHalf $ delta + 1
617+ right = mkHalf delta
618+
619+-- | A box without a title
620+box :: (Monad m, Reflex t, MonadNodeId m)
621+ => Behavior t BoxStyle
622+ -> VtyWidget t m a
623+ -> VtyWidget t m a
624+box boxStyle = boxTitle boxStyle mempty
625+
626+-- | A box whose style is static
627+boxStatic
628+ :: (Reflex t, Monad m, MonadNodeId m)
629+ => BoxStyle
630+ -> VtyWidget t m a
631+ -> VtyWidget t m a
632+boxStatic = box . pure
633+
634+-- | Configuration options for displaying "rich" text
635+data RichTextConfig t = RichTextConfig
636+ { _richTextConfig_attributes :: Behavior t V.Attr
637+ }
528
638
529−-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.
639+instance Reflex t => Default (RichTextConfig t) where
530−imagesInRegion
640+ def = RichTextConfig $ pure V.defAttr
531− :: Reflex t
532− => Behavior t Region
533− -> Behavior t [Image]
534− -> Behavior t [Image]
535−imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
536
641
537−-- * Running sub-widgets
642+-- | A widget that displays text with custom time-varying attributes
643+richText
644+ :: (Reflex t, Monad m)
645+ => RichTextConfig t
646+ -> Behavior t Text
647+ -> VtyWidget t m ()
648+richText cfg t = do
649+ dw <- displayWidth
650+ let img = (\w a s -> [wrapText w a s])
651+ <$> current dw
652+ <*> _richTextConfig_attributes cfg
653+ <*> t
654+ tellImages img
655+ where
656+ wrapText maxWidth attrs = V.vertCat
657+ . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
658+ . T.split (=='\n')
538
659
539−-- | Low-level widget combinator that runs a child widget within
660+-- | Renders text, wrapped to the container width
540−-- a given region and context. This widget filters and modifies the input
661+text
541−-- that the child widget receives such that:
662+ :: (Reflex t, Monad m)
542−-- * unfocused widgets receive no key events
663+ => Behavior t Text
543−-- * mouse inputs outside the region are ignored
664+ -> VtyWidget t m ()
544−-- * mouse inputs inside the region have their coordinates translated such
665+text = richText def
545−-- that (0,0) is the top-left corner of the region
666+
546−pane
667+-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
547− :: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
668+-- that are hidden)
548− => Dynamic t Region
669+scrollableText
549− -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
670+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m)
550− -> m a
671+ => Event t Int
551− -> m a
672+ -- ^ Number of lines to scroll by
552−pane dr foc child = localRegion (const dr) $
673+ -> Behavior t Text
553− mapImages (imagesInRegion $ current dr) $
674+ -> VtyWidget t m (Behavior t (Int, Int))
554− localFocus (const foc) $
675+ -- ^ (Current scroll position, total number of lines)
555− inputInFocusedRegion >>= \e -> localInput (const e) child
676+scrollableText scrollBy t = do
677+ dw <- displayWidth
678+ let imgs = wrap <$> current dw <*> t
679+ kup <- key V.KUp
680+ kdown <- key V.KDown
681+ m <- mouseScroll
682+ let requestedScroll :: Event t Int
683+ requestedScroll = leftmost
684+ [ 1 <$ kdown
685+ , (-1) <$ kup
686+ , ffor m $ \case
687+ ScrollDirection_Up -> (-1)
688+ ScrollDirection_Down -> 1
689+ , scrollBy
690+ ]
691+ updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
692+ lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
693+ attach (length <$> imgs) requestedScroll
694+ tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
695+ return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
696+ where
697+ wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
556
698
557−-- * Misc
699+-- | Renders any behavior whose value can be converted to
700+-- 'String' as text
701+display
702+ :: (Reflex t, Monad m, Show a)
703+ => Behavior t a
704+ -> VtyWidget t m ()
705+display a = text $ T.pack . show <$> a
558
706
559-- | A widget that draws nothing
707-- | A widget that draws nothing
560−blank :: Monad m => m ()
708+blank :: Monad m => VtyWidget t m ()
561blank = return ()
709blank = return ()
src/Reflex/Vty/Widget/Box.hsdeleted−124
@@ -1,124 +0,0 @@
1−{-|
2− Description: Drawing boxes in various styles
3−-}
4−module Reflex.Vty.Widget.Box where
5−
6−import Data.Default
7−import Data.Text (Text)
8−import qualified Data.Text as T
9−import Graphics.Vty (Image)
10−import qualified Graphics.Vty as V
11−import Reflex
12−import Reflex.Vty.Widget
13−import Reflex.Vty.Widget.Text
14−
15−-- | Fill the background with the bottom box style
16−hRule :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => BoxStyle -> m ()
17−hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)
18−
19−-- | Defines a set of symbols to use to draw the outlines of boxes
20−-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character
21−data BoxStyle = BoxStyle
22− { _boxStyle_nw :: Char
23− , _boxStyle_n :: Char
24− , _boxStyle_ne :: Char
25− , _boxStyle_e :: Char
26− , _boxStyle_se :: Char
27− , _boxStyle_s :: Char
28− , _boxStyle_sw :: Char
29− , _boxStyle_w :: Char
30− }
31−
32−instance Default BoxStyle where
33− def = singleBoxStyle
34−
35−-- | A box style that uses hyphens and pipe characters. Doesn't handle
36−-- corners very well.
37−hyphenBoxStyle :: BoxStyle
38−hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
39−
40−-- | A single line box style
41−singleBoxStyle :: BoxStyle
42−singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
43−
44−-- | A thick single line box style
45−thickBoxStyle :: BoxStyle
46−thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
47−
48−-- | A double line box style
49−doubleBoxStyle :: BoxStyle
50−doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
51−
52−-- | A single line box style with rounded corners
53−roundedBoxStyle :: BoxStyle
54−roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
55−
56−-- | Draws a titled box in the provided style and a child widget inside of that box
57−boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
58− => Behavior t BoxStyle
59− -> Behavior t Text
60− -> m a
61− -> m a
62−boxTitle boxStyle title child = do
63− dh <- displayHeight
64− dw <- displayWidth
65− bt <- theme
66− let boxReg = Region 0 0 <$> dw <*> dh
67− innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)
68−
69− tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg)
70− tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r]))
71−
72− pane innerReg (pure True) child
73− where
74− boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image]
75− boxImages attr title' style (Region left top width height) =
76− let right = left + width - 1
77− bottom = top + height - 1
78− sides =
79− [ withinImage (Region (left + 1) top (width - 2) 1) $
80− V.text' attr $
81− hPadText title' (_boxStyle_n style) (width - 2)
82− , withinImage (Region right (top + 1) 1 (height - 2)) $
83− V.charFill attr (_boxStyle_e style) 1 (height - 2)
84− , withinImage (Region (left + 1) bottom (width - 2) 1) $
85− V.charFill attr (_boxStyle_s style) (width - 2) 1
86− , withinImage (Region left (top + 1) 1 (height - 2)) $
87− V.charFill attr (_boxStyle_w style) 1 (height - 2)
88− ]
89− corners =
90− [ withinImage (Region left top 1 1) $
91− V.char attr (_boxStyle_nw style)
92− , withinImage (Region right top 1 1) $
93− V.char attr (_boxStyle_ne style)
94− , withinImage (Region right bottom 1 1) $
95− V.char attr (_boxStyle_se style)
96− , withinImage (Region left bottom 1 1) $
97− V.char attr (_boxStyle_sw style)
98− ]
99− in sides ++ if width > 1 && height > 1 then corners else []
100− hPadText :: T.Text -> Char -> Int -> T.Text
101− hPadText t c l = if lt >= l
102− then t
103− else left <> t <> right
104− where
105− lt = T.length t
106− delta = l - lt
107− mkHalf n = T.replicate (n `div` 2) (T.singleton c)
108− left = mkHalf $ delta + 1
109− right = mkHalf delta
110−
111−-- | A box without a title
112−box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
113− => Behavior t BoxStyle
114− -> m a
115− -> m a
116−box boxStyle = boxTitle boxStyle mempty
117−
118−-- | A box whose style is static
119−boxStatic
120− :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
121− => BoxStyle
122− -> m a
123− -> m a
124−boxStatic = box . pure
src/Reflex/Vty/Widget/Input.hs+22−40
@@ -2,26 +2,24 @@
2Module: Reflex.Vty.Widget.Input
2Module: Reflex.Vty.Widget.Input
3Description: User input widgets for reflex-vty
3Description: User input widgets for reflex-vty
4-}
4-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE OverloadedStrings #-}
5module Reflex.Vty.Widget.Input
7module Reflex.Vty.Widget.Input
6 ( module Export
8 ( module Export
7 , module Reflex.Vty.Widget.Input
9 , module Reflex.Vty.Widget.Input
8 ) where
10 ) where
9
11
10
12
11−import Reflex.Vty.Widget.Input.Mouse as Export
12import Reflex.Vty.Widget.Input.Text as Export
13import Reflex.Vty.Widget.Input.Text as Export
13
14
14import Control.Monad (join)
15import Control.Monad (join)
15import Control.Monad.Fix (MonadFix)
16import Control.Monad.Fix (MonadFix)
17+import Control.Monad.NodeId (MonadNodeId)
16import Data.Default (Default(..))
18import Data.Default (Default(..))
17import Data.Text (Text)
19import Data.Text (Text)
18import qualified Graphics.Vty as V
20import qualified Graphics.Vty as V
19import Reflex
21import Reflex
20import Reflex.Vty.Widget
22import Reflex.Vty.Widget
21−import Reflex.Vty.Widget.Box
22−import Reflex.Vty.Widget.Text
23−
24−-- * Buttons
25
23
26-- | Configuration options for the 'button' widget
24-- | Configuration options for the 'button' widget
27data ButtonConfig t = ButtonConfig
25data ButtonConfig t = ButtonConfig
@@ -34,10 +32,10 @@ instance Reflex t => Default (ButtonConfig t) where
34
32
35-- | A button widget that contains a sub-widget
33-- | A button widget that contains a sub-widget
36button
34button
37− :: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
35+ :: (Reflex t, Monad m, MonadNodeId m)
38 => ButtonConfig t
36 => ButtonConfig t
39− -> m ()
37+ -> VtyWidget t m ()
40− -> m (Event t ())
38+ -> VtyWidget t m (Event t ())
41button cfg child = do
39button cfg child = do
42 f <- focus
40 f <- focus
43 let style = do
41 let style = do
@@ -52,44 +50,39 @@ button cfg child = do
52
50
53-- | A button widget that displays text that can change
51-- | A button widget that displays text that can change
54textButton
52textButton
55− :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
53+ :: (Reflex t, Monad m, MonadNodeId m)
56 => ButtonConfig t
54 => ButtonConfig t
57 -> Behavior t Text
55 -> Behavior t Text
58− -> m (Event t ())
56+ -> VtyWidget t m (Event t ())
59textButton cfg = button cfg . text -- TODO Centering etc.
57textButton cfg = button cfg . text -- TODO Centering etc.
60
58
61-- | A button widget that displays a static bit of text
59-- | A button widget that displays a static bit of text
62textButtonStatic
60textButtonStatic
63− :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
61+ :: (Reflex t, Monad m, MonadNodeId m)
64 => ButtonConfig t
62 => ButtonConfig t
65 -> Text
63 -> Text
66− -> m (Event t ())
64+ -> VtyWidget t m (Event t ())
67textButtonStatic cfg = textButton cfg . pure
65textButtonStatic cfg = textButton cfg . pure
68
66
69−-- * Links
70−
71-- | A clickable link widget
67-- | A clickable link widget
72link
68link
73− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m)
69+ :: (Reflex t, Monad m)
74 => Behavior t Text
70 => Behavior t Text
75− -> m (Event t MouseUp)
71+ -> VtyWidget t m (Event t MouseUp)
76link t = do
72link t = do
77− bt <- theme
78 let cfg = RichTextConfig
73 let cfg = RichTextConfig
79− { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt
74+ { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline
80 }
75 }
81 richText cfg t
76 richText cfg t
82 mouseUp
77 mouseUp
83
78
84-- | A clickable link widget with a static label
79-- | A clickable link widget with a static label
85linkStatic
80linkStatic
86− :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)
81+ :: (Reflex t, Monad m)
87 => Text
82 => Text
88− -> m (Event t MouseUp)
83+ -> VtyWidget t m (Event t MouseUp)
89linkStatic = link . pure
84linkStatic = link . pure
90
85
91−-- * Checkboxes
92−
93-- | Characters used to render checked and unchecked textboxes
86-- | Characters used to render checked and unchecked textboxes
94data CheckboxStyle = CheckboxStyle
87data CheckboxStyle = CheckboxStyle
95 { _checkboxStyle_unchecked :: Text
88 { _checkboxStyle_unchecked :: Text
@@ -116,43 +109,32 @@ checkboxStyleTick = CheckboxStyle
116-- | Configuration options for a checkbox
109-- | Configuration options for a checkbox
117data CheckboxConfig t = CheckboxConfig
110data CheckboxConfig t = CheckboxConfig
118 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
111 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
119− -- TODO DELETE and use HasTheme instead
120 , _checkboxConfig_attributes :: Behavior t V.Attr
112 , _checkboxConfig_attributes :: Behavior t V.Attr
121− , _checkboxConfig_setValue :: Event t Bool
122 }
113 }
123
114
124instance (Reflex t) => Default (CheckboxConfig t) where
115instance (Reflex t) => Default (CheckboxConfig t) where
125 def = CheckboxConfig
116 def = CheckboxConfig
126 { _checkboxConfig_checkboxStyle = pure def
117 { _checkboxConfig_checkboxStyle = pure def
127 , _checkboxConfig_attributes = pure V.defAttr
118 , _checkboxConfig_attributes = pure V.defAttr
128− , _checkboxConfig_setValue = never
129 }
119 }
130
120
131-- | A checkbox widget
121-- | A checkbox widget
132checkbox
122checkbox
133− :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)
123+ :: (MonadHold t m, MonadFix m, Reflex t)
134 => CheckboxConfig t
124 => CheckboxConfig t
135 -> Bool
125 -> Bool
136− -> m (Dynamic t Bool)
126+ -> VtyWidget t m (Dynamic t Bool)
137checkbox cfg v0 = do
127checkbox cfg v0 = do
138 md <- mouseDown V.BLeft
128 md <- mouseDown V.BLeft
139 mu <- mouseUp
129 mu <- mouseUp
140− space <- key (V.KChar ' ')
130+ v <- toggle v0 $ () <$ mu
141− f <- focus
142− v <- foldDyn ($) v0 $ leftmost
143− [ not <$ mu
144− , not <$ space
145− , const <$> _checkboxConfig_setValue cfg
146− ]
147− let bold = V.withStyle mempty V.bold
148 depressed <- hold mempty $ leftmost
131 depressed <- hold mempty $ leftmost
149− [ bold <$ md
132+ [ V.withStyle mempty V.bold <$ md
150 , mempty <$ mu
133 , mempty <$ mu
151 ]
134 ]
152− let focused = ffor (current f) $ \x -> if x then bold else mempty
153− let attrs = mconcat <$> sequence [_checkboxConfig_attributes cfg, depressed, focused]
135+ let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed
154 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
136 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
155 if checked
137 if checked
156− then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg
138+ then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg
157− else _checkboxStyle_unchecked <$> _checkboxConfig_checkboxStyle cfg
139+ else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg
158 return v
140 return v
src/Reflex/Vty/Widget/Input/Mouse.hsdeleted−106
@@ -1,106 +0,0 @@
1−{-|
2− Description: Mouse clicks, drags, and scrolls
3−-}
4−module Reflex.Vty.Widget.Input.Mouse where
5−
6−import Control.Monad.Fix
7−import qualified Graphics.Vty as V
8−import Reflex
9−import Reflex.Vty.Widget
10−
11−-- | Information about a drag operation
12−data Drag = Drag
13− { _drag_from :: (Int, Int) -- ^ Where the drag began
14− , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
15− , _drag_button :: V.Button -- ^ Which mouse button is dragging
16− , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
17− , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
18− }
19− deriving (Eq, Ord, Show)
20−
21−-- | Converts raw vty mouse drag events into an event stream of 'Drag's
22−drag
23− :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
24− => V.Button
25− -> m (Event t Drag)
26−drag btn = do
27− inp <- input
28− let f :: Maybe Drag -> V.Event -> Maybe Drag
29− f Nothing = \case
30− V.EvMouseDown x y btn' mods
31− | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
32− | otherwise -> Nothing
33− _ -> Nothing
34− f (Just (Drag from _ _ mods end)) = \case
35− V.EvMouseDown x y btn' mods'
36− | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
37− | btn == btn' -> Just $ Drag from (x,y) btn mods' False
38− | otherwise -> Nothing -- Ignore other buttons.
39− V.EvMouseUp x y (Just btn')
40− | end -> Nothing
41− | btn == btn' -> Just $ Drag from (x,y) btn mods True
42− | otherwise -> Nothing
43− V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
44− -- assume it's the right one.
45− | end -> Nothing
46− | otherwise -> Just $ Drag from (x,y) btn mods True
47− _ -> Nothing
48− rec let newDrag = attachWithMaybe f (current dragD) inp
49− dragD <- holdDyn Nothing $ Just <$> newDrag
50− return (fmapMaybe id $ updated dragD)
51−
52−-- | Mouse down events for a particular mouse button
53−mouseDown
54− :: (Reflex t, Monad m, HasInput t m)
55− => V.Button
56− -> m (Event t MouseDown)
57−mouseDown btn = do
58− i <- input
59− return $ fforMaybe i $ \case
60− V.EvMouseDown x y btn' mods -> if btn == btn'
61− then Just $ MouseDown btn' (x, y) mods
62− else Nothing
63− _ -> Nothing
64−
65−-- | Mouse up events for a particular mouse button
66−mouseUp
67− :: (Reflex t, Monad m, HasInput t m)
68− => m (Event t MouseUp)
69−mouseUp = do
70− i <- input
71− return $ fforMaybe i $ \case
72− V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
73− _ -> Nothing
74−
75−-- | Information about a mouse down event
76−data MouseDown = MouseDown
77− { _mouseDown_button :: V.Button
78− , _mouseDown_coordinates :: (Int, Int)
79− , _mouseDown_modifiers :: [V.Modifier]
80− }
81− deriving (Eq, Ord, Show)
82−
83−-- | Information about a mouse up event
84−data MouseUp = MouseUp
85− { _mouseUp_button :: Maybe V.Button
86− , _mouseUp_coordinates :: (Int, Int)
87− }
88− deriving (Eq, Ord, Show)
89−
90−-- | Mouse scroll direction
91−data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
92− deriving (Eq, Ord, Show)
93−
94−-- | Produce an event that fires when the mouse wheel is scrolled
95−mouseScroll
96− :: (Reflex t, Monad m, HasInput t m)
97− => m (Event t ScrollDirection)
98−mouseScroll = do
99− up <- mouseDown V.BScrollUp
100− down <- mouseDown V.BScrollDown
101− return $ leftmost
102− [ ScrollDirection_Up <$ up
103− , ScrollDirection_Down <$ down
104− ]
105−
106−
src/Reflex/Vty/Widget/Input/Text.hs+22−22
@@ -2,6 +2,11 @@
2Module: Reflex.Vty.Widget.Input.Text
2Module: Reflex.Vty.Widget.Input.Text
3Description: Widgets for accepting text input from users and manipulating text within those inputs
3Description: Widgets for accepting text input from users and manipulating text within those inputs
4-}
4-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE RecursiveDo #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
5module Reflex.Vty.Widget.Input.Text
10module Reflex.Vty.Widget.Input.Text
6 ( module Reflex.Vty.Widget.Input.Text
11 ( module Reflex.Vty.Widget.Input.Text
7 , def
12 , def
@@ -9,6 +14,7 @@ module Reflex.Vty.Widget.Input.Text
9
14
10import Control.Monad (join)
15import Control.Monad (join)
11import Control.Monad.Fix (MonadFix)
16import Control.Monad.Fix (MonadFix)
17+import Control.Monad.NodeId (MonadNodeId)
12import Data.Default (Default(..))
18import Data.Default (Default(..))
13import Data.Text (Text)
19import Data.Text (Text)
14import Data.Text.Zipper
20import Data.Text.Zipper
@@ -17,7 +23,6 @@ import Reflex
17
23
18import Reflex.Vty.Widget
24import Reflex.Vty.Widget
19import Reflex.Vty.Widget.Layout
25import Reflex.Vty.Widget.Layout
20−import Reflex.Vty.Widget.Input.Mouse
21
26
22-- | Configuration options for a 'textInput'. For more information on
27-- | Configuration options for a 'textInput'. For more information on
23-- 'TextZipper', see 'Data.Text.Zipper'.
28-- 'TextZipper', see 'Data.Text.Zipper'.
@@ -43,16 +48,14 @@ data TextInput t = TextInput
43
48
44-- | A widget that allows text input
49-- | A widget that allows text input
45textInput
50textInput
46− :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)
51+ :: (Reflex t, MonadHold t m, MonadFix m)
47 => TextInputConfig t
52 => TextInputConfig t
48− -> m (TextInput t)
53+ -> VtyWidget t m (TextInput t)
49textInput cfg = do
54textInput cfg = do
50 i <- input
55 i <- input
51 f <- focus
56 f <- focus
52 dh <- displayHeight
57 dh <- displayHeight
53 dw <- displayWidth
58 dw <- displayWidth
54− bt <- theme
55− attr0 <- sample bt
56 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
59 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
57 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
60 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
58 , _textInputConfig_modify cfg
61 , _textInputConfig_modify cfg
@@ -61,20 +64,13 @@ textInput cfg = do
61 goToDisplayLinePosition mx (st + my) dl
64 goToDisplayLinePosition mx (st + my) dl
62 ]
65 ]
63 click <- mouseDown V.BLeft
66 click <- mouseDown V.BLeft
64−
67+ let cursorAttrs = ffor f $ \x -> if x then cursorAttributes else V.defAttr
65− -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)
68+ let rows = (\w s c -> displayLines w V.defAttr c s)
66− let toCursorAttrs attr = V.withStyle attr V.reverseVideo
67− rowInputDyn = (,,)
68 <$> dw
69 <$> dw
69 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
70 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
70− <*> f
71+ <*> cursorAttrs
71− toDisplayLines attr (w, s, x) =
72− let c = if x then toCursorAttrs attr else attr
73− in displayLines w attr c s
74− attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)
75− let rows = ffor2 attrDyn rowInputDyn toDisplayLines
76 img = images . _displayLines_spans <$> rows
72 img = images . _displayLines_spans <$> rows
77− y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows
73+ y <- holdUniqDyn $ _displayLines_cursorY <$> rows
78 let newScrollTop :: Int -> (Int, Int) -> Int
74 let newScrollTop :: Int -> (Int, Int) -> Int
79 newScrollTop st (h, cursorY)
75 newScrollTop st (h, cursorY)
80 | cursorY < st = cursorY
76 | cursorY < st = cursorY
@@ -90,9 +86,9 @@ textInput cfg = do
90
86
91-- | A widget that allows multiline text input
87-- | A widget that allows multiline text input
92multilineTextInput
88multilineTextInput
93− :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)
89+ :: (Reflex t, MonadHold t m, MonadFix m)
94 => TextInputConfig t
90 => TextInputConfig t
95− -> m (TextInput t)
91+ -> VtyWidget t m (TextInput t)
96multilineTextInput cfg = do
92multilineTextInput cfg = do
97 i <- input
93 i <- input
98 textInput $ cfg
94 textInput $ cfg
@@ -108,18 +104,22 @@ multilineTextInput cfg = do
108-- the computed line count to greedily size the tile when vertically
104-- the computed line count to greedily size the tile when vertically
109-- oriented, and uses the fallback width when horizontally oriented.
105-- oriented, and uses the fallback width when horizontally oriented.
110textInputTile
106textInputTile
111− :: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)
107+ :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
112− => m (TextInput t)
108+ => VtyWidget t m (TextInput t)
113 -> Dynamic t Int
109 -> Dynamic t Int
114− -> m (TextInput t)
110+ -> Layout t m (TextInput t)
115textInputTile txt width = do
111textInputTile txt width = do
116 o <- askOrientation
112 o <- askOrientation
117− rec t <- tile (Constraint_Fixed <$> sz) txt
113+ rec t <- fixed sz txt
118 let sz = join $ ffor o $ \case
114 let sz = join $ ffor o $ \case
119 Orientation_Column -> _textInput_lines t
115 Orientation_Column -> _textInput_lines t
120 Orientation_Row -> width
116 Orientation_Row -> width
121 return t
117 return t
122
118
119+-- | Default attributes for the text cursor
120+cursorAttributes :: V.Attr
121+cursorAttributes = V.withStyle V.defAttr V.reverseVideo
122+
123-- | Turn a set of display line rows into a list of images (one per line)
123-- | Turn a set of display line rows into a list of images (one per line)
124images :: [[Span V.Attr]] -> [V.Image]
124images :: [[Span V.Attr]] -> [V.Image]
125images = map (V.horizCat . map spanToImage)
125images = map (V.horizCat . map spanToImage)
src/Reflex/Vty/Widget/Layout.hs+234−499
@@ -2,405 +2,86 @@
2Module: Reflex.Vty.Widget.Layout
2Module: Reflex.Vty.Widget.Layout
3Description: Monad transformer and tools for arranging widgets and building screen layouts
3Description: Monad transformer and tools for arranging widgets and building screen layouts
4-}
4-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE RecursiveDo #-}
5−{-# Language UndecidableInstances #-}
10+{-# LANGUAGE UndecidableInstances #-}
6−
11+
7−module Reflex.Vty.Widget.Layout where
12+module Reflex.Vty.Widget.Layout
8−
13+ ( Orientation(..)
9−import Control.Applicative (liftA2)
14+ , Constraint(..)
10−import Control.Monad.Morph
15+ , Layout
16+ , runLayout
17+ , TileConfig(..)
18+ , tile
19+ , fixed
20+ , stretch
21+ , col
22+ , row
23+ , tabNavigation
24+ , askOrientation
25+ ) where
26+
11−import Control.Monad.NodeId (MonadNodeId(..), NodeId)
27+import Control.Monad.NodeId (NodeId, MonadNodeId(..))
12import Control.Monad.Reader
28import Control.Monad.Reader
13−import Data.List (mapAccumL)
29+import Data.Bimap (Bimap)
30+import qualified Data.Bimap as Bimap
31+import Data.Default (Default(..))
14−import Data.Map.Ordered (OMap)
32+import Data.Map (Map)
15−import qualified Data.Map.Ordered as OMap
33+import qualified Data.Map as Map
16−import Data.Maybe (fromMaybe, isNothing)
34+import Data.Maybe (fromMaybe)
35+import Data.Monoid hiding (First(..))
17import Data.Ratio ((%))
36import Data.Ratio ((%))
18import Data.Semigroup (First(..))
37import Data.Semigroup (First(..))
19−import Data.Set.Ordered (OSet)
20−import qualified Data.Set.Ordered as OSet
21import qualified Graphics.Vty as V
38import qualified Graphics.Vty as V
22
39
23import Reflex
40import Reflex
24import Reflex.Host.Class (MonadReflexCreateTrigger)
41import Reflex.Host.Class (MonadReflexCreateTrigger)
25import Reflex.Vty.Widget
42import Reflex.Vty.Widget
26−import Reflex.Vty.Widget.Input.Mouse
27−
28−-- * Focus
29−--
30−-- $focus
31−--
32−-- The focus monad tracks which element is currently focused and processes
33−-- requests to change focus. Focusable elements are assigned a 'FocusId' and
34−-- can manually request focus or receive focus due to some other action (e.g.,
35−-- a tab press in a sibling element, a click event).
36−--
37−-- Focusable elements will usually be created via 'tile', but can also be
38−-- constructed via 'makeFocus' in 'HasFocus'. The latter option allows for
39−-- more find-grained control of focus behavior.
40−
41−-- ** Storing focus state
42−
43−-- | Identifies an element that is focusable. Can be created using 'makeFocus'.
44−newtype FocusId = FocusId NodeId
45− deriving (Eq, Ord)
46−
47−-- | An ordered set of focus identifiers. The order here determines the order
48−-- in which focus cycles between focusable elements.
49−newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }
50−
51−instance Semigroup FocusSet where
52− FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b
53−
54−instance Monoid FocusSet where
55− mempty = FocusSet OSet.empty
56−
57−-- | Produces a 'FocusSet' with a single element
58−singletonFS :: FocusId -> FocusSet
59−singletonFS = FocusSet . OSet.singleton
60−
61−-- ** Changing focus state
62−
63−-- | Operations that change the currently focused element.
64−data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS')
65− | Refocus_Id FocusId -- ^ Focus a particular element
66− | Refocus_Clear -- ^ Remove focus from all elements
67−
68−-- | Given a 'FocusSet', a currently focused element, and a number of positions
69−-- to move by, determine the newly focused element.
70−shiftFS :: FocusSet -> Maybe FocusId -> Int -> Maybe FocusId
71−shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
72− Nothing -> OSet.elemAt s 0
73− Just Nothing -> OSet.elemAt s 0
74− Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
75−
76−-- ** The focus management monad
77−
78−-- | A class for things that can produce focusable elements.
79−class (Monad m, Reflex t) => HasFocus t m | m -> t where
80− -- | Create a focusable element.
81− makeFocus :: m FocusId
82− -- | Emit an 'Event' of requests to change the focus.
83− requestFocus :: Event t Refocus -> m ()
84− -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused.
85− isFocused :: FocusId -> m (Dynamic t Bool)
86− -- | Run an action, additionally returning the focusable elements it produced.
87− subFoci :: m a -> m (a, Dynamic t FocusSet)
88− -- | Get a 'Dynamic' of the currently focused element identifier.
89− focusedId :: m (Dynamic t (Maybe FocusId))
90−
91−-- | A monad transformer that keeps track of the set of focusable elements and
92−-- which, if any, are currently focused, and allows focus requests.
93−newtype Focus t m a = Focus
94− { unFocus :: DynamicWriterT t FocusSet
95− (ReaderT (Dynamic t (Maybe FocusId))
96− (EventWriterT t (First Refocus) m)) a
97− }
98− deriving
99− ( Functor
100− , Applicative
101− , Monad
102− , MonadHold t
103− , MonadSample t
104− , MonadFix
105− , TriggerEvent t
106− , PerformEvent t
107− , NotReady t
108− , MonadReflexCreateTrigger t
109− , HasDisplayRegion t
110− , PostBuild t
111− , MonadNodeId
112− , MonadIO
113− )
114−
115−
116−instance MonadTrans (Focus t) where
117− lift = Focus . lift . lift . lift
118−
119−instance MFunctor (Focus t) where
120− hoist f = Focus . hoist (hoist (hoist f)) . unFocus
121−
122−instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
123− runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
124− traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
125− traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
126− traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
127−
128−instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where
129− localInput f = hoist (localInput f)
130−
131−instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
132− mapImages f = hoist (mapImages f)
133−
134−instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
135−
136−instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)
137−
138−instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where
139− makeFocus = do
140− fid <- FocusId <$> lift getNextNodeId
141− Focus $ tellDyn $ pure $ singletonFS fid
142− pure fid
143− requestFocus = Focus . tellEvent . fmap First
144− isFocused fid = do
145− sel <- Focus ask
146− pure $ (== Just fid) <$> sel
147− subFoci (Focus child) = Focus $ do
148− (a, fs) <- lift $ runDynamicWriterT child
149− tellDyn fs
150− return (a, fs)
151− focusedId = Focus ask
152−
153−-- | Runs a 'Focus' action, maintaining the selection state internally.
154−runFocus
155− :: (MonadFix m, MonadHold t m, Reflex t)
156− => Focus t m a
157− -> m (a, Dynamic t FocusSet)
158−runFocus (Focus x) = do
159− rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x
160− sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests
161− pure (a, focusIds)
162− where
163− f :: (FocusSet, First Refocus) -> Maybe FocusId -> Maybe FocusId
164− f (fs, rf) mf = case getFirst rf of
165− Refocus_Clear -> Nothing
166− Refocus_Id fid -> Just fid
167− Refocus_Shift n -> if n < 0 && isNothing mf
168− then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n
169− else shiftFS fs mf n
170−
171−-- | Runs an action in the focus monad, providing it with information about
172−-- whether any of the foci created within it are focused.
173−anyChildFocused
174− :: (HasFocus t m, MonadFix m)
175− => (Dynamic t Bool -> m a)
176− -> m a
177−anyChildFocused f = do
178− fid <- focusedId
179− rec (a, fs) <- subFoci (f b)
180− let b = liftA2 (\foc s -> case foc of
181− Nothing -> False
182− Just f' -> OSet.member f' $ unFocusSet s) fid fs
183− pure a
184−
185−-- ** Focus controls
186−
187−-- | Request focus be shifted backward and forward based on tab presses. <Tab>
188−-- shifts focus forward and <Shift+Tab> shifts focus backward.
189−tabNavigation :: (Reflex t, HasInput t m, HasFocus t m) => m ()
190−tabNavigation = do
191− fwd <- fmap (const 1) <$> key (V.KChar '\t')
192− back <- fmap (const (-1)) <$> key V.KBackTab
193− requestFocus $ Refocus_Shift <$> leftmost [fwd, back]
194−
195−-- * Layout
196−--
197−-- $layout
198−-- The layout monad keeps track of a tree of elements, each having its own
199−-- layout constraints and orientation. Given the available rendering space, it
200−-- computes a layout solution and provides child elements with their particular
201−-- layout solution (the width and height of their rendering space).
202−--
203−-- Complex layouts are built up though some combination of:
204−--
205−-- - 'axis', which lays out its children in a particular orientation, and
206−-- - 'region', which "claims" some part of the screen according to its constraints
207−--
208−
209−-- ** Layout restrictions
210−
211−-- *** Constraints
212−
213−-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
214−data Constraint = Constraint_Fixed Int
215− | Constraint_Min Int
216− deriving (Show, Read, Eq, Ord)
217−
218−-- | Shorthand for constructing a fixed constraint
219−fixed
220− :: Reflex t
221− => Dynamic t Int
222− -> Dynamic t Constraint
223−fixed = fmap Constraint_Fixed
224−
225−-- | Shorthand for constructing a minimum size constraint
226−stretch
227− :: Reflex t
228− => Dynamic t Int
229− -> Dynamic t Constraint
230−stretch = fmap Constraint_Min
231−
232−-- | Shorthand for constructing a constraint of no minimum size
233−flex
234− :: Reflex t
235− => Dynamic t Constraint
236−flex = pure $ Constraint_Min 0
237−
238−-- *** Orientation
239
43
240-- | The main-axis orientation of a 'Layout' widget
44-- | The main-axis orientation of a 'Layout' widget
241data Orientation = Orientation_Column
45data Orientation = Orientation_Column
242 | Orientation_Row
46 | Orientation_Row
243 deriving (Show, Read, Eq, Ord)
47 deriving (Show, Read, Eq, Ord)
244
48
245−-- | Create a row-oriented 'axis'
49+data LayoutSegment = LayoutSegment
246−row
50+ { _layoutSegment_offset :: Int
247− :: (Reflex t, MonadFix m, HasLayout t m)
51+ , _layoutSegment_size :: Int
248− => m a
249− -> m a
250−row = axis (pure Orientation_Row) flex
251−
252−-- | Create a column-oriented 'axis'
253−col
254− :: (Reflex t, MonadFix m, HasLayout t m)
255− => m a
256− -> m a
257−col = axis (pure Orientation_Column) flex
258−
259−-- ** Layout management data
260−
261−-- | A collection of information related to the layout of the screen. The root
262−-- node is a "parent" widget, and the contents of the 'LayoutForest' are its
263−-- children.
264−data LayoutTree a = LayoutTree a (LayoutForest a)
265− deriving (Show)
266−
267−-- | An ordered, indexed collection of 'LayoutTree's representing information
268−-- about the children of some widget.
269−newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }
270− deriving (Show)
271−
272−instance Semigroup (LayoutForest a) where
273− LayoutForest a <> LayoutForest b = LayoutForest $ a OMap.|<> b
274−
275−instance Monoid (LayoutForest a) where
276− mempty = LayoutForest OMap.empty
277−
278−-- | Perform a lookup by 'NodeId' in a 'LayoutForest'
279−lookupLF :: NodeId -> LayoutForest a -> Maybe (LayoutTree a)
280−lookupLF n (LayoutForest a) = OMap.lookup n a
281−
282−-- | Create a 'LayoutForest' with one element
283−singletonLF :: NodeId -> LayoutTree a -> LayoutForest a
284−singletonLF n t = LayoutForest $ OMap.singleton (n, t)
285−
286−-- | Produce a 'LayoutForest' from a list. The order of the list is preserved.
287−fromListLF :: [(NodeId, LayoutTree a)] -> LayoutForest a
288−fromListLF = LayoutForest . OMap.fromList
289−
290−-- | Extract the information at the root of a 'LayoutTree'
291−rootLT :: LayoutTree a -> a
292−rootLT (LayoutTree a _) = a
293−
294−-- | Extract the child nodes of a 'LayoutTree'
295−childrenLT :: LayoutTree a -> LayoutForest a
296−childrenLT (LayoutTree _ a) = a
297−
298−-- | Produce a layout solution given a starting orientation, the overall screen
299−-- size, and a set of constraints.
300−solve
301− :: Orientation
302− -> Region
303− -> LayoutForest (Constraint, Orientation)
304− -> LayoutTree (Region, Orientation)
305−solve o0 r0 (LayoutForest cs) =
306− let a = map (\(x, t@(LayoutTree (c, _) _)) -> ((x, t), c)) $ OMap.assocs cs
307− extent = case o0 of
308− Orientation_Row -> _region_width r0
309− Orientation_Column -> _region_height r0
310− sizes = computeEdges $ computeSizes extent a
311− chunks = [ (nodeId, solve o1 r1 f)
312− | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes
313− , let r1 = chunk o0 r0 sz
314− ]
315− in LayoutTree (r0, o0) $ fromListLF chunks
316− where
317− computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
318− computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
319− (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
320− computeSizes
321− :: Int
322− -> [(a, Constraint)]
323− -> [(a, Int)]
324− computeSizes available constraints =
325− -- The minimum amount of space we need. Calculated by adding up all of
326− -- the fixed size items and all the minimum sizes of stretchable items
327− let minTotal = sum $ ffor constraints $ \case
328− (_, Constraint_Fixed n) -> n
329− (_, Constraint_Min n) -> n
330− -- The leftover space is the area we can allow stretchable items to
331− -- expand into
332− leftover = max 0 (available - minTotal)
333− -- The number of stretchable items that will try to share some of the
334− -- leftover space
335− numStretch = length $ filter (isMin . snd) constraints
336− -- Space to allocate to the stretchable items (this is the same for all
337− -- items and there may still be additional leftover space that will have
338− -- to be unevenly distributed)
339− szStretch = floor $ leftover % max numStretch 1
340− -- Remainder of available space after even distribution. This extra space
341− -- will be distributed to as many stretchable widgets as possible.
342− adjustment = max 0 $ available - minTotal - szStretch * numStretch
343− in snd $ mapAccumL (\adj (a, c) -> case c of
344− Constraint_Fixed n -> (adj, (a, n))
345− Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints
346− isMin (Constraint_Min _) = True
347− isMin _ = False
348−
349−-- | Produce a 'Region' given a starting orientation and region, and the offset
350−-- and main-axis size of the chunk.
351−chunk :: Orientation -> Region -> (Int, Int) -> Region
352−chunk o r (offset, sz) = case o of
353− Orientation_Column -> r
354− { _region_top = _region_top r + offset
355− , _region_height = sz
356− }
52+ }
357− Orientation_Row -> r
358− { _region_left = _region_left r + offset
359− , _region_width = sz
360− }
361−
362−-- ** The layout monad
363
53
364−-- | A class of operations for creating screen layouts.
54+data LayoutCtx t = LayoutCtx
365−class Monad m => HasLayout t m | m -> t where
55+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
366− -- | Starts a parent element in the current layout with the given size
56+ , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)
367− -- constraint, which lays out its children according to the provided
368− -- orientation.
369− axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
370− -- | Creates a child element in the current layout with the given size
371− -- constraint, returning the 'Region' that the child element is allocated.
372− region :: Dynamic t Constraint -> m (Dynamic t Region)
373− -- | Returns the orientation of the containing 'axis'.
374− askOrientation :: m (Dynamic t Orientation)
57+ , _layoutCtx_orientation :: Dynamic t Orientation
58+ }
375
59
376−-- | A monad transformer that collects layout constraints and provides a layout
60+-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
377−-- solution that satisfies those constraints.
61+-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
62+-- switchboard for focus requests. See 'tile' and 'runLayout'.
378newtype Layout t m a = Layout
63newtype Layout t m a = Layout
64+ { unLayout :: EventWriterT t (First NodeId)
379− { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))
65+ (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))])
380− (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a
66+ (ReaderT (LayoutCtx t)
381− }
67+ (VtyWidget t m))) a
382− deriving
68+ } deriving
383 ( Functor
69 ( Functor
384 , Applicative
70 , Applicative
385− , HasDisplayRegion t
386 , Monad
71 , Monad
387− , MonadFix
388 , MonadHold t
72 , MonadHold t
389− , MonadIO
390− , MonadNodeId
391− , MonadReflexCreateTrigger t
392 , MonadSample t
73 , MonadSample t
393− , NotReady t
74+ , MonadFix
394− , PerformEvent t
395− , PostBuild t
396 , TriggerEvent t
75 , TriggerEvent t
76+ , PerformEvent t
77+ , NotReady t
78+ , MonadReflexCreateTrigger t
79+ , HasDisplaySize t
80+ , MonadNodeId
397 )
81 )
398
82
399instance MonadTrans (Layout t) where
83instance MonadTrans (Layout t) where
400− lift = Layout . lift . lift
84+ lift x = Layout $ lift $ lift $ lift $ lift x
401−
402−instance MFunctor (Layout t) where
403− hoist f = Layout . hoist (hoist f) . unLayout
404
85
405instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
86instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
406 runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
87 runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
@@ -408,142 +89,196 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m
408 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
89 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
409 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
90 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
410
91
411−-- | Apply a transformation to the context of a child 'Layout' action and run
92+-- | Run a 'Layout' action
412−-- that action
413−hoistRunLayout
414− :: (HasDisplayRegion t m, MonadFix m, Monad n)
415− => (m a -> n b)
416− -> Layout t m a
417− -> Layout t n b
418−hoistRunLayout f x = do
419− solution <- Layout ask
420− let orientation = snd . rootLT <$> solution
421− lift $ f $ do
422− dw <- displayWidth
423− dh <- displayHeight
424− let reg = Region 0 0 <$> dw <*> dh
425− runLayout orientation reg x
426−
427−instance (HasInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasInput t (Layout t m) where
428− localInput = hoistRunLayout . localInput
429−
430−instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where
431− mapImages f = hoistRunLayout (mapImages f)
432−
433−instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)
434−
435−instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)
436−
437−instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where
438− axis o c (Layout x) = Layout $ do
439− nodeId <- getNextNodeId
440− let dummyParentLayout = LayoutTree (nilRegion, Orientation_Column) mempty
441− (result, forest) <- lift $ local (\t -> fromMaybe dummyParentLayout . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x
442− tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)
443− pure result
444− region c = do
445− nodeId <- lift getNextNodeId
446− Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty
447− solutions <- Layout ask
448− pure $ maybe nilRegion (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions
449− askOrientation = Layout $ asks $ fmap (snd . rootLT)
450−
451−instance (MonadFix m, HasFocus t m) => HasFocus t (Layout t m) where
452− makeFocus = lift makeFocus
453− requestFocus = lift . requestFocus
454− isFocused = lift . isFocused
455− focusedId = lift focusedId
456− subFoci (Layout x) = Layout $ do
457− y <- ask
458− ((a, w), sf) <- lift $ lift $ subFoci $ flip runReaderT y $ runDynamicWriterT x
459− tellDyn w
460− pure (a, sf)
461−
462−-- | Runs a 'Layout' action, using the given orientation and region to
463−-- calculate layout solutions.
464runLayout
93runLayout
465− :: (MonadFix m, Reflex t)
94+ :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
466− => Dynamic t Orientation
95+ => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
467− -> Dynamic t Region
96+ -> Int -- ^ The positional index of the initially focused tile
97+ -> Event t Int -- ^ An event that shifts focus by a given number of tiles
98+ -> Layout t m a -- ^ The 'Layout' widget
99+ -> VtyWidget t m a
100+runLayout ddir focus0 focusShift (Layout child) = do
101+ dw <- displayWidth
102+ dh <- displayHeight
103+ let main = ffor3 ddir dw dh $ \d w h -> case d of
104+ Orientation_Column -> h
105+ Orientation_Row -> w
106+ pb <- getPostBuild
107+ rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir
108+ let queries = flip appEndo [] <$> queriesEndo
109+ solution = ffor2 main queries $ \sz qs -> Map.fromList
110+ . Map.elems
111+ . computeEdges
112+ . computeSizes sz
113+ . fmap (fmap snd)
114+ . Map.fromList
115+ . zip [0::Integer ..]
116+ $ qs
117+ solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
118+ { _layoutSegment_offset = offset
119+ , _layoutSegment_size = sz
120+ }
121+ focusable = fmap (Bimap.fromList . zip [0..]) $
122+ ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
123+ if f then Just nodeId else Nothing
124+ adjustFocus
125+ :: (Bimap Int NodeId, (Int, Maybe NodeId))
126+ -> Either Int NodeId
127+ -> (Int, Maybe NodeId)
128+ adjustFocus (fm, (cur, _)) (Left shift) =
129+ let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
130+ in (ix, Bimap.lookup ix fm)
131+ adjustFocus (fm, (cur, _)) (Right goto) =
132+ let ix = fromMaybe cur $ Bimap.lookupR goto fm
133+ in (ix, Just goto)
134+ focusChange = attachWith
135+ adjustFocus
136+ (current $ (,) <$> focusable <*> focussed)
137+ $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
138+ -- A pair (Int, Maybe NodeId) which represents the index
139+ -- that we're trying to focus, and the node that actually gets
140+ -- focused (at that index) if it exists
141+ focussed <- holdDyn (focus0, Nothing) focusChange
142+ let focusDemux = demux $ snd <$> focussed
143+ return a
144+
145+-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
146+-- on its size and ability to grow and on whether it can be focused. It also allows its child
147+-- widget to request focus.
148+tile
149+ :: (Reflex t, Monad m, MonadNodeId m)
150+ => TileConfig t -- ^ The tile's configuration
151+ -> VtyWidget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
468 -> Layout t m a
152 -> Layout t m a
469− -> m a
153+tile (TileConfig con focusable) child = do
470−runLayout o r (Layout x) = do
154+ nodeId <- getNextNodeId
471− rec (result, w) <- runReaderT (runDynamicWriterT x) solutions
155+ Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)
472− let solutions = solve <$> o <*> r <*> w
156+ seg <- Layout $ asks $
473− return result
157+ fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
474−
475−-- | Initialize and run the layout monad, using all of the available screen space.
476−initLayout :: (HasDisplayRegion t m, MonadFix m) => Layout t m a -> m a
477−initLayout f = do
478 dw <- displayWidth
158 dw <- displayWidth
479 dh <- displayHeight
159 dh <- displayHeight
480− let r = Region 0 0 <$> dw <*> dh
160+ o <- askOrientation
481− runLayout (pure Orientation_Column) r f
161+ let cross = join $ ffor o $ \case
162+ Orientation_Column -> dw
163+ Orientation_Row -> dh
164+ let reg = DynRegion
165+ { _dynRegion_top = ffor2 seg o $ \s -> \case
166+ Orientation_Column -> _layoutSegment_offset s
167+ Orientation_Row -> 0
168+ , _dynRegion_left = ffor2 seg o $ \s -> \case
169+ Orientation_Column -> 0
170+ Orientation_Row -> _layoutSegment_offset s
171+ , _dynRegion_width = ffor3 seg cross o $ \s c -> \case
172+ Orientation_Column -> c
173+ Orientation_Row -> _layoutSegment_size s
174+ , _dynRegion_height = ffor3 seg cross o $ \s c -> \case
175+ Orientation_Column -> _layoutSegment_size s
176+ Orientation_Row -> c
177+ }
178+ focussed <- Layout $ asks _layoutCtx_focusDemux
179+ (focusReq, a) <- Layout $ lift $ lift $ lift $
180+ pane reg (demuxed focussed $ Just nodeId) $ child
181+ Layout $ tellEvent $ First nodeId <$ focusReq
182+ return a
183+
184+-- | Configuration options for and constraints on 'tile'
185+data TileConfig t = TileConfig
186+ { _tileConfig_constraint :: Dynamic t Constraint
187+ -- ^ 'Constraint' on the tile's size
188+ , _tileConfig_focusable :: Dynamic t Bool
189+ -- ^ Whether the tile is focusable
190+ }
482
191
483−-- * The tile "window manager"
192+instance Reflex t => Default (TileConfig t) where
484−--
193+ def = TileConfig (pure $ Constraint_Min 0) (pure True)
485−-- $tiling
486−-- Generally HasLayout and HasFocus are used together to build a user
487−-- interface. These functions check the available screen size and initialize
488−-- the layout monad with that information, and also initialize the focus monad.
489
194
490−-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.
195+-- | A 'tile' of a fixed size that is focusable and gains focus on click
491−initManager
196+fixed
492− :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
197+ :: (Reflex t, Monad m, MonadNodeId m)
493− => Layout t (Focus t m) a
494− -> m (a, Dynamic t FocusSet)
198+ => Dynamic t Int
495−initManager =
199+ -> VtyWidget t m a
496− runFocus . initLayout
200+ -> Layout t m a
201+fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
497
202
498−-- | Initialize a 'Layout' and 'Focus' management context.
203+-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
499−initManager_
204+-- This tile is focusable and gains focus on click.
500− :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
205+stretch
501− => Layout t (Focus t m) a
206+ :: (Reflex t, Monad m, MonadNodeId m)
502− -> m a
207+ => VtyWidget t m a
503−initManager_ = fmap fst . initManager
208+ -> Layout t m a
209+stretch = tile def . clickable
504
210
211+-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
212+-- change tile focus.
213+col
214+ :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
505−-- ** Layout tiles
215+ => Layout t m a
216+ -> VtyWidget t m a
217+col child = do
218+ nav <- tabNavigation
219+ runLayout (pure Orientation_Column) 0 nav child
220+
221+-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
222+-- change tile focus.
223+row
224+ :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
225+ => Layout t m a
226+ -> VtyWidget t m a
227+row child = do
228+ nav <- tabNavigation
229+ runLayout (pure Orientation_Row) 0 nav child
230+
231+-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
232+-- and backward one tile when Shift+Tab is pressed.
233+tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
234+tabNavigation = do
235+ fwd <- fmap (const 1) <$> key (V.KChar '\t')
236+ back <- fmap (const (-1)) <$> key V.KBackTab
237+ return $ leftmost [fwd, back]
238+
239+-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
240+-- requesting focus when using 'tile'.
241+clickable
242+ :: (Reflex t, Monad m)
243+ => VtyWidget t m a
244+ -> VtyWidget t m (Event t (), a)
245+clickable child = do
246+ click <- mouseDown V.BLeft
247+ a <- child
248+ return (() <$ click, a)
249+
250+-- | Retrieve the current orientation of a 'Layout'
251+askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
252+askOrientation = Layout $ asks _layoutCtx_orientation
506
253
507−-- *** Focusable
254+-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
255+data Constraint = Constraint_Fixed Int
256+ | Constraint_Min Int
257+ deriving (Show, Read, Eq, Ord)
508
258
509−-- | A widget that is focusable and occupies a layout region based on the
259+-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
510−-- provided constraint. Returns the 'FocusId' allowing for manual focus
260+computeSizes
511−-- management.
261+ :: Ord k
512−tile'
262+ => Int
513− :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
263+ -> Map k (a, Constraint)
514− => Dynamic t Constraint
264+ -> Map k (a, Int)
515− -> m a
265+computeSizes available constraints =
516− -> m (FocusId, a)
266+ let minTotal = sum $ ffor (Map.elems constraints) $ \case
517−tile' c w = do
267+ (_, Constraint_Fixed n) -> n
518− fid <- makeFocus
268+ (_, Constraint_Min n) -> n
519− r <- region c
269+ leftover = max 0 (available - minTotal)
520− parentFocused <- isFocused fid
270+ numStretch = Map.size $ Map.filter (isMin . snd) constraints
521− rec (click, result, childFocused) <- pane r focused $ anyChildFocused $ \childFoc -> do
271+ szStretch = floor $ leftover % (max numStretch 1)
522− m <- mouseDown V.BLeft
272+ adjustment = max 0 $ available - minTotal - szStretch * numStretch
523− x <- w
273+ in snd $ Map.mapAccum (\adj (a, c) -> case c of
524− pure (m, x, childFoc)
274+ Constraint_Fixed n -> (adj, (a, n))
525− let focused = (||) <$> parentFocused <*> childFocused
275+ Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
526− requestFocus $ Refocus_Id fid <$ click
276+ where
527− pure (fid, result)
277+ isMin (Constraint_Min _) = True
278+ isMin _ = False
528
279
529−-- | A widget that is focusable and occupies a layout region based on the
280+computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
530−-- provided constraint.
281+computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
531−tile
282+ (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
532− :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
533− => Dynamic t Constraint
534− -> m a
535− -> m a
536−tile c = fmap snd . tile' c
537
283
538−-- *** Unfocusable
539
284
540−-- | A widget that is not focusable and occupies a layout region based on the
541−-- provided constraint.
542−grout
543− :: (Reflex t, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
544− => Dynamic t Constraint
545− -> m a
546− -> m a
547−grout c w = do
548− r <- region c
549− pane r (pure True) w
src/Reflex/Vty/Widget/Split.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-|
2− Description: Widgets that split the display vertically or horizontally.
3−-}
4−module Reflex.Vty.Widget.Split where
5−
6−import Control.Applicative
7−import Control.Monad.Fix
8−import Graphics.Vty as V
9−import Reflex
10−import Reflex.Vty.Widget
11−import Reflex.Vty.Widget.Input.Mouse
12−
13−-- | A split of the available space into two parts with a draggable separator.
14−-- Starts with half the space allocated to each, and the first pane has focus.
15−-- Clicking in a pane switches focus.
16−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
17− => m ()
18− -> m a
19− -> m b
20− -> m (a,b)
21−splitVDrag wS wA wB = do
22− dh <- displayHeight
23− dw <- displayWidth
24− h0 <- sample $ current dh -- TODO
25− dragE <- drag V.BLeft
26− let splitter0 = h0 `div` 2
27− rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
28− splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
29− splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
30− fromIntegral x / max 1 (fromIntegral h)
31− let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
32− \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
33− if splitterY == fromY then Just (toY, end) else Nothing
34− regA = Region 0 0 <$> dw <*> splitterPos
35− regS = Region 0 <$> splitterPos <*> dw <*> 1
36− regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1)
37− resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
38− \(frac, h) -> round (frac * fromIntegral h)
39− focA <- holdDyn True $ leftmost
40− [ True <$ mA
41− , False <$ mB
42− ]
43− (mA, rA) <- pane regA focA $ withMouseDown wA
44− pane regS (pure False) wS
45− (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
46− return (rA, rB)
47− where
48− withMouseDown x = do
49− m <- mouseDown V.BLeft
50− x' <- x
51− return (m, x')
52−
53−-- | A plain split of the available space into vertically stacked panes.
54−-- No visual separator is built in here.
55−splitV :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
56− => Dynamic t (Int -> Int)
57− -- ^ Function used to determine size of first pane based on available size
58− -> Dynamic t (Bool, Bool)
59− -- ^ How to focus the two sub-panes, given that we are focused.
60− -> m a
61− -- ^ Widget for first pane
62− -> m b
63− -- ^ Widget for second pane
64− -> m (a,b)
65−splitV sizeFunD focD wA wB = do
66− dw <- displayWidth
67− dh <- displayHeight
68− let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh)
69− regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA)
70− ra <- pane regA (fst <$> focD) wA
71− rb <- pane regB (snd <$> focD) wB
72− return (ra,rb)
73−
74−-- | A plain split of the available space into horizontally stacked panes.
75−-- No visual separator is built in here.
76−splitH :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
77− => Dynamic t (Int -> Int)
78− -- ^ Function used to determine size of first pane based on available size
79− -> Dynamic t (Bool, Bool)
80− -- ^ How to focus the two sub-panes, given that we are focused.
81− -> m a
82− -- ^ Widget for first pane
83− -> m b
84− -- ^ Widget for second pane
85− -> m (a,b)
86−splitH sizeFunD focD wA wB = do
87− dw <- displayWidth
88− dh <- displayHeight
89− let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh
90− regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh
91− liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
92−
src/Reflex/Vty/Widget/Text.hsdeleted−106
@@ -1,106 +0,0 @@
1−{-|
2− Description: Text- and character-rendering widgets
3−-}
4−module Reflex.Vty.Widget.Text where
5−
6−import Control.Monad.Fix
7−import Data.Default
8−import Data.Text (Text)
9−import qualified Data.Text as T
10−import Data.Text.Zipper as TZ
11−import qualified Graphics.Vty as V
12−import Reflex
13−import Reflex.Vty.Widget
14−import Reflex.Vty.Widget.Input.Mouse
15−
16−-- | Fill the background with a particular character.
17−fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()
18−fill bc = do
19− dw <- displayWidth
20− dh <- displayHeight
21− bt <- theme
22− let fillImg =
23− (\attr w h c -> [V.charFill attr c w h])
24− <$> bt
25− <*> current dw
26− <*> current dh
27− <*> bc
28− tellImages fillImg
29−
30−-- | Configuration options for displaying "rich" text
31−data RichTextConfig t = RichTextConfig
32− { _richTextConfig_attributes :: Behavior t V.Attr
33− }
34−
35−instance Reflex t => Default (RichTextConfig t) where
36− def = RichTextConfig $ pure V.defAttr
37−
38−
39−-- TODO delete this and use new local theming
40−-- | A widget that displays text with custom time-varying attributes
41−richText
42− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
43− => RichTextConfig t
44− -> Behavior t Text
45− -> m ()
46−richText cfg t = do
47− dw <- displayWidth
48− let img = (\w a s -> [wrapText w a s])
49− <$> current dw
50− <*> _richTextConfig_attributes cfg
51− <*> t
52− tellImages img
53− where
54− wrapText maxWidth attrs = V.vertCat
55− . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
56− . T.split (=='\n')
57−
58−-- | Renders text, wrapped to the container width
59−text
60− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
61− => Behavior t Text
62− -> m ()
63−text t = do
64− bt <- theme
65− richText (RichTextConfig bt) t
66−
67−-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
68−-- that are hidden)
69−scrollableText
70− :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)
71− => Event t Int
72− -- ^ Number of lines to scroll by
73− -> Behavior t Text
74− -> m (Behavior t (Int, Int))
75− -- ^ (Current scroll position, total number of lines)
76−scrollableText scrollBy t = do
77− dw <- displayWidth
78− bt <- theme
79− let imgs = wrap <$> bt <*> current dw <*> t
80− kup <- key V.KUp
81− kdown <- key V.KDown
82− m <- mouseScroll
83− let requestedScroll :: Event t Int
84− requestedScroll = leftmost
85− [ 1 <$ kdown
86− , (-1) <$ kup
87− , ffor m $ \case
88− ScrollDirection_Up -> (-1)
89− ScrollDirection_Down -> 1
90− , scrollBy
91− ]
92− updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
93− lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
94− attach (length <$> imgs) requestedScroll
95− tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
96− return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
97− where
98− wrap attr maxWidth = concatMap (fmap (V.string attr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
99−
100−-- | Renders any behavior whose value can be converted to
101−-- 'String' as text
102−display
103− :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
104− => Behavior t a
105− -> m ()
106−display a = text $ T.pack . show <$> a
test/Data/Text/ZipperSpec.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−module Data.Text.ZipperSpec(
4− spec
5−) where
6−
7−import Prelude
8−
9−import Test.Hspec
10−
11−import qualified Data.Map as Map
12−import qualified Data.Text as T
13−import Control.Monad
14−
15−import Data.Text.Zipper
16−
17−
18−someSentence = "12345 1234 12"
19−
20−splitSentenceAtDisplayWidth :: Int -> T.Text -> [(T.Text, Bool)]
21−splitSentenceAtDisplayWidth w t = splitWordsAtDisplayWidth w (wordsWithWhitespace t)
22−
23−spec :: Spec
24−spec =
25− describe "Zipper" $ do
26− it "wordsWithWhitespace" $ do
27− wordsWithWhitespace "" `shouldBe` []
28− wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]
29− wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"]
30− wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "]
31− it "splitWordsAtDisplayWidth" $ do
32− fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"]
33− fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"]
34− fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"]
35− fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"]
36− fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 "," 56"]
37− 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"]
38− it "wrapWithOffsetAndAlignment" $ do
39− wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]
40− wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]
41− wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]
42− wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]
43−
44− -- leading spaces and offset case
45− wrapWithOffsetAndAlignment TextAlignment_Left 5 1 (" " <> someSentence) `shouldBe` [(WrappedLine " " True 0), (WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]
46− it "eolSpacesToLogicalLines" $ do
47− eolSpacesToLogicalLines
48− [
49− [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]
50− , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]
51− ]
52− `shouldBe`
53− [
54− [ ("😱",1) ]
55− , [ ("😱",2), ("😱",3) ]
56− , [ ("aa",1) ]
57− , [ ("aa",2) ]
58− , [ ("aa",3) ]
59− ]
60− it "offsetMapWithAlignmentInternal" $ do
61− offsetMapWithAlignmentInternal
62− [
63− [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]
64− , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]
65− ]
66− `shouldBe`
67− Map.fromList
68− [ (0, (1,0))
69− , (1, (2,2)) -- jump by 1 for char and 1 for space
70− , (2, (3,3)) -- jump by 1 for char
71− , (3, (1,5)) -- jump by 1 for char and 1 for newline
72− , (4, (2,8)) -- jump by 2 for char and 1 for space
73− , (5, (3,11)) -- jump by 2 for char and 1 for space
74− ]
75− it "displayLines - cursorPos" $ do
76− let
77− dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")
78− dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu")
79− dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n")
80− dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "0123456789")
81− dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (insertChar 'a' $ fromText "aoeu")
82− dl5 = displayLinesWithAlignment TextAlignment_Right 10 () () (left $ insertChar 'a' $ fromText "aoeu")
83− dl6 = displayLinesWithAlignment TextAlignment_Right 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")
84− _displayLines_cursorPos dl0 `shouldBe` (0,0)
85− _displayLines_cursorPos dl1 `shouldBe` (4,0)
86− _displayLines_cursorPos dl2 `shouldBe` (0,1)
87− _displayLines_cursorPos dl3 `shouldBe` (0,1)
88− _displayLines_cursorPos dl4 `shouldBe` (5,0)
89− _displayLines_cursorPos dl5 `shouldBe` (4,0)
90− _displayLines_cursorPos dl6 `shouldBe` (4,0)
91− it "displayLines - offsetMap" $ do
92− let
93− dl0 = displayLinesWithAlignment TextAlignment_Left 5 () () (end $ fromText "aoeku")
94− _displayLines_cursorPos dl0 `shouldBe` (0,1)
95− Map.size (_displayLines_offsetMap dl0) `shouldBe` 2 -- cursor character is on second line
96− it "displayLinesWithAlignment - spans" $ do
97− let
98− someText = top $ fromText "0123456789abcdefgh"
99− -- outer span length should be invariant when changing TextAlignment and CursorPosition
100− forM_ [0..4] $ \x -> do
101− forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do
102− let t = rightN x $ someText
103− length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4
104− length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2
test/Spec.hsdeleted−15
@@ -1,15 +0,0 @@
1−-- hspec auto-discovery stuff
2−-- does not work with current CircleCI image so instead we do it manually for now
3−-- {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
4−
5−
6−import Test.Hspec
7−
8−import qualified Data.Text.ZipperSpec
9−
10−main :: IO ()
11−main = hspec spec
12−
13−spec :: Spec
14−spec = do
15− describe "Data.Text.ZipperSpec" Data.Text.ZipperSpec.spec