on develop help sign in
.github/workflows/haskell.yml+12−10
since splitsnapshots
unifiedsplit
@@ -1,33 +1,33 @@
1−name: Haskell CI
1+name: github-action
2
2
3on: [push, pull_request]
3on: [push, pull_request]
4
4
5jobs:
5jobs:
6 build:
6 build:
7−
8− runs-on: ${{ matrix.os }}
9 strategy:
7 strategy:
10 matrix:
8 matrix:
11− ghc: ['8.4.4', '8.6.5', '8.8.4']
9+ ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
12 os: ['ubuntu-latest', 'macos-latest']
10 os: ['ubuntu-latest', 'macos-latest']
11+ runs-on: ${{ matrix.os }}
12+
13+ name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
13 steps:
14 steps:
14 - uses: actions/checkout@v2
15 - uses: actions/checkout@v2
15 - uses: actions/setup-haskell@v1
16 - uses: actions/setup-haskell@v1
16 with:
17 with:
17 ghc-version: ${{ matrix.ghc }}
18 ghc-version: ${{ matrix.ghc }}
18− cabal-version: '3.0'
19−
20 - name: Cache
19 - name: Cache
21 uses: actions/cache@v1
20 uses: actions/cache@v1
22 env:
21 env:
23 cache-name: cache-cabal
22 cache-name: cache-cabal
24 with:
23 with:
25 path: ~/.cabal
24 path: ~/.cabal
26− key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
25+ key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
27 restore-keys: |
26 restore-keys: |
28− ${{ runner.os }}-build-${{ env.cache-name }}-
27+ ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
29− ${{ runner.os }}-build-
28+ ${{ runner.os }}-${{ matrix.ghc }}-build-
30− ${{ runner.os }}-
29+ ${{ runner.os }}-${{ matrix.ghc }}-
30+ ${{ runner.os }}
31
31
32 - name: Install dependencies
32 - name: Install dependencies
33 run: |
33 run: |
@@ -37,3 +37,5 @@ jobs:
37 run: cabal build --enable-tests --enable-benchmarks all
37 run: cabal build --enable-tests --enable-benchmarks all
38 - name: Run tests
38 - name: Run tests
39 run: cabal test all
39 run: cabal test all
40+ - name: Build Docs
41+ run: cabal haddock
.travis.ymldeleted−112
@@ -1,112 +0,0 @@
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.8.3"
34− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.8.3], sources: [hvr-ghc]}}
35− - compiler: "ghc-8.6.5"
36− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}
37− - compiler: "ghc-8.4.4"
38− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}
39−
40−
41−before_install:
42− - HC=/opt/ghc/bin/${CC}
43− - HCPKG=${HC/ghc/ghc-pkg}
44− - unset CC
45− - CABAL=/opt/ghc/bin/cabal
46− - CABALHOME=$HOME/.cabal
47− - export PATH="$CABALHOME/bin:$PATH"
48− - ROOTDIR=$(pwd)
49− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
50− - echo $HCNUMVER
51−
52−install:
53− - ${CABAL} --version
54− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
55− - TEST=--enable-tests
56− - BENCH=--enable-benchmarks
57− - GHCHEAD=${GHCHEAD-false}
58− - travis_retry ${CABAL} update -v
59− - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config
60− - rm -fv cabal.project cabal.project.local
61− - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'
62− - rm -f cabal.project
63− - touch cabal.project
64− - "printf 'packages: \".\"\\n' >> cabal.project"
65− - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
66− - touch cabal.project.local
67− - "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"
68− - cat cabal.project || true
69− - cat cabal.project.local || true
70− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
71− - rm -f cabal.project.freeze
72− - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry
73− - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
74− - rm "cabal.project.freeze"
75− - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
76− - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
77− - rm -rf .ghc.environment.* "."/dist
78− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
79−
80−# Here starts the actual work to be performed for the package under test;
81−# any command which exits with a non-zero exit code causes the build to fail.
82−script:
83− # test that source-distributions can be generated
84− - ${CABAL} new-sdist all
85− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
86− - cd ${DISTDIR} || false
87− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
88− - rm -f cabal.project
89− - touch cabal.project
90− - "printf 'packages: \"reflex-vty-*/*.cabal\"\\n' >> cabal.project"
91− - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
92− - touch cabal.project.local
93− - "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"
94− - cat cabal.project || true
95− - cat cabal.project.local || true
96− # this builds all libraries and executables (without tests/benchmarks)
97− - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all
98−
99− # build & run tests, build benchmarks
100− - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all
101−
102− # cabal check
103− - (cd reflex-vty-* && ${CABAL} check)
104−
105− # haddock
106− - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all
107−
108− # Build without installed constraints for packages in global-db
109− - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all
110−
111−# REGENDATA ["reflex-vty.cabal","--output",".travis.yml"]
112−# EOF
ChangeLog.md+90−50
@@ -1,56 +1,96 @@
1# Revision history for reflex-vty
1# Revision history for reflex-vty
2
2
3## 0.2.0.0
3## 0.2.0.0
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_:
4−* Remove text-icu dependency and switch to `wcwidth` from vty package to compute character width in `Data.Text.Zipper`.
11+ * Remove text-icu dependency and switch to `wcwidth` from vty package to compute character width in `Data.Text.Zipper`.
5−* `goToDisplayLinePosition` in `Data.Text.Zipper` correctly accounts for character width now.
12+ * `goToDisplayLinePosition` in `Data.Text.Zipper` correctly accounts for character width now.
6−* [#37](https://github.com/reflex-frp/reflex-vty/issues/37) `Layout` should support focus changes through nested layouts (thanks @pdlla for getting this started).
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_:
7−* _Breaking Change_: Layout and focus have been substantially refactored:
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.
8− * Added `MonadFocus` to produce focusable elements, and manage focus state. See the "Focus" section of the Reflex.Vty.Widget.Layout module documentation.
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.
9− * `Layout` no longer has any focus-tracking responsibility. See the "Layout" 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.
10− * `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.
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.
11− * Calls to `fixed` and `stretch` must now be replaced with `tile . fixed` and `tile . stretch`
20+ * Calls to `fixed` and `stretch` must now be replaced with `tile . fixed` and `tile . stretch`
12− * `stretch` now takes a minimum size argument
21+ * `stretch` now takes a minimum size argument
13− * Added `flex` which is equivalent to `stretch 0`
22+ * Added `flex` which is equivalent to `stretch 0`
14− * `tabNavigation` no longer returns an `Event`. Instead it calls `requestFocus` directly with the appropriate `Refocus_Shift` value.
23+ * `tabNavigation` no longer returns an `Event`. Instead it calls `requestFocus` directly with the appropriate `Refocus_Shift` value.
15− * Added `axis` (in `MonadLayout`), a lower-level primitive which is used to implement `row` and `col`.
24+ * Added `axis` (in `HasLayout`), a lower-level primitive which is used to implement `row` and `col`.
16− * Added `region` (in `MonadLayout`), which is used to claim screen real estate and used to implement `tile` and `grout`
25+ * Added `region` (in `HasLayout`), which is used to claim screen real estate and used to implement `tile` and `grout`
17− * Added `grout`, a container element that is not itself focusable (though its children can be)
26+ * Added `grout`, a container element that is not itself focusable (though its children can be)
18−* Add `HasVtyWidgetCtx` for `pane`-like sub-widget container behavior
27+ * Removed `VtyWidget` and replaced it with a number of separate classes and monad transformers
19−* Add default instances for `HasVtyInput`, `HasFocus`, and `ImageWriter`
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
20−* _Breaking Change_: Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.
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`
21−* _Breaking Change_: The following functions are no longer specialized to `VtyWidget`:
45+ * The following functions are no longer specialized to `VtyWidget`:
22− * `pane`: Now requires `HasVtyWidgetCtx` instead
46+ * `pane`: Now requires `HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m`
23− * `drag`: Now requires `HasVtyInput` instead
47+ * `drag`: Now requires `HasInput`
24− * `mouseDown`: Now requires `HasVtyInput` instead
48+ * `mouseDown`: Now requires `HasInput`
25− * `mouseUp`: Now requires `HasVtyInput` instead
49+ * `mouseUp`: Now requires `HasInput`
26− * `mouseScroll`: Now requires `HasVtyInput` instead
50+ * `mouseScroll`: Now requires `HasInput`
27− * `key`: Now requires `HasVtyInput` instead
51+ * `key`: Now requires `HasInput`
28− * `keys`: Now requires `HasVtyInput` instead
52+ * `keys`: Now requires `HasInput`
29− * `keyCombo`: Now requires `HasVtyInput` instead
53+ * `keyCombo`: Now requires `HasInput`
30− * `keyCombos`: Now requires `HasVtyInput` instead
54+ * `keyCombos`: Now requires `HasInput`
31− * `splitV`: Now requires `HasVtyWidgetCtx` and `HasDisplaySize` instead
55+ * `splitV`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
32− * `splitH`: Now requires `HasVtyWidgetCtx` and `HasDisplaySize` instead
56+ * `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
33− * `splitVDrag`: Now requires `HasVtyWidgetCtx`, `HasVtyInput`, and `HasDisplaySize` instead
57+ * `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
34− * `fill`: Now requires `ImageWriter` and `HasDisplaySize` instead
58+ * `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`
35− * `boxTitle`: Now requires `HasVtyWidgetCtx`, `ImageWriter`, and `HasDisplaySize` instead
59+ * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
36− * `box`: Now requires `HasVtyWidgetCtx`, `ImageWriter`, and `HasDisplaySize` instead
60+ * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
37− * `boxStatic`: Now requires `HasVtyWidgetCtx`, `ImageWriter`, and `HasDisplaySize` instead
61+ * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
38− * `richText`: Now requires `ImageWriter`, and `HasDisplaySize` instead
62+ * `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`
39− * `scrollableText`: Now requires `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
63+ * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
40− * `blank`: Now required `Monad` instead
64+ * `blank`: Now requires `Monad`
41− * `button`: Now requires `HasFocus`, `HasVtyWidgetCtx`, `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
65+ * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
42− * `textButton`: Now requires `HasFocus`, `HasVtyWidgetCtx`, `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
66+ * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
43− * `textButtonStatic`: Now requires `HasFocus`, `HasVtyWidgetCtx`, `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
67+ * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
44− * `link`: Now requires `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
68+ * `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
45− * `checkbox`: Now requires `HasFocus`, `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
69+ * `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
46− * `textInput`: Now requires `HasFocus`, `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
70+ * TextZipper interface changes
47− * `multilineTextInput`: Now requires `HasFocus`, `HasVtyInput`, `ImageWriter`, and `HasDisplaySize` instead
71+ * `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`
48− * `textInputTile`: Now requires `HasVtyWidgetCtx`, `HasVtyInput`, `MonadLayout`, and `MonadFocus` instead
72+ * `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position
49−* _Breaking Change_: `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.
73+ * some exposed methods intended for internal use only have been removed
50−* _Breaking Change_: `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.
74+ * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
51−* _Breaking Change_: `HasVtyInput` now has a method `localInput` for filtering the input a child widget may receive
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
52−* Add `anyChildFocused`, which provides information about whether subwidgets are focused
83+ * Add `anyChildFocused`, which provides information about whether subwidgets are focused
53−* Add `filterKeys`, which is the same as `localInput` but only cares about keyboard events
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
54
94
55## 0.1.4.1
95## 0.1.4.1
56* Migrate to new dependent-sum / dependent-map (after the "some" package split)
96* Migrate to new dependent-sum / dependent-map (after the "some" package split)
reflex-vty.cabal+61−9
@@ -12,27 +12,35 @@ maintainer: maintainer@obsidian.systems
12copyright: 2020 Obsidian Systems LLC
12copyright: 2020 Obsidian Systems LLC
13category: FRP
13category: FRP
14build-type: Simple
14build-type: Simple
15−cabal-version: >=1.18
15+cabal-version: 1.18
16extra-source-files:
16extra-source-files:
17 README.md
17 README.md
18 ChangeLog.md
18 ChangeLog.md
19extra-doc-files: doc/tasks.png
19extra-doc-files: doc/tasks.png
20−tested-with: GHC ==8.8.4 || ==8.6.5 || ==8.4.4
20+tested-with:
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
21
26
22library
27library
23 exposed-modules: Reflex.Vty
28 exposed-modules: Reflex.Vty
24 , Reflex.Vty.Host
29 , Reflex.Vty.Host
25 , Reflex.Vty.Widget
30 , Reflex.Vty.Widget
31+ , Reflex.Vty.Widget.Box
26 , Reflex.Vty.Widget.Input
32 , Reflex.Vty.Widget.Input
33+ , Reflex.Vty.Widget.Input.Mouse
27 , Reflex.Vty.Widget.Input.Text
34 , Reflex.Vty.Widget.Input.Text
28 , Reflex.Vty.Widget.Layout
35 , Reflex.Vty.Widget.Layout
36+ , Reflex.Vty.Widget.Split
37+ , Reflex.Vty.Widget.Text
29 , Data.Text.Zipper
38 , Data.Text.Zipper
30− , Reflex.Class.Switchable
31 , Reflex.Spider.Orphans
39 , Reflex.Spider.Orphans
32 , Control.Monad.NodeId
40 , Control.Monad.NodeId
33 build-depends:
41 build-depends:
34− base >= 4.10.0 && < 4.14,
42+ base >= 4.10.0 && < 4.15,
35− bimap >= 0.3.3 && < 0.4,
43+ bimap >= 0.3.3 && < 0.5,
36 containers >= 0.5.0 && < 0.7,
44 containers >= 0.5.0 && < 0.7,
37 mtl >= 2.2.2 && < 2.3,
45 mtl >= 2.2.2 && < 2.3,
38 transformers >= 0.5.5 && < 0.6,
46 transformers >= 0.5.5 && < 0.6,
@@ -42,6 +50,7 @@ library
42 text >= 1.2.3 && < 1.3,
50 text >= 1.2.3 && < 1.3,
43 dependent-sum >= 0.7 && < 0.8,
51 dependent-sum >= 0.7 && < 0.8,
44 exception-transformers >= 0.4.0 && < 0.5,
52 exception-transformers >= 0.4.0 && < 0.5,
53+ mmorph >= 1.1 && < 1.2,
45 ordered-containers >= 0.2.2 && < 0.3,
54 ordered-containers >= 0.2.2 && < 0.3,
46 primitive >= 0.6.3 && < 0.8,
55 primitive >= 0.6.3 && < 0.8,
47 ref-tf >= 0.4.0 && < 0.5,
56 ref-tf >= 0.4.0 && < 0.5,
@@ -81,7 +90,6 @@ library
81 TypeApplications
90 TypeApplications
82 TypeFamilies
91 TypeFamilies
83
92
84−
85executable example
93executable example
86 hs-source-dirs: src-bin
94 hs-source-dirs: src-bin
87 main-is: example.hs
95 main-is: example.hs
@@ -96,7 +104,51 @@ executable example
96 transformers,
104 transformers,
97 vty
105 vty
98 default-language: Haskell2010
106 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
99
137
100−source-repository head
138+
101− type: git
139+test-suite reflex-vty-test
102− location: https://github.com/reflex-frp/reflex-vty
140+ hs-source-dirs: test
141+ main-is: Spec.hs
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
src-bin/Example/CPU.hsnew file+231
@@ -0,0 +1,231 @@
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+37−32
@@ -1,18 +1,6 @@
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−{-# LANGUAGE ConstraintKinds #-}
11−
12import Control.Applicative
1import Control.Applicative
13import Control.Monad
2import Control.Monad
14import Control.Monad.Fix
3import Control.Monad.Fix
15−import Control.Monad.NodeId
16import Data.Functor
4import Data.Functor
17import Data.Functor.Misc
5import Data.Functor.Misc
18import Data.Map (Map)
6import Data.Map (Map)
@@ -26,49 +14,68 @@ import Reflex
26import Reflex.Network
14import Reflex.Network
27import Reflex.Vty
15import Reflex.Vty
28
16
17+import Example.CPU
18+
29type VtyExample t m =
19type VtyExample t m =
30 ( MonadFix m
20 ( MonadFix m
31 , Reflex t
21 , Reflex t
32− , HasVtyInput t m
22+ , HasInput t m
33− , HasVtyWidgetCtx t m
23+ , HasImageWriter t m
34− , ImageWriter t m
24+ , HasDisplayRegion t m
35− , MonadNodeId m
36− , HasDisplaySize t m
37 , HasFocus t m
25 , HasFocus t m
26+ , HasFocusReader t m, HasTheme t m
38 )
27 )
39
28
40type Manager t m =
29type Manager t m =
41− ( MonadLayout t m
30+ ( HasLayout t m
42− , MonadFocus t m
31+ , HasFocus t m
43 )
32 )
44
33
45data Example = Example_TextEditor
34data Example = Example_TextEditor
46 | Example_Todo
35 | Example_Todo
47 | Example_ScrollableTextDisplay
36 | Example_ScrollableTextDisplay
48 | Example_ClickButtonsGetEmojis
37 | Example_ClickButtonsGetEmojis
38+ | Example_CPUStat
49 deriving (Show, Read, Eq, Ord, Enum, Bounded)
39 deriving (Show, Read, Eq, Ord, Enum, Bounded)
50
40
51−main :: IO ()
41+withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
52−main = mainWidget $ do
42+withCtrlC f = do
53 inp <- input
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+
57+main :: IO ()
58+main = mainWidget $ withCtrlC $ do
54 initManager_ $ do
59 initManager_ $ do
55 tabNavigation
60 tabNavigation
56 let gf = grout . fixed
61 let gf = grout . fixed
57− tf = tile . fixed
62+ t = tile flex
58 buttons = col $ do
63 buttons = col $ do
59− gf 4 $ col $ do
64+ gf 3 $ col $ do
60 gf 1 $ text "Select an example."
65 gf 1 $ text "Select an example."
61 gf 1 $ text "Esc will bring you back here."
66 gf 1 $ text "Esc will bring you back here."
62 gf 1 $ text "Ctrl+c to quit."
67 gf 1 $ text "Ctrl+c to quit."
63− a <- tf 5 $ textButtonStatic def "Todo List"
68+ a <- t $ textButtonStatic def "Todo List"
64− b <- tf 5 $ textButtonStatic def "Text Editor"
69+ b <- t $ textButtonStatic def "Text Editor"
65− c <- tf 5 $ textButtonStatic def "Scrollable text display"
70+ c <- t $ textButtonStatic def "Scrollable text display"
66− d <- tf 5 $ textButtonStatic def "Clickable buttons"
71+ d <- t $ textButtonStatic def "Clickable buttons"
72+ e <- t $ textButtonStatic def "CPU Usage"
67 return $ leftmost
73 return $ leftmost
68 [ Left Example_Todo <$ a
74 [ Left Example_Todo <$ a
69 , Left Example_TextEditor <$ b
75 , Left Example_TextEditor <$ b
70 , Left Example_ScrollableTextDisplay <$ c
76 , Left Example_ScrollableTextDisplay <$ c
71 , Left Example_ClickButtonsGetEmojis <$ d
77 , Left Example_ClickButtonsGetEmojis <$ d
78+ , Left Example_CPUStat <$ e
72 ]
79 ]
73 let escapable w = do
80 let escapable w = do
74 void w
81 void w
@@ -78,14 +85,12 @@ main = mainWidget $ do
78 _ -> Nothing
85 _ -> Nothing
79 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
86 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
80 Left Example_Todo -> escapable taskList
87 Left Example_Todo -> escapable taskList
81− Left Example_TextEditor -> escapable testBoxes
88+ Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
82 Left Example_ScrollableTextDisplay -> escapable scrolling
89 Left Example_ScrollableTextDisplay -> escapable scrolling
83 Left Example_ClickButtonsGetEmojis -> escapable easyExample
90 Left Example_ClickButtonsGetEmojis -> escapable easyExample
91+ Left Example_CPUStat -> escapable cpuStats
84 Right () -> buttons
92 Right () -> buttons
85 return ()
93 return ()
86− return $ fforMaybe inp $ \case
87− V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
88− _ -> Nothing
89
94
90-- * Mouse button and emojis example
95-- * Mouse button and emojis example
91easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
96easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
@@ -236,7 +241,7 @@ scrolling = col $ do
236-- * Text editor example with resizable boxes
241-- * Text editor example with resizable boxes
237
242
238testBoxes
243testBoxes
239− :: (MonadHold t m, MonadNodeId m, VtyExample t m)
244+ :: (MonadHold t m, VtyExample t m)
240 => m ()
245 => m ()
241testBoxes = do
246testBoxes = do
242 dw <- displayWidth
247 dw <- displayWidth
src/Control/Monad/NodeId.hs+3−1
@@ -10,6 +10,7 @@ module Control.Monad.NodeId
10 , runNodeIdT
10 , runNodeIdT
11 ) where
11 ) where
12
12
13+import Control.Monad.Morph
13import Control.Monad.Reader
14import Control.Monad.Reader
14import Control.Monad.Ref
15import Control.Monad.Ref
15import Data.IORef
16import Data.IORef
@@ -34,10 +35,12 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
34 deriving
35 deriving
35 ( Functor
36 ( Functor
36 , Applicative
37 , Applicative
38+ , MFunctor
37 , Monad
39 , Monad
38 , MonadFix
40 , MonadFix
39 , MonadHold t
41 , MonadHold t
40 , MonadIO
42 , MonadIO
43+ , MonadRef
41 , MonadReflexCreateTrigger t
44 , MonadReflexCreateTrigger t
42 , MonadSample t
45 , MonadSample t
43 , MonadTrans
46 , MonadTrans
@@ -45,7 +48,6 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
45 , PerformEvent t
48 , PerformEvent t
46 , PostBuild t
49 , PostBuild t
47 , TriggerEvent t
50 , TriggerEvent t
48− , MonadRef
49 )
51 )
50
52
51instance MonadNodeId m => MonadNodeId (ReaderT x m)
53instance MonadNodeId m => MonadNodeId (ReaderT x m)
src/Data/Text/Zipper.hs+280−157
@@ -9,22 +9,26 @@ Description: A zipper for text documents that allows convenient editing and navi
9-}
9-}
10module Data.Text.Zipper where
10module Data.Text.Zipper where
11
11
12+import Prelude
13+
14+import Control.Exception (assert)
15+import Control.Monad.State (evalState, forM, get, put)
12import Data.Char (isSpace)
16import Data.Char (isSpace)
13import Data.Map (Map)
17import Data.Map (Map)
14−import qualified Data.Map as Map
15import Data.Maybe (fromMaybe)
18import Data.Maybe (fromMaybe)
16import Data.String
19import Data.String
17−import Control.Monad.State (evalState, forM, get, put)
18−
19import Data.Text (Text)
20import Data.Text (Text)
20−import qualified Data.Text as T
21import Data.Text.Internal (Text(..), text)
21import Data.Text.Internal (Text(..), text)
22import Data.Text.Internal.Fusion (stream)
22import Data.Text.Internal.Fusion (stream)
23import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
23import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
24import Data.Text.Unsafe
24import Data.Text.Unsafe
25+import qualified Data.List as L
26+import qualified Data.Map as Map
27+import qualified Data.Text as T
25
28
26import Graphics.Text.Width (wcwidth)
29import Graphics.Text.Width (wcwidth)
27
30
31+
28-- | A zipper of the logical text input contents (the "document"). The lines
32-- | A zipper of the logical text input contents (the "document"). The lines
29-- before the line containing the cursor are stored in reverse order.
33-- before the line containing the cursor are stored in reverse order.
30-- The cursor is logically between the "before" and "after" text.
34-- The cursor is logically between the "before" and "after" text.
@@ -166,7 +170,7 @@ deleteLeftWord (TextZipper lb b a la) =
166-- | Insert up to n spaces to get to the next logical column that is a multiple of n
170-- | Insert up to n spaces to get to the next logical column that is a multiple of n
167tab :: Int -> TextZipper -> TextZipper
171tab :: Int -> TextZipper -> TextZipper
168tab n z@(TextZipper _ b _ _) =
172tab n z@(TextZipper _ b _ _) =
169− insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z
173+ insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z
170
174
171-- | The plain text contents of the zipper
175-- | The plain text contents of the zipper
172value :: TextZipper -> Text
176value :: TextZipper -> Text
@@ -189,105 +193,35 @@ fromText = flip insert empty
189data Span tag = Span tag Text
193data Span tag = Span tag Text
190 deriving (Show)
194 deriving (Show)
191
195
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+
192-- | Information about the document as it is displayed (i.e., post-wrapping)
217-- | Information about the document as it is displayed (i.e., post-wrapping)
193data DisplayLines tag = DisplayLines
218data DisplayLines tag = DisplayLines
194 { _displayLines_spans :: [[Span tag]]
219 { _displayLines_spans :: [[Span tag]]
195− , _displayLines_offsetMap :: Map Int Int
220+ , _displayLines_offsetMap :: OffsetMapWithAlignment
196− , _displayLines_cursorY :: Int
221+ , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
197 }
222 }
198 deriving (Show)
223 deriving (Show)
199
224
200−-- | Given a width and a 'TextZipper', produce a list of display lines
201−-- (i.e., lines of wrapped text) with special attributes applied to
202−-- certain segments (e.g., the cursor). Additionally, produce the current
203−-- y-coordinate of the cursor and a mapping from display line number to text
204−-- offset
205−displayLines
206− :: Int -- ^ Width, used for wrapping
207− -> tag -- ^ Metadata for normal characters
208− -> tag -- ^ Metadata for the cursor
209− -> TextZipper -- ^ The text input contents and cursor state
210− -> DisplayLines tag
211−displayLines width tag cursorTag (TextZipper lb b a la) =
212− let linesBefore :: [[Text]] -- The wrapped lines before the cursor line
213− linesBefore = map (wrapWithOffset width 0) $ reverse lb
214− linesAfter :: [[Text]] -- The wrapped lines after the cursor line
215− linesAfter = map (wrapWithOffset width 0) la
216− offsets :: Map Int Int
217− offsets = offsetMap $ mconcat
218− [ linesBefore
219− , [wrapWithOffset width 0 $ b <> a]
220− , linesAfter
221− ]
222− spansBefore = map ((:[]) . Span tag) $ concat linesBefore
223− spansAfter = map ((:[]) . Span tag) $ concat linesAfter
224− -- Separate the spans before the cursor into
225− -- * spans that are on earlier display lines (though on the same logical line), and
226− -- * spans that are on the same display line
227− (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
228− initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)
229− -- Calculate the number of columns on the cursor's display line before the cursor
230− curLineOffset = spansWidth spansCurLineBefore
231− -- Check whether the spans on the current display line are long enough that
232− -- the cursor has to go to the next line
233− cursorAfterEOL = curLineOffset == width
234− cursorCharWidth = case T.uncons a of
235− Nothing -> 1
236− Just (c, _) -> charWidth c
237− -- Separate the span after the cursor into
238− -- * spans that are on the same display line, and
239− -- * spans that are on later display lines (though on the same logical line)
240− (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
241− headTail $ case T.uncons a of
242− Nothing -> [[Span cursorTag " "]]
243− Just (c, rest) ->
244− let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
245− cursor = Span cursorTag (T.singleton c)
246− in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
247− [] -> [[cursor]]
248− (l:ls) -> (cursor : l) : ls
249− in DisplayLines
250− { _displayLines_spans = concat
251− [ spansBefore
252− , spansCurrentBefore
253− , if cursorAfterEOL
254− then [ spansCurLineBefore, spansCurLineAfter ]
255− else [ spansCurLineBefore <> spansCurLineAfter ]
256− , spansCurrentAfter
257− , spansAfter
258− ]
259− , _displayLines_offsetMap = offsets
260− , _displayLines_cursorY = sum
261− [ length spansBefore
262− , length spansCurrentBefore
263− , if cursorAfterEOL then 1 else 0
264− ]
265− }
266− where
267− initLast :: [a] -> Maybe ([a], a)
268− initLast = \case
269− [] -> Nothing
270− (x:xs) -> case initLast xs of
271− Nothing -> Just ([], x)
272− Just (ys, y) -> Just (x:ys, y)
273− headTail :: [a] -> Maybe (a, [a])
274− headTail = \case
275− [] -> Nothing
276− x:xs -> Just (x, xs)
277−
278−-- | Wraps a logical line of text to fit within the given width. The first
279−-- wrapped line is offset by the number of columns provided. Subsequent wrapped
280−-- lines are not.
281−wrapWithOffset
282− :: Int -- ^ Maximum width
283− -> Int -- ^ Offset for first line
284− -> Text -- ^ Text to be wrapped
285− -> [Text]
286−wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
287−wrapWithOffset maxWidth n xs =
288− let (firstLine, rest) = splitAtWidth (maxWidth - n) xs
289− in firstLine : (fmap (takeWidth maxWidth) . takeWhile (not . T.null) . iterate (dropWidth maxWidth) $ rest)
290−
291-- | Split a 'Text' at the given column index. For example
225-- | Split a 'Text' at the given column index. For example
292--
226--
293-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
227-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
@@ -297,16 +231,16 @@ splitAtWidth :: Int -> Text -> (Text, Text)
297splitAtWidth n t@(Text arr off len)
231splitAtWidth n t@(Text arr off len)
298 | n <= 0 = (T.empty, t)
232 | n <= 0 = (T.empty, t)
299 | n >= textWidth t = (t, T.empty)
233 | n >= textWidth t = (t, T.empty)
300− | otherwise = let k = iterNWidth n t
234+ | otherwise = let k = toLogicalIndex n t
301 in (text arr off k, text arr (off+k) (len-k))
235 in (text arr off k, text arr (off+k) (len-k))
302− where
236+
303− iterNWidth :: Int -> Text -> Int
237+toLogicalIndex :: Int -> Text -> Int
304− iterNWidth n' t'@(Text _ _ len') = loop 0 0
238+toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
305− where loop !i !cnt
239+ where loop !i !cnt
306− | i >= len' || cnt + w > n' = i
240+ | i >= len' || cnt + w > n' = i
307− | otherwise = loop (i+d) (cnt + w)
241+ | otherwise = loop (i+d) (cnt + w)
308− where Iter c d = iter t' i
242+ where Iter c d = iter t' i
309− w = charWidth c
243+ w = charWidth c
310
244
311-- | Takes the given number of columns of characters. For example
245-- | Takes the given number of columns of characters. For example
312--
246--
@@ -335,56 +269,6 @@ dropWidth n = snd . splitAtWidth n
335charWidth :: Char -> Int
269charWidth :: Char -> Int
336charWidth = wcwidth
270charWidth = wcwidth
337
271
338−
339−-- | For a given set of wrapped logical lines, computes a map
340−-- from display line index to text offset in the original text.
341−-- This is used to help determine how interactions with the displayed
342−-- text map back to the original text.
343−-- For example, given the document @\"AA\\nBBB\\nCCCCCCCC\\n\"@ wrapped to 5 columns,
344−-- this function will compute the offset in the original document of each character
345−-- in column 1:
346−--
347−-- > AA... (0, 0)
348−-- > BBB.. (1, 3)
349−-- > CCCCC (2, 7) -- (this line wraps to the next row)
350−-- > CCC.. (3, 12)
351−-- > ..... (4, 16)
352−offsetMap
353− :: [[Text]] -- ^ The outer list represents logical lines, and the
354− -- inner list represents the display lines into which
355− -- the logical line has been wrapped
356− -> Map Int Int -- ^ A map from the index (row) of display line to
357− -- the text offset from the beginning of the document
358− -- to the first character of the display line
359−offsetMap ts = evalState (offsetMap' ts) (0, 0)
360− where
361− offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
362− maps <- forM x $ \line -> do
363− let l = T.length line
364− (dl, o) <- get
365− put (dl + 1, o + l)
366− return $ Map.singleton dl o
367− (dl, o) <- get
368− put (dl, o + 1)
369− return $ Map.insert dl (o + 1) $ Map.unions maps
370−
371−-- | Move the cursor of the given 'TextZipper' to the logical position indicated
372−-- by the given display line coordinates, using the provided 'DisplayLines'
373−-- information. If the x coordinate is beyond the end of a line, the cursor is
374−-- moved to the end of the line.
375−goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
376−goToDisplayLinePosition x y dl tz =
377− let offset = Map.lookup y $ _displayLines_offsetMap dl
378− in case offset of
379− Nothing -> tz
380− Just o ->
381− let
382− moveRight = case drop y $ _displayLines_spans dl of
383− [] -> x
384− (s:_) -> charIndexAt x . stream . mconcat . fmap (\(Span _ t) -> t) $ s
385− in rightN (o + min moveRight x) $ top tz
386−
387−
388-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
272-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
389spansWidth :: [Span tag] -> Int
273spansWidth :: [Span tag] -> Int
390spansWidth = sum . map (\(Span _ t) -> textWidth t)
274spansWidth = sum . map (\(Span _ t) -> textWidth t)
@@ -420,3 +304,242 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
420 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
304 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
421 w = z + charWidth c
305 w = z + charWidth c
422{-# INLINE[0] charIndexAt #-}
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
405+-- (i.e., lines of wrapped text) with special attributes applied to
406+-- 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
408+-- offset
409+displayLinesWithAlignment
410+ :: TextAlignment
411+ -> Int -- ^ Width, used for wrapping
412+ -> tag -- ^ Metadata for normal characters
413+ -> tag -- ^ Metadata for the cursor
414+ -> TextZipper -- ^ The text input contents and cursor state
415+ -> DisplayLines tag
416+displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
417+ let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
418+ linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
419+ linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
420+ linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
421+
422+ -- simulate trailing cursor character when computing OffsetMap
423+ afterWithCursor = if T.null a then " " else a
424+ offsets :: OffsetMapWithAlignment
425+ offsets = offsetMapWithAlignmentInternal $ mconcat
426+ [ linesBefore
427+ , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]
428+ , linesAfter
429+ ]
430+ flattenLines = concatMap (fmap _wrappedLines_text)
431+ spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore
432+ spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter
433+ -- Separate the spans before the cursor into
434+ -- * spans that are on earlier display lines (though on the same logical line), and
435+ -- * spans that are on the same display line
436+
437+ (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
438+ initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b)
439+ -- Calculate the number of columns on the cursor's display line before the cursor
440+ curLineOffset = spansWidth spansCurLineBefore
441+ -- Check whether the spans on the current display line are long enough that
442+ -- the cursor has to go to the next line
443+ cursorAfterEOL = curLineOffset == width
444+ cursorCharWidth = case T.uncons a of
445+ Nothing -> 1
446+ Just (c, _) -> charWidth c
447+
448+ -- Separate the span after the cursor into
449+ -- * spans that are on the same display line, and
450+ -- * spans that are on later display lines (though on the same logical line)
451+
452+ (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
453+ headTail $ case T.uncons a of
454+ Nothing -> [[Span cursorTag " "]]
455+ Just (c, rest) ->
456+ let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
457+ cursor = Span cursorTag (T.singleton c)
458+ in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of
459+ [] -> [[cursor]]
460+ (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
484+ { _displayLines_spans = concat
485+ [ spansBefore
486+ , spansCurrentBefore
487+ , curLineSpan
488+ , spansCurrentAfter
489+ , spansAfter
490+ ]
491+ , _displayLines_offsetMap = offsets
492+ , _displayLines_cursorPos = (cursorX, cursorY)
493+ }
494+ where
495+ initLast :: [a] -> Maybe ([a], a)
496+ initLast = \case
497+ [] -> Nothing
498+ (x:xs) -> case initLast xs of
499+ Nothing -> Just ([], x)
500+ Just (ys, y) -> Just (x:ys, y)
501+ headTail :: [a] -> Maybe (a, [a])
502+ headTail = \case
503+ [] -> Nothing
504+ x:xs -> Just (x, xs)
505+
506+
507+-- | Move the cursor of the given 'TextZipper' to the logical position indicated
508+-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
509+-- information. If the x coordinate is beyond the end of a line, the cursor is
510+-- moved to the end of the line.
511+goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
512+goToDisplayLinePosition x y dl tz =
513+ let offset = Map.lookup y $ _displayLines_offsetMap dl
514+ in case offset of
515+ Nothing -> tz
516+ Just (alignOff,o) ->
517+ let
518+ trueX = max 0 (x - alignOff)
519+ moveRight = case drop y $ _displayLines_spans dl of
520+ [] -> 0
521+ (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
522+ in rightN (o + moveRight) $ top tz
523+
524+-- | Given a width and a 'TextZipper', produce a list of display lines
525+-- (i.e., lines of wrapped text) with special attributes applied to
526+-- certain segments (e.g., the cursor). Additionally, produce the current
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+
537+-- | Wraps a logical line of text to fit within the given width. The first
538+-- wrapped line is offset by the number of columns provided. Subsequent wrapped
539+-- lines are not.
540+wrapWithOffset
541+ :: Int -- ^ Maximum width
542+ -> Int -- ^ Offset for first line
543+ -> Text -- ^ Text to be wrapped
544+ -> [Text]
545+wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs
src/Reflex/Class/Switchable.hsdeleted−27
@@ -1,27 +0,0 @@
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 UndecidableInstances #-}
6−module Reflex.Class.Switchable where
7−
8−import Control.Monad
9−import Reflex
10−
11−-- | Class representing things that can be switched when the provided event occurs
12−class Reflex t => Switchable t w | w -> t where
13− switching :: MonadHold t m => w -> Event t w -> m w
14−
15−instance Reflex t => Switchable t (Event t a) where
16− switching = switchHold
17−
18−instance Reflex t => Switchable t (Dynamic t a) where
19− switching a e = fmap join $ holdDyn a e
20−
21−instance Reflex t => Switchable t (Behavior t a) where
22− switching = switcher
23−
24−instance (Reflex t, Switchable t a, Switchable t b) => Switchable t (a, b) where
25− switching (a, b) e = (,)
26− <$> switching a (fmap fst e)
27− <*> switching b (fmap snd e)
src/Reflex/Vty.hs+6
@@ -14,15 +14,21 @@ 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
17 , module Reflex.Vty.Widget.Input
18 , module Reflex.Vty.Widget.Input
18 , module Reflex.Vty.Widget.Layout
19 , module Reflex.Vty.Widget.Layout
20+ , module Reflex.Vty.Widget.Split
21+ , module Reflex.Vty.Widget.Text
19 , module Control.Monad.NodeId
22 , module Control.Monad.NodeId
20 ) where
23 ) where
21
24
22import Reflex
25import Reflex
23import Reflex.Vty.Host
26import Reflex.Vty.Host
24import Reflex.Vty.Widget
27import Reflex.Vty.Widget
28+import Reflex.Vty.Widget.Box
25import Reflex.Vty.Widget.Input
29import Reflex.Vty.Widget.Input
26import Reflex.Vty.Widget.Layout
30import Reflex.Vty.Widget.Layout
31+import Reflex.Vty.Widget.Split
32+import Reflex.Vty.Widget.Text
27
33
28import Control.Monad.NodeId
34import Control.Monad.NodeId
src/Reflex/Vty/Widget.hs+460−615
@@ -4,70 +4,18 @@ Description: Basic set of widgets and building blocks for reflex-vty application
4-}
4-}
5{-# Language UndecidableInstances #-}
5{-# Language UndecidableInstances #-}
6
6
7−module Reflex.Vty.Widget
7+module Reflex.Vty.Widget where
8− ( VtyWidgetCtx(..)
9− , VtyWidget(..)
10− , VtyWidgetOut(..)
11− , ImageWriter(..)
12− , runVtyWidget
13− , mainWidget
14− , mainWidgetWithHandle
15− , HasDisplaySize(..)
16− , HasFocus(..)
17− , HasVtyInput(..)
18− , HasVtyWidgetCtx(..)
19− , Region(..)
20− , regionSize
21− , regionBlankImage
22− , Drag(..)
23− , drag
24− , MouseDown(..)
25− , MouseUp(..)
26− , mouseDown
27− , mouseUp
28− , ScrollDirection(..)
29− , mouseScroll
30− , pane
31− , splitV
32− , splitH
33− , splitVDrag
34− , boxTitle
35− , box
36− , boxStatic
37− , RichTextConfig(..)
38− , richText
39− , text
40− , scrollableText
41− , display
42− , BoxStyle(..)
43− , hyphenBoxStyle
44− , singleBoxStyle
45− , roundedBoxStyle
46− , thickBoxStyle
47− , doubleBoxStyle
48− , fill
49− , hRule
50− , filterKeys
51− , KeyCombo
52− , key
53− , keys
54− , keyCombo
55− , keyCombos
56− , blank
57− ) where
58
8
59import Control.Applicative (liftA2)
9import Control.Applicative (liftA2)
60import Control.Monad.Fix (MonadFix)
10import Control.Monad.Fix (MonadFix)
61import Control.Monad.IO.Class (MonadIO)
11import Control.Monad.IO.Class (MonadIO)
12+import Control.Monad.Morph
62import Control.Monad.NodeId
13import Control.Monad.NodeId
63−import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
14+import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
15+import Control.Monad.Ref
64import Control.Monad.Trans (MonadTrans, lift)
16import Control.Monad.Trans (MonadTrans, lift)
65−import Data.Default (Default(..))
66import Data.Set (Set)
17import Data.Set (Set)
67import qualified Data.Set as Set
18import qualified Data.Set as Set
68−import Data.Text (Text)
69−import qualified Data.Text as T
70−import qualified Data.Text.Zipper as TZ
71import Graphics.Vty (Image)
19import Graphics.Vty (Image)
72import qualified Graphics.Vty as V
20import qualified Graphics.Vty as V
73import Reflex
21import Reflex
@@ -75,85 +23,20 @@ import Reflex.Class ()
75import Reflex.Host.Class (MonadReflexCreateTrigger)
23import Reflex.Host.Class (MonadReflexCreateTrigger)
76import Reflex.Vty.Host
24import Reflex.Vty.Host
77
25
78−-- | The context within which a 'VtyWidget' runs
26+-- * Running a vty application
79−data VtyWidgetCtx t = VtyWidgetCtx
80− { _vtyWidgetCtx_width :: Dynamic t Int
81− -- ^ The width of the region allocated to the widget.
82− , _vtyWidgetCtx_height :: Dynamic t Int
83− -- ^ The height of the region allocated to the widget.
84− , _vtyWidgetCtx_focus :: Dynamic t Bool
85− -- ^ Whether the widget should behave as if it has focus for keyboard input.
86− }
87−
88−-- | The output of a 'VtyWidget'
89−data VtyWidgetOut t = VtyWidgetOut
90− { _vtyWidgetOut_shutdown :: Event t ()
91− }
92−
93−instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where
94− runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'
95− traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $
96− traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
97− traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do
98− traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
99− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do
100− traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'
101−
102−-- | A widget that can read its context and produce image output
103−newtype VtyWidget t m a = VtyWidget
104− { unVtyWidget :: BehaviorWriterT t [Image]
105− (ReaderT (VtyWidgetCtx t)
106− (ReaderT (Event t VtyEvent) m)) a
107− } deriving
108− ( Functor
109− , Applicative
110− , Monad
111− , MonadSample t
112− , MonadHold t
113− , MonadFix
114− , NotReady t
115− , ImageWriter t
116− , PostBuild t
117− , TriggerEvent t
118− , MonadReflexCreateTrigger t
119− , MonadIO
120− )
121−
122−deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
123−instance MonadTrans (VtyWidget t) where
124− lift f = VtyWidget $ lift $ lift $ lift f
125−
126−instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
127− getNextNodeId = VtyWidget $ do
128− lift $ lift getNextNodeId
129−
130−-- | A reader-like class for the vty widget context. Allows actions to be run in a sub-context.
131−class HasVtyWidgetCtx t m | m -> t where
132− askCtx :: m (VtyWidgetCtx t)
133− default askCtx :: (f m' ~ m, Monad m', MonadTrans f, HasVtyWidgetCtx t m') => m (VtyWidgetCtx t)
134− askCtx = lift askCtx
135− localCtx :: (VtyWidgetCtx t -> VtyWidgetCtx t) -> (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
136−
137−instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where
138− askCtx = VtyWidget $ lift ask
139− localCtx f g (VtyWidget x) = VtyWidget $ do
140− (a, images) :: (a, Behavior t [Image]) <- lift $ local f $ runBehaviorWriterT x
141− tellImages $ g images
142− pure a
143
27
144−-- | Runs a 'VtyWidget' with a given context
145−runVtyWidget
146− :: (Reflex t, MonadNodeId m)
147− => Event t VtyEvent
148− -> VtyWidgetCtx t
149− -> VtyWidget t m a
150− -> m (a, Behavior t [Image])
151−runVtyWidget e ctx w = runReaderT (runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx) e
152−
153−-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context
28+-- | Sets up the top-level context for a vty widget and runs it with that context
154mainWidgetWithHandle
29mainWidgetWithHandle
155 :: V.Vty
30 :: V.Vty
31+ -> (forall t m.
156− -> (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
32+ ( MonadVtyApp t m
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 ()))
157 -> IO ()
40 -> IO ()
158mainWidgetWithHandle vty child =
41mainWidgetWithHandle vty child =
159 runVtyAppWithHandle vty $ \dr0 inp -> do
42 runVtyAppWithHandle vty $ \dr0 inp -> do
@@ -163,89 +46,178 @@ mainWidgetWithHandle vty child =
163 let inp' = fforMaybe inp $ \case
46 let inp' = fforMaybe inp $ \case
164 V.EvResize {} -> Nothing
47 V.EvResize {} -> Nothing
165 x -> Just x
48 x -> Just x
166− let ctx = VtyWidgetCtx
49+ (shutdown, images) <- runThemeReader (constant V.defAttr) $
167− { _vtyWidgetCtx_width = fmap fst size
50+ runFocusReader (pure True) $
168− , _vtyWidgetCtx_height = fmap snd size
51+ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
169− , _vtyWidgetCtx_focus = constDyn True
52+ runImageWriter $
170− }
53+ runNodeIdT $
171− (shutdown, images) <- runNodeIdT $ runVtyWidget inp' ctx $ do
54+ runInput inp' $ do
172− tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
55+ tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
173− child
56+ child
174 return $ VtyResult
57 return $ VtyResult
175 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
58 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
176 , _vtyResult_shutdown = shutdown
59 , _vtyResult_shutdown = shutdown
177 }
60 }
178
61
62+-- | The output of a vty widget
63+data VtyWidgetOut t = VtyWidgetOut
64+ { _vtyWidgetOut_shutdown :: Event t ()
65+ }
66+
179-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
67-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
180mainWidget
68mainWidget
69+ :: (forall t m.
181− :: (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
70+ ( MonadVtyApp t m
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 ()))
182 -> IO ()
78 -> IO ()
183mainWidget child = do
79mainWidget child = do
184 vty <- getDefaultVty
80 vty <- getDefaultVty
185 mainWidgetWithHandle vty child
81 mainWidgetWithHandle vty child
186
82
187−-- | A class for things that know their own display size dimensions
83+-- * Input Events
188−class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
189− -- | Retrieve the display width (columns)
190− displayWidth :: m (Dynamic t Int)
191− default displayWidth :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
192− displayWidth = lift displayWidth
193− -- | Retrieve the display height (rows)
194− displayHeight :: m (Dynamic t Int)
195− default displayHeight :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
196− displayHeight = lift displayHeight
197−
198−instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
199− displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width
200− displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height
201−
202−instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)
203−instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)
204−instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)
205−instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)
206−instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)
207
84
208-- | A class for things that can receive vty events as input
85-- | A class for things that can receive vty events as input
209−class HasVtyInput t m | m -> t where
86+class HasInput t m | m -> t where
210 input :: m (Event t VtyEvent)
87 input :: m (Event t VtyEvent)
211− default input :: (f m' ~ m, Monad m', MonadTrans f, HasVtyInput t m') => m (Event t VtyEvent)
88+ default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)
212 input = lift input
89 input = lift input
213 -- | User input events that the widget's parent chooses to share. These will generally
90 -- | User input events that the widget's parent chooses to share. These will generally
214 -- be filtered for relevance.
91 -- be filtered for relevance.
215 localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
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+
150+-- | Type synonym for a key and modifier combination
151+type KeyCombo = (V.Key, [V.Modifier])
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+
157+-- | Emits an event that fires on particular key presses (without modifiers)
158+keys :: (Monad m, Reflex t, HasInput t m) => [V.Key] -> m (Event t KeyCombo)
159+keys = keyCombos . Set.fromList . fmap (,[])
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+
168+-- | Emit an event that fires whenever any of the provided key combinations occur
169+keyCombos
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
216
180
217-- | Filter the keyboard input that a child widget may receive
181-- | Filter the keyboard input that a child widget may receive
218−filterKeys :: (Reflex t, HasVtyInput t m) => (KeyCombo -> Bool) -> m a -> m a
182+filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a
219filterKeys f x = localInput (ffilter (\case
183filterKeys f x = localInput (ffilter (\case
220 V.EvKey k mods -> f (k, mods)
184 V.EvKey k mods -> f (k, mods)
221 _ -> True)) x
185 _ -> True)) x
222
186
223−instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
187+-- | Filter mouse input events based on whether they target a particular region
224− input = VtyWidget . lift $ lift $ ask
188+-- and translate them to the internal coordinate system of that region.
225− localInput f (VtyWidget m) = VtyWidget $ do
189+--
226− ctx <- ask
190+-- NB: Non-mouse events are passed through unfiltered and unchanged
227− (a, images) <- lift $ lift $ local f $ runReaderT (runBehaviorWriterT m) ctx
191+mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent
228− tellImages images
192+mouseInRegion (Region l t w h) e = case e of
229− pure a
193+ V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
230−
194+ V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
231−-- | A class for things that can dynamically gain and lose focus
195+ _ -> Just e
232−class HasFocus t m | m -> t where
196+ where
233− focus :: m (Dynamic t Bool)
197+ mouse con x y
234− default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocus t m') => m (Dynamic t Bool)
198+ | or [ x < l
235− focus = lift focus
199+ , y < t
236−
200+ , x >= l + w
237−instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
201+ , y >= t + h ] = Nothing
238− focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
202+ | otherwise =
239−
203+ Just (con (x - l) (y - t))
240−-- | A class for widgets that can produce images to draw to the display
204+
241−class (Reflex t, Monad m) => ImageWriter t m | m -> t where
205+-- | Filter mouse input outside the current display region and
242− -- | Send images upstream for rendering
206+-- all input if the region is not focused
243− tellImages :: Behavior t [Image] -> m ()
207+inputInFocusedRegion
244− default tellImages :: (f m' ~ m, Monad m', MonadTrans f, ImageWriter t m') => Behavior t [Image] -> m ()
208+ :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
245− tellImages = lift . tellImages
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
246
219
247−instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
220+-- * Getting and setting the display region
248− tellImages = tellBehavior
249
221
250-- | A chunk of the display area
222-- | A chunk of the display area
251data Region = Region
223data Region = Region
@@ -256,14 +228,293 @@ data Region = Region
256 }
228 }
257 deriving (Show, Read, Eq, Ord)
229 deriving (Show, Read, Eq, Ord)
258
230
231+-- | A region that occupies no space.
232+nilRegion :: Region
233+nilRegion = Region 0 0 0 0
234+
259-- | The width and height of a 'Region'
235-- | The width and height of a 'Region'
260regionSize :: Region -> (Int, Int)
236regionSize :: Region -> (Int, Int)
261regionSize (Region _ _ w h) = (w, h)
237regionSize (Region _ _ w h) = (w, h)
262
238
263-- | Produces an 'Image' that fills a region with space characters
239-- | Produces an 'Image' that fills a region with space characters
264−regionBlankImage :: Region -> Image
240+regionBlankImage :: V.Attr -> Region -> Image
265−regionBlankImage r@(Region _ _ width height) =
241+regionBlankImage attr r@(Region _ _ width height) =
266− withinImage r $ V.charFill V.defAttr ' ' width height
242+ withinImage r $ V.charFill attr ' ' width height
243+
244+-- | A class for things that know their own display size dimensions
245+class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
246+ -- | Retrieve the display region
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+
307+instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
308+
309+-- | Run a 'DisplayRegion' action with a given 'Region'
310+runDisplayRegion
311+ :: (Reflex t, Monad m)
312+ => Dynamic t Region
313+ -> DisplayRegion t m a
314+ -> m a
315+runDisplayRegion r = flip runReaderT r . unDisplayRegion
316+
317+-- * Getting focus state
318+
319+-- | A class for things that can dynamically gain and lose focus
320+class (Reflex t, Monad m) => HasFocusReader t m | m -> t where
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+
373+-- | Run a 'FocusReader' action with the given focus value
374+runFocusReader
375+ :: (Reflex t, Monad m)
376+ => Dynamic t Bool
377+ -> FocusReader t m a
378+ -> m a
379+runFocusReader b = flip runReaderT b . unFocusReader
380+
381+-- * "Image" output
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+
425+instance HasImageWriter t m => HasImageWriter t (ReaderT x m)
426+instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)
427+instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)
428+instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)
429+instance HasImageWriter t m => HasImageWriter t (NodeIdT m)
430+
431+instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
432+ tellImages = ImageWriter . tellBehavior
433+ mapImages f (ImageWriter x) = ImageWriter $ do
434+ (a, images) <- lift $ runBehaviorWriterT x
435+ tellBehavior $ f images
436+ pure a
437+
438+instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
439+instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
440+
441+-- | Run a widget that can produce images
442+runImageWriter
443+ :: (Reflex t, Monad m)
444+ => ImageWriter t m a
445+ -> m (a, Behavior t [Image])
446+runImageWriter = runBehaviorWriterT . unImageWriter
447+
448+-- * Theming
449+
450+-- | A class for things that can be visually styled
451+class (Reflex t, Monad m) => HasTheme t m | m -> t where
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+
500+instance MonadTrans (ThemeReader t) where
501+ lift = ThemeReader . lift
502+
503+instance MFunctor (ThemeReader t) where
504+ hoist f = ThemeReader . hoist f . unThemeReader
505+
506+instance MonadNodeId m => MonadNodeId (ThemeReader t m)
507+
508+-- | Run a 'ThemeReader' action with the given focus value
509+runThemeReader
510+ :: (Reflex t, Monad m)
511+ => Behavior t V.Attr
512+ -> ThemeReader t m a
513+ -> m a
514+runThemeReader b = flip runReaderT b . unThemeReader
515+
516+
517+-- ** Manipulating images
267
518
268-- | Translates and crops an 'Image' so that it is contained by
519-- | Translates and crops an 'Image' so that it is contained by
269-- the given 'Region'.
520-- the given 'Region'.
@@ -275,7 +526,17 @@ withinImage (Region left top width height)
275 | width < 0 || height < 0 = withinImage (Region left top 0 0)
526 | width < 0 || height < 0 = withinImage (Region left top 0 0)
276 | otherwise = V.translate left top . V.crop width height
527 | otherwise = V.translate left top . V.crop width height
277
528
529+-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.
530+imagesInRegion
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+
537+-- * Running sub-widgets
538+
278−-- | Low-level widget combinator that runs a child 'VtyWidget' within
539+-- | Low-level widget combinator that runs a child widget within
279-- a given region and context. This widget filters and modifies the input
540-- a given region and context. This widget filters and modifies the input
280-- that the child widget receives such that:
541-- that the child widget receives such that:
281-- * unfocused widgets receive no key events
542-- * unfocused widgets receive no key events
@@ -283,433 +544,17 @@ withinImage (Region left top width height)
283-- * mouse inputs inside the region have their coordinates translated such
544-- * mouse inputs inside the region have their coordinates translated such
284-- that (0,0) is the top-left corner of the region
545-- that (0,0) is the top-left corner of the region
285pane
546pane
286− :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasVtyInput t m)
547+ :: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
287 => Dynamic t Region
548 => Dynamic t Region
288 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
549 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
289 -> m a
550 -> m a
290 -> m a
551 -> m a
291−pane dr foc child = do
552+pane dr foc child = localRegion (const dr) $
292− let reg = current dr
553+ mapImages (imagesInRegion $ current dr) $
293− let subContext ctx = VtyWidgetCtx
554+ localFocus (const foc) $
294− { _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
555+ inputInFocusedRegion >>= \e -> localInput (const e) child
295− , _vtyWidgetCtx_width = _region_width <$> dr
296− , _vtyWidgetCtx_height = _region_height <$> dr
297− }
298− inputFilter = fmapMaybe id .
299− attachWith (\(r,f) e -> filterInput r f e)
300− (liftA2 (,) reg (current foc))
301− let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg
302− localInput inputFilter $ localCtx subContext imagesWithinRegion child
303− where
304− filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
305− filterInput (Region l t w h) focused e = case e of
306− V.EvKey _ _ | not focused -> Nothing
307− V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
308− V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
309− _ -> Just e
310− where
311− mouse con x y
312− | or [ x < l
313− , y < t
314− , x >= l + w
315− , y >= t + h ] = Nothing
316− | otherwise =
317− Just (con (x - l) (y - t))
318−
319−-- | Information about a drag operation
320−data Drag = Drag
321− { _drag_from :: (Int, Int) -- ^ Where the drag began
322− , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
323− , _drag_button :: V.Button -- ^ Which mouse button is dragging
324− , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
325− , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
326− }
327− deriving (Eq, Ord, Show)
328−
329−-- | Converts raw vty mouse drag events into an event stream of 'Drag's
330−drag
331− :: (Reflex t, MonadFix m, MonadHold t m, HasVtyInput t m)
332− => V.Button
333− -> m (Event t Drag)
334−drag btn = do
335− inp <- input
336− let f :: Maybe Drag -> V.Event -> Maybe Drag
337− f Nothing = \case
338− V.EvMouseDown x y btn' mods
339− | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
340− | otherwise -> Nothing
341− _ -> Nothing
342− f (Just (Drag from _ _ mods end)) = \case
343− V.EvMouseDown x y btn' mods'
344− | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
345− | btn == btn' -> Just $ Drag from (x,y) btn mods' False
346− | otherwise -> Nothing -- Ignore other buttons.
347− V.EvMouseUp x y (Just btn')
348− | end -> Nothing
349− | btn == btn' -> Just $ Drag from (x,y) btn mods True
350− | otherwise -> Nothing
351− V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
352− -- assume it's the right one.
353− | end -> Nothing
354− | otherwise -> Just $ Drag from (x,y) btn mods True
355− _ -> Nothing
356− rec let newDrag = attachWithMaybe f (current dragD) inp
357− dragD <- holdDyn Nothing $ Just <$> newDrag
358− return (fmapMaybe id $ updated dragD)
359−
360−-- | Mouse down events for a particular mouse button
361−mouseDown
362− :: (Reflex t, Monad m, HasVtyInput t m)
363− => V.Button
364− -> m (Event t MouseDown)
365−mouseDown btn = do
366− i <- input
367− return $ fforMaybe i $ \case
368− V.EvMouseDown x y btn' mods -> if btn == btn'
369− then Just $ MouseDown btn' (x, y) mods
370− else Nothing
371− _ -> Nothing
372−
373−-- | Mouse up events for a particular mouse button
374−mouseUp
375− :: (Reflex t, Monad m, HasVtyInput t m)
376− => m (Event t MouseUp)
377−mouseUp = do
378− i <- input
379− return $ fforMaybe i $ \case
380− V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
381− _ -> Nothing
382−
383−-- | Information about a mouse down event
384−data MouseDown = MouseDown
385− { _mouseDown_button :: V.Button
386− , _mouseDown_coordinates :: (Int, Int)
387− , _mouseDown_modifiers :: [V.Modifier]
388− }
389− deriving (Eq, Ord, Show)
390
556
391−-- | Information about a mouse up event
557+-- * Misc
392−data MouseUp = MouseUp
393− { _mouseUp_button :: Maybe V.Button
394− , _mouseUp_coordinates :: (Int, Int)
395− }
396− deriving (Eq, Ord, Show)
397−
398−-- | Mouse scroll direction
399−data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
400− deriving (Eq, Ord, Show)
401−
402−-- | Produce an event that fires when the mouse wheel is scrolled
403−mouseScroll
404− :: (Reflex t, Monad m, HasVtyInput t m)
405− => m (Event t ScrollDirection)
406−mouseScroll = do
407− up <- mouseDown V.BScrollUp
408− down <- mouseDown V.BScrollDown
409− return $ leftmost
410− [ ScrollDirection_Up <$ up
411− , ScrollDirection_Down <$ down
412− ]
413−
414−-- | Type synonym for a key and modifier combination
415−type KeyCombo = (V.Key, [V.Modifier])
416−
417−-- | Emits an event that fires on a particular key press (without modifiers)
418−key :: (Monad m, Reflex t, HasVtyInput t m) => V.Key -> m (Event t KeyCombo)
419−key = keyCombos . Set.singleton . (,[])
420−
421−-- | Emits an event that fires on particular key presses (without modifiers)
422−keys :: (Monad m, Reflex t, HasVtyInput t m) => [V.Key] -> m (Event t KeyCombo)
423−keys = keyCombos . Set.fromList . fmap (,[])
424−
425−-- | Emit an event that fires whenever the provided key combination occurs
426−keyCombo
427− :: (Reflex t, Monad m, HasVtyInput t m)
428− => KeyCombo
429− -> m (Event t KeyCombo)
430−keyCombo = keyCombos . Set.singleton
431−
432−-- | Emit an event that fires whenever any of the provided key combinations occur
433−keyCombos
434− :: (Reflex t, Monad m, HasVtyInput t m)
435− => Set KeyCombo
436− -> m (Event t KeyCombo)
437−keyCombos ks = do
438− i <- input
439− return $ fforMaybe i $ \case
440− V.EvKey k m -> if Set.member (k, m) ks
441− then Just (k, m)
442− else Nothing
443− _ -> Nothing
444−
445−-- | A plain split of the available space into vertically stacked panes.
446−-- No visual separator is built in here.
447−splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplaySize t m, HasVtyInput t m)
448− => Dynamic t (Int -> Int)
449− -- ^ Function used to determine size of first pane based on available size
450− -> Dynamic t (Bool, Bool)
451− -- ^ How to focus the two sub-panes, given that we are focused.
452− -> m a
453− -- ^ Widget for first pane
454− -> m b
455− -- ^ Widget for second pane
456− -> m (a,b)
457−splitV sizeFunD focD wA wB = do
458− dw <- displayWidth
459− dh <- displayHeight
460− let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh)
461− regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA)
462− ra <- pane regA (fst <$> focD) wA
463− rb <- pane regB (snd <$> focD) wB
464− return (ra,rb)
465−
466−-- | A plain split of the available space into horizontally stacked panes.
467−-- No visual separator is built in here.
468−splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasVtyWidgetCtx t m, HasVtyInput t m)
469− => Dynamic t (Int -> Int)
470− -- ^ Function used to determine size of first pane based on available size
471− -> Dynamic t (Bool, Bool)
472− -- ^ How to focus the two sub-panes, given that we are focused.
473− -> m a
474− -- ^ Widget for first pane
475− -> m b
476− -- ^ Widget for second pane
477− -> m (a,b)
478−splitH sizeFunD focD wA wB = do
479− dw <- displayWidth
480− dh <- displayHeight
481− let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh
482− regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh
483− liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
484−
485−-- | A split of the available space into two parts with a draggable separator.
486−-- Starts with half the space allocated to each, and the first pane has focus.
487−-- Clicking in a pane switches focus.
488−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m, HasDisplaySize t m, HasVtyInput t m, HasVtyWidgetCtx t m)
489− => m ()
490− -> m a
491− -> m b
492− -> m (a,b)
493−splitVDrag wS wA wB = do
494− dh <- displayHeight
495− dw <- displayWidth
496− h0 <- sample $ current dh -- TODO
497− dragE <- drag V.BLeft
498− let splitter0 = h0 `div` 2
499− rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
500− splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
501− splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
502− fromIntegral x / max 1 (fromIntegral h)
503− let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
504− \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
505− if splitterY == fromY then Just (toY, end) else Nothing
506− regA = Region 0 0 <$> dw <*> splitterPos
507− regS = Region 0 <$> splitterPos <*> dw <*> 1
508− regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1)
509− resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
510− \(frac, h) -> round (frac * fromIntegral h)
511− focA <- holdDyn True $ leftmost
512− [ True <$ mA
513− , False <$ mB
514− ]
515− (mA, rA) <- pane regA focA $ withMouseDown wA
516− pane regS (pure False) wS
517− (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
518− return (rA, rB)
519− where
520− withMouseDown x = do
521− m <- mouseDown V.BLeft
522− x' <- x
523− return (m, x')
524−
525−-- | Fill the background with a particular character.
526−fill :: (HasDisplaySize t m, ImageWriter t m) => Char -> m ()
527−fill c = do
528− dw <- displayWidth
529− dh <- displayHeight
530− let fillImg = current $ liftA2 (\w h -> [V.charFill V.defAttr c w h]) dw dh
531− tellImages fillImg
532−
533−-- | Fill the background with the bottom
534−hRule :: (HasDisplaySize t m, ImageWriter t m) => BoxStyle -> m ()
535−hRule boxStyle = fill (_boxStyle_s boxStyle)
536−
537−-- | Defines a set of symbols to use to draw the outlines of boxes
538−-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character
539−data BoxStyle = BoxStyle
540− { _boxStyle_nw :: Char
541− , _boxStyle_n :: Char
542− , _boxStyle_ne :: Char
543− , _boxStyle_e :: Char
544− , _boxStyle_se :: Char
545− , _boxStyle_s :: Char
546− , _boxStyle_sw :: Char
547− , _boxStyle_w :: Char
548− }
549−
550−instance Default BoxStyle where
551− def = singleBoxStyle
552−
553−-- | A box style that uses hyphens and pipe characters. Doesn't handle
554−-- corners very well.
555−hyphenBoxStyle :: BoxStyle
556−hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
557−
558−-- | A single line box style
559−singleBoxStyle :: BoxStyle
560−singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
561−
562−-- | A thick single line box style
563−thickBoxStyle :: BoxStyle
564−thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
565−
566−-- | A double line box style
567−doubleBoxStyle :: BoxStyle
568−doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
569−
570−-- | A single line box style with rounded corners
571−roundedBoxStyle :: BoxStyle
572−roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
573−
574−-- | Draws a titled box in the provided style and a child widget inside of that box
575−boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
576− => Behavior t BoxStyle
577− -> Text
578− -> m a
579− -> m a
580−boxTitle boxStyle title child = do
581− dh <- displayHeight
582− dw <- displayWidth
583− let boxReg = Region 0 0 <$> dw <*> dh
584− innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)
585− tellImages (boxImages <$> boxStyle <*> current boxReg)
586− tellImages (fmap (\r -> [regionBlankImage r]) (current innerReg))
587− pane innerReg (pure True) child
588− where
589− boxImages :: BoxStyle -> Region -> [Image]
590− boxImages style (Region left top width height) =
591− let right = left + width - 1
592− bottom = top + height - 1
593− sides =
594− [ withinImage (Region (left + 1) top (width - 2) 1) $
595− V.text' V.defAttr $
596− hPadText title (_boxStyle_n style) (width - 2)
597− , withinImage (Region right (top + 1) 1 (height - 2)) $
598− V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)
599− , withinImage (Region (left + 1) bottom (width - 2) 1) $
600− V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1
601− , withinImage (Region left (top + 1) 1 (height - 2)) $
602− V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)
603− ]
604− corners =
605− [ withinImage (Region left top 1 1) $
606− V.char V.defAttr (_boxStyle_nw style)
607− , withinImage (Region right top 1 1) $
608− V.char V.defAttr (_boxStyle_ne style)
609− , withinImage (Region right bottom 1 1) $
610− V.char V.defAttr (_boxStyle_se style)
611− , withinImage (Region left bottom 1 1) $
612− V.char V.defAttr (_boxStyle_sw style)
613− ]
614− in sides ++ if width > 1 && height > 1 then corners else []
615− hPadText :: T.Text -> Char -> Int -> T.Text
616− hPadText t c l = if lt >= l
617− then t
618− else left <> t <> right
619− where
620− lt = T.length t
621− delta = l - lt
622− mkHalf n = T.replicate (n `div` 2) (T.singleton c)
623− left = mkHalf $ delta + 1
624− right = mkHalf delta
625−
626−-- | A box without a title
627−box :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
628− => Behavior t BoxStyle
629− -> m a
630− -> m a
631−box boxStyle = boxTitle boxStyle mempty
632−
633−-- | A box whose style is static
634−boxStatic
635− :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
636− => BoxStyle
637− -> m a
638− -> m a
639−boxStatic = box . pure
640−
641−-- | Configuration options for displaying "rich" text
642−data RichTextConfig t = RichTextConfig
643− { _richTextConfig_attributes :: Behavior t V.Attr
644− }
645−
646−instance Reflex t => Default (RichTextConfig t) where
647− def = RichTextConfig $ pure V.defAttr
648−
649−-- | A widget that displays text with custom time-varying attributes
650−richText
651− :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)
652− => RichTextConfig t
653− -> Behavior t Text
654− -> m ()
655−richText cfg t = do
656− dw <- displayWidth
657− let img = (\w a s -> [wrapText w a s])
658− <$> current dw
659− <*> _richTextConfig_attributes cfg
660− <*> t
661− tellImages img
662− where
663− wrapText maxWidth attrs = V.vertCat
664− . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
665− . T.split (=='\n')
666−
667−-- | Renders text, wrapped to the container width
668−text
669− :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)
670− => Behavior t Text
671− -> m ()
672−text = richText def
673−
674−-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
675−-- that are hidden)
676−scrollableText
677− :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplaySize t m, HasVtyInput t m, ImageWriter t m)
678− => Event t Int
679− -- ^ Number of lines to scroll by
680− -> Behavior t Text
681− -> m (Behavior t (Int, Int))
682− -- ^ (Current scroll position, total number of lines)
683−scrollableText scrollBy t = do
684− dw <- displayWidth
685− let imgs = wrap <$> current dw <*> t
686− kup <- key V.KUp
687− kdown <- key V.KDown
688− m <- mouseScroll
689− let requestedScroll :: Event t Int
690− requestedScroll = leftmost
691− [ 1 <$ kdown
692− , (-1) <$ kup
693− , ffor m $ \case
694− ScrollDirection_Up -> (-1)
695− ScrollDirection_Down -> 1
696− , scrollBy
697− ]
698− updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
699− lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
700− attach (length <$> imgs) requestedScroll
701− tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
702− return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
703− where
704− wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
705−
706−-- | Renders any behavior whose value can be converted to
707−-- 'String' as text
708−display
709− :: (Reflex t, Monad m, Show a, HasDisplaySize t m, ImageWriter t m)
710− => Behavior t a
711− -> m ()
712−display a = text $ T.pack . show <$> a
713
558
714-- | A widget that draws nothing
559-- | A widget that draws nothing
715blank :: Monad m => m ()
560blank :: Monad m => m ()
src/Reflex/Vty/Widget/Box.hsnew file+124
@@ -0,0 +1,124 @@
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+18−8
@@ -8,16 +8,20 @@ module Reflex.Vty.Widget.Input
8 ) where
8 ) where
9
9
10
10
11+import Reflex.Vty.Widget.Input.Mouse as Export
11import Reflex.Vty.Widget.Input.Text as Export
12import Reflex.Vty.Widget.Input.Text as Export
12
13
13import Control.Monad (join)
14import Control.Monad (join)
14import Control.Monad.Fix (MonadFix)
15import Control.Monad.Fix (MonadFix)
15−import Control.Monad.NodeId (MonadNodeId)
16import Data.Default (Default(..))
16import Data.Default (Default(..))
17import Data.Text (Text)
17import Data.Text (Text)
18import qualified Graphics.Vty as V
18import qualified Graphics.Vty as V
19import Reflex
19import Reflex
20import Reflex.Vty.Widget
20import Reflex.Vty.Widget
21+import Reflex.Vty.Widget.Box
22+import Reflex.Vty.Widget.Text
23+
24+-- * Buttons
21
25
22-- | Configuration options for the 'button' widget
26-- | Configuration options for the 'button' widget
23data ButtonConfig t = ButtonConfig
27data ButtonConfig t = ButtonConfig
@@ -30,7 +34,7 @@ instance Reflex t => Default (ButtonConfig t) where
30
34
31-- | A button widget that contains a sub-widget
35-- | A button widget that contains a sub-widget
32button
36button
33− :: (Reflex t, Monad m, MonadNodeId m, HasFocus t m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
37+ :: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
34 => ButtonConfig t
38 => ButtonConfig t
35 -> m ()
39 -> m ()
36 -> m (Event t ())
40 -> m (Event t ())
@@ -48,7 +52,7 @@ button cfg child = do
48
52
49-- | A button widget that displays text that can change
53-- | A button widget that displays text that can change
50textButton
54textButton
51− :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
55+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
52 => ButtonConfig t
56 => ButtonConfig t
53 -> Behavior t Text
57 -> Behavior t Text
54 -> m (Event t ())
58 -> m (Event t ())
@@ -56,31 +60,36 @@ textButton cfg = button cfg . text -- TODO Centering etc.
56
60
57-- | A button widget that displays a static bit of text
61-- | A button widget that displays a static bit of text
58textButtonStatic
62textButtonStatic
59− :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
63+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
60 => ButtonConfig t
64 => ButtonConfig t
61 -> Text
65 -> Text
62 -> m (Event t ())
66 -> m (Event t ())
63textButtonStatic cfg = textButton cfg . pure
67textButtonStatic cfg = textButton cfg . pure
64
68
69+-- * Links
70+
65-- | A clickable link widget
71-- | A clickable link widget
66link
72link
67− :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m, HasVtyInput t m)
73+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m)
68 => Behavior t Text
74 => Behavior t Text
69 -> m (Event t MouseUp)
75 -> m (Event t MouseUp)
70link t = do
76link t = do
77+ bt <- theme
71 let cfg = RichTextConfig
78 let cfg = RichTextConfig
72− { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline
79+ { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt
73 }
80 }
74 richText cfg t
81 richText cfg t
75 mouseUp
82 mouseUp
76
83
77-- | A clickable link widget with a static label
84-- | A clickable link widget with a static label
78linkStatic
85linkStatic
79− :: (Reflex t, Monad m, ImageWriter t m, HasDisplaySize t m, HasVtyInput t m)
86+ :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)
80 => Text
87 => Text
81 -> m (Event t MouseUp)
88 -> m (Event t MouseUp)
82linkStatic = link . pure
89linkStatic = link . pure
83
90
91+-- * Checkboxes
92+
84-- | Characters used to render checked and unchecked textboxes
93-- | Characters used to render checked and unchecked textboxes
85data CheckboxStyle = CheckboxStyle
94data CheckboxStyle = CheckboxStyle
86 { _checkboxStyle_unchecked :: Text
95 { _checkboxStyle_unchecked :: Text
@@ -107,6 +116,7 @@ checkboxStyleTick = CheckboxStyle
107-- | Configuration options for a checkbox
116-- | Configuration options for a checkbox
108data CheckboxConfig t = CheckboxConfig
117data CheckboxConfig t = CheckboxConfig
109 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
118 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
119+ -- TODO DELETE and use HasTheme instead
110 , _checkboxConfig_attributes :: Behavior t V.Attr
120 , _checkboxConfig_attributes :: Behavior t V.Attr
111 , _checkboxConfig_setValue :: Event t Bool
121 , _checkboxConfig_setValue :: Event t Bool
112 }
122 }
@@ -120,7 +130,7 @@ instance (Reflex t) => Default (CheckboxConfig t) where
120
130
121-- | A checkbox widget
131-- | A checkbox widget
122checkbox
132checkbox
123− :: (MonadHold t m, MonadFix m, Reflex t, HasVtyInput t m, HasDisplaySize t m, ImageWriter t m, HasFocus t m)
133+ :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)
124 => CheckboxConfig t
134 => CheckboxConfig t
125 -> Bool
135 -> Bool
126 -> m (Dynamic t Bool)
136 -> m (Dynamic t Bool)
src/Reflex/Vty/Widget/Input/Mouse.hsnew file+106
@@ -0,0 +1,106 @@
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+17−12
@@ -9,7 +9,6 @@ module Reflex.Vty.Widget.Input.Text
9
9
10import Control.Monad (join)
10import Control.Monad (join)
11import Control.Monad.Fix (MonadFix)
11import Control.Monad.Fix (MonadFix)
12−import Control.Monad.NodeId (MonadNodeId)
13import Data.Default (Default(..))
12import Data.Default (Default(..))
14import Data.Text (Text)
13import Data.Text (Text)
15import Data.Text.Zipper
14import Data.Text.Zipper
@@ -18,6 +17,7 @@ import Reflex
18
17
19import Reflex.Vty.Widget
18import Reflex.Vty.Widget
20import Reflex.Vty.Widget.Layout
19import Reflex.Vty.Widget.Layout
20+import Reflex.Vty.Widget.Input.Mouse
21
21
22-- | Configuration options for a 'textInput'. For more information on
22-- | Configuration options for a 'textInput'. For more information on
23-- 'TextZipper', see 'Data.Text.Zipper'.
23-- 'TextZipper', see 'Data.Text.Zipper'.
@@ -43,7 +43,7 @@ data TextInput t = TextInput
43
43
44-- | A widget that allows text input
44-- | A widget that allows text input
45textInput
45textInput
46− :: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplaySize t m, ImageWriter t m)
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)
47 => TextInputConfig t
47 => TextInputConfig t
48 -> m (TextInput t)
48 -> m (TextInput t)
49textInput cfg = do
49textInput cfg = do
@@ -51,6 +51,8 @@ textInput cfg = do
51 f <- focus
51 f <- focus
52 dh <- displayHeight
52 dh <- displayHeight
53 dw <- displayWidth
53 dw <- displayWidth
54+ bt <- theme
55+ attr0 <- sample bt
54 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
56 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
55 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
57 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
56 , _textInputConfig_modify cfg
58 , _textInputConfig_modify cfg
@@ -59,13 +61,20 @@ textInput cfg = do
59 goToDisplayLinePosition mx (st + my) dl
61 goToDisplayLinePosition mx (st + my) dl
60 ]
62 ]
61 click <- mouseDown V.BLeft
63 click <- mouseDown V.BLeft
62− let cursorAttrs = ffor f $ \x -> if x then cursorAttributes else V.defAttr
64+
63− let rows = (\w s c -> displayLines w V.defAttr c s)
65+ -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)
66+ let toCursorAttrs attr = V.withStyle attr V.reverseVideo
67+ rowInputDyn = (,,)
64 <$> dw
68 <$> dw
65 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
69 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
66− <*> cursorAttrs
70+ <*> f
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
67 img = images . _displayLines_spans <$> rows
76 img = images . _displayLines_spans <$> rows
68− y <- holdUniqDyn $ _displayLines_cursorY <$> rows
77+ y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows
69 let newScrollTop :: Int -> (Int, Int) -> Int
78 let newScrollTop :: Int -> (Int, Int) -> Int
70 newScrollTop st (h, cursorY)
79 newScrollTop st (h, cursorY)
71 | cursorY < st = cursorY
80 | cursorY < st = cursorY
@@ -81,7 +90,7 @@ textInput cfg = do
81
90
82-- | A widget that allows multiline text input
91-- | A widget that allows multiline text input
83multilineTextInput
92multilineTextInput
84− :: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplaySize t m, ImageWriter t m)
93+ :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)
85 => TextInputConfig t
94 => TextInputConfig t
86 -> m (TextInput t)
95 -> m (TextInput t)
87multilineTextInput cfg = do
96multilineTextInput cfg = do
@@ -99,7 +108,7 @@ multilineTextInput cfg = do
99-- the computed line count to greedily size the tile when vertically
108-- the computed line count to greedily size the tile when vertically
100-- oriented, and uses the fallback width when horizontally oriented.
109-- oriented, and uses the fallback width when horizontally oriented.
101textInputTile
110textInputTile
102− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m, MonadLayout t m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m)
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)
103 => m (TextInput t)
112 => m (TextInput t)
104 -> Dynamic t Int
113 -> Dynamic t Int
105 -> m (TextInput t)
114 -> m (TextInput t)
@@ -111,10 +120,6 @@ textInputTile txt width = do
111 Orientation_Row -> width
120 Orientation_Row -> width
112 return t
121 return t
113
122
114−-- | Default attributes for the text cursor
115−cursorAttributes :: V.Attr
116−cursorAttributes = V.withStyle V.defAttr V.reverseVideo
117−
118-- | 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)
119images :: [[Span V.Attr]] -> [V.Image]
124images :: [[Span V.Attr]] -> [V.Image]
120images = map (V.horizCat . map spanToImage)
125images = map (V.horizCat . map spanToImage)
src/Reflex/Vty/Widget/Layout.hs+99−84
@@ -7,12 +7,13 @@ Description: Monad transformer and tools for arranging widgets and building scre
7module Reflex.Vty.Widget.Layout where
7module Reflex.Vty.Widget.Layout where
8
8
9import Control.Applicative (liftA2)
9import Control.Applicative (liftA2)
10+import Control.Monad.Morph
10import Control.Monad.NodeId (MonadNodeId(..), NodeId)
11import Control.Monad.NodeId (MonadNodeId(..), NodeId)
11import Control.Monad.Reader
12import Control.Monad.Reader
12import Data.List (mapAccumL)
13import Data.List (mapAccumL)
13import Data.Map.Ordered (OMap)
14import Data.Map.Ordered (OMap)
14import qualified Data.Map.Ordered as OMap
15import qualified Data.Map.Ordered as OMap
15−import Data.Maybe (fromMaybe)
16+import Data.Maybe (fromMaybe, isNothing)
16import Data.Ratio ((%))
17import Data.Ratio ((%))
17import Data.Semigroup (First(..))
18import Data.Semigroup (First(..))
18import Data.Set.Ordered (OSet)
19import Data.Set.Ordered (OSet)
@@ -22,6 +23,7 @@ import qualified Graphics.Vty as V
22import Reflex
23import Reflex
23import Reflex.Host.Class (MonadReflexCreateTrigger)
24import Reflex.Host.Class (MonadReflexCreateTrigger)
24import Reflex.Vty.Widget
25import Reflex.Vty.Widget
26+import Reflex.Vty.Widget.Input.Mouse
25
27
26-- * Focus
28-- * Focus
27--
29--
@@ -33,7 +35,7 @@ import Reflex.Vty.Widget
33-- a tab press in a sibling element, a click event).
35-- a tab press in a sibling element, a click event).
34--
36--
35-- Focusable elements will usually be created via 'tile', but can also be
37-- Focusable elements will usually be created via 'tile', but can also be
36−-- constructed via 'makeFocus' in 'MonadFocus'. The latter option allows for
38+-- constructed via 'makeFocus' in 'HasFocus'. The latter option allows for
37-- more find-grained control of focus behavior.
39-- more find-grained control of focus behavior.
38
40
39-- ** Storing focus state
41-- ** Storing focus state
@@ -74,7 +76,7 @@ shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
74-- ** The focus management monad
76-- ** The focus management monad
75
77
76-- | A class for things that can produce focusable elements.
78-- | A class for things that can produce focusable elements.
77−class (Monad m, Reflex t) => MonadFocus t m | m -> t where
79+class (Monad m, Reflex t) => HasFocus t m | m -> t where
78 -- | Create a focusable element.
80 -- | Create a focusable element.
79 makeFocus :: m FocusId
81 makeFocus :: m FocusId
80 -- | Emit an 'Event' of requests to change the focus.
82 -- | Emit an 'Event' of requests to change the focus.
@@ -104,43 +106,36 @@ newtype Focus t m a = Focus
104 , PerformEvent t
106 , PerformEvent t
105 , NotReady t
107 , NotReady t
106 , MonadReflexCreateTrigger t
108 , MonadReflexCreateTrigger t
107− , HasDisplaySize t
109+ , HasDisplayRegion t
108 , PostBuild t
110 , PostBuild t
109 , MonadNodeId
111 , MonadNodeId
112+ , MonadIO
110 )
113 )
111
114
112
115
113instance MonadTrans (Focus t) where
116instance MonadTrans (Focus t) where
114 lift = Focus . lift . lift . lift
117 lift = Focus . lift . lift . lift
115
118
119+instance MFunctor (Focus t) where
120+ hoist f = Focus . hoist (hoist (hoist f)) . unFocus
121+
116instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
122instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
117 runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
123 runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
118 traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
124 traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
119 traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
125 traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
120 traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
126 traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
121
127
122−instance (Reflex t, MonadFix m, HasVtyInput t m) => HasVtyInput t (Focus t m) where
128+instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where
123− localInput f (Focus w) = Focus $ do
129+ localInput f = hoist (localInput f)
124− d <- ask
125− ((a, fs), e) <- lift $ lift $ lift $
126− localInput f $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
127− tellEvent e
128− tellDyn fs
129− return a
130
130
131−instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
131+instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
132− localCtx f g (Focus w) = Focus $ do
132+ mapImages f = hoist (mapImages f)
133− d <- ask
134− ((a, fs), e) <- lift $ lift $ lift $ localCtx f g $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
135− tellEvent e
136− tellDyn fs
137− return a
138
133
139−instance ImageWriter t m => ImageWriter t (Focus t m)
134+instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
140
135
141−instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)
136+instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)
142
137
143−instance (Reflex t, MonadFix m, MonadNodeId m) => MonadFocus t (Focus t m) where
138+instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where
144 makeFocus = do
139 makeFocus = do
145 fid <- FocusId <$> lift getNextNodeId
140 fid <- FocusId <$> lift getNextNodeId
146 Focus $ tellDyn $ pure $ singletonFS fid
141 Focus $ tellDyn $ pure $ singletonFS fid
@@ -169,13 +164,29 @@ runFocus (Focus x) = do
169 f (fs, rf) mf = case getFirst rf of
164 f (fs, rf) mf = case getFirst rf of
170 Refocus_Clear -> Nothing
165 Refocus_Clear -> Nothing
171 Refocus_Id fid -> Just fid
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
172− Refocus_Shift n -> shiftFS fs mf 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
173
184
174-- ** Focus controls
185-- ** Focus controls
175
186
176-- | Request focus be shifted backward and forward based on tab presses. <Tab>
187-- | Request focus be shifted backward and forward based on tab presses. <Tab>
177-- shifts focus forward and <Shift+Tab> shifts focus backward.
188-- shifts focus forward and <Shift+Tab> shifts focus backward.
178−tabNavigation :: (Reflex t, MonadNodeId m, HasVtyInput t m, MonadFocus t m) => m ()
189+tabNavigation :: (Reflex t, HasInput t m, HasFocus t m) => m ()
179tabNavigation = do
190tabNavigation = do
180 fwd <- fmap (const 1) <$> key (V.KChar '\t')
191 fwd <- fmap (const 1) <$> key (V.KChar '\t')
181 back <- fmap (const (-1)) <$> key V.KBackTab
192 back <- fmap (const (-1)) <$> key V.KBackTab
@@ -233,14 +244,14 @@ data Orientation = Orientation_Column
233
244
234-- | Create a row-oriented 'axis'
245-- | Create a row-oriented 'axis'
235row
246row
236− :: (Reflex t, MonadNodeId m, MonadFix m, MonadLayout t m)
247+ :: (Reflex t, MonadFix m, HasLayout t m)
237 => m a
248 => m a
238 -> m a
249 -> m a
239row = axis (pure Orientation_Row) flex
250row = axis (pure Orientation_Row) flex
240
251
241-- | Create a column-oriented 'axis'
252-- | Create a column-oriented 'axis'
242col
253col
243− :: (Reflex t, MonadNodeId m, MonadFix m, MonadLayout t m)
254+ :: (Reflex t, MonadFix m, HasLayout t m)
244 => m a
255 => m a
245 -> m a
256 -> m a
246col = axis (pure Orientation_Column) flex
257col = axis (pure Orientation_Column) flex
@@ -311,16 +322,27 @@ solve o0 r0 (LayoutForest cs) =
311 -> [(a, Constraint)]
322 -> [(a, Constraint)]
312 -> [(a, Int)]
323 -> [(a, Int)]
313 computeSizes available constraints =
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
314 let minTotal = sum $ ffor constraints $ \case
327 let minTotal = sum $ ffor constraints $ \case
315 (_, Constraint_Fixed n) -> n
328 (_, Constraint_Fixed n) -> n
316 (_, Constraint_Min n) -> n
329 (_, Constraint_Min n) -> n
330+ -- The leftover space is the area we can allow stretchable items to
331+ -- expand into
317 leftover = max 0 (available - minTotal)
332 leftover = max 0 (available - minTotal)
333+ -- The number of stretchable items that will try to share some of the
334+ -- leftover space
318 numStretch = length $ filter (isMin . snd) constraints
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)
319 szStretch = floor $ leftover % max numStretch 1
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.
320 adjustment = max 0 $ available - minTotal - szStretch * numStretch
342 adjustment = max 0 $ available - minTotal - szStretch * numStretch
321 in snd $ mapAccumL (\adj (a, c) -> case c of
343 in snd $ mapAccumL (\adj (a, c) -> case c of
322 Constraint_Fixed n -> (adj, (a, n))
344 Constraint_Fixed n -> (adj, (a, n))
323− Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
345+ Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints
324 isMin (Constraint_Min _) = True
346 isMin (Constraint_Min _) = True
325 isMin _ = False
347 isMin _ = False
326
348
@@ -340,8 +362,8 @@ chunk o r (offset, sz) = case o of
340-- ** The layout monad
362-- ** The layout monad
341
363
342-- | A class of operations for creating screen layouts.
364-- | A class of operations for creating screen layouts.
343−class Monad m => MonadLayout t m | m -> t where
365+class Monad m => HasLayout t m | m -> t where
344− -- | Creates a parent element in the current layout with the given size
366+ -- | Starts a parent element in the current layout with the given size
345 -- constraint, which lays out its children according to the provided
367 -- constraint, which lays out its children according to the provided
346 -- orientation.
368 -- orientation.
347 axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
369 axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
@@ -360,66 +382,73 @@ newtype Layout t m a = Layout
360 deriving
382 deriving
361 ( Functor
383 ( Functor
362 , Applicative
384 , Applicative
385+ , HasDisplayRegion t
363 , Monad
386 , Monad
387+ , MonadFix
364 , MonadHold t
388 , MonadHold t
389+ , MonadIO
390+ , MonadNodeId
391+ , MonadReflexCreateTrigger t
365 , MonadSample t
392 , MonadSample t
366− , MonadFix
367− , TriggerEvent t
368− , PerformEvent t
369 , NotReady t
393 , NotReady t
370− , MonadReflexCreateTrigger t
394+ , PerformEvent t
371− , HasDisplaySize t
372 , PostBuild t
395 , PostBuild t
373− , MonadNodeId
396+ , TriggerEvent t
374 )
397 )
375
398
376instance MonadTrans (Layout t) where
399instance MonadTrans (Layout t) where
377 lift = Layout . lift . lift
400 lift = Layout . lift . lift
378
401
402+instance MFunctor (Layout t) where
403+ hoist f = Layout . hoist (hoist f) . unLayout
404+
379instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
405instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
380 runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
406 runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
381 traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
407 traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
382 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
408 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
383 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
409 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
384
410
385−instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Layout t m) where
411+-- | Apply a transformation to the context of a child 'Layout' action and run
386− localCtx f g x = do
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
387− solution <- Layout ask
419+ solution <- Layout ask
388− let orientation = snd . rootLT <$> solution
420+ let orientation = snd . rootLT <$> solution
389− lift $ localCtx f g $ do
421+ lift $ f $ do
390− dw <- displayWidth
422+ dw <- displayWidth
391− dh <- displayHeight
423+ dh <- displayHeight
392− let reg = Region 0 0 <$> dw <*> dh
424+ let reg = Region 0 0 <$> dw <*> dh
393− runLayout orientation reg x
425+ runLayout orientation reg x
394−
426+
395−instance (HasVtyInput t m, HasDisplaySize t m, MonadFix m, Reflex t) => HasVtyInput t (Layout t m) where
427+instance (HasInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasInput t (Layout t m) where
396− localInput f x = do
428+ localInput = hoistRunLayout . localInput
397− solution <- Layout ask
429+
398− let orientation = snd . rootLT <$> solution
430+instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where
399− lift $ localInput f $ do
431+ mapImages f = hoistRunLayout (mapImages f)
400− dw <- displayWidth
432+
401− dh <- displayHeight
402− let reg = Region 0 0 <$> dw <*> dh
403− runLayout orientation reg x
404−
405−instance ImageWriter t m => ImageWriter t (Layout t m)
433+instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)
406−
434+
407−instance (HasFocus t m, Monad m) => HasFocus t (Layout t m)
435+instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)
408−
436+
409−instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => MonadLayout t (Layout t m) where
437+instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where
410 axis o c (Layout x) = Layout $ do
438 axis o c (Layout x) = Layout $ do
411 nodeId <- getNextNodeId
439 nodeId <- getNextNodeId
440+ let dummyParentLayout = LayoutTree (nilRegion, Orientation_Column) mempty
412− (result, forest) <- lift $ local (\t -> fromMaybe (LayoutTree (Region 0 0 0 0, Orientation_Column) mempty) . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x
441+ (result, forest) <- lift $ local (\t -> fromMaybe dummyParentLayout . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x
413 tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)
442 tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)
414 pure result
443 pure result
415 region c = do
444 region c = do
416 nodeId <- lift getNextNodeId
445 nodeId <- lift getNextNodeId
417 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty
446 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty
418 solutions <- Layout ask
447 solutions <- Layout ask
419− pure $ maybe (Region 0 0 0 0) (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions
448+ pure $ maybe nilRegion (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions
420 askOrientation = Layout $ asks $ fmap (snd . rootLT)
449 askOrientation = Layout $ asks $ fmap (snd . rootLT)
421
450
422−instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where
451+instance (MonadFix m, HasFocus t m) => HasFocus t (Layout t m) where
423 makeFocus = lift makeFocus
452 makeFocus = lift makeFocus
424 requestFocus = lift . requestFocus
453 requestFocus = lift . requestFocus
425 isFocused = lift . isFocused
454 isFocused = lift . isFocused
@@ -430,20 +459,6 @@ instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where
430 tellDyn w
459 tellDyn w
431 pure (a, sf)
460 pure (a, sf)
432
461
433−-- | Runs an action in the focus monad, providing it with information about
434−-- whether any of the foci created within it are focused.
435−anyChildFocused
436− :: (MonadFocus t m, MonadFix m)
437− => (Dynamic t Bool -> m a)
438− -> m a
439−anyChildFocused f = do
440− fid <- focusedId
441− rec (a, fs) <- subFoci (f b)
442− let b = liftA2 (\foc s -> case foc of
443− Nothing -> False
444− Just f' -> OSet.member f' $ unFocusSet s) fid fs
445− pure a
446−
447-- | Runs a 'Layout' action, using the given orientation and region to
462-- | Runs a 'Layout' action, using the given orientation and region to
448-- calculate layout solutions.
463-- calculate layout solutions.
449runLayout
464runLayout
@@ -458,7 +473,7 @@ runLayout o r (Layout x) = do
458 return result
473 return result
459
474
460-- | Initialize and run the layout monad, using all of the available screen space.
475-- | Initialize and run the layout monad, using all of the available screen space.
461−initLayout :: (HasDisplaySize t m, MonadFix m) => Layout t m a -> m a
476+initLayout :: (HasDisplayRegion t m, MonadFix m) => Layout t m a -> m a
462initLayout f = do
477initLayout f = do
463 dw <- displayWidth
478 dw <- displayWidth
464 dh <- displayHeight
479 dh <- displayHeight
@@ -468,13 +483,13 @@ initLayout f = do
468-- * The tile "window manager"
483-- * The tile "window manager"
469--
484--
470-- $tiling
485-- $tiling
471−-- Generally MonadLayout and MonadFocus are used together to build a user
486+-- Generally HasLayout and HasFocus are used together to build a user
472-- interface. These functions check the available screen size and initialize
487-- interface. These functions check the available screen size and initialize
473-- the layout monad with that information, and also initialize the focus monad.
488-- the layout monad with that information, and also initialize the focus monad.
474
489
475-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.
490-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.
476initManager
491initManager
477− :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
492+ :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
478 => Layout t (Focus t m) a
493 => Layout t (Focus t m) a
479 -> m (a, Dynamic t FocusSet)
494 -> m (a, Dynamic t FocusSet)
480initManager =
495initManager =
@@ -482,7 +497,7 @@ initManager =
482
497
483-- | Initialize a 'Layout' and 'Focus' management context.
498-- | Initialize a 'Layout' and 'Focus' management context.
484initManager_
499initManager_
485− :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
500+ :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
486 => Layout t (Focus t m) a
501 => Layout t (Focus t m) a
487 -> m a
502 -> m a
488initManager_ = fmap fst . initManager
503initManager_ = fmap fst . initManager
@@ -495,7 +510,7 @@ initManager_ = fmap fst . initManager
495-- provided constraint. Returns the 'FocusId' allowing for manual focus
510-- provided constraint. Returns the 'FocusId' allowing for manual focus
496-- management.
511-- management.
497tile'
512tile'
498− :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
513+ :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
499 => Dynamic t Constraint
514 => Dynamic t Constraint
500 -> m a
515 -> m a
501 -> m (FocusId, a)
516 -> m (FocusId, a)
@@ -514,7 +529,7 @@ tile' c w = do
514-- | A widget that is focusable and occupies a layout region based on the
529-- | A widget that is focusable and occupies a layout region based on the
515-- provided constraint.
530-- provided constraint.
516tile
531tile
517− :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
532+ :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
518 => Dynamic t Constraint
533 => Dynamic t Constraint
519 -> m a
534 -> m a
520 -> m a
535 -> m a
@@ -525,7 +540,7 @@ tile c = fmap snd . tile' c
525-- | A widget that is not focusable and occupies a layout region based on the
540-- | A widget that is not focusable and occupies a layout region based on the
526-- provided constraint.
541-- provided constraint.
527grout
542grout
528− :: (Reflex t, MonadNodeId m, HasVtyWidgetCtx t m, MonadLayout t m, HasVtyInput t m)
543+ :: (Reflex t, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
529 => Dynamic t Constraint
544 => Dynamic t Constraint
530 -> m a
545 -> m a
531 -> m a
546 -> m a
src/Reflex/Vty/Widget/Split.hsnew file+92
@@ -0,0 +1,92 @@
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.hsnew file+106
@@ -0,0 +1,106 @@
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.hsnew file+104
@@ -0,0 +1,104 @@
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.hsnew file+15
@@ -0,0 +1,15 @@
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