on eb0e499 help sign in
.github/workflows/haskell.yml+10−12
since splitsnapshots
unifiedsplit
@@ -1,33 +1,33 @@
1−name: github-action
1+name: Haskell CI
2
2
3on: [push, pull_request]
3on: [push, pull_request]
4
4
5jobs:
5jobs:
6 build:
6 build:
7+
8+ runs-on: ${{ matrix.os }}
7 strategy:
9 strategy:
8 matrix:
10 matrix:
9− ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
11+ ghc: ['8.4.4', '8.6.5', '8.8.4']
10 os: ['ubuntu-latest', 'macos-latest']
12 os: ['ubuntu-latest', 'macos-latest']
11− runs-on: ${{ matrix.os }}
12−
13− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
14 steps:
13 steps:
15 - uses: actions/checkout@v2
14 - uses: actions/checkout@v2
16 - uses: actions/setup-haskell@v1
15 - uses: actions/setup-haskell@v1
17 with:
16 with:
18 ghc-version: ${{ matrix.ghc }}
17 ghc-version: ${{ matrix.ghc }}
18+ cabal-version: '3.0'
19+
19 - name: Cache
20 - name: Cache
20 uses: actions/cache@v1
21 uses: actions/cache@v1
21 env:
22 env:
22 cache-name: cache-cabal
23 cache-name: cache-cabal
23 with:
24 with:
24 path: ~/.cabal
25 path: ~/.cabal
25− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
26+ key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
26 restore-keys: |
27 restore-keys: |
27− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
28+ ${{ runner.os }}-build-${{ env.cache-name }}-
28− ${{ runner.os }}-${{ matrix.ghc }}-build-
29+ ${{ runner.os }}-build-
29− ${{ runner.os }}-${{ matrix.ghc }}-
30+ ${{ runner.os }}-
30− ${{ runner.os }}
31
31
32 - name: Install dependencies
32 - name: Install dependencies
33 run: |
33 run: |
@@ -37,5 +37,3 @@ 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.ymlnew file+112
@@ -0,0 +1,112 @@
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+3−91
@@ -1,96 +1,8 @@
1# Revision history for reflex-vty
1# Revision history for reflex-vty
2
2
3−## 0.2.0.0
3+## Unreleased
4−
5−* _Module Reorganization_: The following modules have been added (and are all re-exported by Reflex.Vty):
6− * Reflex.Vty.Widget.Box for all the box functions and datatypes
7− * Reflex.Vty.Widget.Input.Mouse for clicking, dragging, and scrolling
8− * Reflex.Vty.Widget.Split contains `splitV`, `splitH`, etc
9− * Reflex.Vty.Widget.Text contains text rendering functions like `text` and `display`
10−* _Bugfixes_:
11− * Remove text-icu dependency and switch to `wcwidth` from vty package to compute character width in `Data.Text.Zipper`.
4+* Remove text-icu dependency and switch to `wcwidth` from vty package to compute character width in `Data.Text.Zipper`.
12− * `goToDisplayLinePosition` in `Data.Text.Zipper` correctly accounts for character width now.
5+* `goToDisplayLinePosition` in `Data.Text.Zipper` correctly accounts for character width now.
13− * [#37](https://github.com/reflex-frp/reflex-vty/issues/37) `Layout` should support focus changes through nested layouts (thanks @pdlla for getting this started -- see entry on Layout and Focus below).
14− * Fix distribution of available space when it cannot be evenly distributed. Previously, all leftover space would be allocated to the first stretchable widget.
15−* _Breaking Changes_:
16− * Layout and focus have been substantially refactored to fix [#37](https://github.com/reflex-frp/reflex-vty/issues/37) and support a wider variety of layouts and focus switching requirements.
17− * Added a new `HasFocus` class (the old one is now `HasFocusReader`) to produce focusable elements, and manage focus state. See the "Focus" section of the Reflex.Vty.Widget.Layout module documentation.
18− * `Layout` no longer has any focus-tracking responsibility. See the "Layout" section of the Reflex.Vty.Widget.Layout module documentation.
19− * `tile` no longer takes a configuration record and no longer requires that its child widget return a focus request event. Focus requests are instead handled using calls to `requestFocus` in the child widget.
20− * Calls to `fixed` and `stretch` must now be replaced with `tile . fixed` and `tile . stretch`
21− * `stretch` now takes a minimum size argument
22− * Added `flex` which is equivalent to `stretch 0`
23− * `tabNavigation` no longer returns an `Event`. Instead it calls `requestFocus` directly with the appropriate `Refocus_Shift` value.
24− * Added `axis` (in `HasLayout`), a lower-level primitive which is used to implement `row` and `col`.
25− * Added `region` (in `HasLayout`), which is used to claim screen real estate and used to implement `tile` and `grout`
26− * Added `grout`, a container element that is not itself focusable (though its children can be)
27− * Removed `VtyWidget` and replaced it with a number of separate classes and monad transformers
28− * Replace `HasDisplaySize` with `HasDisplayRegion` which carries around a region instead of just a width and height. `displayWidth` and `displayHeight` are now functions implemented in terms of `askRegion` instead of class methods.
29− * Add a `DisplayRegion` monad transformer
30− * Rename `ImageWriter` to `HasImageWriter`
31− * Introduce an `ImageWriter` monad transformer
32− * Rename `HasFocus` to `HasFocusReader`
33− * Introduce a `FocusReader` monad transformer
34− * Replace `HasVtyInput` with `HasInput`
35− * Introduce an `Input` monad transformer
36− * Introduce `HasTheme` reader class to allow setting Vty attributes of all built-in widgets
37− * Introduce `ThemeReader` monad transformer
38− * Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.
39− * `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.
40− * `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.
41− * `HasInput` (formerly `HasVtyInput`) now has a method `localInput` for filtering the input a child widget may receive
42− * `HasImageWriter` now has a method `mapImages` for transforming the images emitted by a child widget
43− * `boxTitle` now takes a `Behavior t Text` as its title, instead of a plain `Text`
44− * `fill` now takes a `Behavior t Char` instead of a `Char`
45− * The following functions are no longer specialized to `VtyWidget`:
46− * `pane`: Now requires `HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m`
47− * `drag`: Now requires `HasInput`
48− * `mouseDown`: Now requires `HasInput`
49− * `mouseUp`: Now requires `HasInput`
50− * `mouseScroll`: Now requires `HasInput`
51− * `key`: Now requires `HasInput`
52− * `keys`: Now requires `HasInput`
53− * `keyCombo`: Now requires `HasInput`
54− * `keyCombos`: Now requires `HasInput`
55− * `splitV`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
56− * `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
57− * `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
58− * `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`
59− * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
60− * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
61− * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
62− * `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`
63− * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
64− * `blank`: Now requires `Monad`
65− * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
66− * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
67− * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
68− * `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
69− * `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
70− * TextZipper interface changes
71− * `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`
72− * `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position
73− * some exposed methods intended for internal use only have been removed
74− * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
75− * `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
76− * `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, `HasTheme`, and `HasFocus`
77−* _Misc_:
78− * (#40 Add alignment support to TextZipper)[https://github.com/reflex-frp/reflex-vty/pull/40]
79− * Add alignment (left/center/right) support to TextZipper
80− * Add basic unit tests for newly created alignment methods in TextZipper
81− * Add default instances for `HasInput`, `HasFocus`, and `HasImageWriter`
82− * Export `withinImage` and add `imagesInRegion` to crop images to a region
83− * Add `anyChildFocused`, which provides information about whether subwidgets are focused
84− * Add `filterKeys`, which is the same as `localInput` but only cares about keyboard events
85− * Add `hoistRunLayout` to apply a transformation to the context of a `Layout` action and run that action
86− * Add various `MFunctor` instances
87− * Add a CPU usage indicator to the example executable
88−
89−## 0.1.4.2
90−
91−* Wider bounds for GHC 8.10 support
92−
93−## 0.1.4.1
94
6
95## 0.1.4.1
7## 0.1.4.1
96* Migrate to new dependent-sum / dependent-map (after the "some" package split)
8* Migrate to new dependent-sum / dependent-map (after the "some" package split)
reflex-vty.cabal+10−63
@@ -1,5 +1,5 @@
1name: reflex-vty
1name: reflex-vty
2−version: 0.2.0.0
2+version: 0.1.4.1
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,35 +12,27 @@ 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:
20+tested-with: GHC ==8.8.4 || ==8.6.5 || ==8.4.4
21− GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
22−
23−source-repository head
24− type: git
25− location: https://github.com/reflex-frp/reflex-vty
26
21
27library
22library
28 exposed-modules: Reflex.Vty
23 exposed-modules: Reflex.Vty
29 , Reflex.Vty.Host
24 , Reflex.Vty.Host
30 , Reflex.Vty.Widget
25 , Reflex.Vty.Widget
31− , Reflex.Vty.Widget.Box
32 , Reflex.Vty.Widget.Input
26 , Reflex.Vty.Widget.Input
33− , Reflex.Vty.Widget.Input.Mouse
34 , Reflex.Vty.Widget.Input.Text
27 , Reflex.Vty.Widget.Input.Text
35 , Reflex.Vty.Widget.Layout
28 , Reflex.Vty.Widget.Layout
36− , Reflex.Vty.Widget.Split
37− , Reflex.Vty.Widget.Text
38 , Data.Text.Zipper
29 , Data.Text.Zipper
30+ , Reflex.Class.Switchable
39 , Reflex.Spider.Orphans
31 , Reflex.Spider.Orphans
40 , Control.Monad.NodeId
32 , Control.Monad.NodeId
41 build-depends:
33 build-depends:
42− base >= 4.10.0 && < 4.15,
34+ base >= 4.10.0 && < 4.14,
43− bimap >= 0.3.3 && < 0.5,
35+ bimap >= 0.3.3 && < 0.4,
44 containers >= 0.5.0 && < 0.7,
36 containers >= 0.5.0 && < 0.7,
45 mtl >= 2.2.2 && < 2.3,
37 mtl >= 2.2.2 && < 2.3,
46 transformers >= 0.5.5 && < 0.6,
38 transformers >= 0.5.5 && < 0.6,
@@ -50,8 +42,6 @@ library
50 text >= 1.2.3 && < 1.3,
42 text >= 1.2.3 && < 1.3,
51 dependent-sum >= 0.7 && < 0.8,
43 dependent-sum >= 0.7 && < 0.8,
52 exception-transformers >= 0.4.0 && < 0.5,
44 exception-transformers >= 0.4.0 && < 0.5,
53− mmorph >= 1.1 && < 1.2,
54− ordered-containers >= 0.2.2 && < 0.3,
55 primitive >= 0.6.3 && < 0.8,
45 primitive >= 0.6.3 && < 0.8,
56 ref-tf >= 0.4.0 && < 0.5,
46 ref-tf >= 0.4.0 && < 0.5,
57 reflex >= 0.8 && < 0.9,
47 reflex >= 0.8 && < 0.9,
@@ -90,6 +80,7 @@ library
90 TypeApplications
80 TypeApplications
91 TypeFamilies
81 TypeFamilies
92
82
83+
93executable example
84executable example
94 hs-source-dirs: src-bin
85 hs-source-dirs: src-bin
95 main-is: example.hs
86 main-is: example.hs
@@ -104,51 +95,7 @@ executable example
104 transformers,
95 transformers,
105 vty
96 vty
106 default-language: Haskell2010
97 default-language: Haskell2010
107− other-modules: Example.CPU
108− default-extensions:
109− BangPatterns
110− ConstraintKinds
111− CPP
112− DataKinds
113− DefaultSignatures
114− DeriveFunctor
115− DeriveGeneric
116− FlexibleContexts
117− FlexibleInstances
118− FunctionalDependencies
119− GADTs
120− GeneralizedNewtypeDeriving
121− KindSignatures
122− LambdaCase
123− MultiParamTypeClasses
124− MultiWayIf
125− OverloadedStrings
126− PatternGuards
127− PolyKinds
128− QuasiQuotes
129− RankNTypes
130− RecursiveDo
131− ScopedTypeVariables
132− StandaloneDeriving
133− TemplateHaskell
134− TupleSections
135− TypeApplications
136− TypeFamilies
137
98
138−
99+source-repository head
139−test-suite reflex-vty-test
100+ type: git
140− hs-source-dirs: test
101+ location: https://github.com/reflex-frp/reflex-vty
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.hsdeleted−231
@@ -1,231 +0,0 @@
1−{-|
2− Description: A CPU usage indicator
3−-}
4−module Example.CPU where
5−
6−import Control.Exception
7−import Control.Monad.Fix
8−import Control.Monad.IO.Class
9−import Data.Ratio
10−import Data.Time
11−import Data.Word
12−import qualified Data.Text as T
13−import qualified Graphics.Vty as V
14−import Text.Printf
15−
16−import Reflex
17−import Reflex.Vty
18−
19−-- | Each constructor represents a cpu statistic column as presented in @/proc/stat@
20−data CpuStat
21− = CpuStat_User
22− | CpuStat_Nice
23− | CpuStat_System
24− | CpuStat_Idle
25− | CpuStat_Iowait
26− | CpuStat_Irq
27− | CpuStat_Softirq
28− | CpuStat_Steal
29− | CpuStat_Guest
30− | CpuStat_GuestNice
31− deriving (Show, Read, Eq, Ord, Enum, Bounded)
32−
33−-- | Read @/proc/stat@
34−getCpuStat :: IO (Maybe (CpuStat -> Word64))
35−getCpuStat = do
36− s <- readFile "/proc/stat"
37− _ <- evaluate $ length s -- Make readFile strict
38− pure $ do
39− cpuSummaryLine : _ <- pure $ lines s
40− [user, nice, system, idle, iowait, irq, softirq, steal, guest, guestNice] <- pure $ map read $ words $ drop 4 cpuSummaryLine
41− pure $ \case
42− CpuStat_User -> user
43− CpuStat_Nice -> nice
44− CpuStat_System -> system
45− CpuStat_Idle -> idle
46− CpuStat_Iowait -> iowait
47− CpuStat_Irq -> irq
48− CpuStat_Softirq -> softirq
49− CpuStat_Steal -> steal
50− CpuStat_Guest -> guest
51− CpuStat_GuestNice -> guestNice
52−
53−sumStats :: (CpuStat -> Word64) -> [CpuStat] -> Word64
54−sumStats get stats = sum $ get <$> stats
55−
56−-- | user + nice + system + irq + softirq + steal
57−nonIdleStats :: [CpuStat]
58−nonIdleStats =
59− [ CpuStat_User
60− , CpuStat_Nice
61− , CpuStat_System
62− , CpuStat_Irq
63− , CpuStat_Softirq
64− , CpuStat_Steal
65− ]
66−
67−-- | idle + iowait
68−idleStats :: [CpuStat]
69−idleStats =
70− [ CpuStat_Idle
71− , CpuStat_Iowait
72− ]
73−
74−-- | Draws the cpu usage percent as a live-updating bar graph. The output should look like:
75−--
76−-- > ╔══════ CPU Usage: 38% ══════╗
77−-- > ║ ║
78−-- > ║ ║
79−-- > ║ ║
80−-- > ║ ║
81−-- > ║ ║
82−-- > ║ ║
83−-- > ║█████████████████████████████║
84−-- > ║█████████████████████████████║
85−-- > ║█████████████████████████████║
86−-- > ║█████████████████████████████║
87−-- > ╚═════════════════════════════╝
88−--
89−cpuStats
90− :: ( Reflex t
91− , MonadFix m
92− , MonadHold t m
93− , MonadIO (Performable m)
94− , MonadIO m
95− , PerformEvent t m
96− , PostBuild t m
97− , TriggerEvent t m
98− , HasDisplayRegion t m
99− , HasImageWriter t m
100− , HasLayout t m
101− , HasFocus t m
102− , HasInput t m
103− , HasFocusReader t m, HasTheme t m
104− )
105− => m ()
106−cpuStats = do
107− tick <- tickLossy 0.25 =<< liftIO getCurrentTime
108− cpuStat :: Event t (Word64, Word64) <- fmap (fmapMaybe id) $
109− performEvent $ ffor tick $ \_ -> do
110− get <- liftIO getCpuStat
111− pure $ case get of
112− Nothing -> Nothing
113− Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats)
114− active <- foldDyn cpuPercentStep ((0, 0), 0) cpuStat
115− let pct = fmap snd active
116− chart pct
117−
118−chart
119− :: ( MonadFix m
120− , HasFocus t m
121− , HasLayout t m
122− , HasImageWriter t m
123− , HasInput t m
124− , HasDisplayRegion t m
125− , HasFocusReader t m, HasTheme t m
126− )
127− => Dynamic t (Ratio Word64) -> m ()
128−chart pct = do
129− let title = ffor pct $ \x -> mconcat
130− [ " CPU Usage: "
131− , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int))
132− , "% "
133− ]
134− boxTitle (pure doubleBoxStyle) (current title) $ col $ do
135− grout flex blank
136− dh <- displayHeight
137− let heights = calcRowHeights <$> dh <*> pct
138− quarters = fst <$> heights
139− eighths = snd <$> heights
140− eighthRow = ffor eighths $ \x -> if x == 0 then 0 else 1
141− grout (fixed eighthRow) $ fill' (current $ eighthBlocks <$> eighths) $ current $
142− ffor quarters $ \q ->
143− if | _quarter_fourth q > 0 -> red
144− | _quarter_third q > 0 -> orange
145− | _quarter_second q > 0 -> yellow
146− | otherwise -> white
147− grout (fixed $ _quarter_fourth <$> quarters) $ fill' (pure '█') (pure red)
148− grout (fixed $ _quarter_third <$> quarters) $ fill' (pure '█') (pure orange)
149− grout (fixed $ _quarter_second <$> quarters) $ fill' (pure '█') (pure yellow)
150− grout (fixed $ _quarter_first <$> quarters) $ fill' (pure '█') (pure white)
151− where
152− -- Calculate number of full rows, height of partial row
153− calcRowHeights :: Int -> Ratio Word64 -> (Quarter Int, Int)
154− calcRowHeights h r =
155− let (full, leftovers) = divMod (numerator r * fromIntegral h) (denominator r)
156− partial = ceiling $ 8 * (leftovers % denominator r)
157− quarter = ceiling $ fromIntegral h / (4 :: Double)
158− n = fromIntegral full
159− in if | n <= quarter ->
160− (Quarter n 0 0 0, partial)
161− | n <= (2 * quarter) ->
162− (Quarter quarter (n - quarter) 0 0, partial)
163− | n <= (3 * quarter) ->
164− (Quarter quarter quarter (n - (2 * quarter)) 0, partial)
165− | otherwise ->
166− (Quarter quarter quarter quarter (n - (3 * quarter)), partial)
167− fill' bc attr = do
168− dw <- displayWidth
169− dh <- displayHeight
170− let fillImg =
171− (\w h c a -> [V.charFill a c w h])
172− <$> current dw
173− <*> current dh
174− <*> bc
175− <*> attr
176− tellImages fillImg
177− color :: Int -> Int -> Int -> V.Color
178− color = V.rgbColor
179− red = V.withForeColor V.defAttr $ color 255 0 0
180− orange = V.withForeColor V.defAttr $ color 255 165 0
181− yellow = V.withForeColor V.defAttr $ color 255 255 0
182− white = V.withForeColor V.defAttr $ color 255 255 255
183−
184−data Quarter a = Quarter
185− { _quarter_first :: a
186− , _quarter_second :: a
187− , _quarter_third :: a
188− , _quarter_fourth :: a
189− }
190−
191−eighthBlocks :: (Eq a, Num a, Ord a) => a -> Char
192−eighthBlocks n =
193− if
194− | n <= 0 -> ' '
195− | n == 1 -> '▁'
196− | n == 2 -> '▂'
197− | n == 3 -> '▃'
198− | n == 4 -> '▄'
199− | n == 5 -> '▅'
200− | n == 6 -> '▆'
201− | n == 7 -> '▇'
202− | otherwise -> '█'
203−
204−-- | Determine the current percentage usage according to this algorithm:
205−--
206−-- PrevIdle = previdle + previowait
207−-- Idle = idle + iowait
208−--
209−-- PrevNonIdle = prevuser + prevnice + prevsystem + previrq + prevsoftirq + prevsteal
210−-- NonIdle = user + nice + system + irq + softirq + steal
211−--
212−-- PrevTotal = PrevIdle + PrevNonIdle
213−-- Total = Idle + NonIdle
214−--
215−-- totald = Total - PrevTotal
216−-- idled = Idle - PrevIdle
217−--
218−-- CPU_Percentage = (totald - idled)/totald
219−--
220−-- Source: https://stackoverflow.com/questions/23367857/accurate-calculation-of-cpu-usage-given-in-percentage-in-linux
221−cpuPercentStep
222− :: (Word64, Word64) -- Current active, Current idle
223− -> ((Word64, Word64), Ratio Word64) -- (Previous idle, Previous total), previous percent
224− -> ((Word64, Word64), Ratio Word64) -- (New idle, new total), percent
225−cpuPercentStep (nonidle, idle) ((previdle, prevtotal), _) =
226− let total = idle + nonidle
227− idled = idle - previdle
228− totald = total - prevtotal
229− in ( (idle, total)
230− , (totald - idled) % totald
231− )
src-bin/example.hs+184−211
@@ -1,151 +1,164 @@
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+
1import Control.Applicative
15import Control.Applicative
2import Control.Monad
16import Control.Monad
3import Control.Monad.Fix
17import Control.Monad.Fix
18+import Control.Monad.NodeId
4import Data.Functor
19import Data.Functor
5import Data.Functor.Misc
20import Data.Functor.Misc
6import Data.Map (Map)
21import Data.Map (Map)
22+import Data.Maybe
7import qualified Data.Map as Map
23import qualified Data.Map as Map
8−import qualified Data.Set as Set
9import Data.Text (Text)
24import Data.Text (Text)
10import qualified Data.Text as T
25import qualified Data.Text as T
11import qualified Data.Text.Zipper as TZ
26import qualified Data.Text.Zipper as TZ
12import qualified Graphics.Vty as V
27import qualified Graphics.Vty as V
13import Reflex
28import Reflex
14import Reflex.Network
29import Reflex.Network
30+import Reflex.Class.Switchable
15import Reflex.Vty
31import Reflex.Vty
16
32
17−import Example.CPU
33+easyExample :: IO ()
18−
34+easyExample = mainWidget $ do
19−type VtyExample t m =
35+ beginLayout $ row $ fixedL 39 $ col $ do
20− ( MonadFix m
36+ (a1,b1,c1) <- fixedL 3 $ row $ do
21− , Reflex t
37+ a <- stretch $ textButtonStatic def "POTATO"
22− , HasInput t m
38+ b <- stretch $ textButtonStatic def "TOMATO"
23− , HasImageWriter t m
39+ c <- stretch $ textButtonStatic def "EGGPLANT"
24− , HasDisplayRegion t m
40+ return (a,b,c)
25− , HasFocus t m
41+ (a2,b2,c2) <- fixedL 3 $ row $ do
26− , HasFocusReader t m, HasTheme t m
42+ a <- stretch $ textButtonStatic def "CHEESE"
27− )
43+ b <- stretch $ textButtonStatic def "BEES"
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
28
61
29−type Manager t m =
30− ( HasLayout t m
31− , HasFocus t m
32− )
33
62
34data Example = Example_TextEditor
63data Example = Example_TextEditor
35 | Example_Todo
64 | Example_Todo
36 | Example_ScrollableTextDisplay
65 | Example_ScrollableTextDisplay
37− | Example_ClickButtonsGetEmojis
38− | Example_CPUStat
39 deriving (Show, Read, Eq, Ord, Enum, Bounded)
66 deriving (Show, Read, Eq, Ord, Enum, Bounded)
40
67
41−withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
42−withCtrlC f = do
43− inp <- input
44− f
45− return $ fforMaybe inp $ \case
46− V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
47− _ -> Nothing
48−
49−darkTheme :: V.Attr
50−darkTheme = V.Attr {
51− V.attrStyle = V.SetTo V.standout
52− , V.attrForeColor = V.SetTo V.black
53− , V.attrBackColor = V.Default
54− , V.attrURL = V.Default
55−}
56−
57main :: IO ()
68main :: IO ()
58−main = mainWidget $ withCtrlC $ do
69+main = mainWidget $ do
59− initManager_ $ do
60− tabNavigation
61− let gf = grout . fixed
62− t = tile flex
63− buttons = col $ do
64− gf 3 $ col $ do
65− gf 1 $ text "Select an example."
66− gf 1 $ text "Esc will bring you back here."
67− gf 1 $ text "Ctrl+c to quit."
68− a <- t $ textButtonStatic def "Todo List"
69− b <- t $ textButtonStatic def "Text Editor"
70− c <- t $ textButtonStatic def "Scrollable text display"
71− d <- t $ textButtonStatic def "Clickable buttons"
72− e <- t $ textButtonStatic def "CPU Usage"
73− return $ leftmost
74− [ Left Example_Todo <$ a
75− , Left Example_TextEditor <$ b
76− , Left Example_ScrollableTextDisplay <$ c
77− , Left Example_ClickButtonsGetEmojis <$ d
78− , Left Example_CPUStat <$ e
79− ]
80− let escapable w = do
81− void w
82− i <- input
83− return $ fforMaybe i $ \case
84− V.EvKey V.KEsc [] -> Just $ Right ()
85− _ -> Nothing
86− rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
87− Left Example_Todo -> escapable taskList
88− Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
89− Left Example_ScrollableTextDisplay -> escapable scrolling
90− Left Example_ClickButtonsGetEmojis -> escapable easyExample
91− Left Example_CPUStat -> escapable cpuStats
92− Right () -> buttons
93− return ()
94−
95−-- * Mouse button and emojis example
96−easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
97−easyExample = do
98− row $ grout (fixed 39) $ col $ do
99− (a1,b1,c1) <- grout (fixed 3) $ row $ do
100− a <- tile flex $ btn "POTATO"
101− b <- tile flex $ btn "TOMATO"
102− c <- tile flex $ btn "EGGPLANT"
103− return (a,b,c)
104− (a2,b2,c2) <- grout (fixed 3) $ row $ do
105− a <- tile flex $ btn "CHEESE"
106− b <- tile flex $ btn "BEES"
107− c <- tile flex $ btn "MY KNEES"
108− return (a,b,c)
109− (a3,b3,c3) <- grout (fixed 3) $ row $ do
110− a <- tile flex $ btn "TIME"
111− b <- tile flex $ btn "RHYME"
112− c <- tile flex $ btn "A BIG CRIME"
113− return (a,b,c)
114− tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do
115− outputDyn <- foldDyn (<>) "" $ mergeWith (<>)
116− [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
117− text (current outputDyn)
118− tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map."
119 inp <- input
70 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
120 return $ fforMaybe inp $ \case
95 return $ fforMaybe inp $ \case
121 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
96 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
122 _ -> Nothing
97 _ -> 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]
132
98
133−-- * Task list example
134taskList
99taskList
135− :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
100+ :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
136− => m ()
101+ => VtyWidget t m ()
137−taskList = col $ do
102+taskList = do
103+ let btn = textButtonStatic def "Add another task"
104+ inp <- input
138 let todos0 =
105 let todos0 =
139 [ Todo "Find reflex-vty" True
106 [ Todo "Find reflex-vty" True
140 , Todo "Become functional reactive" False
107 , Todo "Become functional reactive" False
141 , Todo "Make vty apps" False
108 , Todo "Make vty apps" False
142 ]
109 ]
143− btn = textButtonStatic def "Add another task"
110+ rec let todos' = todos todos0 $ leftmost
144− enter <- fmap (const ()) <$> key V.KEnter
111+ [ () <$ e
145− rec void $ grout flex $ todos todos0 $ enter <> click
112+ , fforMaybe inp $ \case
146− click <- tile (fixed 3) btn
113+ V.EvKey V.KEnter [] -> Just ()
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)
147 return ()
118 return ()
148
119
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+
149data Todo = Todo
162data Todo = Todo
150 { _todo_label :: Text
163 { _todo_label :: Text
151 , _todo_done :: Bool
164 , _todo_done :: Bool
@@ -156,128 +169,88 @@ data TodoOutput t = TodoOutput
156 { _todoOutput_todo :: Dynamic t Todo
169 { _todoOutput_todo :: Dynamic t Todo
157 , _todoOutput_delete :: Event t ()
170 , _todoOutput_delete :: Event t ()
158 , _todoOutput_height :: Dynamic t Int
171 , _todoOutput_height :: Dynamic t Int
159− , _todoOutput_focusId :: FocusId
160 }
172 }
161
173
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+
162todo
180todo
163− :: (VtyExample t m, Manager t m, MonadHold t m)
181+ :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
164 => Todo
182 => Todo
165− -> m (TodoOutput t)
183+ -> VtyWidget t m (TodoOutput t)
166−todo t0 = row $ do
184+todo t0 = do
167− let toggleKeys = Set.fromList
185+ w <- displayWidth
168− [ (V.KChar ' ', [V.MCtrl])
186+ rec let checkboxWidth = 3
169− , (V.KChar '@', [V.MCtrl])
187+ checkboxRegion = DynRegion 0 0 checkboxWidth 1
170− ]
188+ labelHeight = _textInput_lines ti
171− anyChildFocused $ \focused -> do
189+ labelWidth = w - 1 - checkboxWidth
172− toggleE <- keyCombos toggleKeys
190+ labelLeft = checkboxWidth + 1
173− filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do
191+ labelTop = constDyn 0
174− rec let cfg = def
192+ labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
175− { _checkboxConfig_setValue = setVal
176− }
177− value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0
193+ value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
178− let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE
194+ (ti, d) <- pane labelRegion (pure True) $ do
179− (fid, (ti, d)) <- tile' flex $ do
180− i <- input
195+ i <- input
181− v <- textInput $ def
182− { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
196+ v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
183− let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
197+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
184− return (v, deleteSelf)
198+ return (v, deleteSelf)
185− return $ TodoOutput
199+ return $ TodoOutput
186− { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
200+ { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
187− , _todoOutput_delete = d
201+ , _todoOutput_delete = d
188− , _todoOutput_height = _textInput_lines ti
202+ , _todoOutput_height = _textInput_lines ti
189− , _todoOutput_focusId = fid
190− }
203+ }
191 where
204 where
192 backspaceOnEmpty v = \case
205 backspaceOnEmpty v = \case
193 V.EvKey V.KBS _ | T.null v -> Just ()
206 V.EvKey V.KBS _ | T.null v -> Just ()
194 _ -> Nothing
207 _ -> Nothing
195
208
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+
196todos
215todos
197 :: forall t m.
216 :: forall t m.
198 ( MonadHold t m
217 ( MonadHold t m
199− , Manager t m
218+ , MonadFix m
200− , VtyExample t m
219+ , Reflex t
201 , Adjustable t m
220 , Adjustable t m
221+ , NotReady t m
202 , PostBuild t m
222 , PostBuild t m
223+ , MonadNodeId m
203 )
224 )
204 => [Todo]
225 => [Todo]
205 -> Event t ()
226 -> Event t ()
206− -> m (Dynamic t (Map Int (TodoOutput t)))
227+ -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
207todos todos0 newTodo = do
228todos todos0 newTodo = do
208 let todosMap0 = Map.fromList $ zip [0..] todos0
229 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) $
209− rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
236+ listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do
210− to <- todo t
211− let sel = select selectOnDelete $ Const2 k
237+ let sel = select selectOnDelete $ Const2 k
238+ click <- void <$> mouseDown V.BLeft
212− pb <- getPostBuild
239+ pb <- getPostBuild
213− requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
240+ let focusMe = leftmost [ click, sel, pb ]
214− pure to
241+ r <- todo t
215− let delete = flip Map.singleton Nothing <$> todoDelete
242+ return (focusMe, r)
216− todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
243+ let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
217− insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
218− Nothing -> Map.singleton 0 $ Just $ Todo "" False
219− Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
220 updates = leftmost [insert, delete]
244 updates = leftmost [insert, delete]
221 todoDelete = switch . current $
245 todoDelete = switch . current $
222− leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
246+ leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> _layoutReturnData_value
223−
247+ todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> _layoutReturnData_value
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
224 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
251 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
225 (\m k -> let (before, after) = Map.split k m
252 (\m k -> let (before, after) = Map.split k m
226 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
253 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
227 (current todosMap)
254 (current todosMap)
228 todoDelete
255 todoDelete
229− return listOut
256+ return _layoutReturnData_value
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+1−3
@@ -10,7 +10,6 @@ module Control.Monad.NodeId
10 , runNodeIdT
10 , runNodeIdT
11 ) where
11 ) where
12
12
13−import Control.Monad.Morph
14import Control.Monad.Reader
13import Control.Monad.Reader
15import Control.Monad.Ref
14import Control.Monad.Ref
16import Data.IORef
15import Data.IORef
@@ -35,12 +34,10 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
35 deriving
34 deriving
36 ( Functor
35 ( Functor
37 , Applicative
36 , Applicative
38− , MFunctor
39 , Monad
37 , Monad
40 , MonadFix
38 , MonadFix
41 , MonadHold t
39 , MonadHold t
42 , MonadIO
40 , MonadIO
43− , MonadRef
44 , MonadReflexCreateTrigger t
41 , MonadReflexCreateTrigger t
45 , MonadSample t
42 , MonadSample t
46 , MonadTrans
43 , MonadTrans
@@ -48,6 +45,7 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
48 , PerformEvent t
45 , PerformEvent t
49 , PostBuild t
46 , PostBuild t
50 , TriggerEvent t
47 , TriggerEvent t
48+ , MonadRef
51 )
49 )
52
50
53instance MonadNodeId m => MonadNodeId (ReaderT x m)
51instance MonadNodeId m => MonadNodeId (ReaderT x m)
src/Data/Text/Zipper.hs+157−280
@@ -9,26 +9,22 @@ 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)
16import Data.Char (isSpace)
12import Data.Char (isSpace)
17import Data.Map (Map)
13import Data.Map (Map)
14+import qualified Data.Map as Map
18import Data.Maybe (fromMaybe)
15import Data.Maybe (fromMaybe)
19import Data.String
16import Data.String
17+import Control.Monad.State (evalState, forM, get, put)
18+
20import Data.Text (Text)
19import 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
28
25
29import Graphics.Text.Width (wcwidth)
26import Graphics.Text.Width (wcwidth)
30
27
31−
32-- | A zipper of the logical text input contents (the "document"). The lines
28-- | A zipper of the logical text input contents (the "document"). The lines
33-- before the line containing the cursor are stored in reverse order.
29-- before the line containing the cursor are stored in reverse order.
34-- The cursor is logically between the "before" and "after" text.
30-- The cursor is logically between the "before" and "after" text.
@@ -170,7 +166,7 @@ deleteLeftWord (TextZipper lb b a la) =
170-- | Insert up to n spaces to get to the next logical column that is a multiple of n
166-- | Insert up to n spaces to get to the next logical column that is a multiple of n
171tab :: Int -> TextZipper -> TextZipper
167tab :: Int -> TextZipper -> TextZipper
172tab n z@(TextZipper _ b _ _) =
168tab n z@(TextZipper _ b _ _) =
173− insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z
169+ insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z
174
170
175-- | The plain text contents of the zipper
171-- | The plain text contents of the zipper
176value :: TextZipper -> Text
172value :: TextZipper -> Text
@@ -193,35 +189,105 @@ fromText = flip insert empty
193data Span tag = Span tag Text
189data Span tag = Span tag Text
194 deriving (Show)
190 deriving (Show)
195
191
196−-- | Text alignment type
197−data TextAlignment =
198− TextAlignment_Left
199− | TextAlignment_Right
200− | TextAlignment_Center
201− deriving (Eq, Show)
202−
203−-- A map from the index (row) of display line to (fst,snd)
204−-- fst: leading empty spaces from left (may be negative) to adjust for alignment
205−-- snd: the text offset from the beginning of the document
206−-- to the first character of the display line
207−type OffsetMapWithAlignment = Map Int (Int, Int)
208−
209−-- helper type representing a single visual line that may be part of a wrapped logical line
210−data WrappedLine = WrappedLine
211− { _wrappedLines_text :: Text
212− , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character
213− , _wrappedLines_offset :: Int -- ^ offset from beginning of line
214− }
215− deriving (Eq, Show)
216−
217-- | Information about the document as it is displayed (i.e., post-wrapping)
192-- | Information about the document as it is displayed (i.e., post-wrapping)
218data DisplayLines tag = DisplayLines
193data DisplayLines tag = DisplayLines
219 { _displayLines_spans :: [[Span tag]]
194 { _displayLines_spans :: [[Span tag]]
220− , _displayLines_offsetMap :: OffsetMapWithAlignment
195+ , _displayLines_offsetMap :: Map Int Int
221− , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
196+ , _displayLines_cursorY :: Int
222 }
197 }
223 deriving (Show)
198 deriving (Show)
224
199
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+
225-- | Split a 'Text' at the given column index. For example
291-- | Split a 'Text' at the given column index. For example
226--
292--
227-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
293-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
@@ -231,16 +297,16 @@ splitAtWidth :: Int -> Text -> (Text, Text)
231splitAtWidth n t@(Text arr off len)
297splitAtWidth n t@(Text arr off len)
232 | n <= 0 = (T.empty, t)
298 | n <= 0 = (T.empty, t)
233 | n >= textWidth t = (t, T.empty)
299 | n >= textWidth t = (t, T.empty)
234− | otherwise = let k = toLogicalIndex n t
300+ | otherwise = let k = iterNWidth n t
235 in (text arr off k, text arr (off+k) (len-k))
301 in (text arr off k, text arr (off+k) (len-k))
236−
302+ where
237−toLogicalIndex :: Int -> Text -> Int
303+ iterNWidth :: Int -> Text -> Int
238−toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
304+ iterNWidth n' t'@(Text _ _ len') = loop 0 0
239− where loop !i !cnt
305+ where loop !i !cnt
240− | i >= len' || cnt + w > n' = i
306+ | i >= len' || cnt + w > n' = i
241− | otherwise = loop (i+d) (cnt + w)
307+ | otherwise = loop (i+d) (cnt + w)
242− where Iter c d = iter t' i
308+ where Iter c d = iter t' i
243− w = charWidth c
309+ w = charWidth c
244
310
245-- | Takes the given number of columns of characters. For example
311-- | Takes the given number of columns of characters. For example
246--
312--
@@ -269,6 +335,56 @@ dropWidth n = snd . splitAtWidth n
269charWidth :: Char -> Int
335charWidth :: Char -> Int
270charWidth = wcwidth
336charWidth = wcwidth
271
337
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+
272-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
388-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
273spansWidth :: [Span tag] -> Int
389spansWidth :: [Span tag] -> Int
274spansWidth = sum . map (\(Span _ t) -> textWidth t)
390spansWidth = sum . map (\(Span _ t) -> textWidth t)
@@ -304,242 +420,3 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
304 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
420 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
305 w = z + charWidth c
421 w = z + charWidth c
306{-# INLINE[0] charIndexAt #-}
422{-# 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.hsnew file+27
@@ -0,0 +1,27 @@
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,21 +14,15 @@ module Reflex.Vty
14 ( module Reflex
14 ( module Reflex
15 , module Reflex.Vty.Host
15 , module Reflex.Vty.Host
16 , module Reflex.Vty.Widget
16 , module Reflex.Vty.Widget
17− , module Reflex.Vty.Widget.Box
18 , module Reflex.Vty.Widget.Input
17 , module Reflex.Vty.Widget.Input
19 , module Reflex.Vty.Widget.Layout
18 , module Reflex.Vty.Widget.Layout
20− , module Reflex.Vty.Widget.Split
21− , module Reflex.Vty.Widget.Text
22 , module Control.Monad.NodeId
19 , module Control.Monad.NodeId
23 ) where
20 ) where
24
21
25import Reflex
22import Reflex
26import Reflex.Vty.Host
23import Reflex.Vty.Host
27import Reflex.Vty.Widget
24import Reflex.Vty.Widget
28−import Reflex.Vty.Widget.Box
29import Reflex.Vty.Widget.Input
25import Reflex.Vty.Widget.Input
30import Reflex.Vty.Widget.Layout
26import Reflex.Vty.Widget.Layout
31−import Reflex.Vty.Widget.Split
32−import Reflex.Vty.Widget.Text
33
27
34import Control.Monad.NodeId
28import Control.Monad.NodeId
src/Reflex/Vty/Host.hs+1
@@ -196,6 +196,7 @@ 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
199 -- | Use the given 'FireCommand' to fire events that have subscribers
200 -- | Use the given 'FireCommand' to fire events that have subscribers
200 -- and call the callback for the 'TriggerInvocation' of each.
201 -- and call the callback for the 'TriggerInvocation' of each.
201 fireEventTriggerRefs
202 fireEventTriggerRefs
src/Reflex/Vty/Widget.hs+633−467
@@ -4,39 +4,147 @@ 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 where
7+module Reflex.Vty.Widget
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
8
58
9import Control.Applicative (liftA2)
59import Control.Applicative (liftA2)
10import Control.Monad.Fix (MonadFix)
60import Control.Monad.Fix (MonadFix)
11import Control.Monad.IO.Class (MonadIO)
61import Control.Monad.IO.Class (MonadIO)
12−import Control.Monad.Morph
13−import Control.Monad.NodeId
14−import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
62+import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
15−import Control.Monad.Ref
16import Control.Monad.Trans (MonadTrans, lift)
63import Control.Monad.Trans (MonadTrans, lift)
64+import Data.Default (Default(..))
17import Data.Set (Set)
65import Data.Set (Set)
18import qualified Data.Set as Set
66import 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
19import Graphics.Vty (Image)
70import Graphics.Vty (Image)
20import qualified Graphics.Vty as V
71import qualified Graphics.Vty as V
21import Reflex
72import Reflex
22import Reflex.Class ()
73import Reflex.Class ()
23import Reflex.Host.Class (MonadReflexCreateTrigger)
74import Reflex.Host.Class (MonadReflexCreateTrigger)
75+
24import Reflex.Vty.Host
76import Reflex.Vty.Host
25
77
26−-- * Running a vty application
78+import Control.Monad.NodeId
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
27
143
28−-- | Sets up the top-level context for a vty widget and runs it with that context
144+-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context
29mainWidgetWithHandle
145mainWidgetWithHandle
30 :: V.Vty
146 :: V.Vty
31− -> (forall t m.
32− ( MonadVtyApp t m
147+ -> (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
33− , HasImageWriter t m
34− , MonadNodeId m
35− , HasDisplayRegion t m
36− , HasFocusReader t m
37− , HasInput t m
38− , HasTheme t m
39− ) => m (Event t ()))
40 -> IO ()
148 -> IO ()
41mainWidgetWithHandle vty child =
149mainWidgetWithHandle vty child =
42 runVtyAppWithHandle vty $ \dr0 inp -> do
150 runVtyAppWithHandle vty $ \dr0 inp -> do
@@ -46,178 +154,71 @@ mainWidgetWithHandle vty child =
46 let inp' = fforMaybe inp $ \case
154 let inp' = fforMaybe inp $ \case
47 V.EvResize {} -> Nothing
155 V.EvResize {} -> Nothing
48 x -> Just x
156 x -> Just x
49− (shutdown, images) <- runThemeReader (constant V.defAttr) $
157+ let ctx = VtyWidgetCtx
50− runFocusReader (pure True) $
158+ { _vtyWidgetCtx_width = fmap fst size
51− runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
159+ , _vtyWidgetCtx_height = fmap snd size
52− runImageWriter $
160+ , _vtyWidgetCtx_input = inp'
53− runNodeIdT $
161+ , _vtyWidgetCtx_focus = constDyn True
54− runInput inp' $ do
162+ }
163+ (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do
55− tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
164+ tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
56− child
165+ child
57 return $ VtyResult
166 return $ VtyResult
58 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
167 { _vtyResult_picture = fmap (V.picForLayers . reverse) images
59 , _vtyResult_shutdown = shutdown
168 , _vtyResult_shutdown = shutdown
60 }
169 }
61
170
62−-- | The output of a vty widget
63−data VtyWidgetOut t = VtyWidgetOut
64− { _vtyWidgetOut_shutdown :: Event t ()
65− }
66−
67-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
171-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
68mainWidget
172mainWidget
69− :: (forall t m.
70− ( MonadVtyApp t m
173+ :: (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
71− , HasImageWriter t m
72− , MonadNodeId m
73− , HasDisplayRegion t m
74− , HasFocusReader t m
75− , HasTheme t m
76− , HasInput t m
77− ) => m (Event t ()))
78 -> IO ()
174 -> IO ()
79mainWidget child = do
175mainWidget child = do
80 vty <- getDefaultVty
176 vty <- getDefaultVty
81 mainWidgetWithHandle vty child
177 mainWidgetWithHandle vty child
82
178
83−-- * Input Events
179+-- | A class for things that know their own display size dimensions
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)
84
200
85-- | A class for things that can receive vty events as input
201-- | A class for things that can receive vty events as input
86−class HasInput t m | m -> t where
202+class HasVtyInput t m | m -> t where
87 input :: m (Event t VtyEvent)
203 input :: m (Event t VtyEvent)
88− default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)
89− input = lift input
90− -- | User input events that the widget's parent chooses to share. These will generally
91− -- be filtered for relevance.
92− localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
93− default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
94− localInput f = hoist (localInput f)
95−
96−instance (Reflex t, Monad m) => HasInput t (Input t m) where
97− input = Input ask
98− localInput f (Input m) = Input $ local f m
99−
100−-- | A widget that can receive input events. See 'Graphics.Vty.Event'
101−newtype Input t m a = Input
102− { unInput :: ReaderT (Event t VtyEvent) m a
103− } deriving
104− ( Functor
105− , Applicative
106− , Monad
107− , MonadSample t
108− , MonadHold t
109− , MonadFix
110− , MonadIO
111− , MonadRef
112− )
113−
114−instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where
115− runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a'
116− traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $
117− traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
118− traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do
119− traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
120− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do
121− traverseDMapWithKeyWithAdjustWithMove (\k v -> unInput (f k v)) dm0 dm'
122−
123−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Input t m)
124−deriving instance NotReady t m => NotReady t (Input t m)
125−deriving instance PerformEvent t m => PerformEvent t (Input t m)
126−deriving instance PostBuild t m => PostBuild t (Input t m)
127−deriving instance TriggerEvent t m => TriggerEvent t (Input t m)
128−instance HasImageWriter t m => HasImageWriter t (Input t m)
129−instance HasDisplayRegion t m => HasDisplayRegion t (Input t m)
130−instance HasFocusReader t m => HasFocusReader t (Input t m)
131−
132−instance MonadTrans (Input t) where
133− lift f = Input $ lift f
134−
135−instance MFunctor (Input t) where
136− hoist f = Input . hoist f . unInput
137−
138−instance MonadNodeId m => MonadNodeId (Input t m)
139−
140−-- | Runs an 'Input' with a given context
141−runInput
142− :: Reflex t
143− => Event t VtyEvent
144− -> Input t m a
145− -> m a
146−runInput e w = runReaderT (unInput w) e
147−
148−-- ** Filtering input
149
204
150−-- | Type synonym for a key and modifier combination
205+instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
151−type KeyCombo = (V.Key, [V.Modifier])
206+ input = VtyWidget . lift $ asks _vtyWidgetCtx_input
152−
153−-- | Emits an event that fires on a particular key press (without modifiers)
154−key :: (Monad m, Reflex t, HasInput t m) => V.Key -> m (Event t KeyCombo)
155−key = keyCombos . Set.singleton . (,[])
156
207
157−-- | Emits an event that fires on particular key presses (without modifiers)
208+-- | A class for things that can dynamically gain and lose focus
158−keys :: (Monad m, Reflex t, HasInput t m) => [V.Key] -> m (Event t KeyCombo)
209+class HasFocus t m | m -> t where
159−keys = keyCombos . Set.fromList . fmap (,[])
210+ focus :: m (Dynamic t Bool)
160−
161−-- | Emit an event that fires whenever the provided key combination occurs
162−keyCombo
163− :: (Reflex t, Monad m, HasInput t m)
164− => KeyCombo
165− -> m (Event t KeyCombo)
166−keyCombo = keyCombos . Set.singleton
167
211
168−-- | Emit an event that fires whenever any of the provided key combinations occur
212+instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
169−keyCombos
213+ focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
170− :: (Reflex t, Monad m, HasInput t m)
171− => Set KeyCombo
172− -> m (Event t KeyCombo)
173−keyCombos ks = do
174− i <- input
175− return $ fforMaybe i $ \case
176− V.EvKey k m -> if Set.member (k, m) ks
177− then Just (k, m)
178− else Nothing
179− _ -> Nothing
180
214
181−-- | Filter the keyboard input that a child widget may receive
215+-- | A class for widgets that can produce images to draw to the display
182−filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a
216+class (Reflex t, Monad m) => ImageWriter t m | m -> t where
183−filterKeys f x = localInput (ffilter (\case
217+ -- | Send images upstream for rendering
184− V.EvKey k mods -> f (k, mods)
218+ tellImages :: Behavior t [Image] -> m ()
185− _ -> True)) x
186−
187−-- | Filter mouse input events based on whether they target a particular region
188−-- and translate them to the internal coordinate system of that region.
189−--
190−-- NB: Non-mouse events are passed through unfiltered and unchanged
191−mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent
192−mouseInRegion (Region l t w h) e = case e of
193− V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
194− V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
195− _ -> Just e
196− where
197− mouse con x y
198− | or [ x < l
199− , y < t
200− , x >= l + w
201− , y >= t + h ] = Nothing
202− | otherwise =
203− Just (con (x - l) (y - t))
204−
205−-- | Filter mouse input outside the current display region and
206−-- all input if the region is not focused
207−inputInFocusedRegion
208− :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
209− => m (Event t VtyEvent)
210−inputInFocusedRegion = do
211− inp <- input
212− reg <- current <$> askRegion
213− foc <- current <$> focus
214− pure $ fmapMaybe id $ attachWith filterInput ((,) <$> reg <*> foc) inp
215− where
216− filterInput (r, f) = \case
217− V.EvKey {} | not f -> Nothing
218− x -> mouseInRegion r x
219
219
220−-- * Getting and setting the display region
220+instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
221+ tellImages = tellBehavior
221
222
222-- | A chunk of the display area
223-- | A chunk of the display area
223data Region = Region
224data Region = Region
@@ -228,334 +229,499 @@ data Region = Region
228 }
229 }
229 deriving (Show, Read, Eq, Ord)
230 deriving (Show, Read, Eq, Ord)
230
231
231−-- | A region that occupies no space.
232+-- | A dynamic chunk of the display area
232−nilRegion :: Region
233+data DynRegion t = DynRegion
233−nilRegion = Region 0 0 0 0
234+ { _dynRegion_left :: Dynamic t Int
235+ , _dynRegion_top :: Dynamic t Int
236+ , _dynRegion_width :: Dynamic t Int
237+ , _dynRegion_height :: Dynamic t Int
238+ }
234
239
235-- | The width and height of a 'Region'
240-- | The width and height of a 'Region'
236regionSize :: Region -> (Int, Int)
241regionSize :: Region -> (Int, Int)
237regionSize (Region _ _ w h) = (w, h)
242regionSize (Region _ _ w h) = (w, h)
238
243
239-- | Produces an 'Image' that fills a region with space characters
244-- | Produces an 'Image' that fills a region with space characters
240−regionBlankImage :: V.Attr -> Region -> Image
245+regionBlankImage :: Region -> Image
241−regionBlankImage attr r@(Region _ _ width height) =
246+regionBlankImage r@(Region _ _ width height) =
242− withinImage r $ V.charFill attr ' ' width height
247+ withinImage r $ V.charFill V.defAttr ' ' width height
243
248
244−-- | A class for things that know their own display size dimensions
249+-- | A behavior of the current display area represented by a 'DynRegion'
245−class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
250+currentRegion :: Reflex t => DynRegion t -> Behavior t Region
246− -- | Retrieve the display region
251+currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h
247− askRegion :: m (Dynamic t Region)
248− default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)
249− askRegion = lift askRegion
250− -- | Run an action in a local region, by applying a transformation to the region
251− localRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a
252− default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a
253− localRegion f = hoist (localRegion f)
254−
255−-- | Retrieve the display width
256−displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
257−displayWidth = fmap _region_width <$> askRegion
258−
259−-- | Retrieve the display height
260−displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)
261−displayHeight = fmap _region_height <$> askRegion
262−
263−instance HasDisplayRegion t m => HasDisplayRegion t (ReaderT x m)
264−instance HasDisplayRegion t m => HasDisplayRegion t (BehaviorWriterT t x m)
265−instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)
266−instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)
267−instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)
268−
269−-- | A widget that has access to a particular region of the vty display
270−newtype DisplayRegion t m a = DisplayRegion
271− { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
272− deriving
273− ( Functor
274− , Applicative
275− , Monad
276− , MonadFix
277− , MonadHold t
278− , MonadIO
279− , MonadRef
280− , MonadSample t
281− )
282−
283−instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where
284− askRegion = DisplayRegion ask
285− localRegion f = DisplayRegion . local f . unDisplayRegion
286−
287−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m)
288−deriving instance NotReady t m => NotReady t (DisplayRegion t m)
289−deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
290−deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
291−deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
292−instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
293−instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)
294−
295−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
296− runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e
297− traverseIntMapWithKeyWithAdjust f m e = DisplayRegion $ traverseIntMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
298− traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
299− traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
300−
301−instance MonadTrans (DisplayRegion t) where
302− lift = DisplayRegion . lift
303−
304−instance MFunctor (DisplayRegion t) where
305− hoist f = DisplayRegion . hoist f . unDisplayRegion
306
252
307−instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
253+-- | Translates and crops an 'Image' so that it is contained by
254+-- the given 'Region'.
255+withinImage
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
308
262
309−-- | Run a 'DisplayRegion' action with a given 'Region'
263+-- | Low-level widget combinator that runs a child 'VtyWidget' within
310−runDisplayRegion
264+-- a given region and context. This widget filters and modifies the input
265+-- that the child widget receives such that:
266+-- * unfocused widgets receive no key events
267+-- * mouse inputs outside the region are ignored
268+-- * mouse inputs inside the region have their coordinates translated such
269+-- that (0,0) is the top-left corner of the region
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
311 :: (Reflex t, Monad m)
353 :: (Reflex t, Monad m)
312− => Dynamic t Region
354+ => V.Button
313− -> DisplayRegion t m a
355+ -> VtyWidget t m (Event t MouseDown)
314− -> m a
356+mouseDown btn = do
315−runDisplayRegion r = flip runReaderT r . unDisplayRegion
357+ i <- input
316−
358+ return $ fforMaybe i $ \case
317−-- * Getting focus state
359+ V.EvMouseDown x y btn' mods -> if btn == btn'
318−
360+ then Just $ MouseDown btn' (x, y) mods
319−-- | A class for things that can dynamically gain and lose focus
361+ else Nothing
320−class (Reflex t, Monad m) => HasFocusReader t m | m -> t where
362+ _ -> Nothing
321− focus :: m (Dynamic t Bool)
322− default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocusReader t m') => m (Dynamic t Bool)
323− focus = lift focus
324− localFocus :: (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
325− default localFocus :: (f m' ~ m, Monad m', MFunctor f, HasFocusReader t m') => (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
326− localFocus f = hoist (localFocus f)
327−
328−instance HasFocusReader t m => HasFocusReader t (ReaderT x m)
329−instance HasFocusReader t m => HasFocusReader t (BehaviorWriterT t x m)
330−instance HasFocusReader t m => HasFocusReader t (DynamicWriterT t x m)
331−instance HasFocusReader t m => HasFocusReader t (EventWriterT t x m)
332−instance HasFocusReader t m => HasFocusReader t (NodeIdT m)
333−
334−-- | A widget that has access to information about whether it is focused
335−newtype FocusReader t m a = FocusReader
336− { unFocusReader :: ReaderT (Dynamic t Bool) m a }
337− deriving
338− ( Functor
339− , Applicative
340− , Monad
341− , MonadFix
342− , MonadHold t
343− , MonadIO
344− , MonadRef
345− , MonadSample t
346− )
347−
348−instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where
349− focus = FocusReader ask
350− localFocus f = FocusReader . local f . unFocusReader
351−
352−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (FocusReader t m)
353−deriving instance NotReady t m => NotReady t (FocusReader t m)
354−deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)
355−deriving instance PostBuild t m => PostBuild t (FocusReader t m)
356−deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)
357−instance HasImageWriter t m => HasImageWriter t (FocusReader t m)
358−
359−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where
360− runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e
361− traverseIntMapWithKeyWithAdjust f m e = FocusReader $ traverseIntMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
362− traverseDMapWithKeyWithAdjust f m e = FocusReader $ traverseDMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
363− traverseDMapWithKeyWithAdjustWithMove f m e = FocusReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocusReader $ f k v) m e
364−
365−instance MonadTrans (FocusReader t) where
366− lift = FocusReader . lift
367−
368−instance MFunctor (FocusReader t) where
369− hoist f = FocusReader . hoist f . unFocusReader
370−
371−instance MonadNodeId m => MonadNodeId (FocusReader t m)
372
363
373−-- | Run a 'FocusReader' action with the given focus value
364+-- | Mouse up events for a particular mouse button
374−runFocusReader
365+mouseUp
375 :: (Reflex t, Monad m)
366 :: (Reflex t, Monad m)
376− => Dynamic t Bool
367+ => VtyWidget t m (Event t MouseUp)
377− -> FocusReader t m a
368+mouseUp = do
378− -> m a
369+ i <- input
379−runFocusReader b = flip runReaderT b . unFocusReader
370+ return $ fforMaybe i $ \case
380−
371+ V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
381−-- * "Image" output
372+ _ -> Nothing
382−
383−-- | A class for widgets that can produce images to draw to the display
384−class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
385− -- | Send images upstream for rendering
386− tellImages :: Behavior t [Image] -> m ()
387− default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()
388− tellImages = lift . tellImages
389− -- | Apply a transformation to the images produced by the child actions
390− mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
391− default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
392− mapImages f = hoist (mapImages f)
393−
394−-- | A widget that can produce images to draw onto the display
395−newtype ImageWriter t m a = ImageWriter
396− { unImageWriter :: BehaviorWriterT t [Image] m a }
397− deriving
398− ( Functor
399− , Applicative
400− , Monad
401− , MonadFix
402− , MonadHold t
403− , MonadIO
404− , MonadRef
405− , MonadReflexCreateTrigger t
406− , MonadSample t
407− , NotReady t
408− , PerformEvent t
409− , PostBuild t
410− , TriggerEvent t
411− )
412−
413−instance MonadTrans (ImageWriter t) where
414− lift = ImageWriter . lift
415−
416−instance MFunctor (ImageWriter t) where
417− hoist f = ImageWriter . (hoist f) . unImageWriter
418−
419−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ImageWriter t m) where
420− runWithReplace (ImageWriter a) e = ImageWriter $ runWithReplace a $ fmap unImageWriter e
421− traverseIntMapWithKeyWithAdjust f m e = ImageWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
422− traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
423− traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e
424
373
425−instance HasImageWriter t m => HasImageWriter t (ReaderT x m)
374+-- | Information about a mouse down event
426−instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)
375+data MouseDown = MouseDown
427−instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)
376+ { _mouseDown_button :: V.Button
428−instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)
377+ , _mouseDown_coordinates :: (Int, Int)
429−instance HasImageWriter t m => HasImageWriter t (NodeIdT m)
378+ , _mouseDown_modifiers :: [V.Modifier]
379+ }
380+ deriving (Eq, Ord, Show)
430
381
431−instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
382+-- | Information about a mouse up event
432− tellImages = ImageWriter . tellBehavior
383+data MouseUp = MouseUp
433− mapImages f (ImageWriter x) = ImageWriter $ do
384+ { _mouseUp_button :: Maybe V.Button
434− (a, images) <- lift $ runBehaviorWriterT x
385+ , _mouseUp_coordinates :: (Int, Int)
435− tellBehavior $ f images
386+ }
436− pure a
387+ deriving (Eq, Ord, Show)
437
388
438−instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
389+-- | Mouse scroll direction
439−instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
390+data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
391+ deriving (Eq, Ord, Show)
440
392
441−-- | Run a widget that can produce images
393+-- | Produce an event that fires when the mouse wheel is scrolled
442−runImageWriter
394+mouseScroll
443 :: (Reflex t, Monad m)
395 :: (Reflex t, Monad m)
444− => ImageWriter t m a
396+ => VtyWidget t m (Event t ScrollDirection)
445− -> m (a, Behavior t [Image])
397+mouseScroll = do
446−runImageWriter = runBehaviorWriterT . unImageWriter
398+ up <- mouseDown V.BScrollUp
447−
399+ down <- mouseDown V.BScrollDown
448−-- * Theming
400+ return $ leftmost
449−
401+ [ ScrollDirection_Up <$ up
450−-- | A class for things that can be visually styled
402+ , ScrollDirection_Down <$ down
451−class (Reflex t, Monad m) => HasTheme t m | m -> t where
403+ ]
452− theme :: m (Behavior t V.Attr)
453− default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)
454− theme = lift theme
455− localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
456− default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
457− localTheme f = hoist (localTheme f)
458−
459−instance HasTheme t m => HasTheme t (ReaderT x m)
460−instance HasTheme t m => HasTheme t (BehaviorWriterT t x m)
461−instance HasTheme t m => HasTheme t (DynamicWriterT t x m)
462−instance HasTheme t m => HasTheme t (EventWriterT t x m)
463−instance HasTheme t m => HasTheme t (NodeIdT m)
464−instance HasTheme t m => HasTheme t (Input t m)
465−instance HasTheme t m => HasTheme t (ImageWriter t m)
466−instance HasTheme t m => HasTheme t (DisplayRegion t m)
467−instance HasTheme t m => HasTheme t (FocusReader t m)
468−
469−-- | A widget that has access to theme information
470−newtype ThemeReader t m a = ThemeReader
471− { unThemeReader :: ReaderT (Behavior t V.Attr) m a }
472− deriving
473− ( Functor
474− , Applicative
475− , Monad
476− , MonadFix
477− , MonadHold t
478− , MonadIO
479− , MonadRef
480− , MonadSample t
481− )
482−
483−instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where
484− theme = ThemeReader ask
485− localTheme f = ThemeReader . local f . unThemeReader
486−
487−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)
488−deriving instance NotReady t m => NotReady t (ThemeReader t m)
489−deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)
490−deriving instance PostBuild t m => PostBuild t (ThemeReader t m)
491−deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)
492−instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)
493−
494−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where
495− runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e
496− traverseIntMapWithKeyWithAdjust f m e = ThemeReader $ traverseIntMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
497− traverseDMapWithKeyWithAdjust f m e = ThemeReader $ traverseDMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
498− traverseDMapWithKeyWithAdjustWithMove f m e = ThemeReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unThemeReader $ f k v) m e
499
404
500−instance MonadTrans (ThemeReader t) where
405+-- | Type synonym for a key and modifier combination
501− lift = ThemeReader . lift
406+type KeyCombo = (V.Key, [V.Modifier])
502
407
503−instance MFunctor (ThemeReader t) where
408+-- | Emits an event that fires on a particular key press (without modifiers)
504− hoist f = ThemeReader . hoist f . unThemeReader
409+key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)
410+key = keyCombos . Set.singleton . (,[])
505
411
506−instance MonadNodeId m => MonadNodeId (ThemeReader t m)
412+-- | Emits an event that fires on particular key presses (without modifiers)
413+keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)
414+keys = keyCombos . Set.fromList . fmap (,[])
507
415
508−-- | Run a 'ThemeReader' action with the given focus value
416+-- | Emit an event that fires whenever the provided key combination occurs
509−runThemeReader
417+keyCombo
510 :: (Reflex t, Monad m)
418 :: (Reflex t, Monad m)
511− => Behavior t V.Attr
419+ => KeyCombo
512− -> ThemeReader t m a
420+ -> VtyWidget t m (Event t KeyCombo)
513− -> m a
421+keyCombo = keyCombos . Set.singleton
514−runThemeReader b = flip runReaderT b . unThemeReader
515
422
423+-- | Emit an event that fires whenever any of the provided key combinations occur
424+keyCombos
425+ :: (Reflex t, Monad m)
426+ => Set KeyCombo
427+ -> VtyWidget t m (Event t KeyCombo)
428+keyCombos ks = do
429+ i <- input
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
516
435
517−-- ** Manipulating images
436+-- | A plain split of the available space into vertically stacked panes.
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+ }
518
560
519−-- | Translates and crops an 'Image' so that it is contained by
561+instance Default BoxStyle where
520−-- the given 'Region'.
562+ def = singleBoxStyle
521−withinImage
563+
522− :: Region
564+-- | A box style that uses hyphens and pipe characters. Doesn't handle
523− -> Image
565+-- corners very well.
524− -> Image
566+hyphenBoxStyle :: BoxStyle
525−withinImage (Region left top width height)
567+hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
526− | width < 0 || height < 0 = withinImage (Region left top 0 0)
568+
527− | otherwise = V.translate left top . V.crop width height
569+-- | A single line box style
570+singleBoxStyle :: BoxStyle
571+singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
572+
573+-- | A thick single line box style
574+thickBoxStyle :: BoxStyle
575+thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
576+
577+-- | A double line box style
578+doubleBoxStyle :: BoxStyle
579+doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
580+
581+-- | A single line box style with rounded corners
582+roundedBoxStyle :: BoxStyle
583+roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
584+
585+-- | Draws a titled box in the provided style and a child widget inside of that box
586+boxTitle :: (Monad m, Reflex t, MonadNodeId m)
587+ => Behavior t BoxStyle
588+ -> Text
589+ -> VtyWidget t m a
590+ -> VtyWidget t m a
591+boxTitle boxStyle title child = do
592+ dh <- displayHeight
593+ dw <- displayWidth
594+ let boxReg = DynRegion (pure 0) (pure 0) dw dh
595+ innerReg = DynRegion (pure 1) (pure 1) (subtract 2 <$> dw) (subtract 2 <$> dh)
596+ tellImages (boxImages <$> boxStyle <*> currentRegion boxReg)
597+ tellImages (fmap (\r -> [regionBlankImage r]) (currentRegion innerReg))
598+ pane innerReg (pure True) child
599+ where
600+ boxImages :: BoxStyle -> Region -> [Image]
601+ boxImages style (Region left top width height) =
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+ }
528
656
529−-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.
657+instance Reflex t => Default (RichTextConfig t) where
530−imagesInRegion
658+ def = RichTextConfig $ pure V.defAttr
531− :: Reflex t
532− => Behavior t Region
533− -> Behavior t [Image]
534− -> Behavior t [Image]
535−imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
536
659
537−-- * Running sub-widgets
660+-- | A widget that displays text with custom time-varying attributes
661+richText
662+ :: (Reflex t, Monad m)
663+ => RichTextConfig t
664+ -> Behavior t Text
665+ -> VtyWidget t m ()
666+richText cfg t = do
667+ dw <- displayWidth
668+ let img = (\w a s -> [wrapText w a s])
669+ <$> current dw
670+ <*> _richTextConfig_attributes cfg
671+ <*> t
672+ tellImages img
673+ where
674+ wrapText maxWidth attrs = V.vertCat
675+ . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
676+ . T.split (=='\n')
538
677
539−-- | Low-level widget combinator that runs a child widget within
678+-- | Renders text, wrapped to the container width
540−-- a given region and context. This widget filters and modifies the input
679+text
541−-- that the child widget receives such that:
680+ :: (Reflex t, Monad m)
542−-- * unfocused widgets receive no key events
681+ => Behavior t Text
543−-- * mouse inputs outside the region are ignored
682+ -> VtyWidget t m ()
544−-- * mouse inputs inside the region have their coordinates translated such
683+text = richText def
545−-- that (0,0) is the top-left corner of the region
684+
546−pane
685+-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
547− :: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
686+-- that are hidden)
548− => Dynamic t Region
687+scrollableText
549− -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
688+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m)
550− -> m a
689+ => Event t Int
551− -> m a
690+ -- ^ Number of lines to scroll by
552−pane dr foc child = localRegion (const dr) $
691+ -> Behavior t Text
553− mapImages (imagesInRegion $ current dr) $
692+ -> VtyWidget t m (Behavior t (Int, Int))
554− localFocus (const foc) $
693+ -- ^ (Current scroll position, total number of lines)
555− inputInFocusedRegion >>= \e -> localInput (const e) child
694+scrollableText scrollBy t = do
695+ dw <- displayWidth
696+ let imgs = wrap <$> current dw <*> t
697+ kup <- key V.KUp
698+ kdown <- key V.KDown
699+ m <- mouseScroll
700+ let requestedScroll :: Event t Int
701+ requestedScroll = leftmost
702+ [ 1 <$ kdown
703+ , (-1) <$ kup
704+ , ffor m $ \case
705+ ScrollDirection_Up -> (-1)
706+ ScrollDirection_Down -> 1
707+ , scrollBy
708+ ]
709+ updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
710+ lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
711+ attach (length <$> imgs) requestedScroll
712+ tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
713+ return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
714+ where
715+ wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
556
716
557−-- * Misc
717+-- | Renders any behavior whose value can be converted to
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
558
724
559-- | A widget that draws nothing
725-- | A widget that draws nothing
560−blank :: Monad m => m ()
726+blank :: Monad m => VtyWidget t m ()
561blank = return ()
727blank = return ()
src/Reflex/Vty/Widget/Box.hsdeleted−124
@@ -1,124 +0,0 @@
1−{-|
2− Description: Drawing boxes in various styles
3−-}
4−module Reflex.Vty.Widget.Box where
5−
6−import Data.Default
7−import Data.Text (Text)
8−import qualified Data.Text as T
9−import Graphics.Vty (Image)
10−import qualified Graphics.Vty as V
11−import Reflex
12−import Reflex.Vty.Widget
13−import Reflex.Vty.Widget.Text
14−
15−-- | Fill the background with the bottom box style
16−hRule :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => BoxStyle -> m ()
17−hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)
18−
19−-- | Defines a set of symbols to use to draw the outlines of boxes
20−-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character
21−data BoxStyle = BoxStyle
22− { _boxStyle_nw :: Char
23− , _boxStyle_n :: Char
24− , _boxStyle_ne :: Char
25− , _boxStyle_e :: Char
26− , _boxStyle_se :: Char
27− , _boxStyle_s :: Char
28− , _boxStyle_sw :: Char
29− , _boxStyle_w :: Char
30− }
31−
32−instance Default BoxStyle where
33− def = singleBoxStyle
34−
35−-- | A box style that uses hyphens and pipe characters. Doesn't handle
36−-- corners very well.
37−hyphenBoxStyle :: BoxStyle
38−hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
39−
40−-- | A single line box style
41−singleBoxStyle :: BoxStyle
42−singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
43−
44−-- | A thick single line box style
45−thickBoxStyle :: BoxStyle
46−thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
47−
48−-- | A double line box style
49−doubleBoxStyle :: BoxStyle
50−doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
51−
52−-- | A single line box style with rounded corners
53−roundedBoxStyle :: BoxStyle
54−roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
55−
56−-- | Draws a titled box in the provided style and a child widget inside of that box
57−boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
58− => Behavior t BoxStyle
59− -> Behavior t Text
60− -> m a
61− -> m a
62−boxTitle boxStyle title child = do
63− dh <- displayHeight
64− dw <- displayWidth
65− bt <- theme
66− let boxReg = Region 0 0 <$> dw <*> dh
67− innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)
68−
69− tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg)
70− tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r]))
71−
72− pane innerReg (pure True) child
73− where
74− boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image]
75− boxImages attr title' style (Region left top width height) =
76− let right = left + width - 1
77− bottom = top + height - 1
78− sides =
79− [ withinImage (Region (left + 1) top (width - 2) 1) $
80− V.text' attr $
81− hPadText title' (_boxStyle_n style) (width - 2)
82− , withinImage (Region right (top + 1) 1 (height - 2)) $
83− V.charFill attr (_boxStyle_e style) 1 (height - 2)
84− , withinImage (Region (left + 1) bottom (width - 2) 1) $
85− V.charFill attr (_boxStyle_s style) (width - 2) 1
86− , withinImage (Region left (top + 1) 1 (height - 2)) $
87− V.charFill attr (_boxStyle_w style) 1 (height - 2)
88− ]
89− corners =
90− [ withinImage (Region left top 1 1) $
91− V.char attr (_boxStyle_nw style)
92− , withinImage (Region right top 1 1) $
93− V.char attr (_boxStyle_ne style)
94− , withinImage (Region right bottom 1 1) $
95− V.char attr (_boxStyle_se style)
96− , withinImage (Region left bottom 1 1) $
97− V.char attr (_boxStyle_sw style)
98− ]
99− in sides ++ if width > 1 && height > 1 then corners else []
100− hPadText :: T.Text -> Char -> Int -> T.Text
101− hPadText t c l = if lt >= l
102− then t
103− else left <> t <> right
104− where
105− lt = T.length t
106− delta = l - lt
107− mkHalf n = T.replicate (n `div` 2) (T.singleton c)
108− left = mkHalf $ delta + 1
109− right = mkHalf delta
110−
111−-- | A box without a title
112−box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
113− => Behavior t BoxStyle
114− -> m a
115− -> m a
116−box boxStyle = boxTitle boxStyle mempty
117−
118−-- | A box whose style is static
119−boxStatic
120− :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
121− => BoxStyle
122− -> m a
123− -> m a
124−boxStatic = box . pure
src/Reflex/Vty/Widget/Input.hs+20−40
@@ -8,20 +8,16 @@ module Reflex.Vty.Widget.Input
8 ) where
8 ) where
9
9
10
10
11−import Reflex.Vty.Widget.Input.Mouse as Export
12import Reflex.Vty.Widget.Input.Text as Export
11import Reflex.Vty.Widget.Input.Text as Export
13
12
14import Control.Monad (join)
13import Control.Monad (join)
15import Control.Monad.Fix (MonadFix)
14import 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
25
21
26-- | Configuration options for the 'button' widget
22-- | Configuration options for the 'button' widget
27data ButtonConfig t = ButtonConfig
23data ButtonConfig t = ButtonConfig
@@ -34,10 +30,10 @@ instance Reflex t => Default (ButtonConfig t) where
34
30
35-- | A button widget that contains a sub-widget
31-- | A button widget that contains a sub-widget
36button
32button
37− :: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
33+ :: (Reflex t, Monad m, MonadNodeId m)
38 => ButtonConfig t
34 => ButtonConfig t
39− -> m ()
35+ -> VtyWidget t m ()
40− -> m (Event t ())
36+ -> VtyWidget t m (Event t ())
41button cfg child = do
37button cfg child = do
42 f <- focus
38 f <- focus
43 let style = do
39 let style = do
@@ -52,44 +48,39 @@ button cfg child = do
52
48
53-- | A button widget that displays text that can change
49-- | A button widget that displays text that can change
54textButton
50textButton
55− :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
51+ :: (Reflex t, Monad m, MonadNodeId m)
56 => ButtonConfig t
52 => ButtonConfig t
57 -> Behavior t Text
53 -> Behavior t Text
58− -> m (Event t ())
54+ -> VtyWidget t m (Event t ())
59textButton cfg = button cfg . text -- TODO Centering etc.
55textButton cfg = button cfg . text -- TODO Centering etc.
60
56
61-- | A button widget that displays a static bit of text
57-- | A button widget that displays a static bit of text
62textButtonStatic
58textButtonStatic
63− :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
59+ :: (Reflex t, Monad m, MonadNodeId m)
64 => ButtonConfig t
60 => ButtonConfig t
65 -> Text
61 -> Text
66− -> m (Event t ())
62+ -> VtyWidget t m (Event t ())
67textButtonStatic cfg = textButton cfg . pure
63textButtonStatic cfg = textButton cfg . pure
68
64
69−-- * Links
70−
71-- | A clickable link widget
65-- | A clickable link widget
72link
66link
73− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m)
67+ :: (Reflex t, Monad m)
74 => Behavior t Text
68 => Behavior t Text
75− -> m (Event t MouseUp)
69+ -> VtyWidget t m (Event t MouseUp)
76link t = do
70link t = do
77− bt <- theme
78 let cfg = RichTextConfig
71 let cfg = RichTextConfig
79− { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt
72+ { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline
80 }
73 }
81 richText cfg t
74 richText cfg t
82 mouseUp
75 mouseUp
83
76
84-- | A clickable link widget with a static label
77-- | A clickable link widget with a static label
85linkStatic
78linkStatic
86− :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)
79+ :: (Reflex t, Monad m)
87 => Text
80 => Text
88− -> m (Event t MouseUp)
81+ -> VtyWidget t m (Event t MouseUp)
89linkStatic = link . pure
82linkStatic = link . pure
90
83
91−-- * Checkboxes
92−
93-- | Characters used to render checked and unchecked textboxes
84-- | Characters used to render checked and unchecked textboxes
94data CheckboxStyle = CheckboxStyle
85data CheckboxStyle = CheckboxStyle
95 { _checkboxStyle_unchecked :: Text
86 { _checkboxStyle_unchecked :: Text
@@ -116,43 +107,32 @@ checkboxStyleTick = CheckboxStyle
116-- | Configuration options for a checkbox
107-- | Configuration options for a checkbox
117data CheckboxConfig t = CheckboxConfig
108data CheckboxConfig t = CheckboxConfig
118 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
109 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
119− -- TODO DELETE and use HasTheme instead
120 , _checkboxConfig_attributes :: Behavior t V.Attr
110 , _checkboxConfig_attributes :: Behavior t V.Attr
121− , _checkboxConfig_setValue :: Event t Bool
122 }
111 }
123
112
124instance (Reflex t) => Default (CheckboxConfig t) where
113instance (Reflex t) => Default (CheckboxConfig t) where
125 def = CheckboxConfig
114 def = CheckboxConfig
126 { _checkboxConfig_checkboxStyle = pure def
115 { _checkboxConfig_checkboxStyle = pure def
127 , _checkboxConfig_attributes = pure V.defAttr
116 , _checkboxConfig_attributes = pure V.defAttr
128− , _checkboxConfig_setValue = never
129 }
117 }
130
118
131-- | A checkbox widget
119-- | A checkbox widget
132checkbox
120checkbox
133− :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)
121+ :: (MonadHold t m, MonadFix m, Reflex t)
134 => CheckboxConfig t
122 => CheckboxConfig t
135 -> Bool
123 -> Bool
136− -> m (Dynamic t Bool)
124+ -> VtyWidget t m (Dynamic t Bool)
137checkbox cfg v0 = do
125checkbox cfg v0 = do
138 md <- mouseDown V.BLeft
126 md <- mouseDown V.BLeft
139 mu <- mouseUp
127 mu <- mouseUp
140− space <- key (V.KChar ' ')
128+ v <- toggle v0 $ () <$ mu
141− f <- focus
142− v <- foldDyn ($) v0 $ leftmost
143− [ not <$ mu
144− , not <$ space
145− , const <$> _checkboxConfig_setValue cfg
146− ]
147− let bold = V.withStyle mempty V.bold
148 depressed <- hold mempty $ leftmost
129 depressed <- hold mempty $ leftmost
149− [ bold <$ md
130+ [ V.withStyle mempty V.bold <$ md
150 , mempty <$ mu
131 , mempty <$ mu
151 ]
132 ]
152− let focused = ffor (current f) $ \x -> if x then bold else mempty
153− let attrs = mconcat <$> sequence [_checkboxConfig_attributes cfg, depressed, focused]
133+ let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed
154 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
134 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
155 if checked
135 if checked
156− then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg
136+ then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg
157− else _checkboxStyle_unchecked <$> _checkboxConfig_checkboxStyle cfg
137+ else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg
158 return v
138 return v
src/Reflex/Vty/Widget/Input/Mouse.hsdeleted−106
@@ -1,106 +0,0 @@
1−{-|
2− Description: Mouse clicks, drags, and scrolls
3−-}
4−module Reflex.Vty.Widget.Input.Mouse where
5−
6−import Control.Monad.Fix
7−import qualified Graphics.Vty as V
8−import Reflex
9−import Reflex.Vty.Widget
10−
11−-- | Information about a drag operation
12−data Drag = Drag
13− { _drag_from :: (Int, Int) -- ^ Where the drag began
14− , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
15− , _drag_button :: V.Button -- ^ Which mouse button is dragging
16− , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
17− , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
18− }
19− deriving (Eq, Ord, Show)
20−
21−-- | Converts raw vty mouse drag events into an event stream of 'Drag's
22−drag
23− :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
24− => V.Button
25− -> m (Event t Drag)
26−drag btn = do
27− inp <- input
28− let f :: Maybe Drag -> V.Event -> Maybe Drag
29− f Nothing = \case
30− V.EvMouseDown x y btn' mods
31− | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
32− | otherwise -> Nothing
33− _ -> Nothing
34− f (Just (Drag from _ _ mods end)) = \case
35− V.EvMouseDown x y btn' mods'
36− | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
37− | btn == btn' -> Just $ Drag from (x,y) btn mods' False
38− | otherwise -> Nothing -- Ignore other buttons.
39− V.EvMouseUp x y (Just btn')
40− | end -> Nothing
41− | btn == btn' -> Just $ Drag from (x,y) btn mods True
42− | otherwise -> Nothing
43− V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
44− -- assume it's the right one.
45− | end -> Nothing
46− | otherwise -> Just $ Drag from (x,y) btn mods True
47− _ -> Nothing
48− rec let newDrag = attachWithMaybe f (current dragD) inp
49− dragD <- holdDyn Nothing $ Just <$> newDrag
50− return (fmapMaybe id $ updated dragD)
51−
52−-- | Mouse down events for a particular mouse button
53−mouseDown
54− :: (Reflex t, Monad m, HasInput t m)
55− => V.Button
56− -> m (Event t MouseDown)
57−mouseDown btn = do
58− i <- input
59− return $ fforMaybe i $ \case
60− V.EvMouseDown x y btn' mods -> if btn == btn'
61− then Just $ MouseDown btn' (x, y) mods
62− else Nothing
63− _ -> Nothing
64−
65−-- | Mouse up events for a particular mouse button
66−mouseUp
67− :: (Reflex t, Monad m, HasInput t m)
68− => m (Event t MouseUp)
69−mouseUp = do
70− i <- input
71− return $ fforMaybe i $ \case
72− V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
73− _ -> Nothing
74−
75−-- | Information about a mouse down event
76−data MouseDown = MouseDown
77− { _mouseDown_button :: V.Button
78− , _mouseDown_coordinates :: (Int, Int)
79− , _mouseDown_modifiers :: [V.Modifier]
80− }
81− deriving (Eq, Ord, Show)
82−
83−-- | Information about a mouse up event
84−data MouseUp = MouseUp
85− { _mouseUp_button :: Maybe V.Button
86− , _mouseUp_coordinates :: (Int, Int)
87− }
88− deriving (Eq, Ord, Show)
89−
90−-- | Mouse scroll direction
91−data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
92− deriving (Eq, Ord, Show)
93−
94−-- | Produce an event that fires when the mouse wheel is scrolled
95−mouseScroll
96− :: (Reflex t, Monad m, HasInput t m)
97− => m (Event t ScrollDirection)
98−mouseScroll = do
99− up <- mouseDown V.BScrollUp
100− down <- mouseDown V.BScrollDown
101− return $ leftmost
102− [ ScrollDirection_Up <$ up
103− , ScrollDirection_Down <$ down
104− ]
105−
106−
src/Reflex/Vty/Widget/Input/Text.hs+17−22
@@ -9,6 +9,7 @@ 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)
12import Data.Default (Default(..))
13import Data.Default (Default(..))
13import Data.Text (Text)
14import Data.Text (Text)
14import Data.Text.Zipper
15import Data.Text.Zipper
@@ -17,7 +18,6 @@ import Reflex
17
18
18import Reflex.Vty.Widget
19import Reflex.Vty.Widget
19import Reflex.Vty.Widget.Layout
20import 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,16 +43,14 @@ 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, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)
46+ :: (Reflex t, MonadHold t m, MonadFix m)
47 => TextInputConfig t
47 => TextInputConfig t
48− -> m (TextInput t)
48+ -> VtyWidget t 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
56 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
54 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
57 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
55 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
58 , _textInputConfig_modify cfg
56 , _textInputConfig_modify cfg
@@ -61,20 +59,13 @@ textInput cfg = do
61 goToDisplayLinePosition mx (st + my) dl
59 goToDisplayLinePosition mx (st + my) dl
62 ]
60 ]
63 click <- mouseDown V.BLeft
61 click <- mouseDown V.BLeft
64−
62+ let cursorAttrs = ffor f $ \x -> if x then cursorAttributes else V.defAttr
65− -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)
63+ let rows = (\w s c -> displayLines w V.defAttr c s)
66− let toCursorAttrs attr = V.withStyle attr V.reverseVideo
67− rowInputDyn = (,,)
68 <$> dw
64 <$> dw
69 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
65 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
70− <*> f
66+ <*> cursorAttrs
71− toDisplayLines attr (w, s, x) =
72− let c = if x then toCursorAttrs attr else attr
73− in displayLines w attr c s
74− attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)
75− let rows = ffor2 attrDyn rowInputDyn toDisplayLines
76 img = images . _displayLines_spans <$> rows
67 img = images . _displayLines_spans <$> rows
77− y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows
68+ y <- holdUniqDyn $ _displayLines_cursorY <$> rows
78 let newScrollTop :: Int -> (Int, Int) -> Int
69 let newScrollTop :: Int -> (Int, Int) -> Int
79 newScrollTop st (h, cursorY)
70 newScrollTop st (h, cursorY)
80 | cursorY < st = cursorY
71 | cursorY < st = cursorY
@@ -90,9 +81,9 @@ textInput cfg = do
90
81
91-- | A widget that allows multiline text input
82-- | A widget that allows multiline text input
92multilineTextInput
83multilineTextInput
93− :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)
84+ :: (Reflex t, MonadHold t m, MonadFix m)
94 => TextInputConfig t
85 => TextInputConfig t
95− -> m (TextInput t)
86+ -> VtyWidget t m (TextInput t)
96multilineTextInput cfg = do
87multilineTextInput cfg = do
97 i <- input
88 i <- input
98 textInput $ cfg
89 textInput $ cfg
@@ -108,18 +99,22 @@ multilineTextInput cfg = do
108-- the computed line count to greedily size the tile when vertically
99-- the computed line count to greedily size the tile when vertically
109-- oriented, and uses the fallback width when horizontally oriented.
100-- oriented, and uses the fallback width when horizontally oriented.
110textInputTile
101textInputTile
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)
102+ :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
112− => m (TextInput t)
103+ => VtyWidget t m (TextInput t)
113 -> Dynamic t Int
104 -> Dynamic t Int
114− -> m (TextInput t)
105+ -> Layout t m (TextInput t)
115textInputTile txt width = do
106textInputTile txt width = do
116 o <- askOrientation
107 o <- askOrientation
117− rec t <- tile (Constraint_Fixed <$> sz) txt
108+ rec t <- fixed sz txt
118 let sz = join $ ffor o $ \case
109 let sz = join $ ffor o $ \case
119 Orientation_Column -> _textInput_lines t
110 Orientation_Column -> _textInput_lines t
120 Orientation_Row -> width
111 Orientation_Row -> width
121 return t
112 return t
122
113
114+-- | Default attributes for the text cursor
115+cursorAttributes :: V.Attr
116+cursorAttributes = V.withStyle V.defAttr V.reverseVideo
117+
123-- | Turn a set of display line rows into a list of images (one per line)
118-- | Turn a set of display line rows into a list of images (one per line)
124images :: [[Span V.Attr]] -> [V.Image]
119images :: [[Span V.Attr]] -> [V.Image]
125images = map (V.horizCat . map spanToImage)
120images = map (V.horizCat . map spanToImage)
src/Reflex/Vty/Widget/Layout.hs+546−502
@@ -2,100 +2,94 @@
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+
7−module Reflex.Vty.Widget.Layout where
8+module Reflex.Vty.Widget.Layout
8−
9+ ( Orientation(..)
9−import Control.Applicative (liftA2)
10+ , Constraint(..)
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+
10−import Control.Monad.Morph
41+import Control.Monad.Identity (Identity (..))
11−import Control.Monad.NodeId (MonadNodeId(..), NodeId)
42+import Control.Monad.NodeId (MonadNodeId (..), NodeId)
12−import Control.Monad.Reader
43+import Control.Monad.Reader
13−import Data.List (mapAccumL)
44+import Data.Bimap (Bimap)
45+import qualified Data.Bimap as Bimap
46+import Data.Default (Default (..))
14−import Data.Map.Ordered (OMap)
47+import qualified Data.Dependent.Map as DMap
48+import Data.Dependent.Sum (DSum ((:=>)))
49+import Data.Functor
50+import Data.Functor.Misc
51+import Data.Map (Map)
15−import qualified Data.Map.Ordered as OMap
52+import qualified Data.Map as Map
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 (..))
17−import Data.Ratio ((%))
56+import Data.Ratio ((%))
18−import Data.Semigroup (First(..))
57+import Data.Semigroup (First (..))
19−import Data.Set.Ordered (OSet)
58+import Data.Traversable (mapAccumL)
20−import qualified Data.Set.Ordered as OSet
59+import qualified Data.Tree as Tree
21−import qualified Graphics.Vty as V
60+import qualified Graphics.Vty as V
22−
61+
23−import Reflex
62+import Reflex
24−import Reflex.Host.Class (MonadReflexCreateTrigger)
63+import Reflex.Host.Class (MonadReflexCreateTrigger)
25−import Reflex.Vty.Widget
26−import Reflex.Vty.Widget.Input.Mouse
64+import Reflex.Vty.Widget
27−
65+
28−-- * Focus
66+-- | The main-axis orientation of a 'Layout' widget
29−--
67+data Orientation = Orientation_Column
30−-- $focus
68+ | Orientation_Row
31−--
32−-- The focus monad tracks which element is currently focused and processes
33−-- requests to change focus. Focusable elements are assigned a 'FocusId' and
34−-- can manually request focus or receive focus due to some other action (e.g.,
35−-- a tab press in a sibling element, a click event).
36−--
37−-- Focusable elements will usually be created via 'tile', but can also be
38−-- constructed via 'makeFocus' in 'HasFocus'. The latter option allows for
39−-- more find-grained control of focus behavior.
40−
41−-- ** Storing focus state
42−
43−-- | Identifies an element that is focusable. Can be created using 'makeFocus'.
44−newtype FocusId = FocusId NodeId
45− deriving (Eq, Ord)
69+ deriving (Show, Read, Eq, Ord)
46−
70+
47−-- | An ordered set of focus identifiers. The order here determines the order
71+data LayoutSegment = LayoutSegment
48−-- in which focus cycles between focusable elements.
72+ { _layoutSegment_offset :: Int
49−newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }
73+ , _layoutSegment_size :: Int
50−
74+ }
51−instance Semigroup FocusSet where
75+
52− FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b
76+data LayoutCtx t = LayoutCtx
53−
77+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
54−instance Monoid FocusSet where
78+ , _layoutCtx_focusSelfDemux :: Demux t (Maybe NodeId)
55− mempty = FocusSet OSet.empty
79+ , _layoutCtx_orientation :: Dynamic t Orientation
56−
80+ , _layoutCtx_focusChildSelector :: EventSelector t (Const2 NodeId (Maybe Int))
57−-- | Produces a 'FocusSet' with a single element
58−singletonFS :: FocusId -> FocusSet
59−singletonFS = FocusSet . OSet.singleton
60−
61−-- ** Changing focus state
62−
63−-- | Operations that change the currently focused element.
64−data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS')
65− | Refocus_Id FocusId -- ^ Focus a particular element
66− | Refocus_Clear -- ^ Remove focus from all elements
67−
68−-- | Given a 'FocusSet', a currently focused element, and a number of positions
69−-- to move by, determine the newly focused element.
70−shiftFS :: FocusSet -> Maybe FocusId -> Int -> Maybe FocusId
71−shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
72− Nothing -> OSet.elemAt s 0
73− Just Nothing -> OSet.elemAt s 0
74− Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
75−
76−-- ** The focus management monad
77−
78−-- | A class for things that can produce focusable elements.
79−class (Monad m, Reflex t) => HasFocus t m | m -> t where
80− -- | Create a focusable element.
81− makeFocus :: m FocusId
82− -- | Emit an 'Event' of requests to change the focus.
83− requestFocus :: Event t Refocus -> m ()
84− -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused.
85− isFocused :: FocusId -> m (Dynamic t Bool)
86− -- | Run an action, additionally returning the focusable elements it produced.
87− subFoci :: m a -> m (a, Dynamic t FocusSet)
88− -- | Get a 'Dynamic' of the currently focused element identifier.
89− focusedId :: m (Dynamic t (Maybe FocusId))
90−
91−-- | A monad transformer that keeps track of the set of focusable elements and
92−-- which, if any, are currently focused, and allows focus requests.
93−newtype Focus t m a = Focus
94− { unFocus :: DynamicWriterT t FocusSet
95− (ReaderT (Dynamic t (Maybe FocusId))
96− (EventWriterT t (First Refocus) m)) a
97 }
81 }
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
98− deriving
92+ } deriving
99 ( Functor
93 ( Functor
100 , Applicative
94 , Applicative
101 , Monad
95 , Monad
@@ -106,444 +100,494 @@ newtype Focus t m a = Focus
106 , PerformEvent t
100 , PerformEvent t
107 , NotReady t
101 , NotReady t
108 , MonadReflexCreateTrigger t
102 , MonadReflexCreateTrigger t
109− , HasDisplayRegion t
103+ , HasDisplaySize t
110− , PostBuild t
111 , MonadNodeId
104 , MonadNodeId
112− , MonadIO
105+ , PostBuild t
113 )
106 )
114
107
108+instance MonadTrans (Layout t) where
109+ lift x = Layout $ lift $ lift $ lift $ lift x
115
110
116−instance MonadTrans (Focus t) where
117− lift = Focus . lift . lift . lift
118−
119−instance MFunctor (Focus t) where
120− hoist f = Focus . hoist (hoist (hoist f)) . unFocus
121−
122−instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
111+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
123− runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
112+ runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
124− traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
113+ traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
125− traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
114+ traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
126− traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
115+ traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
127−
116+
128−instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where
117+findNearestFloor_ :: (Ord k) => k -> (k, a) -> (k, a) -> Map k a -> Maybe (k, a)
129− localInput f = hoist (localInput f)
118+findNearestFloor_ target leftValue parent Map.Tip = if target < fst leftValue
130−
119+ then Nothing -- error $ "Map.findNearestFloorSure: map has no element <= " <> show target
131−instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
120+ else if target < fst parent
132− mapImages f = hoist (mapImages f)
121+ then Just leftValue
133−
122+ else Just parent
134−instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
123+findNearestFloor_ target leftValue _ (Map.Bin _ k a l r) = if target == k
135−
124+ then Just (k, a)
136−instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)
125+ else if target < k
137−
126+ then findNearestFloor_ target leftValue (k, a) l
138−instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where
127+ else findNearestFloor_ target (k, a) (k, a) r
139− makeFocus = do
128+
140− fid <- FocusId <$> lift getNextNodeId
129+findNearestFloor :: (Ord k) => k -> Map k a -> Maybe (k,a)
141− Focus $ tellDyn $ pure $ singletonFS fid
130+findNearestFloor _ Map.Tip = Nothing
142− pure fid
131+-- TODO I don't think we need to do findMin here, just pass in (k,x) as a placeholder value
143− requestFocus = Focus . tellEvent . fmap First
132+findNearestFloor target m@(Map.Bin _ k x _ _) = findNearestFloor_ target (Map.findMin m) (k, x) m
144− isFocused fid = do
133+
145− sel <- Focus ask
134+fanFocusEv :: (Reflex t) => Behavior t (Maybe (NodeId, Int)) -> Event t (Maybe (NodeId, Int)) -> EventSelector t (Const2 NodeId (Maybe Int))
146− pure $ (== Just fid) <$> sel
135+fanFocusEv focussed focusReqIx = fan $ attachWith attachfn focussed focusReqIx where
147− subFoci (Focus child) = Focus $ do
136+ attachfn mkv0 mkv1 = case mkv1 of
148− (a, fs) <- lift $ runDynamicWriterT child
137+ Nothing -> case mkv0 of
149− tellDyn fs
138+ Nothing -> DMap.empty
150− return (a, fs)
139+ Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing]
151− focusedId = Focus ask
140+ Just (k1,v1) -> case mkv0 of
152−
141+ Nothing -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
153−-- | Runs a 'Focus' action, maintaining the selection state internally.
142+ Just (k0,v0) | k0 == k1 && v0 == v1 -> DMap.empty
154−runFocus
143+ Just (k0,_) | k0 == k1 -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
155− :: (MonadFix m, MonadHold t m, Reflex t)
144+ Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing,
156− => Focus t m a
145+ Const2 k1 :=> Identity (Just v1)]
157− -> m (a, Dynamic t FocusSet)
146+
158−runFocus (Focus x) = do
147+
159− rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x
148+translateLayoutTree :: (Reflex t) => Orientation -> NodeId -> Dynamic t (Map NodeId LayoutSegment) -> Dynamic t LayoutTree -> Dynamic t LayoutTree
160− sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests
149+translateLayoutTree orient nid solutionMap dlt = ffor2 solutionMap dlt fn where
161− pure (a, focusIds)
150+ fn sm lt = result where
162− where
151+ ls = fromMaybe (error "expected result") (Map.lookup nid sm)
163− f :: (FocusSet, First Refocus) -> Maybe FocusId -> Maybe FocusId
152+ result = ffor lt $ \reg -> if orient == Orientation_Row
164− f (fs, rf) mf = case getFirst rf of
153+ then offsetRegion (_layoutSegment_offset ls, 0) reg
165− Refocus_Clear -> Nothing
154+ else offsetRegion (0, _layoutSegment_offset ls) reg
166− Refocus_Id fid -> Just fid
155+
167− Refocus_Shift n -> if n < 0 && isNothing mf
156+-- | Run a 'Layout' action
168− then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n
157+runLayoutL
169− else shiftFS fs mf n
158+ :: forall t m a. (Reflex t, MonadFix m, MonadHold t m)
170−
159+ => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
171−-- | Runs an action in the focus monad, providing it with information about
160+ -> Maybe Int -- ^ The positional index of the initially focused tile_
172−-- whether any of the foci created within it are focused.
161+ -> Layout t m a -- ^ The 'Layout' widget
173−anyChildFocused
162+ -> LayoutVtyWidget t m (LayoutReturnData t a)
174− :: (HasFocus t m, MonadFix m)
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
175− => (Dynamic t Bool -> m a)
324+ , _tile_Config_focusable :: Dynamic t Bool
176− -> m a
325+ -- ^ Whether the tile_ is focusable
177−anyChildFocused f = do
326+ }
178− fid <- focusedId
327+
179− rec (a, fs) <- subFoci (f b)
328+instance Reflex t => Default (TileConfig t) where
180− let b = liftA2 (\foc s -> case foc of
329+ def = TileConfig (pure $ Constraint_Min 0) (pure True)
181− Nothing -> False
330+
182− Just f' -> OSet.member f' $ unFocusSet s) fid fs
331+
183− pure a
332+fixed_
184−
333+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
185−-- ** Focus controls
334+ => Dynamic t Int
186−
335+ -> widget t m b
187−-- | Request focus be shifted backward and forward based on tab presses. <Tab>
336+ -> Layout t m a
188−-- shifts focus forward and <Shift+Tab> shifts focus backward.
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+
399+-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
400+-- and backward one tile when Shift+Tab is pressed.
189−tabNavigation :: (Reflex t, HasInput t m, HasFocus t m) => m ()
401+tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
190tabNavigation = do
402tabNavigation = do
191 fwd <- fmap (const 1) <$> key (V.KChar '\t')
403 fwd <- fmap (const 1) <$> key (V.KChar '\t')
192 back <- fmap (const (-1)) <$> key V.KBackTab
404 back <- fmap (const (-1)) <$> key V.KBackTab
193− requestFocus $ Refocus_Shift <$> leftmost [fwd, back]
405+ return $ leftmost [fwd, back]
194−
406+
195−-- * Layout
407+-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
196−--
408+-- requesting focus when using 'tile'.
197−-- $layout
409+clickable
198−-- The layout monad keeps track of a tree of elements, each having its own
410+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m)
199−-- layout constraints and orientation. Given the available rendering space, it
411+ => widget t m a
200−-- computes a layout solution and provides child elements with their particular
412+ -> LayoutVtyWidget t m (Event t (), a)
201−-- layout solution (the width and height of their rendering space).
413+clickable child = LayoutVtyWidget . ReaderT $ \focusEv -> do
202−--
414+ click <- mouseDown V.BLeft
203−-- Complex layouts are built up though some combination of:
415+ a <- runIsLayoutVtyWidget child focusEv
204−--
416+ return (() <$ click, a)
205−-- - 'axis', which lays out its children in a particular orientation, and
417+
206−-- - 'region', which "claims" some part of the screen according to its constraints
418+-- | create a focus event (to be used with runIsLayoutVtyWidget) from a navigation event
207−--
419+layoutFocusEvFromNavigation
208−
420+ :: (Reflex t)
209−-- ** Layout restrictions
421+ => Event t Int
210−
422+ -> Event t ()
211−-- *** Constraints
423+ -> LayoutReturnData t a
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
212
474
213-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
475-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
214data Constraint = Constraint_Fixed Int
476data Constraint = Constraint_Fixed Int
215 | Constraint_Min Int
477 | Constraint_Min Int
216 deriving (Show, Read, Eq, Ord)
478 deriving (Show, Read, Eq, Ord)
217
479
218−-- | Shorthand for constructing a fixed constraint
480+-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
219−fixed
481+computeSizes
220− :: Reflex t
482+ :: Int
221− => Dynamic t Int
483+ -> Map k (a, Constraint)
222− -> Dynamic t Constraint
484+ -> Map k (a, Int)
485+computeSizes available constraints =
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
223−fixed = fmap Constraint_Fixed
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
224
499
225−-- | Shorthand for constructing a minimum size constraint
500+computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
226−stretch
501+computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
227− :: Reflex t
502+ (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
228− => Dynamic t Int
229− -> Dynamic t Constraint
230−stretch = fmap Constraint_Min
231
503
232−-- | Shorthand for constructing a constraint of no minimum size
233−flex
234− :: Reflex t
235− => Dynamic t Constraint
236−flex = pure $ Constraint_Min 0
237
504
238−-- *** Orientation
239
505
240−-- | The main-axis orientation of a 'Layout' widget
506+offsetRegion :: (Int, Int) -> Region -> Region
241−data Orientation = Orientation_Column
507+offsetRegion (x,y) reg = reg {
242− | Orientation_Row
508+ _region_left = x+x'
243− deriving (Show, Read, Eq, Ord)
509+ , _region_top = y+y'
510+ } where
511+ x' = _region_left reg
512+ y' = _region_top reg
244
513
245−-- | Create a row-oriented 'axis'
514+-- | Dynamic sizing information on a layout hierarchy (intended for testing)
246−row
515+type LayoutTree = Tree.Tree Region
247− :: (Reflex t, MonadFix m, HasLayout t m)
248− => m a
249− -> m a
250−row = axis (pure Orientation_Row) flex
251
516
252−-- | Create a column-oriented 'axis'
517+emptyLayoutTree :: LayoutTree
253−col
518+emptyLayoutTree = Tree.Node (Region 0 0 0 0) []
254− :: (Reflex t, MonadFix m, HasLayout t m)
255− => m a
256− -> m a
257−col = axis (pure Orientation_Column) flex
258−
259−-- ** Layout management data
260−
261−-- | A collection of information related to the layout of the screen. The root
262−-- node is a "parent" widget, and the contents of the 'LayoutForest' are its
263−-- children.
264−data LayoutTree a = LayoutTree a (LayoutForest a)
265− deriving (Show)
266−
267−-- | An ordered, indexed collection of 'LayoutTree's representing information
268−-- about the children of some widget.
269−newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }
270− deriving (Show)
271−
272−instance Semigroup (LayoutForest a) where
273− LayoutForest a <> LayoutForest b = LayoutForest $ a OMap.|<> b
274−
275−instance Monoid (LayoutForest a) where
276− mempty = LayoutForest OMap.empty
277−
278−-- | Perform a lookup by 'NodeId' in a 'LayoutForest'
279−lookupLF :: NodeId -> LayoutForest a -> Maybe (LayoutTree a)
280−lookupLF n (LayoutForest a) = OMap.lookup n a
281−
282−-- | Create a 'LayoutForest' with one element
283−singletonLF :: NodeId -> LayoutTree a -> LayoutForest a
284−singletonLF n t = LayoutForest $ OMap.singleton (n, t)
285−
286−-- | Produce a 'LayoutForest' from a list. The order of the list is preserved.
287−fromListLF :: [(NodeId, LayoutTree a)] -> LayoutForest a
288−fromListLF = LayoutForest . OMap.fromList
289−
290−-- | Extract the information at the root of a 'LayoutTree'
291−rootLT :: LayoutTree a -> a
292−rootLT (LayoutTree a _) = a
293−
294−-- | Extract the child nodes of a 'LayoutTree'
295−childrenLT :: LayoutTree a -> LayoutForest a
296−childrenLT (LayoutTree _ a) = a
297−
298−-- | Produce a layout solution given a starting orientation, the overall screen
299−-- size, and a set of constraints.
300−solve
301− :: Orientation
302− -> Region
303− -> LayoutForest (Constraint, Orientation)
304− -> LayoutTree (Region, Orientation)
305−solve o0 r0 (LayoutForest cs) =
306− let a = map (\(x, t@(LayoutTree (c, _) _)) -> ((x, t), c)) $ OMap.assocs cs
307− extent = case o0 of
308− Orientation_Row -> _region_width r0
309− Orientation_Column -> _region_height r0
310− sizes = computeEdges $ computeSizes extent a
311− chunks = [ (nodeId, solve o1 r1 f)
312− | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes
313− , let r1 = chunk o0 r0 sz
314− ]
315− in LayoutTree (r0, o0) $ fromListLF chunks
316− where
317− computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
318− computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
319− (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
320− computeSizes
321− :: Int
322− -> [(a, Constraint)]
323− -> [(a, Int)]
324− computeSizes available constraints =
325− -- The minimum amount of space we need. Calculated by adding up all of
326− -- the fixed size items and all the minimum sizes of stretchable items
327− let minTotal = sum $ ffor constraints $ \case
328− (_, Constraint_Fixed n) -> n
329− (_, Constraint_Min n) -> n
330− -- The leftover space is the area we can allow stretchable items to
331− -- expand into
332− leftover = max 0 (available - minTotal)
333− -- The number of stretchable items that will try to share some of the
334− -- leftover space
335− numStretch = length $ filter (isMin . snd) constraints
336− -- Space to allocate to the stretchable items (this is the same for all
337− -- items and there may still be additional leftover space that will have
338− -- to be unevenly distributed)
339− szStretch = floor $ leftover % max numStretch 1
340− -- Remainder of available space after even distribution. This extra space
341− -- will be distributed to as many stretchable widgets as possible.
342− adjustment = max 0 $ available - minTotal - szStretch * numStretch
343− in snd $ mapAccumL (\adj (a, c) -> case c of
344− Constraint_Fixed n -> (adj, (a, n))
345− Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints
346− isMin (Constraint_Min _) = True
347− isMin _ = False
348−
349−-- | Produce a 'Region' given a starting orientation and region, and the offset
350−-- and main-axis size of the chunk.
351−chunk :: Orientation -> Region -> (Int, Int) -> Region
352−chunk o r (offset, sz) = case o of
353− Orientation_Column -> r
354− { _region_top = _region_top r + offset
355− , _region_height = sz
356− }
357− Orientation_Row -> r
358− { _region_left = _region_left r + offset
359− , _region_width = sz
360− }
361
519
362−-- ** The layout monad
520+dynLayoutTreeInDynRegion :: (Reflex t) => DynRegion t -> Dynamic t LayoutTree -> Dynamic t LayoutTree
363−
521+dynLayoutTreeInDynRegion DynRegion {..} dlt = ffor3 _dynRegion_left _dynRegion_top dlt $ \x y lt -> fmap (offsetRegion (x,y)) lt
364−-- | A class of operations for creating screen layouts.
522+
365−class Monad m => HasLayout t m | m -> t where
523+infix 9 !!?
366− -- | Starts a parent element in the current layout with the given size
524+(!!?) :: [a] -> Int -> Maybe a
367− -- constraint, which lays out its children according to the provided
525+(!!?) xs i
368− -- orientation.
526+ | i < 0 = Nothing
369− axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
527+ | otherwise = go i xs
370− -- | Creates a child element in the current layout with the given size
528+ where
371− -- constraint, returning the 'Region' that the child element is allocated.
529+ go :: Int -> [a] -> Maybe a
372− region :: Dynamic t Constraint -> m (Dynamic t Region)
530+ go 0 (x:_) = Just x
373− -- | Returns the orientation of the containing 'axis'.
531+ go j (_:ys) = go (j - 1) ys
374− askOrientation :: m (Dynamic t Orientation)
532+ go _ [] = Nothing
375−
533+{-# INLINE (!!?) #-}
376−-- | A monad transformer that collects layout constraints and provides a layout
534+
377−-- solution that satisfies those constraints.
535+-- | gives top left corner of the cell following directions
378−newtype Layout t m a = Layout
536+layoutTreeCellToPosition :: [Int] -> LayoutTree -> Maybe (Int, Int)
379− { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))
537+layoutTreeCellToPosition [] (Tree.Node region _) = Just (_region_left region, _region_top region)
380− (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a
538+layoutTreeCellToPosition (x:xs) (Tree.Node _ kiddos) = kiddos !!? x >>= layoutTreeCellToPosition xs
539+
540+class IsLayoutReturn t b a where
541+ getLayoutResult :: b -> a
542+ getLayoutNumChildren :: b -> Dynamic t Int
543+ getLayoutFocussedDyn :: b -> Dynamic t (Maybe Int)
544+ getLayoutTree :: b -> Dynamic t LayoutTree
545+
546+data LayoutReturnData t a = LayoutReturnData {
547+ _layoutReturnData_tree :: Dynamic t LayoutTree
548+ , _layoutReturnData_focus :: Dynamic t (Maybe Int)
549+ , _layoutReturnData_children :: Dynamic t Int
550+ , _layoutReturnData_value :: a
381 }
551 }
552+
553+instance IsLayoutReturn t (LayoutReturnData t a) a where
554+ getLayoutResult lrd = _layoutReturnData_value lrd
555+ getLayoutNumChildren lrd = _layoutReturnData_children lrd
556+ getLayoutFocussedDyn lrd = _layoutReturnData_focus lrd
557+ getLayoutTree lrd = _layoutReturnData_tree lrd
558+
559+instance Reflex t => IsLayoutReturn t a a where
560+ getLayoutResult = id
561+ getLayoutNumChildren _ = 1
562+ getLayoutFocussedDyn _ = constDyn Nothing
563+ getLayoutTree _ = constDyn emptyLayoutTree
564+
565+class IsLayoutVtyWidget l t m where
566+ runIsLayoutVtyWidget :: l t m a -> Event t (Maybe Int) -> VtyWidget t m a
567+
568+newtype LayoutVtyWidget t m a = LayoutVtyWidget {
569+ unLayoutVtyWidget :: ReaderT (Event t (Maybe Int)) (VtyWidget t m) a
382− deriving
570+ } deriving
383 ( Functor
571 ( Functor
384 , Applicative
572 , Applicative
385− , HasDisplayRegion t
386 , Monad
573 , Monad
387− , MonadFix
388 , MonadHold t
574 , MonadHold t
389− , MonadIO
390− , MonadNodeId
391− , MonadReflexCreateTrigger t
392 , MonadSample t
575 , MonadSample t
393− , NotReady t
576+ , MonadFix
577+ , TriggerEvent t
394 , PerformEvent t
578 , PerformEvent t
579+ , NotReady t
580+ , MonadReflexCreateTrigger t
581+ , HasDisplaySize t
582+ , MonadNodeId
395 , PostBuild t
583 , PostBuild t
396− , TriggerEvent t
397 )
584 )
398
585
399−instance MonadTrans (Layout t) where
586+instance MonadTrans (LayoutVtyWidget t) where
400− lift = Layout . lift . lift
587+ lift x = LayoutVtyWidget $ lift $ lift x
401−
402−instance MFunctor (Layout t) where
403− hoist f = Layout . hoist (hoist f) . unLayout
404
588
405−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
589+instance IsLayoutVtyWidget VtyWidget t m where
406− runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
590+ runIsLayoutVtyWidget w _ = w
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
410
591
411−-- | Apply a transformation to the context of a child 'Layout' action and run
592+instance IsLayoutVtyWidget LayoutVtyWidget t m where
412−-- that action
593+ runIsLayoutVtyWidget = runReaderT . unLayoutVtyWidget
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.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-|
2− Description: Widgets that split the display vertically or horizontally.
3−-}
4−module Reflex.Vty.Widget.Split where
5−
6−import Control.Applicative
7−import Control.Monad.Fix
8−import Graphics.Vty as V
9−import Reflex
10−import Reflex.Vty.Widget
11−import Reflex.Vty.Widget.Input.Mouse
12−
13−-- | A split of the available space into two parts with a draggable separator.
14−-- Starts with half the space allocated to each, and the first pane has focus.
15−-- Clicking in a pane switches focus.
16−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
17− => m ()
18− -> m a
19− -> m b
20− -> m (a,b)
21−splitVDrag wS wA wB = do
22− dh <- displayHeight
23− dw <- displayWidth
24− h0 <- sample $ current dh -- TODO
25− dragE <- drag V.BLeft
26− let splitter0 = h0 `div` 2
27− rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
28− splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
29− splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
30− fromIntegral x / max 1 (fromIntegral h)
31− let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
32− \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
33− if splitterY == fromY then Just (toY, end) else Nothing
34− regA = Region 0 0 <$> dw <*> splitterPos
35− regS = Region 0 <$> splitterPos <*> dw <*> 1
36− regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1)
37− resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
38− \(frac, h) -> round (frac * fromIntegral h)
39− focA <- holdDyn True $ leftmost
40− [ True <$ mA
41− , False <$ mB
42− ]
43− (mA, rA) <- pane regA focA $ withMouseDown wA
44− pane regS (pure False) wS
45− (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
46− return (rA, rB)
47− where
48− withMouseDown x = do
49− m <- mouseDown V.BLeft
50− x' <- x
51− return (m, x')
52−
53−-- | A plain split of the available space into vertically stacked panes.
54−-- No visual separator is built in here.
55−splitV :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
56− => Dynamic t (Int -> Int)
57− -- ^ Function used to determine size of first pane based on available size
58− -> Dynamic t (Bool, Bool)
59− -- ^ How to focus the two sub-panes, given that we are focused.
60− -> m a
61− -- ^ Widget for first pane
62− -> m b
63− -- ^ Widget for second pane
64− -> m (a,b)
65−splitV sizeFunD focD wA wB = do
66− dw <- displayWidth
67− dh <- displayHeight
68− let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh)
69− regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA)
70− ra <- pane regA (fst <$> focD) wA
71− rb <- pane regB (snd <$> focD) wB
72− return (ra,rb)
73−
74−-- | A plain split of the available space into horizontally stacked panes.
75−-- No visual separator is built in here.
76−splitH :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
77− => Dynamic t (Int -> Int)
78− -- ^ Function used to determine size of first pane based on available size
79− -> Dynamic t (Bool, Bool)
80− -- ^ How to focus the two sub-panes, given that we are focused.
81− -> m a
82− -- ^ Widget for first pane
83− -> m b
84− -- ^ Widget for second pane
85− -> m (a,b)
86−splitH sizeFunD focD wA wB = do
87− dw <- displayWidth
88− dh <- displayHeight
89− let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh
90− regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh
91− liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
92−
src/Reflex/Vty/Widget/Text.hsdeleted−106
@@ -1,106 +0,0 @@
1−{-|
2− Description: Text- and character-rendering widgets
3−-}
4−module Reflex.Vty.Widget.Text where
5−
6−import Control.Monad.Fix
7−import Data.Default
8−import Data.Text (Text)
9−import qualified Data.Text as T
10−import Data.Text.Zipper as TZ
11−import qualified Graphics.Vty as V
12−import Reflex
13−import Reflex.Vty.Widget
14−import Reflex.Vty.Widget.Input.Mouse
15−
16−-- | Fill the background with a particular character.
17−fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()
18−fill bc = do
19− dw <- displayWidth
20− dh <- displayHeight
21− bt <- theme
22− let fillImg =
23− (\attr w h c -> [V.charFill attr c w h])
24− <$> bt
25− <*> current dw
26− <*> current dh
27− <*> bc
28− tellImages fillImg
29−
30−-- | Configuration options for displaying "rich" text
31−data RichTextConfig t = RichTextConfig
32− { _richTextConfig_attributes :: Behavior t V.Attr
33− }
34−
35−instance Reflex t => Default (RichTextConfig t) where
36− def = RichTextConfig $ pure V.defAttr
37−
38−
39−-- TODO delete this and use new local theming
40−-- | A widget that displays text with custom time-varying attributes
41−richText
42− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
43− => RichTextConfig t
44− -> Behavior t Text
45− -> m ()
46−richText cfg t = do
47− dw <- displayWidth
48− let img = (\w a s -> [wrapText w a s])
49− <$> current dw
50− <*> _richTextConfig_attributes cfg
51− <*> t
52− tellImages img
53− where
54− wrapText maxWidth attrs = V.vertCat
55− . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
56− . T.split (=='\n')
57−
58−-- | Renders text, wrapped to the container width
59−text
60− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
61− => Behavior t Text
62− -> m ()
63−text t = do
64− bt <- theme
65− richText (RichTextConfig bt) t
66−
67−-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
68−-- that are hidden)
69−scrollableText
70− :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)
71− => Event t Int
72− -- ^ Number of lines to scroll by
73− -> Behavior t Text
74− -> m (Behavior t (Int, Int))
75− -- ^ (Current scroll position, total number of lines)
76−scrollableText scrollBy t = do
77− dw <- displayWidth
78− bt <- theme
79− let imgs = wrap <$> bt <*> current dw <*> t
80− kup <- key V.KUp
81− kdown <- key V.KDown
82− m <- mouseScroll
83− let requestedScroll :: Event t Int
84− requestedScroll = leftmost
85− [ 1 <$ kdown
86− , (-1) <$ kup
87− , ffor m $ \case
88− ScrollDirection_Up -> (-1)
89− ScrollDirection_Down -> 1
90− , scrollBy
91− ]
92− updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
93− lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
94− attach (length <$> imgs) requestedScroll
95− tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
96− return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
97− where
98− wrap attr maxWidth = concatMap (fmap (V.string attr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
99−
100−-- | Renders any behavior whose value can be converted to
101−-- 'String' as text
102−display
103− :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
104− => Behavior t a
105− -> m ()
106−display a = text $ T.pack . show <$> a
test/Data/Text/ZipperSpec.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−module Data.Text.ZipperSpec(
4− spec
5−) where
6−
7−import Prelude
8−
9−import Test.Hspec
10−
11−import qualified Data.Map as Map
12−import qualified Data.Text as T
13−import Control.Monad
14−
15−import Data.Text.Zipper
16−
17−
18−someSentence = "12345 1234 12"
19−
20−splitSentenceAtDisplayWidth :: Int -> T.Text -> [(T.Text, Bool)]
21−splitSentenceAtDisplayWidth w t = splitWordsAtDisplayWidth w (wordsWithWhitespace t)
22−
23−spec :: Spec
24−spec =
25− describe "Zipper" $ do
26− it "wordsWithWhitespace" $ do
27− wordsWithWhitespace "" `shouldBe` []
28− wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]
29− wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"]
30− wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "]
31− it "splitWordsAtDisplayWidth" $ do
32− fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"]
33− fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"]
34− fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"]
35− fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"]
36− fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 "," 56"]
37− fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4","5 6 7 8", "9 1"]
38− it "wrapWithOffsetAndAlignment" $ do
39− wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]
40− wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]
41− wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]
42− wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]
43−
44− -- leading spaces and offset case
45− wrapWithOffsetAndAlignment TextAlignment_Left 5 1 (" " <> someSentence) `shouldBe` [(WrappedLine " " True 0), (WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]
46− it "eolSpacesToLogicalLines" $ do
47− eolSpacesToLogicalLines
48− [
49− [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]
50− , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]
51− ]
52− `shouldBe`
53− [
54− [ ("😱",1) ]
55− , [ ("😱",2), ("😱",3) ]
56− , [ ("aa",1) ]
57− , [ ("aa",2) ]
58− , [ ("aa",3) ]
59− ]
60− it "offsetMapWithAlignmentInternal" $ do
61− offsetMapWithAlignmentInternal
62− [
63− [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]
64− , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]
65− ]
66− `shouldBe`
67− Map.fromList
68− [ (0, (1,0))
69− , (1, (2,2)) -- jump by 1 for char and 1 for space
70− , (2, (3,3)) -- jump by 1 for char
71− , (3, (1,5)) -- jump by 1 for char and 1 for newline
72− , (4, (2,8)) -- jump by 2 for char and 1 for space
73− , (5, (3,11)) -- jump by 2 for char and 1 for space
74− ]
75− it "displayLines - cursorPos" $ do
76− let
77− dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")
78− dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu")
79− dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n")
80− dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "0123456789")
81− dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (insertChar 'a' $ fromText "aoeu")
82− dl5 = displayLinesWithAlignment TextAlignment_Right 10 () () (left $ insertChar 'a' $ fromText "aoeu")
83− dl6 = displayLinesWithAlignment TextAlignment_Right 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")
84− _displayLines_cursorPos dl0 `shouldBe` (0,0)
85− _displayLines_cursorPos dl1 `shouldBe` (4,0)
86− _displayLines_cursorPos dl2 `shouldBe` (0,1)
87− _displayLines_cursorPos dl3 `shouldBe` (0,1)
88− _displayLines_cursorPos dl4 `shouldBe` (5,0)
89− _displayLines_cursorPos dl5 `shouldBe` (4,0)
90− _displayLines_cursorPos dl6 `shouldBe` (4,0)
91− it "displayLines - offsetMap" $ do
92− let
93− dl0 = displayLinesWithAlignment TextAlignment_Left 5 () () (end $ fromText "aoeku")
94− _displayLines_cursorPos dl0 `shouldBe` (0,1)
95− Map.size (_displayLines_offsetMap dl0) `shouldBe` 2 -- cursor character is on second line
96− it "displayLinesWithAlignment - spans" $ do
97− let
98− someText = top $ fromText "0123456789abcdefgh"
99− -- outer span length should be invariant when changing TextAlignment and CursorPosition
100− forM_ [0..4] $ \x -> do
101− forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do
102− let t = rightN x $ someText
103− length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4
104− length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2
test/Spec.hsdeleted−15
@@ -1,15 +0,0 @@
1−-- hspec auto-discovery stuff
2−-- does not work with current CircleCI image so instead we do it manually for now
3−-- {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
4−
5−
6−import Test.Hspec
7−
8−import qualified Data.Text.ZipperSpec
9−
10−main :: IO ()
11−main = hspec spec
12−
13−spec :: Spec
14−spec = do
15− describe "Data.Text.ZipperSpec" Data.Text.ZipperSpec.spec