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+91−3
@@ -1,8 +1,96 @@
1# Revision history for reflex-vty
1# Revision history for reflex-vty
2
2
3−## Unreleased
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.
13+ * [#37](https://github.com/reflex-frp/reflex-vty/issues/37) `Layout` should support focus changes through nested layouts (thanks @pdlla for getting this started -- see entry on Layout and Focus below).
14+ * Fix distribution of available space when it cannot be evenly distributed. Previously, all leftover space would be allocated to the first stretchable widget.
15+* _Breaking Changes_:
16+ * Layout and focus have been substantially refactored to fix [#37](https://github.com/reflex-frp/reflex-vty/issues/37) and support a wider variety of layouts and focus switching requirements.
17+ * Added a new `HasFocus` class (the old one is now `HasFocusReader`) to produce focusable elements, and manage focus state. See the "Focus" section of the Reflex.Vty.Widget.Layout module documentation.
18+ * `Layout` no longer has any focus-tracking responsibility. See the "Layout" section of the Reflex.Vty.Widget.Layout module documentation.
19+ * `tile` no longer takes a configuration record and no longer requires that its child widget return a focus request event. Focus requests are instead handled using calls to `requestFocus` in the child widget.
20+ * Calls to `fixed` and `stretch` must now be replaced with `tile . fixed` and `tile . stretch`
21+ * `stretch` now takes a minimum size argument
22+ * Added `flex` which is equivalent to `stretch 0`
23+ * `tabNavigation` no longer returns an `Event`. Instead it calls `requestFocus` directly with the appropriate `Refocus_Shift` value.
24+ * Added `axis` (in `HasLayout`), a lower-level primitive which is used to implement `row` and `col`.
25+ * Added `region` (in `HasLayout`), which is used to claim screen real estate and used to implement `tile` and `grout`
26+ * Added `grout`, a container element that is not itself focusable (though its children can be)
27+ * Removed `VtyWidget` and replaced it with a number of separate classes and monad transformers
28+ * Replace `HasDisplaySize` with `HasDisplayRegion` which carries around a region instead of just a width and height. `displayWidth` and `displayHeight` are now functions implemented in terms of `askRegion` instead of class methods.
29+ * Add a `DisplayRegion` monad transformer
30+ * Rename `ImageWriter` to `HasImageWriter`
31+ * Introduce an `ImageWriter` monad transformer
32+ * Rename `HasFocus` to `HasFocusReader`
33+ * Introduce a `FocusReader` monad transformer
34+ * Replace `HasVtyInput` with `HasInput`
35+ * Introduce an `Input` monad transformer
36+ * Introduce `HasTheme` reader class to allow setting Vty attributes of all built-in widgets
37+ * Introduce `ThemeReader` monad transformer
38+ * Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.
39+ * `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.
40+ * `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.
41+ * `HasInput` (formerly `HasVtyInput`) now has a method `localInput` for filtering the input a child widget may receive
42+ * `HasImageWriter` now has a method `mapImages` for transforming the images emitted by a child widget
43+ * `boxTitle` now takes a `Behavior t Text` as its title, instead of a plain `Text`
44+ * `fill` now takes a `Behavior t Char` instead of a `Char`
45+ * The following functions are no longer specialized to `VtyWidget`:
46+ * `pane`: Now requires `HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m`
47+ * `drag`: Now requires `HasInput`
48+ * `mouseDown`: Now requires `HasInput`
49+ * `mouseUp`: Now requires `HasInput`
50+ * `mouseScroll`: Now requires `HasInput`
51+ * `key`: Now requires `HasInput`
52+ * `keys`: Now requires `HasInput`
53+ * `keyCombo`: Now requires `HasInput`
54+ * `keyCombos`: Now requires `HasInput`
55+ * `splitV`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
56+ * `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
57+ * `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
58+ * `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`
59+ * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
60+ * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
61+ * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
62+ * `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`
63+ * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
64+ * `blank`: Now requires `Monad`
65+ * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
66+ * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
67+ * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
68+ * `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
69+ * `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
70+ * TextZipper interface changes
71+ * `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`
72+ * `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position
73+ * some exposed methods intended for internal use only have been removed
74+ * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
75+ * `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
76+ * `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, `HasTheme`, and `HasFocus`
77+* _Misc_:
78+ * (#40 Add alignment support to TextZipper)[https://github.com/reflex-frp/reflex-vty/pull/40]
79+ * Add alignment (left/center/right) support to TextZipper
80+ * Add basic unit tests for newly created alignment methods in TextZipper
81+ * Add default instances for `HasInput`, `HasFocus`, and `HasImageWriter`
82+ * Export `withinImage` and add `imagesInRegion` to crop images to a region
83+ * Add `anyChildFocused`, which provides information about whether subwidgets are focused
84+ * Add `filterKeys`, which is the same as `localInput` but only cares about keyboard events
85+ * Add `hoistRunLayout` to apply a transformation to the context of a `Layout` action and run that action
86+ * Add various `MFunctor` instances
87+ * Add a CPU usage indicator to the example executable
88+
89+## 0.1.4.2
90+
91+* Wider bounds for GHC 8.10 support
92+
93+## 0.1.4.1
6
94
7## 0.1.4.1
95## 0.1.4.1
8* 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+63−10
@@ -1,5 +1,5 @@
1name: reflex-vty
1name: reflex-vty
2−version: 0.1.4.1
2+version: 0.2.0.0
3synopsis: Reflex FRP host and widgets for VTY applications
3synopsis: Reflex FRP host and widgets for VTY applications
4description:
4description:
5 Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).
5 Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).
@@ -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,8 @@ 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,
54+ ordered-containers >= 0.2.2 && < 0.3,
45 primitive >= 0.6.3 && < 0.8,
55 primitive >= 0.6.3 && < 0.8,
46 ref-tf >= 0.4.0 && < 0.5,
56 ref-tf >= 0.4.0 && < 0.5,
47 reflex >= 0.8 && < 0.9,
57 reflex >= 0.8 && < 0.9,
@@ -80,7 +90,6 @@ library
80 TypeApplications
90 TypeApplications
81 TypeFamilies
91 TypeFamilies
82
92
83−
84executable example
93executable example
85 hs-source-dirs: src-bin
94 hs-source-dirs: src-bin
86 main-is: example.hs
95 main-is: example.hs
@@ -95,7 +104,51 @@ executable example
95 transformers,
104 transformers,
96 vty
105 vty
97 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
98
137
99−source-repository head
138+
100− type: git
139+test-suite reflex-vty-test
101− 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+211−184
@@ -1,164 +1,151 @@
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 RecordWildCards #-}
11−
12−
13−{-# OPTIONS_GHC -threaded #-}
14−
15import Control.Applicative
1import Control.Applicative
16import Control.Monad
2import Control.Monad
17import Control.Monad.Fix
3import Control.Monad.Fix
18−import Control.Monad.NodeId
19import Data.Functor
4import Data.Functor
20import Data.Functor.Misc
5import Data.Functor.Misc
21import Data.Map (Map)
6import Data.Map (Map)
22−import Data.Maybe
23import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.Set as Set
24import Data.Text (Text)
9import Data.Text (Text)
25import qualified Data.Text as T
10import qualified Data.Text as T
26import qualified Data.Text.Zipper as TZ
11import qualified Data.Text.Zipper as TZ
27import qualified Graphics.Vty as V
12import qualified Graphics.Vty as V
28import Reflex
13import Reflex
29import Reflex.Network
14import Reflex.Network
30−import Reflex.Class.Switchable
31import Reflex.Vty
15import Reflex.Vty
32
16
33−easyExample :: IO ()
17+import Example.CPU
34−easyExample = mainWidget $ do
18+
35− beginLayout $ row $ fixedL 39 $ col $ do
19+type VtyExample t m =
36− (a1,b1,c1) <- fixedL 3 $ row $ do
20+ ( MonadFix m
37− a <- stretch $ textButtonStatic def "POTATO"
21+ , Reflex t
38− b <- stretch $ textButtonStatic def "TOMATO"
22+ , HasInput t m
39− c <- stretch $ textButtonStatic def "EGGPLANT"
23+ , HasImageWriter t m
40− return (a,b,c)
24+ , HasDisplayRegion t m
41− (a2,b2,c2) <- fixedL 3 $ row $ do
25+ , HasFocus t m
42− a <- stretch $ textButtonStatic def "CHEESE"
26+ , HasFocusReader t m, HasTheme t m
43− b <- stretch $ textButtonStatic def "BEES"
27+ )
44− c <- stretch $ textButtonStatic def "MY KNEES"
45− return (a,b,c)
46− (a3,b3,c3) <- fixedL 3 $ row $ do
47− a <- stretch $ textButtonStatic def "TIME"
48− b <- stretch $ textButtonStatic def "RHYME"
49− c <- stretch $ textButtonStatic def "A BIG CRIME"
50− return (a,b,c)
51− -- NOTE the box will most likely not render correctly once you put emoji's
52− -- you need to initialize vty with an updated char width map to fix this
53− fixed 7 $ boxTitle (constant def) "CLICK BUTTONS TO DRAW" $ do
54− outputDyn <- foldDyn (<>) "" $ mergeWith (<>)
55− [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
56− text (current outputDyn)
57− inp <- input
58− return $ fforMaybe inp $ \case
59− V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
60− _ -> Nothing
61
28
29+type Manager t m =
30+ ( HasLayout t m
31+ , HasFocus t m
32+ )
62
33
63data Example = Example_TextEditor
34data Example = Example_TextEditor
64 | Example_Todo
35 | Example_Todo
65 | Example_ScrollableTextDisplay
36 | Example_ScrollableTextDisplay
37+ | Example_ClickButtonsGetEmojis
38+ | Example_CPUStat
66 deriving (Show, Read, Eq, Ord, Enum, Bounded)
39 deriving (Show, Read, Eq, Ord, Enum, Bounded)
67
40
41+withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
42+withCtrlC f = do
43+ inp <- input
44+ f
45+ return $ fforMaybe inp $ \case
46+ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
47+ _ -> Nothing
48+
49+darkTheme :: V.Attr
50+darkTheme = V.Attr {
51+ V.attrStyle = V.SetTo V.standout
52+ , V.attrForeColor = V.SetTo V.black
53+ , V.attrBackColor = V.Default
54+ , V.attrURL = V.Default
55+}
56+
68main :: IO ()
57main :: IO ()
69−main = mainWidget $ do
58+main = mainWidget $ withCtrlC $ do
59+ initManager_ $ do
60+ tabNavigation
61+ let gf = grout . fixed
62+ t = tile flex
63+ buttons = col $ do
64+ gf 3 $ col $ do
65+ gf 1 $ text "Select an example."
66+ gf 1 $ text "Esc will bring you back here."
67+ gf 1 $ text "Ctrl+c to quit."
68+ a <- t $ textButtonStatic def "Todo List"
69+ b <- t $ textButtonStatic def "Text Editor"
70+ c <- t $ textButtonStatic def "Scrollable text display"
71+ d <- t $ textButtonStatic def "Clickable buttons"
72+ e <- t $ textButtonStatic def "CPU Usage"
73+ return $ leftmost
74+ [ Left Example_Todo <$ a
75+ , Left Example_TextEditor <$ b
76+ , Left Example_ScrollableTextDisplay <$ c
77+ , Left Example_ClickButtonsGetEmojis <$ d
78+ , Left Example_CPUStat <$ e
79+ ]
80+ let escapable w = do
81+ void w
82+ i <- input
83+ return $ fforMaybe i $ \case
84+ V.EvKey V.KEsc [] -> Just $ Right ()
85+ _ -> Nothing
86+ rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
87+ Left Example_Todo -> escapable taskList
88+ Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
89+ Left Example_ScrollableTextDisplay -> escapable scrolling
90+ Left Example_ClickButtonsGetEmojis -> escapable easyExample
91+ Left Example_CPUStat -> escapable cpuStats
92+ Right () -> buttons
93+ return ()
94+
95+-- * Mouse button and emojis example
96+easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
97+easyExample = do
98+ row $ grout (fixed 39) $ col $ do
99+ (a1,b1,c1) <- grout (fixed 3) $ row $ do
100+ a <- tile flex $ btn "POTATO"
101+ b <- tile flex $ btn "TOMATO"
102+ c <- tile flex $ btn "EGGPLANT"
103+ return (a,b,c)
104+ (a2,b2,c2) <- grout (fixed 3) $ row $ do
105+ a <- tile flex $ btn "CHEESE"
106+ b <- tile flex $ btn "BEES"
107+ c <- tile flex $ btn "MY KNEES"
108+ return (a,b,c)
109+ (a3,b3,c3) <- grout (fixed 3) $ row $ do
110+ a <- tile flex $ btn "TIME"
111+ b <- tile flex $ btn "RHYME"
112+ c <- tile flex $ btn "A BIG CRIME"
113+ return (a,b,c)
114+ tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do
115+ outputDyn <- foldDyn (<>) "" $ mergeWith (<>)
116+ [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
117+ text (current outputDyn)
118+ tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map."
70 inp <- input
119 inp <- input
71− let buttons = beginLayout $ col $ do
72− fixedL 4 $ col $ do
73− fixed 1 $ text "Select an example."
74− fixed 1 $ text "Esc will bring you back here."
75− fixed 1 $ text "Ctrl+c to quit."
76− a <- fixed 5 $ textButtonStatic def "Todo List"
77− b <- fixed 5 $ textButtonStatic def "Text Editor"
78− c <- fixed 5 $ textButtonStatic def "Scrollable text display"
79− return $ leftmost
80− [ Left Example_Todo <$ a
81− , Left Example_TextEditor <$ b
82− , Left Example_ScrollableTextDisplay <$ c
83− ]
84− escapable w = do
85− void w
86− i <- input
87− return $ fforMaybe i $ \case
88− V.EvKey V.KEsc [] -> Just $ Right ()
89− _ -> Nothing
90− rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
91− Left Example_TextEditor -> escapable testBoxes
92− Left Example_Todo -> escapable taskList
93− Left Example_ScrollableTextDisplay -> escapable scrolling
94− Right () -> buttons
95 return $ fforMaybe inp $ \case
120 return $ fforMaybe inp $ \case
96 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
121 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
97 _ -> Nothing
122 _ -> Nothing
123+ where
124+ btn label = do
125+ let cfg = def { _buttonConfig_focusStyle = pure doubleBoxStyle }
126+ buttonClick <- textButtonStatic cfg label
127+ keyPress <- keyCombos $ Set.fromList
128+ [ (V.KEnter, [])
129+ , (V.KChar ' ', [])
130+ ]
131+ pure $ leftmost [() <$ buttonClick, () <$ keyPress]
98
132
133+-- * Task list example
99taskList
134taskList
100− :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
135+ :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
101− => VtyWidget t m ()
136+ => m ()
102−taskList = do
137+taskList = col $ do
103− let btn = textButtonStatic def "Add another task"
104− inp <- input
105 let todos0 =
138 let todos0 =
106 [ Todo "Find reflex-vty" True
139 [ Todo "Find reflex-vty" True
107 , Todo "Become functional reactive" False
140 , Todo "Become functional reactive" False
108 , Todo "Make vty apps" False
141 , Todo "Make vty apps" False
109 ]
142 ]
110− rec let todos' = todos todos0 $ leftmost
143+ btn = textButtonStatic def "Add another task"
111− [ () <$ e
144+ enter <- fmap (const ()) <$> key V.KEnter
112− , fforMaybe inp $ \case
145+ rec void $ grout flex $ todos todos0 $ enter <> click
113− V.EvKey V.KEnter [] -> Just ()
146+ click <- tile (fixed 3) btn
114− _ -> Nothing
115− ]
116− (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
117− splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
118 return ()
147 return ()
119
148
120−testBoxes
121− :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
122− => VtyWidget t m ()
123−testBoxes = do
124− dw <- displayWidth
125− dh <- displayHeight
126− let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
127− region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
128− pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
129− _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
130− let cfg = def
131− { _textInputConfig_initialValue =
132− "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."
133− }
134− textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
135− multilineTextInput cfg
136− dragBox = boxStatic roundedBoxStyle dragTest
137− in splitVDrag (hRule doubleBoxStyle) textBox dragBox
138− return ()
139− where
140− div' :: (Integral a, Applicative f) => f a -> f a -> f a
141− div' = liftA2 div
142−
143−debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
144−debugFocus = do
145− f <- focus
146− text $ T.pack . show <$> current f
147−
148−debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
149−debugInput = do
150− lastEvent <- hold "No event yet" . fmap show =<< input
151− text $ T.pack <$> lastEvent
152−
153−dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
154−dragTest = do
155− lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
156− text $ T.pack <$> lastEvent
157−
158−testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()
159−testStringBox = boxStatic singleBoxStyle .
160− text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
161−
162data Todo = Todo
149data Todo = Todo
163 { _todo_label :: Text
150 { _todo_label :: Text
164 , _todo_done :: Bool
151 , _todo_done :: Bool
@@ -169,88 +156,128 @@ data TodoOutput t = TodoOutput
169 { _todoOutput_todo :: Dynamic t Todo
156 { _todoOutput_todo :: Dynamic t Todo
170 , _todoOutput_delete :: Event t ()
157 , _todoOutput_delete :: Event t ()
171 , _todoOutput_height :: Dynamic t Int
158 , _todoOutput_height :: Dynamic t Int
159+ , _todoOutput_focusId :: FocusId
172 }
160 }
173
161
174−instance Reflex t => Switchable t (TodoOutput t) where
175− switching t0 e = TodoOutput
176− <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
177− <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
178− <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)
179−
180todo
162todo
181− :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
163+ :: (VtyExample t m, Manager t m, MonadHold t m)
182 => Todo
164 => Todo
183− -> VtyWidget t m (TodoOutput t)
165+ -> m (TodoOutput t)
184−todo t0 = do
166+todo t0 = row $ do
185− w <- displayWidth
167+ let toggleKeys = Set.fromList
186− rec let checkboxWidth = 3
168+ [ (V.KChar ' ', [V.MCtrl])
187− checkboxRegion = DynRegion 0 0 checkboxWidth 1
169+ , (V.KChar '@', [V.MCtrl])
188− labelHeight = _textInput_lines ti
170+ ]
189− labelWidth = w - 1 - checkboxWidth
171+ anyChildFocused $ \focused -> do
190− labelLeft = checkboxWidth + 1
172+ toggleE <- keyCombos toggleKeys
191− labelTop = constDyn 0
173+ filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do
192− labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
174+ rec let cfg = def
175+ { _checkboxConfig_setValue = setVal
176+ }
193− value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
177+ value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0
194− (ti, d) <- pane labelRegion (pure True) $ do
178+ let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE
179+ (fid, (ti, d)) <- tile' flex $ do
195− i <- input
180+ i <- input
181+ v <- textInput $ def
196− v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
182+ { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
197− let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
183+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
198− return (v, deleteSelf)
184+ return (v, deleteSelf)
199− return $ TodoOutput
185+ return $ TodoOutput
200− { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
186+ { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
201− , _todoOutput_delete = d
187+ , _todoOutput_delete = d
202− , _todoOutput_height = _textInput_lines ti
188+ , _todoOutput_height = _textInput_lines ti
189+ , _todoOutput_focusId = fid
203− }
190+ }
204 where
191 where
205 backspaceOnEmpty v = \case
192 backspaceOnEmpty v = \case
206 V.EvKey V.KBS _ | T.null v -> Just ()
193 V.EvKey V.KBS _ | T.null v -> Just ()
207 _ -> Nothing
194 _ -> Nothing
208
195
209−scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m ()
210−scrolling = beginLayout $ col $ do
211− fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:"
212− out <- fixed 5 $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
213− fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
214−
215todos
196todos
216 :: forall t m.
197 :: forall t m.
217 ( MonadHold t m
198 ( MonadHold t m
218− , MonadFix m
199+ , Manager t m
219− , Reflex t
200+ , VtyExample t m
220 , Adjustable t m
201 , Adjustable t m
221− , NotReady t m
222 , PostBuild t m
202 , PostBuild t m
223− , MonadNodeId m
224 )
203 )
225 => [Todo]
204 => [Todo]
226 -> Event t ()
205 -> Event t ()
227− -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
206+ -> m (Dynamic t (Map Int (TodoOutput t)))
228todos todos0 newTodo = do
207todos todos0 newTodo = do
229 let todosMap0 = Map.fromList $ zip [0..] todos0
208 let todosMap0 = Map.fromList $ zip [0..] todos0
230− rec tabNav <- tabNavigation
231− let insertNav = 1 <$ insert
232− navEv = leftmost [tabNav, insertNav]
233− focusEv = layoutFocusEvFromNavigation navEv never lrd
234− tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1}
235− lrd@LayoutReturnData {..} <- flip runIsLayoutVtyWidget focusEv $ runLayoutL (pure Orientation_Column) (Just 0) $
236− listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do
209+ rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
210+ to <- todo t
237− let sel = select selectOnDelete $ Const2 k
211+ let sel = select selectOnDelete $ Const2 k
238− click <- void <$> mouseDown V.BLeft
239− pb <- getPostBuild
212+ pb <- getPostBuild
240− let focusMe = leftmost [ click, sel, pb ]
213+ requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
241− r <- todo t
214+ pure to
242− return (focusMe, r)
243− let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
215+ let delete = flip Map.singleton Nothing <$> todoDelete
216+ todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
217+ insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
218+ Nothing -> Map.singleton 0 $ Just $ Todo "" False
219+ Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
244 updates = leftmost [insert, delete]
220 updates = leftmost [insert, delete]
245 todoDelete = switch . current $
221 todoDelete = switch . current $
246− leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> _layoutReturnData_value
222+ leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
247− todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> _layoutReturnData_value
223+
248− insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
249− Nothing -> Map.singleton 0 $ Just $ Todo "" False
250− Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
251 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
224 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
252 (\m k -> let (before, after) = Map.split k m
225 (\m k -> let (before, after) = Map.split k m
253 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
226 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
254 (current todosMap)
227 (current todosMap)
255 todoDelete
228 todoDelete
256− return _layoutReturnData_value
229+ return listOut
230+
231+-- * Scrollable text example
232+
233+scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
234+scrolling = col $ do
235+ grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
236+ (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
237+ pb <- getPostBuild
238+ requestFocus $ Refocus_Id fid <$ pb
239+ grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
240+
241+-- * Text editor example with resizable boxes
242+
243+testBoxes
244+ :: (MonadHold t m, VtyExample t m)
245+ => m ()
246+testBoxes = do
247+ dw <- displayWidth
248+ dh <- displayHeight
249+ let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
250+ region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
251+ pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
252+ _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
253+ let cfg = def
254+ { _textInputConfig_initialValue =
255+ "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."
256+ }
257+ textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
258+ multilineTextInput cfg
259+ dragBox = boxStatic roundedBoxStyle dragTest
260+ in splitVDrag (hRule doubleBoxStyle) textBox dragBox
261+ return ()
262+ where
263+ div' :: (Integral a, Applicative f) => f a -> f a -> f a
264+ div' = liftA2 div
265+
266+debugFocus :: (VtyExample t m) => m ()
267+debugFocus = do
268+ f <- focus
269+ text $ T.pack . show <$> current f
270+
271+debugInput :: (VtyExample t m, MonadHold t m) => m ()
272+debugInput = do
273+ lastEvent <- hold "No event yet" . fmap show =<< input
274+ text $ T.pack <$> lastEvent
275+
276+dragTest :: (VtyExample t m, MonadHold t m) => m ()
277+dragTest = do
278+ lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
279+ text $ T.pack <$> lastEvent
280+
281+testStringBox :: VtyExample t m => m ()
282+testStringBox = boxStatic singleBoxStyle .
283+ text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
src/Control/Monad/NodeId.hs+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/Host.hs−1
@@ -196,7 +196,6 @@ runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $
196 updateVty
196 updateVty
197 loop
197 loop
198 where
198 where
199− -- TODO Some part of this is probably general enough to belong in reflex
200 -- | Use the given 'FireCommand' to fire events that have subscribers
199 -- | Use the given 'FireCommand' to fire events that have subscribers
201 -- and call the callback for the 'TriggerInvocation' of each.
200 -- and call the callback for the 'TriggerInvocation' of each.
202 fireEventTriggerRefs
201 fireEventTriggerRefs
src/Reflex/Vty/Widget.hs+467−633
@@ -4,147 +4,39 @@ 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− , DynRegion(..)
19− , currentRegion
20− , Region(..)
21− , regionSize
22− , regionBlankImage
23− , Drag(..)
24− , drag
25− , MouseDown(..)
26− , MouseUp(..)
27− , mouseDown
28− , mouseUp
29− , ScrollDirection(..)
30− , mouseScroll
31− , pane
32− , splitV
33− , splitH
34− , splitVDrag
35− , boxTitle
36− , box
37− , boxStatic
38− , RichTextConfig(..)
39− , richText
40− , text
41− , scrollableText
42− , display
43− , BoxStyle(..)
44− , hyphenBoxStyle
45− , singleBoxStyle
46− , roundedBoxStyle
47− , thickBoxStyle
48− , doubleBoxStyle
49− , fill
50− , hRule
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
13+import Control.Monad.NodeId
62−import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
14+import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
15+import Control.Monad.Ref
63import Control.Monad.Trans (MonadTrans, lift)
16import Control.Monad.Trans (MonadTrans, lift)
64−import Data.Default (Default(..))
65import Data.Set (Set)
17import Data.Set (Set)
66import qualified Data.Set as Set
18import qualified Data.Set as Set
67−import Data.Text (Text)
68−import qualified Data.Text as T
69−import qualified Data.Text.Zipper as TZ
70import Graphics.Vty (Image)
19import Graphics.Vty (Image)
71import qualified Graphics.Vty as V
20import qualified Graphics.Vty as V
72import Reflex
21import Reflex
73import Reflex.Class ()
22import Reflex.Class ()
74import Reflex.Host.Class (MonadReflexCreateTrigger)
23import Reflex.Host.Class (MonadReflexCreateTrigger)
75−
76import Reflex.Vty.Host
24import Reflex.Vty.Host
77
25
78−import Control.Monad.NodeId
26+-- * Running a vty application
79−
80−-- | The context within which a 'VtyWidget' runs
81−data VtyWidgetCtx t = VtyWidgetCtx
82− { _vtyWidgetCtx_width :: Dynamic t Int
83− -- ^ The width of the region allocated to the widget.
84− , _vtyWidgetCtx_height :: Dynamic t Int
85− -- ^ The height of the region allocated to the widget.
86− , _vtyWidgetCtx_focus :: Dynamic t Bool
87− -- ^ Whether the widget should behave as if it has focus for keyboard input.
88− , _vtyWidgetCtx_input :: Event t VtyEvent
89− -- ^ User input events that the widget's parent chooses to share. These will generally
90− -- be filtered for relevance:
91− -- * Keyboard inputs are restricted to focused widgets
92− -- * Mouse inputs are restricted to the region in which the widget resides and are
93− -- translated into its internal coordinates.
94− }
95−
96−-- | The output of a 'VtyWidget'
97−data VtyWidgetOut t = VtyWidgetOut
98− { _vtyWidgetOut_shutdown :: Event t ()
99− }
100−
101−instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where
102− runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'
103− traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $
104− traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
105− traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do
106− traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
107− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do
108− traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'
109−
110−-- | A widget that can read its context and produce image output
111−newtype VtyWidget t m a = VtyWidget
112− { unVtyWidget :: BehaviorWriterT t [Image] (ReaderT (VtyWidgetCtx t) m) a
113− } deriving
114− ( Functor
115− , Applicative
116− , Monad
117− , MonadSample t
118− , MonadHold t
119− , MonadFix
120− , NotReady t
121− , ImageWriter t
122− , PostBuild t
123− , TriggerEvent t
124− , MonadReflexCreateTrigger t
125− , MonadIO
126− )
127−
128−deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
129−instance MonadTrans (VtyWidget t) where
130− lift f = VtyWidget $ lift $ lift f
131−
132−instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
133− getNextNodeId = VtyWidget $ do
134− lift $ lift getNextNodeId
135−
136−-- | Runs a 'VtyWidget' with a given context
137−runVtyWidget
138− :: (Reflex t, MonadNodeId m)
139− => VtyWidgetCtx t
140− -> VtyWidget t m a
141− -> m (a, Behavior t [Image])
142−runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx
143
27
144−-- | 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
145mainWidgetWithHandle
29mainWidgetWithHandle
146 :: V.Vty
30 :: V.Vty
31+ -> (forall t m.
147− -> (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 ()))
148 -> IO ()
40 -> IO ()
149mainWidgetWithHandle vty child =
41mainWidgetWithHandle vty child =
150 runVtyAppWithHandle vty $ \dr0 inp -> do
42 runVtyAppWithHandle vty $ \dr0 inp -> do
@@ -154,71 +46,178 @@ mainWidgetWithHandle vty child =
154 let inp' = fforMaybe inp $ \case
46 let inp' = fforMaybe inp $ \case
155 V.EvResize {} -> Nothing
47 V.EvResize {} -> Nothing
156 x -> Just x
48 x -> Just x
157− let ctx = VtyWidgetCtx
49+ (shutdown, images) <- runThemeReader (constant V.defAttr) $
158− { _vtyWidgetCtx_width = fmap fst size
50+ runFocusReader (pure True) $
159− , _vtyWidgetCtx_height = fmap snd size
51+ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
160− , _vtyWidgetCtx_input = inp'
52+ runImageWriter $
161− , _vtyWidgetCtx_focus = constDyn True
53+ runNodeIdT $
162− }
54+ runInput inp' $ do
163− (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do
164− 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]
165− child
56+ child
166 return $ VtyResult
57 return $ VtyResult
167 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
58 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
168 , _vtyResult_shutdown = shutdown
59 , _vtyResult_shutdown = shutdown
169 }
60 }
170
61
62+-- | The output of a vty widget
63+data VtyWidgetOut t = VtyWidgetOut
64+ { _vtyWidgetOut_shutdown :: Event t ()
65+ }
66+
171-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
67-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
172mainWidget
68mainWidget
69+ :: (forall t m.
173− :: (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 ()))
174 -> IO ()
78 -> IO ()
175mainWidget child = do
79mainWidget child = do
176 vty <- getDefaultVty
80 vty <- getDefaultVty
177 mainWidgetWithHandle vty child
81 mainWidgetWithHandle vty child
178
82
179−-- | A class for things that know their own display size dimensions
83+-- * Input Events
180−class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
181− -- | Retrieve the display width (columns)
182− displayWidth :: m (Dynamic t Int)
183− default displayWidth :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
184− displayWidth = lift displayWidth
185− -- | Retrieve the display height (rows)
186− displayHeight :: m (Dynamic t Int)
187− default displayHeight :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
188− displayHeight = lift displayHeight
189−
190−instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
191− displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width
192− displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height
193−
194−instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)
195−instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)
196−instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)
197−instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)
198−
199−instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)
200
84
201-- | A class for things that can receive vty events as input
85-- | A class for things that can receive vty events as input
202−class HasVtyInput t m | m -> t where
86+class HasInput t m | m -> t where
203 input :: m (Event t VtyEvent)
87 input :: m (Event t VtyEvent)
88+ default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)
89+ input = lift input
90+ -- | User input events that the widget's parent chooses to share. These will generally
91+ -- be filtered for relevance.
92+ localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
93+ default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
94+ localInput f = hoist (localInput f)
95+
96+instance (Reflex t, Monad m) => HasInput t (Input t m) where
97+ input = Input ask
98+ localInput f (Input m) = Input $ local f m
99+
100+-- | A widget that can receive input events. See 'Graphics.Vty.Event'
101+newtype Input t m a = Input
102+ { unInput :: ReaderT (Event t VtyEvent) m a
103+ } deriving
104+ ( Functor
105+ , Applicative
106+ , Monad
107+ , MonadSample t
108+ , MonadHold t
109+ , MonadFix
110+ , MonadIO
111+ , MonadRef
112+ )
204
113
205−instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
114+instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where
206− input = VtyWidget . lift $ asks _vtyWidgetCtx_input
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
207
149
208−-- | A class for things that can dynamically gain and lose focus
150+-- | Type synonym for a key and modifier combination
209−class HasFocus t m | m -> t where
151+type KeyCombo = (V.Key, [V.Modifier])
210− focus :: m (Dynamic t Bool)
211
152
212−instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
153+-- | Emits an event that fires on a particular key press (without modifiers)
213− focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
154+key :: (Monad m, Reflex t, HasInput t m) => V.Key -> m (Event t KeyCombo)
155+key = keyCombos . Set.singleton . (,[])
214
156
215−-- | A class for widgets that can produce images to draw to the display
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
216−class (Reflex t, Monad m) => ImageWriter t m | m -> t where
163+ :: (Reflex t, Monad m, HasInput t m)
217− -- | Send images upstream for rendering
164+ => KeyCombo
218− tellImages :: Behavior t [Image] -> m ()
165+ -> m (Event t KeyCombo)
166+keyCombo = keyCombos . Set.singleton
219
167
220−instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
168+-- | Emit an event that fires whenever any of the provided key combinations occur
221− tellImages = tellBehavior
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
180+
181+-- | Filter the keyboard input that a child widget may receive
182+filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a
183+filterKeys f x = localInput (ffilter (\case
184+ V.EvKey k mods -> f (k, mods)
185+ _ -> True)) x
186+
187+-- | Filter mouse input events based on whether they target a particular region
188+-- and translate them to the internal coordinate system of that region.
189+--
190+-- NB: Non-mouse events are passed through unfiltered and unchanged
191+mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent
192+mouseInRegion (Region l t w h) e = case e of
193+ V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
194+ V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
195+ _ -> Just e
196+ where
197+ mouse con x y
198+ | or [ x < l
199+ , y < t
200+ , x >= l + w
201+ , y >= t + h ] = Nothing
202+ | otherwise =
203+ Just (con (x - l) (y - t))
204+
205+-- | Filter mouse input outside the current display region and
206+-- all input if the region is not focused
207+inputInFocusedRegion
208+ :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
209+ => m (Event t VtyEvent)
210+inputInFocusedRegion = do
211+ inp <- input
212+ reg <- current <$> askRegion
213+ foc <- current <$> focus
214+ pure $ fmapMaybe id $ attachWith filterInput ((,) <$> reg <*> foc) inp
215+ where
216+ filterInput (r, f) = \case
217+ V.EvKey {} | not f -> Nothing
218+ x -> mouseInRegion r x
219+
220+-- * Getting and setting the display region
222
221
223-- | A chunk of the display area
222-- | A chunk of the display area
224data Region = Region
223data Region = Region
@@ -229,499 +228,334 @@ data Region = Region
229 }
228 }
230 deriving (Show, Read, Eq, Ord)
229 deriving (Show, Read, Eq, Ord)
231
230
232−-- | A dynamic chunk of the display area
231+-- | A region that occupies no space.
233−data DynRegion t = DynRegion
232+nilRegion :: Region
234− { _dynRegion_left :: Dynamic t Int
233+nilRegion = Region 0 0 0 0
235− , _dynRegion_top :: Dynamic t Int
236− , _dynRegion_width :: Dynamic t Int
237− , _dynRegion_height :: Dynamic t Int
238− }
239
234
240-- | The width and height of a 'Region'
235-- | The width and height of a 'Region'
241regionSize :: Region -> (Int, Int)
236regionSize :: Region -> (Int, Int)
242regionSize (Region _ _ w h) = (w, h)
237regionSize (Region _ _ w h) = (w, h)
243
238
244-- | Produces an 'Image' that fills a region with space characters
239-- | Produces an 'Image' that fills a region with space characters
245−regionBlankImage :: Region -> Image
240+regionBlankImage :: V.Attr -> Region -> Image
246−regionBlankImage r@(Region _ _ width height) =
241+regionBlankImage attr r@(Region _ _ width height) =
247− withinImage r $ V.charFill V.defAttr ' ' width height
242+ withinImage r $ V.charFill attr ' ' width height
248
243
249−-- | A behavior of the current display area represented by a 'DynRegion'
244+-- | A class for things that know their own display size dimensions
250−currentRegion :: Reflex t => DynRegion t -> Behavior t Region
245+class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
251−currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h
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+ )
252
282
253−-- | Translates and crops an 'Image' so that it is contained by
283+instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where
254−-- the given 'Region'.
284+ askRegion = DisplayRegion ask
255−withinImage
285+ localRegion f = DisplayRegion . local f . unDisplayRegion
256− :: Region
257− -> Image
258− -> Image
259−withinImage (Region left top width height)
260− | width < 0 || height < 0 = withinImage (Region left top 0 0)
261− | otherwise = V.translate left top . V.crop width height
262
286
263−-- | Low-level widget combinator that runs a child 'VtyWidget' within
287+deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m)
264−-- a given region and context. This widget filters and modifies the input
288+deriving instance NotReady t m => NotReady t (DisplayRegion t m)
265−-- that the child widget receives such that:
289+deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
266−-- * unfocused widgets receive no key events
290+deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
267−-- * mouse inputs outside the region are ignored
291+deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
268−-- * mouse inputs inside the region have their coordinates translated such
292+instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
269−-- that (0,0) is the top-left corner of the region
293+instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)
270−pane
271− :: (Reflex t, Monad m, MonadNodeId m)
272− => DynRegion t
273− -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
274− -> VtyWidget t m a
275− -> VtyWidget t m a
276−pane dr foc child = VtyWidget $ do
277− ctx <- lift ask
278− let reg = currentRegion dr
279− let ctx' = VtyWidgetCtx
280− { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.
281− [ fmapMaybe id $
282− attachWith (\(r,f) e -> filterInput r f e)
283− (liftA2 (,) reg (current foc))
284− (_vtyWidgetCtx_input ctx)
285− ]
286− , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
287− , _vtyWidgetCtx_width = _dynRegion_width dr
288− , _vtyWidgetCtx_height = _dynRegion_height dr
289− }
290− (result, images) <- lift . lift $ runVtyWidget ctx' child
291− let images' = liftA2 (\r is -> map (withinImage r) is) reg images
292− tellImages images'
293− return result
294− where
295− filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
296− filterInput (Region l t w h) focused e = case e of
297− V.EvKey _ _ | not focused -> Nothing
298− V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
299− V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
300− _ -> Just e
301− where
302− mouse con x y
303− | or [ x < l
304− , y < t
305− , x >= l + w
306− , y >= t + h ] = Nothing
307− | otherwise =
308− Just (con (x - l) (y - t))
309−
310−-- | Information about a drag operation
311−data Drag = Drag
312− { _drag_from :: (Int, Int) -- ^ Where the drag began
313− , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
314− , _drag_button :: V.Button -- ^ Which mouse button is dragging
315− , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
316− , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
317− }
318− deriving (Eq, Ord, Show)
319−
320−-- | Converts raw vty mouse drag events into an event stream of 'Drag's
321−drag
322− :: (Reflex t, MonadFix m, MonadHold t m)
323− => V.Button
324− -> VtyWidget t m (Event t Drag)
325−drag btn = do
326− inp <- input
327− let f :: Maybe Drag -> V.Event -> Maybe Drag
328− f Nothing = \case
329− V.EvMouseDown x y btn' mods
330− | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
331− | otherwise -> Nothing
332− _ -> Nothing
333− f (Just (Drag from _ _ mods end)) = \case
334− V.EvMouseDown x y btn' mods'
335− | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
336− | btn == btn' -> Just $ Drag from (x,y) btn mods' False
337− | otherwise -> Nothing -- Ignore other buttons.
338− V.EvMouseUp x y (Just btn')
339− | end -> Nothing
340− | btn == btn' -> Just $ Drag from (x,y) btn mods True
341− | otherwise -> Nothing
342− V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
343− -- assume it's the right one.
344− | end -> Nothing
345− | otherwise -> Just $ Drag from (x,y) btn mods True
346− _ -> Nothing
347− rec let newDrag = attachWithMaybe f (current dragD) inp
348− dragD <- holdDyn Nothing $ Just <$> newDrag
349− return (fmapMaybe id $ updated dragD)
350−
351−-- | Mouse down events for a particular mouse button
352−mouseDown
353− :: (Reflex t, Monad m)
354− => V.Button
355− -> VtyWidget t m (Event t MouseDown)
356−mouseDown btn = do
357− i <- input
358− return $ fforMaybe i $ \case
359− V.EvMouseDown x y btn' mods -> if btn == btn'
360− then Just $ MouseDown btn' (x, y) mods
361− else Nothing
362− _ -> Nothing
363
294
364−-- | Mouse up events for a particular mouse button
295+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
365−mouseUp
296+ runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e
366− :: (Reflex t, Monad m)
297+ traverseIntMapWithKeyWithAdjust f m e = DisplayRegion $ traverseIntMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
367− => VtyWidget t m (Event t MouseUp)
298+ traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
368−mouseUp = do
299+ traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
369− i <- input
370− return $ fforMaybe i $ \case
371− V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
372− _ -> Nothing
373
300
374−-- | Information about a mouse down event
301+instance MonadTrans (DisplayRegion t) where
375−data MouseDown = MouseDown
302+ lift = DisplayRegion . lift
376− { _mouseDown_button :: V.Button
377− , _mouseDown_coordinates :: (Int, Int)
378− , _mouseDown_modifiers :: [V.Modifier]
379− }
380− deriving (Eq, Ord, Show)
381
303
382−-- | Information about a mouse up event
304+instance MFunctor (DisplayRegion t) where
383−data MouseUp = MouseUp
305+ hoist f = DisplayRegion . hoist f . unDisplayRegion
384− { _mouseUp_button :: Maybe V.Button
385− , _mouseUp_coordinates :: (Int, Int)
386− }
387− deriving (Eq, Ord, Show)
388
306
389−-- | Mouse scroll direction
307+instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
390−data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
391− deriving (Eq, Ord, Show)
392
308
393−-- | Produce an event that fires when the mouse wheel is scrolled
309+-- | Run a 'DisplayRegion' action with a given 'Region'
394−mouseScroll
310+runDisplayRegion
395 :: (Reflex t, Monad m)
311 :: (Reflex t, Monad m)
396− => VtyWidget t m (Event t ScrollDirection)
312+ => Dynamic t Region
397−mouseScroll = do
313+ -> DisplayRegion t m a
398− up <- mouseDown V.BScrollUp
314+ -> m a
399− down <- mouseDown V.BScrollDown
315+runDisplayRegion r = flip runReaderT r . unDisplayRegion
400− return $ leftmost
401− [ ScrollDirection_Up <$ up
402− , ScrollDirection_Down <$ down
403− ]
404
316
405−-- | Type synonym for a key and modifier combination
317+-- * Getting focus state
406−type KeyCombo = (V.Key, [V.Modifier])
407
318
408−-- | Emits an event that fires on a particular key press (without modifiers)
319+-- | A class for things that can dynamically gain and lose focus
409−key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)
320+class (Reflex t, Monad m) => HasFocusReader t m | m -> t where
410−key = keyCombos . Set.singleton . (,[])
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+ )
411
347
412−-- | Emits an event that fires on particular key presses (without modifiers)
348+instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where
413−keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)
349+ focus = FocusReader ask
414−keys = keyCombos . Set.fromList . fmap (,[])
350+ localFocus f = FocusReader . local f . unFocusReader
415
351
416−-- | Emit an event that fires whenever the provided key combination occurs
352+deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (FocusReader t m)
417−keyCombo
353+deriving instance NotReady t m => NotReady t (FocusReader t m)
418− :: (Reflex t, Monad m)
354+deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)
419− => KeyCombo
355+deriving instance PostBuild t m => PostBuild t (FocusReader t m)
420− -> VtyWidget t m (Event t KeyCombo)
356+deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)
421−keyCombo = keyCombos . Set.singleton
357+instance HasImageWriter t m => HasImageWriter t (FocusReader t m)
422
358
423−-- | Emit an event that fires whenever any of the provided key combinations occur
359+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where
424−keyCombos
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
425 :: (Reflex t, Monad m)
375 :: (Reflex t, Monad m)
426− => Set KeyCombo
376+ => Dynamic t Bool
427− -> VtyWidget t m (Event t KeyCombo)
377+ -> FocusReader t m a
428−keyCombos ks = do
378+ -> m a
429− i <- input
379+runFocusReader b = flip runReaderT b . unFocusReader
430− return $ fforMaybe i $ \case
431− V.EvKey k m -> if Set.member (k, m) ks
432− then Just (k, m)
433− else Nothing
434− _ -> Nothing
435
380
436−-- | A plain split of the available space into vertically stacked panes.
381+-- * "Image" output
437−-- No visual separator is built in here.
438−splitV :: (Reflex t, Monad m, MonadNodeId m)
439− => Dynamic t (Int -> Int)
440− -- ^ Function used to determine size of first pane based on available size
441− -> Dynamic t (Bool, Bool)
442− -- ^ How to focus the two sub-panes, given that we are focused.
443− -> VtyWidget t m a
444− -- ^ Widget for first pane
445− -> VtyWidget t m b
446− -- ^ Widget for second pane
447− -> VtyWidget t m (a,b)
448−splitV sizeFunD focD wA wB = do
449− dw <- displayWidth
450− dh <- displayHeight
451− let regA = DynRegion
452− { _dynRegion_left = pure 0
453− , _dynRegion_top = pure 0
454− , _dynRegion_width = dw
455− , _dynRegion_height = sizeFunD <*> dh
456− }
457− regB = DynRegion
458− { _dynRegion_left = pure 0
459− , _dynRegion_top = _dynRegion_height regA
460− , _dynRegion_width = dw
461− , _dynRegion_height = liftA2 (-) dh (_dynRegion_height regA)
462− }
463− ra <- pane regA (fst <$> focD) wA
464− rb <- pane regB (snd <$> focD) wB
465− return (ra,rb)
466−
467−-- | A plain split of the available space into horizontally stacked panes.
468−-- No visual separator is built in here.
469−splitH :: (Reflex t, Monad m, MonadNodeId m)
470− => Dynamic t (Int -> Int)
471− -- ^ Function used to determine size of first pane based on available size
472− -> Dynamic t (Bool, Bool)
473− -- ^ How to focus the two sub-panes, given that we are focused.
474− -> VtyWidget t m a
475− -- ^ Widget for first pane
476− -> VtyWidget t m b
477− -- ^ Widget for second pane
478− -> VtyWidget t m (a,b)
479−splitH sizeFunD focD wA wB = do
480− dw <- displayWidth
481− dh <- displayHeight
482− let regA = DynRegion
483− { _dynRegion_left = pure 0
484− , _dynRegion_top = pure 0
485− , _dynRegion_width = sizeFunD <*> dw
486− , _dynRegion_height = dh
487− }
488− regB = DynRegion
489− { _dynRegion_left = _dynRegion_width regA
490− , _dynRegion_top = pure 0
491− , _dynRegion_width = liftA2 (-) dw (_dynRegion_width regA)
492− , _dynRegion_height = dh
493− }
494− liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
495−
496−-- | A split of the available space into two parts with a draggable separator.
497−-- Starts with half the space allocated to each, and the first pane has focus.
498−-- Clicking in a pane switches focus.
499−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
500− => VtyWidget t m ()
501− -> VtyWidget t m a
502− -> VtyWidget t m b
503− -> VtyWidget t m (a,b)
504−splitVDrag wS wA wB = do
505− dh <- displayHeight
506− dw <- displayWidth
507− h0 <- sample $ current dh -- TODO
508− dragE <- drag V.BLeft
509− let splitter0 = h0 `div` 2
510− rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
511− splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
512− splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
513− fromIntegral x / max 1 (fromIntegral h)
514− let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
515− \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
516− if splitterY == fromY then Just (toY, end) else Nothing
517− regA = DynRegion 0 0 dw splitterPos
518− regS = DynRegion 0 splitterPos dw 1
519− regB = DynRegion 0 (splitterPos + 1) dw (dh - splitterPos - 1)
520− resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
521− \(frac, h) -> round (frac * fromIntegral h)
522− focA <- holdDyn True $ leftmost
523− [ True <$ mA
524− , False <$ mB
525− ]
526− (mA, rA) <- pane regA focA $ withMouseDown wA
527− pane regS (pure False) wS
528− (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
529− return (rA, rB)
530− where
531− withMouseDown x = do
532− m <- mouseDown V.BLeft
533− x' <- x
534− return (m, x')
535−
536−-- | Fill the background with a particular character.
537−fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
538−fill c = do
539− dw <- displayWidth
540− dh <- displayHeight
541− let fillImg = current $ liftA2 (\w h -> [V.charFill V.defAttr c w h]) dw dh
542− tellImages fillImg
543−
544−-- | Fill the background with the bottom
545−hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
546−hRule boxStyle = fill (_boxStyle_s boxStyle)
547−
548−-- | Defines a set of symbols to use to draw the outlines of boxes
549−-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character
550−data BoxStyle = BoxStyle
551− { _boxStyle_nw :: Char
552− , _boxStyle_n :: Char
553− , _boxStyle_ne :: Char
554− , _boxStyle_e :: Char
555− , _boxStyle_se :: Char
556− , _boxStyle_s :: Char
557− , _boxStyle_sw :: Char
558− , _boxStyle_w :: Char
559− }
560
382
561−instance Default BoxStyle where
383+-- | A class for widgets that can produce images to draw to the display
562− def = singleBoxStyle
384+class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
563−
385+ -- | Send images upstream for rendering
564−-- | A box style that uses hyphens and pipe characters. Doesn't handle
386+ tellImages :: Behavior t [Image] -> m ()
565−-- corners very well.
387+ default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()
566−hyphenBoxStyle :: BoxStyle
388+ tellImages = lift . tellImages
567−hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
389+ -- | Apply a transformation to the images produced by the child actions
568−
390+ mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
569−-- | A single line box style
391+ default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
570−singleBoxStyle :: BoxStyle
392+ mapImages f = hoist (mapImages f)
571−singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
393+
572−
394+-- | A widget that can produce images to draw onto the display
573−-- | A thick single line box style
395+newtype ImageWriter t m a = ImageWriter
574−thickBoxStyle :: BoxStyle
396+ { unImageWriter :: BehaviorWriterT t [Image] m a }
575−thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
397+ deriving
576−
398+ ( Functor
577−-- | A double line box style
399+ , Applicative
578−doubleBoxStyle :: BoxStyle
400+ , Monad
579−doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
401+ , MonadFix
580−
402+ , MonadHold t
581−-- | A single line box style with rounded corners
403+ , MonadIO
582−roundedBoxStyle :: BoxStyle
404+ , MonadRef
583−roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
405+ , MonadReflexCreateTrigger t
584−
406+ , MonadSample t
585−-- | Draws a titled box in the provided style and a child widget inside of that box
407+ , NotReady t
586−boxTitle :: (Monad m, Reflex t, MonadNodeId m)
408+ , PerformEvent t
587− => Behavior t BoxStyle
409+ , PostBuild t
588− -> Text
410+ , TriggerEvent t
589− -> VtyWidget t m a
411+ )
590− -> VtyWidget t m a
412+
591−boxTitle boxStyle title child = do
413+instance MonadTrans (ImageWriter t) where
592− dh <- displayHeight
414+ lift = ImageWriter . lift
593− dw <- displayWidth
415+
594− let boxReg = DynRegion (pure 0) (pure 0) dw dh
416+instance MFunctor (ImageWriter t) where
595− innerReg = DynRegion (pure 1) (pure 1) (subtract 2 <$> dw) (subtract 2 <$> dh)
417+ hoist f = ImageWriter . (hoist f) . unImageWriter
596− tellImages (boxImages <$> boxStyle <*> currentRegion boxReg)
418+
597− tellImages (fmap (\r -> [regionBlankImage r]) (currentRegion innerReg))
419+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ImageWriter t m) where
598− pane innerReg (pure True) child
420+ runWithReplace (ImageWriter a) e = ImageWriter $ runWithReplace a $ fmap unImageWriter e
599− where
421+ traverseIntMapWithKeyWithAdjust f m e = ImageWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
600− boxImages :: BoxStyle -> Region -> [Image]
422+ traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
601− boxImages style (Region left top width height) =
423+ traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e
602− let right = left + width - 1
603− bottom = top + height - 1
604− sides =
605− [ withinImage (Region (left + 1) top (width - 2) 1) $
606− V.text' V.defAttr $
607− hPadText title (_boxStyle_n style) (width - 2)
608− , withinImage (Region right (top + 1) 1 (height - 2)) $
609− V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)
610− , withinImage (Region (left + 1) bottom (width - 2) 1) $
611− V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1
612− , withinImage (Region left (top + 1) 1 (height - 2)) $
613− V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)
614− ]
615− corners =
616− [ withinImage (Region left top 1 1) $
617− V.char V.defAttr (_boxStyle_nw style)
618− , withinImage (Region right top 1 1) $
619− V.char V.defAttr (_boxStyle_ne style)
620− , withinImage (Region right bottom 1 1) $
621− V.char V.defAttr (_boxStyle_se style)
622− , withinImage (Region left bottom 1 1) $
623− V.char V.defAttr (_boxStyle_sw style)
624− ]
625− in sides ++ if width > 1 && height > 1 then corners else []
626− hPadText :: T.Text -> Char -> Int -> T.Text
627− hPadText t c l = if lt >= l
628− then t
629− else left <> t <> right
630− where
631− lt = T.length t
632− delta = l - lt
633− mkHalf n = T.replicate (n `div` 2) (T.singleton c)
634− left = mkHalf $ delta + 1
635− right = mkHalf delta
636−
637−-- | A box without a title
638−box :: (Monad m, Reflex t, MonadNodeId m)
639− => Behavior t BoxStyle
640− -> VtyWidget t m a
641− -> VtyWidget t m a
642−box boxStyle = boxTitle boxStyle mempty
643−
644−-- | A box whose style is static
645−boxStatic
646− :: (Reflex t, Monad m, MonadNodeId m)
647− => BoxStyle
648− -> VtyWidget t m a
649− -> VtyWidget t m a
650−boxStatic = box . pure
651−
652−-- | Configuration options for displaying "rich" text
653−data RichTextConfig t = RichTextConfig
654− { _richTextConfig_attributes :: Behavior t V.Attr
655− }
656
424
657−instance Reflex t => Default (RichTextConfig t) where
425+instance HasImageWriter t m => HasImageWriter t (ReaderT x m)
658− def = RichTextConfig $ pure V.defAttr
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)
659
430
660−-- | A widget that displays text with custom time-varying attributes
431+instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
661−richText
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
662 :: (Reflex t, Monad m)
443 :: (Reflex t, Monad m)
663− => RichTextConfig t
444+ => ImageWriter t m a
664− -> Behavior t Text
445+ -> m (a, Behavior t [Image])
665− -> VtyWidget t m ()
446+runImageWriter = runBehaviorWriterT . unImageWriter
666−richText cfg t = do
447+
667− dw <- displayWidth
448+-- * Theming
668− let img = (\w a s -> [wrapText w a s])
449+
669− <$> current dw
450+-- | A class for things that can be visually styled
670− <*> _richTextConfig_attributes cfg
451+class (Reflex t, Monad m) => HasTheme t m | m -> t where
671− <*> t
452+ theme :: m (Behavior t V.Attr)
672− tellImages img
453+ default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)
673− where
454+ theme = lift theme
674− wrapText maxWidth attrs = V.vertCat
455+ localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
675− . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
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
676− . T.split (=='\n')
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
677
502
678−-- | Renders text, wrapped to the container width
503+instance MFunctor (ThemeReader t) where
679−text
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
680 :: (Reflex t, Monad m)
510 :: (Reflex t, Monad m)
681− => Behavior t Text
511+ => Behavior t V.Attr
682− -> VtyWidget t m ()
512+ -> ThemeReader t m a
683−text = richText def
513+ -> m a
684−
514+runThemeReader b = flip runReaderT b . unThemeReader
685−-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
515+
686−-- that are hidden)
516+
687−scrollableText
517+-- ** Manipulating images
688− :: forall t m. (Reflex t, MonadHold t m, MonadFix m)
518+
689− => Event t Int
519+-- | Translates and crops an 'Image' so that it is contained by
690− -- ^ Number of lines to scroll by
520+-- the given 'Region'.
691− -> Behavior t Text
521+withinImage
692− -> VtyWidget t m (Behavior t (Int, Int))
522+ :: Region
693− -- ^ (Current scroll position, total number of lines)
523+ -> Image
694−scrollableText scrollBy t = do
524+ -> Image
695− dw <- displayWidth
525+withinImage (Region left top width height)
696− let imgs = wrap <$> current dw <*> t
526+ | width < 0 || height < 0 = withinImage (Region left top 0 0)
697− kup <- key V.KUp
527+ | otherwise = V.translate left top . V.crop width height
698− kdown <- key V.KDown
528+
699− m <- mouseScroll
529+-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.
700− let requestedScroll :: Event t Int
530+imagesInRegion
701− requestedScroll = leftmost
531+ :: Reflex t
702− [ 1 <$ kdown
532+ => Behavior t Region
703− , (-1) <$ kup
533+ -> Behavior t [Image]
704− , ffor m $ \case
534+ -> Behavior t [Image]
705− ScrollDirection_Up -> (-1)
535+imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
706− ScrollDirection_Down -> 1
536+
707− , scrollBy
537+-- * Running sub-widgets
708− ]
538+
709− updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
539+-- | Low-level widget combinator that runs a child widget within
710− lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
540+-- a given region and context. This widget filters and modifies the input
711− attach (length <$> imgs) requestedScroll
541+-- that the child widget receives such that:
712− tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
542+-- * unfocused widgets receive no key events
713− return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
543+-- * mouse inputs outside the region are ignored
714− where
544+-- * mouse inputs inside the region have their coordinates translated such
715− wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
545+-- that (0,0) is the top-left corner of the region
546+pane
547+ :: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
548+ => Dynamic t Region
549+ -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
550+ -> m a
551+ -> m a
552+pane dr foc child = localRegion (const dr) $
553+ mapImages (imagesInRegion $ current dr) $
554+ localFocus (const foc) $
555+ inputInFocusedRegion >>= \e -> localInput (const e) child
716
556
717−-- | Renders any behavior whose value can be converted to
557+-- * Misc
718−-- 'String' as text
719−display
720− :: (Reflex t, Monad m, Show a)
721− => Behavior t a
722− -> VtyWidget t m ()
723−display a = text $ T.pack . show <$> a
724
558
725-- | A widget that draws nothing
559-- | A widget that draws nothing
726−blank :: Monad m => VtyWidget t m ()
560+blank :: Monad m => m ()
727blank = return ()
561blank = return ()
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+40−20
@@ -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,10 +34,10 @@ 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)
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− -> VtyWidget t m ()
39+ -> m ()
36− -> VtyWidget t m (Event t ())
40+ -> m (Event t ())
37button cfg child = do
41button cfg child = do
38 f <- focus
42 f <- focus
39 let style = do
43 let style = do
@@ -48,39 +52,44 @@ 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)
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− -> VtyWidget t m (Event t ())
58+ -> m (Event t ())
55textButton cfg = button cfg . text -- TODO Centering etc.
59textButton 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)
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− -> VtyWidget t 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)
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− -> VtyWidget t 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)
86+ :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)
80 => Text
87 => Text
81− -> VtyWidget t 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,32 +116,43 @@ 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
121+ , _checkboxConfig_setValue :: Event t Bool
111 }
122 }
112
123
113instance (Reflex t) => Default (CheckboxConfig t) where
124instance (Reflex t) => Default (CheckboxConfig t) where
114 def = CheckboxConfig
125 def = CheckboxConfig
115 { _checkboxConfig_checkboxStyle = pure def
126 { _checkboxConfig_checkboxStyle = pure def
116 , _checkboxConfig_attributes = pure V.defAttr
127 , _checkboxConfig_attributes = pure V.defAttr
128+ , _checkboxConfig_setValue = never
117 }
129 }
118
130
119-- | A checkbox widget
131-- | A checkbox widget
120checkbox
132checkbox
121− :: (MonadHold t m, MonadFix m, Reflex t)
133+ :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)
122 => CheckboxConfig t
134 => CheckboxConfig t
123 -> Bool
135 -> Bool
124− -> VtyWidget t m (Dynamic t Bool)
136+ -> m (Dynamic t Bool)
125checkbox cfg v0 = do
137checkbox cfg v0 = do
126 md <- mouseDown V.BLeft
138 md <- mouseDown V.BLeft
127 mu <- mouseUp
139 mu <- mouseUp
128− v <- toggle v0 $ () <$ mu
140+ space <- key (V.KChar ' ')
141+ f <- focus
142+ v <- foldDyn ($) v0 $ leftmost
143+ [ not <$ mu
144+ , not <$ space
145+ , const <$> _checkboxConfig_setValue cfg
146+ ]
147+ let bold = V.withStyle mempty V.bold
129 depressed <- hold mempty $ leftmost
148 depressed <- hold mempty $ leftmost
130− [ V.withStyle mempty V.bold <$ md
149+ [ bold <$ md
131 , mempty <$ mu
150 , mempty <$ mu
132 ]
151 ]
152+ let focused = ffor (current f) $ \x -> if x then bold else mempty
133− let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed
153+ let attrs = mconcat <$> sequence [_checkboxConfig_attributes cfg, depressed, focused]
134 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
154 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
135 if checked
155 if checked
136− then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg
156+ then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg
137− else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg
157+ else _checkboxStyle_unchecked <$> _checkboxConfig_checkboxStyle cfg
138 return v
158 return v
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+22−17
@@ -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,14 +43,16 @@ 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)
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− -> VtyWidget t m (TextInput t)
48+ -> m (TextInput t)
49textInput cfg = do
49textInput cfg = do
50 i <- input
50 i <- input
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,9 +90,9 @@ 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)
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− -> VtyWidget t m (TextInput t)
95+ -> m (TextInput t)
87multilineTextInput cfg = do
96multilineTextInput cfg = do
88 i <- input
97 i <- input
89 textInput $ cfg
98 textInput $ cfg
@@ -99,22 +108,18 @@ 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− :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId 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− => VtyWidget t m (TextInput t)
112+ => m (TextInput t)
104 -> Dynamic t Int
113 -> Dynamic t Int
105− -> Layout t m (TextInput t)
114+ -> m (TextInput t)
106textInputTile txt width = do
115textInputTile txt width = do
107 o <- askOrientation
116 o <- askOrientation
108− rec t <- fixed sz txt
117+ rec t <- tile (Constraint_Fixed <$> sz) txt
109 let sz = join $ ffor o $ \case
118 let sz = join $ ffor o $ \case
110 Orientation_Column -> _textInput_lines t
119 Orientation_Column -> _textInput_lines t
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+502−546
@@ -2,94 +2,100 @@
2Module: Reflex.Vty.Widget.Layout
2Module: Reflex.Vty.Widget.Layout
3Description: Monad transformer and tools for arranging widgets and building screen layouts
3Description: Monad transformer and tools for arranging widgets and building screen layouts
4-}
4-}
5−{-# LANGUAGE UndecidableInstances #-}
5+{-# Language UndecidableInstances #-}
6−
6+
7−
8−module Reflex.Vty.Widget.Layout
7+module Reflex.Vty.Widget.Layout where
9− ( Orientation(..)
8+
10− , Constraint(..)
9+import Control.Applicative (liftA2)
11− , Layout
12− , runLayoutL
13− , runLayout
14− , TileConfig(..)
15− , clickable
16− , tile_
17− , tile
18− , fixed
19− , fixedL
20− , stretch
21− , stretchL
22− , col
23− , row
24− , dummyCell
25− , beginLayout
26− , beginLayoutL
27− , layoutFocusEvFromNavigation
28− , tabNavigation
29− , askOrientation
30− , LayoutVtyWidget(..)
31− , LayoutTree
32− , dynLayoutTreeInDynRegion
33− , layoutTreeCellToPosition
34− , IsLayoutVtyWidget(..)
35− , LayoutReturnData(..)
36− ) where
37−
38−
39−import Prelude
40−
41−import Control.Monad.Identity (Identity (..))
10+import Control.Monad.Morph
42−import Control.Monad.NodeId (MonadNodeId (..), NodeId)
11+import Control.Monad.NodeId (MonadNodeId(..), NodeId)
43−import Control.Monad.Reader
12+import Control.Monad.Reader
44−import Data.Bimap (Bimap)
13+import Data.List (mapAccumL)
45−import qualified Data.Bimap as Bimap
46−import Data.Default (Default (..))
47−import qualified Data.Dependent.Map as DMap
14+import Data.Map.Ordered (OMap)
48−import Data.Dependent.Sum (DSum ((:=>)))
49−import Data.Functor
50−import Data.Functor.Misc
51−import Data.Map (Map)
52−import qualified Data.Map as Map
15+import qualified Data.Map.Ordered as OMap
53−import qualified Data.Map.Internal as Map (Map (Bin, Tip))
16+import Data.Maybe (fromMaybe, isNothing)
54−import Data.Maybe (fromMaybe)
55−import Data.Monoid hiding (First (..))
56−import Data.Ratio ((%))
17+import Data.Ratio ((%))
57−import Data.Semigroup (First (..))
18+import Data.Semigroup (First(..))
58−import Data.Traversable (mapAccumL)
19+import Data.Set.Ordered (OSet)
59−import qualified Data.Tree as Tree
20+import qualified Data.Set.Ordered as OSet
60−import qualified Graphics.Vty as V
21+import qualified Graphics.Vty as V
61−
22+
62−import Reflex
23+import Reflex
63−import Reflex.Host.Class (MonadReflexCreateTrigger)
24+import Reflex.Host.Class (MonadReflexCreateTrigger)
64−import Reflex.Vty.Widget
25+import Reflex.Vty.Widget
65−
26+import Reflex.Vty.Widget.Input.Mouse
66−-- | The main-axis orientation of a 'Layout' widget
27+
67−data Orientation = Orientation_Column
28+-- * Focus
68− | Orientation_Row
29+--
30+-- $focus
31+--
32+-- The focus monad tracks which element is currently focused and processes
33+-- requests to change focus. Focusable elements are assigned a 'FocusId' and
34+-- can manually request focus or receive focus due to some other action (e.g.,
35+-- a tab press in a sibling element, a click event).
36+--
37+-- Focusable elements will usually be created via 'tile', but can also be
38+-- constructed via 'makeFocus' in 'HasFocus'. The latter option allows for
39+-- more find-grained control of focus behavior.
40+
41+-- ** Storing focus state
42+
43+-- | Identifies an element that is focusable. Can be created using 'makeFocus'.
44+newtype FocusId = FocusId NodeId
69− deriving (Show, Read, Eq, Ord)
45+ deriving (Eq, Ord)
70−
46+
71−data LayoutSegment = LayoutSegment
47+-- | An ordered set of focus identifiers. The order here determines the order
72− { _layoutSegment_offset :: Int
48+-- in which focus cycles between focusable elements.
73− , _layoutSegment_size :: Int
49+newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }
74− }
50+
75−
51+instance Semigroup FocusSet where
76−data LayoutCtx t = LayoutCtx
52+ FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b
77− { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
53+
78− , _layoutCtx_focusSelfDemux :: Demux t (Maybe NodeId)
54+instance Monoid FocusSet where
79− , _layoutCtx_orientation :: Dynamic t Orientation
55+ mempty = FocusSet OSet.empty
80− , _layoutCtx_focusChildSelector :: EventSelector t (Const2 NodeId (Maybe Int))
56+
57+-- | Produces a 'FocusSet' with a single element
58+singletonFS :: FocusId -> FocusSet
59+singletonFS = FocusSet . OSet.singleton
60+
61+-- ** Changing focus state
62+
63+-- | Operations that change the currently focused element.
64+data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS')
65+ | Refocus_Id FocusId -- ^ Focus a particular element
66+ | Refocus_Clear -- ^ Remove focus from all elements
67+
68+-- | Given a 'FocusSet', a currently focused element, and a number of positions
69+-- to move by, determine the newly focused element.
70+shiftFS :: FocusSet -> Maybe FocusId -> Int -> Maybe FocusId
71+shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
72+ Nothing -> OSet.elemAt s 0
73+ Just Nothing -> OSet.elemAt s 0
74+ Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
75+
76+-- ** The focus management monad
77+
78+-- | A class for things that can produce focusable elements.
79+class (Monad m, Reflex t) => HasFocus t m | m -> t where
80+ -- | Create a focusable element.
81+ makeFocus :: m FocusId
82+ -- | Emit an 'Event' of requests to change the focus.
83+ requestFocus :: Event t Refocus -> m ()
84+ -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused.
85+ isFocused :: FocusId -> m (Dynamic t Bool)
86+ -- | Run an action, additionally returning the focusable elements it produced.
87+ subFoci :: m a -> m (a, Dynamic t FocusSet)
88+ -- | Get a 'Dynamic' of the currently focused element identifier.
89+ focusedId :: m (Dynamic t (Maybe FocusId))
90+
91+-- | A monad transformer that keeps track of the set of focusable elements and
92+-- which, if any, are currently focused, and allows focus requests.
93+newtype Focus t m a = Focus
94+ { unFocus :: DynamicWriterT t FocusSet
95+ (ReaderT (Dynamic t (Maybe FocusId))
96+ (EventWriterT t (First Refocus) m)) a
81 }
97 }
82−
83−
84−-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
85−-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
86−-- switchboard for focus requests. See 'tile_' and 'runLayout'.
87−newtype Layout t m a = Layout
88− { unLayout :: EventWriterT t (First (NodeId, Int))
89− (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint), Dynamic t LayoutTree, Int)])
90− (ReaderT (LayoutCtx t)
91− (VtyWidget t m))) a
92− } deriving
98+ deriving
93 ( Functor
99 ( Functor
94 , Applicative
100 , Applicative
95 , Monad
101 , Monad
@@ -100,494 +106,444 @@ newtype Layout t m a = Layout
100 , PerformEvent t
106 , PerformEvent t
101 , NotReady t
107 , NotReady t
102 , MonadReflexCreateTrigger t
108 , MonadReflexCreateTrigger t
103− , HasDisplaySize t
109+ , HasDisplayRegion t
104− , MonadNodeId
105 , PostBuild t
110 , PostBuild t
111+ , MonadNodeId
112+ , MonadIO
106 )
113 )
107
114
108−instance MonadTrans (Layout t) where
109− lift x = Layout $ lift $ lift $ lift $ lift x
110−
111−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
112− runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
113− traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
114− traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
115− traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
116−
117−findNearestFloor_ :: (Ord k) => k -> (k, a) -> (k, a) -> Map k a -> Maybe (k, a)
118−findNearestFloor_ target leftValue parent Map.Tip = if target < fst leftValue
119− then Nothing -- error $ "Map.findNearestFloorSure: map has no element <= " <> show target
120− else if target < fst parent
121− then Just leftValue
122− else Just parent
123−findNearestFloor_ target leftValue _ (Map.Bin _ k a l r) = if target == k
124− then Just (k, a)
125− else if target < k
126− then findNearestFloor_ target leftValue (k, a) l
127− else findNearestFloor_ target (k, a) (k, a) r
128−
129−findNearestFloor :: (Ord k) => k -> Map k a -> Maybe (k,a)
130−findNearestFloor _ Map.Tip = Nothing
131−-- TODO I don't think we need to do findMin here, just pass in (k,x) as a placeholder value
132−findNearestFloor target m@(Map.Bin _ k x _ _) = findNearestFloor_ target (Map.findMin m) (k, x) m
133−
134−fanFocusEv :: (Reflex t) => Behavior t (Maybe (NodeId, Int)) -> Event t (Maybe (NodeId, Int)) -> EventSelector t (Const2 NodeId (Maybe Int))
135−fanFocusEv focussed focusReqIx = fan $ attachWith attachfn focussed focusReqIx where
136− attachfn mkv0 mkv1 = case mkv1 of
137− Nothing -> case mkv0 of
138− Nothing -> DMap.empty
139− Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing]
140− Just (k1,v1) -> case mkv0 of
141− Nothing -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
142− Just (k0,v0) | k0 == k1 && v0 == v1 -> DMap.empty
143− Just (k0,_) | k0 == k1 -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
144− Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing,
145− Const2 k1 :=> Identity (Just v1)]
146−
147−
148−translateLayoutTree :: (Reflex t) => Orientation -> NodeId -> Dynamic t (Map NodeId LayoutSegment) -> Dynamic t LayoutTree -> Dynamic t LayoutTree
149−translateLayoutTree orient nid solutionMap dlt = ffor2 solutionMap dlt fn where
150− fn sm lt = result where
151− ls = fromMaybe (error "expected result") (Map.lookup nid sm)
152− result = ffor lt $ \reg -> if orient == Orientation_Row
153− then offsetRegion (_layoutSegment_offset ls, 0) reg
154− else offsetRegion (0, _layoutSegment_offset ls) reg
155−
156−-- | Run a 'Layout' action
157−runLayoutL
158− :: forall t m a. (Reflex t, MonadFix m, MonadHold t m)
159− => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
160− -> Maybe Int -- ^ The positional index of the initially focused tile_
161− -> Layout t m a -- ^ The 'Layout' widget
162− -> LayoutVtyWidget t m (LayoutReturnData t a)
163−runLayoutL ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx -> mdo
164− dw <- displayWidth
165− dh <- displayHeight
166− let main = ffor3 ddir dw dh $ \d w h -> case d of
167− Orientation_Column -> h
168− Orientation_Row -> w
169− ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMapDyn focusDemux ddir focusChildSelector
170− let queries = flip appEndo [] <$> queriesEndo
171− solution = ffor2 main queries $ \sz qs -> Map.fromList
172− . Map.elems
173− . computeEdges
174− . computeSizes sz
175− . fmap (\(nodeid,(_,constraint),_,_) -> (nodeid,constraint))
176− . Map.fromList
177− . zip [0::Integer ..]
178− $ qs
179− solutionMapDyn = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
180− { _layoutSegment_offset = offset
181− , _layoutSegment_size = sz
182− }
183−
184−
185− focusableMapAccumFn acc (nid, (_, _), _, nc) = (nextAcc, value) where
186− nextAcc = acc + nc
187− value = (acc, nid)
188− focusable = fmap (Bimap.fromList . snd . mapAccumL focusableMapAccumFn 0) $
189− ffor queries $ \qs -> fforMaybe qs $ \n@(_, (f, _), _, nc) ->
190− if f && nc > 0 then Just n else Nothing
191−
192− -- ix is focus in self index space
193− -- fst of return value is child node id to focus
194− -- snd of return value is focus in child's index space
195− findChildFocus :: Bimap Int NodeId -> Int -> Maybe (NodeId, Int)
196− findChildFocus fm ix = findNearestFloor ix (Bimap.toMap fm) >>= \(ixl, t) -> Just (t, ix-ixl)
197−
198− adjustFocus
199− :: (Bimap Int NodeId)
200− -> Either (Maybe Int) (NodeId, Int) -- left is self index, right is (child id, child index)
201− -> Maybe (Int, (NodeId, Int)) -- fst is self index, snd is (child id, child index)
202− adjustFocus fm (Left (Just ix)) = do
203− x <- findChildFocus fm ix
204− return (ix, x)
205− adjustFocus fm (Left Nothing) = Nothing
206− adjustFocus fm (Right (goto, ixrel)) = do
207− ix <- Bimap.lookupR goto fm
208− return (ix+ixrel, (goto, ixrel))
209−
210− focusChange = attachWith adjustFocus (current focusable)
211− -- TODO handle Nothing case in both places (so that event produces Nothing in this case)
212− $ leftmost [ fmap Right . fmap getFirst $ focusReq, Left <$> focusReqIx]
213−
214− let
215− forestDyn :: Dynamic t [LayoutTree] = join . fmap distributeListOverDyn $ ffor2 queries ddir $ \qs dir -> ffor qs $ \(nid,_,dlt,_) -> translateLayoutTree dir nid solutionMapDyn dlt
216− layoutTreeDyn :: Dynamic t LayoutTree = ffor3 forestDyn dw dh $ \f w h -> Tree.Node (Region 0 0 w h) f
217−
218− fm0 <- sample . current $ focusable
219− -- TODO this is dependent on focusable-ness of children so _layoutReturnData_children should be changed to dynamic...
220− -- TODO consider removing dynamic from focus/constraint instead
221− let totalKiddos = fmap (sum . fmap (\(_,(f, _),_,k) -> if f then k else 0)) queries
222−
223− -- brief explanation of overly complicated focus tracking
224− -- focus is propogated in 2 ways
225− -- focusReq (focus from bottom up)
226− -- focusReqIx (focus from top down)
227− -- focussed tracks the focus state
228− -- focusDemux is used to pass the 'pane's of immediate children
229−
230− -- fst is index we want to focus in self index space, snd is node id we want to focus
231− focussed :: Dynamic t (Maybe (Int, (NodeId, Int))) <- holdDyn initialFocus (focusChange)
232− let
233− initialFocus :: Maybe (Int, (NodeId, Int)) = do
234− f0 <- mfocus0
235− cf0 <- findChildFocus fm0 f0
236− return (f0, cf0)
237−
238− focussedForDemux = fmap (fmap (fst . snd)) focussed
239− focusDemux :: Demux t (Maybe NodeId) = demux focussedForDemux
240−
241− focusReqWithNodeId :: Event t (Maybe (NodeId, Int))
242− focusReqWithNodeId = attachWith (\fm mix -> mix >>= \ix -> findChildFocus fm ix) (current focusable) (focusReqIx)
243− focusChildSelector = fanFocusEv (current $ fmap (fmap snd) focussed) (focusReqWithNodeId)
244−
245− return LayoutReturnData {
246− _layoutReturnData_tree = layoutTreeDyn
247− , _layoutReturnData_focus = (fmap (fmap fst)) focussed
248− , _layoutReturnData_children = totalKiddos
249− , _layoutReturnData_value = a
250− }
251−
252−-- | Run a 'Layout' action
253−runLayout
254− :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, Monad m, MonadNodeId m)
255− => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
256− -> Maybe Int -- ^ The positional index of the initially focused tile_
257− -> Layout t m a -- ^ The 'Layout' widget
258− -> LayoutVtyWidget t m a
259−runLayout ddir mfocus0 layout = fmap _layoutReturnData_value $ runLayoutL ddir mfocus0 layout
260−
261−swap :: (a,b) -> (b,a)
262−swap (a,b) = (b,a)
263−
264−tile_
265− :: forall t b widget m a x. (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
266− => TileConfig t -- ^ The tile_'s configuration
267− -> widget t m (Event t x, b) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
268− -> Layout t m a
269−tile_ (TileConfig con focusable) child = mdo
270− nodeId <- getNextNodeId
271− -- by calling getLayoutTree/getLayoutNumChildren here, we store the children's layout info inside the DynamicWriter
272− -- runLayoutL will extract this info later
273− Layout $ tellDyn $ ffor3 con focusable nKiddosDyn $ \c f n -> Endo ((nodeId, (f, c), getLayoutTree @t @b @a b, n):)
274− seg <- Layout $ asks $
275− fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
276− dw <- displayWidth
277− dh <- displayHeight
278− o <- askOrientation
279− let cross = join $ ffor o $ \case
280− Orientation_Column -> dw
281− Orientation_Row -> dh
282− let reg = DynRegion
283− { _dynRegion_top = ffor2 seg o $ \s -> \case
284− Orientation_Column -> _layoutSegment_offset s
285− Orientation_Row -> 0
286− , _dynRegion_left = ffor2 seg o $ \s -> \case
287− Orientation_Column -> 0
288− Orientation_Row -> _layoutSegment_offset s
289− , _dynRegion_width = ffor3 seg cross o $ \s c -> \case
290− Orientation_Column -> c
291− Orientation_Row -> _layoutSegment_size s
292− , _dynRegion_height = ffor3 seg cross o $ \s c -> \case
293− Orientation_Column -> _layoutSegment_size s
294− Orientation_Row -> c
295− }
296− let nKiddosDyn = getLayoutNumChildren @t @b @a b
297−
298− focusChildSelector <- Layout $ asks _layoutCtx_focusChildSelector
299− let focusChildEv = select focusChildSelector (Const2 nodeId)
300− focussed <- Layout $ asks _layoutCtx_focusSelfDemux
301− (focusReq, b) <- Layout $ lift $ lift $ lift $
302− pane reg (demuxed focussed $ Just nodeId) $ runIsLayoutVtyWidget child (focusChildEv)
303− Layout $ tellEvent $
304− gate (fmap (>0) (current nKiddosDyn))
305− . fmap (First . swap)
306− $ attachPromptlyDyn (fmap (fromMaybe 0) $ getLayoutFocussedDyn @t @b @a b) (nodeId <$ focusReq)
307− return $ getLayoutResult @t b
308−
309−-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
310−-- on its size and ability to grow and on whether it can be focused. It also allows its child
311−-- widget to request focus.
312−tile
313− :: (Reflex t, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
314− => TileConfig t -- ^ The tile's configuration
315− -> widget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
316− -> Layout t m a
317−tile = tile_
318−
319−
320−-- | Configuration options for and constraints on 'tile_'
321−data TileConfig t = TileConfig
322− { _tileConfig_constraint :: Dynamic t Constraint
323− -- ^ 'Constraint' on the tile_'s size
324− , _tile_Config_focusable :: Dynamic t Bool
325− -- ^ Whether the tile_ is focusable
326− }
327−
328−instance Reflex t => Default (TileConfig t) where
329− def = TileConfig (pure $ Constraint_Min 0) (pure True)
330−
331−
332−fixed_
333− :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
334− => Dynamic t Int
335− -> widget t m b
336− -> Layout t m a
337−fixed_ sz = tile_ (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
338−
339−-- | Use this variant to start a sub layout.
340−fixedL
341− :: (Reflex t, MonadFix m, MonadNodeId m)
342− => Dynamic t Int
343− -> LayoutVtyWidget t m (LayoutReturnData t a)
344− -> Layout t m a
345−fixedL = fixed_
346−
347−-- | A 'tile' of a fixed size that is focusable and gains focus on click
348−fixed
349− :: (Reflex t, MonadFix m, MonadNodeId m)
350− => Dynamic t Int
351− -> VtyWidget t m a
352− -> Layout t m a
353−fixed = fixed_
354−
355−stretch_
356− :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
357− => widget t m b
358− -> Layout t m a
359−stretch_ = tile_ def . clickable
360−
361−-- | Use this variant to start a sub layout.
362−stretchL
363− :: (Reflex t, MonadFix m, MonadNodeId m)
364− => LayoutVtyWidget t m (LayoutReturnData t a)
365− -> Layout t m a
366−stretchL = stretch_
367−
368−-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
369−-- This tile is focusable and gains focus on click.
370−stretch
371− :: (Reflex t, MonadFix m, MonadNodeId m)
372− => VtyWidget t m a
373− -> Layout t m a
374−stretch = stretch_
375−
376−-- | A version of 'runLayout' that arranges tiles in a column
377−col
378− :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
379− => Layout t m a
380− -> LayoutVtyWidget t m (LayoutReturnData t a)
381−col child = runLayoutL (pure Orientation_Column) (Nothing) child
382−
383−-- | A version of 'runLayout' that arranges tiles in a row
384−row
385− :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
386− => Layout t m a
387− -> LayoutVtyWidget t m (LayoutReturnData t a)
388−row child = runLayoutL (pure Orientation_Row) (Nothing) child
389−
390−-- | Use to make placeholder empty cells in sub layouts.
391−dummyCell :: (Reflex t, Monad m) => (Reflex t) => LayoutVtyWidget t m (LayoutReturnData t ())
392−dummyCell = return LayoutReturnData {
393− _layoutReturnData_tree = constDyn emptyLayoutTree
394− , _layoutReturnData_focus = constDyn Nothing
395− , _layoutReturnData_children = 0
396− , _layoutReturnData_value = ()
397− }
398
115
399−-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
116+instance MonadTrans (Focus t) where
400−-- and backward one tile when Shift+Tab is pressed.
117+ lift = Focus . lift . lift . lift
118+
119+instance MFunctor (Focus t) where
120+ hoist f = Focus . hoist (hoist (hoist f)) . unFocus
121+
122+instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
123+ runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
124+ traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
125+ traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
126+ traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
127+
128+instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where
129+ localInput f = hoist (localInput f)
130+
131+instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
132+ mapImages f = hoist (mapImages f)
133+
134+instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
135+
136+instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)
137+
138+instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where
139+ makeFocus = do
140+ fid <- FocusId <$> lift getNextNodeId
141+ Focus $ tellDyn $ pure $ singletonFS fid
142+ pure fid
143+ requestFocus = Focus . tellEvent . fmap First
144+ isFocused fid = do
145+ sel <- Focus ask
146+ pure $ (== Just fid) <$> sel
147+ subFoci (Focus child) = Focus $ do
148+ (a, fs) <- lift $ runDynamicWriterT child
149+ tellDyn fs
150+ return (a, fs)
151+ focusedId = Focus ask
152+
153+-- | Runs a 'Focus' action, maintaining the selection state internally.
154+runFocus
155+ :: (MonadFix m, MonadHold t m, Reflex t)
156+ => Focus t m a
157+ -> m (a, Dynamic t FocusSet)
158+runFocus (Focus x) = do
159+ rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x
160+ sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests
161+ pure (a, focusIds)
162+ where
163+ f :: (FocusSet, First Refocus) -> Maybe FocusId -> Maybe FocusId
164+ f (fs, rf) mf = case getFirst rf of
165+ Refocus_Clear -> Nothing
166+ Refocus_Id fid -> Just fid
167+ Refocus_Shift n -> if n < 0 && isNothing mf
168+ then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n
169+ else shiftFS fs mf n
170+
171+-- | Runs an action in the focus monad, providing it with information about
172+-- whether any of the foci created within it are focused.
173+anyChildFocused
174+ :: (HasFocus t m, MonadFix m)
175+ => (Dynamic t Bool -> m a)
176+ -> m a
177+anyChildFocused f = do
178+ fid <- focusedId
179+ rec (a, fs) <- subFoci (f b)
180+ let b = liftA2 (\foc s -> case foc of
181+ Nothing -> False
182+ Just f' -> OSet.member f' $ unFocusSet s) fid fs
183+ pure a
184+
185+-- ** Focus controls
186+
187+-- | Request focus be shifted backward and forward based on tab presses. <Tab>
188+-- shifts focus forward and <Shift+Tab> shifts focus backward.
401−tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
189+tabNavigation :: (Reflex t, HasInput t m, HasFocus t m) => m ()
402tabNavigation = do
190tabNavigation = do
403 fwd <- fmap (const 1) <$> key (V.KChar '\t')
191 fwd <- fmap (const 1) <$> key (V.KChar '\t')
404 back <- fmap (const (-1)) <$> key V.KBackTab
192 back <- fmap (const (-1)) <$> key V.KBackTab
405− return $ leftmost [fwd, back]
193+ requestFocus $ Refocus_Shift <$> leftmost [fwd, back]
406−
194+
407−-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
195+-- * Layout
408−-- requesting focus when using 'tile'.
196+--
409−clickable
197+-- $layout
410− :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m)
198+-- The layout monad keeps track of a tree of elements, each having its own
411− => widget t m a
199+-- layout constraints and orientation. Given the available rendering space, it
412− -> LayoutVtyWidget t m (Event t (), a)
200+-- computes a layout solution and provides child elements with their particular
413−clickable child = LayoutVtyWidget . ReaderT $ \focusEv -> do
201+-- layout solution (the width and height of their rendering space).
414− click <- mouseDown V.BLeft
202+--
415− a <- runIsLayoutVtyWidget child focusEv
203+-- Complex layouts are built up though some combination of:
416− return (() <$ click, a)
204+--
417−
205+-- - 'axis', which lays out its children in a particular orientation, and
418−-- | create a focus event (to be used with runIsLayoutVtyWidget) from a navigation event
206+-- - 'region', which "claims" some part of the screen according to its constraints
419−layoutFocusEvFromNavigation
207+--
420− :: (Reflex t)
208+
421− => Event t Int
209+-- ** Layout restrictions
422− -> Event t ()
210+
423− -> LayoutReturnData t a
211+-- *** Constraints
424− -> Event t (Maybe Int)
425−layoutFocusEvFromNavigation navEv unfocusEv LayoutReturnData {..} = r where
426− fmapfn (nKiddos, (mcur, shift)) = maybe (Just 0) (\cur -> Just $ (shift + cur) `mod` nKiddos) mcur
427− navEv' = attach (current _layoutReturnData_children) $ attach (current _layoutReturnData_focus) navEv
428− r = leftmost [unfocusEv $> Nothing, fmap fmapfn navEv']
429−
430−-- TODO look into making a variant of this function that takes a navigation event
431−-- | Use this variant to begin a layout if you need its "LayoutReturnData"
432−beginLayoutL
433− :: (Reflex t, MonadHold t m, MonadFix m)
434− => LayoutVtyWidget t m (LayoutReturnData t a)
435− -> VtyWidget t m (LayoutReturnData t a)
436−beginLayoutL child = mdo
437− -- TODO consider unfocusing if this loses focus
438− --focussed <- focus
439− tabEv <- tabNavigation
440− let
441− focusChildEv = layoutFocusEvFromNavigation tabEv never lrd
442− lrd <- runIsLayoutVtyWidget child focusChildEv
443− return lrd
444−
445−-- | Begin a layout using tab and shift-tab to navigate
446−beginLayout
447− :: (Reflex t, MonadHold t m, MonadFix m)
448− => LayoutVtyWidget t m (LayoutReturnData t a)
449− -> VtyWidget t m a
450−beginLayout = fmap _layoutReturnData_value . beginLayoutL
451−
452−
453−{- something like this
454−beginLayoutL
455− :: (Reflex t, MonadHold t m, MonadFix m)
456− => LayoutVtyWidget t m (LayoutReturnData t a)
457− -> Maybe (Event t Int)
458− -> VtyWidget t m (LayoutReturnData t a)
459−beginLayoutL mNavEv child = mdo
460− -- TODO consider unfocusing if this loses focus
461− --focussed <- focus
462− let
463− focusChildEv = case mNavEv of
464− Just navEv -> layoutFocusEvFromNavigation navEv never lrd
465− Nothing -> never
466− lrd <- runIsLayoutVtyWidget child focusChildEv
467− return lrd
468−-}
469−
470−
471−-- | Retrieve the current orientation of a 'Layout'
472−askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
473−askOrientation = Layout $ asks _layoutCtx_orientation
474
212
475-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
213-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
476data Constraint = Constraint_Fixed Int
214data Constraint = Constraint_Fixed Int
477 | Constraint_Min Int
215 | Constraint_Min Int
478 deriving (Show, Read, Eq, Ord)
216 deriving (Show, Read, Eq, Ord)
479
217
480−-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
218+-- | Shorthand for constructing a fixed constraint
481−computeSizes
219+fixed
482− :: Int
220+ :: Reflex t
483− -> Map k (a, Constraint)
221+ => Dynamic t Int
484− -> Map k (a, Int)
222+ -> Dynamic t Constraint
485−computeSizes available constraints =
223+fixed = fmap Constraint_Fixed
486− let minTotal = sum $ ffor (Map.elems constraints) $ \case
487− (_, Constraint_Fixed n) -> n
488− (_, Constraint_Min n) -> n
489− leftover = max 0 (available - minTotal)
490− numStretch = Map.size $ Map.filter (isMin . snd) constraints
491− szStretch = floor $ leftover % (max numStretch 1)
492− adjustment = max 0 $ available - minTotal - szStretch * numStretch
493− in snd $ Map.mapAccum (\adj (a, c) -> case c of
494− Constraint_Fixed n -> (adj, (a, n))
495− Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
496− where
497− isMin (Constraint_Min _) = True
498− isMin _ = False
499−
500−computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
501−computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
502− (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
503−
504
224
225+-- | Shorthand for constructing a minimum size constraint
226+stretch
227+ :: Reflex t
228+ => Dynamic t Int
229+ -> Dynamic t Constraint
230+stretch = fmap Constraint_Min
505
231
506−offsetRegion :: (Int, Int) -> Region -> Region
232+-- | Shorthand for constructing a constraint of no minimum size
507−offsetRegion (x,y) reg = reg {
233+flex
508− _region_left = x+x'
234+ :: Reflex t
509− , _region_top = y+y'
235+ => Dynamic t Constraint
510− } where
236+flex = pure $ Constraint_Min 0
511− x' = _region_left reg
512− y' = _region_top reg
513
237
514−-- | Dynamic sizing information on a layout hierarchy (intended for testing)
238+-- *** Orientation
515−type LayoutTree = Tree.Tree Region
516
239
517−emptyLayoutTree :: LayoutTree
240+-- | The main-axis orientation of a 'Layout' widget
518−emptyLayoutTree = Tree.Node (Region 0 0 0 0) []
241+data Orientation = Orientation_Column
242+ | Orientation_Row
243+ deriving (Show, Read, Eq, Ord)
519
244
520−dynLayoutTreeInDynRegion :: (Reflex t) => DynRegion t -> Dynamic t LayoutTree -> Dynamic t LayoutTree
245+-- | Create a row-oriented 'axis'
521−dynLayoutTreeInDynRegion DynRegion {..} dlt = ffor3 _dynRegion_left _dynRegion_top dlt $ \x y lt -> fmap (offsetRegion (x,y)) lt
246+row
247+ :: (Reflex t, MonadFix m, HasLayout t m)
248+ => m a
249+ -> m a
250+row = axis (pure Orientation_Row) flex
522
251
523−infix 9 !!?
252+-- | Create a column-oriented 'axis'
524−(!!?) :: [a] -> Int -> Maybe a
253+col
525−(!!?) xs i
254+ :: (Reflex t, MonadFix m, HasLayout t m)
526− | i < 0 = Nothing
255+ => m a
527− | otherwise = go i xs
256+ -> m a
257+col = axis (pure Orientation_Column) flex
258+
259+-- ** Layout management data
260+
261+-- | A collection of information related to the layout of the screen. The root
262+-- node is a "parent" widget, and the contents of the 'LayoutForest' are its
263+-- children.
264+data LayoutTree a = LayoutTree a (LayoutForest a)
265+ deriving (Show)
266+
267+-- | An ordered, indexed collection of 'LayoutTree's representing information
268+-- about the children of some widget.
269+newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }
270+ deriving (Show)
271+
272+instance Semigroup (LayoutForest a) where
273+ LayoutForest a <> LayoutForest b = LayoutForest $ a OMap.|<> b
274+
275+instance Monoid (LayoutForest a) where
276+ mempty = LayoutForest OMap.empty
277+
278+-- | Perform a lookup by 'NodeId' in a 'LayoutForest'
279+lookupLF :: NodeId -> LayoutForest a -> Maybe (LayoutTree a)
280+lookupLF n (LayoutForest a) = OMap.lookup n a
281+
282+-- | Create a 'LayoutForest' with one element
283+singletonLF :: NodeId -> LayoutTree a -> LayoutForest a
284+singletonLF n t = LayoutForest $ OMap.singleton (n, t)
285+
286+-- | Produce a 'LayoutForest' from a list. The order of the list is preserved.
287+fromListLF :: [(NodeId, LayoutTree a)] -> LayoutForest a
288+fromListLF = LayoutForest . OMap.fromList
289+
290+-- | Extract the information at the root of a 'LayoutTree'
291+rootLT :: LayoutTree a -> a
292+rootLT (LayoutTree a _) = a
293+
294+-- | Extract the child nodes of a 'LayoutTree'
295+childrenLT :: LayoutTree a -> LayoutForest a
296+childrenLT (LayoutTree _ a) = a
297+
298+-- | Produce a layout solution given a starting orientation, the overall screen
299+-- size, and a set of constraints.
300+solve
301+ :: Orientation
302+ -> Region
303+ -> LayoutForest (Constraint, Orientation)
304+ -> LayoutTree (Region, Orientation)
305+solve o0 r0 (LayoutForest cs) =
306+ let a = map (\(x, t@(LayoutTree (c, _) _)) -> ((x, t), c)) $ OMap.assocs cs
307+ extent = case o0 of
308+ Orientation_Row -> _region_width r0
309+ Orientation_Column -> _region_height r0
310+ sizes = computeEdges $ computeSizes extent a
311+ chunks = [ (nodeId, solve o1 r1 f)
312+ | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes
313+ , let r1 = chunk o0 r0 sz
314+ ]
315+ in LayoutTree (r0, o0) $ fromListLF chunks
528 where
316 where
529− go :: Int -> [a] -> Maybe a
317+ computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
530− go 0 (x:_) = Just x
318+ computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
531− go j (_:ys) = go (j - 1) ys
319+ (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
532− go _ [] = Nothing
320+ computeSizes
533−{-# INLINE (!!?) #-}
321+ :: Int
534−
322+ -> [(a, Constraint)]
535−-- | gives top left corner of the cell following directions
323+ -> [(a, Int)]
536−layoutTreeCellToPosition :: [Int] -> LayoutTree -> Maybe (Int, Int)
324+ computeSizes available constraints =
537−layoutTreeCellToPosition [] (Tree.Node region _) = Just (_region_left region, _region_top region)
325+ -- The minimum amount of space we need. Calculated by adding up all of
538−layoutTreeCellToPosition (x:xs) (Tree.Node _ kiddos) = kiddos !!? x >>= layoutTreeCellToPosition xs
326+ -- the fixed size items and all the minimum sizes of stretchable items
539−
327+ let minTotal = sum $ ffor constraints $ \case
540−class IsLayoutReturn t b a where
328+ (_, Constraint_Fixed n) -> n
541− getLayoutResult :: b -> a
329+ (_, Constraint_Min n) -> n
542− getLayoutNumChildren :: b -> Dynamic t Int
330+ -- The leftover space is the area we can allow stretchable items to
543− getLayoutFocussedDyn :: b -> Dynamic t (Maybe Int)
331+ -- expand into
544− getLayoutTree :: b -> Dynamic t LayoutTree
332+ leftover = max 0 (available - minTotal)
545−
333+ -- The number of stretchable items that will try to share some of the
546−data LayoutReturnData t a = LayoutReturnData {
334+ -- leftover space
547− _layoutReturnData_tree :: Dynamic t LayoutTree
335+ numStretch = length $ filter (isMin . snd) constraints
548− , _layoutReturnData_focus :: Dynamic t (Maybe Int)
336+ -- Space to allocate to the stretchable items (this is the same for all
549− , _layoutReturnData_children :: Dynamic t Int
337+ -- items and there may still be additional leftover space that will have
550− , _layoutReturnData_value :: a
338+ -- to be unevenly distributed)
551− }
339+ szStretch = floor $ leftover % max numStretch 1
552−
340+ -- Remainder of available space after even distribution. This extra space
553−instance IsLayoutReturn t (LayoutReturnData t a) a where
341+ -- will be distributed to as many stretchable widgets as possible.
554− getLayoutResult lrd = _layoutReturnData_value lrd
342+ adjustment = max 0 $ available - minTotal - szStretch * numStretch
555− getLayoutNumChildren lrd = _layoutReturnData_children lrd
343+ in snd $ mapAccumL (\adj (a, c) -> case c of
556− getLayoutFocussedDyn lrd = _layoutReturnData_focus lrd
344+ Constraint_Fixed n -> (adj, (a, n))
557− getLayoutTree lrd = _layoutReturnData_tree lrd
345+ Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints
558−
346+ isMin (Constraint_Min _) = True
559−instance Reflex t => IsLayoutReturn t a a where
347+ isMin _ = False
560− getLayoutResult = id
348+
561− getLayoutNumChildren _ = 1
349+-- | Produce a 'Region' given a starting orientation and region, and the offset
562− getLayoutFocussedDyn _ = constDyn Nothing
350+-- and main-axis size of the chunk.
563− getLayoutTree _ = constDyn emptyLayoutTree
351+chunk :: Orientation -> Region -> (Int, Int) -> Region
564−
352+chunk o r (offset, sz) = case o of
565−class IsLayoutVtyWidget l t m where
353+ Orientation_Column -> r
566− runIsLayoutVtyWidget :: l t m a -> Event t (Maybe Int) -> VtyWidget t m a
354+ { _region_top = _region_top r + offset
355+ , _region_height = sz
356+ }
357+ Orientation_Row -> r
358+ { _region_left = _region_left r + offset
359+ , _region_width = sz
360+ }
567
361
568−newtype LayoutVtyWidget t m a = LayoutVtyWidget {
362+-- ** The layout monad
569− unLayoutVtyWidget :: ReaderT (Event t (Maybe Int)) (VtyWidget t m) a
363+
364+-- | A class of operations for creating screen layouts.
365+class Monad m => HasLayout t m | m -> t where
366+ -- | Starts a parent element in the current layout with the given size
367+ -- constraint, which lays out its children according to the provided
368+ -- orientation.
369+ axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
370+ -- | Creates a child element in the current layout with the given size
371+ -- constraint, returning the 'Region' that the child element is allocated.
372+ region :: Dynamic t Constraint -> m (Dynamic t Region)
373+ -- | Returns the orientation of the containing 'axis'.
374+ askOrientation :: m (Dynamic t Orientation)
375+
376+-- | A monad transformer that collects layout constraints and provides a layout
377+-- solution that satisfies those constraints.
378+newtype Layout t m a = Layout
379+ { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))
380+ (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a
381+ }
570− } deriving
382+ deriving
571 ( Functor
383 ( Functor
572 , Applicative
384 , Applicative
385+ , HasDisplayRegion t
573 , Monad
386 , Monad
387+ , MonadFix
574 , MonadHold t
388 , MonadHold t
389+ , MonadIO
390+ , MonadNodeId
391+ , MonadReflexCreateTrigger t
575 , MonadSample t
392 , MonadSample t
576− , MonadFix
577− , TriggerEvent t
578− , PerformEvent t
579 , NotReady t
393 , NotReady t
580− , MonadReflexCreateTrigger t
394+ , PerformEvent t
581− , HasDisplaySize t
582− , MonadNodeId
583 , PostBuild t
395 , PostBuild t
396+ , TriggerEvent t
584 )
397 )
585
398
586−instance MonadTrans (LayoutVtyWidget t) where
399+instance MonadTrans (Layout t) where
587− lift x = LayoutVtyWidget $ lift $ lift x
400+ lift = Layout . lift . lift
401+
402+instance MFunctor (Layout t) where
403+ hoist f = Layout . hoist (hoist f) . unLayout
588
404
589−instance IsLayoutVtyWidget VtyWidget t m where
405+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
590− runIsLayoutVtyWidget w _ = w
406+ runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
407+ traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
408+ traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
409+ traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
591
410
592−instance IsLayoutVtyWidget LayoutVtyWidget t m where
411+-- | Apply a transformation to the context of a child 'Layout' action and run
593− runIsLayoutVtyWidget = runReaderT . unLayoutVtyWidget
412+-- that action
413+hoistRunLayout
414+ :: (HasDisplayRegion t m, MonadFix m, Monad n)
415+ => (m a -> n b)
416+ -> Layout t m a
417+ -> Layout t n b
418+hoistRunLayout f x = do
419+ solution <- Layout ask
420+ let orientation = snd . rootLT <$> solution
421+ lift $ f $ do
422+ dw <- displayWidth
423+ dh <- displayHeight
424+ let reg = Region 0 0 <$> dw <*> dh
425+ runLayout orientation reg x
426+
427+instance (HasInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasInput t (Layout t m) where
428+ localInput = hoistRunLayout . localInput
429+
430+instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where
431+ mapImages f = hoistRunLayout (mapImages f)
432+
433+instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)
434+
435+instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)
436+
437+instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where
438+ axis o c (Layout x) = Layout $ do
439+ nodeId <- getNextNodeId
440+ let dummyParentLayout = LayoutTree (nilRegion, Orientation_Column) mempty
441+ (result, forest) <- lift $ local (\t -> fromMaybe dummyParentLayout . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x
442+ tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)
443+ pure result
444+ region c = do
445+ nodeId <- lift getNextNodeId
446+ Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty
447+ solutions <- Layout ask
448+ pure $ maybe nilRegion (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions
449+ askOrientation = Layout $ asks $ fmap (snd . rootLT)
450+
451+instance (MonadFix m, HasFocus t m) => HasFocus t (Layout t m) where
452+ makeFocus = lift makeFocus
453+ requestFocus = lift . requestFocus
454+ isFocused = lift . isFocused
455+ focusedId = lift focusedId
456+ subFoci (Layout x) = Layout $ do
457+ y <- ask
458+ ((a, w), sf) <- lift $ lift $ subFoci $ flip runReaderT y $ runDynamicWriterT x
459+ tellDyn w
460+ pure (a, sf)
461+
462+-- | Runs a 'Layout' action, using the given orientation and region to
463+-- calculate layout solutions.
464+runLayout
465+ :: (MonadFix m, Reflex t)
466+ => Dynamic t Orientation
467+ -> Dynamic t Region
468+ -> Layout t m a
469+ -> m a
470+runLayout o r (Layout x) = do
471+ rec (result, w) <- runReaderT (runDynamicWriterT x) solutions
472+ let solutions = solve <$> o <*> r <*> w
473+ return result
474+
475+-- | Initialize and run the layout monad, using all of the available screen space.
476+initLayout :: (HasDisplayRegion t m, MonadFix m) => Layout t m a -> m a
477+initLayout f = do
478+ dw <- displayWidth
479+ dh <- displayHeight
480+ let r = Region 0 0 <$> dw <*> dh
481+ runLayout (pure Orientation_Column) r f
482+
483+-- * The tile "window manager"
484+--
485+-- $tiling
486+-- Generally HasLayout and HasFocus are used together to build a user
487+-- interface. These functions check the available screen size and initialize
488+-- the layout monad with that information, and also initialize the focus monad.
489+
490+-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.
491+initManager
492+ :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
493+ => Layout t (Focus t m) a
494+ -> m (a, Dynamic t FocusSet)
495+initManager =
496+ runFocus . initLayout
497+
498+-- | Initialize a 'Layout' and 'Focus' management context.
499+initManager_
500+ :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
501+ => Layout t (Focus t m) a
502+ -> m a
503+initManager_ = fmap fst . initManager
504+
505+-- ** Layout tiles
506+
507+-- *** Focusable
508+
509+-- | A widget that is focusable and occupies a layout region based on the
510+-- provided constraint. Returns the 'FocusId' allowing for manual focus
511+-- management.
512+tile'
513+ :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
514+ => Dynamic t Constraint
515+ -> m a
516+ -> m (FocusId, a)
517+tile' c w = do
518+ fid <- makeFocus
519+ r <- region c
520+ parentFocused <- isFocused fid
521+ rec (click, result, childFocused) <- pane r focused $ anyChildFocused $ \childFoc -> do
522+ m <- mouseDown V.BLeft
523+ x <- w
524+ pure (m, x, childFoc)
525+ let focused = (||) <$> parentFocused <*> childFocused
526+ requestFocus $ Refocus_Id fid <$ click
527+ pure (fid, result)
528+
529+-- | A widget that is focusable and occupies a layout region based on the
530+-- provided constraint.
531+tile
532+ :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
533+ => Dynamic t Constraint
534+ -> m a
535+ -> m a
536+tile c = fmap snd . tile' c
537+
538+-- *** Unfocusable
539+
540+-- | A widget that is not focusable and occupies a layout region based on the
541+-- provided constraint.
542+grout
543+ :: (Reflex t, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
544+ => Dynamic t Constraint
545+ -> m a
546+ -> m a
547+grout c w = do
548+ r <- region c
549+ pane r (pure True) w
src/Reflex/Vty/Widget/Split.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