git.iko.soy/vty
on master help sign in
swap
4a29aec362 ahead, 0 behind
.gitignore+1
since splitsnapshots
unifiedsplit
@@ -6,6 +6,7 @@ Setup
6dist
6dist
7dist-newstyle
7dist-newstyle
8cabal.project.local
8cabal.project.local
9+.ghc.environment.*
9test/benchmark
10test/benchmark
10.hpc
11.hpc
11.cabal-sandbox
12.cabal-sandbox
.travis.yml+100−18
@@ -1,27 +1,109 @@
1+# This Travis job script has been generated by a script via
2+#
3+# runghc make_travis_yml_2.hs 'vty.cabal'
4+#
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
1−language: haskell
7+language: c
8+sudo: false
2
9
3−notifications:
10+git:
4− email: false
11+ submodules: false # whether to recursively clone submodules
12+
13+cache:
14+ directories:
15+ - $HOME/.cabal/packages
16+ - $HOME/.cabal/store
17+
18+before_cache:
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
20+ # remove files that are regenerated by 'cabal update'
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26+
27+ - rm -rfv $HOME/.cabal/packages/head.hackage
5
28
6matrix:
29matrix:
7− allow_failures:
30+ include:
8− - env: CABALVER=head GHCVER=head
31+ - compiler: "ghc-8.4.3"
32+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
33+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
34+ - compiler: "ghc-8.2.2"
35+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
36+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}
37+ - compiler: "ghc-8.0.2"
38+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
39+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}
40+ - compiler: "ghc-7.10.3"
41+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
42+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}
9
43
10−env:
44+before_install:
11− - CABALVER=1.20 GHCVER=7.6.3
45+ - HC=${CC}
12− - CABALVER=1.20 GHCVER=7.8.3
46+ - HCPKG=${HC/ghc/ghc-pkg}
13− - CABALVER=1.22 GHCVER=7.10.1
47+ - unset CC
14− - CABALVER=1.24 GHCVER=8.0.1
48+ - ROOTDIR=$(pwd)
15− - CABALVER=head GHCVER=head
49+ - mkdir -p $HOME/.local/bin
50+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
51+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
52+ - echo $HCNUMVER
16
53
17install:
54install:
18− - ./ci/travis_ci_install
55+ - cabal --version
56+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
57+ - BENCH=${BENCH---enable-benchmarks}
58+ - TEST=${TEST---enable-tests}
59+ - HADDOCK=${HADDOCK-true}
60+ - UNCONSTRAINED=${UNCONSTRAINED-true}
61+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
62+ - GHCHEAD=${GHCHEAD-false}
63+ - travis_retry cabal update -v
64+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
65+ - rm -fv cabal.project cabal.project.local
66+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
67+ - "printf 'packages: \".\"\\n' > cabal.project"
68+ - touch cabal.project.local
69+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- vty | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
70+ - cat cabal.project || true
71+ - cat cabal.project.local || true
72+ - if [ -f "./configure.ac" ]; then
73+ (cd "." && autoreconf -i);
74+ fi
75+ - rm -f cabal.project.freeze
76+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
77+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
78+ - rm -rf .ghc.environment.* "."/dist
79+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
19
80
81+# Here starts the actual work to be performed for the package under test;
82+# any command which exits with a non-zero exit code causes the build to fail.
20script:
83script:
21− - ./ci/travis_ci_script
84+ # test that source-distributions can be generated
85+ - (cd "." && cabal sdist)
86+ - mv "."/dist/vty-*.tar.gz ${DISTDIR}/
87+ - cd ${DISTDIR} || false
88+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
89+ - "printf 'packages: vty-*/*.cabal\\n' > cabal.project"
90+ - touch cabal.project.local
91+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- vty | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
92+ - cat cabal.project || true
93+ - cat cabal.project.local || true
94+ # this builds all libraries and executables (without tests/benchmarks)
95+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
22
96
23−before_install:
97+ # build & run tests, build benchmarks
24− - sudo add-apt-repository -y ppa:hvr/ghc
98+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
25− - sudo apt-get update
99+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
26− - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
100+
27− - export PATH=/opt/ghc/$GHCVER/bin:$PATH
101+ # haddock
102+ - rm -rf ./dist-newstyle
103+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
104+
105+ # Build without installed constraints for packages in global-db
106+ - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi
107+
108+# REGENDATA ["vty.cabal"]
109+# EOF
CHANGELOG.md+782−329
@@ -1,408 +1,861 @@
1+
2+5.35.1
3+------
4+
5+Bug fixes:
6+ * Fixed a build issue with a test program.
7+
8+5.35
9+----
10+
11+New features:
12+ * Add support for 24-bit color (thanks @u-quark). This change
13+ updates Vty to look at the `COLORTERM` environment variable that is
14+ conventionally used to advertise support for truecolor escape
15+ sequences. The change also updates the Vty demo to demonstrate
16+ 24-bit colors. This change also adds a new data type, `ColorMode`,
17+ to represent the color mode in use, as well as an `Output` interface
18+ field, `outputColorMode`, to track the active color mode and use it
19+ to clamp emitted color escape sequences to the active color range.
20+
21+API changes:
22+ * All types in `Graphics.Vty.Input.Events` now have strict constructor
23+ fields.
24+ * Internal events are now wrapped in a new `InternalEvent` type to
25+ improve how signal handling is done. This change modifies the `Input`
26+ type's event channel API to produce `InternalEvents`, not `Events`.
27+ The new `InternalEvent` either wraps `Event` with the `InputEvent`
28+ constructor (the previous behavior) or indicates that Vty resumed
29+ after handling a signal using the `ResumeAfterSignal` constructor.
30+ This change avoids the previous use of `EvResize` with lazy exception
31+ arguments as a sentinel value for `ResumeAfterSignal`.
32+
33+Other enhancements:
34+ * Bracketed paste parsing performance has been greatly improved thanks
35+ to benchmarking and optimization work by @iphydf. As part of that
36+ work, Vty now uses bytestrings rather than Strings internally when
37+ parsing input to look for events.
38+ * The `\b` value is now interpreted as `KBS` (thanks @vglfr)
39+
40+5.34
41+----
42+
43+API changes:
44+ * Added an `NFData` instance for `Event` (thanks Mario Lang)
45+ * Removed `Monoid` and `Semigroup` instances for `Attr` and
46+ `MaybeDefault`. This change removed the instances because they were
47+ misbehaved; merging `Attr` and `MaybeDefault` values with these
48+ instances resulted in field value losses. For example, before this
49+ change,
50+```
51+(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)
52+```
53+ would result in just
54+```
55+ (defAttr `withBackColor` green)
56+```
57+ because the instances were designed to favor the right-hand
58+ arguments' fields even if they had not been explicitly set
59+ (a consequence of the `MaybeDefault` `Semigroup` instance).
60+ While that behavior was sensible specifically in the context of
61+ `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made
62+ for surprising instance behavior. Since there is actually no good way
63+ to handle this in a `Semigroup` instance for `Attr` -- some choices
64+ have to be made about how to merge two attributes' foreground colors,
65+ and that won't be much better than what we had -- the instance was
66+ just removed.
67+
68+
69+5.33
70+----
71+
72+API changes:
73+* The `Cursor` type got a new `PositionOnly` constructor for cursor
74+ placement without visibility.
75+
76+Package changes:
77+* Relaxed upper bound for `random`
78+* Updated `microlens` bounds to allow 0.4.12
79+
80+Other improvements:
81+* Various hlint-driven improvements (thanks Willem Van Onsem)
82+* The implementation of `color240` was improved (thanks (Willem Van
83+ Onsem)
84+
85+5.32
86+----
87+
88+New features:
89+ * Meta-PageUp and Meta-PageDown are now supported (#193)
90+ * Added `supportsItalics` and `supportsStrikethrough` functions to
91+ check for feature support in terminfo
92+
93+Bug fixes:
94+ * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka
95+ Nkurumeh)
96+
97+5.31
98+----
99+
100+New features and API changes:
101+ * Added support for strikethrough mode. This change adds a new
102+ `strikethrough` `Style` value and uses the `smxx` and `rmxx`
103+ Terminfo capabilities to activate and deactivate strikethrough mode,
104+ respectively. If the terminfo does not report those capabilities,
105+ this style is ignored.
106+ * `Output`: added the `setDisplayBounds` field to set the output
107+ dimensions of the output handle; added an implementation of this for
108+ the `TerminfoBased` backend.
109+
110+Other changes:
111+ * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.
112+
113+5.30
114+----
115+
116+New features:
117+ * Added `Graphics.Vty.setWindowTitle` to emit an escape
118+ sequence to set the window title, provide the terminal emulator
119+ accepts Xterm-style title sequences. For details, see:
120+ https://tldp.org/HOWTO/Xterm-Title-3.html
121+
122+5.29
123+----
124+
125+API changes:
126+ * The Input type got a new field, 'restoreInputState'. This field
127+ allows the end user to have direct access to the logic needed to
128+ restore the terminal's input state flags. Prior to having this field,
129+ this state restoration logic could only be invoked as part of calling
130+ 'shutdownInput', but since that function does other things (like
131+ killing threads) it is not advisable to call it repeatedly (which is
132+ necessary in the use case this change is intended to support). This
133+ can be called directly to restore the input state flags as needed,
134+ although this is not required if 'shutdown' (or 'shutdownInput') is
135+ called.
136+
137+Other changes:
138+ * attributeControl: explicitly enable the ICRNL terminal mode flag (see
139+ #187 and c572ad).
140+
141+5.28.2
142+------
143+
144+Bug fixes:
145+ * Added a package dependency on `semigroups` for the
146+ `vty-build-width-table` tool on older GHCs (#185)
147+
148+5.28.1
149+------
150+
151+Bug fixes:
152+ * `installUnicodeWidthTable`: use `throwIO`, not `throw`
153+
154+5.28
155+----
156+
157+This release improves Vty's support for multi-column Unicode characters
158+and provides greater compatibility with a wider array of terminal
159+emulators. The following sections summarize the relevant changes, but an
160+overview of the new functionality is motivated and detailed in the new
161+"Multi-Column Character Support" README section. For
162+historical context, please also consider reading over
163+[#175](https://github.com/jtdaugherty/vty/issues/175).
164+
165+API changes:
166+ * New modules were added:
167+ * `Graphics.Vty.UnicodeWidthTable.Types`
168+ * `Graphics.Vty.UnicodeWidthTable.IO`
169+ * `Graphics.Vty.UnicodeWidthTable.Query`
170+ * `Graphics.Vty.UnicodeWidthTable.Install`
171+ * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,
172+ that controls whether `mkVty` will attempt to load a Unicode width
173+ table if specified in the configuration.
174+
175+Configuration file changes:
176+ * A new syntax was added to support specifying Unicode width tables on
177+ a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the
178+ documentation for `Graphics.Vty.Config` for details. Since prior
179+ versions of this library will silently ignore any configuration file
180+ lines they cannot parse, this change to user configuration files is
181+ at least non-breaking for older versions of Vty.
182+
183+Other changes:
184+ * The `mkVty` function now automatically attempts to load a custom
185+ Unicode width table if one is specified in the configuration,
186+ provided `allowCustomUnicodeWidthTables` is not set to `Just False`.
187+ See the documentation for `Graphics.Vty.mkVty` for details.
188+ * Vty now includes a command line tool, `vty-build-width-table`, that
189+ queries the terminal emulator to construct a custom Unicode width
190+ table and optionally update the Vty configuration file to use it.
191+ Programs that want to use that tool's functionality may also do so
192+ via the API exposed in the various modules listed above.
193+
194+5.27
195+----
196+
197+* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the
198+ kernel for the current terminal's settings to obtain the character
199+ assigned by the `stty erase` command. That can then be added to the
200+ Vty configuration's input map to map to `KBS` (backspace) if desired.
201+
202+5.26
203+----
204+
205+* Resolved various import warnings (thanks @glguy)
206+* Removed the `MonadIO` constraint from the Output type's fields and
207+ removed `MonadFail` uses (PR #177, thanks @glguy)
208+* Clarified documentation for ANSI colors (thanks Colby Jenn)
209+* `Graphics.Vty.Attributes` no longer re-exports
210+ `Graphics.Vty.Attributes.Color`
211+* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks
212+ Colby Jenn)
213+* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)
214+* Changed from using `System.Posix.Env.getEnv` to
215+ `System.Environment.lookupEnv` (thanks Jonathan Osser)
216+* Added `Graphics.Vty.Image` functions for dealing with character width
217+ computations on `Text` values instead of `Strings`:
218+ * `safeWctwidth`
219+ * `safeWctlwidth`
220+ * `wctwidth`
221+ * `wctlwidth`
222+
223+5.25.1
224+------
225+
226+* Avoided a conflict with a Microlens 0.4.10 operator and added an
227+ upper bound on Microlens of 0.4.11.
228+
229+5.25
230+----
231+
232+* The Vty type got a new field, isShutdown, that returns whether the
233+ Vty handle has had its 'shutdown' function called (thanks Ian
234+ Jeffries)
235+* Vty's shutdown function is now thread-safe.
236+
237+5.24.1
238+------
239+
240+* The "shutdown" method of Vty handles is now idempotent (#159)
241+
242+5.24
243+----
244+
245+* Add Generic and NFData instances for some types
246+* Image: remove custom Show instance, add derived Show and Read
247+ instances
248+* Updated Travis build settings (thanks Eric Mertens)
249+
250+5.23.1
251+------
252+
253+* Fixed a bug where italics did not combine properly with other display
254+ modes (#155, thanks Eric Mertens)
255+
256+5.23
257+----
258+
259+* Added support for italicized output when terminfo supports it. This
260+ takes the form of a new Style, "italic". Note that most terminfo
261+ descriptors do not report capabilities for italics, so support for
262+ this will be very spotty.
263+* Updateed text/string function documentation to indicate that escapes
264+ are not permitted in their inputs.
265+
266+5.22
267+----
268+
269+* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function
270+ (thanks Brent Carmer)
271+* Added nextEventNonblocking function (field) to Vty type (#87)
272+
273+5.21
274+----
275+
276+* Picture and Background now provide Eq instances (thanks Jaro Reinders)
277+* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)
278+* #142: note requirement of threaded RTS
279+
280+5.20
281+----
282+
283+API changes:
284+* Split up Monoid instances into Monoid and Semigroup for newer GHCs
285+ (thanks Ryan Scott)
286+
287+5.19.1
288+------
289+
290+API changes:
291+* Cursor now provides an Eq instance (thanks Jaro Reinders)
292+
293+5.19
294+----
295+
296+API changes:
297+* URL hyperlinking (via 'withURL') is now optional and disabled by
298+ default due to poor support on some common terminals. A new 'Mode'
299+ constructor, 'Hyperlink', has been added to enable this feature. To
300+ change the hyperlinking mode, use 'setMode' on the 'outputIface' of a
301+ Vty handle.
302+
303+5.18.1
304+------
305+
306+Bug fixes:
307+* Reset the hyperlink state on line endings to avoid run-on hyperlinks
308+
309+5.18
310+----
311+
312+API changes:
313+* Added support for hyperlinking attributes (thanks Getty Ritter). This
314+ change adds a new Attr field for containing the hyperlink to apply,
315+ as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda
316+
317+5.17.1
318+------
319+
320+* withStyle now ignores zero arguments, leaving attribute styles
321+ untouched if the input style is the null style
322+
323+5.17
324+----
325+
326+API changes:
327+* Add support for terminal focus events. This change adds a new mode
328+ usable with setMode, Focus, that requests that the terminal send
329+ events on focus lose/gain. This change also adds two new Event
330+ constructors, EvLostFocus and EvGainedFocus.
331+* No longer enable UTF8 mouse event encoding. This encoding was not
332+ working properly with Terminal.app, and using the other modes (SGR,
333+ etc.) work.
334+* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
335+ #131)
336+
337+5.16
338+----
339+
340+API changes:
341+* Added support for mouse wheel events while in mouse mode. The Button
342+ type got two new constructors as a result: BScrollUp and BScrollDown.
343+ Thanks to doublescale@tutanota.com for this contribution!
344+
345+Bug fixes:
346+* charFill now clamps negative arguments to zero (thanks Eric Mertens!)
347+
348+5.15.1
349+------
350+
351+Package changes:
352+* Documentation files are now marked accordingly (thanks Michal
353+ Suchánek)
354+
355+Bug fixes:
356+* translateX/Y: fix negative translations
357+
358+5.15
359+----
360+
361+Package changes:
362+* Discontinued support for GHC versions prior to 7.10.1.
363+* Removed instructions and configuration for Stack builds since they
364+ are no longer supported.
365+* Clarified README mention of (lack of) Windows support (contributors
366+ wanted, though!)
367+* Removed dependency on data-default (see below).
368+
369+API changes:
370+* Moved color definitions from Attributes to Color module.
371+* In lieu of data-default (Default) instances for Attr and Config, use
372+ 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
373+* Graphics.Vty.Output no longer re-exports
374+ Graphics.Vty.Output.Interface.
375+* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
376+ accessors to Graphics.Vty.Image.
377+* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
378+* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
379+
15.14
3805.14
381+----
382+
2− - addMaybeClippedJoin: instead of raising an exception when the join
383+* addMaybeClippedJoin: instead of raising an exception when the join
3− is totally clipped, just reduce the clip amount and continue
384+ is totally clipped, just reduce the clip amount and continue
4− - addMaybeClipped: skip blit of joins when their primary dimension is
385+* addMaybeClipped: skip blit of joins when their primary dimension is
5− zero
386+ zero
6− - 'string' and related text functions no longer treat an empty string
387+* 'string' and related text functions no longer treat an empty string
7− as an empty image (thanks Chris Penner). This means that now it is
388+ as an empty image (thanks Chris Penner). This means that now it is
8− possible to use 'str ""' as a non-empty image with height 1.
389+ possible to use 'str ""' as a non-empty image with height 1.
9
390
105.13
3915.13
392+----
393+
11− - Reverted changes in 5.12 due to disagreements between terminal
394+* Reverted changes in 5.12 due to disagreements between terminal
12− emulators and utf8proc; for more details, please see the ticket
395+ emulators and utf8proc; for more details, please see the ticket
13− discussion at
396+ discussion at
14− https://github.com/coreyoconnor/vty/issues/115
397+ https://github.com/coreyoconnor/vty/issues/115
15
398
165.12
3995.12
400+----
401+
17− - Replaced 'wcwidth' with a call to the utf8proc library's character
402+* Replaced 'wcwidth' with a call to the utf8proc library's character
18− width function, which is much more up to date (by several Unicode
403+ width function, which is much more up to date (by several Unicode
19− versions) and returns the right width for a much larger set of
404+ versions) and returns the right width for a much larger set of
20− characters.
405+ characters.
21− - Added a bundled version of the utf8proc C library.
406+* Added a bundled version of the utf8proc C library.
22
407
235.11.3
4085.11.3
409+------
410+
24− - Fix mouse event offsets in mouse-up events
411+* Fix mouse event offsets in mouse-up events
25
412
265.11.2
4135.11.2
414+------
415+
27− - Mouse events were modified so that the upper-left corner of the
416+* Mouse events were modified so that the upper-left corner of the window
28− window is (0,0) rather than (1,1).
417+ is (0,0) rather than (1,1).
29
418
305.11.1
4195.11.1
420+------
421+
31− - Add Generic instance for Image
422+* Add Generic instance for Image
32− - nextEvent: stop trying to refresh on a resize event (fixes segfault
423+* nextEvent: stop trying to refresh on a resize event (fixes segfault
33− on refresh with normal cursor positioning mode)
424+ on refresh with normal cursor positioning mode)
34− - Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
425+* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
35− - Update maintainer
426+* Update maintainer
36
427
375.11
4285.11
429+----
430+
38− - Vty now raises a VtyConfigurationError exception when the TERM
431+* Vty now raises a VtyConfigurationError exception when the TERM
39− evironment variable is missing (thanks Eric Mertens)
432+ evironment variable is missing (thanks Eric Mertens)
40− - Graphics.Vty.Config got an explicit export list to avoid accidentally
433+* Graphics.Vty.Config got an explicit export list to avoid accidentally
41− exporting internal types (thanks Eric Mertens)
434+ exporting internal types (thanks Eric Mertens)
42
435
435.10
4365.10
437+----
438+
44− - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
439+* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
45− mode provides greater control over cursor positioning by bypassing
440+ mode provides greater control over cursor positioning by bypassing
46− the logical positioning provided by default. Rather than positioning
441+ the logical positioning provided by default. Rather than positioning
47− the cursor by looking at the widths of characters involved, this
442+ the cursor by looking at the widths of characters involved, this
48− constructor lets you provide a physical row and column instead. This
443+ constructor lets you provide a physical row and column instead. This
49− is useful in more sophisticated programs. (thanks Eric Mertens)
444+ is useful in more sophisticated programs. (thanks Eric Mertens)
50− - Added a new Generic-derived config parser (thanks Eric Mertens)
445+* Added a new Generic-derived config parser (thanks Eric Mertens)
51− - Fixed the MShift case in the configuration file parser (thanks Eric
446+* Fixed the MShift case in the configuration file parser (thanks Eric
52− Mertens)
447+ Mertens)
53− - Fixed wcwidth import and matched safeWcswidth to its documented
448+* Fixed wcwidth import and matched safeWcswidth to its documented
54− behavior. Previously vty_mk_wcwidth was being imported with
449+ behavior. Previously vty_mk_wcwidth was being imported with the
55− the wrong type causing the -1 return value to be mapped to the
450+ wrong type causing the -1 return value to be mapped to the wrong Int
56− wrong Int value. Additionally safeWcswidth was using the unsafe
451+ value. Additionally safeWcswidth was using the unsafe character width
57− character width function and only ensuring that the final result was
452+ function and only ensuring that the final result was non-negative.
58− non-negative. (thanks Eric Mertens)
453+ (thanks Eric Mertens)
59
454
605.9.1
4555.9.1
456+-----
457+
61− - Vty now only emits UTF8 charset sequences in terminals without a
458+* Vty now only emits UTF8 charset sequences in terminals without a
62− preexisting UTF8 declaration to avoid emitting garbage sequences
459+ preexisting UTF8 declaration to avoid emitting garbage sequences
63− (fixes #89)
460+ (fixes #89)
64
461
655.9
4625.9
463+---
464+
66− - Added new Output methods supportsBell and ringTerminalBell to find
465+* Added new Output methods supportsBell and ringTerminalBell to find out
67− out whether the output device has an audio bell and to ring it (see
466+ whether the output device has an audio bell and to ring it (see #102)
68− #102)
69
467
705.8.1
4685.8.1
469+-----
470+
71− - Fixed "refresh" to work as advertised (see #104)
471+* Fixed "refresh" to work as advertised (see #104)
72
472
735.8
4735.8
474+---
475+
74− - API change: EvPaste input event now provides paste data as a raw
476+* API change: EvPaste input event now provides paste data as a raw
75− ByteString rather than a String to allow the application to decode
477+ ByteString rather than a String to allow the application to decode how
76− how best to decode it
478+ best to decode it
77
479
785.7.1
4805.7.1
481+-----
482+
79− - ModeDemo: added an explicit Control.Applicative import for older
483+* ModeDemo: added an explicit Control.Applicative import for older GHCs
80− GHCs
81
484
825.7
4855.7
486+---
487+
83− - Mouse and paste modes are now off by default.
488+* Mouse and paste modes are now off by default.
84− - The Config type got new fields: mouseMode and bracketedPasteMode.
489+* The Config type got new fields: mouseMode and bracketedPasteMode.
85− These determine whether these modes are enabled initially (for
490+ These determine whether these modes are enabled initially (for
86− terminals that support them).
491+ terminals that support them).
87− - Added a Mode type for modal terminal features (mouse events,
492+* Added a Mode type for modal terminal features (mouse events,
88− bracketed paste mode) that is used with new Output interface
493+ bracketed paste mode) that is used with new Output interface
89− functions:
494+ functions:
90− * supportsMode :: Mode -> Bool tells whether the device supports a
495+ * supportsMode :: Mode -> Bool tells whether the device supports a
91− mode
496+ mode
92− * setMode :: Mode -> Bool -> IO () turns a mode on or off
497+ * setMode :: Mode -> Bool -> IO () turns a mode on or off
93− * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
498+ * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
94− off
499+ off
95− - Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
500+* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
96
501
975.6
5025.6
503+---
504+
98− - Added support for normal and extended mouse modes in Xterm-like
505+* Added support for normal and extended mouse modes in Xterm-like
99− terminals via the MouseDown and MouseUp Event constructors
506+ terminals via the MouseDown and MouseUp Event constructors
100− - Added support for bracketed paste mode in Xterm-like terminals via
507+* Added support for bracketed paste mode in Xterm-like terminals via
101− the EvPaste event constructor
508+ the EvPaste event constructor
102− - Added derived Show instances for Event and Button (thanks Felix
509+* Added derived Show instances for Event and Button (thanks Felix
103− Hirn)
510+ Hirn)
104− - Now TERM values containing "screen" will automatically use the
511+* Now TERM values containing "screen" will automatically use the
105− XtermColor driver rather than just TerminfoBased
512+ XtermColor driver rather than just TerminfoBased
106
513
1075.5.0
5145.5.0
515+-----
516+
108− - Replaced lens dependency with microlens, microlens-mtl, microlens-th
517+* Replaced lens dependency with microlens, microlens-mtl, microlens-th
109− dependencies. Issue #90
518+ dependencies. Issue #90
110− - Thanks Jonathan Daugherty
519+ * Thanks Jonathan Daugherty
111− - Cabal corrections.
520+* Cabal corrections.
112− - Thanks Lennart Spitzner
521+ * Thanks Lennart Spitzner
113
522
1145.4.0
5235.4.0
524+-----
525+
115− - Changed eventChannel of Graphics.Vty.Input from Chan to TChan.
526+* Changed eventChannel of Graphics.Vty.Input from Chan to
116− This enables clients to query if there are no pending events. The
527+ TChan. This enables clients to query if there are no pending
117− Graphics.Vty interface nextEvent is unchanged. Clients that use
528+ events. The Graphics.Vty interface nextEvent is unchanged.
118− eventChannel directly will require updating.
529+ Clients that use eventChannel directly will require updating.
119− https://github.com/coreyoconnor/vty/issues/60
530+ https://github.com/coreyoconnor/vty/issues/60
531+
1205.3.1
5325.3.1
533+-----
534+
121− - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due
535+* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to
122− to possibly breaking this on reasonable GHC versions
536+ possibly breaking this on reasonable GHC versions
123
537
1245.3
5385.3
539+---
540+
125− - Upgraded QuickCheck dependency to 2.7
541+* Upgraded QuickCheck dependency to 2.7
126− - The standard IO Config (standardIOConfig) was overriding any
542+* The standard IO Config (standardIOConfig) was overriding any provided
127− provided application config. In addition, the inputFd and outputFd
543+ application config. In addition, the inputFd and outputFd could not be
128− could not be changed if mkVty was used. Fixed.
544+ changed if mkVty was used. Fixed.
129− - Correct handling of display attributes at end of line. The output
545+* Correct handling of display attributes at end of line. The output
130− attributes are set to default at the end of content for the line and
546+ attributes are set to default at the end of content for the line and
131− at the start of a new line. Previously the current attribute would
547+ at the start of a new line. Previously the current attribute would
132− extend to the next start of content. This was odd to reason about
548+ extend to the next start of content. This was odd to reason about and
133− and was the cause of https://github.com/coreyoconnor/vty/issues/76
549+ was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi
134− IIRC Yi requires the old behavior to display the selection region
550+ requires the old behavior to display the selection region correctly.
135− correctly.
136− - shutdown of the input thread is now performed using killThread and
551+* shutdown of the input thread is now performed using killThread and
137− synchronization on an MVar. For correct handling of the terminal
552+ synchronization on an MVar. For correct handling of the terminal read
138− read vmin and vtime the read must be a blocking read on an OS
553+ vmin and vtime the read must be a blocking read on an OS thread.
139− thread. This places a threadWaitRead, which will be interrupted by
554+ This places a threadWaitRead, which will be interrupted by the
140− the killThread, prior to the uninterruptable read. An alternative
555+ killThread, prior to the uninterruptable read. An alternative would be
141− would be to re-import the read foreign call as interruptable.
556+ to re-import the read foreign call as interruptable.
142
557
1435.2.11
5585.2.11
559+------
560+
144− - deepseq bounds increased for tests.
561+* deepseq bounds increased for tests.
145− - Clean up warnings when compiling on 7.10
562+* Clean up warnings when compiling on 7.10
146− - Thanks Eric Mertens
563+ * Thanks Eric Mertens
147− - Avoid discarding input bytes after multi-byte encoded codepoint
564+* Avoid discarding input bytes after multi-byte encoded codepoint
148− - Thanks Eric Mertens
565+ * Thanks Eric Mertens
149
566
1505.2.10
5675.2.10
568+------
569+
151− - "str" now returns EmptyImage for empty strings to match behavior of
570+* "str" now returns EmptyImage for empty strings to match behavior of
152− other string-like Image constructors (fixes #74)
571+ other string-like Image constructors (fixes #74)
153− - Thanks Jonathan Daugherty
572+ * Thanks Jonathan Daugherty
154
573
1555.2.9
5745.2.9
575+-----
576+
156− - dependency version bumps
577+* dependency version bumps
157− - https://github.com/coreyoconnor/vty/pull/71
578+ * https://github.com/coreyoconnor/vty/pull/71
158− - https://github.com/coreyoconnor/vty/pull/70
579+ * https://github.com/coreyoconnor/vty/pull/70
159− - Correct/Simplify the example code
580+* Correct/Simplify the example code
160− - Thanks glguy
581+ * Thanks glguy
161− - https://github.com/coreyoconnor/vty/pull/69
582+ * https://github.com/coreyoconnor/vty/pull/69
162
583
1635.2.8
5845.2.8
585+-----
586+
164− - blaze-builder, lens, utf8-string version constraint bump
587+* blaze-builder, lens, utf8-string version constraint bump
165− - Thanks glguy
588+ * Thanks glguy
166− - https://github.com/coreyoconnor/vty/pull/67
589+ * https://github.com/coreyoconnor/vty/pull/67
167− - Do not differentiate based on TERM_PROGRAM
590+* Do not differentiate based on TERM_PROGRAM
168− - https://github.com/coreyoconnor/vty/issues/68
591+ * https://github.com/coreyoconnor/vty/issues/68
169
592
1705.2.7
5935.2.7
594+-----
595+
171− - lens and deepseq constraint bump + misc
596+* lens and deepseq constraint bump + misc
172− - Thanks ethercrow
597+ * Thanks ethercrow
173− - https://github.com/coreyoconnor/vty/pull/66
598+ * https://github.com/coreyoconnor/vty/pull/66
174
599
1755.2.6
6005.2.6
601+-----
602+
176− - lens constraint bump
603+* lens constraint bump
177− - Thanks alexander-b!
604+ * Thanks alexander-b!
178− - https://github.com/coreyoconnor/vty/pull/64
605+ * https://github.com/coreyoconnor/vty/pull/64
179
606
1805.2.5
6075.2.5
608+-----
609+
181− - lens and random version constraint bump.
610+* lens and random version constraint bump.
182− - Thanks RyanGlScott!
611+ * Thanks RyanGlScott!
183− - https://github.com/coreyoconnor/vty/pull/62
612+ * https://github.com/coreyoconnor/vty/pull/62
184
613
1855.2.4
6145.2.4
615+-----
616+
186− - removed -fpic from cc-options. No longer required.
617+* removed -fpic from cc-options. No longer required.
187− - https://github.com/coreyoconnor/vty/issues/61
618+ * https://github.com/coreyoconnor/vty/issues/61
188− - https://ghc.haskell.org/trac/ghc/ticket/9657
619+ * https://ghc.haskell.org/trac/ghc/ticket/9657
189− - Thanks Fuuzetsu!
620+ * Thanks Fuuzetsu!
190
621
1915.2.3
6225.2.3
623+-----
624+
192− - evaluate/compile the input parsing table once instead of each
625+* evaluate/compile the input parsing table once instead of each
193− keystroke.
626+ keystroke.
194− - https://github.com/coreyoconnor/vty/pull/59
627+ * https://github.com/coreyoconnor/vty/pull/59
195− - Thanks ethercrow!
628+ * Thanks ethercrow!
196
629
1975.2.2
6305.2.2
631+-----
632+
198− - When looking at input for an event, don't look too deep.
633+* When looking at input for an event, don't look too deep.
199− - https://github.com/coreyoconnor/vty/pull/57
634+ * https://github.com/coreyoconnor/vty/pull/57
200− - Thanks ethercrow!
635+ * Thanks ethercrow!
201
636
2025.2.1
6375.2.1
638+-----
639+
203− - Bump upper version bound for lens to 4.5. Thanks markus1189!
640+* Bump upper version bound for lens to 4.5. Thanks markus1189!
204
641
2055.2.0
6425.2.0
643+-----
644+
206− - Config structure now specifies file descriptor to use. The default
645+* Config structure now specifies file descriptor to use. The default
207− is stdInput and stdOutput file descriptors. Previously Vty used
646+ is stdInput and stdOutput file descriptors. Previously Vty used
208− stdInput for input and the follow code for output:
647+ stdInput for input and the follow code for output:
209− - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
648+ * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
210− NoBuffering)
649+ NoBuffering)
211− - the difference was required by Vty.Inline. Now, Vty.Inline uses
650+ * the difference was required by Vty.Inline. Now, Vty.Inline uses
212− the Config structure options to acheive the same effect.
651+ the Config structure options to acheive the same effect.
213− - removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
652+* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
214− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
653+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
215− - added: inputForConfig, outputForConfig
654+* added: inputForConfig, outputForConfig
216− - updates to vty-rogue from jtdaugherty. Thanks!
655+* updates to vty-rogue from jtdaugherty. Thanks!
217− - the oldest version of GHC tested to support vty is 7.6.2.
656+* the oldest version of GHC tested to support vty is 7.6.2.
218− - the oldest version of GHC that vty compiles under is 7.4.2
657+* the oldest version of GHC that vty compiles under is 7.4.2
219
658
2205.1.4
6595.1.4
660+-----
661+
221− - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
662+* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
222
663
2235.1.1
6645.1.1
665+-----
666+
224− - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
667+* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
225− - jtdaugherty resolved a number of compiler warnings. Thanks!
668+* jtdaugherty resolved a number of compiler warnings. Thanks!
226
669
2275.1.0
6705.1.0
671+-----
672+
228− - vmin and vtime can be specified however the application requires.
673+* vmin and vtime can be specified however the application requires.
229− See Graphics.Vty.Config.
674+ See Graphics.Vty.Config.
230− - fixed the processing of input when vmin is set > 1.
675+* fixed the processing of input when vmin is set > 1.
231
676
2325.0.0
6775.0.0
678+-----
679+
233− - The naming convention now matches:
680+* The naming convention now matches:
234− - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
681+ * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
235− - all projects using vty for input must be compiled with -threaded.
682+* all projects using vty for input must be compiled with -threaded.
236− Please notify vty author if this is not acceptable.
683+ Please notify vty author if this is not acceptable.
237− - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
684+* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
238− vty with the default configuration.
685+ vty with the default configuration.
239− - input handling changes
686+* input handling changes
240− - KASCII is now KChar
687+ * KASCII is now KChar
241− - KPN5 is now KCenter
688+ * KPN5 is now KCenter
242− - tests exist.
689+ * tests exist.
243− - Applications can add to the input tables by setting inputMap of
690+ * Applications can add to the input tables by setting inputMap of
244− the Config. See Graphics.Vty.Config
691+ the Config. See Graphics.Vty.Config
245− - Users can define input table extensions that will apply to all vty
692+ * Users can define input table extensions that will apply to all vty
246− applications. See Graphics.Vty.Config
693+ applications. See Graphics.Vty.Config
247− - terminal timing is now handled by selecting an appropriate VTIME.
694+ * terminal timing is now handled by selecting an appropriate VTIME.
248− Previously this was implemented within Vty itself. This reduced
695+ Previously this was implemented within Vty itself. This reduced
249− complexity in vty but provides a different meta key behavior and
696+ complexity in vty but provides a different meta key behavior and
250− implies a requirement on -threaded.
697+ implies a requirement on -threaded.
251− - The time vty will wait to verify an ESC byte means a single ESC
698+ * The time vty will wait to verify an ESC byte means a single ESC
252− key is the singleEscPeriod of the Input Config structure.
699+ key is the singleEscPeriod of the Input Config structure.
253− - removed the typeclass based terminal and display context interface
700+* removed the typeclass based terminal and display context interface
254− in favor of a data structure of properties interface.
701+ in favor of a data structure of properties interface.
255− - renamed the Terminal interface to Output
702+* renamed the Terminal interface to Output
256− - The default picture for an image now uses the "clear" background.
703+* The default picture for an image now uses the "clear" background.
257− This background fills background spans with spaces or just ends the
704+ This background fills background spans with spaces or just ends the
258− line.
705+ line.
259− - Previously the background defaulted to the space character. This
706+ * Previously the background defaulted to the space character. This
260− causes issues copying text from a text editor. The text would end
707+ causes issues copying text from a text editor. The text would end
261− up with extra spaces at the end of the line.
708+ up with extra spaces at the end of the line.
262− - Layer support
709+* Layer support
263− - Each layer is an image.
710+ * Each layer is an image.
264− - The layers for a picture are a list of images.
711+ * The layers for a picture are a list of images.
265− - The first image is the top-most layer. The images are ordered from
712+ * The first image is the top-most layer. The images are ordered from
266− top to bottom.
713+ top to bottom.
267− - The transparent areas for a layer are the backgroundFill areas.
714+ * The transparent areas for a layer are the backgroundFill areas.
268− backgroundFill is added to pad images when images of different
715+ backgroundFill is added to pad images when images of different
269− sizes are joined.
716+ sizes are joined.
270− - If the background is clear there is no background layer.
717+ * If the background is clear there is no background layer.
271− - If there is a background character then the bottom layer is the
718+ * If there is a background character then the bottom layer is the
272− background layer.
719+ background layer.
273− - emptyPicture is a Picture with no layers and no cursor
720+ * emptyPicture is a Picture with no layers and no cursor
274− - addToTop and addToBottom add a layer to the top and bottom of the
721+ * addToTop and addToBottom add a layer to the top and bottom of the
275− given Picture.
722+ given Picture.
276− - compatibility improvements:
723+* compatibility improvements:
277− - terminfo based terminals with no cursor support are silently
724+ * terminfo based terminals with no cursor support are silently
278− accepted. The cursor visibility changes in the Picture will have
725+ accepted. The cursor visibility changes in the Picture will have
279− no effect.
726+ no effect.
280− - alternate (setf/setb) color maps supported. Though colors beyond
727+ * alternate (setf/setb) color maps supported. Though colors beyond
281− the first 8 are just a guess.
728+ the first 8 are just a guess.
282− - added "rgbColor" for easy support of RGB specified colors.
729+ * added "rgbColor" for easy support of RGB specified colors.
283− - Both applications and users can add to the mapping used to
730+ * Both applications and users can add to the mapping used to
284− translate from input bytes to events.
731+ translate from input bytes to events.
285− - Additional information about input and output process can be
732+* Additional information about input and output process can be
286− appended to a debug log
733+ appended to a debug log
287− - Set environment variable VTY_DEBUG_LOG to path of debug log
734+ * Set environment variable VTY_DEBUG_LOG to path of debug log
288− - Or use "debugLog <path>" config directive
735+ * Or use "debugLog <path>" config directive
289− - Or set 'debugLog' property of the Config provided to mkVty.
736+ * Or set 'debugLog' property of the Config provided to mkVty.
290− - examples moved to vty-examples package. See test directory for cabal
737+* examples moved to vty-examples package. See test directory for cabal
291− file.
738+ file.
292− - vty-interactive-terminal-test
739+ * vty-interactive-terminal-test
293− - interactive test. Useful for building a bug report for vty's
740+ * interactive test. Useful for building a bug report for vty's
294− author.
741+ author.
295− - test/interactive_terminal_test.hs
742+ * test/interactive_terminal_test.hs
296− - vty-event-echo
743+ * vty-event-echo
297− - view a input event log for vty. Example of interacting with
744+ * view a input event log for vty. Example of interacting with
298− user.
745+ user.
299− - test/EventEcho.hs
746+ * test/EventEcho.hs
300− - vty-rogue
747+ * vty-rogue
301− - The start of a rogue-like game. Example of layers and image
748+ * The start of a rogue-like game. Example of layers and image
302− build operations.
749+ build operations.
303− - test/Rogue.hs
750+ * test/Rogue.hs
304− - vty-benchmark
751+ * vty-benchmark
305− - benchmarks vty. A series of tests that push random pictures to
752+ * benchmarks vty. A series of tests that push random pictures to
306− the terminal. The random pictures are generated using
753+ the terminal. The random pictures are generated using
307− QuickCheck. The same generators used in the automated tests.
754+ QuickCheck. The same generators used in the automated tests.
308− - test/benchmark.hs
755+ * test/benchmark.hs
309
756
3104.7.0.0
7574.7.0.0
311− - API changes:
758+-------
312− - Added Graphics.Vty.Image.crop: Ensure an image is no larger
313− than the specified size.
314− - Added Graphics.Vty.Image.pad: Ensure an image is no smaller
315− than the specified size.
316− - Added Graphics.Vty.Image.translate: Offset an image.
317− - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
318
759
319−4.3.0.0
760+API changes:
761+* Added Graphics.Vty.Image.crop: Ensure an image is no larger
762+ than the specified size.
763+* Added Graphics.Vty.Image.pad: Ensure an image is no smaller
764+ than the specified size.
765+* Added Graphics.Vty.Image.translate: Offset an image.
766+* Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
320
767
3214.2.1.0
7684.2.1.0
769+-------
770+
322− - API changes:
771+API changes:
323− - Attr record accessor fore_color changed to attr_fore_color
772+* Attr record accessor fore_color changed to attr_fore_color
324− - Attr record accessor back_color changed to attr_back_color
773+* Attr record accessor back_color changed to attr_back_color
325− - Attr record accessor style changed to attr_style
774+* Attr record accessor style changed to attr_style
326− - Added an "inline" display attribute changing DSL:
775+* Added an "inline" display attribute changing DSL:
327− - put_attr_change applies a display attribute change
776+ * put_attr_change applies a display attribute change
328− immediately to a terminal
777+ immediately to a terminal
329− - For instance, can be used to change the display attrbiutes
778+ * For instance, can be used to change the display attrbiutes
330− of text output via putStrLn and putStr. EX:
779+ of text output via putStrLn and putStr. EX:
331− "put_attr_change $ back_color red" will set the background
780+ "put_attr_change $ back_color red" will set the background
332− color to red.
781+ color to red.
333− - Changes do not apply to a Picture output via output_picture.
782+ * Changes do not apply to a Picture output via output_picture.
334− - See Graphics.Vty.Inline
783+ * See Graphics.Vty.Inline
335− - Moved all IO actions into any monad an instance of MonadIO
784+* Moved all IO actions into any monad an instance of MonadIO
336
785
3374.0.0.1
7864.0.0.1
787+-------
788+
338− - binding for mk_wcswidth was incorrect. Most platforms just
789+* binding for mk_wcswidth was incorrect. Most platforms just
339− magically worked due to coincidence.
790+ magically worked due to coincidence.
340
791
3414.0.0
7924.0.0
793+-----
794+
342− - API changes:
795+API changes:
343− - "getSize" has been removed. Use "terminal vty >>= display_bounds"
796+* "getSize" has been removed. Use "terminal vty >>= display_bounds"
344− where "vty" is an instance of the Vty data structure.
797+ where "vty" is an instance of the Vty data structure.
345− - added a "terminal" field to the Vty data structure. Accesses the
798+* added a "terminal" field to the Vty data structure. Accesses the
346− TerminalHandle associated with the Vty instance.
799+ TerminalHandle associated with the Vty instance.
347− - Graphics.Vty.Types has undergone a number of changes. Summary:
800+* Graphics.Vty.Types has undergone a number of changes. Summary:
348− - Partitioned into Graphics.Vty.Attributes for display attributes.
801+ * Partitioned into Graphics.Vty.Attributes for display attributes.
349− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
802+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
350− for final picture construction.
803+ for final picture construction.
351− - Graphics.Vty.Attributes:
804+* Graphics.Vty.Attributes:
352− - "setFG" and "setBG" are now "with_fore_color" and
805+ * "setFG" and "setBG" are now "with_fore_color" and
353− "with_back_color"
806+ "with_back_color"
354− - All other "set.." equations similarly replaced.
807+ * All other "set.." equations similarly replaced.
355− - "attr" is now "def_attr", short for "default display attributes"
808+ * "attr" is now "def_attr", short for "default display attributes"
356− Also added a "current_attr" for "currently applied display
809+ Also added a "current_attr" for "currently applied display
357− attributes"
810+ attributes"
358− - Graphics.Vty.Image:
811+* Graphics.Vty.Image:
359− - "horzcat" is now "horiz_cat"
812+ * "horzcat" is now "horiz_cat"
360− - "vertcat" is now "vert_cat"
813+ * "vertcat" is now "vert_cat"
361− - "renderBS" is now "utf8_bytestring"
814+ * "renderBS" is now "utf8_bytestring"
362− - "renderChar" is now "char"
815+ * "renderChar" is now "char"
363− - "renderFill" is now "char_fill"
816+ * "renderFill" is now "char_fill"
364− - added a "utf8_string" and "string" (AKA "iso_10464_string") for
817+ * added a "utf8_string" and "string" (AKA "iso_10464_string") for
365− UTF-8 encoded Strings and ISO-10464 encoded Strings. String
818+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String
366− literals in GHC have an ISO-10464 runtime representation.
819+ literals in GHC have an ISO-10464 runtime representation.
367− - Graphics.Vty.Picture:
820+* Graphics.Vty.Picture:
368− - exports Graphics.Vty.Image
821+ * exports Graphics.Vty.Image
369− - "pic" is now "pic_for_image"
822+ * "pic" is now "pic_for_image"
370− - added API for setting background fill pattern.
823+ * added API for setting background fill pattern.
371− - Completely rewritten output backend.
824+* Completely rewritten output backend.
372− - Efficient, scanline style output span generator. Has not been
825+ * Efficient, scanline style output span generator. Has not been
373− fully optimized, but good enough.
826+ fully optimized, but good enough.
374− - The details required to display the desired picture on a
827+ * The details required to display the desired picture on a
375− terminal are well encapsulated.
828+ terminal are well encapsulated.
376− - Terminfo based display terminal implementation. With specialized
829+ * Terminfo based display terminal implementation. With specialized
377− derivitives for xterm, Terminal.app, and iTerm.app.
830+ derivitives for xterm, Terminal.app, and iTerm.app.
378− - Attempts to robustly handle even terminals that don't
831+ * Attempts to robustly handle even terminals that don't
379− support all display attributes.
832+ support all display attributes.
380− - I've tested the following terminals with success: iTerm.app,
833+ * I've tested the following terminals with success: iTerm.app,
381− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
834+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
382− konsole, screen, linux vty. Hopefully you will be as
835+ konsole, screen, linux vty. Hopefully you will be as
383− successfull.
836+ successfull.
384− - Improved unicode support. Double wide characters will display as
837+ * Improved unicode support. Double wide characters will display as
385− expected.
838+ expected.
386− - 256 color support. See Graphics.Vty.Attributes.Color240. The actual
839+* 256 color support. See Graphics.Vty.Attributes.Color240. The actual
387− output color is adjusted according to the number of colors the
840+ output color is adjusted according to the number of colors the
388− terminal supports.
841+ terminal supports.
389− - The Graphics.Vty.Image combinators no longer require matching
842+* The Graphics.Vty.Image combinators no longer require matching
390− dimensions to arguments. Unspecified areas are filled in with a
843+ dimensions to arguments. Unspecified areas are filled in with a
391− user-customizable background pattern. See Graphics.Vty.Picture.
844+ user-customizable background pattern. See Graphics.Vty.Picture.
392− - output images are always cropped to display size.
845+* output images are always cropped to display size.
393− - Significant code coverage by QuickCheck tests. An interactive test
846+* Significant code coverage by QuickCheck tests. An interactive test
394− for those final properties that couldn't be automatically verified.
847+ for those final properties that couldn't be automatically verified.
395
848
396Issues resolved:
849Issues resolved:
397− - "gnome terminal displays non-basic attributes as strikethrough"
850+* "gnome terminal displays non-basic attributes as strikethrough"
398− - http://trac.haskell.org/vty/ticket/14
851+ * http://trac.haskell.org/vty/ticket/14
399− - "Multi-byte characters are not displayed correctly on update"
852+* "Multi-byte characters are not displayed correctly on update"
400− - http://trac.haskell.org/vty/ticket/10
853+ * http://trac.haskell.org/vty/ticket/10
401− - "Redraw does not handle rendering a line that extends beyond screen
854+* "Redraw does not handle rendering a line that extends beyond screen
402− width characters"
855+ width characters"
403− - http://trac.haskell.org/vty/ticket/13
856+ * http://trac.haskell.org/vty/ticket/13
404− - "The <|> and <-> combinators should be more forgiving of mismatched
857+* "The <|> and <-> combinators should be more forgiving of mismatched
405− dimensions"
858+ dimensions"
406− - http://trac.haskell.org/vty/ticket/9
859+ * http://trac.haskell.org/vty/ticket/9
407− - "256-color support"
860+* "256-color support"
408− - http://trac.haskell.org/vty/ticket/19
861+ * http://trac.haskell.org/vty/ticket/19
LICENSE+2
@@ -1,3 +1,5 @@
1+BSD 3-Clause License
2+
1Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
3Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
2
4
3All rights reserved.
5All rights reserved.
README.md+137−58
@@ -1,12 +1,13 @@
1[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty)
1[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty)
2
2
3`vty` is a terminal interface library. It provides a high-level
3`vty` is a terminal interface library. It provides a high-level
4−interface for doing terminal I/O.
4+interface for doing terminal I/O. Vty is supported on GHC versions
5+7.10.1 and up.
5
6
6Install via `git` with:
7Install via `git` with:
7
8
8```
9```
9−git clone git://github.com/coreyoconnor/vty.git
10+git clone git://github.com/jtdaugherty/vty.git
10```
11```
11
12
12Install via `cabal` with:
13Install via `cabal` with:
@@ -17,24 +18,21 @@ cabal install vty
17
18
18# Features
19# Features
19
20
20−* Supports a large number of terminals. vt100, ansi, hurd, linux,
21+* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,
21− screen, etc., or anything with a sufficient terminfo entry.
22+ `screen`, etc., or anything with a sufficient terminfo entry.
22
23
23−* Automatic handling of window resizes.
24+* Automatically handles window resizes.
24
25
25−* Unicode output on terminals with UTF-8 support.
26+* Supports Unicode output on terminals with UTF-8 support.
26
27
27−* Handles multi-column glyphs. (Requires user to properly configure
28− terminal.)
29−
30−* Efficient output. Output buffering and terminal state changes are
28+* Provides an efficient output algorithm. Output buffering and terminal
31− minimized.
29+ state changes are minimized.
32
30
33* Minimizes repaint area, which virtually eliminates the flicker
31* Minimizes repaint area, which virtually eliminates the flicker
34 problems that plague ncurses programs.
32 problems that plague ncurses programs.
35
33
36−* A pure, compositional interface for efficiently constructing display
34+* Provides a pure, compositional interface for efficiently constructing
37− images.
35+ display images.
38
36
39* Automatically decodes keyboard keys into (key,[modifier]) tuples.
37* Automatically decodes keyboard keys into (key,[modifier]) tuples.
40
38
@@ -43,7 +41,7 @@ cabal install vty
43* Supports a keypress timeout after for lone ESC. The timeout is
41* Supports a keypress timeout after for lone ESC. The timeout is
44 customizable.
42 customizable.
45
43
46−* The interface is designed for easy extension.
44+* Provides extensible input and output interfaces.
47
45
48* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
46* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
49 with a type-safe interface and graceful fallback for terminals
47 with a type-safe interface and graceful fallback for terminals
@@ -53,70 +51,151 @@ cabal install vty
53
51
54* Provides a comprehensive test suite.
52* Provides a comprehensive test suite.
55
53
56−# Known Issues
57−
58−* Terminals have numerous quirks and bugs. Vty picks what works best for
59− the author in ambiguous or buggy situations.
60−
61−* Signal handling of STOP, TERM and INT are nonexistent.
62−
63−* The character encoding of the terminal is assumed to be UTF-8 if
64− unicode is used.
65−
66−* Terminfo is assumed to be correct unless there is an override
67− configured. Some terminals will not have correct special key support
68− (shifted F10 etc). See `Config` for customizing vty's behavior for a
69− particular terminal.
70−
71−* Uses the `TIOCGWINSZ` ioctl to find the current window size, which
72− appears to be limited to Linux and BSD.
73−
74* Supports "normal" and "extended" (SGR) mouse modes as described at
54* Supports "normal" and "extended" (SGR) mouse modes as described at
75 http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
55 http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
76
56
77* Supports bracketed paste mode as described at
57* Supports bracketed paste mode as described at
78 http://cirw.in/blog/bracketed-paste
58 http://cirw.in/blog/bracketed-paste
79
59
60+* Supports multi-column Unicode characters such as emoji characters. In
61+ cases where Vty and your terminal emulator disagree on character
62+ widths, Vty provides a tool `vty-build-width-table` and library
63+ functionality to build a width table that will work for your terminal
64+ and load it on application startup.
65+
66+# Development Notes
67+
68+Vty uses threads internally, so programs made with Vty need to be
69+compiled with the threaded runtime using the GHC `-threaded` option.
70+
80# Platform Support
71# Platform Support
81
72
82## Posix Terminals
73## Posix Terminals
83
74
84−Uses terminfo to determine terminal protocol. With some special rules to
75+For the most part, Vty uses `terminfo` to determine terminal protocol
85−handle some omissions from terminfo.
76+with some special rules to handle some omissions from `terminfo`.
86
77
87## Windows
78## Windows
88
79
89−Unsupported (but contributions and testing here are very welcome!)
80+Windows is not supported.
81+
82+# Multi-Column Character Support
83+
84+Vty supports rendering of multi-column characters such as two-column
85+Asian characters and Emoji characters. This section details how to
86+take advantage of this feature, since its behavior will depend on the
87+terminal emulator in use.
88+
89+Terminal emulators support Unicode to varying degrees, and each terminal
90+emulator relies on a table of column widths for each supported Unicode
91+character. Vty also needs to rely on such a table to compute the width
92+of Vty images to do image layout. Since those tables can disagree if
93+Vty and the terminal emulator support different versions of Unicode,
94+and since different terminal emulators will support different versions
95+of Unicode, it's likely that for some wide characters, Vty applications
96+will exhibit rendering problems. Those rendering problems arise from Vty
97+and the terminal emulator coming to different conclusions about how wide
98+some characters are.
99+
100+To address this, Vty supports loading custom character width tables
101+that are based on the terminal's behavior in order to eliminate these
102+disagreements. By default, though, Vty will use its built-in Unicode
103+character width table. Since the built-in table is likely to eventually
104+disagree with your terminal, Vty provides an API and a command-line tool
105+to generate and install custom tables.
106+
107+Custom Unicode width tables based on your terminal emulator can be
108+built by running Vty's built-in tool, `vty-build-width-table`. The tool
109+works by querying the current terminal emulator to obtain its width
110+measurements for the entire supported Unicode range. The
111+results are then saved to a disk file. These custom tables
112+can also be generated programmatically by using the API in
113+`Graphics.Vty.UnicodeWidthTable.Query`.
114+
115+Saved width tables can then be loaded in one of two ways:
116+
117+* Via the library API in `Graphics.Vty.UnicodeWidthTable.IO`
118+* By adding a `widthMap` directive to your Vty configuration file and
119+ then invoking `mkVty` to initialize Vty
120+
121+The Vty configuration file supports the `widthMap` directive to allow
122+users to specify which custom width table should be loaded for a given
123+terminal type. This is done by specifying, e.g.,
90
124
91−# Development Notes
125+```
126+widthMap "xterm" "/path/to/map.dat"
127+```
92
128
93−## Under NixOS
129+where the first argument is the value that `TERM` must have in order for
130+the table to be loaded, and the second argument is the path to the table
131+file itself as generated by the two alternatives listed above. If the
132+Vty configuration file contains multiple matching `widthMap` directives
133+for the current value of `TERM`, the last one listed in the file is
134+used.
135+
136+The tables declared in the configuration file are only ever
137+automatically loaded when applications set up Vty by calling
138+`Graphics.Vty.mkVty`.
139+
140+Before a custom table has been loaded, calls to the library's character
141+width functions (e.g. `wcwidth`) will use the default built-in table.
142+Once a custom table has been loaded, the functions will use the new
143+custom table. Only one custom table load can be performed in a Vty
144+program. Once a custom table has been loaded, it cannot be replaced or
145+removed.
146+
147+Without using a custom width table, users of Vty-based applications
148+are likely to eventually experience rendering problems with with wide
149+characters. We recommend that developers of Vty-based applications either:
150+
151+* Provide the `vty-build-width-table` tool and documentation for running
152+ it and updating the Vty configuration, or
153+* Have the application invoke the Vty library's table-building
154+ functionality and load the table at startup without using the Vty
155+ configuration.
156+
157+The best option will depend on a number of factors: the user audience,
158+the amount of risk posed by wide character rendering, the terminal
159+emulators in use, etc.
160+
161+# Contributing
162+
163+If you decide to contribute, that's great! Here are some guidelines you
164+should consider to make submitting patches easier for all concerned:
165+
166+ - If you want to take on big things, talk to me first; let's have a
167+ design/vision discussion before you start coding. Create a GitHub
168+ issue and we can use that as the place to hash things out.
169+ - If you make changes, make them consistent with the syntactic
170+ conventions already used in the codebase.
171+ - Please provide Haddock documentation for any changes you make.
94
172
95−### Using cabal
173+# Known Issues
96
174
97−After installing `ncurses` to the user environment:
175+* Terminals have numerous quirks and bugs, so mileage may vary. Please
176+ report issues as you encounter them and provide details on your
177+ terminal emulator, operating system, etc.
98
178
99−~~~
179+* STOP, TERM and INT signals are not handled.
100−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib
101−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build
102−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test
103−~~~
104
180
105−## Code Coverage
181+* The character encoding of the terminal is assumed to be UTF-8 if
182+ unicode is used.
106
183
107−As of last testing, profiling causes issues with coverage when enabled.
184+* Terminfo is assumed to be correct unless there is an override
108−To evaluate coverage, configure as follows:
185+ configured. Some terminals will not have correct special key support
186+ (shifted F10 etc). See `Config` for customizing vty's behavior for a
187+ particular terminal.
188+
189+* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which
190+ appears to be limited to Linux and BSD.
109
191
110−~~~
192+# Further Reading
111−rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \
112− --disable-library-profiling \
113− --disable-executable-profiling
114−~~~
115
193
116−## Profiling
194+Good sources of documentation for terminal programming are:
117
195
118−~~~
196+* https://github.com/b4winckler/vim/blob/master/src/term.c
119−rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
197+* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
120− --enable-library-profiling \
198+* http://ulisse.elettra.trieste.it/services/doc/serial/config.html
121− --enable-executable-profiling
199+* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html
122−~~~
200+* http://www.unixwiz.net/techtips/termios-vmin-vtime.html
201+* http://vt100.net/docs/vt100-ug/chapter3.html
cbits/get_tty_erase.cnew file+18
@@ -0,0 +1,18 @@
1+#include <termios.h>
2+#include <stdio.h>
3+#include <unistd.h>
4+#include <stdlib.h>
5+
6+// Given a file descriptor for a terminal, get the ERASE character for
7+// the terminal. If the terminal info cannot be obtained, this returns
8+// zero.
9+char vty_get_tty_erase(int fd)
10+{
11+ struct termios trm;
12+
13+ if (0 == tcgetattr(fd, &trm)) {
14+ return (char) trm.c_cc[VERASE];
15+ } else {
16+ return (char) 0;
17+ }
18+}
cbits/gwinsz.c+14−5
@@ -1,9 +1,18 @@
1#include <sys/ioctl.h>
1#include <sys/ioctl.h>
2
2
3unsigned long vty_c_get_window_size(int fd) {
3unsigned long vty_c_get_window_size(int fd) {
4− struct winsize w;
4+ struct winsize w;
5− if (ioctl (fd, TIOCGWINSZ, &w) >= 0)
5+ if (ioctl (fd, TIOCGWINSZ, &w) >= 0)
6− return (w.ws_row << 16) + w.ws_col;
6+ return (w.ws_row << 16) + w.ws_col;
7− else
7+ else
8− return 0x190050;
8+ return 0x190050;
9+}
10+
11+void vty_c_set_window_size(int fd, unsigned long val) {
12+ struct winsize w;
13+ if (ioctl(fd, TIOCGWINSZ, &w) >= 0) {
14+ w.ws_row = val >> 16;
15+ w.ws_col = val & 0xFFFF;
16+ ioctl(fd, TIOCSWINSZ, &w);
17+ }
9}
18}
cbits/gwinsz.h+2−1
@@ -1 +1,2 @@
1−unsigned long vty_c_get_window_size(void);
1+unsigned long vty_c_get_window_size(int fd);
2+unsigned long vty_c_set_window_size(int fd, unsigned long val);
cbits/mk_wcwidth.c+136−2
@@ -60,6 +60,28 @@
60 */
60 */
61
61
62#include <HsFFI.h>
62#include <HsFFI.h>
63+#include <stdlib.h>
64+#include <string.h>
65+
66+// The maximum size for a custom character width table is the total
67+// number of possible characters as dictated by the compiler.
68+#define MAX_CUSTOM_TABLE_SIZE (HS_CHAR_MAX + 1)
69+
70+// The pointer to the start of the custom character width table, if
71+// any. If this is NULL or this is set but the ready flag is false, the
72+// built-in tree search logic is used.
73+static uint8_t* custom_table = NULL;
74+
75+// The size of the custom table, in entries. This should only be set
76+// if custom_table is not NULL. Its value should be the size of the
77+// custom_table array.
78+static uint32_t custom_table_size = 0;
79+
80+// A flag indicating whether the custom table is ready for
81+// use. This should only be set once the table has been
82+// allocated with vty_init_custom_table and initialized with
83+// vty_set_custom_table_range.
84+static uint8_t custom_table_ready = 0;
63
85
64struct interval {
86struct interval {
65 int first;
87 int first;
@@ -119,7 +141,7 @@ static int vty_bisearch(HsChar ucs, const struct interval *table, int max) {
119 * in ISO 10646.
141 * in ISO 10646.
120 */
142 */
121
143
122−HsInt vty_mk_wcwidth(HsChar ucs)
144+static HsInt builtin_wcwidth(HsChar ucs)
123{
145{
124 /* sorted list of non-overlapping intervals of non-spacing characters */
146 /* sorted list of non-overlapping intervals of non-spacing characters */
125 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
147 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
@@ -182,7 +204,7 @@ HsInt vty_mk_wcwidth(HsChar ucs)
182
204
183 /* binary search in table of non-spacing characters */
205 /* binary search in table of non-spacing characters */
184 if (vty_bisearch(ucs, combining,
206 if (vty_bisearch(ucs, combining,
185− sizeof(combining) / sizeof(struct interval) - 1))
207+ sizeof(combining) / sizeof(struct interval) - 1))
186 return 0;
208 return 0;
187
209
188 /* if we arrive here, ucs is not a combining or C0/C1 control character */
210 /* if we arrive here, ucs is not a combining or C0/C1 control character */
@@ -202,3 +224,115 @@ HsInt vty_mk_wcwidth(HsChar ucs)
202 (ucs >= 0x20000 && ucs <= 0x2fffd) ||
224 (ucs >= 0x20000 && ucs <= 0x2fffd) ||
203 (ucs >= 0x30000 && ucs <= 0x3fffd)));
225 (ucs >= 0x30000 && ucs <= 0x3fffd)));
204}
226}
227+
228+// Return the width, in terminal cells, of the specified character.
229+//
230+// If the global custom width table is present, that table will be
231+// consulted for the character's width. If the character is not in
232+// the table, zero will be returned. If the custom width table is not
233+// present, the built-in width table will be used.
234+HsInt vty_mk_wcwidth(HsChar ch)
235+{
236+ if (custom_table_ready) {
237+ if ((ch >= 0) && (ch < custom_table_size)) {
238+ return custom_table[ch];
239+ } else {
240+ return -1;
241+ }
242+ } else {
243+ return builtin_wcwidth(ch);
244+ }
245+}
246+
247+// Initialize a custom character width table.
248+//
249+// This allocates a new character width table of the specified size
250+// (in characters). If a custom table has already been allocated, this
251+// returns 1. Otherwise it allocates a new table, initializes all of its
252+// entries to 1, and returns zero.
253+//
254+// Note that this does *not* mark the table as ready for use. Until the
255+// table is marked ready, it will not be used by vty_mk_wcwidth. To mark
256+// the table as ready, call vty_activate_custom_table() after the table
257+// has been set up with calls to vty_set_custom_table_range.
258+int vty_init_custom_table(int size)
259+{
260+ if (custom_table == NULL) {
261+ if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) {
262+ custom_table_ready = 0;
263+ custom_table = malloc(size);
264+ memset(custom_table, 1, size);
265+ custom_table_size = size;
266+ return 0;
267+ } else {
268+ return 1;
269+ }
270+ } else {
271+ return 1;
272+ }
273+}
274+
275+// Set the specified character range in the custom width table to the
276+// specified width.
277+//
278+// This function sets 'width' as the character width for all entries
279+// in the custom character table starting at the 'start' entry and
280+// including all entries up to and including 'start + size - 1'.
281+//
282+// If this succeeds, it returns zero. If it fails, it returns 1. It
283+// fails if the table is not allocated, marked as ready (i.e. it is in
284+// use and has already been populated), or if the start or size values
285+// are not in bounds for the table.
286+int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width)
287+{
288+ if ((custom_table == NULL) ||
289+ (size >= custom_table_size) ||
290+ (start >= custom_table_size) ||
291+ ((start + 1) >= (custom_table_size - size)) ||
292+ custom_table_ready) {
293+ return 1;
294+ } else {
295+ memset(custom_table + start, width, size);
296+ return 0;
297+ }
298+}
299+
300+// Mark the allocated custom character width table as ready for use.
301+//
302+// After this call, further calls to vty_set_custom_table_range will
303+// fail.
304+//
305+// This function returns 0 if it succeeds. If it fails, it returns 1.
306+// It fails if the custom table is already ready or if it has not been
307+// allocated.
308+int vty_activate_custom_table()
309+{
310+ if (custom_table_ready || (custom_table == NULL)) {
311+ return 1;
312+ } else {
313+ custom_table_ready = 1;
314+ return 0;
315+ }
316+}
317+
318+// Returns whether a custom character width table has been marked ready.
319+int vty_custom_table_ready()
320+{
321+ return custom_table_ready;
322+}
323+
324+// Deallocate the custom width table.
325+//
326+// This does nothing if there is no allocated custom width table, or if
327+// there is one but it is in use (marked ready). This is only useful if
328+// an initial allocation succeeds, but range population fails, after
329+// which point the application may want to deallocate the table to avoid
330+// leaving it in an intermediate state.
331+void vty_deallocate_custom_table()
332+{
333+ if ((custom_table != NULL) && (!custom_table_ready)) {
334+ free(custom_table);
335+ custom_table = NULL;
336+ custom_table_size = 0;
337+ }
338+}
demos/Demo.hs+14−8
@@ -1,5 +1,4 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2−
3module Main where
2module Main where
4
3
5import Graphics.Vty
4import Graphics.Vty
@@ -8,7 +7,6 @@ import Control.Applicative hiding ((<|>))
8import Control.Arrow
7import Control.Arrow
9import Control.Monad.RWS
8import Control.Monad.RWS
10
9
11−import Data.Default (def)
12import Data.Sequence (Seq, (<|) )
10import Data.Sequence (Seq, (<|) )
13import qualified Data.Sequence as Seq
11import qualified Data.Sequence as Seq
14import Data.Foldable
12import Data.Foldable
@@ -19,8 +17,8 @@ type App = RWST Vty () (Seq String) IO
19
17
20main = do
18main = do
21 vty <- if True -- change to false for emacs-like input processing
19 vty <- if True -- change to false for emacs-like input processing
22− then mkVty def
20+ then mkVty defaultConfig
23− else mkVty (def { vmin = Just 2, vtime = Just 300 } )
21+ else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )
24 _ <- execRWST (vtyInteract False) vty Seq.empty
22 _ <- execRWST (vtyInteract False) vty Seq.empty
25 shutdown vty
23 shutdown vty
26
24
@@ -33,7 +31,8 @@ introText = vertCat $ map (string defAttr)
33 [ "this line is hidden by the top layer"
31 [ "this line is hidden by the top layer"
34 , "The vty demo program will echo the events generated by the pressed keys."
32 , "The vty demo program will echo the events generated by the pressed keys."
35 , "Below there is a 240 color box."
33 , "Below there is a 240 color box."
36− , "Followed by a description of the 16 color pallete."
34+ , "Followed by a description of the 16 color palette."
35+ , "Followed by tones of red using a 24-bit palette."
37 , "If the 240 color box is not visible then the terminal"
36 , "If the 240 color box is not visible then the terminal"
38 , "claims 240 colors are not supported."
37 , "claims 240 colors are not supported."
39 , "Try setting TERM to xterm-256color"
38 , "Try setting TERM to xterm-256color"
@@ -44,12 +43,19 @@ introText = vertCat $ map (string defAttr)
44 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
45 ]
44 ]
46
45
46+splitColorImages :: [Image] -> [[Image]]
47+splitColorImages [] = []
48+splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
49+
50+fullcolorbox :: Image
51+fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages
52+ where
53+ colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255]
54+
47colorbox_240 :: Image
55colorbox_240 :: Image
48colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
49 where
57 where
50 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
51− splitColorImages [] = []
52− splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
53
59
54colorbox_16 :: Image
60colorbox_16 :: Image
55colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
61colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
@@ -72,7 +78,7 @@ updateDisplay = do
72 "Press ESC to exit. Events for keys below."
78 "Press ESC to exit. Events for keys below."
73 eventLog <- foldMap (string defAttr) <$> get
79 eventLog <- foldMap (string defAttr) <$> get
74 let pic = picForImage (info <-> eventLog)
80 let pic = picForImage (info <-> eventLog)
75− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
81+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
76 vty <- ask
82 vty <- ask
77 liftIO $ update vty pic
83 liftIO $ update vty pic
78
84
demos/ModeDemo.hs+2
@@ -2,6 +2,8 @@ module Main where
2
2
3import Control.Applicative
3import Control.Applicative
4import Data.Monoid
4import Data.Monoid
5+import Foreign.C.Types (CInt(..), CChar(..))
6+import System.Posix.Types (Fd(..))
5
7
6import Graphics.Vty
8import Graphics.Vty
7
9
src/Codec/Binary/UTF8/Debug.hs+4−6
@@ -1,7 +1,6 @@
1{-# OPTIONS_HADDOCK hide #-}
1{-# OPTIONS_HADDOCK hide #-}
2-- Copyright 2009 Corey O'Connor
2-- Copyright 2009 Corey O'Connor
3−module Codec.Binary.UTF8.Debug
3+module Codec.Binary.UTF8.Debug where
4− where
5
4
6import Codec.Binary.UTF8.String ( encode )
5import Codec.Binary.UTF8.String ( encode )
7
6
@@ -9,11 +8,10 @@ import Data.Word
9
8
10import Numeric
9import Numeric
11
10
12−-- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the
11+-- | Converts an array of ISO-10646 characters (Char type) to an array
13−-- corresponding UTF8 byte sequence
12+-- of Word8 bytes that is the corresponding UTF8 byte sequence
14utf8FromIso :: [Int] -> [Word8]
13utf8FromIso :: [Int] -> [Word8]
15utf8FromIso = encode . map toEnum
14utf8FromIso = encode . map toEnum
16
15
17ppUtf8 :: [Int] -> IO ()
16ppUtf8 :: [Int] -> IO ()
18−ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso
17+ppUtf8 = print . map (`showHex` "") . utf8FromIso
19−
src/Data/Sequence/Extra.hs+1−1
@@ -7,7 +7,7 @@ import Data.Sequence
7import Control.Parallel.Strategies
7import Control.Parallel.Strategies
8
8
9instance NFData a => NFData (Seq a) where
9instance NFData a => NFData (Seq a) where
10− rnf = \v -> rnf' (viewl v)
10+ rnf = rnf' . viewl
11 where
11 where
12 rnf' EmptyL = ()
12 rnf' EmptyL = ()
13 rnf' (a :< r) = rnf a >| rnf' (viewl r)
13 rnf' (a :< r) = rnf a >| rnf' (viewl r)
src/Data/Terminfo/Eval.hs+13−20
@@ -1,18 +1,14 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# OPTIONS_GHC -funbox-strict-fields #-}
3{-# OPTIONS_GHC -funbox-strict-fields #-}
5{-# OPTIONS_HADDOCK hide #-}
4{-# OPTIONS_HADDOCK hide #-}
6
5
7−#ifndef MIN_VERSION_base
8−#defined MIN_VERSION_base(x,y,z) 1
9−#endif
10−
11−{- Evaluates the paramaterized terminfo string capability with the given parameters.
6+-- | Evaluates the paramaterized terminfo string capability with the
12− -
7+-- given parameters.
13− -}
14−module Data.Terminfo.Eval (writeCapExpr)
8+module Data.Terminfo.Eval
9+ ( writeCapExpr
10+ )
15− where
11+where
16
12
17import Blaze.ByteString.Builder.Word
13import Blaze.ByteString.Builder.Word
18import Blaze.ByteString.Builder
14import Blaze.ByteString.Builder
@@ -27,10 +23,6 @@ import Data.List
27
23
28import qualified Data.Vector.Unboxed as Vector
24import qualified Data.Vector.Unboxed as Vector
29
25
30−#if !(MIN_VERSION_base(4,8,0))
31−import Data.Word
32−#endif
33−
34-- | capability evaluator state
26-- | capability evaluator state
35data EvalState = EvalState
27data EvalState = EvalState
36 { evalStack :: ![CapParam]
28 { evalStack :: ![CapParam]
@@ -50,7 +42,7 @@ pop = do
50
42
51readParam :: Word -> Eval CapParam
43readParam :: Word -> Eval CapParam
52readParam pn = do
44readParam pn = do
53− !params <- get >>= return . evalParams
45+ !params <- evalParams <$> get
54 return $! genericIndex params pn
46 return $! genericIndex params pn
55
47
56push :: CapParam -> Eval ()
48push :: CapParam -> Eval ()
@@ -72,11 +64,11 @@ writeCapExpr cap params =
72 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
73
65
74writeCapOps :: CapOps -> Eval ()
66writeCapOps :: CapOps -> Eval ()
75−writeCapOps ops = mapM_ writeCapOp ops
67+writeCapOps = mapM_ writeCapOp
76
68
77writeCapOp :: CapOp -> Eval ()
69writeCapOp :: CapOp -> Eval ()
78writeCapOp (Bytes !offset !count) = do
70writeCapOp (Bytes !offset !count) = do
79− !cap <- get >>= return . evalExpression
71+ !cap <- evalExpression <$> get
80 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
81 Vector.forM_ bytes $ tell.writeWord8
73 Vector.forM_ bytes $ tell.writeWord8
82writeCapOp DecOut = do
74writeCapOp DecOut = do
@@ -95,9 +87,10 @@ writeCapOp (Conditional expr parts) = do
95 writeContitionalParts [] = return ()
87 writeContitionalParts [] = return ()
96 writeContitionalParts ((trueOps, falseOps) : falseParts) = do
88 writeContitionalParts ((trueOps, falseOps) : falseParts) = do
97 -- (man 5 terminfo)
89 -- (man 5 terminfo)
98− -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
90+ -- Usually the %? expr part pushes a value onto the stack,
91+ -- and %t pops it from the stack, testing if it is nonzero
99− -- stack, testing if it is nonzero (true). If it is zero (false), control
92+ -- (true). If it is zero (false), control passes to the %e
100− -- passes to the %e (else) part.
93+ -- (else) part.
101 v <- pop
94 v <- pop
102 if v /= 0
95 if v /= 0
103 then writeCapOps trueOps
96 then writeCapOps trueOps
src/Data/Terminfo/Parse.hs+33−32
@@ -1,22 +1,22 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
3−{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE CPP #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
5−{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
6{-# OPTIONS_GHC -funbox-strict-fields -O #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6+{-# OPTIONS_HADDOCK hide #-}
7
7
8−#ifndef MIN_VERSION_base
9−#defined MIN_VERSION_base(x,y,z) 1
10−#endif
11−
12−module Data.Terminfo.Parse ( module Data.Terminfo.Parse
8+module Data.Terminfo.Parse
9+ ( module Data.Terminfo.Parse
13− , Text.Parsec.ParseError
10+ , Text.Parsec.ParseError
14− )
11+ )
15− where
12+where
16
13
17import Control.Monad ( liftM )
14import Control.Monad ( liftM )
18import Control.DeepSeq
15import Control.DeepSeq
19
16
17+#if !(MIN_VERSION_base(4,11,0))
18+import Data.Semigroup (Semigroup(..))
19+#endif
20import Data.Word
20import Data.Word
21import qualified Data.Vector.Unboxed as Vector
21import qualified Data.Vector.Unboxed as Vector
22
22
@@ -24,10 +24,6 @@ import Numeric (showHex)
24
24
25import Text.Parsec
25import Text.Parsec
26
26
27−#if !(MIN_VERSION_base(4,8,0))
28−import Data.Monoid
29−#endif
30−
31data CapExpression = CapExpression
27data CapExpression = CapExpression
32 { capOps :: !CapOps
28 { capOps :: !CapOps
33 , capBytes :: !(Vector.Vector Word8)
29 , capBytes :: !(Vector.Vector Word8)
@@ -43,7 +39,7 @@ instance Show CapExpression where
43 ++ " <= " ++ show (sourceString c)
39 ++ " <= " ++ show (sourceString c)
44 where
40 where
45 hexDump :: [Word8] -> String
41 hexDump :: [Word8] -> String
46− hexDump = foldr (\b s -> showHex b s) ""
42+ hexDump = foldr showHex ""
47
43
48instance NFData CapExpression where
44instance NFData CapExpression where
49 rnf (CapExpression ops !_bytes !str !c !pOps)
45 rnf (CapExpression ops !_bytes !str !c !pOps)
@@ -55,11 +51,11 @@ type CapOps = [CapOp]
55data CapOp =
51data CapOp =
56 Bytes !Int !Int -- offset count
52 Bytes !Int !Int -- offset count
57 | DecOut | CharOut
53 | DecOut | CharOut
58− -- This stores a 0-based index to the parameter. However the operation that implies this op is
54+ -- This stores a 0-based index to the parameter. However the
59− -- 1-based
55+ -- operation that implies this op is 1-based
60 | PushParam !Word | PushValue !Word
56 | PushParam !Word | PushValue !Word
61− -- The conditional parts are the sequence of (%t expression, %e expression) pairs.
57+ -- The conditional parts are the sequence of (%t expression, %e
62− -- The %e expression may be NOP
58+ -- The expression) pairs. %e expression may be NOP
63 | Conditional
59 | Conditional
64 { conditionalExpr :: !CapOps
60 { conditionalExpr :: !CapOps
65 , conditionalParts :: ![(CapOps, CapOps)]
61 , conditionalParts :: ![(CapOps, CapOps)]
@@ -103,12 +99,12 @@ parseCapExpression capString =
103 Left e -> Left e
99 Left e -> Left e
104 Right buildResults -> Right $ constructCapExpression capString buildResults
100 Right buildResults -> Right $ constructCapExpression capString buildResults
105
101
106−constructCapExpression :: [Char] -> BuildResults -> CapExpression
102+constructCapExpression :: String -> BuildResults -> CapExpression
107constructCapExpression capString buildResults =
103constructCapExpression capString buildResults =
108 let expr = CapExpression
104 let expr = CapExpression
109 { capOps = outCapOps buildResults
105 { capOps = outCapOps buildResults
110− -- The cap bytes are the lower 8 bits of the input string's characters.
106+ -- The cap bytes are the lower 8 bits of the input
111− -- \todo Verify the input string actually contains an 8bit byte per character.
107+ -- string's characters.
112 , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
108 , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
113 , sourceString = capString
109 , sourceString = capString
114 , paramCount = outParamCount buildResults
110 , paramCount = outParamCount buildResults
@@ -132,7 +128,7 @@ paramEscapeParser = do
132literalPercentParser :: CapParser BuildResults
128literalPercentParser :: CapParser BuildResults
133literalPercentParser = do
129literalPercentParser = do
134 _ <- char '%'
130 _ <- char '%'
135− startOffset <- getState >>= return . nextOffset
131+ startOffset <- nextOffset <$> getState
136 incOffset 1
132 incOffset 1
137 return $ BuildResults 0 [Bytes startOffset 1] []
133 return $ BuildResults 0 [Bytes startOffset 1] []
138
134
@@ -158,7 +154,7 @@ incrementOpParser = do
158pushOpParser :: CapParser BuildResults
154pushOpParser :: CapParser BuildResults
159pushOpParser = do
155pushOpParser = do
160 _ <- char 'p'
156 _ <- char 'p'
161− paramN <- digit >>= return . (\d -> read [d])
157+ paramN <- read . pure <$> digit
162 incOffset 2
158 incOffset 2
163 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
164
160
@@ -303,7 +299,7 @@ compareOpParser
303bytesOpParser :: CapParser BuildResults
299bytesOpParser :: CapParser BuildResults
304bytesOpParser = do
300bytesOpParser = do
305 bytes <- many1 $ satisfy (/= '%')
301 bytes <- many1 $ satisfy (/= '%')
306− startOffset <- getState >>= return . nextOffset
302+ startOffset <- nextOffset <$> getState
307 let !c = length bytes
303 let !c = length bytes
308 !s <- getState
304 !s <- getState
309 let s' = s { nextOffset = startOffset + c }
305 let s' = s { nextOffset = startOffset + c }
@@ -337,11 +333,16 @@ data BuildResults = BuildResults
337 , outParamOps :: !ParamOps
333 , outParamOps :: !ParamOps
338 }
334 }
339
335
340−instance Monoid BuildResults where
336+instance Semigroup BuildResults where
341− mempty = BuildResults 0 [] []
342− v0 `mappend` v1
337+ v0 <> v1
343 = BuildResults
338 = BuildResults
344− { outParamCount = (outParamCount v0) `max` (outParamCount v1)
339+ { outParamCount = outParamCount v0 `max` outParamCount v1
345− , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
340+ , outCapOps = outCapOps v0 <> outCapOps v1
346− , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
341+ , outParamOps = outParamOps v0 <> outParamOps v1
347 }
342 }
343+
344+instance Monoid BuildResults where
345+ mempty = BuildResults 0 [] []
346+#if !(MIN_VERSION_base(4,11,0))
347+ mappend = (<>)
348+#endif
src/Graphics/Text/Width.hs+51−16
@@ -1,29 +1,64 @@
1-- Copyright 2009 Corey O'Connor
1-- Copyright 2009 Corey O'Connor
2{-# OPTIONS_GHC -D_XOPEN_SOURCE #-}
2{-# OPTIONS_GHC -D_XOPEN_SOURCE #-}
3{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE ForeignFunctionInterface #-}
4+-- | This module provides functions to measure the terminal column width
5+-- of characters and strings.
6+--
7+-- The functions provided in this module all ultimately make calls to
8+-- the C implementation in @cbits/mk_wcwidth.c@. That code manages some
9+-- global state that carries a table of Unicode character widths. For
10+-- more details, see 'Graphics.Vty.UnicodeWidthTable.Install', the C
11+-- code, and the "Multi-Column Character Support" section of the project
12+-- @README@.
4−module Graphics.Text.Width ( wcwidth
13+module Graphics.Text.Width
14+ ( wcwidth
5− , wcswidth
15+ , wcswidth
16+ , wctwidth
17+ , wctlwidth
6− , safeWcwidth
18+ , safeWcwidth
7− , safeWcswidth
19+ , safeWcswidth
20+ , safeWctwidth
21+ , safeWctlwidth
8− )
22+ )
9− where
23+where
24+
25+import Data.List (foldl')
26+import qualified Data.Text as T
27+import qualified Data.Text.Lazy as TL
10
28
11foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
29foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
12
30
13wcswidth :: String -> Int
31wcswidth :: String -> Int
14−wcswidth = sum . map wcwidth
32+wcswidth = foldl' (\l c -> wcwidth c + l) 0
33+{-# INLINE [1] wcswidth #-}
15
34
16−-- XXX: Characters with unknown widths occupy 1 column?
35+wctwidth :: T.Text -> Int
17−--
36+wctwidth = T.foldl' (\l c -> wcwidth c + l) 0
18−-- Not sure if this is actually correct. I presume there is a replacement character that is output
37+
19−-- by the terminal instead of the character and this replacement character is 1 column wide. If this
38+wctlwidth :: TL.Text -> Int
20−-- is not true for all terminals then a per-terminal replacement character width needs to be
39+wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0
21−-- implemented.
22
40
41+{-# RULES
42+"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x
43+"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x
44+ #-}
45+
23−-- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width
46+-- | Returns the display width of a character. Assumes all characters
47+-- with unknown widths are 0 width.
24safeWcwidth :: Char -> Int
48safeWcwidth :: Char -> Int
25safeWcwidth = max 0 . wcwidth
49safeWcwidth = max 0 . wcwidth
26
50
27−-- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width
51+-- | Returns the display width of a string. Assumes all characters with
52+-- unknown widths are 0 width.
28safeWcswidth :: String -> Int
53safeWcswidth :: String -> Int
29−safeWcswidth = sum . map safeWcwidth
54+safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0
55+
56+-- | Returns the display width of a text. Assumes all characters with
57+-- unknown widths are 0 width.
58+safeWctwidth :: T.Text -> Int
59+safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0
60+
61+-- | Returns the display width of a lazy text. Assumes all characters
62+-- with unknown widths are 0 width.
63+safeWctlwidth :: TL.Text -> Int
64+safeWctlwidth = TL.foldl' (\l c -> safeWcwidth c + l) 0
src/Graphics/Vty.hs+174−90
@@ -1,17 +1,20 @@
1−-- | Vty supports input and output to terminal devices.
1+{-# LANGUAGE CPP #-}
2−--
2+{-# LANGUAGE ScopedTypeVariables #-}
3−-- - Input to the terminal is provided to the app as a sequence of 'Event's.
3+
4−--
4+-- | Vty provides interfaces for both terminal input and terminal
5−-- - The output is defined by a 'Picture'. Which is one or more layers of 'Image's.
5+-- output.
6−--
7−-- - The module "Graphics.Vty.Image" provides a number of constructor equations that will build
8−-- correct 'Image' values. See 'string', '<|>', and '<->' for starters.
9--
6--
10−-- - The constructors in "Graphics.Vty.Image.Internal" should not be used.
7+-- - Input to the terminal is provided to the Vty application as a
8+-- sequence of 'Event's.
11--
9--
10+-- - Output is provided to Vty by the application in the form of a
11+-- 'Picture'. A 'Picture' is one or more layers of 'Image's.
12+-- 'Image' values can be built by the various constructors in
13+-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
12−-- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
14+-- values in the "Graphics.Vty.Attributes" module.
13--
15--
14−-- See the vty-examples package for a number of examples.
16+-- Vty uses threads internally, so programs made with Vty need to be
17+-- compiled with the threaded runtime using the GHC @-threaded@ option.
15--
18--
16-- @
19-- @
17-- import "Graphics.Vty"
20-- import "Graphics.Vty"
@@ -28,103 +31,153 @@
28-- 'shutdown' vty
31-- 'shutdown' vty
29-- 'print' (\"Last event was: \" '++' 'show' e)
32-- 'print' (\"Last event was: \" '++' 'show' e)
30-- @
33-- @
31−--
32−-- Good sources of documentation for terminal programming are:
33−--
34−-- - <https://github.com/b4winckler/vim/blob/master/src/term.c>
35−--
36−-- - <http://invisible-island.net/xterm/ctlseqs/ctlseqs.html>
37−--
38−-- - <http://ulisse.elettra.trieste.it/services/doc/serial/config.html>
39−--
40−-- - <http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html>
41−--
42−-- - <http://www.unixwiz.net/techtips/termios-vmin-vtime.html>
43−--
44−-- - <http://vt100.net/docs/vt100-ug/chapter3.html vt100 control sequences>
45−module Graphics.Vty ( Vty(..)
34+module Graphics.Vty
35+ ( Vty(..)
46− , mkVty
36+ , mkVty
37+ , setWindowTitle
38+ , Mode(..)
47− , module Graphics.Vty.Config
39+ , module Graphics.Vty.Config
48− , module Graphics.Vty.Input
40+ , module Graphics.Vty.Input
49− , module Graphics.Vty.Output
41+ , module Graphics.Vty.Output
42+ , module Graphics.Vty.Output.Interface
50− , module Graphics.Vty.Picture
43+ , module Graphics.Vty.Picture
51− , DisplayRegion
44+ , module Graphics.Vty.Image
52− , Mode(..)
45+ , module Graphics.Vty.Attributes
53− )
46+ )
54− where
47+where
55−
56−import Graphics.Vty.Prelude
57
48
58import Graphics.Vty.Config
49import Graphics.Vty.Config
59import Graphics.Vty.Input
50import Graphics.Vty.Input
51+import Graphics.Vty.Input.Events
60import Graphics.Vty.Output
52import Graphics.Vty.Output
61import Graphics.Vty.Output.Interface
53import Graphics.Vty.Output.Interface
62import Graphics.Vty.Picture
54import Graphics.Vty.Picture
55+import Graphics.Vty.Image
56+import Graphics.Vty.Attributes
57+import Graphics.Vty.UnicodeWidthTable.IO
58+import Graphics.Vty.UnicodeWidthTable.Install
63
59
60+import Data.Char (isPrint, showLitChar)
61+import qualified Data.ByteString.Char8 as BS8
62+
63+import qualified Control.Exception as E
64+import Control.Monad (when)
64import Control.Concurrent.STM
65import Control.Concurrent.STM
65
66
66import Data.IORef
67import Data.IORef
68+#if !(MIN_VERSION_base(4,11,0))
67−import Data.Monoid
69+import Data.Semigroup ((<>))
70+#endif
68
71
69−-- | The main object. At most one should be created.
72+-- | A Vty value represents a handle to the Vty library that the
73+-- application must create in order to use Vty.
70--
74--
71-- The use of Vty typically follows this process:
75-- The use of Vty typically follows this process:
72--
76--
73−-- 0. initialize vty
77+-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
74−--
78+--
75−-- 1. use the update equation of Vty to display a picture
79+-- 2. Use 'update' to display a picture.
76−--
77−-- 2. repeat
78−--
80+--
79−-- 3. shutdown vty.
81+-- 3. Use 'nextEvent' to get the next input event.
80−--
82+--
81−-- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe".
83+-- 4. Depending on the event, go to 2 or 5.
84+--
85+-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
86+-- this point the 'Vty' handle cannot be used again.
82−--
87+--
83−-- This does not assure any thread safety. In theory, as long as an update action is not executed
88+-- Operations on Vty handles are not thread-safe.
84−-- when another update action is already then it's safe to call this on multiple threads.
85−--
86−-- \todo Remove explicit `shutdown` requirement.
87−data Vty = Vty
89+data Vty =
90+ Vty { update :: Picture -> IO ()
88− { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context
91+ -- ^ Outputs the given 'Picture'.
89− -- implicitly managed by Vty. The managed display context is reset on resize.
92+ , nextEvent :: IO Event
90− update :: Picture -> IO ()
93+ -- ^ Return the next 'Event' or block until one becomes
91− -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event
94+ -- available.
92− -- is a 'EvResize'.
95+ , nextEventNonblocking :: IO (Maybe Event)
93− , nextEvent :: IO Event
96+ -- ^ Non-blocking version of 'nextEvent'.
94− -- | The input interface. See 'Input'
95− , inputIface :: Input
97+ , inputIface :: Input
96− -- | The output interface. See 'Output'
98+ -- ^ The input interface. See 'Input'.
97− , outputIface :: Output
99+ , outputIface :: Output
98− -- | Refresh the display. 'nextEvent' will refresh the display if a resize occurs.
100+ -- ^ The output interface. See 'Output'.
101+ , refresh :: IO ()
102+ -- ^ Refresh the display. If other programs output to the
99− -- If other programs output to the terminal and mess up the display then the application might
103+ -- terminal and mess up the display then the application might
100− -- want to force a refresh.
104+ -- want to force a refresh using this function.
101− , refresh :: IO ()
105+ , shutdown :: IO ()
102− -- | Clean up after vty.
106+ -- ^ Clean up after vty. A call to this function is necessary to
107+ -- cleanly restore the terminal state before application exit.
103− -- The above methods will throw an exception if executed after this is executed.
108+ -- The above methods will throw an exception if executed after
104− , shutdown :: IO ()
109+ -- this is executed. Idempotent.
110+ , isShutdown :: IO Bool
105− }
111+ }
106
112
107−-- | Set up the state object for using vty. At most one state object should be
113+-- | Create a Vty handle. At most one handle should be created at a time
108−-- created at a time for a given terminal device.
114+-- for a given terminal device.
109--
115--
116+-- The specified configuration is added to the the configuration
110−-- The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence.
117+-- loaded by 'userConfig' with the 'userConfig' configuration taking
111−-- See "Graphics.Vty.Config"
118+-- precedence. See "Graphics.Vty.Config".
112--
119--
113−-- For most applications @mkVty def@ is sufficient.
120+-- For most applications @mkVty defaultConfig@ is sufficient.
114mkVty :: Config -> IO Vty
121mkVty :: Config -> IO Vty
115mkVty appConfig = do
122mkVty appConfig = do
116 config <- (<> appConfig) <$> userConfig
123 config <- (<> appConfig) <$> userConfig
117− input <- inputForConfig config
118− out <- outputForConfig config
119− intMkVty input out
120
124
125+ when (allowCustomUnicodeWidthTables config /= Just False) $
126+ installCustomWidthTable config
127+
128+ input <- inputForConfig config
129+ out <- outputForConfig config
130+ internalMkVty input out
131+
132+installCustomWidthTable :: Config -> IO ()
133+installCustomWidthTable c = do
134+ let doLog s = case debugLog c of
135+ Nothing -> return ()
136+ Just path -> appendFile path $ "installWidthTable: " <> s <> "\n"
137+
138+ customInstalled <- isCustomTableReady
139+ when (not customInstalled) $ do
140+ mTerm <- currentTerminalName
141+ case mTerm of
142+ Nothing ->
143+ doLog "No current terminal name available"
144+ Just currentTerm ->
145+ case lookup currentTerm (termWidthMaps c) of
146+ Nothing ->
147+ doLog "Current terminal not found in custom character width mapping list"
148+ Just path -> do
149+ tableResult <- E.try $ readUnicodeWidthTable path
150+ case tableResult of
151+ Left (e::E.SomeException) ->
152+ doLog $ "Error reading custom character width table " <>
153+ "at " <> show path <> ": " <> show e
154+ Right (Left msg) ->
155+ doLog $ "Error reading custom character width table " <>
156+ "at " <> show path <> ": " <> msg
157+ Right (Right table) -> do
158+ installResult <- E.try $ installUnicodeWidthTable table
159+ case installResult of
160+ Left (e::E.SomeException) ->
161+ doLog $ "Error installing unicode table (" <>
162+ show path <> ": " <> show e
163+ Right () ->
164+ doLog $ "Successfully installed Unicode width table " <>
165+ " from " <> show path
166+
121−intMkVty :: Input -> Output -> IO Vty
167+internalMkVty :: Input -> Output -> IO Vty
122−intMkVty input out = do
168+internalMkVty input out = do
123 reserveDisplay out
169 reserveDisplay out
170+
171+ shutdownVar <- newTVarIO False
124 let shutdownIo = do
172 let shutdownIo = do
173+ alreadyShutdown <- atomically $ swapTVar shutdownVar True
174+ when (not alreadyShutdown) $ do
125− shutdownInput input
175+ shutdownInput input
126− releaseDisplay out
176+ releaseDisplay out
127− releaseTerminal out
177+ releaseTerminal out
178+
179+ let shutdownStatus = readTVarIO shutdownVar
180+
128 lastPicRef <- newIORef Nothing
181 lastPicRef <- newIORef Nothing
129 lastUpdateRef <- newIORef Nothing
182 lastUpdateRef <- newIORef Nothing
130
183
@@ -156,16 +209,47 @@ intMkVty input out = do
156 mPic <- readIORef lastPicRef
209 mPic <- readIORef lastPicRef
157 maybe (return ()) innerUpdate mPic
210 maybe (return ()) innerUpdate mPic
158
211
212+ let mkResize = uncurry EvResize <$> displayBounds out
213+
214+ translateInternalEvent ResumeAfterSignal = mkResize
215+ translateInternalEvent (InputEvent e) = return e
216+
217+ gkey = do
159− let gkey = do k <- atomically $ readTChan $ _eventChannel input
218+ e <- atomically $ readTChan $ _eventChannel input
219+ translateInternalEvent e
220+ gkey' = do
221+ mEv <- atomically $ tryReadTChan $ _eventChannel input
160− case k of
222+ case mEv of
161− (EvResize _ _) -> displayBounds out
223+ Just e -> Just <$> translateInternalEvent e
162− >>= return . (\(w,h)-> EvResize w h)
163− _ -> return k
224+ Nothing -> return Nothing
164
225
165 return $ Vty { update = innerUpdate
226 return $ Vty { update = innerUpdate
166 , nextEvent = gkey
227 , nextEvent = gkey
228+ , nextEventNonblocking = gkey'
167 , inputIface = input
229 , inputIface = input
168 , outputIface = out
230 , outputIface = out
169 , refresh = innerRefresh
231 , refresh = innerRefresh
170 , shutdown = shutdownIo
232 , shutdown = shutdownIo
233+ , isShutdown = shutdownStatus
171 }
234 }
235+
236+-- | Set the terminal window title string.
237+--
238+-- This function emits an Xterm-compatible escape sequence that we
239+-- anticipate will work for essentially all modern terminal emulators.
240+-- Ideally we'd use a terminal capability for this, but there does not
241+-- seem to exist a termcap for setting window titles. If you find that
242+-- this function does not work for a given terminal emulator, please
243+-- report the issue.
244+--
245+-- For details, see:
246+--
247+-- https://tldp.org/HOWTO/Xterm-Title-3.html
248+setWindowTitle :: Vty -> String -> IO ()
249+setWindowTitle vty title = do
250+ let sanitize :: String -> String
251+ sanitize = concatMap sanitizeChar
252+ sanitizeChar c | not (isPrint c) = showLitChar c ""
253+ | otherwise = [c]
254+ let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007"
255+ outputByteBuffer (outputIface vty) buf
src/Graphics/Vty/Attributes.hs+120−118
@@ -1,68 +1,89 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE StandaloneDeriving #-}
2+{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE DeriveAnyClass #-}
4−{-# LANGUAGE RankNTypes #-}
5−
6−#ifndef MIN_VERSION_base
7−#defined MIN_VERSION_base(x,y,z) 1
8−#endif
9
4
10-- | Display attributes
5-- | Display attributes
11--
6--
12−-- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes:
7+-- Attributes have three components: a foreground color, a background
8+-- color, and a style mask. The simplest attribute is the default
9+-- attribute, or 'defAttr'. Attributes can be modified with
10+-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,
13--
11--
14-- @
12-- @
15−-- defAttr `withForeColor` red
13+-- defAttr \`withForeColor\` red
16-- @
14-- @
17--
15--
18−-- Is the attribute that will set the foreground color to red and the background color to the
16+-- 'Image' constructors often require an 'Attr' to indicate the
19−-- default.
17+-- attributes used in the image, e.g.,
20−--
21−-- This can then be used to build an image with a red foreground like so:
22--
18--
23-- @
19-- @
24−-- string (defAttr `withForeColor` red) "this text will be red"
20+-- string (defAttr \`withForeColor\` red) "this text will be red"
25-- @
21-- @
26--
22--
27−-- The default attributes set by 'defAttr' have a presentation determined by the terminal. This is
23+-- The appearance of 'Image's using 'defAttr' is determined by the The
24+-- terminal, so this is not something VTY can control. The user is free
28−-- not something VTY can control. The user is free to define the color scheme of the terminal as
25+-- to The define the color scheme of the terminal as they see fit.
29−-- they see fit. Up to the limits of the terminal anyways.
30−--
26+--
31−-- The value 'currentAttr' will keep the attributes of whatever was output previously.
27+-- The value 'currentAttr' will keep the attributes of whatever was
32−--
28+-- output previously.
33−-- \todo This API is very verbose IMO. I'd like something more succinct.
34−module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes
29+module Graphics.Vty.Attributes
35− , module Graphics.Vty.Attributes.Color
30+ ( module Graphics.Vty.Attributes.Color
36− , module Graphics.Vty.Attributes.Color240
31+
32+ , Attr(..)
33+ , FixedAttr(..)
34+ , MaybeDefault(..)
35+ , defAttr
36+ , currentAttr
37+
38+ -- * Styles
39+ , Style
40+ , withStyle
41+ , standout
42+ , italic
43+ , strikethrough
44+ , underline
45+ , reverseVideo
46+ , blink
47+ , dim
48+ , bold
49+ , defaultStyleMask
50+ , styleMask
51+ , hasStyle
52+
53+ -- * Setting attribute colors
54+ , withForeColor
55+ , withBackColor
56+
57+ -- * Setting hyperlinks
58+ , withURL
37− )
59+ )
38− where
60+where
39−
61+
62+import Control.DeepSeq
40import Data.Bits
63import Data.Bits
41−import Data.Default
64+import Data.Text (Text)
42import Data.Word
65import Data.Word
66+import GHC.Generics
43
67
44import Graphics.Vty.Attributes.Color
68import Graphics.Vty.Attributes.Color
45−import Graphics.Vty.Attributes.Color240
46−
47−#if !(MIN_VERSION_base(4,8,0))
48−import Data.Monoid
49−#endif
50
69
51−-- | A display attribute defines the Color and Style of all the characters rendered after the
70+-- | A display attribute defines the Color and Style of all the
52−-- attribute is applied.
71+-- characters rendered after the attribute is applied.
53--
72--
54−-- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and
73+-- At most 256 colors, picked from a 240 and 16 color palette, are
74+-- possible for the background and foreground. The 240 colors and
55−-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more
75+-- 16 colors are points in different palettes. See Color for more
56−-- information.
76+-- information.
57data Attr = Attr
77data Attr = Attr
58 { attrStyle :: !(MaybeDefault Style)
78 { attrStyle :: !(MaybeDefault Style)
59 , attrForeColor :: !(MaybeDefault Color)
79 , attrForeColor :: !(MaybeDefault Color)
60 , attrBackColor :: !(MaybeDefault Color)
80 , attrBackColor :: !(MaybeDefault Color)
81+ , attrURL :: !(MaybeDefault Text)
61− } deriving ( Eq, Show, Read )
82+ } deriving ( Eq, Show, Read, Generic, NFData )
62
83
63−-- This could be encoded into a single 32 bit word. The 32 bit word is first divided
84+-- This could be encoded into a single 32 bit word. The 32 bit word is
64−-- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to
85+-- first divided into 4 groups of 8 bits where: The first group codes
65−-- the other groups.
86+-- what action should be taken with regards to the other groups.
66-- XXYYZZ__
87-- XXYYZZ__
67-- XX - style action
88-- XX - style action
68-- 00 => reset to default
89-- 00 => reset to default
@@ -79,85 +100,47 @@ data Attr = Attr
79-- __ - unused
100-- __ - unused
80--
101--
81-- Next is the style flags
102-- Next is the style flags
82−-- SURBDO__
103+-- SURBDOI_
83-- S - standout
104-- S - standout
84-- U - underline
105-- U - underline
85-- R - reverse video
106-- R - reverse video
86-- B - blink
107-- B - blink
87-- D - dim
108-- D - dim
88-- O - bold
109-- O - bold
110+-- I - italic
89−-- __ - unused
111+-- _ - unused
90--
112--
91-- Then the foreground color encoded into 8 bits.
113-- Then the foreground color encoded into 8 bits.
92-- Then the background color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
93
115
94−instance Monoid Attr where
95− mempty = Attr mempty mempty mempty
96− mappend attr0 attr1 =
97− Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
98− ( attrForeColor attr0 `mappend` attrForeColor attr1 )
99− ( attrBackColor attr0 `mappend` attrBackColor attr1 )
100−
101−-- | Specifies the display attributes such that the final style and color values do not depend on
116+-- | Specifies the display attributes such that the final style and
117+-- color values do not depend on the previously applied display
102−-- the previously applied display attribute. The display attributes can still depend on the
118+-- attribute. The display attributes can still depend on the terminal's
103−-- terminal's default colors (unfortunately).
119+-- default colors (unfortunately).
104data FixedAttr = FixedAttr
120data FixedAttr = FixedAttr
105 { fixedStyle :: !Style
121 { fixedStyle :: !Style
106 , fixedForeColor :: !(Maybe Color)
122 , fixedForeColor :: !(Maybe Color)
107 , fixedBackColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
124+ , fixedURL :: !(Maybe Text)
108 } deriving ( Eq, Show )
125 } deriving ( Eq, Show )
109
126
110−-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the
127+-- | The style and color attributes can either be the terminal defaults.
111−-- previously applied style. Or be a specific value.
128+-- Or be equivalent to the previously applied style. Or be a specific
129+-- value.
112−data MaybeDefault v where
130+data MaybeDefault v = Default | KeepCurrent | SetTo !v
113− Default :: MaybeDefault v
131+ deriving (Eq, Read, Show)
114− KeepCurrent :: MaybeDefault v
132+
115− SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
116−
117−deriving instance Eq v => Eq (MaybeDefault v)
118−deriving instance Eq v => Show (MaybeDefault v)
119−deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
120−
121−instance Eq v => Monoid ( MaybeDefault v ) where
133+instance (NFData v) => NFData (MaybeDefault v) where
122− mempty = KeepCurrent
134+ rnf Default = ()
123− mappend Default Default = Default
124− mappend Default KeepCurrent = Default
125− mappend Default ( SetTo v ) = SetTo v
126− mappend KeepCurrent Default = Default
127− mappend KeepCurrent KeepCurrent = KeepCurrent
135+ rnf KeepCurrent = ()
128− mappend KeepCurrent ( SetTo v ) = SetTo v
136+ rnf (SetTo v) = rnf v
129− mappend ( SetTo _v ) Default = Default
137+
130− mappend ( SetTo v ) KeepCurrent = SetTo v
131− mappend ( SetTo _ ) ( SetTo v ) = SetTo v
132−
133−-- | Standard 8-color ANSI terminal color codes.
134−black, red, green, yellow, blue, magenta, cyan, white :: Color
135−black = ISOColor 0
136−red = ISOColor 1
137−green = ISOColor 2
138−yellow = ISOColor 3
139−blue = ISOColor 4
140−magenta= ISOColor 5
141−cyan = ISOColor 6
142−white = ISOColor 7
143−
144−-- | Bright/Vivid variants of the standard 8-color ANSI
145−brightBlack, brightRed, brightGreen, brightYellow :: Color
146−brightBlue, brightMagenta, brightCyan, brightWhite :: Color
147−brightBlack = ISOColor 8
148−brightRed = ISOColor 9
149−brightGreen = ISOColor 10
150−brightYellow = ISOColor 11
151−brightBlue = ISOColor 12
152−brightMagenta= ISOColor 13
153−brightCyan = ISOColor 14
154−brightWhite = ISOColor 15
155−
156−-- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute
138+-- | Styles are represented as an 8 bit word. Each bit in the word is 1
139+-- if the style attribute assigned to that bit should be applied and 0
157−-- assigned to that bit should be applied and 0 if the style attribute should not be applied.
140+-- if the style attribute should not be applied.
158type Style = Word8
141type Style = Word8
159
142
160−-- | The 6 possible style attributes:
143+-- | Valid style attributes include:
161--
144--
162-- * standout
145-- * standout
163--
146--
@@ -171,15 +154,21 @@ type Style = Word8
171--
154--
172-- * bold/bright
155-- * bold/bright
173--
156--
157+-- * italic
158+--
159+-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160+--
174−-- ( The invisible, protect, and altcharset display attributes some terminals support are not
161+-- (The invisible, protect, and altcharset display attributes some
175−-- supported via VTY.)
162+-- terminals support are not supported via VTY.)
176−standout, underline, reverseVideo, blink, dim, bold :: Style
163+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
177standout = 0x01
164standout = 0x01
178underline = 0x02
165underline = 0x02
179−reverseVideo = 0x04
166+reverseVideo = 0x04
180blink = 0x08
167blink = 0x08
181dim = 0x10
168dim = 0x10
182bold = 0x20
169bold = 0x20
170+italic = 0x40
171+strikethrough = 0x80
183
172
184defaultStyleMask :: Style
173defaultStyleMask :: Style
185defaultStyleMask = 0x00
174defaultStyleMask = 0x00
@@ -205,22 +194,35 @@ withBackColor attr c = attr { attrBackColor = SetTo c }
205
194
206-- | Add the given style attribute
195-- | Add the given style attribute
207withStyle :: Attr -> Style -> Attr
196withStyle :: Attr -> Style -> Attr
197+withStyle attr 0 = attr
208withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
209
199
200+-- | Add a hyperlinked URL using the proposed [escape sequences for
201+-- hyperlinked
202+-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
203+-- These escape sequences are comparatively new and aren't widely
204+-- supported in terminal emulators yet, but most terminal emulators
205+-- that don't know about these sequences will ignore these sequences,
206+-- and therefore this should fall back sensibly. In some cases they
207+-- won't and this will result in garbage, so this is why hyperlinking is
208+-- disabled by default, in which case this combinator has no observable
209+-- effect. To enable it, enable 'Hyperlink' mode on your Vty output
210+-- interface.
211+withURL :: Attr -> Text -> Attr
212+withURL attr url = attr { attrURL = SetTo url }
213+
210−-- | Sets the style, background color and foreground color to the default values for the terminal.
214+-- | Sets the style, background color and foreground color to the
215+-- default values for the terminal. There is no easy way to determine
211−-- There is no easy way to determine what the default background and foreground colors are.
216+-- what the default background and foreground colors are.
212defAttr :: Attr
217defAttr :: Attr
213−defAttr = Attr Default Default Default
218+defAttr = Attr Default Default Default Default
214−
215−instance Default Attr where
216− def = defAttr
217
219
218−-- | Keeps the style, background color and foreground color that was previously set. Used to
220+-- | Keeps the style, background color and foreground color that was
219−-- override some part of the previous style.
221+-- previously set. Used to override some part of the previous style.
220--
222--
221-- EG: current_style `withForeColor` brightMagenta
223-- EG: current_style `withForeColor` brightMagenta
222--
224--
223−-- Would be the currently applied style (be it underline, bold, etc) but with the foreground color
225+-- Would be the currently applied style (be it underline, bold, etc) but
224−-- set to brightMagenta.
226+-- with the foreground color set to brightMagenta.
225currentAttr :: Attr
227currentAttr :: Attr
226−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
228+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs+160−19
@@ -1,15 +1,74 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE MultiWayIf #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+
1−module Graphics.Vty.Attributes.Color where
6+module Graphics.Vty.Attributes.Color
7+ ( Color(..)
8+ , ColorMode(..)
9+
10+ -- * Detecting Terminal Color Support
11+ , detectColorMode
12+
13+ -- ** Fixed Colors
14+ -- | Standard 8-color ANSI terminal color codes.
15+ --
16+ -- Note that these map to colors in the terminal's custom palette. For
17+ -- instance, `white` maps to whatever the terminal color theme uses for
18+ -- white.
19+ --
20+ -- Use these functions if you want to make apps that fit the terminal theme.
21+ -- If you want access to more/stronger colors use `rgbColor`
22+ , black
23+ , red
24+ , green
25+ , yellow
26+ , blue
27+ , magenta
28+ , cyan
29+ , white
30+
31+ -- | Bright/Vivid variants of the standard 8-color ANSI
32+ , brightBlack
33+ , brightRed
34+ , brightGreen
35+ , brightYellow
36+ , brightBlue
37+ , brightMagenta
38+ , brightCyan
39+ , brightWhite
40+ -- ** Creating Colors From RGB
41+ , linearColor
42+ , srgbColor
43+ , rgbColor
44+ , color240
45+ , module Graphics.Vty.Attributes.Color240
46+ )
47+where
48+
2import Data.Word
49import Data.Word
50+import GHC.Generics
51+import Control.DeepSeq
52+import System.Environment (lookupEnv)
53+
54+import qualified System.Console.Terminfo as Terminfo
55+import Control.Exception (catch)
56+import Data.Maybe
57+
58+import Graphics.Vty.Attributes.Color240
3
59
4-- | Abstract data type representing a color.
60-- | Abstract data type representing a color.
5--
61--
6−-- Currently the foreground and background color are specified as points in either a:
62+-- Currently the foreground and background color are specified as points
63+-- in either a:
7--
64--
8−-- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8
65+-- * 16 color palette. Where the first 8 colors are equal to the 8
66+-- colors of the ISO 6429 (ANSI) 8 color palette and the second 8
9−-- color palette and the second 8 colors are bright/vivid versions of the first 8 colors.
67+-- colors are bright/vivid versions of the first 8 colors.
10--
68--
11−-- * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first
69+-- * 240 color palette. This palette is a regular sampling of the full
12−-- 224 colors. The remaining 16 colors is a greyscale palette.
70+-- RGB colorspace for the first 224 colors. The remaining 16 colors is
71+-- a greyscale palette.
13--
72--
14-- The 8 ISO 6429 (ANSI) colors are as follows:
73-- The 8 ISO 6429 (ANSI) colors are as follows:
15--
74--
@@ -29,22 +88,104 @@ import Data.Word
29--
88--
30-- 7. white
89-- 7. white
31--
90--
32−-- The mapping from points in the 240 color palette to colors actually displayable by the terminal
91+-- The mapping from points in the 240 color palette to colors actually
92+-- displayable by the terminal depends on the number of colors the
33−-- depends on the number of colors the terminal claims to support. Which is usually determined by
93+-- terminal claims to support. Which is usually determined by the
34−-- the terminfo "colors" property. If this property is not being accurately reported then the color
94+-- terminfo "colors" property. If this property is not being accurately
35−-- reproduction will be incorrect.
95+-- reported then the color reproduction will be incorrect.
36--
96--
37−-- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8
97+-- If the terminal reports <= 16 colors then the 240 color palette
98+-- points are only mapped to the 8 color palette. I'm not sure of
38−-- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not
99+-- the RGB points for the "bright" colors which is why they are not
39-- addressable via the 240 color palette.
100-- addressable via the 240 color palette.
40--
101--
41−-- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest
102+-- If the terminal reports > 16 colors then the 240 color palette
103+-- points are mapped to the nearest points in a ("color count" - 16)
42−-- points in a ("color count" - 16) subsampling of the 240 color palette.
104+-- subsampling of the 240 color palette.
43--
105--
44−-- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors.
106+-- All of this assumes the terminals are behaving similarly to xterm and
107+-- rxvt when handling colors. And that the individual colors have not
45−-- And that the individual colors have not been remapped by the user. There may be a way to verify
108+-- been remapped by the user. There may be a way to verify this through
46−-- this through terminfo but I don't know it.
109+-- terminfo but I don't know it.
47--
110--
48-- Seriously, terminal color support is INSANE.
111-- Seriously, terminal color support is INSANE.
49−data Color = ISOColor !Word8 | Color240 !Word8
112+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8
50− deriving ( Eq, Show, Read )
113+ deriving ( Eq, Show, Read, Generic, NFData )
114+
115+data ColorMode
116+ = NoColor
117+ | ColorMode8
118+ | ColorMode16
119+ | ColorMode240 !Word8
120+ | FullColor
121+ deriving ( Eq, Show )
122+
123+detectColorMode :: String -> IO ColorMode
124+detectColorMode termName' = do
125+ term <- catch (Just <$> Terminfo.setupTerm termName')
126+ (\(_ :: Terminfo.SetupTermError) -> return Nothing)
127+ let getCap cap = term >>= \t -> Terminfo.getCapability t cap
128+ termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")
129+ colorterm <- lookupEnv "COLORTERM"
130+ return $ if
131+ | termColors < 8 -> NoColor
132+ | termColors < 16 -> ColorMode8
133+ | termColors == 16 -> ColorMode16
134+ | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)
135+ | colorterm == Just "truecolor" -> FullColor
136+ | colorterm == Just "24bit" -> FullColor
137+ | otherwise -> ColorMode240 240
138+
139+black, red, green, yellow, blue, magenta, cyan, white :: Color
140+black = ISOColor 0
141+red = ISOColor 1
142+green = ISOColor 2
143+yellow = ISOColor 3
144+blue = ISOColor 4
145+magenta= ISOColor 5
146+cyan = ISOColor 6
147+white = ISOColor 7
148+
149+brightBlack, brightRed, brightGreen, brightYellow :: Color
150+brightBlue, brightMagenta, brightCyan, brightWhite :: Color
151+brightBlack = ISOColor 8
152+brightRed = ISOColor 9
153+brightGreen = ISOColor 10
154+brightYellow = ISOColor 11
155+brightBlue = ISOColor 12
156+brightMagenta= ISOColor 13
157+brightCyan = ISOColor 14
158+brightWhite = ISOColor 15
159+
160+linearColor :: Integral i => i -> i -> i -> Color
161+linearColor r g b = RGBColor r' g' b'
162+ where
163+ r' = fromIntegral (clamp r) :: Word8
164+ g' = fromIntegral (clamp g) :: Word8
165+ b' = fromIntegral (clamp b) :: Word8
166+ clamp = min 255 . max 0
167+
168+srgbColor :: Integral i => i -> i -> i -> Color
169+srgbColor r g b =
170+ -- srgb to rgb transformation as described at
171+ -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation
172+ --
173+ -- TODO: it may be worth translating this to a lookup table, as with color240
174+ let shrink n = fromIntegral n / 255 :: Double
175+ -- called gamma^-1 in wiki
176+ gamma u
177+ | u <= 0.04045 = u/12.92
178+ | otherwise = ((u + 0.055) / 1.055) ** 2.4
179+ -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?
180+ expand n = round (255 * n)
181+ convert = expand . gamma . shrink
182+ in RGBColor (convert r) (convert g) (convert b)
183+
184+color240 :: Integral i => i -> i -> i -> Color
185+color240 r g b = Color240 (rgbColorToColor240 r g b)
186+
187+-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.
188+-- This function is lossy in the sense that we only internally support 240 colors but the
189+-- #RRGGBB format supports 16^3 colors.
190+rgbColor :: Integral i => i -> i -> i -> Color
191+rgbColor = color240
src/Graphics/Vty/Attributes/Color240.hs+291−254
@@ -1,261 +1,298 @@
1−{-
2− - This header file was generated by ./256colres.pl
1+-- This header file was generated by ./256colres.pl
3− -}
4−module Graphics.Vty.Attributes.Color240 where
2+module Graphics.Vty.Attributes.Color240
5−
3+ ( rgbColorToColor240
6−import Graphics.Vty.Attributes.Color
4+ , color240CodeToRGB
5+ )
6+where
7
7
8+import Data.Word (Word8)
8import Text.Printf
9import Text.Printf
9
10
10−-- | RGB color to 240 color palette.
11+-- Note: rgbColor's mapping from RGB to 240 colors was generated from
11−--
12−-- generated from 256colres.pl which is forked from xterm 256colres.pl
12+-- 256colres.pl which is forked from xterm 256colres.pl.
13−-- todo: all values get clamped high.
13+
14+-- | Create a value in the Color240 set from an RGB triple
14−rgbColor :: Integral i => i -> i -> i -> Color
15+rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
15−rgbColor r g b
16+rgbColorToColor240 r g b
16 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
17 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
17− | r == 8 && g == 8 && b == 8 = Color240 216
18+ | r == 8 && g == 8 && b == 8 = 216
18− | r == 18 && g == 18 && b == 18 = Color240 217
19+ | r == 18 && g == 18 && b == 18 = 217
19− | r == 28 && g == 28 && b == 28 = Color240 218
20+ | r == 28 && g == 28 && b == 28 = 218
20− | r == 38 && g == 38 && b == 38 = Color240 219
21+ | r == 38 && g == 38 && b == 38 = 219
21− | r == 48 && g == 48 && b == 48 = Color240 220
22+ | r == 48 && g == 48 && b == 48 = 220
22− | r == 58 && g == 58 && b == 58 = Color240 221
23+ | r == 58 && g == 58 && b == 58 = 221
23− | r == 68 && g == 68 && b == 68 = Color240 222
24+ | r == 68 && g == 68 && b == 68 = 222
24− | r == 78 && g == 78 && b == 78 = Color240 223
25+ | r == 78 && g == 78 && b == 78 = 223
25− | r == 88 && g == 88 && b == 88 = Color240 224
26+ | r == 88 && g == 88 && b == 88 = 224
26− | r == 98 && g == 98 && b == 98 = Color240 225
27+ | r == 98 && g == 98 && b == 98 = 225
27− | r == 108 && g == 108 && b == 108 = Color240 226
28+ | r == 108 && g == 108 && b == 108 = 226
28− | r == 118 && g == 118 && b == 118 = Color240 227
29+ | r == 118 && g == 118 && b == 118 = 227
29− | r == 128 && g == 128 && b == 128 = Color240 228
30+ | r == 128 && g == 128 && b == 128 = 228
30− | r == 138 && g == 138 && b == 138 = Color240 229
31+ | r == 138 && g == 138 && b == 138 = 229
31− | r == 148 && g == 148 && b == 148 = Color240 230
32+ | r == 148 && g == 148 && b == 148 = 230
32− | r == 158 && g == 158 && b == 158 = Color240 231
33+ | r == 158 && g == 158 && b == 158 = 231
33− | r == 168 && g == 168 && b == 168 = Color240 232
34+ | r == 168 && g == 168 && b == 168 = 232
34− | r == 178 && g == 178 && b == 178 = Color240 233
35+ | r == 178 && g == 178 && b == 178 = 233
35− | r == 188 && g == 188 && b == 188 = Color240 234
36+ | r == 188 && g == 188 && b == 188 = 234
36− | r == 198 && g == 198 && b == 198 = Color240 235
37+ | r == 198 && g == 198 && b == 198 = 235
37− | r == 208 && g == 208 && b == 208 = Color240 236
38+ | r == 208 && g == 208 && b == 208 = 236
38− | r == 218 && g == 218 && b == 218 = Color240 237
39+ | r == 218 && g == 218 && b == 218 = 237
39− | r == 228 && g == 228 && b == 228 = Color240 238
40+ | r == 228 && g == 228 && b == 228 = 238
40− | r == 238 && g == 238 && b == 238 = Color240 239
41+ | r == 238 && g == 238 && b == 238 = 239
41− | r <= 0 && g <= 0 && b <= 0 = Color240 0
42+ | otherwise = 36 * go r + 6 * go g + go b
42− | r <= 0 && g <= 0 && b <= 95 = Color240 1
43+ where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."
43− | r <= 0 && g <= 0 && b <= 135 = Color240 2
44− | r <= 0 && g <= 0 && b <= 175 = Color240 3
45− | r <= 0 && g <= 0 && b <= 215 = Color240 4
46− | r <= 0 && g <= 0 && b <= 255 = Color240 5
47− | r <= 0 && g <= 95 && b <= 0 = Color240 6
48− | r <= 0 && g <= 95 && b <= 95 = Color240 7
49− | r <= 0 && g <= 95 && b <= 135 = Color240 8
50− | r <= 0 && g <= 95 && b <= 175 = Color240 9
51− | r <= 0 && g <= 95 && b <= 215 = Color240 10
52− | r <= 0 && g <= 95 && b <= 255 = Color240 11
53− | r <= 0 && g <= 135 && b <= 0 = Color240 12
54− | r <= 0 && g <= 135 && b <= 95 = Color240 13
55− | r <= 0 && g <= 135 && b <= 135 = Color240 14
56− | r <= 0 && g <= 135 && b <= 175 = Color240 15
57− | r <= 0 && g <= 135 && b <= 215 = Color240 16
58− | r <= 0 && g <= 135 && b <= 255 = Color240 17
59− | r <= 0 && g <= 175 && b <= 0 = Color240 18
60− | r <= 0 && g <= 175 && b <= 95 = Color240 19
61− | r <= 0 && g <= 175 && b <= 135 = Color240 20
62− | r <= 0 && g <= 175 && b <= 175 = Color240 21
63− | r <= 0 && g <= 175 && b <= 215 = Color240 22
64− | r <= 0 && g <= 175 && b <= 255 = Color240 23
65− | r <= 0 && g <= 215 && b <= 0 = Color240 24
66− | r <= 0 && g <= 215 && b <= 95 = Color240 25
67− | r <= 0 && g <= 215 && b <= 135 = Color240 26
68− | r <= 0 && g <= 215 && b <= 175 = Color240 27
69− | r <= 0 && g <= 215 && b <= 215 = Color240 28
70− | r <= 0 && g <= 215 && b <= 255 = Color240 29
71− | r <= 0 && g <= 255 && b <= 0 = Color240 30
72− | r <= 0 && g <= 255 && b <= 95 = Color240 31
73− | r <= 0 && g <= 255 && b <= 135 = Color240 32
74− | r <= 0 && g <= 255 && b <= 175 = Color240 33
75− | r <= 0 && g <= 255 && b <= 215 = Color240 34
76− | r <= 0 && g <= 255 && b <= 255 = Color240 35
77− | r <= 95 && g <= 0 && b <= 0 = Color240 36
78− | r <= 95 && g <= 0 && b <= 95 = Color240 37
79− | r <= 95 && g <= 0 && b <= 135 = Color240 38
80− | r <= 95 && g <= 0 && b <= 175 = Color240 39
81− | r <= 95 && g <= 0 && b <= 215 = Color240 40
82− | r <= 95 && g <= 0 && b <= 255 = Color240 41
83− | r <= 95 && g <= 95 && b <= 0 = Color240 42
84− | r <= 95 && g <= 95 && b <= 95 = Color240 43
85− | r <= 95 && g <= 95 && b <= 135 = Color240 44
86− | r <= 95 && g <= 95 && b <= 175 = Color240 45
87− | r <= 95 && g <= 95 && b <= 215 = Color240 46
88− | r <= 95 && g <= 95 && b <= 255 = Color240 47
89− | r <= 95 && g <= 135 && b <= 0 = Color240 48
90− | r <= 95 && g <= 135 && b <= 95 = Color240 49
91− | r <= 95 && g <= 135 && b <= 135 = Color240 50
92− | r <= 95 && g <= 135 && b <= 175 = Color240 51
93− | r <= 95 && g <= 135 && b <= 215 = Color240 52
94− | r <= 95 && g <= 135 && b <= 255 = Color240 53
95− | r <= 95 && g <= 175 && b <= 0 = Color240 54
96− | r <= 95 && g <= 175 && b <= 95 = Color240 55
97− | r <= 95 && g <= 175 && b <= 135 = Color240 56
98− | r <= 95 && g <= 175 && b <= 175 = Color240 57
99− | r <= 95 && g <= 175 && b <= 215 = Color240 58
100− | r <= 95 && g <= 175 && b <= 255 = Color240 59
101− | r <= 95 && g <= 215 && b <= 0 = Color240 60
102− | r <= 95 && g <= 215 && b <= 95 = Color240 61
103− | r <= 95 && g <= 215 && b <= 135 = Color240 62
104− | r <= 95 && g <= 215 && b <= 175 = Color240 63
105− | r <= 95 && g <= 215 && b <= 215 = Color240 64
106− | r <= 95 && g <= 215 && b <= 255 = Color240 65
107− | r <= 95 && g <= 255 && b <= 0 = Color240 66
108− | r <= 95 && g <= 255 && b <= 95 = Color240 67
109− | r <= 95 && g <= 255 && b <= 135 = Color240 68
110− | r <= 95 && g <= 255 && b <= 175 = Color240 69
111− | r <= 95 && g <= 255 && b <= 215 = Color240 70
112− | r <= 95 && g <= 255 && b <= 255 = Color240 71
113− | r <= 135 && g <= 0 && b <= 0 = Color240 72
114− | r <= 135 && g <= 0 && b <= 95 = Color240 73
115− | r <= 135 && g <= 0 && b <= 135 = Color240 74
116− | r <= 135 && g <= 0 && b <= 175 = Color240 75
117− | r <= 135 && g <= 0 && b <= 215 = Color240 76
118− | r <= 135 && g <= 0 && b <= 255 = Color240 77
119− | r <= 135 && g <= 95 && b <= 0 = Color240 78
120− | r <= 135 && g <= 95 && b <= 95 = Color240 79
121− | r <= 135 && g <= 95 && b <= 135 = Color240 80
122− | r <= 135 && g <= 95 && b <= 175 = Color240 81
123− | r <= 135 && g <= 95 && b <= 215 = Color240 82
124− | r <= 135 && g <= 95 && b <= 255 = Color240 83
125− | r <= 135 && g <= 135 && b <= 0 = Color240 84
126− | r <= 135 && g <= 135 && b <= 95 = Color240 85
127− | r <= 135 && g <= 135 && b <= 135 = Color240 86
128− | r <= 135 && g <= 135 && b <= 175 = Color240 87
129− | r <= 135 && g <= 135 && b <= 215 = Color240 88
130− | r <= 135 && g <= 135 && b <= 255 = Color240 89
131− | r <= 135 && g <= 175 && b <= 0 = Color240 90
132− | r <= 135 && g <= 175 && b <= 95 = Color240 91
133− | r <= 135 && g <= 175 && b <= 135 = Color240 92
134− | r <= 135 && g <= 175 && b <= 175 = Color240 93
135− | r <= 135 && g <= 175 && b <= 215 = Color240 94
136− | r <= 135 && g <= 175 && b <= 255 = Color240 95
137− | r <= 135 && g <= 215 && b <= 0 = Color240 96
138− | r <= 135 && g <= 215 && b <= 95 = Color240 97
139− | r <= 135 && g <= 215 && b <= 135 = Color240 98
140− | r <= 135 && g <= 215 && b <= 175 = Color240 99
141− | r <= 135 && g <= 215 && b <= 215 = Color240 100
142− | r <= 135 && g <= 215 && b <= 255 = Color240 101
143− | r <= 135 && g <= 255 && b <= 0 = Color240 102
144− | r <= 135 && g <= 255 && b <= 95 = Color240 103
145− | r <= 135 && g <= 255 && b <= 135 = Color240 104
146− | r <= 135 && g <= 255 && b <= 175 = Color240 105
147− | r <= 135 && g <= 255 && b <= 215 = Color240 106
148− | r <= 135 && g <= 255 && b <= 255 = Color240 107
149− | r <= 175 && g <= 0 && b <= 0 = Color240 108
150− | r <= 175 && g <= 0 && b <= 95 = Color240 109
151− | r <= 175 && g <= 0 && b <= 135 = Color240 110
152− | r <= 175 && g <= 0 && b <= 175 = Color240 111
153− | r <= 175 && g <= 0 && b <= 215 = Color240 112
154− | r <= 175 && g <= 0 && b <= 255 = Color240 113
155− | r <= 175 && g <= 95 && b <= 0 = Color240 114
156− | r <= 175 && g <= 95 && b <= 95 = Color240 115
157− | r <= 175 && g <= 95 && b <= 135 = Color240 116
158− | r <= 175 && g <= 95 && b <= 175 = Color240 117
159− | r <= 175 && g <= 95 && b <= 215 = Color240 118
160− | r <= 175 && g <= 95 && b <= 255 = Color240 119
161− | r <= 175 && g <= 135 && b <= 0 = Color240 120
162− | r <= 175 && g <= 135 && b <= 95 = Color240 121
163− | r <= 175 && g <= 135 && b <= 135 = Color240 122
164− | r <= 175 && g <= 135 && b <= 175 = Color240 123
165− | r <= 175 && g <= 135 && b <= 215 = Color240 124
166− | r <= 175 && g <= 135 && b <= 255 = Color240 125
167− | r <= 175 && g <= 175 && b <= 0 = Color240 126
168− | r <= 175 && g <= 175 && b <= 95 = Color240 127
169− | r <= 175 && g <= 175 && b <= 135 = Color240 128
170− | r <= 175 && g <= 175 && b <= 175 = Color240 129
171− | r <= 175 && g <= 175 && b <= 215 = Color240 130
172− | r <= 175 && g <= 175 && b <= 255 = Color240 131
173− | r <= 175 && g <= 215 && b <= 0 = Color240 132
174− | r <= 175 && g <= 215 && b <= 95 = Color240 133
175− | r <= 175 && g <= 215 && b <= 135 = Color240 134
176− | r <= 175 && g <= 215 && b <= 175 = Color240 135
177− | r <= 175 && g <= 215 && b <= 215 = Color240 136
178− | r <= 175 && g <= 215 && b <= 255 = Color240 137
179− | r <= 175 && g <= 255 && b <= 0 = Color240 138
180− | r <= 175 && g <= 255 && b <= 95 = Color240 139
181− | r <= 175 && g <= 255 && b <= 135 = Color240 140
182− | r <= 175 && g <= 255 && b <= 175 = Color240 141
183− | r <= 175 && g <= 255 && b <= 215 = Color240 142
184− | r <= 175 && g <= 255 && b <= 255 = Color240 143
185− | r <= 215 && g <= 0 && b <= 0 = Color240 144
186− | r <= 215 && g <= 0 && b <= 95 = Color240 145
187− | r <= 215 && g <= 0 && b <= 135 = Color240 146
188− | r <= 215 && g <= 0 && b <= 175 = Color240 147
189− | r <= 215 && g <= 0 && b <= 215 = Color240 148
190− | r <= 215 && g <= 0 && b <= 255 = Color240 149
191− | r <= 215 && g <= 95 && b <= 0 = Color240 150
192− | r <= 215 && g <= 95 && b <= 95 = Color240 151
193− | r <= 215 && g <= 95 && b <= 135 = Color240 152
194− | r <= 215 && g <= 95 && b <= 175 = Color240 153
195− | r <= 215 && g <= 95 && b <= 215 = Color240 154
196− | r <= 215 && g <= 95 && b <= 255 = Color240 155
197− | r <= 215 && g <= 135 && b <= 0 = Color240 156
198− | r <= 215 && g <= 135 && b <= 95 = Color240 157
199− | r <= 215 && g <= 135 && b <= 135 = Color240 158
200− | r <= 215 && g <= 135 && b <= 175 = Color240 159
201− | r <= 215 && g <= 135 && b <= 215 = Color240 160
202− | r <= 215 && g <= 135 && b <= 255 = Color240 161
203− | r <= 215 && g <= 175 && b <= 0 = Color240 162
204− | r <= 215 && g <= 175 && b <= 95 = Color240 163
205− | r <= 215 && g <= 175 && b <= 135 = Color240 164
206− | r <= 215 && g <= 175 && b <= 175 = Color240 165
207− | r <= 215 && g <= 175 && b <= 215 = Color240 166
208− | r <= 215 && g <= 175 && b <= 255 = Color240 167
209− | r <= 215 && g <= 215 && b <= 0 = Color240 168
210− | r <= 215 && g <= 215 && b <= 95 = Color240 169
211− | r <= 215 && g <= 215 && b <= 135 = Color240 170
212− | r <= 215 && g <= 215 && b <= 175 = Color240 171
213− | r <= 215 && g <= 215 && b <= 215 = Color240 172
214− | r <= 215 && g <= 215 && b <= 255 = Color240 173
215− | r <= 215 && g <= 255 && b <= 0 = Color240 174
216− | r <= 215 && g <= 255 && b <= 95 = Color240 175
217− | r <= 215 && g <= 255 && b <= 135 = Color240 176
218− | r <= 215 && g <= 255 && b <= 175 = Color240 177
219− | r <= 215 && g <= 255 && b <= 215 = Color240 178
220− | r <= 215 && g <= 255 && b <= 255 = Color240 179
221− | r <= 255 && g <= 0 && b <= 0 = Color240 180
222− | r <= 255 && g <= 0 && b <= 95 = Color240 181
223− | r <= 255 && g <= 0 && b <= 135 = Color240 182
224− | r <= 255 && g <= 0 && b <= 175 = Color240 183
225− | r <= 255 && g <= 0 && b <= 215 = Color240 184
226− | r <= 255 && g <= 0 && b <= 255 = Color240 185
227− | r <= 255 && g <= 95 && b <= 0 = Color240 186
228− | r <= 255 && g <= 95 && b <= 95 = Color240 187
229− | r <= 255 && g <= 95 && b <= 135 = Color240 188
230− | r <= 255 && g <= 95 && b <= 175 = Color240 189
231− | r <= 255 && g <= 95 && b <= 215 = Color240 190
232− | r <= 255 && g <= 95 && b <= 255 = Color240 191
233− | r <= 255 && g <= 135 && b <= 0 = Color240 192
234− | r <= 255 && g <= 135 && b <= 95 = Color240 193
235− | r <= 255 && g <= 135 && b <= 135 = Color240 194
236− | r <= 255 && g <= 135 && b <= 175 = Color240 195
237− | r <= 255 && g <= 135 && b <= 215 = Color240 196
238− | r <= 255 && g <= 135 && b <= 255 = Color240 197
239− | r <= 255 && g <= 175 && b <= 0 = Color240 198
240− | r <= 255 && g <= 175 && b <= 95 = Color240 199
241− | r <= 255 && g <= 175 && b <= 135 = Color240 200
242− | r <= 255 && g <= 175 && b <= 175 = Color240 201
243− | r <= 255 && g <= 175 && b <= 215 = Color240 202
244− | r <= 255 && g <= 175 && b <= 255 = Color240 203
245− | r <= 255 && g <= 215 && b <= 0 = Color240 204
246− | r <= 255 && g <= 215 && b <= 95 = Color240 205
247− | r <= 255 && g <= 215 && b <= 135 = Color240 206
248− | r <= 255 && g <= 215 && b <= 175 = Color240 207
249− | r <= 255 && g <= 215 && b <= 215 = Color240 208
250− | r <= 255 && g <= 215 && b <= 255 = Color240 209
251− | r <= 255 && g <= 255 && b <= 0 = Color240 210
252− | r <= 255 && g <= 255 && b <= 95 = Color240 211
253− | r <= 255 && g <= 255 && b <= 135 = Color240 212
254− | r <= 255 && g <= 255 && b <= 175 = Color240 213
255− | r <= 255 && g <= 255 && b <= 215 = Color240 214
256− | r <= 255 && g <= 255 && b <= 255 = Color240 215
257− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
258 (fromIntegral r :: Int)
44 (fromIntegral r :: Int)
259 (fromIntegral g :: Int)
45 (fromIntegral g :: Int)
260− (fromIntegral b :: Int))
46+ (fromIntegral b :: Int)))
47+
48+simpleColor_ :: Integral i => Word8 -> i -> Word8
49+simpleColor_ e c
50+ | c <= 0 = 0
51+ | c <= 95 = 1
52+ | c <= 255 = fromIntegral ((c-16) `div` 40)
53+ | otherwise = e
261
54
55+-- | Create a RGB triple from a value in the Color240 set.
56+color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)
57+color240CodeToRGB n = case n of
58+ 0 -> Just (0, 0, 0)
59+ 1 -> Just (0, 0, 95)
60+ 2 -> Just (0, 0, 135)
61+ 3 -> Just (0, 0, 175)
62+ 4 -> Just (0, 0, 215)
63+ 5 -> Just (0, 0, 255)
64+ 6 -> Just (0, 95, 0)
65+ 7 -> Just (0, 95, 95)
66+ 8 -> Just (0, 95, 135)
67+ 9 -> Just (0, 95, 175)
68+ 10 -> Just (0, 95, 215)
69+ 11 -> Just (0, 95, 255)
70+ 12 -> Just (0, 135, 0)
71+ 13 -> Just (0, 135, 95)
72+ 14 -> Just (0, 135, 135)
73+ 15 -> Just (0, 135, 175)
74+ 16 -> Just (0, 135, 215)
75+ 17 -> Just (0, 135, 255)
76+ 18 -> Just (0, 175, 0)
77+ 19 -> Just (0, 175, 95)
78+ 20 -> Just (0, 175, 135)
79+ 21 -> Just (0, 175, 175)
80+ 22 -> Just (0, 175, 215)
81+ 23 -> Just (0, 175, 255)
82+ 24 -> Just (0, 215, 0)
83+ 25 -> Just (0, 215, 95)
84+ 26 -> Just (0, 215, 135)
85+ 27 -> Just (0, 215, 175)
86+ 28 -> Just (0, 215, 215)
87+ 29 -> Just (0, 215, 255)
88+ 30 -> Just (0, 255, 0)
89+ 31 -> Just (0, 255, 95)
90+ 32 -> Just (0, 255, 135)
91+ 33 -> Just (0, 255, 175)
92+ 34 -> Just (0, 255, 215)
93+ 35 -> Just (0, 255, 255)
94+ 36 -> Just (95, 0, 0)
95+ 37 -> Just (95, 0, 95)
96+ 38 -> Just (95, 0, 135)
97+ 39 -> Just (95, 0, 175)
98+ 40 -> Just (95, 0, 215)
99+ 41 -> Just (95, 0, 255)
100+ 42 -> Just (95, 95, 0)
101+ 43 -> Just (95, 95, 95)
102+ 44 -> Just (95, 95, 135)
103+ 45 -> Just (95, 95, 175)
104+ 46 -> Just (95, 95, 215)
105+ 47 -> Just (95, 95, 255)
106+ 48 -> Just (95, 135, 0)
107+ 49 -> Just (95, 135, 95)
108+ 50 -> Just (95, 135, 135)
109+ 51 -> Just (95, 135, 175)
110+ 52 -> Just (95, 135, 215)
111+ 53 -> Just (95, 135, 255)
112+ 54 -> Just (95, 175, 0)
113+ 55 -> Just (95, 175, 95)
114+ 56 -> Just (95, 175, 135)
115+ 57 -> Just (95, 175, 175)
116+ 58 -> Just (95, 175, 215)
117+ 59 -> Just (95, 175, 255)
118+ 60 -> Just (95, 215, 0)
119+ 61 -> Just (95, 215, 95)
120+ 62 -> Just (95, 215, 135)
121+ 63 -> Just (95, 215, 175)
122+ 64 -> Just (95, 215, 215)
123+ 65 -> Just (95, 215, 255)
124+ 66 -> Just (95, 255, 0)
125+ 67 -> Just (95, 255, 95)
126+ 68 -> Just (95, 255, 135)
127+ 69 -> Just (95, 255, 175)
128+ 70 -> Just (95, 255, 215)
129+ 71 -> Just (95, 255, 255)
130+ 72 -> Just (135, 0, 0)
131+ 73 -> Just (135, 0, 95)
132+ 74 -> Just (135, 0, 135)
133+ 75 -> Just (135, 0, 175)
134+ 76 -> Just (135, 0, 215)
135+ 77 -> Just (135, 0, 255)
136+ 78 -> Just (135, 95, 0)
137+ 79 -> Just (135, 95, 95)
138+ 80 -> Just (135, 95, 135)
139+ 81 -> Just (135, 95, 175)
140+ 82 -> Just (135, 95, 215)
141+ 83 -> Just (135, 95, 255)
142+ 84 -> Just (135, 135, 0)
143+ 85 -> Just (135, 135, 95)
144+ 86 -> Just (135, 135, 135)
145+ 87 -> Just (135, 135, 175)
146+ 88 -> Just (135, 135, 215)
147+ 89 -> Just (135, 135, 255)
148+ 90 -> Just (135, 175, 0)
149+ 91 -> Just (135, 175, 95)
150+ 92 -> Just (135, 175, 135)
151+ 93 -> Just (135, 175, 175)
152+ 94 -> Just (135, 175, 215)
153+ 95 -> Just (135, 175, 255)
154+ 96 -> Just (135, 215, 0)
155+ 97 -> Just (135, 215, 95)
156+ 98 -> Just (135, 215, 135)
157+ 99 -> Just (135, 215, 175)
158+ 100 -> Just (135, 215, 215)
159+ 101 -> Just (135, 215, 255)
160+ 102 -> Just (135, 255, 0)
161+ 103 -> Just (135, 255, 95)
162+ 104 -> Just (135, 255, 135)
163+ 105 -> Just (135, 255, 175)
164+ 106 -> Just (135, 255, 215)
165+ 107 -> Just (135, 255, 255)
166+ 108 -> Just (175, 0, 0)
167+ 109 -> Just (175, 0, 95)
168+ 110 -> Just (175, 0, 135)
169+ 111 -> Just (175, 0, 175)
170+ 112 -> Just (175, 0, 215)
171+ 113 -> Just (175, 0, 255)
172+ 114 -> Just (175, 95, 0)
173+ 115 -> Just (175, 95, 95)
174+ 116 -> Just (175, 95, 135)
175+ 117 -> Just (175, 95, 175)
176+ 118 -> Just (175, 95, 215)
177+ 119 -> Just (175, 95, 255)
178+ 120 -> Just (175, 135, 0)
179+ 121 -> Just (175, 135, 95)
180+ 122 -> Just (175, 135, 135)
181+ 123 -> Just (175, 135, 175)
182+ 124 -> Just (175, 135, 215)
183+ 125 -> Just (175, 135, 255)
184+ 126 -> Just (175, 175, 0)
185+ 127 -> Just (175, 175, 95)
186+ 128 -> Just (175, 175, 135)
187+ 129 -> Just (175, 175, 175)
188+ 130 -> Just (175, 175, 215)
189+ 131 -> Just (175, 175, 255)
190+ 132 -> Just (175, 215, 0)
191+ 133 -> Just (175, 215, 95)
192+ 134 -> Just (175, 215, 135)
193+ 135 -> Just (175, 215, 175)
194+ 136 -> Just (175, 215, 215)
195+ 137 -> Just (175, 215, 255)
196+ 138 -> Just (175, 255, 0)
197+ 139 -> Just (175, 255, 95)
198+ 140 -> Just (175, 255, 135)
199+ 141 -> Just (175, 255, 175)
200+ 142 -> Just (175, 255, 215)
201+ 143 -> Just (175, 255, 255)
202+ 144 -> Just (215, 0, 0)
203+ 145 -> Just (215, 0, 95)
204+ 146 -> Just (215, 0, 135)
205+ 147 -> Just (215, 0, 175)
206+ 148 -> Just (215, 0, 215)
207+ 149 -> Just (215, 0, 255)
208+ 150 -> Just (215, 95, 0)
209+ 151 -> Just (215, 95, 95)
210+ 152 -> Just (215, 95, 135)
211+ 153 -> Just (215, 95, 175)
212+ 154 -> Just (215, 95, 215)
213+ 155 -> Just (215, 95, 255)
214+ 156 -> Just (215, 135, 0)
215+ 157 -> Just (215, 135, 95)
216+ 158 -> Just (215, 135, 135)
217+ 159 -> Just (215, 135, 175)
218+ 160 -> Just (215, 135, 215)
219+ 161 -> Just (215, 135, 255)
220+ 162 -> Just (215, 175, 0)
221+ 163 -> Just (215, 175, 95)
222+ 164 -> Just (215, 175, 135)
223+ 165 -> Just (215, 175, 175)
224+ 166 -> Just (215, 175, 215)
225+ 167 -> Just (215, 175, 255)
226+ 168 -> Just (215, 215, 0)
227+ 169 -> Just (215, 215, 95)
228+ 170 -> Just (215, 215, 135)
229+ 171 -> Just (215, 215, 175)
230+ 172 -> Just (215, 215, 215)
231+ 173 -> Just (215, 215, 255)
232+ 174 -> Just (215, 255, 0)
233+ 175 -> Just (215, 255, 95)
234+ 176 -> Just (215, 255, 135)
235+ 177 -> Just (215, 255, 175)
236+ 178 -> Just (215, 255, 215)
237+ 179 -> Just (215, 255, 255)
238+ 180 -> Just (255, 0, 0)
239+ 181 -> Just (255, 0, 95)
240+ 182 -> Just (255, 0, 135)
241+ 183 -> Just (255, 0, 175)
242+ 184 -> Just (255, 0, 215)
243+ 185 -> Just (255, 0, 255)
244+ 186 -> Just (255, 95, 0)
245+ 187 -> Just (255, 95, 95)
246+ 188 -> Just (255, 95, 135)
247+ 189 -> Just (255, 95, 175)
248+ 190 -> Just (255, 95, 215)
249+ 191 -> Just (255, 95, 255)
250+ 192 -> Just (255, 135, 0)
251+ 193 -> Just (255, 135, 95)
252+ 194 -> Just (255, 135, 135)
253+ 195 -> Just (255, 135, 175)
254+ 196 -> Just (255, 135, 215)
255+ 197 -> Just (255, 135, 255)
256+ 198 -> Just (255, 175, 0)
257+ 199 -> Just (255, 175, 95)
258+ 200 -> Just (255, 175, 135)
259+ 201 -> Just (255, 175, 175)
260+ 202 -> Just (255, 175, 215)
261+ 203 -> Just (255, 175, 255)
262+ 204 -> Just (255, 215, 0)
263+ 205 -> Just (255, 215, 95)
264+ 206 -> Just (255, 215, 135)
265+ 207 -> Just (255, 215, 175)
266+ 208 -> Just (255, 215, 215)
267+ 209 -> Just (255, 215, 255)
268+ 210 -> Just (255, 255, 0)
269+ 211 -> Just (255, 255, 95)
270+ 212 -> Just (255, 255, 135)
271+ 213 -> Just (255, 255, 175)
272+ 214 -> Just (255, 255, 215)
273+ 215 -> Just (255, 255, 255)
274+ 216 -> Just (8, 8, 8)
275+ 217 -> Just (18, 18, 18)
276+ 218 -> Just (28, 28, 28)
277+ 219 -> Just (38, 38, 38)
278+ 220 -> Just (48, 48, 48)
279+ 221 -> Just (58, 58, 58)
280+ 222 -> Just (68, 68, 68)
281+ 223 -> Just (78, 78, 78)
282+ 224 -> Just (88, 88, 88)
283+ 225 -> Just (98, 98, 98)
284+ 226 -> Just (108, 108, 108)
285+ 227 -> Just (118, 118, 118)
286+ 228 -> Just (128, 128, 128)
287+ 229 -> Just (138, 138, 138)
288+ 230 -> Just (148, 148, 148)
289+ 231 -> Just (158, 158, 158)
290+ 232 -> Just (168, 168, 168)
291+ 233 -> Just (178, 178, 178)
292+ 234 -> Just (188, 188, 188)
293+ 235 -> Just (198, 198, 198)
294+ 236 -> Just (208, 208, 208)
295+ 237 -> Just (218, 218, 218)
296+ 238 -> Just (228, 228, 228)
297+ 239 -> Just (238, 238, 238)
298+ _ -> Nothing
src/Graphics/Vty/Config.hs+289−110
@@ -3,21 +3,13 @@
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
4{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE LambdaCase, MultiWayIf #-}
7+-- | Vty supports a configuration file format and associated 'Config'
6−-- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can
8+-- data type. The 'Config' can be provided to 'mkVty' to customize the
7−-- be used to customize vty for a user's system.
9+-- application's use of Vty.
8--
10--
9−-- The 'Config' provided is mappend'd to 'Config's loaded from @'getAppUserDataDirectory'/config@
10−-- and @$VTY_CONFIG_FILE@. The @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the
11−-- application provided 'Config'.
12−--
13−-- Lines in config files that fail to parse are ignored. Later entries take precedence over
11+-- Lines in config files that fail to parse are ignored. Later entries
14−-- earlier.
12+-- take precedence over earlier ones.
15−--
16−-- For all directives:
17−--
18−-- @
19−-- string := \"\\\"\" chars+ \"\\\"\"
20−-- @
21--
13--
22-- = Debug
14-- = Debug
23--
15--
@@ -29,8 +21,8 @@
29-- \"debugLog\" string
21-- \"debugLog\" string
30-- @
22-- @
31--
23--
32−-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent to a debugLog entry at the
24+-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent
33−-- end of the last config file.
25+-- to a debugLog entry at the end of the last config file.
34--
26--
35-- = Input Processing
27-- = Input Processing
36--
28--
@@ -47,7 +39,7 @@
47-- term := "_" | string
39-- term := "_" | string
48-- @
40-- @
49--
41--
50−-- EG: If the contents are
42+-- E.g., if the contents are
51--
43--
52-- @
44-- @
53-- map _ \"\\ESC[B\" KUp []
45-- map _ \"\\ESC[B\" KUp []
@@ -55,16 +47,41 @@
55-- map \"xterm\" \"\\ESC[D\" KLeft []
47-- map \"xterm\" \"\\ESC[D\" KLeft []
56-- @
48-- @
57--
49--
58−-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all terminals. The bytes
50+-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all
51+-- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown
59−-- @\"\\ESC[1;3B\"@ will result in the event KDown with the MAlt modifier on all terminals.
52+-- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will
60−-- The bytes @\"\\ESC[D\"@ will result in the KLeft event when @TERM@ is @xterm@.
53+-- result in the KLeft event when @TERM@ is @xterm@.
54+--
55+-- If a debug log is requested then vty will output the current input
56+-- table to the log in the above format. A workflow for using this is
57+-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
58+-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.
59+--
60+-- = Unicode Character Width Maps
61+--
62+-- == @widthMap@
63+--
64+-- Format:
65+--
66+-- @
67+-- \"widthMap\" string string
68+-- @
61--
69--
62−-- If a debug log is requested then vty will output the current input table to the log in the above
70+-- E.g.,
63−-- format.
64--
71--
65−-- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings. Add corrected mappings to
72+-- @
66−-- .vty/config
73+-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"
74+-- @
67--
75--
76+-- This directive specifies the path to a Unicode character width
77+-- map (the second argument) that should be loaded and used when
78+-- the value of TERM matches the first argument. Unicode character
79+-- width maps can be produced either by running the provided binary
80+-- @vty-build-width-table@ or by calling the library routine
81+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The
82+-- 'Graphics.Vty.mkVty' function will use these configuration settings
83+-- to attempt to load and install the specified width map. See the
84+-- documentation for 'Graphics.Vty.mkVty' for details.
68module Graphics.Vty.Config
85module Graphics.Vty.Config
69 ( InputMap
86 ( InputMap
70 , Config(..)
87 , Config(..)
@@ -74,13 +91,22 @@ module Graphics.Vty.Config
74 , standardIOConfig
91 , standardIOConfig
75 , runParseConfig
92 , runParseConfig
76 , parseConfigFile
93 , parseConfigFile
94+ , defaultConfig
95+ , getTtyEraseChar
96+ , currentTerminalName
97+
98+ , vtyConfigPath
99+ , widthTableFilename
100+ , vtyDataDirectory
101+ , terminalWidthTablePath
102+ , vtyConfigFileEnvName
103+
104+ , ConfigUpdateResult(..)
105+ , addConfigWidthMap
106+ )
77− ) where
107+where
78
108
79−#if __GLASGOW_HASKELL__ > 704
80import Prelude
109import Prelude
81−#else
82−import Prelude hiding (catch)
83−#endif
84
110
85import Control.Applicative hiding (many)
111import Control.Applicative hiding (many)
86
112
@@ -88,113 +114,186 @@ import Control.Exception (catch, IOException, Exception(..), throwIO)
88import Control.Monad (liftM, guard, void)
114import Control.Monad (liftM, guard, void)
89
115
90import qualified Data.ByteString as BS
116import qualified Data.ByteString as BS
117+#if !(MIN_VERSION_base(4,8,0))
91−import Data.Default
118+import Data.Monoid (Monoid(..))
119+#endif
120+#if !(MIN_VERSION_base(4,11,0))
92−import Data.Monoid
121+import Data.Semigroup (Semigroup(..))
122+#endif
93import Data.Typeable (Typeable)
123import Data.Typeable (Typeable)
94
124
95import Graphics.Vty.Input.Events
125import Graphics.Vty.Input.Events
126+import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
96
127
97import GHC.Generics
128import GHC.Generics
98
129
99−import System.Directory (getAppUserDataDirectory)
130+import System.Directory ( getAppUserDataDirectory, doesFileExist
131+ , createDirectoryIfMissing
132+ )
100−import System.Posix.Env (getEnv)
133+import System.Environment (lookupEnv)
134+import System.FilePath ((</>), takeDirectory)
101import System.Posix.IO (stdInput, stdOutput)
135import System.Posix.IO (stdInput, stdOutput)
102import System.Posix.Types (Fd(..))
136import System.Posix.Types (Fd(..))
137+import Foreign.C.Types (CInt(..), CChar(..))
103
138
104import Text.Parsec hiding ((<|>))
139import Text.Parsec hiding ((<|>))
105import Text.Parsec.Token ( GenLanguageDef(..) )
140import Text.Parsec.Token ( GenLanguageDef(..) )
106import qualified Text.Parsec.Token as P
141import qualified Text.Parsec.Token as P
107
142
108-- | Type of errors that can be thrown when configuring VTY
143-- | Type of errors that can be thrown when configuring VTY
109−data VtyConfigurationError
144+data VtyConfigurationError =
145+ VtyMissingTermEnvVar
110− = VtyMissingTermEnvVar -- ^ TERM environment variable not set
146+ -- ^ TERM environment variable not set
111− deriving (Show, Eq, Typeable)
147+ deriving (Show, Eq, Typeable)
112
148
113instance Exception VtyConfigurationError where
149instance Exception VtyConfigurationError where
114−#if MIN_VERSION_base(4,8,0)
115− displayException VtyMissingTermEnvVar = "TERM environment variable not set"
150+ displayException VtyMissingTermEnvVar = "TERM environment variable not set"
116−#endif
117
151
118−-- | Mappings from input bytes to event in the order specified. Later entries take precedence over
152+-- | Mappings from input bytes to event in the order specified. Later
119−-- earlier in the case multiple entries have the same byte string.
153+-- entries take precedence over earlier in the case multiple entries
154+-- have the same byte string.
120type InputMap = [(Maybe String, String, Event)]
155type InputMap = [(Maybe String, String, Event)]
121
156
157+-- | A Vty configuration.
122−data Config = Config
158+data Config =
123− {
124− -- | The default is 1 character.
125− vmin :: Maybe Int
159+ Config { vmin :: Maybe Int
160+ -- ^ The default is 1 character.
161+ , vtime :: Maybe Int
126− -- | The default is 100 milliseconds, 0.1 seconds.
162+ -- ^ The default is 100 milliseconds, 0.1 seconds.
127− , vtime :: Maybe Int
163+ , mouseMode :: Maybe Bool
128− -- | The default is False.
164+ -- ^ The default is False.
129− , mouseMode :: Maybe Bool
165+ , bracketedPasteMode :: Maybe Bool
130− -- | The default is False.
166+ -- ^ The default is False.
131− , bracketedPasteMode :: Maybe Bool
167+ , debugLog :: Maybe FilePath
132− -- | Debug information is appended to this file if not Nothing.
168+ -- ^ Debug information is appended to this file if not
133− , debugLog :: Maybe FilePath
169+ -- Nothing.
170+ , inputMap :: InputMap
134− -- | The (input byte, output event) pairs extend the internal input table of VTY and the table
171+ -- ^ The (input byte, output event) pairs extend the internal
135− -- from terminfo.
172+ -- input table of VTY and the table from terminfo.
136− --
173+ --
137− -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive.
174+ -- See "Graphics.Vty.Config" module documentation for
138− , inputMap :: InputMap
175+ -- documentation of the @map@ directive.
176+ , inputFd :: Maybe Fd
139− -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput'
177+ -- ^ The input file descriptor to use. The default is
178+ -- 'System.Posix.IO.stdInput'
140− , inputFd :: Maybe Fd
179+ , outputFd :: Maybe Fd
141− -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput'
180+ -- ^ The output file descriptor to use. The default is
142− , outputFd :: Maybe Fd
181+ -- 'System.Posix.IO.stdOutput'
182+ , termName :: Maybe String
143− -- | The terminal name used to look up terminfo capabilities.
183+ -- ^ The terminal name used to look up terminfo capabilities.
144− -- The default is the value of the TERM environment variable.
184+ -- The default is the value of the TERM environment variable.
145− , termName :: Maybe String
185+ , termWidthMaps :: [(String, FilePath)]
186+ -- ^ Terminal width map files.
187+ , allowCustomUnicodeWidthTables :: Maybe Bool
188+ -- ^ Whether to permit custom Unicode width table loading by
189+ -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that
190+ -- table loading should not be performed. Other values permit
191+ -- table loading.
192+ --
193+ -- If a table load is attempted and fails, information
194+ -- about the failure will be logged to the debug log if the
195+ -- configuration specifies one. If no custom table is loaded
196+ -- (or if a load fails), the built-in character width table
197+ -- will be used.
198+ , colorMode :: Maybe ColorMode
199+ -- ^ The color mode used to know how many colors the terminal
200+ -- supports.
201+ }
146− } deriving (Show, Eq)
202+ deriving (Show, Eq)
147−
203+
204+defaultConfig :: Config
205+defaultConfig = mempty
206+
148−instance Default Config where
207+instance Semigroup Config where
149− def = mempty
208+ c0 <> c1 =
209+ -- latter config takes priority for everything but inputMap
210+ Config { vmin = vmin c1 <|> vmin c0
211+ , vtime = vtime c1 <|> vtime c0
212+ , mouseMode = mouseMode c1
213+ , bracketedPasteMode = bracketedPasteMode c1
214+ , debugLog = debugLog c1 <|> debugLog c0
215+ , inputMap = inputMap c0 <> inputMap c1
216+ , inputFd = inputFd c1 <|> inputFd c0
217+ , outputFd = outputFd c1 <|> outputFd c0
218+ , termName = termName c1 <|> termName c0
219+ , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0
220+ , allowCustomUnicodeWidthTables =
221+ allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0
222+ , colorMode = colorMode c1 <|> colorMode c0
223+ }
150
224
151instance Monoid Config where
225instance Monoid Config where
152− mempty = Config
226+ mempty =
153− { vmin = Nothing
227+ Config { vmin = Nothing
154− , vtime = Nothing
228+ , vtime = Nothing
155− , mouseMode = Nothing
229+ , mouseMode = Nothing
156− , bracketedPasteMode = Nothing
230+ , bracketedPasteMode = Nothing
157− , debugLog = mempty
231+ , debugLog = mempty
158− , inputMap = mempty
232+ , inputMap = mempty
159− , inputFd = Nothing
233+ , inputFd = Nothing
160− , outputFd = Nothing
234+ , outputFd = Nothing
161− , termName = Nothing
235+ , termName = Nothing
236+ , termWidthMaps = []
237+ , allowCustomUnicodeWidthTables = Nothing
238+ , colorMode = Nothing
162− }
239+ }
240+#if !(MIN_VERSION_base(4,11,0))
163− mappend c0 c1 = Config
241+ mappend = (<>)
164− -- latter config takes priority for everything but inputMap
242+#endif
165− { vmin = vmin c1 <|> vmin c0
243+
166− , vtime = vtime c1 <|> vtime c0
244+vtyDataDirectory :: IO FilePath
167− , mouseMode = mouseMode c1
245+vtyDataDirectory = getAppUserDataDirectory "vty"
168− , bracketedPasteMode = bracketedPasteMode c1
246+
169− , debugLog = debugLog c1 <|> debugLog c0
247+vtyConfigPath :: IO FilePath
170− , inputMap = inputMap c0 <> inputMap c1
248+vtyConfigPath = do
171− , inputFd = inputFd c1 <|> inputFd c0
249+ dir <- vtyDataDirectory
172− , outputFd = outputFd c1 <|> outputFd c0
250+ return $ dir </> "config"
173− , termName = termName c1 <|> termName c0
251+
174− }
252+vtyConfigFileEnvName :: String
175−
253+vtyConfigFileEnvName = "VTY_CONFIG_FILE"
254+
176−-- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@
255+-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
177userConfig :: IO Config
256userConfig :: IO Config
178userConfig = do
257userConfig = do
179− configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
258+ configFile <- vtyConfigPath >>= parseConfigFile
180− overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
259+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
260+ lookupEnv vtyConfigFileEnvName
181 let base = configFile <> overrideConfig
261 let base = configFile <> overrideConfig
182 mappend base <$> overrideEnvConfig
262 mappend base <$> overrideEnvConfig
183
263
264+widthTableFilename :: String -> String
265+widthTableFilename term = "width_table_" <> term <> ".dat"
266+
267+termVariable :: String
268+termVariable = "TERM"
269+
270+currentTerminalName :: IO (Maybe String)
271+currentTerminalName = lookupEnv termVariable
272+
273+terminalWidthTablePath :: IO (Maybe FilePath)
274+terminalWidthTablePath = do
275+ dataDir <- vtyDataDirectory
276+ result <- lookupEnv termVariable
277+ case result of
278+ Nothing -> return Nothing
279+ Just term -> do
280+ return $ Just $ dataDir </> widthTableFilename term
281+
184overrideEnvConfig :: IO Config
282overrideEnvConfig :: IO Config
185overrideEnvConfig = do
283overrideEnvConfig = do
186− d <- getEnv "VTY_DEBUG_LOG"
284+ d <- lookupEnv "VTY_DEBUG_LOG"
187− return $ def { debugLog = d }
285+ return $ defaultConfig { debugLog = d }
188
286
189−-- | Configures VTY using defaults suitable for terminals. This action
287+-- | Configures VTY using defaults suitable for terminals. This function
190-- can raise 'VtyConfigurationError'.
288-- can raise 'VtyConfigurationError'.
191standardIOConfig :: IO Config
289standardIOConfig :: IO Config
192standardIOConfig = do
290standardIOConfig = do
193− mb <- getEnv "TERM"
291+ mb <- lookupEnv termVariable
194 case mb of
292 case mb of
195 Nothing -> throwIO VtyMissingTermEnvVar
293 Nothing -> throwIO VtyMissingTermEnvVar
196− Just t ->
294+ Just t -> do
295+ mcolorMode <- detectColorMode t
197− return def
296+ return defaultConfig
198 { vmin = Just 1
297 { vmin = Just 1
199 , mouseMode = Just False
298 , mouseMode = Just False
200 , bracketedPasteMode = Just False
299 , bracketedPasteMode = Just False
@@ -202,25 +301,24 @@ standardIOConfig = do
202 , inputFd = Just stdInput
301 , inputFd = Just stdInput
203 , outputFd = Just stdOutput
302 , outputFd = Just stdOutput
204 , termName = Just t
303 , termName = Just t
304+ , colorMode = Just mcolorMode
205 }
305 }
206
306
207parseConfigFile :: FilePath -> IO Config
307parseConfigFile :: FilePath -> IO Config
208parseConfigFile path = do
308parseConfigFile path = do
209 catch (runParseConfig path <$> BS.readFile path)
309 catch (runParseConfig path <$> BS.readFile path)
210− (\(_ :: IOException) -> return def)
310+ (\(_ :: IOException) -> return defaultConfig)
211
311
212runParseConfig :: String -> BS.ByteString -> Config
312runParseConfig :: String -> BS.ByteString -> Config
213runParseConfig name cfgTxt =
313runParseConfig name cfgTxt =
214 case runParser parseConfig () name cfgTxt of
314 case runParser parseConfig () name cfgTxt of
215 Right cfg -> cfg
315 Right cfg -> cfg
216− Left{} -> def
316+ Left{} -> defaultConfig
217
317
218------------------------------------------------------------------------
318------------------------------------------------------------------------
219
319
220type Parser = Parsec BS.ByteString ()
320type Parser = Parsec BS.ByteString ()
221
321
222−-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the
223−-- String stream type.
224configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
322configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
225configLanguage = LanguageDef
323configLanguage = LanguageDef
226 { commentStart = "{-"
324 { commentStart = "{-"
@@ -247,13 +345,20 @@ mapDecl = do
247 bytes <- P.stringLiteral configLexer
345 bytes <- P.stringLiteral configLexer
248 key <- parseValue
346 key <- parseValue
249 modifiers <- parseValue
347 modifiers <- parseValue
250− return def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
348+ return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
251
349
252debugLogDecl :: Parser Config
350debugLogDecl :: Parser Config
253debugLogDecl = do
351debugLogDecl = do
254 "debugLog" <- P.identifier configLexer
352 "debugLog" <- P.identifier configLexer
255 path <- P.stringLiteral configLexer
353 path <- P.stringLiteral configLexer
256− return def { debugLog = Just path }
354+ return defaultConfig { debugLog = Just path }
355+
356+widthMapDecl :: Parser Config
357+widthMapDecl = do
358+ "widthMap" <- P.identifier configLexer
359+ tName <- P.stringLiteral configLexer
360+ path <- P.stringLiteral configLexer
361+ return defaultConfig { termWidthMaps = [(tName, path)] }
257
362
258ignoreLine :: Parser ()
363ignoreLine :: Parser ()
259ignoreLine = void $ manyTill anyChar newline
364ignoreLine = void $ manyTill anyChar newline
@@ -261,8 +366,8 @@ ignoreLine = void $ manyTill anyChar newline
261parseConfig :: Parser Config
366parseConfig :: Parser Config
262parseConfig = liftM mconcat $ many $ do
367parseConfig = liftM mconcat $ many $ do
263 P.whiteSpace configLexer
368 P.whiteSpace configLexer
264− let directives = [try mapDecl, try debugLogDecl]
369+ let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]
265− choice directives <|> (ignoreLine >> return def)
370+ choice directives <|> (ignoreLine >> return defaultConfig)
266
371
267class Parse a where parseValue :: Parser a
372class Parse a where parseValue :: Parser a
268instance Parse Char where parseValue = P.charLiteral configLexer
373instance Parse Char where parseValue = P.charLiteral configLexer
@@ -307,3 +412,77 @@ instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
307 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
412 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
308
413
309instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"
414instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"
415+
416+foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar
417+
418+-- | Get the "erase" character for the terminal attached to the
419+-- specified file descriptor. This is the character configured by 'stty
420+-- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'.
421+-- Otherwise it will return the character that has been configured to
422+-- indicate the canonical mode ERASE behavior. That character can then
423+-- be added to the table of strings that we interpret to mean Backspace.
424+--
425+-- For more details, see:
426+--
427+-- * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html
428+-- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty
429+-- * https://github.com/matterhorn-chat/matterhorn/issues/565
430+getTtyEraseChar :: Fd -> IO (Maybe Char)
431+getTtyEraseChar fd = do
432+ c <- cGetTtyErase fd
433+ if c /= 0
434+ then return $ Just $ toEnum $ fromEnum c
435+ else return Nothing
436+
437+data ConfigUpdateResult =
438+ ConfigurationCreated
439+ | ConfigurationModified
440+ | ConfigurationConflict String
441+ | ConfigurationRedundant
442+ deriving (Eq, Show)
443+
444+-- | Add a @widthMap@ directive to the Vty configuration file at the
445+-- specified path.
446+--
447+-- If the configuration path refers to a configuration that already
448+-- contains the directive for the specified map and terminal type, the
449+-- configuration file will not be modified. If the file does not contain
450+-- the directive, it will be appended to the file.
451+--
452+-- If the configuration path does not exist, a new configuration file
453+-- will be created and any directories in the path will also be created.
454+--
455+-- This returns @True@ if the configuration was created or modified and
456+-- @False@ otherwise. This does not handle exceptions raised by file or
457+-- directory permissions issues.
458+addConfigWidthMap :: FilePath
459+ -- ^ The configuration file path of the configuration
460+ -- to modify or create.
461+ -> String
462+ -- ^ The @TERM@ value for the @widthMap@ directive.
463+ -> FilePath
464+ -- ^ The width table file path for the directive.
465+ -> IO ConfigUpdateResult
466+addConfigWidthMap configPath term tablePath = do
467+ configEx <- doesFileExist configPath
468+ if configEx
469+ then updateConfig
470+ else createConfig >> return ConfigurationCreated
471+
472+ where
473+ directive = "widthMap " <> show term <> " " <> show tablePath <> "\n"
474+
475+ createConfig = do
476+ let dir = takeDirectory configPath
477+ createDirectoryIfMissing True dir
478+ writeFile configPath directive
479+
480+ updateConfig = do
481+ config <- parseConfigFile configPath
482+ if (term, tablePath) `elem` termWidthMaps config
483+ then return ConfigurationRedundant
484+ else case lookup term (termWidthMaps config) of
485+ Just other -> return $ ConfigurationConflict other
486+ Nothing -> do
487+ appendFile configPath directive
488+ return ConfigurationModified
src/Graphics/Vty/Debug.hs+11−11
@@ -1,27 +1,27 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2−module Graphics.Vty.Debug ( module Graphics.Vty.Debug
2+module Graphics.Vty.Debug
3+ ( module Graphics.Vty.Debug
3− , module Graphics.Vty.Debug.Image
4+ , module Graphics.Vty.Debug.Image
4− )
5+ )
5where
6where
6
7
7−import Graphics.Vty.Prelude
8−
9import Graphics.Vty.Attributes
8import Graphics.Vty.Attributes
9+import Graphics.Vty.Image (DisplayRegion)
10import Graphics.Vty.Debug.Image
10import Graphics.Vty.Debug.Image
11import Graphics.Vty.Span
11import Graphics.Vty.Span
12
12
13import qualified Data.Vector as Vector
13import qualified Data.Vector as Vector
14
14
15−rowOpsEffectedColumns :: DisplayOps -> [Int]
15+rowOpsAffectedColumns :: DisplayOps -> [Int]
16−rowOpsEffectedColumns ops
16+rowOpsAffectedColumns ops
17− = Vector.toList $ Vector.map spanOpsEffectedColumns ops
17+ = Vector.toList $ Vector.map spanOpsAffectedColumns ops
18
18
19allSpansHaveWidth :: DisplayOps -> Int -> Bool
19allSpansHaveWidth :: DisplayOps -> Int -> Bool
20allSpansHaveWidth ops expected
20allSpansHaveWidth ops expected
21− = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops
21+ = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops
22
22
23−spanOpsEffectedRows :: DisplayOps -> Int
23+spanOpsAffectedRows :: DisplayOps -> Int
24−spanOpsEffectedRows ops
24+spanOpsAffectedRows ops
25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
26
26
27type SpanConstructLog = [SpanConstructEvent]
27type SpanConstructLog = [SpanConstructEvent]
src/Graphics/Vty/DisplayAttributes.hs+63−32
@@ -1,31 +1,30 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2−{-# LANGUAGE CPP #-}
3{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE CPP #-}
4
4
5−#ifndef MIN_VERSION_base
6−#defined MIN_VERSION_base(x,y,z) 1
7−#endif
8−
9−module Graphics.Vty.DisplayAttributes
5+module Graphics.Vty.DisplayAttributes where
10− where
11
6
12import Graphics.Vty.Attributes
7import Graphics.Vty.Attributes
13
8
14import Data.Bits ((.&.))
9import Data.Bits ((.&.))
15−
10+import Data.ByteString (ByteString)
16−#if !(MIN_VERSION_base(4,8,0))
11+#if !(MIN_VERSION_base(4,11,0))
17−import Data.Monoid (Monoid(..), mconcat)
12+import Data.Semigroup (Semigroup(..))
18#endif
13#endif
14+import Data.Text (Text)
15+import Data.Text.Encoding (encodeUtf8)
19
16
20−-- | Given the previously applied display attributes as a FixedAttr and the current display
17+-- | Given the previously applied display attributes as a FixedAttr and
18+-- the current display attributes as an Attr produces a FixedAttr that
21−-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This
19+-- represents the current display attributes. This is done by using the
22−-- is done by using the previously applied display attributes to remove the "KeepCurrent"
20+-- previously applied display attributes to remove the "KeepCurrent"
23-- abstraction.
21-- abstraction.
24fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr
22fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr
25fixDisplayAttr fattr attr
23fixDisplayAttr fattr attr
26 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
24 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
27 (fixColor (fixedForeColor fattr) (attrForeColor attr))
25 (fixColor (fixedForeColor fattr) (attrForeColor attr))
28 (fixColor (fixedBackColor fattr) (attrBackColor attr))
26 (fixColor (fixedBackColor fattr) (attrBackColor attr))
27+ (fixURL (fixedURL fattr) (attrURL attr))
29 where
28 where
30 fixStyle _s Default = defaultStyleMask
29 fixStyle _s Default = defaultStyleMask
31 fixStyle s KeepCurrent = s
30 fixStyle s KeepCurrent = s
@@ -33,43 +32,56 @@ fixDisplayAttr fattr attr
33 fixColor _c Default = Nothing
32 fixColor _c Default = Nothing
34 fixColor c KeepCurrent = c
33 fixColor c KeepCurrent = c
35 fixColor _c (SetTo c) = Just c
34 fixColor _c (SetTo c) = Just c
35+ fixURL c KeepCurrent = c
36+ fixURL _c (SetTo n) = Just n
37+ fixURL _c Default = Nothing
36
38
37−-- | difference between two display attributes. Used in the calculation of the operations required
39+-- | difference between two display attributes. Used in the calculation
38−-- to go from one display attribute to the next.
40+-- of the operations required to go from one display attribute to the
41+-- next.
39--
42--
40−-- Previously, vty would reset display attributes to default then apply the new display attributes.
43+-- Previously, vty would reset display attributes to default then apply
44+-- the new display attributes. This turned out to be very expensive: A
41−-- This turned out to be very expensive: A *lot* more data would be sent to the terminal than
45+-- *lot* more data would be sent to the terminal than required.
42−-- required.
43data DisplayAttrDiff = DisplayAttrDiff
46data DisplayAttrDiff = DisplayAttrDiff
44 { styleDiffs :: [StyleStateChange]
47 { styleDiffs :: [StyleStateChange]
45 , foreColorDiff :: DisplayColorDiff
48 , foreColorDiff :: DisplayColorDiff
46 , backColorDiff :: DisplayColorDiff
49 , backColorDiff :: DisplayColorDiff
50+ , urlDiff :: URLDiff
47 }
51 }
48 deriving (Show)
52 deriving (Show)
49
53
50−instance Monoid DisplayAttrDiff where
54+instance Semigroup DisplayAttrDiff where
51− mempty = DisplayAttrDiff [] NoColorChange NoColorChange
52− mappend d0 d1 =
55+ d0 <> d1 =
53 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
56 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
54 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
57 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
55 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
58 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
59+ ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
56− in DisplayAttrDiff ds fcd bcd
60+ in DisplayAttrDiff ds fcd bcd ud
61+
62+instance Monoid DisplayAttrDiff where
63+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
64+#if !(MIN_VERSION_base(4,11,0))
65+ mappend = (<>)
66+#endif
57
67
58-- | Used in the computation of a final style attribute change.
68-- | Used in the computation of a final style attribute change.
59−--
60−-- TODO(corey): not really a simplify but a monoid instance.
61simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
62simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
70simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
63
71
64−-- | Consider two display color attributes diffs. What display color attribute diff are these
72+-- | Consider two display color attributes diffs. What display color
65−-- equivalent to?
73+-- attribute diff are these equivalent to?
66−--
67−-- TODO(corey): not really a simplify but a monoid instance.
68simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
74simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
69simplifyColorDiffs _cd ColorToDefault = ColorToDefault
75simplifyColorDiffs _cd ColorToDefault = ColorToDefault
70simplifyColorDiffs cd NoColorChange = cd
76simplifyColorDiffs cd NoColorChange = cd
71simplifyColorDiffs _cd (SetColor !c) = SetColor c
77simplifyColorDiffs _cd (SetColor !c) = SetColor c
72
78
79+-- | Consider two URL changes, which are mostly going to be the latter
80+-- unless the latter specifies no change.
81+simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
82+simplifyUrlDiffs ud NoLinkChange = ud
83+simplifyUrlDiffs _ ud = ud
84+
73-- | Difference between two display color attribute changes.
85-- | Difference between two display color attribute changes.
74data DisplayColorDiff
86data DisplayColorDiff
75 = ColorToDefault
87 = ColorToDefault
@@ -77,11 +89,15 @@ data DisplayColorDiff
77 | SetColor !Color
89 | SetColor !Color
78 deriving (Show, Eq)
90 deriving (Show, Eq)
79
91
80−-- | Style attribute changes are transformed into a sequence of apply/removes of the individual
92+-- | Style attribute changes are transformed into a sequence of
81−-- attributes.
93+-- apply/removes of the individual attributes.
82data StyleStateChange
94data StyleStateChange
83 = ApplyStandout
95 = ApplyStandout
84 | RemoveStandout
96 | RemoveStandout
97+ | ApplyItalic
98+ | RemoveItalic
99+ | ApplyStrikethrough
100+ | RemoveStrikethrough
85 | ApplyUnderline
101 | ApplyUnderline
86 | RemoveUnderline
102 | RemoveUnderline
87 | ApplyReverseVideo
103 | ApplyReverseVideo
@@ -94,15 +110,28 @@ data StyleStateChange
94 | RemoveBold
110 | RemoveBold
95 deriving (Show, Eq)
111 deriving (Show, Eq)
96
112
113+-- Setting and unsetting hyperlinks
114+data URLDiff
115+ = LinkTo !ByteString
116+ | NoLinkChange
117+ | EndLink
118+ deriving (Show, Eq)
119+
97−-- | Determines the diff between two display&color attributes. This diff determines the operations
120+-- | Determines the diff between two display&color attributes. This diff
98−-- that actually get output to the terminal.
121+-- determines the operations that actually get output to the terminal.
99displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
100displayAttrDiffs attr attr' = DisplayAttrDiff
123displayAttrDiffs attr attr' = DisplayAttrDiff
101 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
124 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
102 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
125 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
103 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
126 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
127+ , urlDiff = diffURL (fixedURL attr) (fixedURL attr')
104 }
128 }
105
129
130+diffURL :: Maybe Text -> Maybe Text -> URLDiff
131+diffURL Nothing Nothing = NoLinkChange
132+diffURL (Just _) Nothing = EndLink
133+diffURL _ (Just url) = LinkTo (encodeUtf8 url)
134+
106diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
135diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
107diffColor Nothing (Just c') = SetColor c'
136diffColor Nothing (Just c') = SetColor c'
108diffColor (Just c) (Just c')
137diffColor (Just c) (Just c')
@@ -116,6 +145,8 @@ diffStyles prev cur
116 = mconcat
145 = mconcat
117 [ styleDiff standout ApplyStandout RemoveStandout
146 [ styleDiff standout ApplyStandout RemoveStandout
118 , styleDiff underline ApplyUnderline RemoveUnderline
147 , styleDiff underline ApplyUnderline RemoveUnderline
148+ , styleDiff italic ApplyItalic RemoveItalic
149+ , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
119 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
120 , styleDiff blink ApplyBlink RemoveBlink
151 , styleDiff blink ApplyBlink RemoveBlink
121 , styleDiff dim ApplyDim RemoveDim
152 , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Error.hs+3−3
@@ -1,8 +1,8 @@
1−module Graphics.Vty.Error
1+module Graphics.Vty.Error where
2− where
3
2
4-- | The type of exceptions specific to vty.
3-- | The type of exceptions specific to vty.
5--
4--
6−-- These have fully qualified names by default since, IMO, exception handling requires this.
5+-- These have fully qualified names by default since, IMO, exception
6+-- handling requires this.
7data VtyException
7data VtyException
8 = VtyFailure String -- ^ Uncategorized failure specific to vty.
8 = VtyFailure String -- ^ Uncategorized failure specific to vty.
src/Graphics/Vty/Image.hs+195−115
@@ -1,48 +1,63 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2−{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE DisambiguateRecordFields #-}
3{-# LANGUAGE DisambiguateRecordFields #-}
4+-- | A Vty program makes 'Picture's from 'Image's. This module provides
5+-- the core constructors for creating, combining, and modifying
6+-- 'Image's.
5−module Graphics.Vty.Image ( DisplayText
7+module Graphics.Vty.Image
8+ (
9+ -- * Images
6− , Image
10+ Image
7− , imageWidth
11+ , imageWidth
8− , imageHeight
12+ , imageHeight
13+ -- * Image constructors
14+ , emptyImage
15+ , char
16+ , string
17+ , iso10646String
18+ , utf8String
19+ , text
20+ , text'
21+ , backgroundFill
22+ , utf8Bytestring
23+ , utf8Bytestring'
24+ , charFill
25+ -- * Combinators
9− , horizJoin
26+ , horizJoin
10− , (<|>)
27+ , (<|>)
11− , vertJoin
28+ , vertJoin
12− , (<->)
29+ , (<->)
13− , horizCat
30+ , horizCat
14− , vertCat
31+ , vertCat
15− , backgroundFill
32+ -- * Image modifications
16− , text
17− , text'
18− , char
19− , string
20− , iso10646String
21− , utf8String
22− , utf8Bytestring
23− , utf8Bytestring'
24− , charFill
25− , emptyImage
26− , safeWcwidth
27− , safeWcswidth
28− , wcwidth
29− , wcswidth
30− , crop
33+ , crop
31− , cropRight
34+ , cropRight
32− , cropLeft
35+ , cropLeft
33− , cropBottom
36+ , cropBottom
34− , cropTop
37+ , cropTop
35− , pad
38+ , pad
36− , resize
39+ , resize
37− , resizeWidth
40+ , resizeWidth
38− , resizeHeight
41+ , resizeHeight
39− , translate
42+ , translate
40− , translateX
43+ , translateX
41− , translateY
44+ , translateY
42− -- | The possible display attributes used in constructing an `Image`.
45+ -- * Character width functions
43− , module Graphics.Vty.Attributes
46+ , safeWcwidth
47+ , safeWcswidth
48+ , safeWctwidth
49+ , safeWctlwidth
50+ , wcwidth
51+ , wcswidth
52+ , wctwidth
53+ , wctlwidth
54+ -- * Display Regions
55+ , DisplayText
56+ , DisplayRegion
57+ , regionWidth
58+ , regionHeight
44− )
59+ )
45− where
60+where
46
61
47import Graphics.Vty.Attributes
62import Graphics.Vty.Attributes
48import Graphics.Vty.Image.Internal
63import Graphics.Vty.Image.Internal
@@ -56,115 +71,163 @@ import qualified Data.Text.Lazy as TL
56import qualified Data.Text.Lazy.Encoding as TL
71import qualified Data.Text.Lazy.Encoding as TL
57import Data.Word
72import Data.Word
58
73
74+-- | A region of the display (first width, then height)
75+type DisplayRegion = (Int,Int)
76+
77+regionWidth :: DisplayRegion -> Int
78+regionWidth = fst
79+
80+regionHeight :: DisplayRegion -> Int
81+regionHeight = snd
82+
59infixr 5 <|>
83infixr 5 <|>
60infixr 4 <->
84infixr 4 <->
61
85
62−-- | An area of the picture's bacground (See Background) of w columns and h rows.
86+-- | An area of the picture's background (See 'Background').
63−backgroundFill :: Int -> Int -> Image
87+backgroundFill :: Int
88+ -- ^ Fill width in columns
89+ -> Int
90+ -- ^ Fill height in rows
91+ -> Image
64backgroundFill w h
92backgroundFill w h
65 | w == 0 = EmptyImage
93 | w == 0 = EmptyImage
66 | h == 0 = EmptyImage
94 | h == 0 = EmptyImage
67 | otherwise = BGFill w h
95 | otherwise = BGFill w h
68
96
69−-- | Combines two images horizontally. Alias for horizJoin
97+-- | Combines two images horizontally. This is an alias for 'horizJoin'.
70--
98--
71-- infixr 5
99-- infixr 5
72(<|>) :: Image -> Image -> Image
100(<|>) :: Image -> Image -> Image
73(<|>) = horizJoin
101(<|>) = horizJoin
74
102
75−-- | Combines two images vertically. Alias for vertJoin
103+-- | Combines two images vertically. This is an alias for 'vertJoin'.
76--
104--
77-- infixr 4
105-- infixr 4
78(<->) :: Image -> Image -> Image
106(<->) :: Image -> Image -> Image
79(<->) = vertJoin
107(<->) = vertJoin
80
108
81−-- | Compose any number of images horizontally.
109+-- | Compose any number of images together horizontally, with the first
110+-- in the list being leftmost.
82horizCat :: [Image] -> Image
111horizCat :: [Image] -> Image
83horizCat = foldr horizJoin EmptyImage
112horizCat = foldr horizJoin EmptyImage
84
113
85−-- | Compose any number of images vertically.
114+-- | Compose any number of images vertically, with the first in the list
115+-- being topmost.
86vertCat :: [Image] -> Image
116vertCat :: [Image] -> Image
87vertCat = foldr vertJoin EmptyImage
117vertCat = foldr vertJoin EmptyImage
88
118
89−-- | A Data.Text.Lazy value
119+-- | Make an 'Image' from a lazy text value. The text value should be
120+-- sanitized of escape sequences (ASCII 27) and carriage returns;
121+-- otherwise layout and attribute problems may result.
90text :: Attr -> TL.Text -> Image
122text :: Attr -> TL.Text -> Image
91−text a txt = let displayWidth = safeWcswidth (TL.unpack txt)
123+text a txt = let displayWidth = safeWctlwidth txt
92 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
93
125
94−-- | A Data.Text value
126+-- | Make an 'Image' from a text value. The text value should be
127+-- sanitized of escape sequences (ASCII 27) and carriage returns;
128+-- otherwise layout and attribute problems may result.
95text' :: Attr -> T.Text -> Image
129text' :: Attr -> T.Text -> Image
96−text' a txt = let displayWidth = safeWcswidth (T.unpack txt)
130+text' a txt = let displayWidth = safeWctwidth txt
97 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
98
132
99−-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in
133+-- | Make an image from a single character. This is a standard Haskell
100−-- the ISO-10646 encoding.
134+-- 31-bit character assumed to be in the ISO-10646 encoding.
101char :: Attr -> Char -> Image
135char :: Attr -> Char -> Image
102char a c =
136char a c =
103 let displayWidth = safeWcwidth c
137 let displayWidth = safeWcwidth c
104 in HorizText a (TL.singleton c) displayWidth 1
138 in HorizText a (TL.singleton c) displayWidth 1
105
139
140+-- | Make an image from a string of characters laid out on a single
106−-- | A string of characters layed out on a single row with the same display attribute. The string is
141+-- row with the same display attribute. The string is assumed to be a
107−-- assumed to be a sequence of ISO-10646 characters.
142+-- sequence of ISO-10646 characters. The input string should be
108−--
143+-- sanitized of escape sequences (ASCII 27) and carriage returns;
109−-- Note: depending on how the Haskell compiler represents string literals a string literal in a
144+-- otherwise layout and attribute problems may result.
110−-- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string.
111−-- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry
112−-- about the encoding format when outputting string literals. Just provide the string literal
113−-- directly to iso10646String or string.
114--
145--
146+-- Note: depending on how the Haskell compiler represents string
147+-- literals, a string literal in a UTF-8 encoded source file, for
148+-- example, may be represented as a ISO-10646 string. That is, I think,
149+-- the case with GHC 6.10. This means, for the most part, you don't need
150+-- to worry about the encoding format when outputting string literals.
151+-- Just provide the string literal directly to iso10646String or string.
115iso10646String :: Attr -> String -> Image
152iso10646String :: Attr -> String -> Image
116iso10646String a str =
153iso10646String a str =
117 let displayWidth = safeWcswidth str
154 let displayWidth = safeWcswidth str
118 in HorizText a (TL.pack str) displayWidth (length str)
155 in HorizText a (TL.pack str) displayWidth (length str)
119
156
120−-- | Alias for iso10646String. Since the usual case is that a literal string like "foo" is
157+-- | Make an 'Image' from a 'String'.
121−-- represented internally as a list of ISO 10646 31 bit characters.
122--
158--
159+-- This is an alias for iso10646String since the usual case is that a
160+-- literal string like "foo" is represented internally as a list of ISO
161+-- 10646 31 bit characters.
162+--
123−-- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while
163+-- Note: Keep in mind that GHC will compile source encoded as UTF-8
164+-- but the literal strings, while UTF-8 encoded in the source, will be
124−-- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime
165+-- transcoded to a ISO 10646 31 bit characters runtime representation.
125−-- representation.
126string :: Attr -> String -> Image
166string :: Attr -> String -> Image
127string = iso10646String
167string = iso10646String
128
168
129−-- | A string of characters layed out on a single row. The input is assumed to be the bytes for
169+-- | Make an 'Image' from a string of characters layed out on a single
130−-- UTF-8 encoded text.
170+-- row. The input is assumed to be the bytes for UTF-8 encoded text.
131utf8String :: Attr -> [Word8] -> Image
171utf8String :: Attr -> [Word8] -> Image
132utf8String a bytes = utf8Bytestring a (BL.pack bytes)
172utf8String a bytes = utf8Bytestring a (BL.pack bytes)
133
173
134−-- | Renders a UTF-8 encoded lazy bytestring.
174+-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
135utf8Bytestring :: Attr -> BL.ByteString -> Image
175utf8Bytestring :: Attr -> BL.ByteString -> Image
136utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
137
177
138−-- | Renders a UTF-8 encoded strict bytestring.
178+-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
139utf8Bytestring' :: Attr -> B.ByteString -> Image
179utf8Bytestring' :: Attr -> B.ByteString -> Image
140utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
141
181
142−-- | creates a fill of the specified character. The dimensions are in number of characters wide and
182+-- | Make an image filling a region with the specified character.
143−-- number of rows high.
183+--
184+-- If either the width or height are less than or equal to 0, then
185+-- the result is the empty image.
144−charFill :: Integral d => Attr -> Char -> d -> d -> Image
186+charFill :: Integral d
187+ => Attr
188+ -- ^ The attribute to use.
189+ -> Char
190+ -- ^ The character to use in filling the region.
191+ -> d
192+ -- ^ The region width.
193+ -> d
194+ -- ^ The region height.
195+ -> Image
145−charFill _a _c 0 _h = EmptyImage
196+charFill a c w h
146−charFill _a _c _w 0 = EmptyImage
197+ | w <= 0 || h <= 0 = EmptyImage
147−charFill a c w h =
198+ | otherwise = vertCat
199+ $ replicate (fromIntegral h)
148− vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth
200+ $ HorizText a txt displayWidth charWidth
149− where
201+ where
150− txt = TL.replicate (fromIntegral w) (TL.singleton c)
202+ txt = TL.replicate charWidth (TL.singleton c)
151− displayWidth = safeWcwidth c * (fromIntegral w)
203+ displayWidth = safeWcwidth c * charWidth
204+
205+ charWidth :: Num a => a
152− charWidth = fromIntegral w
206+ charWidth = fromIntegral w
153−
207+
154−-- | The empty image. Useful for fold combinators. These occupy no space nor define any display
208+-- | The empty image. Useful for fold combinators. These occupy no space
155−-- attributes.
209+-- and do not affect display attributes.
156emptyImage :: Image
210emptyImage :: Image
157emptyImage = EmptyImage
211emptyImage = EmptyImage
158
212
159−-- | pad the given image. This adds background character fills to the left, top, right, bottom.
213+-- | Pad the given image. This adds background character fills to the
160−-- The pad values are how many display columns or rows to add.
214+-- left, top, right, bottom.
161−pad :: Int -> Int -> Int -> Int -> Image -> Image
215+pad :: Int
216+ -- ^ How much padding to add to the left side of the image.
217+ -> Int
218+ -- ^ How much padding to add to the top of the image.
219+ -> Int
220+ -- ^ How much padding to add to the right side of the image.
221+ -> Int
222+ -- ^ How much padding to add to the bottom of the image.
223+ -> Image
224+ -- ^ The image to pad.
225+ -> Image
162pad 0 0 0 0 i = i
226pad 0 0 0 0 i = i
163pad inL inT inR inB inImage
227pad inL inT inR inB inImage
164 | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
228 | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
165 | otherwise = go inL inT inR inB inImage
229 | otherwise = go inL inT inR inB inImage
166 where
230 where
167− -- TODO: uh.
168 go 0 0 0 0 i = i
231 go 0 0 0 0 i = i
169 go 0 0 0 b i = VertJoin i (BGFill w b) w h
232 go 0 0 0 b i = VertJoin i (BGFill w b) w h
170 where w = imageWidth i
233 where w = imageWidth i
@@ -179,40 +242,53 @@ pad inL inT inR inB inImage
179 where w = imageWidth i + l
242 where w = imageWidth i + l
180 h = imageHeight i
243 h = imageHeight i
181
244
182−-- | translates an image by padding or cropping the left and top. First param is amount to translate
245+-- | Translates an image by padding or cropping the left and top.
183−-- left. Second param is amount to translate top.
184--
246--
185−-- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than
247+-- If translation offsets are negative then the image is cropped.
186−-- (0,0) will crop the image.
187−translate :: Int -> Int -> Image -> Image
248+translate :: Int
249+ -- ^ The horizontal translation offset (can be negative)
250+ -> Int
251+ -- ^ The vertical translation offset (can be negative)
252+ -> Image
253+ -- ^ The image to translate.
254+ -> Image
188translate x y i = translateX x (translateY y i)
255translate x y i = translateX x (translateY y i)
189
256
190−-- | translates an image by padding or cropping the left
257+-- | Translates an image by padding or cropping its left side.
191translateX :: Int -> Image -> Image
258translateX :: Int -> Image -> Image
192translateX x i
259translateX x i
260+ | x < 0 && (abs x > imageWidth i) = emptyImage
193 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)
261 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)
194 | x == 0 = i
262 | x == 0 = i
195 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h
263 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h
196
264
197−-- | translates an image by padding or cropping the top
265+-- | Translates an image by padding or cropping its top.
198translateY :: Int -> Image -> Image
266translateY :: Int -> Image -> Image
199translateY y i
267translateY y i
268+ | y < 0 && (abs y > imageHeight i) = emptyImage
200 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)
269 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)
201 | y == 0 = i
270 | y == 0 = i
202 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)
271 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)
203
272
204−-- | Ensure an image is no larger than the provided size. If the image is larger then crop the right
273+-- | Ensure an image is no larger than the provided size. If the image
205−-- or bottom.
274+-- is larger then crop the right or bottom.
206--
275--
207−-- This is transformed to a vertical crop from the bottom followed by horizontal crop from the
276+-- This is equivalent to a vertical crop from the bottom followed by
208−-- right.
277+-- horizontal crop from the right.
209−crop :: Int -> Int -> Image -> Image
278+crop :: Int
279+ -- ^ Cropping width
280+ -> Int
281+ -- ^ Cropping height
282+ -> Image
283+ -- ^ The image to crop
284+ -> Image
210crop 0 _ _ = EmptyImage
285crop 0 _ _ = EmptyImage
211crop _ 0 _ = EmptyImage
286crop _ 0 _ = EmptyImage
212crop w h i = cropBottom h (cropRight w i)
287crop w h i = cropBottom h (cropRight w i)
213
288
214−-- | crop the display height. If the image is less than or equal in height then this operation has
289+-- | Crop an image's height. If the image's height is less than or equal
290+-- to the specified height then this operation has no effect. Otherwise
215−-- no effect. Otherwise the image is cropped from the bottom.
291+-- the image is cropped from the bottom.
216cropBottom :: Int -> Image -> Image
292cropBottom :: Int -> Image -> Image
217cropBottom 0 _ = EmptyImage
293cropBottom 0 _ = EmptyImage
218cropBottom h inI
294cropBottom h inI
@@ -227,8 +303,9 @@ cropBottom h inI
227 | h >= imageHeight i = i
303 | h >= imageHeight i = i
228 | otherwise = CropBottom i (imageWidth i) h
304 | otherwise = CropBottom i (imageWidth i) h
229
305
230−-- | ensure the image is no wider than the given width. If the image is wider then crop the right
306+-- | Crop an image's width. If the image's width is less than or equal
231−-- side.
307+-- to the specified width then this operation has no effect. Otherwise
308+-- the image is cropped from the right.
232cropRight :: Int -> Image -> Image
309cropRight :: Int -> Image -> Image
233cropRight 0 _ = EmptyImage
310cropRight 0 _ = EmptyImage
234cropRight w inI
311cropRight w inI
@@ -243,8 +320,9 @@ cropRight w inI
243 | w >= imageWidth i = i
320 | w >= imageWidth i = i
244 | otherwise = CropRight i w (imageHeight i)
321 | otherwise = CropRight i w (imageHeight i)
245
322
246−-- | ensure the image is no wider than the given width. If the image is wider then crop the left
323+-- | Crop an image's width. If the image's width is less than or equal
247−-- side.
324+-- to the specified width then this operation has no effect. Otherwise
325+-- the image is cropped from the left.
248cropLeft :: Int -> Image -> Image
326cropLeft :: Int -> Image -> Image
249cropLeft 0 _ = EmptyImage
327cropLeft 0 _ = EmptyImage
250cropLeft w inI
328cropLeft w inI
@@ -261,8 +339,9 @@ cropLeft w inI
261 | imageWidth i <= w = i
339 | imageWidth i <= w = i
262 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
340 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
263
341
264−-- | crop the display height. If the image is less than or equal in height then this operation has
342+-- | Crop an image's height. If the image's height is less than or equal
343+-- to the specified height then this operation has no effect. Otherwise
265−-- no effect. Otherwise the image is cropped from the top.
344+-- the image is cropped from the top.
266cropTop :: Int -> Image -> Image
345cropTop :: Int -> Image -> Image
267cropTop 0 _ = EmptyImage
346cropTop 0 _ = EmptyImage
268cropTop h inI
347cropTop h inI
@@ -279,21 +358,22 @@ cropTop h inI
279 | imageHeight i <= h = i
358 | imageHeight i <= h = i
280 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
359 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
281
360
282−-- | Generic resize. Pads and crops as required to assure the given display width and height.
361+-- | Generic resize. Pads and crops are added to ensure that the
362+-- resulting image matches the specified dimensions. This is biased to
283−-- This is biased to pad/crop the right and bottom.
363+-- pad/crop the right and bottom.
284resize :: Int -> Int -> Image -> Image
364resize :: Int -> Int -> Image -> Image
285resize w h i = resizeHeight h (resizeWidth w i)
365resize w h i = resizeHeight h (resizeWidth w i)
286
366
287−-- | Resize the width. Pads and crops as required to assure the given display width.
367+-- | Resize the width. Pads and crops as required to assure the given
288−-- This is biased to pad/crop the right.
368+-- display width. This is biased to pad/crop on the right.
289resizeWidth :: Int -> Image -> Image
369resizeWidth :: Int -> Image -> Image
290resizeWidth w i = case w `compare` imageWidth i of
370resizeWidth w i = case w `compare` imageWidth i of
291 LT -> cropRight w i
371 LT -> cropRight w i
292 EQ -> i
372 EQ -> i
293 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
373 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
294
374
295−-- | Resize the height. Pads and crops as required to assure the given display height.
375+-- | Resize the height. Pads and crops as required to assure the given
296−-- This is biased to pad/crop the bottom.
376+-- display height. This is biased to pad/crop on the bottom.
297resizeHeight :: Int -> Image -> Image
377resizeHeight :: Int -> Image -> Image
298resizeHeight h i = case h `compare` imageHeight i of
378resizeHeight h i = case h `compare` imageHeight i of
299 LT -> cropBottom h i
379 LT -> cropBottom h i
src/Graphics/Vty/Image/Internal.hs+67−86
@@ -3,10 +3,6 @@
3{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# OPTIONS_HADDOCK hide #-}
4{-# OPTIONS_HADDOCK hide #-}
5
5
6−#ifndef MIN_VERSION_base
7−#defined MIN_VERSION_base(x,y,z) 1
8−#endif
9−
10module Graphics.Vty.Image.Internal where
6module Graphics.Vty.Image.Internal where
11
7
12import Graphics.Vty.Attributes
8import Graphics.Vty.Attributes
@@ -16,24 +12,14 @@ import GHC.Generics
16
12
17import Control.DeepSeq
13import Control.DeepSeq
18
14
19−import qualified Data.Text.Lazy as TL
20−
21−#if !(MIN_VERSION_base(4,8,0))
15+#if !(MIN_VERSION_base(4,11,0))
22−import Data.Monoid
16+import Data.Semigroup (Semigroup(..))
23#endif
17#endif
18+import qualified Data.Text.Lazy as TL
24
19
25-- | A display text is a Data.Text.Lazy
20-- | A display text is a Data.Text.Lazy
26−--
27−-- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each
28−-- application probably uses a single type. Perhaps parameterize the entire vty interface by the
29−-- input text type?
30−-- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance
31−-- for the usual case of appending a bunch of characters with the same attribute together.
32type DisplayText = TL.Text
21type DisplayText = TL.Text
33
22
34−-- TODO: store a skip list in HorizText(?)
35−-- TODO: represent display strings containing chars that are not 1 column chars as a separate
36−-- display string value?
37clipText :: DisplayText -> Int -> Int -> DisplayText
23clipText :: DisplayText -> Int -> Int -> DisplayText
38clipText txt leftSkip rightClip =
24clipText txt leftSkip rightClip =
39 -- CPS would clarify this I think
25 -- CPS would clarify this I think
@@ -42,8 +28,8 @@ clipText txt leftSkip rightClip =
42 (toTake,padSuffix) = clipForCharWidth rightClip txt' 0
28 (toTake,padSuffix) = clipForCharWidth rightClip txt' 0
43 txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)
29 txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)
44 -- Note: some characters and zero-width and combining characters
30 -- Note: some characters and zero-width and combining characters
45− -- combine to the left, so keep taking characters even if the width
31+ -- combine to the left, so keep taking characters even if the
46− -- is zero.
32+ -- width is zero.
47 clipForCharWidth w t n
33 clipForCharWidth w t n
48 | TL.null t = (n, False)
34 | TL.null t = (n, False)
49 | w < cw = (n, w /= 0)
35 | w < cw = (n, w /= 0)
@@ -51,8 +37,8 @@ clipText txt leftSkip rightClip =
51 where cw = safeWcwidth (TL.head t)
37 where cw = safeWcwidth (TL.head t)
52 in txt''
38 in txt''
53
39
54−-- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to
40+-- | This is the internal representation of Images. Use the constructors
55−-- create instances.
41+-- in "Graphics.Vty.Image" to create instances.
56--
42--
57-- Images are:
43-- Images are:
58--
44--
@@ -69,45 +55,57 @@ data Image =
69 -- | A horizontal text span has a row height of 1.
55 -- | A horizontal text span has a row height of 1.
70 HorizText
56 HorizText
71 { attr :: Attr
57 { attr :: Attr
72− -- | The text to display. The display width of the text is always outputWidth.
58+ -- | The text to display. The display width of the text is always
59+ -- outputWidth.
73 , displayText :: DisplayText
60 , displayText :: DisplayText
74 -- | The number of display columns for the text.
61 -- | The number of display columns for the text.
75 , outputWidth :: Int
62 , outputWidth :: Int
76 -- | the number of characters in the text.
63 -- | the number of characters in the text.
77 , charWidth :: Int
64 , charWidth :: Int
78 }
65 }
79− -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is
66+ -- | A horizontal join can be constructed between any two images.
67+ -- However a HorizJoin instance is required to be between two images
80− -- required to be between two images of equal height. The horizJoin constructor adds background
68+ -- of equal height. The horizJoin constructor adds background fills
81− -- fills to the provided images that assure this is true for the HorizJoin value produced.
69+ -- to the provided images that assure this is true for the HorizJoin
70+ -- value produced.
82 | HorizJoin
71 | HorizJoin
83 { partLeft :: Image
72 { partLeft :: Image
84 , partRight :: Image
73 , partRight :: Image
74+ , outputWidth :: Int
85− , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 0
75+ -- ^ imageWidth partLeft == imageWidth partRight. Always > 0
76+ , outputHeight :: Int
86− , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0
77+ -- ^ imageHeight partLeft == imageHeight partRight. Always > 0
87 }
78 }
88− -- | A veritical join can be constructed between any two images. However a VertJoin instance is
79+ -- | A veritical join can be constructed between any two images.
80+ -- However a VertJoin instance is required to be between two images
89− -- required to be between two images of equal width. The vertJoin constructor adds background
81+ -- of equal width. The vertJoin constructor adds background fills
90− -- fills to the provides images that assure this is true for the VertJoin value produced.
82+ -- to the provides images that assure this is true for the VertJoin
83+ -- value produced.
91 | VertJoin
84 | VertJoin
92 { partTop :: Image
85 { partTop :: Image
93 , partBottom :: Image
86 , partBottom :: Image
87+ , outputWidth :: Int
94− , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0
88+ -- ^ imageWidth partTop == imageWidth partBottom. always > 0
89+ , outputHeight :: Int
95− , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1
90+ -- ^ imageHeight partTop == imageHeight partBottom. always > 1
96 }
91 }
97− -- | A background fill will be filled with the background char. The background char is
92+ -- | A background fill will be filled with the background char. The
98− -- defined as a property of the Picture this Image is used to form.
93+ -- background char is defined as a property of the Picture this
94+ -- Image is used to form.
99 | BGFill
95 | BGFill
100 { outputWidth :: Int -- ^ always > 0
96 { outputWidth :: Int -- ^ always > 0
101 , outputHeight :: Int -- ^ always > 0
97 , outputHeight :: Int -- ^ always > 0
102 }
98 }
103− -- | Crop an image horizontally to a size by reducing the size from the right.
99+ -- | Crop an image horizontally to a size by reducing the size from
100+ -- the right.
104 | CropRight
101 | CropRight
105 { croppedImage :: Image
102 { croppedImage :: Image
106 -- | Always < imageWidth croppedImage > 0
103 -- | Always < imageWidth croppedImage > 0
107 , outputWidth :: Int
104 , outputWidth :: Int
108 , outputHeight :: Int -- ^ imageHeight croppedImage
105 , outputHeight :: Int -- ^ imageHeight croppedImage
109 }
106 }
110− -- | Crop an image horizontally to a size by reducing the size from the left.
107+ -- | Crop an image horizontally to a size by reducing the size from
108+ -- the left.
111 | CropLeft
109 | CropLeft
112 { croppedImage :: Image
110 { croppedImage :: Image
113 -- | Always < imageWidth croppedImage > 0
111 -- | Always < imageWidth croppedImage > 0
@@ -116,7 +114,8 @@ data Image =
116 , outputWidth :: Int
114 , outputWidth :: Int
117 , outputHeight :: Int
115 , outputHeight :: Int
118 }
116 }
119− -- | Crop an image vertically to a size by reducing the size from the bottom
117+ -- | Crop an image vertically to a size by reducing the size from
118+ -- the bottom
120 | CropBottom
119 | CropBottom
121 { croppedImage :: Image
120 { croppedImage :: Image
122 -- | imageWidth croppedImage
121 -- | imageWidth croppedImage
@@ -124,7 +123,8 @@ data Image =
124 -- | height image is cropped to. Always < imageHeight croppedImage > 0
123 -- | height image is cropped to. Always < imageHeight croppedImage > 0
125 , outputHeight :: Int
124 , outputHeight :: Int
126 }
125 }
127− -- | Crop an image vertically to a size by reducing the size from the top
126+ -- | Crop an image vertically to a size by reducing the size from
127+ -- the top
128 | CropTop
128 | CropTop
129 { croppedImage :: Image
129 { croppedImage :: Image
130 -- | Always < imageHeight croppedImage > 0
130 -- | Always < imageHeight croppedImage > 0
@@ -142,37 +142,11 @@ data Image =
142 --
142 --
143 -- Any image of zero size equals the empty image.
143 -- Any image of zero size equals the empty image.
144 | EmptyImage
144 | EmptyImage
145− deriving (Eq, Generic)
145+ deriving (Eq, Generic, Show, Read)
146−
147−instance Show Image where
148− show ( HorizText { attr, displayText, outputWidth, charWidth } )
149− = "HorizText " ++ show displayText
150− ++ "@(" ++ show attr ++ ","
151− ++ show outputWidth ++ ","
152− ++ show charWidth ++ ")"
153− show ( BGFill { outputWidth, outputHeight } )
154− = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"
155− show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )
156− = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
157− show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )
158− = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
159− show ( CropRight { croppedImage, outputWidth, outputHeight } )
160− = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
161− ++ " (" ++ show croppedImage ++ ")"
162− show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )
163− = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
164− ++ " (" ++ show croppedImage ++ ")"
165− show ( CropBottom { croppedImage, outputWidth, outputHeight } )
166− = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
167− ++ " (" ++ show croppedImage ++ ")"
168− show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )
169− = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
170− ++ " (" ++ show croppedImage ++ ")"
171− show ( EmptyImage ) = "EmptyImage"
172
146
173-- | pretty print just the structure of an image.
147-- | pretty print just the structure of an image.
174ppImageStructure :: Image -> String
148ppImageStructure :: Image -> String
175−ppImageStructure inImg = go 0 inImg
149+ppImageStructure = go 0
176 where
150 where
177 go indent img = tab indent ++ pp indent img
151 go indent img = tab indent ++ pp indent img
178 tab indent = concat $ replicate indent " "
152 tab indent = concat $ replicate indent " "
@@ -210,7 +184,8 @@ instance NFData Image where
210 rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()
184 rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()
211 rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()
185 rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()
212
186
213−-- | The width of an Image. This is the number display columns the image will occupy.
187+-- | The width of an Image. This is the number display columns the image
188+-- will occupy.
214imageWidth :: Image -> Int
189imageWidth :: Image -> Int
215imageWidth HorizText { outputWidth = w } = w
190imageWidth HorizText { outputWidth = w } = w
216imageWidth HorizJoin { outputWidth = w } = w
191imageWidth HorizJoin { outputWidth = w } = w
@@ -222,7 +197,8 @@ imageWidth CropBottom { outputWidth = w } = w
222imageWidth CropTop { outputWidth = w } = w
197imageWidth CropTop { outputWidth = w } = w
223imageWidth EmptyImage = 0
198imageWidth EmptyImage = 0
224
199
225−-- | The height of an Image. This is the number of display rows the image will occupy.
200+-- | The height of an Image. This is the number of display rows the
201+-- image will occupy.
226imageHeight :: Image -> Int
202imageHeight :: Image -> Int
227imageHeight HorizText {} = 1
203imageHeight HorizText {} = 1
228imageHeight HorizJoin { outputHeight = h } = h
204imageHeight HorizJoin { outputHeight = h } = h
@@ -234,27 +210,32 @@ imageHeight CropBottom { outputHeight = h } = h
234imageHeight CropTop { outputHeight = h } = h
210imageHeight CropTop { outputHeight = h } = h
235imageHeight EmptyImage = 0
211imageHeight EmptyImage = 0
236
212
213+-- | Append in the 'Semigroup' instance is equivalent to '<->'.
214+instance Semigroup Image where
215+ (<>) = vertJoin
216+
237−-- | Append in the Monoid instance is equivalent to <->.
217+-- | Append in the 'Monoid' instance is equivalent to '<->'.
238instance Monoid Image where
218instance Monoid Image where
239 mempty = EmptyImage
219 mempty = EmptyImage
220+#if !(MIN_VERSION_base(4,11,0))
240− mappend = vertJoin
221+ mappend = (<>)
222+#endif
241
223
242-- | combines two images side by side
224-- | combines two images side by side
243--
225--
244−-- Combines text chunks where possible. Assures outputWidth and outputHeight properties are not
226+-- Combines text chunks where possible. Assures outputWidth and
245−-- violated.
227+-- outputHeight properties are not violated.
246−--
247−-- The result image will have a width equal to the sum of the two images width. And the height will
248−-- equal the largest height of the two images. The area not defined in one image due to a height
249−-- missmatch will be filled with the background pattern.
250--
228--
251−-- TODO: the bg fill is biased towards top to bottom languages(?)
229+-- The result image will have a width equal to the sum of the two images
230+-- width. And the height will equal the largest height of the two
231+-- images. The area not defined in one image due to a height mismatch
232+-- will be filled with the background pattern.
252horizJoin :: Image -> Image -> Image
233horizJoin :: Image -> Image -> Image
253horizJoin EmptyImage i = i
234horizJoin EmptyImage i = i
254horizJoin i EmptyImage = i
235horizJoin i EmptyImage = i
255horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)
236horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)
256 | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)
237 | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)
257− -- TODO: assumes horiz text height is always 1
238+ -- assumes horiz text height is always 1
258 | otherwise = HorizJoin i0 i1 (w0 + w1) 1
239 | otherwise = HorizJoin i0 i1 (w0 + w1) 1
259horizJoin i0 i1
240horizJoin i0 i1
260 -- If the images are of the same height then no padding is required
241 -- If the images are of the same height then no padding is required
@@ -276,19 +257,19 @@ horizJoin _ _ = error "horizJoin applied to undefined values."
276
257
277-- | combines two images vertically
258-- | combines two images vertically
278--
259--
279−-- The result image will have a height equal to the sum of the heights of both images.
260+-- The result image will have a height equal to the sum of the heights
280−-- The width will equal the largest width of the two images.
261+-- of both images. The width will equal the largest width of the two
281−-- The area not defined in one image due to a width missmatch will be filled with the background
262+-- images. The area not defined in one image due to a width mismatch
282−-- pattern.
263+-- will be filled with the background pattern.
283−--
284−-- TODO: the bg fill is biased towards right to left languages(?)
285vertJoin :: Image -> Image -> Image
264vertJoin :: Image -> Image -> Image
286vertJoin EmptyImage i = i
265vertJoin EmptyImage i = i
287vertJoin i EmptyImage = i
266vertJoin i EmptyImage = i
288vertJoin i0 i1
267vertJoin i0 i1
289− -- If the images are of the same width then no background padding is required
268+ -- If the images are of the same width then no background padding is
269+ -- required
290 | w0 == w1 = VertJoin i0 i1 w0 h
270 | w0 == w1 = VertJoin i0 i1 w0 h
291− -- Otherwise one of the images needs to be padded to the size of the other image.
271+ -- Otherwise one of the images needs to be padded to the size of the
272+ -- other image.
292 | w0 < w1
273 | w0 < w1
293 = let padAmount = w1 - w0
274 = let padAmount = w1 - w0
294 in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h
275 in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h
src/Graphics/Vty/Inline.hs+61−54
@@ -1,12 +1,14 @@
1−-- | The inline module provides a limited interface to changing the style of terminal output. The
1+-- | The inline module provides a limited interface to changing the
2+-- style of terminal output. The intention is for this interface to be
2−-- intention is for this interface to be used inline with other output systems.
3+-- used inline with other output systems.
3--
4--
4−-- The changes specified by the InlineM monad are applied to the terminals display attributes. These
5+-- The changes specified by the InlineM monad are applied to the
6+-- terminal's display attributes. These display attributes affect the
5−-- display attributes effect the display of all following text output to the terminal file
7+-- display of all following text output to the terminal file descriptor.
6−-- descriptor.
7--
8--
8−-- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the
9+-- For example, in an IO monad the following code will print the text
10+-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
9−-- text \" Styled! \" drawn over a red background and underlined.
11+-- background and underlined.
10--
12--
11-- @
13-- @
12-- putStr \"Not styled. \"
14-- putStr \"Not styled. \"
@@ -18,28 +20,22 @@
18-- putStrLn \"Not styled.\"
20-- putStrLn \"Not styled.\"
19-- @
21-- @
20--
22--
21−-- 'putAttrChange' outputs the control codes to the terminal device 'Handle'. This is a duplicate
23+-- 'putAttrChange' emits the control codes to the terminal device
24+-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when
22−-- of the 'stdout' handle when the 'terminalHandle' was (first) acquired. If 'stdout' has since been
25+-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been
23−-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than
26+-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a
24−-- 'putAttrChange'
27+-- different 'Handle' than 'putAttrChange'.
25--
28--
26-- Copyright 2009-2010 Corey O'Connor
29-- Copyright 2009-2010 Corey O'Connor
27−{-# LANGUAGE CPP #-}
28−{-# LANGUAGE BangPatterns #-}
29−
30−#ifndef MIN_VERSION_base
31−#defined MIN_VERSION_base(x,y,z) 1
32−#endif
33−
34−module Graphics.Vty.Inline ( module Graphics.Vty.Inline
30+module Graphics.Vty.Inline
31+ ( module Graphics.Vty.Inline
35− , withVty
32+ , withVty
36− )
33+ )
37− where
34+where
38
35
39import Graphics.Vty
36import Graphics.Vty
40import Graphics.Vty.DisplayAttributes
37import Graphics.Vty.DisplayAttributes
41import Graphics.Vty.Inline.Unsafe
38import Graphics.Vty.Inline.Unsafe
42−import Graphics.Vty.Output.Interface
43
39
44import Blaze.ByteString.Builder (writeToByteString)
40import Blaze.ByteString.Builder (writeToByteString)
45
41
@@ -50,44 +46,55 @@ import Data.IORef
50
46
51import System.IO
47import System.IO
52
48
53−#if !(MIN_VERSION_base(4,8,0))
49+type InlineM v = State InlineState v
54−import Control.Applicative
55−import Data.Monoid ( mappend )
56−#endif
57
50
58−type InlineM v = State Attr v
51+data InlineState =
52+ InlineState { inlineAttr :: Attr
53+ , inlineUrlsEnabled :: Bool
54+ }
59
55
60−-- | Set the background color to the provided 'Color'
56+-- | Set the background color to the provided 'Color'.
61backColor :: Color -> InlineM ()
57backColor :: Color -> InlineM ()
62−backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )
58+backColor c = modify $ \s ->
59+ s { inlineAttr = inlineAttr s `withBackColor` c
60+ }
63
61
64−-- | Set the foreground color to the provided 'Color'
62+-- | Set the foreground color to the provided 'Color'.
65foreColor :: Color -> InlineM ()
63foreColor :: Color -> InlineM ()
66−foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )
64+foreColor c = modify $ \s ->
65+ s { inlineAttr = inlineAttr s `withForeColor` c
66+ }
67
67
68−-- | Attempt to change the 'Style' of the following text.
68+-- | Attempt to change the 'Style' of the following text..
69--
69--
70−-- If the terminal does not support the style change no error is produced. The style can still be
70+-- If the terminal does not support the style change then no error is
71−-- removed.
71+-- produced. The style can still be removed.
72applyStyle :: Style -> InlineM ()
72applyStyle :: Style -> InlineM ()
73−applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
73+applyStyle st = modify $ \s ->
74+ s { inlineAttr = inlineAttr s `withStyle` st
75+ }
74
76
75−-- | Attempt to remove the specified 'Style' from the display of the following text.
77+-- | Attempt to remove the specified 'Style' from the display of the
78+-- following text.
76--
79--
77−-- This will fail if applyStyle for the given style has not been previously called.
80+-- This will fail if 'applyStyle' for the given style has not been
81+-- previously called.
78removeStyle :: Style -> InlineM ()
82removeStyle :: Style -> InlineM ()
79−removeStyle sMask = modify $ \attr ->
83+removeStyle sMask = modify $ \s ->
84+ s { inlineAttr =
80− let style' = case attrStyle attr of
85+ let style' = case attrStyle (inlineAttr s) of
81− Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
86+ Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
82− KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
87+ KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
83− SetTo s -> s .&. complement sMask
88+ SetTo st -> st .&. complement sMask
84− in attr { attrStyle = SetTo style' }
89+ in (inlineAttr s) { attrStyle = SetTo style' }
85−
90+ }
91+
86−-- | Reset the display attributes
92+-- | Reset the display attributes.
87defaultAll :: InlineM ()
93defaultAll :: InlineM ()
88−defaultAll = put defAttr
94+defaultAll = modify $ \s -> s { inlineAttr = defAttr }
89
95
90−-- | Apply the provided display attribute changes to the given terminal output device.
96+-- | Apply the provided display attribute changes to the given terminal
97+-- output device.
91--
98--
92-- This does not flush the terminal.
99-- This does not flush the terminal.
93putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()
100putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()
@@ -97,19 +104,19 @@ putAttrChange out c = liftIO $ do
97 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
98 fattr <- case mfattr of
105 fattr <- case mfattr of
99 Nothing -> do
106 Nothing -> do
100− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
107+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
101− return $ FixedAttr defaultStyleMask Nothing Nothing
108+ return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
102 Just v -> return v
109 Just v -> return v
103− let attr = execState c currentAttr
110+ let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
104 attr' = limitAttrForDisplay out attr
111 attr' = limitAttrForDisplay out attr
105 fattr' = fixDisplayAttr fattr attr'
112 fattr' = fixDisplayAttr fattr attr'
106 diffs = displayAttrDiffs fattr fattr'
113 diffs = displayAttrDiffs fattr fattr'
107− outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
114+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
108 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
109 inlineHack dc
116 inlineHack dc
110
117
111−-- | Apply the provided display attributes changes to the terminal output device that was current at
118+-- | Apply the provided display attributes changes to the terminal
112−-- the time this was first used. Which, for most use cases, is the current terminal.
119+-- output device.
113--
120--
114-- This will flush the terminal output.
121-- This will flush the terminal output.
115putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
122putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
src/Graphics/Vty/Inline/Unsafe.hs+4−14
@@ -1,16 +1,9 @@
1−{-# LANGUAGE CPP #-}
2{-# OPTIONS_HADDOCK hide #-}
1{-# OPTIONS_HADDOCK hide #-}
3
2
4−#ifndef MIN_VERSION_base
5−#defined MIN_VERSION_base(x,y,z) 1
6−#endif
7−
8module Graphics.Vty.Inline.Unsafe where
3module Graphics.Vty.Inline.Unsafe where
9
4
10import Graphics.Vty
5import Graphics.Vty
11
6
12−import Data.Default
13−import Data.Monoid
14import Data.IORef
7import Data.IORef
15
8
16import GHC.IO.Handle (hDuplicate)
9import GHC.IO.Handle (hDuplicate)
@@ -21,10 +14,6 @@ import System.IO.Unsafe
21
14
22import System.Posix.IO (handleToFd)
15import System.Posix.IO (handleToFd)
23
16
24−#if !(MIN_VERSION_base(4,8,0))
25−import Control.Applicative
26−#endif
27−
28globalVty :: IORef (Maybe Vty)
17globalVty :: IORef (Maybe Vty)
29{-# NOINLINE globalVty #-}
18{-# NOINLINE globalVty #-}
30globalVty = unsafePerformIO $ newIORef Nothing
19globalVty = unsafePerformIO $ newIORef Nothing
@@ -39,10 +28,11 @@ mkDupeConfig = do
39 hSetBuffering stdin NoBuffering
28 hSetBuffering stdin NoBuffering
40 stdinDupe <- hDuplicate stdin >>= handleToFd
29 stdinDupe <- hDuplicate stdin >>= handleToFd
41 stdoutDupe <- hDuplicate stdout >>= handleToFd
30 stdoutDupe <- hDuplicate stdout >>= handleToFd
42− return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
31+ return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
43
32
44−-- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.
33+-- | This will create a Vty instance using 'mkVty' and execute an IO
34+-- action provided that instance. The created Vty instance will be
45−-- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'.
35+-- stored to the unsafe 'IORef' 'globalVty'.
46--
36--
47-- This instance will use duplicates of the stdin and stdout Handles.
37-- This instance will use duplicates of the stdin and stdout Handles.
48withVty :: (Vty -> IO b) -> IO b
38withVty :: (Vty -> IO b) -> IO b
src/Graphics/Vty/Input.hs+97−127
@@ -1,135 +1,125 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
3
2
4−#ifndef MIN_VERSION_base
3+-- | This module provides the input layer for Vty, including methods
5−#defined MIN_VERSION_base(x,y,z) 1
6−#endif
7−
8−-- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can
4+-- for initializing an 'Input' structure and reading 'Event's from the
9−-- then be used to read 'Event's from the terminal.
5+-- terminal.
10−--
6+--
11−-- The history of terminals has resulted in a broken input process. Some keys and combinations will
7+-- Note that due to the evolution of terminal emulators, some keys
12−-- not reliably map to the expected events by any terminal program. Even those not using vty. There
8+-- and combinations will not reliably map to the expected events by
9+-- any terminal program. There is no 1:1 mapping from key events to
13−-- is no 1:1 mapping from key events to bytes read from the terminal input device. In very limited
10+-- bytes read from the terminal input device. In very limited cases the
14−-- cases the terminal and vty's input process can be customized to resolve these issues.
11+-- terminal and vty's input process can be customized to resolve these
15−--
16−-- See "Graphics.Vty.Config" for how to configure vty's input processing. Customizing terminfo and
12+-- issues; see "Graphics.Vty.Config" for how to configure vty's input
17−-- the terminal is beyond the scope of this documentation.
13+-- processing.
18--
14--
19-- = VTY's Implementation
15-- = VTY's Implementation
20--
16--
21−-- One can get the brain rot trying to understand all this. So, as far as I can care...
22−--
23-- There are two input modes:
17-- There are two input modes:
24--
18--
25−-- 1. 7 bit
19+-- 1. 7-bit
26--
20--
27−-- 2. 8 bit
21+-- 2. 8-bit
28--
22--
29−-- 7 bit input is the default and the expected in most use cases. This is what vty uses.
23+-- The 7-bit input mode is the default and the expected mode in most use
24+-- cases. This is what Vty uses.
30--
25--
31−-- == 7 bit input encoding
26+-- == 7-bit input encoding
32--
27--
33−-- Control key combinations are represented by masking the two high bits of the 7bit input. Back in
28+-- Control key combinations are represented by masking the two high bits
29+-- of the 7-bit input. Historically the control key actually grounded
34−-- the day the control key actually grounded the two high bit wires: 6 and 7. This is why
30+-- the two high bit wires: 6 and 7. This is why control key combos
35−-- control key combos map to single character events: The input bytes are identical. The input byte
31+-- map to single character events: the input bytes are identical. The
36−-- is the bit encoding of the character with bits 6 and 7 masked. Bit 6 is set by shift. Bit 6 and
32+-- input byte is the bit encoding of the character with bits 6 and 7
37−-- 7 are masked by control. EG:
33+-- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For
34+-- example,
38--
35--
39−-- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become `00001001`. Which is the ASCII
36+-- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become
40−-- and UTF-8 encoding of the tab key.
37+-- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key.
41--
38--
42−-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero which makes `0000011` and
39+-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
43−-- is the "End of Text" code.
40+-- which is `0000011` and is the "End of Text" code.
44--
41--
45−-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This is the value 1 with bit 7
42+-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this
46−-- set and 6 unset.
43+-- is the value 1 with bit 7 set and 6 unset.
47--
44--
48−-- * Hypothesis: Bit 6 is unset by upper case letters because, initially, there were only upper case
45+-- * Hypothesis: Bit 6 is unset by upper case letters because,
49−-- letters used and a 5 bit encoding.
46+-- initially, there were only upper case letters used and a 5 bit
47+-- encoding.
50--
48--
51−-- == 8 bit encoding
49+-- == 8-bit encoding
52--
50--
53−-- The 8th bit was originally used for parity checking. Useless for emulators. Some terminal
51+-- The 8th bit was originally used for parity checking which is useless
52+-- for terminal emulators. Some terminal emulators support an 8-bit
54−-- emulators support a 8 bit input encoding. While this provides some advantages the actual usage is
53+-- input encoding. While this provides some advantages, the actual usage
55−-- low. Most systems use 7bit mode but recognize 8bit control characters when escaped. This is what
54+-- is low. Most systems use 7-bit mode but recognize 8-bit control
56−-- vty does.
55+-- characters when escaped. This is what Vty does.
57--
56--
58-- == Escaped Control Keys
57-- == Escaped Control Keys
59--
58--
60−-- Using 7 bit input encoding the @ESC@ byte can signal the start of an encoded control key. To
59+-- Using 7-bit input encoding, the @ESC@ byte can signal the start of
60+-- an encoded control key. To differentiate a single @ESC@ event from a
61−-- differentiate a single @ESC@ eventfrom a control key the timing of the input is used.
61+-- control key, the timing of the input is used.
62--
62--
63−-- 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'.
63+-- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of
64+-- 'VMIN' milliseconds.
64--
65--
65−-- 2. control keys that contain @ESC@ in their encoding: The @ESC byte; followed by more bytes read
66+-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte
67+-- is followed by more bytes read within 'VMIN' milliseconds. All bytes
66−-- within 'singleEscPeriod'. All bytes up until the next valid input block are passed to the
68+-- up until the next valid input block are passed to the classifier.
67−-- classifier.
68--
69--
69−-- If the current runtime is the threaded runtime then the terminal's @VMIN@ and @VTIME@ behavior
70+-- If the current runtime is the threaded runtime then the terminal's
71+-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
70−-- reliably implement the above rules. If the current runtime does not support forkOS then there is
72+-- the current runtime does not support 'forkOS' then there is currently
71−-- currently no implementation.
73+-- no implementation.
72−--
73−-- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop which did tricky things with
74−-- non-blocking reads and timers. The implementation was not reliable. A reliable implementation is
75−-- possible, but there are no plans to implement this.
76--
74--
77-- == Unicode Input and Escaped Control Key Sequences
75-- == Unicode Input and Escaped Control Key Sequences
78--
76--
79−-- The input encoding determines how UTF-8 encoded characters are recognize.
77+-- The input encoding determines how UTF-8 encoded characters are
78+-- recognized.
80--
79--
81−-- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is a superset of ASCII. UTF-8 does
80+-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
81+-- a superset of ASCII. UTF-8 does not overlap escaped control key
82−-- not overlap escaped control key sequences. However, the escape key must be differentiated from
82+-- sequences. However, the escape key must be differentiated from
83-- escaped control key sequences by the timing of the input bytes.
83-- escaped control key sequences by the timing of the input bytes.
84--
84--
85−-- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not require using the timing of
85+-- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not
86+-- require using the timing of input bytes to differentiate the escape
86−-- input bytes to differentiate the escape key. Many terminals do not support 8 bit mode.
87+-- key. Many terminals do not support 8-bit mode.
87--
88--
88-- == Terminfo
89-- == Terminfo
89--
90--
90−-- The terminfo system is used to determine how some keys are encoded. Terminfo is incomplete. In
91+-- The terminfo system is used to determine how some keys are encoded.
92+-- Terminfo is incomplete and in some cases terminfo is incorrect. Vty
91−-- some cases terminfo is incorrect. Vty assumes terminfo is correct but provides a mechanism to
93+-- assumes terminfo is correct but provides a mechanism to override
92−-- override terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'.
94+-- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'.
93--
95--
94-- == Terminal Input is Broken
96-- == Terminal Input is Broken
95--
97--
96−-- Clearly terminal input has fundemental issues. There is no easy way to reliably resolve these
98+-- Clearly terminal input has fundamental issues. There is no easy way
97−-- issues.
99+-- to reliably resolve these issues.
98−--
99−-- One resolution would be to ditch standard terminal interfaces entirely and just go directly to
100−-- scancodes. A reasonable option for vty if everybody used the linux kernel console. I hear GUIs
101−-- are popular these days. Sadly, GUI terminal emulators don't provide access to scancodes AFAIK.
102−--
103−-- All is lost? Not really. "Graphics.Vty.Config" supports customizing the input byte to event
104−-- mapping and xterm supports customizing the scancode to input byte mapping. With a lot of work a
105−-- user's system can be set up to encode all the key combos in an almost-sane manner.
106−--
107−-- There are other tricky work arounds that can be done. I have no interest in implementing most of
108−-- these. They are not really worth the time.
109−--
110−-- == Terminal Output is Also Broken
111--
100--
112−-- This isn't the only odd aspect of terminals due to historical aspects that no longer apply. EG:
101+-- One resolution would be to ditch standard terminal interfaces
113−-- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes
102+-- entirely and just go directly to scancodes. This would be a
114−-- the control sequence to output red, for instance) This is to account for the slow speed of
103+-- reasonable option for Vty if everybody used the linux kernel console
115−-- hardcopy teletype interfaces. Cause, uh, we totally still use those.
104+-- but for obvious reasons this is not possible.
116--
105--
117−-- The output encoding of colors and attributes are also rife with issues.
106+-- The "Graphics.Vty.Config" module supports customizing the
107+-- input-byte-to-event mapping and xterm supports customizing the
108+-- scancode-to-input-byte mapping. With a lot of work a user's system
109+-- can be set up to encode all the key combos in an almost-sane manner.
118--
110--
119-- == See also
111-- == See also
120--
112--
121-- * http://www.leonerd.org.uk/hacks/fixterms/
113-- * http://www.leonerd.org.uk/hacks/fixterms/
122−--
123−-- In my experience this cannot resolve the issues without changes to the terminal emulator and
124−-- device.
125−module Graphics.Vty.Input ( Key(..)
114+module Graphics.Vty.Input
115+ ( Key(..)
126− , Modifier(..)
116+ , Modifier(..)
127− , Button(..)
117+ , Button(..)
128− , Event(..)
118+ , Event(..)
129− , Input(..)
119+ , Input(..)
130− , inputForConfig
120+ , inputForConfig
131− )
121+ )
132− where
122+where
133
123
134import Graphics.Vty.Config
124import Graphics.Vty.Config
135import Graphics.Vty.Input.Events
125import Graphics.Vty.Input.Events
@@ -142,42 +132,19 @@ import Lens.Micro
142import qualified System.Console.Terminfo as Terminfo
132import qualified System.Console.Terminfo as Terminfo
143import System.Posix.Signals.Exts
133import System.Posix.Signals.Exts
144
134
145−#if !(MIN_VERSION_base(4,8,0))
135+#if !MIN_VERSION_base(4,11,0)
146−import Data.Functor ((<$>))
147−import Data.Monoid
148−#else
149import Data.Monoid ((<>))
136import Data.Monoid ((<>))
150#endif
137#endif
151
138
152−-- | Set up the terminal with file descriptor `inputFd` for input. Returns a 'Input'.
139+-- | Set up the terminal with file descriptor `inputFd` for input.
153−--
140+-- Returns an 'Input'.
154−-- The table used to determine the 'Events' to produce for the input bytes comes from
155−-- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from
156−-- 'inputMap'.
157−--
158−-- The terminal device is configured with the attributes:
159−--
160−-- * IXON disabled
161−-- - disables software flow control on outgoing data. This stops the process from being
162−-- suspended if the output terminal cannot keep up. I presume this has little effect these
163−-- days. I hope this means that output will be buffered if the terminal cannot keep up. In the
164−-- old days the output might of been dropped?
165−--
166−-- "raw" mode is used for input.
167--
141--
168−-- * ISIG disabled
142+-- The table used to determine the 'Events' to produce for the input
169−-- - enables keyboard combinations that result in signals. TODO: should probably be a dynamic
143+-- bytes comes from 'classifyMapForTerm' which is then overridden by
170−-- option.
144+-- the the applicable entries from the configuration's 'inputMap'.
171−--
172−-- * ECHO disabled
173−-- - input is not echod to the output. TODO: should be a dynamic option.
174−--
175−-- * ICANON disabled
176−-- - canonical mode (line mode) input is not used. TODO: should be a dynamic option.
177−--
178−-- * IEXTEN disabled
179−-- - extended functions are disabled. TODO: I don't know what those are.
180--
145--
146+-- The terminal device's mode flags are configured by the
147+-- 'attributeControl' function.
181inputForConfig :: Config -> IO Input
148inputForConfig :: Config -> IO Input
182inputForConfig config@Config{ termName = Just termName
149inputForConfig config@Config{ termName = Just termName
183 , inputFd = Just termFd
150 , inputFd = Just termFd
@@ -187,20 +154,23 @@ inputForConfig config@Config{ termName = Just termName
187 terminal <- Terminfo.setupTerm termName
154 terminal <- Terminfo.setupTerm termName
188 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
155 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
189 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
190− (setAttrs,unsetAttrs) <- attributeControl termFd
157+ (setAttrs, unsetAttrs) <- attributeControl termFd
191 setAttrs
158 setAttrs
192 input <- initInput config activeInputMap
159 input <- initInput config activeInputMap
193 let pokeIO = Catch $ do
160 let pokeIO = Catch $ do
194− let e = error "vty internal failure: this value should not propagate to users"
195 setAttrs
161 setAttrs
196− atomically $ writeTChan (input^.eventChannel) (EvResize e e)
162+ atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
197 _ <- installHandler windowChange pokeIO Nothing
163 _ <- installHandler windowChange pokeIO Nothing
198 _ <- installHandler continueProcess pokeIO Nothing
164 _ <- installHandler continueProcess pokeIO Nothing
165+
166+ let restore = unsetAttrs
167+
199 return $ input
168 return $ input
200 { shutdownInput = do
169 { shutdownInput = do
201 shutdownInput input
170 shutdownInput input
202 _ <- installHandler windowChange Ignore Nothing
171 _ <- installHandler windowChange Ignore Nothing
203 _ <- installHandler continueProcess Ignore Nothing
172 _ <- installHandler continueProcess Ignore Nothing
204− unsetAttrs
173+ restore
174+ , restoreInputState = restoreInputState input >> restore
205 }
175 }
206inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Classify.hs+69−45
@@ -1,84 +1,108 @@
1{-# OPTIONS_HADDOCK hide #-}
1{-# OPTIONS_HADDOCK hide #-}
2−-- This makes a kind of tri. Has space efficiency issues with large input blocks.
2+-- This makes a kind of trie. Has space efficiency issues with large
3−-- Likely building a parser and just applying that would be better.
3+-- input blocks. Likely building a parser and just applying that would
4−-- I did not write this so I might just rewrite it for better understanding. Which is not the best
4+-- be better.
5−-- of reasons.
6−-- TODO: measure and rewrite if required.
7−-- TODO: The ClassifyMap interface requires this code to always assure later entries override
8−-- earlier.
9module Graphics.Vty.Input.Classify
5module Graphics.Vty.Input.Classify
10− ( classify
6+ ( classify
11− , KClass(..)
7+ , KClass(..)
8+ , ClassifierState(..)
9+ )
12− ) where
10+where
13
11
14import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Events
15import Graphics.Vty.Input.Mouse
13import Graphics.Vty.Input.Mouse
14+import Graphics.Vty.Input.Focus
16import Graphics.Vty.Input.Paste
15import Graphics.Vty.Input.Paste
17import Graphics.Vty.Input.Classify.Types
16import Graphics.Vty.Input.Classify.Types
18
17
19import Codec.Binary.UTF8.Generic (decode)
18import Codec.Binary.UTF8.Generic (decode)
20
19
21−import Data.List (inits)
20+import Control.Arrow (first)
22import qualified Data.Map as M( fromList, lookup )
21import qualified Data.Map as M( fromList, lookup )
23import Data.Maybe ( mapMaybe )
22import Data.Maybe ( mapMaybe )
24import qualified Data.Set as S( fromList, member )
23import qualified Data.Set as S( fromList, member )
25
24
26−import Data.Char
27import Data.Word
25import Data.Word
28
26
27+import qualified Data.ByteString as BS
28+import qualified Data.ByteString.Char8 as BS8
29+import Data.ByteString.Char8 (ByteString)
30+
31+-- | Whether the classifier is currently processing a chunked format.
32+-- Currently, only bracketed pastes use this.
33+data ClassifierState
34+ = ClassifierStart
35+ -- ^ Not processing a chunked format.
36+ | ClassifierInChunk ByteString [ByteString]
37+ -- ^ Currently processing a chunked format. The initial chunk is in the
38+ -- first argument and a reversed remainder of the chunks is collected in
39+ -- the second argument. At the end of the processing, the chunks are
40+ -- reversed and concatenated with the final chunk.
41+
29−compile :: ClassifyMap -> [Char] -> KClass
42+compile :: ClassifyMap -> ByteString -> KClass
30compile table = cl' where
43compile table = cl' where
31 -- take all prefixes and create a set of these
44 -- take all prefixes and create a set of these
32− prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
45+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
33 maxValidInputLength = maximum (map (length . fst) table)
46 maxValidInputLength = maximum (map (length . fst) table)
34− eventForInput = M.fromList table
47+ eventForInput = M.fromList $ map (first BS8.pack) table
35− cl' [] = Prefix
48+ cl' inputBlock | BS8.null inputBlock = Prefix
36 cl' inputBlock = case M.lookup inputBlock eventForInput of
49 cl' inputBlock = case M.lookup inputBlock eventForInput of
37− -- if the inputBlock is exactly what is expected for an event then consume the whole
50+ -- if the inputBlock is exactly what is expected for an
38− -- block and return the event
51+ -- event then consume the whole block and return the event
39− Just e -> Valid e []
52+ Just e -> Valid e BS8.empty
40 Nothing -> case S.member inputBlock prefixSet of
53 Nothing -> case S.member inputBlock prefixSet of
41 True -> Prefix
54 True -> Prefix
42− -- look up progressively smaller tails of the input block until an event is found
55+ -- look up progressively smaller tails of the input
56+ -- block until an event is found The assumption is that
43− -- The assumption is that the event that consumes the most input bytes should be
57+ -- the event that consumes the most input bytes should
44− -- produced.
58+ -- be produced.
45 -- The test verifyFullSynInputToEvent2x verifies this.
59 -- The test verifyFullSynInputToEvent2x verifies this.
46− -- H: There will always be one match. The prefixSet contains, by definition, all
60+ -- H: There will always be one match. The prefixSet
47− -- prefixes of an event.
61+ -- contains, by definition, all prefixes of an event.
48 False ->
62 False ->
49− let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
63+ let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
50 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
64 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
51− (s,e) : _ -> Valid e (drop (length s) inputBlock)
65+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
52 -- neither a prefix or a full event.
66 -- neither a prefix or a full event.
53− -- TODO: debug log
54 [] -> Invalid
67 [] -> Invalid
55
68
56−classify :: ClassifyMap -> [Char] -> KClass
69+classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
57−classify table =
70+classify table = process
71+ where
58− let standardClassifier = compile table
72+ standardClassifier = compile table
73+
74+ process ClassifierStart s =
59− in \s -> case s of
75+ case BS.uncons s of
60− _ | bracketedPasteStarted s ->
76+ _ | bracketedPasteStarted s ->
77+ if bracketedPasteFinished s
78+ then parseBracketedPaste s
79+ else Chunk
80+ _ | isMouseEvent s -> classifyMouseEvent s
81+ _ | isFocusEvent s -> classifyFocusEvent s
82+ Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs
83+ _ -> standardClassifier s
84+
85+ process (ClassifierInChunk p ps) s | bracketedPasteStarted p =
61 if bracketedPasteFinished s
86 if bracketedPasteFinished s
62− then parseBracketedPaste s
87+ then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
63− else Prefix
88+ else Chunk
64− _ | isMouseEvent s -> classifyMouseEvent s
89+ process ClassifierInChunk{} _ = Invalid
65− c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
66− _ -> standardClassifier s
67
90
68−classifyUtf8 :: Char -> [Char] -> KClass
91+classifyUtf8 :: Word8 -> ByteString -> KClass
69classifyUtf8 c cs =
92classifyUtf8 c cs =
70− let n = utf8Length (ord c)
93+ let n = utf8Length c
71− (codepoint,rest) = splitAt n (c:cs)
94+ (codepoint,rest) = BS8.splitAt (n - 1) cs
72
95
73 codepoint8 :: [Word8]
96 codepoint8 :: [Word8]
74− codepoint8 = map (fromIntegral . ord) codepoint
97+ codepoint8 = c:BS.unpack codepoint
75
98
76 in case decode codepoint8 of
99 in case decode codepoint8 of
77− _ | n < length codepoint -> Prefix
100+ _ | n < BS.length codepoint + 1 -> Prefix
78− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
101+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
79− Nothing -> Invalid -- something bad happened; just ignore and continue.
102+ -- something bad happened; just ignore and continue.
103+ Nothing -> Invalid
80
104
81−utf8Length :: (Num t, Ord a, Num a) => a -> t
105+utf8Length :: Word8 -> Int
82utf8Length c
106utf8Length c
83 | c < 0x80 = 1
107 | c < 0x80 = 1
84 | c < 0xE0 = 2
108 | c < 0xE0 = 2
src/Graphics/Vty/Input/Classify/Parse.hs+18−14
@@ -1,13 +1,14 @@
1-- | This module provides a simple parser for parsing input event
1-- | This module provides a simple parser for parsing input event
2-- control sequences.
2-- control sequences.
3module Graphics.Vty.Input.Classify.Parse
3module Graphics.Vty.Input.Classify.Parse
4− ( Parser
4+ ( Parser
5− , runParser
5+ , runParser
6− , failParse
6+ , failParse
7− , readInt
7+ , readInt
8− , readChar
8+ , readChar
9− , expectChar
9+ , expectChar
10+ )
10− ) where
11+where
11
12
12import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Classify.Types
14import Graphics.Vty.Input.Classify.Types
@@ -15,12 +16,15 @@ import Graphics.Vty.Input.Classify.Types
15import Control.Monad.Trans.Maybe
16import Control.Monad.Trans.Maybe
16import Control.Monad.State
17import Control.Monad.State
17
18
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+
18−type Parser a = MaybeT (State String) a
22+type Parser a = MaybeT (State ByteString) a
19
23
20-- | Run a parser on a given input string. If the parser fails, return
24-- | Run a parser on a given input string. If the parser fails, return
21-- 'Invalid'. Otherwise return the valid event ('Valid') and the
25-- 'Invalid'. Otherwise return the valid event ('Valid') and the
22-- remaining unparsed characters.
26-- remaining unparsed characters.
23−runParser :: String -> Parser Event -> KClass
27+runParser :: ByteString -> Parser Event -> KClass
24runParser s parser =
28runParser s parser =
25 case runState (runMaybeT parser) s of
29 case runState (runMaybeT parser) s of
26 (Nothing, _) -> Invalid
30 (Nothing, _) -> Invalid
@@ -35,9 +39,9 @@ failParse = fail "invalid parse"
35-- return '123' and consume those characters.
39-- return '123' and consume those characters.
36readInt :: Parser Int
40readInt :: Parser Int
37readInt = do
41readInt = do
38− s <- get
42+ s <- BS8.unpack <$> get
39 case (reads :: ReadS Int) s of
43 case (reads :: ReadS Int) s of
40− [(i, rest)] -> put rest >> return i
44+ [(i, rest)] -> put (BS8.pack rest) >> return i
41 _ -> failParse
45 _ -> failParse
42
46
43-- | Read a character from the input stream. If one cannot be read (e.g.
47-- | Read a character from the input stream. If one cannot be read (e.g.
@@ -45,9 +49,9 @@ readInt = do
45readChar :: Parser Char
49readChar :: Parser Char
46readChar = do
50readChar = do
47 s <- get
51 s <- get
48− case s of
52+ case BS8.uncons s of
49− c:rest -> put rest >> return c
53+ Just (c,rest) -> put rest >> return c
50− _ -> failParse
54+ Nothing -> failParse
51
55
52-- | Read a character from the input stream and fail parsing if it is
56-- | Read a character from the input stream and fail parsing if it is
53-- not the specified character.
57-- not the specified character.
src/Graphics/Vty/Input/Classify/Types.hs+10−3
@@ -1,13 +1,17 @@
1-- | This module exports the input classification type to avoid import
1-- | This module exports the input classification type to avoid import
2-- cycles between other modules that need this.
2-- cycles between other modules that need this.
3+{-# LANGUAGE StrictData #-}
3module Graphics.Vty.Input.Classify.Types
4module Graphics.Vty.Input.Classify.Types
4− ( KClass(..)
5+ ( KClass(..)
6+ )
5− ) where
7+where
6
8
7import Graphics.Vty.Input.Events
9import Graphics.Vty.Input.Events
8
10
11+import Data.ByteString.Char8 (ByteString)
12+
9data KClass
13data KClass
10− = Valid Event [Char]
14+ = Valid Event ByteString
11 -- ^ A valid event was parsed. Any unused characters from the input
15 -- ^ A valid event was parsed. Any unused characters from the input
12 -- stream are also provided.
16 -- stream are also provided.
13 | Invalid
17 | Invalid
@@ -15,4 +19,7 @@ data KClass
15 | Prefix
19 | Prefix
16 -- ^ The input characters form the prefix of a valid event character
20 -- ^ The input characters form the prefix of a valid event character
17 -- sequence.
21 -- sequence.
22+ | Chunk
23+ -- ^ The input characters are either start of a bracketed paste chunk
24+ -- or in the middle of a bracketed paste chunk.
18 deriving(Show, Eq)
25 deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs+38−14
@@ -1,34 +1,44 @@
1{-# Language DeriveGeneric #-}
1{-# Language DeriveGeneric #-}
2+{-# Language StrictData #-}
2module Graphics.Vty.Input.Events where
3module Graphics.Vty.Input.Events where
3
4
5+import Control.DeepSeq
4import Data.ByteString
6import Data.ByteString
5import GHC.Generics
7import GHC.Generics
6
8
7-- | Representations of non-modifier keys.
9-- | Representations of non-modifier keys.
8--
10--
9−-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by terminal and keyboard.
11+-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by
12+-- terminal and keyboard.
10--
13--
11−-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by terminal and keyboard.
14+-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by
15+-- terminal and keyboard.
12--
16--
13−-- * Actually, support for most of these but KEsc, KChar, KBS, and KEnter vary by terminal and
17+-- * Actually, support for most of these but KEsc, KChar, KBS, and
14−-- keyboard.
18+-- KEnter vary by terminal and keyboard.
15−data Key = KEsc | KChar Char | KBS | KEnter
19+data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter
16 | KLeft | KRight | KUp | KDown
20 | KLeft | KRight | KUp | KDown
17 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
21 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
18− | KFun Int | KBackTab | KPrtScr | KPause | KIns
22+ | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns
19 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
23 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
20 deriving (Eq,Show,Read,Ord,Generic)
24 deriving (Eq,Show,Read,Ord,Generic)
21
25
26+instance NFData Key
27+
22−-- | Modifier keys. Key codes are interpreted such that users are more likely to
28+-- | Modifier keys. Key codes are interpreted such that users are more
23−-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
29+-- likely to have Meta than Alt; for instance on the PC Linux console,
24−-- generally correspond to the physical Alt key.
30+-- 'MMeta' will generally correspond to the physical Alt key.
25data Modifier = MShift | MCtrl | MMeta | MAlt
31data Modifier = MShift | MCtrl | MMeta | MAlt
26 deriving (Eq,Show,Read,Ord,Generic)
32 deriving (Eq,Show,Read,Ord,Generic)
27
33
34+instance NFData Modifier
35+
28-- | Mouse buttons.
36-- | Mouse buttons.
29−data Button = BLeft | BMiddle | BRight
37+data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
30 deriving (Eq,Show,Read,Ord,Generic)
38 deriving (Eq,Show,Read,Ord,Generic)
31
39
40+instance NFData Button
41+
32-- | Events.
42-- | Events.
33data Event
43data Event
34 = EvKey Key [Modifier]
44 = EvKey Key [Modifier]
@@ -42,10 +52,8 @@ data Event
42 -- without specifying which one; in that case, Nothing is provided.
52 -- without specifying which one; in that case, Nothing is provided.
43 -- Otherwise Just the button released is included in the event.
53 -- Otherwise Just the button released is included in the event.
44 | EvResize Int Int
54 | EvResize Int Int
45− -- ^ If read from 'eventChannel' this is the size at the time of the
55+ -- The terminal window was resized and the size is provided in the
46− -- signal. If read from 'nextEvent' this is the size at the time the
56+ -- integer fields (width, height).
47− -- event was processed by Vty. Typically these are the same, but if
48− -- somebody is resizing the terminal quickly they can be different.
49 | EvPaste ByteString
57 | EvPaste ByteString
50 -- ^ A paste event occurs when a bracketed paste input sequence is
58 -- ^ A paste event occurs when a bracketed paste input sequence is
51 -- received. For terminals that support bracketed paste mode, these
59 -- received. For terminals that support bracketed paste mode, these
@@ -54,6 +62,22 @@ data Event
54 -- input (which is probably bad, so beware!) Note that the data is
62 -- input (which is probably bad, so beware!) Note that the data is
55 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if
63 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if
56 -- that's what your application expects.
64 -- that's what your application expects.
65+ | EvLostFocus
66+ -- ^ The terminal running the application lost input focus.
67+ | EvGainedFocus
68+ -- ^ The terminal running the application gained input focus.
57 deriving (Eq,Show,Read,Ord,Generic)
69 deriving (Eq,Show,Read,Ord,Generic)
58
70
71+instance NFData Event
72+
59type ClassifyMap = [(String,Event)]
73type ClassifyMap = [(String,Event)]
74+
75+-- | The type of internal events that drive the internal Vty event
76+-- dispatching to the application.
77+data InternalEvent =
78+ ResumeAfterSignal
79+ -- ^ Vty resumed operation after the process was interrupted with a
80+ -- signal. In practice this translates into a screen redraw in the
81+ -- input event loop.
82+ | InputEvent Event
83+ -- ^ An input event was received.
src/Graphics/Vty/Input/Focus.hsnew file+49
@@ -0,0 +1,49 @@
1+module Graphics.Vty.Input.Focus
2+ ( requestFocusEvents
3+ , disableFocusEvents
4+ , isFocusEvent
5+ , classifyFocusEvent
6+ )
7+where
8+
9+import Graphics.Vty.Input.Events
10+import Graphics.Vty.Input.Classify.Types
11+import Graphics.Vty.Input.Classify.Parse
12+
13+import Control.Monad.State
14+
15+import qualified Data.ByteString.Char8 as BS8
16+import Data.ByteString.Char8 (ByteString)
17+
18+-- | These sequences set xterm-based terminals to send focus event
19+-- sequences.
20+requestFocusEvents :: ByteString
21+requestFocusEvents = BS8.pack "\ESC[?1004h"
22+
23+-- | These sequences disable focus events.
24+disableFocusEvents :: ByteString
25+disableFocusEvents = BS8.pack "\ESC[?1004l"
26+
27+-- | Does the specified string begin with a focus event?
28+isFocusEvent :: ByteString -> Bool
29+isFocusEvent s = BS8.isPrefixOf focusIn s ||
30+ BS8.isPrefixOf focusOut s
31+
32+focusIn :: ByteString
33+focusIn = BS8.pack "\ESC[I"
34+
35+focusOut :: ByteString
36+focusOut = BS8.pack "\ESC[O"
37+
38+-- | Attempt to classify an input string as a focus event.
39+classifyFocusEvent :: ByteString -> KClass
40+classifyFocusEvent s = runParser s $ do
41+ when (not $ isFocusEvent s) failParse
42+
43+ expectChar '\ESC'
44+ expectChar '['
45+ ty <- readChar
46+ case ty of
47+ 'I' -> return EvGainedFocus
48+ 'O' -> return EvLostFocus
49+ _ -> failParse
src/Graphics/Vty/Input/Loop.hs+109−47
@@ -1,14 +1,18 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE CPP #-}
2−{-# OPTIONS_HADDOCK hide #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE CPP #-}
6+{-# OPTIONS_HADDOCK hide #-}
6−-- | The input layer used to be a single function that correctly accounted for the non-threaded
7+-- | The input layer used to be a single function that correctly
8+-- accounted for the non-threaded runtime by emulating the terminal
7−-- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with
9+-- VMIN adn VTIME handling. This has been removed and replace with a
8−-- a more straightforward parser. The non-threaded runtime is no longer supported.
10+-- more straightforward parser. The non-threaded runtime is no longer
11+-- supported.
9--
12--
10−-- This is an example of an algorithm where code coverage could be high, even 100%, but the
13+-- This is an example of an algorithm where code coverage could be high,
11−-- behavior is still under tested. I should collect more of these examples...
14+-- even 100%, but the behavior is still under tested. I should collect
15+-- more of these examples...
12--
16--
13-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
17-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
14module Graphics.Vty.Input.Loop where
18module Graphics.Vty.Input.Loop where
@@ -21,8 +25,7 @@ import Control.Applicative
21import Control.Concurrent
25import Control.Concurrent
22import Control.Concurrent.STM
26import Control.Concurrent.STM
23import Control.Exception (mask, try, SomeException)
27import Control.Exception (mask, try, SomeException)
24−import Data.Monoid
25−import Lens.Micro
28+import Lens.Micro hiding ((<>~))
26import Lens.Micro.Mtl
29import Lens.Micro.Mtl
27import Lens.Micro.TH
30import Lens.Micro.TH
28import Control.Monad (when, mzero, forM_)
31import Control.Monad (when, mzero, forM_)
@@ -31,12 +34,15 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)
31import Control.Monad.State.Class (MonadState, modify)
34import Control.Monad.State.Class (MonadState, modify)
32import Control.Monad.Trans.Reader (ReaderT(..))
35import Control.Monad.Trans.Reader (ReaderT(..))
33
36
34−import Data.Char
37+import qualified Data.ByteString.Char8 as BS8
38+import qualified Data.ByteString as BS
39+import Data.ByteString.Char8 (ByteString)
35import Data.IORef
40import Data.IORef
36import Data.Word (Word8)
41import Data.Word (Word8)
37
42
38−import Foreign ( allocaArray, peekArray, Ptr )
43+import Foreign (allocaArray)
39import Foreign.C.Types (CInt(..))
44import Foreign.C.Types (CInt(..))
45+import Foreign.Ptr (Ptr, castPtr)
40
46
41import System.IO
47import System.IO
42import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
48import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
@@ -46,12 +52,18 @@ import System.Posix.Types (Fd(..))
46import Text.Printf (hPrintf)
52import Text.Printf (hPrintf)
47
53
48data Input = Input
54data Input = Input
49− { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
55+ { -- | Channel of events direct from input processing. Unlike
50− -- the display if the next event is an 'EvResize'.
56+ -- 'nextEvent' this will not refresh the display if the next event
57+ -- is an 'EvResize'.
51− _eventChannel :: TChan Event
58+ _eventChannel :: TChan InternalEvent
52− -- | Shuts down the input processing. This should return the terminal input state to before
59+ -- | Shuts down the input processing. As part of shutting down the
53− -- the input initialized.
60+ -- input, this should also restore the input state.
54 , shutdownInput :: IO ()
61 , shutdownInput :: IO ()
62+ -- | Restore the terminal's input state to what it was prior
63+ -- to configuring input for Vty. This should be done as part of
64+ -- 'shutdownInput' but is exposed in case you need to access it
65+ -- directly.
66+ , restoreInputState :: IO ()
55 -- | Changes to this value are reflected after the next event.
67 -- | Changes to this value are reflected after the next event.
56 , _configRef :: IORef Config
68 , _configRef :: IORef Config
57 -- | input debug log
69 -- | input debug log
@@ -68,10 +80,11 @@ data InputBuffer = InputBuffer
68makeLenses ''InputBuffer
80makeLenses ''InputBuffer
69
81
70data InputState = InputState
82data InputState = InputState
71− { _unprocessedBytes :: String
83+ { _unprocessedBytes :: ByteString
84+ , _classifierState :: ClassifierState
72 , _appliedConfig :: Config
85 , _appliedConfig :: Config
73 , _inputBuffer :: InputBuffer
86 , _inputBuffer :: InputBuffer
74− , _classifier :: String -> KClass
87+ , _classifier :: ClassifierState -> ByteString -> KClass
75 }
88 }
76
89
77makeLenses ''InputState
90makeLenses ''InputState
@@ -86,7 +99,8 @@ logMsg msg = do
86 Just h -> liftIO $ hPutStrLn h msg >> hFlush h
99 Just h -> liftIO $ hPutStrLn h msg >> hFlush h
87
100
88-- this must be run on an OS thread dedicated to this input handling.
101-- this must be run on an OS thread dedicated to this input handling.
89−-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
102+-- otherwise the terminal timing read behavior will block the execution
103+-- of the lightweight threads.
90loopInputProcessor :: InputM ()
104loopInputProcessor :: InputM ()
91loopInputProcessor = do
105loopInputProcessor = do
92 readFromDevice >>= addBytesToProcess
106 readFromDevice >>= addBytesToProcess
@@ -95,20 +109,20 @@ loopInputProcessor = do
95 dropInvalid
109 dropInvalid
96 loopInputProcessor
110 loopInputProcessor
97
111
98−addBytesToProcess :: String -> InputM ()
112+addBytesToProcess :: ByteString -> InputM ()
99addBytesToProcess block = unprocessedBytes <>= block
113addBytesToProcess block = unprocessedBytes <>= block
100
114
101emit :: Event -> InputM ()
115emit :: Event -> InputM ()
102emit event = do
116emit event = do
103 logMsg $ "parsed event: " ++ show event
117 logMsg $ "parsed event: " ++ show event
104− view eventChannel >>= liftIO . atomically . flip writeTChan event
118+ view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
105
119
106−-- The timing requirements are assured by the VMIN and VTIME set for the device.
120+-- The timing requirements are assured by the VMIN and VTIME set for the
121+-- device.
107--
122--
108−-- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case
123+-- Precondition: Under the threaded runtime. Only current use is from a
109−-- satisfies precondition.
124+-- forkOS thread. That case satisfies precondition.
110−-- TODO: When under the non-threaded runtime emulate VMIN and VTIME
111−readFromDevice :: InputM String
125+readFromDevice :: InputM ByteString
112readFromDevice = do
126readFromDevice = do
113 newConfig <- view configRef >>= liftIO . readIORef
127 newConfig <- view configRef >>= liftIO . readIORef
114 oldConfig <- use appliedConfig
128 oldConfig <- use appliedConfig
@@ -120,16 +134,18 @@ readFromDevice = do
120 bufferPtr <- use $ inputBuffer.ptr
134 bufferPtr <- use $ inputBuffer.ptr
121 maxBytes <- use $ inputBuffer.size
135 maxBytes <- use $ inputBuffer.size
122 stringRep <- liftIO $ do
136 stringRep <- liftIO $ do
123− -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses
137+ -- The killThread used in shutdownInput will not interrupt the
138+ -- foreign call fdReadBuf uses this provides a location to be
124− -- this provides a location to be interrupted prior to the foreign call. If there is input
139+ -- interrupted prior to the foreign call. If there is input on
125− -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime
140+ -- the FD then the fdReadBuf will return in a finite amount of
126− -- terminal setting.
141+ -- time due to the vtime terminal setting.
127 threadWaitRead fd
142 threadWaitRead fd
128 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
129 if bytesRead > 0
144 if bytesRead > 0
130− then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
145+ then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
131− else return []
146+ else return BS.empty
147+ when (not $ BS.null stringRep) $
132− when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
148+ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
133 return stringRep
149 return stringRep
134
150
135applyConfig :: Fd -> Config -> IO ()
151applyConfig :: Fd -> Config -> IO ()
@@ -140,41 +156,86 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat
140parseEvent :: InputM Event
156parseEvent :: InputM Event
141parseEvent = do
157parseEvent = do
142 c <- use classifier
158 c <- use classifier
159+ s <- use classifierState
143 b <- use unprocessedBytes
160 b <- use unprocessedBytes
144− case c b of
161+ case c s b of
145 Valid e remaining -> do
162 Valid e remaining -> do
146 logMsg $ "valid parse: " ++ show e
163 logMsg $ "valid parse: " ++ show e
147 logMsg $ "remaining: " ++ show remaining
164 logMsg $ "remaining: " ++ show remaining
165+ classifierState .= ClassifierStart
148 unprocessedBytes .= remaining
166 unprocessedBytes .= remaining
149 return e
167 return e
150− _ -> mzero
168+ _ -> mzero
151
169
152dropInvalid :: InputM ()
170dropInvalid :: InputM ()
153dropInvalid = do
171dropInvalid = do
154 c <- use classifier
172 c <- use classifier
173+ s <- use classifierState
155 b <- use unprocessedBytes
174 b <- use unprocessedBytes
175+ case c s b of
176+ Chunk -> do
177+ classifierState .=
178+ case s of
179+ ClassifierStart -> ClassifierInChunk b []
180+ ClassifierInChunk p bs -> ClassifierInChunk p (b:bs)
181+ unprocessedBytes .= BS8.empty
156− when (c b == Invalid) $ do
182+ Invalid -> do
157− logMsg "dropping input bytes"
183+ logMsg "dropping input bytes"
184+ classifierState .= ClassifierStart
158− unprocessedBytes .= []
185+ unprocessedBytes .= BS8.empty
186+ _ -> return ()
159
187
160runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
161runInputProcessorLoop classifyTable input = do
189runInputProcessorLoop classifyTable input = do
162 let bufferSize = 1024
190 let bufferSize = 1024
163 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
192+ s0 <- InputState BS8.empty ClassifierStart
164− s0 <- InputState [] <$> readIORef (_configRef input)
193+ <$> readIORef (_configRef input)
165− <*> pure (InputBuffer bufferPtr bufferSize)
194+ <*> pure (InputBuffer bufferPtr bufferSize)
166− <*> pure (classify classifyTable)
195+ <*> pure (classify classifyTable)
167 runReaderT (evalStateT loopInputProcessor s0) input
196 runReaderT (evalStateT loopInputProcessor s0) input
168
197
198+-- | Construct two IO actions: one to configure the terminal for Vty and
199+-- one to restore the terminal mode flags to the values they had at the
200+-- time this function was called.
201+--
202+-- This function constructs a configuration action to clear the
203+-- following terminal mode flags:
204+--
205+-- * IXON disabled: disables software flow control on outgoing data.
206+-- This stops the process from being suspended if the output terminal
207+-- cannot keep up.
208+--
209+-- * Raw mode is used for input.
210+--
211+-- * ISIG (enables keyboard combinations that result in
212+-- signals)
213+--
214+-- * ECHO (input is not echoed to the output)
215+--
216+-- * ICANON (canonical mode (line mode) input is not used)
217+--
218+-- * IEXTEN (extended functions are disabled)
219+--
220+-- The configuration action also explicitly sets these flags:
221+--
222+-- * ICRNL (input carriage returns are mapped to newlines)
169attributeControl :: Fd -> IO (IO (), IO ())
223attributeControl :: Fd -> IO (IO (), IO ())
170attributeControl fd = do
224attributeControl fd = do
171 original <- getTerminalAttributes fd
225 original <- getTerminalAttributes fd
226+ let vtyMode = foldl withMode clearedFlags flagsToSet
227+ clearedFlags = foldl withoutMode original flagsToUnset
228+ flagsToSet = [ MapCRtoLF -- ICRNL
229+ ]
230+ flagsToUnset = [ StartStopOutput -- IXON
172− let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
231+ , KeyboardInterrupts -- ISIG
232+ , EnableEcho -- ECHO
233+ , ProcessInput -- ICANON
173− , EnableEcho, ProcessInput, ExtendedFunctions
234+ , ExtendedFunctions -- IEXTEN
174− ]
235+ ]
175 let setAttrs = setTerminalAttributes fd vtyMode Immediately
236 let setAttrs = setTerminalAttributes fd vtyMode Immediately
176 unsetAttrs = setTerminalAttributes fd original Immediately
237 unsetAttrs = setTerminalAttributes fd original Immediately
177− return (setAttrs,unsetAttrs)
238+ return (setAttrs, unsetAttrs)
178
239
179logInitialInputState :: Input -> ClassifyMap -> IO()
240logInitialInputState :: Input -> ClassifyMap -> IO()
180logInitialInputState input classifyTable = case _inputDebug input of
241logInitialInputState input classifyTable = case _inputDebug input of
@@ -182,7 +243,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
182 Just h -> do
243 Just h -> do
183 Config{ vmin = Just theVmin
244 Config{ vmin = Just theVmin
184 , vtime = Just theVtime
245 , vtime = Just theVtime
185− , termName = Just theTerm, .. } <- readIORef $ _configRef input
246+ , termName = Just theTerm } <- readIORef $ _configRef input
186 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
187 forM_ classifyTable $ \i -> case i of
248 forM_ classifyTable $ \i -> case i of
188 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
249 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
@@ -198,6 +259,7 @@ initInput config classifyTable = do
198 applyConfig fd config
259 applyConfig fd config
199 stopSync <- newEmptyMVar
260 stopSync <- newEmptyMVar
200 input <- Input <$> atomically newTChan
261 input <- Input <$> atomically newTChan
262+ <*> pure (return ())
201 <*> pure (return ())
263 <*> pure (return ())
202 <*> newIORef config
264 <*> newIORef config
203 <*> maybe (return Nothing)
265 <*> maybe (return Nothing)
src/Graphics/Vty/Input/Mouse.hs+34−23
@@ -3,21 +3,24 @@
3--
3--
4-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
4-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
5module Graphics.Vty.Input.Mouse
5module Graphics.Vty.Input.Mouse
6− ( requestMouseEvents
6+ ( requestMouseEvents
7− , disableMouseEvents
7+ , disableMouseEvents
8− , isMouseEvent
8+ , isMouseEvent
9− , classifyMouseEvent
9+ , classifyMouseEvent
10+ )
10− ) where
11+where
11
12
12import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Classify.Types
14import Graphics.Vty.Input.Classify.Types
14import Graphics.Vty.Input.Classify.Parse
15import Graphics.Vty.Input.Classify.Parse
15
16
16import Control.Monad.State
17import Control.Monad.State
17−import Data.List (isPrefixOf)
18import Data.Maybe (catMaybes)
18import Data.Maybe (catMaybes)
19import Data.Bits ((.&.))
19import Data.Bits ((.&.))
20
20
21+import qualified Data.ByteString.Char8 as BS8
22+import Data.ByteString.Char8 (ByteString)
23+
21-- A mouse event in SGR extended mode is
24-- A mouse event in SGR extended mode is
22--
25--
23-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
26-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
@@ -31,28 +34,28 @@ import Data.Bits ((.&.))
31
34
32-- | These sequences set xterm-based terminals to send mouse event
35-- | These sequences set xterm-based terminals to send mouse event
33-- sequences.
36-- sequences.
34−requestMouseEvents :: String
37+requestMouseEvents :: ByteString
35−requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h\ESC[?1005h"
38+requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
36
39
37-- | These sequences disable mouse events.
40-- | These sequences disable mouse events.
38−disableMouseEvents :: String
41+disableMouseEvents :: ByteString
39−disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l\ESC[?1005l"
42+disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
40
43
41-- | Does the specified string begin with a mouse event?
44-- | Does the specified string begin with a mouse event?
42−isMouseEvent :: String -> Bool
45+isMouseEvent :: ByteString -> Bool
43isMouseEvent s = isSGREvent s || isNormalEvent s
46isMouseEvent s = isSGREvent s || isNormalEvent s
44
47
45−isSGREvent :: String -> Bool
48+isSGREvent :: ByteString -> Bool
46−isSGREvent = isPrefixOf sgrPrefix
49+isSGREvent = BS8.isPrefixOf sgrPrefix
47
50
48−sgrPrefix :: String
51+sgrPrefix :: ByteString
49−sgrPrefix = "\ESC[M"
52+sgrPrefix = BS8.pack "\ESC[M"
50
53
51−isNormalEvent :: String -> Bool
54+isNormalEvent :: ByteString -> Bool
52−isNormalEvent = isPrefixOf normalPrefix
55+isNormalEvent = BS8.isPrefixOf normalPrefix
53
56
54−normalPrefix :: String
57+normalPrefix :: ByteString
55−normalPrefix = "\ESC[<"
58+normalPrefix = BS8.pack "\ESC[<"
56
59
57-- Modifier bits:
60-- Modifier bits:
58shiftBit :: Int
61shiftBit :: Int
@@ -66,7 +69,7 @@ ctrlBit = 16
66
69
67-- These bits indicate the buttons involved:
70-- These bits indicate the buttons involved:
68buttonMask :: Int
71buttonMask :: Int
69−buttonMask = 3
72+buttonMask = 67
70
73
71leftButton :: Int
74leftButton :: Int
72leftButton = 0
75leftButton = 0
@@ -77,11 +80,17 @@ middleButton = 1
77rightButton :: Int
80rightButton :: Int
78rightButton = 2
81rightButton = 2
79
82
83+scrollUp :: Int
84+scrollUp = 64
85+
86+scrollDown :: Int
87+scrollDown = 65
88+
80hasBitSet :: Int -> Int -> Bool
89hasBitSet :: Int -> Int -> Bool
81hasBitSet val bit = val .&. bit > 0
90hasBitSet val bit = val .&. bit > 0
82
91
83−-- | Attempt to lassify an input string as a mouse event.
92+-- | Attempt to classify an input string as a mouse event.
84−classifyMouseEvent :: String -> KClass
93+classifyMouseEvent :: ByteString -> KClass
85classifyMouseEvent s = runParser s $ do
94classifyMouseEvent s = runParser s $ do
86 when (not $ isMouseEvent s) failParse
95 when (not $ isMouseEvent s) failParse
87
96
@@ -93,12 +102,14 @@ classifyMouseEvent s = runParser s $ do
93 'M' -> classifyNormalMouseEvent
102 'M' -> classifyNormalMouseEvent
94 _ -> failParse
103 _ -> failParse
95
104
96−-- Given a modifer/button value, determine which button was indicated
105+-- Given a modifier/button value, determine which button was indicated
97getSGRButton :: Int -> Parser Button
106getSGRButton :: Int -> Parser Button
98getSGRButton mods =
107getSGRButton mods =
99 let buttonMap = [ (leftButton, BLeft)
108 let buttonMap = [ (leftButton, BLeft)
100 , (middleButton, BMiddle)
109 , (middleButton, BMiddle)
101 , (rightButton, BRight)
110 , (rightButton, BRight)
111+ , (scrollUp, BScrollUp)
112+ , (scrollDown, BScrollDown)
102 ]
113 ]
103 in case lookup (mods .&. buttonMask) buttonMap of
114 in case lookup (mods .&. buttonMask) buttonMap of
104 Nothing -> failParse
115 Nothing -> failParse
src/Graphics/Vty/Input/Paste.hs+21−28
@@ -2,47 +2,40 @@
2--
2--
3-- http://cirw.in/blog/bracketed-paste
3-- http://cirw.in/blog/bracketed-paste
4module Graphics.Vty.Input.Paste
4module Graphics.Vty.Input.Paste
5− ( parseBracketedPaste
5+ ( parseBracketedPaste
6− , bracketedPasteStarted
6+ , bracketedPasteStarted
7− , bracketedPasteFinished
7+ , bracketedPasteFinished
8+ )
8− ) where
9+where
9
10
10import qualified Data.ByteString.Char8 as BS8
11import qualified Data.ByteString.Char8 as BS8
12+import Data.ByteString.Char8 (ByteString)
11
13
12import Graphics.Vty.Input.Events
14import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Classify.Types
15import Graphics.Vty.Input.Classify.Types
14
16
15−import Data.List (isPrefixOf, isInfixOf)
17+bracketedPasteStart :: ByteString
18+bracketedPasteStart = BS8.pack "\ESC[200~"
16
19
17−bracketedPasteStart :: String
18−bracketedPasteStart = "\ESC[200~"
19−
20−bracketedPasteEnd :: String
20+bracketedPasteEnd :: ByteString
21−bracketedPasteEnd = "\ESC[201~"
21+bracketedPasteEnd = BS8.pack "\ESC[201~"
22
22
23-- | Does the input start a bracketed paste?
23-- | Does the input start a bracketed paste?
24−bracketedPasteStarted :: String -> Bool
24+bracketedPasteStarted :: ByteString -> Bool
25−bracketedPasteStarted = isPrefixOf bracketedPasteStart
25+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart
26
26
27-- | Does the input contain a complete bracketed paste?
27-- | Does the input contain a complete bracketed paste?
28−bracketedPasteFinished :: String -> Bool
28+bracketedPasteFinished :: ByteString -> Bool
29−bracketedPasteFinished = isInfixOf bracketedPasteEnd
29+bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd
30
30
31-- | Parse a bracketed paste. This should only be called on a string if
31-- | Parse a bracketed paste. This should only be called on a string if
32-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
32-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
33-- 'True'.
33-- 'True'.
34−parseBracketedPaste :: String -> KClass
34+parseBracketedPaste :: ByteString -> KClass
35parseBracketedPaste s =
35parseBracketedPaste s =
36− let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd
37− rest' = if bracketedPasteEnd `isPrefixOf` rest
38− then drop (length bracketedPasteEnd) rest
39− else rest
40− in Valid (EvPaste $ BS8.pack p) rest'
36+ Valid (EvPaste p) (BS8.drop endLen rest')
41−
37+ where
42−takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])
38+ startLen = BS8.length bracketedPasteStart
43−takeUntil [] _ = ([], [])
39+ endLen = BS8.length bracketedPasteEnd
44−takeUntil cs sub
40+ (_, rest ) = BS8.breakSubstring bracketedPasteStart s
45− | length cs < length sub = (cs, [])
41+ (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest
46− | take (length sub) cs == sub = ([], drop (length sub) cs)
47− | otherwise = let (pre, suf) = takeUntil (tail cs) sub
48− in (head cs:pre, suf)
src/Graphics/Vty/Input/Terminfo.hs+32−31
@@ -7,8 +7,8 @@ import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT
7import Control.Arrow
7import Control.Arrow
8import System.Console.Terminfo
8import System.Console.Terminfo
9
9
10−-- | queries the terminal for all capability based input sequences then adds on a terminal dependent
10+-- | Queries the terminal for all capability-based input sequences and
11−-- input sequence mapping.
11+-- then adds on a terminal-dependent input sequence mapping.
12--
12--
13-- For reference see:
13-- For reference see:
14--
14--
@@ -20,29 +20,29 @@ import System.Console.Terminfo
20--
20--
21-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
21-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
22--
22--
23−-- This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect.
23+-- Terminfo is incomplete. The vim source implies that terminfo is also
24−-- Vty assumes that the an internal terminfo table added to the system provided terminfo table is
24+-- incorrect. Vty assumes that the internal terminfo table added to the
25−-- correct.
25+-- system-provided terminfo table is correct.
26--
26--
27−-- 1. build terminfo table for all caps. Missing caps are not added.
27+-- The procedure used here is:
28--
28--
29−-- 2. add tables for visible chars, esc, del plus ctrl and meta
29+-- 1. Build terminfo table for all caps. Missing caps are not added.
30--
30--
31−-- 3. add internally defined table for given terminal type.
31+-- 2. Add tables for visible chars, esc, del, ctrl, and meta.
32--
32--
33−-- Precedence is currently implicit in the 'compile' algorithm. Which is a bit odd.
33+-- 3. Add internally-defined table for given terminal type.
34--
34--
35−-- \todo terminfo meta is not supported.
35+-- Precedence is currently implicit in the 'compile' algorithm.
36−-- \todo no 8bit
37classifyMapForTerm :: String -> Terminal -> ClassifyMap
36classifyMapForTerm :: String -> Terminal -> ClassifyMap
38classifyMapForTerm termName term =
37classifyMapForTerm termName term =
39 concat $ capsClassifyMap term keysFromCapsTable
38 concat $ capsClassifyMap term keysFromCapsTable
40 : universalTable
39 : universalTable
41 : termSpecificTables termName
40 : termSpecificTables termName
42
41
43−-- | key table applicable to all terminals.
42+-- | The key table applicable to all terminals.
44--
43--
45−-- TODO: some probably only applicable to ANSI/VT100 terminals.
44+-- Note that some of these entries are probably only applicable to
45+-- ANSI/VT100 terminals.
46universalTable :: ClassifyMap
46universalTable :: ClassifyMap
47universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
47universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
48
48
@@ -50,31 +50,31 @@ capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap
50capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]
50capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]
51 where extractCap = first (getCapability terminal . tiGetStr)
51 where extractCap = first (getCapability terminal . tiGetStr)
52
52
53−-- | tables specific to a given terminal that are not derivable from terminfo.
53+-- | Tables specific to a given terminal that are not derivable from
54+-- terminfo.
54--
55--
55−-- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier.
56+-- Note that this adds the ANSI/VT100/VT50 tables regardless of term
57+-- identifier.
56termSpecificTables :: String -> [ClassifyMap]
58termSpecificTables :: String -> [ClassifyMap]
57termSpecificTables _termName = ANSIVT.classifyTable
59termSpecificTables _termName = ANSIVT.classifyTable
58
60
59-- | Visible characters in the ISO-8859-1 and UTF-8 common set.
61-- | Visible characters in the ISO-8859-1 and UTF-8 common set.
60--
62--
61−-- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this
63+-- We limit to < 0xC1. The UTF8 sequence detector will catch all values
62−-- classify table is reached.
64+-- 0xC2 and above before this classify table is reached.
63−--
64−-- TODO: resolve
65−-- 1. start at ' '. The earlier characters are all 'ctrlChar'
66visibleChars :: ClassifyMap
65visibleChars :: ClassifyMap
67visibleChars = [ ([x], EvKey (KChar x) [])
66visibleChars = [ ([x], EvKey (KChar x) [])
68 | x <- [' ' .. toEnum 0xC1]
67 | x <- [' ' .. toEnum 0xC1]
69 ]
68 ]
70
69
71−-- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.
70+-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set
71+-- translated to ctrl + char.
72--
72--
73−-- \todo resolve CTRL-i is the same as tab
73+-- This treats CTRL-i the same as tab.
74ctrlChars :: ClassifyMap
74ctrlChars :: ClassifyMap
75ctrlChars =
75ctrlChars =
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
77− | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
77+ | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
79 , y /= 'h' -- CTRL-h should not hide BS
79 , y /= 'h' -- CTRL-h should not hide BS
80 ]
80 ]
@@ -83,22 +83,23 @@ ctrlChars =
83ctrlMetaChars :: ClassifyMap
83ctrlMetaChars :: ClassifyMap
84ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
84ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
85
85
86−-- | esc, meta esc, delete, meta delete, enter, meta enter
86+-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
87specialSupportKeys :: ClassifyMap
87specialSupportKeys :: ClassifyMap
88specialSupportKeys =
88specialSupportKeys =
89+ [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90+ , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
89− [ -- special support for ESC
91+ -- special support for ESC
90− ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
92+ , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
91 -- Special support for backspace
93 -- Special support for backspace
92− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
94+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
93 -- Special support for Enter
95 -- Special support for Enter
94 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
95 -- explicit support for tab
97 -- explicit support for tab
96 , ("\t", EvKey (KChar '\t') [])
98 , ("\t", EvKey (KChar '\t') [])
97 ]
99 ]
98
100
99−-- | classify table directly generated from terminfo cap strings
101+-- | A classification table directly generated from terminfo cap
100−--
102+-- strings. These are:
101−-- these are:
102--
103--
103-- * ka1 - keypad up-left
104-- * ka1 - keypad up-left
104--
105--
@@ -180,6 +181,6 @@ keysFromCapsTable =
180 , ("kcuu1", EvKey KUp [])
181 , ("kcuu1", EvKey KUp [])
181 ] ++ functionKeyCapsTable
182 ] ++ functionKeyCapsTable
182
183
183−-- | cap names for function keys
184+-- | Cap names for function keys.
184functionKeyCapsTable :: ClassifyMap
185functionKeyCapsTable :: ClassifyMap
185functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
186functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+18−16
@@ -1,15 +1,15 @@
1−-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo.
1+-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from
2+-- terminfo.
2--
3--
3−-- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often
4+-- Or that are sent regardless of terminfo by terminal emulators. EG:
5+-- Terminal emulators will often use VT50 input bytes regardless of
4−-- use VT50 input bytes regardless of declared terminal type. This provides compatibility with
6+-- declared terminal type. This provides compatibility with programs
5−-- programs that don't follow terminfo.
7+-- that don't follow terminfo.
6module Graphics.Vty.Input.Terminfo.ANSIVT where
8module Graphics.Vty.Input.Terminfo.ANSIVT where
7
9
8import Graphics.Vty.Input.Events
10import Graphics.Vty.Input.Events
9
11
10-- | Encoding for navigation keys.
12-- | Encoding for navigation keys.
11−--
12−-- TODO: This is not the same as the input bytes pulled from teh caps table.
13navKeys0 :: ClassifyMap
13navKeys0 :: ClassifyMap
14navKeys0 =
14navKeys0 =
15 [ k "G" KCenter
15 [ k "G" KCenter
@@ -30,8 +30,10 @@ navKeys1 =
30 [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
30 [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
31 | charCnt <- ["1;", ""], -- we can have a count or not
31 | charCnt <- ["1;", ""], -- we can have a count or not
32 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
32 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
33+ -- modifiers and their codes
33− ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
34+ ([MShift, MCtrl],6), ([MShift, MMeta],4)],
35+ -- directions and their codes
34− (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes
36+ (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)]
35 ]
37 ]
36
38
37-- | encoding for ins, del, pageup, pagedown, home, end
39-- | encoding for ins, del, pageup, pagedown, home, end
@@ -57,18 +59,18 @@ navKeys3 =
57-- This encoding depends on the terminal.
59-- This encoding depends on the terminal.
58functionKeys1 :: ClassifyMap
60functionKeys1 :: ClassifyMap
59functionKeys1 =
61functionKeys1 =
60− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
62+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in
61 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
63 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
62
64
63-- | encoding for meta plus char
65-- | encoding for meta plus char
64--
66--
65−-- TODO: resolve -
66−--
67−-- 1. removed 'ESC' from second list due to duplication with "special_support_keys".
67+-- 1. removed 'ESC' from second list due to duplication with
68+-- "special_support_keys".
68−-- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is
69+-- 2. removed '[' from second list due to conflict with 7-bit encoding
69−-- the same as ESC should examine km and current encoding.
70+-- for ESC. Whether meta+[ is the same as ESC should examine km and
71+-- current encoding.
70−-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by
72+-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped
71−-- special_support_keys.
73+-- to KBS by special_support_keys.
72functionKeys2 :: ClassifyMap
74functionKeys2 :: ClassifyMap
73functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
75functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
74 | x <- '\t':[' ' .. '~']
76 | x <- '\t':[' ' .. '~']
src/Graphics/Vty/Output.hs+53−52
@@ -1,70 +1,69 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
2−{-# LANGUAGE NamedFieldPuns #-}
2+-- | This module provides functions for accessing the current terminal
3−-- | Output interface.
3+-- or a specific terminal device.
4--
4--
5−-- Access to the current terminal or a specific terminal device.
5+-- See also:
6--
6--
7−-- See also:
7+-- 1. "Graphics.Vty.Output": This instantiates an abtract interface
8+-- to the terminal based on the @TERM@ and @COLORTERM@ environment
9+-- variables.
8--
10--
9−-- 1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based
11+-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
10−-- on the TERM and COLORTERM environment variables.
12+-- terminal modules need to implement.
11--
13--
12−-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement.
14+-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
15+-- that uses terminfo for all control strings. No attempt is made to
16+-- change the character set to UTF-8 for these terminals.
13--
17--
14−-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance that uses terminfo for all
15−-- control strings. No attempt is made to change the character set to UTF-8 for these terminals.
16−-- I don't know a way to reliably determine if that is required or how to do so.
17−--
18−-- 4. "Graphics.Vty.Output.XTermColor": This module contains an interface suitable for xterm-like
18+-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
19+-- interface suitable for xterm-like terminals. These are the terminals
19−-- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many
20+-- where @TERM@ begins with @xterm@. This does use terminfo for as many
20−-- control codes as possible.
21+-- control codes as possible.
21−module Graphics.Vty.Output ( module Graphics.Vty.Output
22+module Graphics.Vty.Output
22− , Output(..) -- \todo hide constructors
23+ ( outputForConfig
23− , AssumedState(..)
24+ , setCursorPos
24− , DisplayContext(..) -- \todo hide constructors
25+ , hideCursor
25− , outputPicture
26+ , showCursor
26− , displayContext
27− )
27+ )
28− where
28+where
29
29
30−import Graphics.Vty.Prelude
30+import Control.Monad (when)
31
31
32import Graphics.Vty.Config
32import Graphics.Vty.Config
33−
33+import Graphics.Vty.Image (regionWidth, regionHeight)
34import Graphics.Vty.Output.Interface
34import Graphics.Vty.Output.Interface
35import Graphics.Vty.Output.XTermColor as XTermColor
35import Graphics.Vty.Output.XTermColor as XTermColor
36import Graphics.Vty.Output.TerminfoBased as TerminfoBased
36import Graphics.Vty.Output.TerminfoBased as TerminfoBased
37
37
38import Blaze.ByteString.Builder (writeToByteString)
38import Blaze.ByteString.Builder (writeToByteString)
39
39
40−import Control.Monad.Trans
41−
42import Data.List (isPrefixOf)
40import Data.List (isPrefixOf)
41+
42+#if !MIN_VERSION_base(4,11,0)
43import Data.Monoid ((<>))
43import Data.Monoid ((<>))
44+#endif
44
45
45−-- | Returns a `Output` for the terminal specified in `Config`
46+-- | Returns an `Output` for the terminal specified in `Config`.
46--
47--
47−-- The specific Output implementation used is hidden from the API user. All terminal implementations
48+-- The specific Output implementation used is hidden from the API user.
49+-- All terminal implementations are assumed to perform more, or less,
48−-- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at
50+-- the same. Currently, all implementations use terminfo for at least
49−-- least some terminal specific information.
51+-- some terminal specific information.
50--
52--
51−-- Specifics about it being based on terminfo are hidden from the API user. If a terminal
52−-- implementation is developed for a terminal without terminfo support then Vty should work as
53+-- If a terminal implementation is developed for a terminal without
53−-- expected on that terminal.
54+-- terminfo support then Vty should work as expected on that terminal.
54--
55--
55-- Selection of a terminal is done as follows:
56-- Selection of a terminal is done as follows:
56--
57--
57-- * If TERM contains "xterm" or "screen", use XTermColor.
58-- * If TERM contains "xterm" or "screen", use XTermColor.
58-- * otherwise use the TerminfoBased driver.
59-- * otherwise use the TerminfoBased driver.
59−--
60−-- \todo add an implementation for windows that does not depend on terminfo. Should be installable
61−-- with only what is provided in the haskell platform. Use ansi-terminal
62outputForConfig :: Config -> IO Output
60outputForConfig :: Config -> IO Output
63−outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do
61+outputForConfig Config{ outputFd = Just fd, termName = Just termName
62+ , colorMode = Just colorMode, .. } = do
64 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
65− then XTermColor.reserveTerminal termName fd
64+ then XTermColor.reserveTerminal termName fd colorMode
66 -- Not an xterm-like terminal. try for generic terminfo.
65 -- Not an xterm-like terminal. try for generic terminfo.
67− else TerminfoBased.reserveTerminal termName fd
66+ else TerminfoBased.reserveTerminal termName fd colorMode
68
67
69 case mouseMode of
68 case mouseMode of
70 Just s -> setMode t Mouse s
69 Just s -> setMode t Mouse s
@@ -79,28 +78,30 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
79
78
80-- | Sets the cursor position to the given output column and row.
79-- | Sets the cursor position to the given output column and row.
81--
80--
82−-- This is not necessarially the same as the character position with the same coordinates.
81+-- This is not necessarily the same as the character position with the
83−-- Characters can be a variable number of columns in width.
82+-- same coordinates. Characters can be a variable number of columns in
83+-- width.
84--
84--
85−-- Currently, the only way to set the cursor position to a given character coordinate is to specify
85+-- Currently, the only way to set the cursor position to a given
86+-- character coordinate is to specify the coordinate in the Picture
86−-- the coordinate in the Picture instance provided to outputPicture or refresh.
87+-- instance provided to 'outputPicture' or 'refresh'.
87−setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()
88+setCursorPos :: Output -> Int -> Int -> IO ()
88setCursorPos t x y = do
89setCursorPos t x y = do
89 bounds <- displayBounds t
90 bounds <- displayBounds t
90 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
91 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
91 dc <- displayContext t bounds
92 dc <- displayContext t bounds
92− liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
93+ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
93
94
94−-- | Hides the cursor
95+-- | Hides the cursor.
95−hideCursor :: MonadIO m => Output -> m ()
96+hideCursor :: Output -> IO ()
96hideCursor t = do
97hideCursor t = do
97 bounds <- displayBounds t
98 bounds <- displayBounds t
98 dc <- displayContext t bounds
99 dc <- displayContext t bounds
99− liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
100+ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
100
101
101−-- | Shows the cursor
102+-- | Shows the cursor.
102−showCursor :: MonadIO m => Output -> m ()
103+showCursor :: Output -> IO ()
103showCursor t = do
104showCursor t = do
104 bounds <- displayBounds t
105 bounds <- displayBounds t
105 dc <- displayContext t bounds
106 dc <- displayContext t bounds
106− liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
107+ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+166−122
@@ -1,21 +1,25 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2−-- General philosophy is: MonadIO is for equations exposed to clients.
3−{-# LANGUAGE CPP #-}
4−{-# LANGUAGE BangPatterns #-}
5{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
7{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
8{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
9−
6+{-# LANGUAGE ScopedTypeVariables #-}
10−#ifndef MIN_VERSION_base
7+-- | This module provides an abstract interface for performing terminal
11−#defined MIN_VERSION_base(x,y,z) 1
8+-- output. The only user-facing part of this API is 'Output'.
12−#endif
13−
14module Graphics.Vty.Output.Interface
9module Graphics.Vty.Output.Interface
10+ ( Output(..)
11+ , AssumedState(..)
12+ , DisplayContext(..)
13+ , Mode(..)
14+ , displayContext
15+ , outputPicture
16+ , initialAssumedState
17+ , limitAttrForDisplay
18+ )
15where
19where
16
20
17−import Graphics.Vty.Prelude
21+import Graphics.Vty.Attributes
18−
22+import Graphics.Vty.Image (DisplayRegion, regionHeight)
19import Graphics.Vty.Picture
23import Graphics.Vty.Picture
20import Graphics.Vty.PictureToSpans
24import Graphics.Vty.PictureToSpans
21import Graphics.Vty.Span
25import Graphics.Vty.Span
@@ -25,72 +29,97 @@ import Graphics.Vty.DisplayAttributes
25import Blaze.ByteString.Builder (Write, writeToByteString)
29import Blaze.ByteString.Builder (Write, writeToByteString)
26import Blaze.ByteString.Builder.ByteString (writeByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
27
31
28−import Control.Monad.Trans
29−
30import qualified Data.ByteString as BS
32import qualified Data.ByteString as BS
31import Data.IORef
33import Data.IORef
32import qualified Data.Text.Encoding as T
34import qualified Data.Text.Encoding as T
33import qualified Data.Text.Lazy as TL
35import qualified Data.Text.Lazy as TL
34import qualified Data.Vector as Vector
36import qualified Data.Vector as Vector
35
37
36−#if !(MIN_VERSION_base(4,8,0))
37−import Data.Monoid (mempty, mappend)
38−#endif
39−
40-- | Modal terminal features that can be enabled and disabled.
38-- | Modal terminal features that can be enabled and disabled.
41data Mode = Mouse
39data Mode = Mouse
40+ -- ^ Mouse mode (whether the terminal is configured to provide
41+ -- mouse input events)
42 | BracketedPaste
42 | BracketedPaste
43+ -- ^ Paste mode (whether the terminal is configured to provide
44+ -- events on OS pastes)
45+ | Focus
46+ -- ^ Focus-in/focus-out events (whether the terminal is
47+ -- configured to provide events on focus change)
48+ | Hyperlink
49+ -- ^ Hyperlink mode via the 'withURL' attribute modifier (see
50+ -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
51+ -- Note that this may not work gracefully in all terminal
52+ -- emulators so be sure to test this mode with the terminals
53+ -- you intend to support. It is off by default.
43 deriving (Eq, Read, Show)
54 deriving (Eq, Read, Show)
44
55
56+-- | The Vty terminal output interface.
45data Output = Output
57data Output = Output
46 { -- | Text identifier for the output device. Used for debugging.
58 { -- | Text identifier for the output device. Used for debugging.
47 terminalID :: String
59 terminalID :: String
60+ -- | Release the terminal just prior to application exit and reset
61+ -- it to its state prior to application startup.
48− , releaseTerminal :: forall m. MonadIO m => m ()
62+ , releaseTerminal :: IO ()
49− -- | Clear the display and initialize the terminal to some initial display state.
63+ -- | Clear the display and initialize the terminal to some initial
64+ -- display state.
50− --
65+ --
51− -- The expectation of a program is that the display starts in some initial state.
66+ -- The expectation of a program is that the display starts in some
52− -- The initial state would consist of fixed values:
67+ -- The initial state. initial state would consist of fixed values:
53− --
68+ --
54− -- - cursor at top left
69+ -- - cursor at top left
55− -- - UTF-8 character encoding
70+ -- - UTF-8 character encoding
56− -- - drawing characteristics are the default
71+ -- - drawing characteristics are the default
57− --
58− -- The abstract operation I think all these behaviors are instances of is reserving exclusive
59− -- access to a display such that:
60− --
61− -- - The previous state cannot be determined
62− -- - When exclusive access to a display is released the display returns to the previous state.
63− , reserveDisplay :: forall m. MonadIO m => m ()
72+ , reserveDisplay :: IO ()
64− -- | Return the display to the state before `reserveDisplay`
73+ -- | Return the display to the state before `reserveDisplay` If no
65− -- If no previous state then set the display state to the initial state.
74+ -- previous state then set the display state to the initial state.
66− , releaseDisplay :: forall m. MonadIO m => m ()
75+ , releaseDisplay :: IO ()
76+ -- | Sets the current display bounds (width, height).
77+ , setDisplayBounds :: (Int, Int) -> IO ()
67− -- | Returns the current display bounds.
78+ -- | Returns the current display bounds.
68− , displayBounds :: forall m. MonadIO m => m DisplayRegion
79+ , displayBounds :: IO DisplayRegion
69− -- | Output the byte string to the terminal device.
80+ -- | Output the bytestring to the terminal device.
70 , outputByteBuffer :: BS.ByteString -> IO ()
81 , outputByteBuffer :: BS.ByteString -> IO ()
71− -- | Maximum number of colors supported by the context.
72− , contextColorCount :: Int
73− -- | if the cursor can be shown / hidden
82+ -- | Specifies whether the cursor can be shown / hidden.
74 , supportsCursorVisibility :: Bool
83 , supportsCursorVisibility :: Bool
75− -- | Indicates support for terminal modes for this output device
84+ -- | Indicates support for terminal modes for this output device.
76 , supportsMode :: Mode -> Bool
85 , supportsMode :: Mode -> Bool
77− -- | Enables or disables a mode (does nothing if the mode is unsupported)
86+ -- | Enables or disables a mode (does nothing if the mode is
87+ -- unsupported).
78− , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()
88+ , setMode :: Mode -> Bool -> IO ()
79− -- | Returns whether a mode is enabled
89+ -- | Returns whether a mode is enabled.
80− , getModeStatus :: forall m. MonadIO m => Mode -> m Bool
90+ , getModeStatus :: Mode -> IO Bool
81 , assumedStateRef :: IORef AssumedState
91 , assumedStateRef :: IORef AssumedState
82− -- | Acquire display access to the given region of the display.
92+ -- | Acquire display access to the given region of the display.
83− -- Currently all regions have the upper left corner of (0,0) and the lower right corner at
93+ -- Currently all regions have the upper left corner of (0,0) and
94+ -- the lower right corner at (max displayWidth providedWidth, max
84− -- (max displayWidth providedWidth, max displayHeight providedHeight)
95+ -- displayHeight providedHeight)
85− , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
96+ , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
86− -- | Ring the terminal bell if supported.
97+ -- | Ring the terminal bell if supported.
87− , ringTerminalBell :: forall m. MonadIO m => m ()
98+ , ringTerminalBell :: IO ()
88− -- | Returns whether the terminal has an audio bell feature.
99+ -- | Returns whether the terminal has an audio bell feature.
89− , supportsBell :: forall m. MonadIO m => m Bool
100+ , supportsBell :: IO Bool
101+ -- | Returns whether the terminal supports italicized text.
102+ --
103+ -- This is terminal-dependent and should make a best effort to
104+ -- determine whether this feature is supported, but even if the
105+ -- terminal advertises support (e.g. via terminfo) that might not
106+ -- be a reliable indicator of whether the feature will work as
107+ -- desired.
108+ , supportsItalics :: IO Bool
109+ -- | Returns whether the terminal supports strikethrough text.
110+ --
111+ -- This is terminal-dependent and should make a best effort to
112+ -- determine whether this feature is supported, but even if the
113+ -- terminal advertises support (e.g. via terminfo) that might not
114+ -- be a reliable indicator of whether the feature will work as
115+ -- desired.
116+ , supportsStrikethrough :: IO Bool
117+ -- | Returns how many colors the terminal supports.
118+ , outputColorMode :: ColorMode
90 }
119 }
91
120
92−displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
121+displayContext :: Output -> DisplayRegion -> IO DisplayContext
93−displayContext t = liftIO . mkDisplayContext t t
122+displayContext t = mkDisplayContext t t
94
123
95data AssumedState = AssumedState
124data AssumedState = AssumedState
96 { prevFattr :: Maybe FixedAttr
125 { prevFattr :: Maybe FixedAttr
@@ -104,67 +133,69 @@ data DisplayContext = DisplayContext
104 { contextDevice :: Output
133 { contextDevice :: Output
105 -- | Provide the bounds of the display context.
134 -- | Provide the bounds of the display context.
106 , contextRegion :: DisplayRegion
135 , contextRegion :: DisplayRegion
107− -- | sets the output position to the specified row and column. Where the number of bytes
136+ -- | Sets the output position to the specified row and column
137+ -- where the number of bytes required for the control codes can be
108− -- required for the control codes can be specified seperate from the actual byte sequence.
138+ -- specified seperate from the actual byte sequence.
109 , writeMoveCursor :: Int -> Int -> Write
139 , writeMoveCursor :: Int -> Int -> Write
110 , writeShowCursor :: Write
140 , writeShowCursor :: Write
111 , writeHideCursor :: Write
141 , writeHideCursor :: Write
112− -- | Assure the specified output attributes will be applied to all the following text until the
142+ -- Ensure that the specified output attributes will be applied to
143+ -- all the following text until the next output attribute change
113− -- next output attribute change. Where the number of bytes required for the control codes can
144+ -- where the number of bytes required for the control codes can be
114− -- be specified seperate from the actual byte sequence. The required number of bytes must be
145+ -- specified seperately from the actual byte sequence. The required
146+ -- number of bytes must be at least the maximum number of bytes
115− -- at least the maximum number of bytes required by any attribute changes. The serialization
147+ -- required by any attribute changes. The serialization equations
116− -- equations must provide the ptr to the next byte to be specified in the output buffer.
148+ -- must provide the ptr to the next byte to be specified in the
149+ -- output buffer.
117 --
150 --
118− -- The currently applied display attributes are provided as well. The Attr data type can
151+ -- The currently applied display attributes are provided as well.
152+ -- The Attr data type can specify the style or color should not be
119− -- specify the style or color should not be changed from the currently applied display
153+ -- changed from the currently applied display attributes. In order
120− -- attributes. In order to support this the currently applied display attributes are required.
154+ -- to support this the currently applied display attributes are
121− -- In addition it may be possible to optimize the state changes based off the currently applied
155+ -- required. In addition it may be possible to optimize the state
122− -- display attributes.
156+ -- changes based off the currently applied display attributes.
123− , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
157+ , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
124− -- | Reset the display attributes to the default display attributes
158+ -- | Reset the display attributes to the default display attributes.
125− , writeDefaultAttr :: Write
159+ , writeDefaultAttr :: Bool -> Write
126 , writeRowEnd :: Write
160 , writeRowEnd :: Write
127 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
128 , inlineHack :: IO ()
162 , inlineHack :: IO ()
129 }
163 }
130
164
131−-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
165+-- | All terminals serialize UTF8 text to the terminal device exactly as
166+-- serialized in memory.
132writeUtf8Text :: BS.ByteString -> Write
167writeUtf8Text :: BS.ByteString -> Write
133writeUtf8Text = writeByteString
168writeUtf8Text = writeByteString
134
169
135-- | Displays the given `Picture`.
170-- | Displays the given `Picture`.
136--
171--
137−-- 0. The image is cropped to the display size.
172+-- 1. The image is cropped to the display size.
138−--
139−-- 1. Converted into a sequence of attribute changes and text spans.
140--
173--
141−-- 2. The cursor is hidden.
174+-- 2. Converted into a sequence of attribute changes and text spans.
142--
175--
143−-- 3. Serialized to the display.
176+-- 3. The cursor is hidden.
144--
177--
145−-- 4. The cursor is then shown and positioned or kept hidden.
178+-- 4. Serialized to the display.
146--
179--
147−-- todo: specify possible IO exceptions.
180+-- 5. The cursor is then shown and positioned or kept hidden.
148−-- abstract from IO monad to a MonadIO instance.
149−outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
181+outputPicture :: DisplayContext -> Picture -> IO ()
150−outputPicture dc pic = liftIO $ do
182+outputPicture dc pic = do
183+ urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
151 as <- readIORef (assumedStateRef $ contextDevice dc)
184 as <- readIORef (assumedStateRef $ contextDevice dc)
152 let manipCursor = supportsCursorVisibility (contextDevice dc)
185 let manipCursor = supportsCursorVisibility (contextDevice dc)
153 r = contextRegion dc
186 r = contextRegion dc
154 ops = displayOpsForPic pic r
187 ops = displayOpsForPic pic r
155− initialAttr = FixedAttr defaultStyleMask Nothing Nothing
188+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
156− -- Diff the previous output against the requested output. Differences are currently on a per-row
189+ -- Diff the previous output against the requested output.
157− -- basis.
190+ -- Differences are currently on a per-row basis.
158− -- \todo handle resizes that crop the dominate directions better.
159 diffs :: [Bool] = case prevOutputOps as of
191 diffs :: [Bool] = case prevOutputOps as of
160− Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True
192+ Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
161− Just previousOps -> if effectedRegion previousOps /= effectedRegion ops
193+ Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
162 then replicate (displayOpsRows ops) True
194 then replicate (displayOpsRows ops) True
163− else zipWith (/=) (Vector.toList previousOps)
195+ else Vector.toList $ Vector.zipWith (/=) previousOps ops
164− (Vector.toList ops)
165 -- build the Write corresponding to the output image
196 -- build the Write corresponding to the output image
166 out = (if manipCursor then writeHideCursor dc else mempty)
197 out = (if manipCursor then writeHideCursor dc else mempty)
167− `mappend` writeOutputOps dc initialAttr diffs ops
198+ `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
168 `mappend`
199 `mappend`
169 (let (w,h) = contextRegion dc
200 (let (w,h) = contextRegion dc
170 clampX = max 0 . min (w-1)
201 clampX = max 0 . min (w-1)
@@ -175,9 +206,15 @@ outputPicture dc pic = liftIO $ do
175 AbsoluteCursor x y ->
206 AbsoluteCursor x y ->
176 writeShowCursor dc `mappend`
207 writeShowCursor dc `mappend`
177 writeMoveCursor dc (clampX x) (clampY y)
208 writeMoveCursor dc (clampX x) (clampY y)
209+ PositionOnly isAbs x y ->
210+ if isAbs
211+ then writeMoveCursor dc (clampX x) (clampY y)
212+ else let (ox, oy) = charToOutputPos m (clampX x, clampY y)
213+ m = cursorOutputMap ops $ picCursor pic
214+ in writeMoveCursor dc (clampX ox) (clampY oy)
178 Cursor x y ->
215 Cursor x y ->
179 let m = cursorOutputMap ops $ picCursor pic
216 let m = cursorOutputMap ops $ picCursor pic
180− (ox, oy) = charToOutputPos m (x,y)
217+ (ox, oy) = charToOutputPos m (clampX x, clampY y)
181 in writeShowCursor dc `mappend`
218 in writeShowCursor dc `mappend`
182 writeMoveCursor dc (clampX ox) (clampY oy)
219 writeMoveCursor dc (clampX ox) (clampY oy)
183 )
220 )
@@ -187,15 +224,15 @@ outputPicture dc pic = liftIO $ do
187 let as' = as { prevOutputOps = Just ops }
224 let as' = as { prevOutputOps = Just ops }
188 writeIORef (assumedStateRef $ contextDevice dc) as'
225 writeIORef (assumedStateRef $ contextDevice dc) as'
189
226
190−writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
227+writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
191−writeOutputOps dc initialAttr diffs ops =
228+writeOutputOps urlsEnabled dc initialAttr diffs ops =
192 let (_, out, _) = Vector.foldl' writeOutputOps'
229 let (_, out, _) = Vector.foldl' writeOutputOps'
193 (0, mempty, diffs)
230 (0, mempty, diffs)
194 ops
231 ops
195 in out
232 in out
196 where
233 where
197 writeOutputOps' (y, out, True : diffs') spanOps
234 writeOutputOps' (y, out, True : diffs') spanOps
198− = let spanOut = writeSpanOps dc y initialAttr spanOps
235+ = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
199 out' = out `mappend` spanOut
236 out' = out `mappend` spanOut
200 in (y+1, out', diffs')
237 in (y+1, out', diffs')
201 writeOutputOps' (y, out, False : diffs') _spanOps
238 writeOutputOps' (y, out, False : diffs') _spanOps
@@ -203,30 +240,31 @@ writeOutputOps dc initialAttr diffs ops =
203 writeOutputOps' (_y, _out, []) _spanOps
240 writeOutputOps' (_y, _out, []) _spanOps
204 = error "vty - output spans without a corresponding diff."
241 = error "vty - output spans without a corresponding diff."
205
242
206−writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
243+writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
207−writeSpanOps dc y initialAttr spanOps =
244+writeSpanOps urlsEnabled dc y initialAttr spanOps =
208 -- The first operation is to set the cursor to the start of the row
245 -- The first operation is to set the cursor to the start of the row
209− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
246+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
210 -- then the span ops are serialized in the order specified
247 -- then the span ops are serialized in the order specified
211− in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
248+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of
212 (opOut, fattr') -> (out `mappend` opOut, fattr')
249 (opOut, fattr') -> (out `mappend` opOut, fattr')
213 )
250 )
214 (start, initialAttr)
251 (start, initialAttr)
215 spanOps
252 spanOps
216
253
217−writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
254+writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
218−writeSpanOp dc (TextSpan attr _ _ str) fattr =
255+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
219 let attr' = limitAttrForDisplay (contextDevice dc) attr
256 let attr' = limitAttrForDisplay (contextDevice dc) attr
220 fattr' = fixDisplayAttr fattr attr'
257 fattr' = fixDisplayAttr fattr attr'
221 diffs = displayAttrDiffs fattr fattr'
258 diffs = displayAttrDiffs fattr fattr'
222− out = writeSetAttr dc fattr attr' diffs
259+ out = writeSetAttr dc urlsEnabled fattr attr' diffs
223 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
260 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
224 in (out, fattr')
261 in (out, fattr')
225−writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
262+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
226−writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
263+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
227
264
228−-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
265+-- | The cursor position is given in X,Y character offsets. Due to
229−-- needs to be translated to column, row positions.
266+-- multi-column characters this needs to be translated to column, row
267+-- positions.
230data CursorOutputMap = CursorOutputMap
268data CursorOutputMap = CursorOutputMap
231 { charToOutputPos :: (Int, Int) -> (Int, Int)
269 { charToOutputPos :: (Int, Int) -> (Int, Int)
232 }
270 }
@@ -261,8 +299,8 @@ cursorColumnOffset ops cx cy =
261 cursorRowOps
299 cursorRowOps
262 in outOffset
300 in outOffset
263
301
264−-- | Not all terminals support all display attributes. This filters a display attribute to what the
302+-- | Not all terminals support all display attributes. This filters a
265−-- given terminal can display.
303+-- display attribute to what the given terminal can display.
266limitAttrForDisplay :: Output -> Attr -> Attr
304limitAttrForDisplay :: Output -> Attr -> Attr
267limitAttrForDisplay t attr
305limitAttrForDisplay t attr
268 = attr { attrForeColor = clampColor $ attrForeColor attr
306 = attr { attrForeColor = clampColor $ attrForeColor attr
@@ -271,17 +309,23 @@ limitAttrForDisplay t attr
271 where
309 where
272 clampColor Default = Default
310 clampColor Default = Default
273 clampColor KeepCurrent = KeepCurrent
311 clampColor KeepCurrent = KeepCurrent
274− clampColor (SetTo c) = clampColor' c
312+ clampColor (SetTo c) = clampColor' (outputColorMode t) c
313+
275− clampColor' (ISOColor v)
314+ clampColor' NoColor _ = Default
276− | contextColorCount t < 8 = Default
315+
316+ clampColor' ColorMode8 (ISOColor v)
277− | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
317+ | v >= 8 = SetTo $ ISOColor (v - 8)
278− | otherwise = SetTo $ ISOColor v
318+ | otherwise = SetTo $ ISOColor v
279− clampColor' (Color240 v)
319+ clampColor' ColorMode8 _ = Default
280− -- TODO: Choose closes ISO color?
320+
281− | contextColorCount t < 8 = Default
321+ clampColor' ColorMode16 c@(ISOColor _) = SetTo c
282− | contextColorCount t < 16 = Default
322+ clampColor' ColorMode16 _ = Default
283− | contextColorCount t <= 256 = SetTo $ Color240 v
323+
324+ clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c
325+ clampColor' (ColorMode240 colorCount) c@(Color240 n)
326+ | n <= colorCount = SetTo c
284− | otherwise
327+ | otherwise = Default
285− = let p :: Double = fromIntegral v / 240.0
328+ clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
286− v' = floor $ p * (fromIntegral $ contextColorCount t)
329+ clampColor' colorMode (color240 r g b)
287− in SetTo $ Color240 v'
330+
331+ clampColor' FullColor c = SetTo c
src/Graphics/Vty/Output/Mock.hs+40−25
@@ -1,13 +1,17 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4−-- | This provides a mock terminal implementation that is nice for testing. This transforms the
4+-- | This provides a mock terminal implementation that is nice for
5−-- output operations to visible characters. Which is nice for some tests.
5+-- testing. This transforms the output operations to visible characters
6+-- which is useful for testing.
6−module Graphics.Vty.Output.Mock ( MockData, mockTerminal )
7+module Graphics.Vty.Output.Mock
8+ ( MockData
9+ , mockTerminal
10+ )
7− where
11+where
8−
9−import Graphics.Vty.Prelude
10
12
13+import Graphics.Vty.Image (DisplayRegion)
14+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
11import Graphics.Vty.Output.Interface
15import Graphics.Vty.Output.Interface
12
16
13import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
@@ -20,18 +24,20 @@ import qualified Data.String.UTF8 as UTF8
20
24
21type MockData = IORef (UTF8.UTF8 BS.ByteString)
25type MockData = IORef (UTF8.UTF8 BS.ByteString)
22
26
23−-- | The mock display terminal produces a string representation of the requested picture. There is
27+-- | The mock display terminal produces a string representation of
28+-- the requested picture. There is *not* an isomorphism between the
24−-- *not* an isomorphism between the string representation and the picture. The string
29+-- string representation and the picture. The string representation is
25−-- representation is a simplification of the picture that is only useful in debugging VTY without
30+-- a simplification of the picture that is only useful in debugging VTY
26−-- considering terminal specific issues.
31+-- without considering terminal specific issues.
27--
32--
28−-- The mock implementation is useful in manually determining if the sequence of terminal operations
33+-- The mock implementation is useful in manually determining if the
34+-- sequence of terminal operations matches the expected sequence. The
29−-- matches the expected sequence. So requirement of the produced representation is simplicity in
35+-- requirement of the produced representation is simplicity in parsing
30−-- parsing the text representation and determining how the picture was mapped to terminal
36+-- the text representation and determining how the picture was mapped to
31−-- operations.
37+-- terminal operations.
32--
38--
33−-- The string representation is a sequence of identifiers where each identifier is the name of an
39+-- The string representation is a sequence of identifiers where each
34−-- operation in the algebra.
40+-- identifier is the name of an operation in the algebra.
35mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)
41mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)
36mockTerminal r = liftIO $ do
42mockTerminal r = liftIO $ do
37 outRef <- newIORef undefined
43 outRef <- newIORef undefined
@@ -43,30 +49,39 @@ mockTerminal r = liftIO $ do
43 , releaseDisplay = return ()
49 , releaseDisplay = return ()
44 , ringTerminalBell = return ()
50 , ringTerminalBell = return ()
45 , supportsBell = return False
51 , supportsBell = return False
52+ , supportsItalics = return False
53+ , supportsStrikethrough = return False
54+ , setDisplayBounds = const $ return ()
46 , displayBounds = return r
55 , displayBounds = return r
47 , outputByteBuffer = \bytes -> do
56 , outputByteBuffer = \bytes -> do
48 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
57 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
49 writeIORef outRef $ UTF8.fromRep bytes
58 writeIORef outRef $ UTF8.fromRep bytes
50− , contextColorCount = 16
51 , supportsCursorVisibility = True
59 , supportsCursorVisibility = True
52 , supportsMode = const False
60 , supportsMode = const False
53 , setMode = const $ const $ return ()
61 , setMode = const $ const $ return ()
54 , getModeStatus = const $ return False
62 , getModeStatus = const $ return False
55 , assumedStateRef = newAssumedStateRef
63 , assumedStateRef = newAssumedStateRef
64+ , outputColorMode = ColorMode16
56 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
65 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
57 { contextRegion = rActual
66 { contextRegion = rActual
58 , contextDevice = tActual
67 , contextDevice = tActual
59− -- A cursor move is always visualized as the single character 'M'
68+ -- A cursor move is always visualized as the single
69+ -- character 'M'
60 , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'
70 , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'
61− -- Show cursor is always visualized as the single character 'S'
71+ -- Show cursor is always visualized as the single
72+ -- character 'S'
62 , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S'
73 , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S'
63− -- Hide cursor is always visualized as the single character 'H'
74+ -- Hide cursor is always visualized as the single
75+ -- character 'H'
64 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
76 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
65− -- An attr change is always visualized as the single character 'A'
77+ -- An attr change is always visualized as the single
78+ -- character 'A'
66− , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
79+ , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
67− -- default attr is always visualized as the single character 'D'
80+ -- default attr is always visualized as the single
81+ -- character 'D'
68− , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'
82+ , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
69− -- row end is always visualized as the single character 'E'
83+ -- row end is always visualized as the single character
84+ -- 'E'
70 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
85 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
71 , inlineHack = return ()
86 , inlineHack = return ()
72 }
87 }
src/Graphics/Vty/Output/TerminfoBased.hs+274−144
@@ -1,42 +1,40 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE CPP #-}
3{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
5{-# CFILES gwinsz.c #-}
5{-# CFILES gwinsz.c #-}
6
6
7−#ifndef MIN_VERSION_base
8−#defined MIN_VERSION_base(x,y,z) 1
9−#endif
10−
11−-- | Terminfo based terminal handling.
7+-- | Terminfo-based terminal output driver.
12−--
13−-- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I
14−-- have easy access to then color support is entirely based of the docs. Probably with some
15−-- assumptions mixed in.
16--
8--
17-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
18−module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )
10+module Graphics.Vty.Output.TerminfoBased
11+ ( reserveTerminal
12+ , setWindowSize
13+ )
19− where
14+where
20−
15+
21−import Graphics.Vty.Prelude
16+import Control.Monad (when)
22−
17+import Data.Bits (shiftL, (.&.))
18+import qualified Data.ByteString as BS
23import Data.ByteString.Internal (toForeignPtr)
19import Data.ByteString.Internal (toForeignPtr)
24import Data.Terminfo.Parse
20import Data.Terminfo.Parse
25import Data.Terminfo.Eval
21import Data.Terminfo.Eval
26
22
27import Graphics.Vty.Attributes
23import Graphics.Vty.Attributes
24+import Graphics.Vty.Image (DisplayRegion)
28import Graphics.Vty.DisplayAttributes
25import Graphics.Vty.DisplayAttributes
29import Graphics.Vty.Output.Interface
26import Graphics.Vty.Output.Interface
30
27
31−import Blaze.ByteString.Builder (Write, writeToByteString)
28+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
32
29
33−import Control.Monad.Trans
34−
35−import Data.Bits ((.&.))
36import Data.IORef
30import Data.IORef
37import Data.Maybe (isJust, isNothing, fromJust)
31import Data.Maybe (isJust, isNothing, fromJust)
38import Data.Word
32import Data.Word
39
33
34+#if !MIN_VERSION_base(4,8,0)
35+import Data.Foldable (foldMap)
36+#endif
37+
40import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.C.Types ( CInt(..), CLong(..) )
41import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.ForeignPtr (withForeignPtr)
42import Foreign.Ptr (Ptr, plusPtr)
40import Foreign.Ptr (Ptr, plusPtr)
@@ -45,18 +43,12 @@ import qualified System.Console.Terminfo as Terminfo
45import System.Posix.IO (fdWriteBuf)
43import System.Posix.IO (fdWriteBuf)
46import System.Posix.Types (Fd(..))
44import System.Posix.Types (Fd(..))
47
45
48−#if !(MIN_VERSION_base(4,8,0))
49−import Data.Foldable (foldMap)
50−import Data.Monoid
51−#endif
52−
53data TerminfoCaps = TerminfoCaps
46data TerminfoCaps = TerminfoCaps
54 { smcup :: Maybe CapExpression
47 { smcup :: Maybe CapExpression
55 , rmcup :: Maybe CapExpression
48 , rmcup :: Maybe CapExpression
56 , cup :: CapExpression
49 , cup :: CapExpression
57 , cnorm :: Maybe CapExpression
50 , cnorm :: Maybe CapExpression
58 , civis :: Maybe CapExpression
51 , civis :: Maybe CapExpression
59− , supportsNoColors :: Bool
60 , useAltColorMap :: Bool
52 , useAltColorMap :: Bool
61 , setForeColor :: CapExpression
53 , setForeColor :: CapExpression
62 , setBackColor :: CapExpression
54 , setBackColor :: CapExpression
@@ -71,6 +63,10 @@ data DisplayAttrCaps = DisplayAttrCaps
71 { setAttrStates :: Maybe CapExpression
63 { setAttrStates :: Maybe CapExpression
72 , enterStandout :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
73 , exitStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
66+ , enterItalic :: Maybe CapExpression
67+ , exitItalic :: Maybe CapExpression
68+ , enterStrikethrough :: Maybe CapExpression
69+ , exitStrikethrough :: Maybe CapExpression
74 , enterUnderline :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
75 , exitUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
76 , enterReverseVideo :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
@@ -78,8 +74,10 @@ data DisplayAttrCaps = DisplayAttrCaps
78 , enterBoldMode :: Maybe CapExpression
74 , enterBoldMode :: Maybe CapExpression
79 }
75 }
80
76
77+-- kinda like:
81−-- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422
78+-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
82−-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried.
79+-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
80+-- the write will be retried.
83fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
81fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
84fdWriteAll outFd ptr len count
82fdWriteAll outFd ptr len count
85 | len < 0 = fail "fdWriteAll: len is less than 0"
83 | len < 0 = fail "fdWriteAll: len is less than 0"
@@ -95,71 +93,95 @@ sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
95sendCapToTerminal t cap capParams = do
93sendCapToTerminal t cap capParams = do
96 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
94 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
97
95
96+-- | Constructs an output driver that uses terminfo for all control
98−{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
97+-- codes. While this should provide the most compatible terminal,
99− - terminfo does not support some features that would increase efficiency and improve compatibility:
98+-- terminfo does not support some features that would increase
100− -
99+-- efficiency and improve compatibility:
100+--
101− - * determine the character encoding supported by the terminal. Should this be taken from the LANG
101+-- * determining the character encoding supported by the terminal.
102− - environment variable?
102+-- Should this be taken from the LANG environment variable?
103− -
103+--
104− - * Provide independent string capabilities for all display attributes.
104+-- * Providing independent string capabilities for all display
105− -
105+-- attributes.
106− - todo: Some display attributes like underline and bold have independent string capabilities that
107− - should be used instead of the generic "sgr" string capability.
108− -}
109−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
106+reserveTerminal :: String -> Fd -> ColorMode -> IO Output
110−reserveTerminal termName outFd = liftIO $ do
107+reserveTerminal termName outFd colorMode = do
111 ti <- Terminfo.setupTerm termName
108 ti <- Terminfo.setupTerm termName
112 -- assumes set foreground always implies set background exists.
109 -- assumes set foreground always implies set background exists.
113− -- if set foreground is not set then all color changing style attributes are filtered.
110+ -- if set foreground is not set then all color changing style
111+ -- attributes are filtered.
114 msetaf <- probeCap ti "setaf"
112 msetaf <- probeCap ti "setaf"
115 msetf <- probeCap ti "setf"
113 msetf <- probeCap ti "setf"
116− let (noColors, useAlt, setForeCap)
114+ let (useAlt, setForeCap)
117 = case msetaf of
115 = case msetaf of
118− Just setaf -> (False, False, setaf)
116+ Just setaf -> (False, setaf)
119 Nothing -> case msetf of
117 Nothing -> case msetf of
120− Just setf -> (False, True, setf)
118+ Just setf -> (True, setf)
121− Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
119+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
122 msetab <- probeCap ti "setab"
120 msetab <- probeCap ti "setab"
123 msetb <- probeCap ti "setb"
121 msetb <- probeCap ti "setb"
124− let set_back_cap
122+ let setBackCap
125 = case msetab of
123 = case msetab of
124+ Just setab -> setab
126 Nothing -> case msetb of
125 Nothing -> case msetb of
127 Just setb -> setb
126 Just setb -> setb
128 Nothing -> error $ "no back color support for terminal " ++ termName
127 Nothing -> error $ "no back color support for terminal " ++ termName
129− Just setab -> setab
128+
129+ hyperlinkModeStatus <- newIORef False
130+ newAssumedStateRef <- newIORef initialAssumedState
131+
132+ let terminfoSetMode m newStatus = do
133+ curStatus <- terminfoModeStatus m
134+ when (newStatus /= curStatus) $
135+ case m of
136+ Hyperlink -> do
137+ writeIORef hyperlinkModeStatus newStatus
138+ writeIORef newAssumedStateRef initialAssumedState
139+ _ -> return ()
140+ terminfoModeStatus m =
141+ case m of
142+ Hyperlink -> readIORef hyperlinkModeStatus
143+ _ -> return False
144+ terminfoModeSupported Hyperlink = True
145+ terminfoModeSupported _ = False
146+
130 terminfoCaps <- pure TerminfoCaps
147 terminfoCaps <- pure TerminfoCaps
131 <*> probeCap ti "smcup"
148 <*> probeCap ti "smcup"
132 <*> probeCap ti "rmcup"
149 <*> probeCap ti "rmcup"
133 <*> requireCap ti "cup"
150 <*> requireCap ti "cup"
134 <*> probeCap ti "cnorm"
151 <*> probeCap ti "cnorm"
135 <*> probeCap ti "civis"
152 <*> probeCap ti "civis"
136− <*> pure noColors
137 <*> pure useAlt
153 <*> pure useAlt
138 <*> pure setForeCap
154 <*> pure setForeCap
139− <*> pure set_back_cap
155+ <*> pure setBackCap
140 <*> requireCap ti "sgr0"
156 <*> requireCap ti "sgr0"
141 <*> requireCap ti "clear"
157 <*> requireCap ti "clear"
142 <*> requireCap ti "el"
158 <*> requireCap ti "el"
143 <*> currentDisplayAttrCaps ti
159 <*> currentDisplayAttrCaps ti
144 <*> probeCap ti "bel"
160 <*> probeCap ti "bel"
145− newAssumedStateRef <- newIORef initialAssumedState
146 let t = Output
161 let t = Output
147 { terminalID = termName
162 { terminalID = termName
148− , releaseTerminal = liftIO $ do
163+ , releaseTerminal = do
149 sendCap setDefaultAttr []
164 sendCap setDefaultAttr []
150 maybeSendCap cnorm []
165 maybeSendCap cnorm []
151 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
166 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
167+ , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) &&
168+ (isJust $ exitItalic (displayAttrCaps terminfoCaps))
169+ , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
170+ (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
152− , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
171+ , ringTerminalBell = maybeSendCap ringBellAudio []
153− , reserveDisplay = liftIO $ do
172+ , reserveDisplay = do
154− -- If there is no support for smcup: Clear the screen and then move the mouse to the
173+ -- If there is no support for smcup: Clear the screen
174+ -- and then move the mouse to the home position to
155− -- home position to approximate the behavior.
175+ -- approximate the behavior.
156 maybeSendCap smcup []
176 maybeSendCap smcup []
157 sendCap clearScreen []
177 sendCap clearScreen []
158− , releaseDisplay = liftIO $ do
178+ , releaseDisplay = do
159 maybeSendCap rmcup []
179 maybeSendCap rmcup []
160 maybeSendCap cnorm []
180 maybeSendCap cnorm []
181+ , setDisplayBounds = \(w, h) ->
182+ setWindowSize outFd (w, h)
161 , displayBounds = do
183 , displayBounds = do
162− rawSize <- liftIO $ getWindowSize outFd
184+ rawSize <- getWindowSize outFd
163 case rawSize of
185 case rawSize of
164 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
186 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
165 | otherwise -> return (w,h)
187 | otherwise -> return (w,h)
@@ -170,51 +192,48 @@ reserveTerminal termName outFd = liftIO $ do
170 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
171 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
172 ++ " Please report this bug to vty project."
194 ++ " Please report this bug to vty project."
173− , contextColorCount
174− = case supportsNoColors terminfoCaps of
175− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
176− Nothing -> 8
177− Just v -> toEnum v
178− True -> 1
179 , supportsCursorVisibility = isJust $ civis terminfoCaps
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
180− , supportsMode = const False
196+ , supportsMode = terminfoModeSupported
181− , setMode = const $ const $ return ()
197+ , setMode = terminfoSetMode
182− , getModeStatus = const $ return False
198+ , getModeStatus = terminfoModeStatus
183 , assumedStateRef = newAssumedStateRef
199 , assumedStateRef = newAssumedStateRef
200+ , outputColorMode = colorMode
184− -- I think fix would help assure tActual is the only reference. I was having issues
201+ -- I think fix would help assure tActual is the only
185− -- tho.
202+ -- reference. I was having issues tho.
186− , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
203+ , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
187 }
204 }
188 sendCap s = sendCapToTerminal t (s terminfoCaps)
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
189 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
190 return t
207 return t
191
208
192−requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
209+requireCap :: Terminfo.Terminal -> String -> IO CapExpression
193requireCap ti capName
210requireCap ti capName
194 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
195 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
196 Just capStr -> parseCap capStr
213 Just capStr -> parseCap capStr
197
214
198−probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
215+probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
199probeCap ti capName
216probeCap ti capName
200 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
201 Nothing -> return Nothing
218 Nothing -> return Nothing
202 Just capStr -> Just <$> parseCap capStr
219 Just capStr -> Just <$> parseCap capStr
203
220
204−parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
221+parseCap :: String -> IO CapExpression
205parseCap capStr = do
222parseCap capStr = do
206 case parseCapExpression capStr of
223 case parseCapExpression capStr of
207 Left e -> fail $ show e
224 Left e -> fail $ show e
208 Right cap -> return cap
225 Right cap -> return cap
209
226
210−currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
227+currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
211− => Terminfo.Terminal
212− -> m DisplayAttrCaps
213currentDisplayAttrCaps ti
228currentDisplayAttrCaps ti
214 = pure DisplayAttrCaps
229 = pure DisplayAttrCaps
215 <*> probeCap ti "sgr"
230 <*> probeCap ti "sgr"
216 <*> probeCap ti "smso"
231 <*> probeCap ti "smso"
217 <*> probeCap ti "rmso"
232 <*> probeCap ti "rmso"
233+ <*> probeCap ti "sitm"
234+ <*> probeCap ti "ritm"
235+ <*> probeCap ti "smxx"
236+ <*> probeCap ti "rmxx"
218 <*> probeCap ti "smul"
237 <*> probeCap ti "smul"
219 <*> probeCap ti "rmul"
238 <*> probeCap ti "rmul"
220 <*> probeCap ti "rev"
239 <*> probeCap ti "rev"
@@ -228,6 +247,13 @@ getWindowSize fd = do
228 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
229 return (fromIntegral b, fromIntegral a)
248 return (fromIntegral b, fromIntegral a)
230
249
250+foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO ()
251+
252+setWindowSize :: Fd -> (Int, Int) -> IO ()
253+setWindowSize fd (w, h) = do
254+ let val = (h `shiftL` 16) + w
255+ c_setWindowSize fd $ fromIntegral val
256+
231terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
232terminfoDisplayContext tActual terminfoCaps r = return dc
258terminfoDisplayContext tActual terminfoCaps r = return dc
233 where dc = DisplayContext
259 where dc = DisplayContext
@@ -241,15 +267,36 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
241 Nothing -> error "this terminal does not support hide cursor"
267 Nothing -> error "this terminal does not support hide cursor"
242 Just c -> writeCapExpr c []
268 Just c -> writeCapExpr c []
243 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270+ , writeDefaultAttr = \urlsEnabled ->
244− , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
271+ writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
272+ (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
273+ (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274+ Just cap -> writeCapExpr cap []
275+ Nothing -> mempty
276+ )
245 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
246 , inlineHack = return ()
278 , inlineHack = return ()
247 }
279 }
248
280
281+-- | Write the escape sequences that are used in some terminals to
282+-- include embedded hyperlinks. As of yet, this information isn't
283+-- included in termcap or terminfo, so this writes them directly
284+-- instead of looking up the appropriate capabilities.
285+writeURLEscapes :: URLDiff -> Write
286+writeURLEscapes (LinkTo url) =
287+ foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`
288+ foldMap writeStorable (BS.unpack url) `mappend`
289+ writeStorable (0x07 :: Word8)
290+writeURLEscapes EndLink =
291+ foldMap writeStorable (BS.unpack "\x1b]8;;\a")
292+writeURLEscapes NoLinkChange =
293+ mempty
294+
249-- | Portably setting the display attributes is a giant pain in the ass.
295-- | Portably setting the display attributes is a giant pain in the ass.
250--
296--
251−-- If the terminal supports the sgr capability (which sets the on/off state of each style
297+-- If the terminal supports the sgr capability (which sets the on/off
298+-- state of each style directly; and, for no good reason, resets the
252−-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
299+-- colors to the default) this procedure is used:
253--
300--
254-- 0. set the style attributes. This resets the fore and back color.
301-- 0. set the style attributes. This resets the fore and back color.
255--
302--
@@ -257,104 +304,164 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
257--
304--
258-- 2. likewise with the background color
305-- 2. likewise with the background color
259--
306--
260−-- If the terminal does not support the sgr cap then:
307+-- If the terminal does not support the sgr cap then: if there is a
261−-- if there is a change from an applied color to the default (in either the fore or back color)
308+-- change from an applied color to the default (in either the fore or
262−-- then:
309+-- back color) then:
263--
310--
264−-- 0. reset all display attributes (sgr0)
311+-- 0. reset all display attributes (sgr0)
265--
312--
266−-- 1. enter required style modes
313+-- 1. enter required style modes
267--
314--
268−-- 2. set the fore color if required
315+-- 2. set the fore color if required
269--
316--
270−-- 3. set the back color if required
317+-- 3. set the back color if required
271--
318--
272−-- Entering the required style modes could require a reset of the display attributes. If this is
319+-- Entering the required style modes could require a reset of the
320+-- display attributes. If this is the case then the back and fore colors
273−-- the case then the back and fore colors always need to be set if not default.
321+-- always need to be set if not default.
274--
322--
275-- This equation implements the above logic.
323-- This equation implements the above logic.
276--
324--
277−-- \todo This assumes the removal of color changes in the display attributes is done as expected
325+-- Note that this assumes the removal of color changes in the
326+-- display attributes is done as expected with noColors == True. See
278−-- with noColors == True. See `limitAttrForDisplay`
327+-- `limitAttrForDisplay`.
279--
328--
280−-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
329+-- Note that this optimizes for fewer state changes followed by fewer
281−-- haven't measured this or even examined terminal implementations. *shrug*
330+-- bytes.
282−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
331+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
283−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
332+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
284− case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
333+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
285− -- The only way to reset either color, portably, to the default is to use either the set
334+ -- The only way to reset either color, portably, to the default
286− -- state capability or the set default capability.
335+ -- is to use either the set state capability or the set default
336+ -- capability.
287− True -> do
337+ True -> do
288 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
289− (fixedStyle attr )
339+ (fixedStyle attr)
290 (styleToApplySeq $ fixedStyle attr) of
340 (styleToApplySeq $ fixedStyle attr) of
291 -- only way to reset a color to the defaults
341 -- only way to reset a color to the defaults
292− EnterExitSeq caps -> writeDefaultAttr dc
342+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
293 `mappend`
343 `mappend`
294 foldMap (\cap -> writeCapExpr cap []) caps
344 foldMap (\cap -> writeCapExpr cap []) caps
295 `mappend`
345 `mappend`
296 setColors
346 setColors
297 -- implicitly resets the colors to the defaults
347 -- implicitly resets the colors to the defaults
298 SetState state -> writeCapExpr (fromJust $ setAttrStates
348 SetState state -> writeCapExpr (fromJust $ setAttrStates
299− $ displayAttrCaps
349+ $ displayAttrCaps terminfoCaps
300− $ terminfoCaps
301 )
350 )
302 (sgrArgsForState state)
351 (sgrArgsForState state)
303− `mappend`
352+ `mappend` setItalics
353+ `mappend` setStrikethrough
304− setColors
354+ `mappend` setColors
305− -- Otherwise the display colors are not changing or changing between two non-default
355+ -- Otherwise the display colors are not changing or changing
306− -- points.
356+ -- between two non-default points.
307 False -> do
357 False -> do
308− -- Still, it could be the case that the change in display attributes requires the
358+ -- Still, it could be the case that the change in display
359+ -- attributes requires the colors to be reset because the
309− -- colors to be reset because the required capability was not available.
360+ -- required capability was not available.
310 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
361 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
311 (fixedStyle attr)
362 (fixedStyle attr)
312 (styleDiffs diffs) of
363 (styleDiffs diffs) of
313− -- Really, if terminals were re-implemented with modern concepts instead of bowing
364+ -- Really, if terminals were re-implemented with modern
365+ -- concepts instead of bowing down to 40 yr old dumb
314− -- down to 40 yr old dumb terminal requirements this would be the only case ever
366+ -- terminal requirements this would be the only case
315− -- reached! Changes the style and color states according to the differences with
367+ -- ever reached! Changes the style and color states
368+ -- according to the differences with the currently
316− -- the currently applied states.
369+ -- applied states.
317 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
318 `mappend`
371 `mappend`
319− writeColorDiff setForeColor (foreColorDiff diffs)
372+ writeColorDiff Foreground (foreColorDiff diffs)
320 `mappend`
373 `mappend`
321− writeColorDiff setBackColor (backColorDiff diffs)
374+ writeColorDiff Background (backColorDiff diffs)
322 -- implicitly resets the colors to the defaults
375 -- implicitly resets the colors to the defaults
323 SetState state -> writeCapExpr (fromJust $ setAttrStates
376 SetState state -> writeCapExpr (fromJust $ setAttrStates
324 $ displayAttrCaps terminfoCaps
377 $ displayAttrCaps terminfoCaps
325 )
378 )
326 (sgrArgsForState state)
379 (sgrArgsForState state)
380+ `mappend` setItalics
381+ `mappend` setStrikethrough
327 `mappend` setColors
382 `mappend` setColors
328 where
383 where
384+ urlAttrs True = writeURLEscapes (urlDiff diffs)
385+ urlAttrs False = mempty
329 colorMap = case useAltColorMap terminfoCaps of
386 colorMap = case useAltColorMap terminfoCaps of
330 False -> ansiColorIndex
387 False -> ansiColorIndex
331 True -> altColorIndex
388 True -> altColorIndex
332 attr = fixDisplayAttr prevAttr reqAttr
389 attr = fixDisplayAttr prevAttr reqAttr
390+
391+ -- italics can't be set via SGR, so here we manually
392+ -- apply the enter and exit sequences as needed after
393+ -- changing the SGR
394+ setItalics
395+ | hasStyle (fixedStyle attr) italic
396+ , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
397+ = writeCapExpr sitm []
398+ | otherwise = mempty
399+ setStrikethrough
400+ | hasStyle (fixedStyle attr) strikethrough
401+ , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)
402+ = writeCapExpr smxx []
403+ | otherwise = mempty
333 setColors =
404 setColors =
334 (case fixedForeColor attr of
405 (case fixedForeColor attr of
335− Just c -> writeCapExpr (setForeColor terminfoCaps)
406+ Just c -> writeColor Foreground c
336− [toEnum $ colorMap c]
337 Nothing -> mempty)
407 Nothing -> mempty)
338 `mappend`
408 `mappend`
339 (case fixedBackColor attr of
409 (case fixedBackColor attr of
340− Just c -> writeCapExpr (setBackColor terminfoCaps)
410+ Just c -> writeColor Background c
341− [toEnum $ colorMap c]
342 Nothing -> mempty)
411 Nothing -> mempty)
343− writeColorDiff _f NoColorChange
412+ writeColorDiff _side NoColorChange
344 = mempty
413 = mempty
345− writeColorDiff _f ColorToDefault
414+ writeColorDiff _side ColorToDefault
346 = error "ColorToDefault is not a possible case for applyColorDiffs"
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
347− writeColorDiff f (SetColor c)
416+ writeColorDiff side (SetColor c)
417+ = writeColor side c
418+
419+ writeColor side (RGBColor r g b) =
420+ case outputColorMode (contextDevice dc) of
421+ FullColor ->
422+ hardcodeColor side (r, g, b)
423+ _ ->
424+ error "clampColor should remove rgb colors in standard mode"
425+ writeColor side c =
348− = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
426+ writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]
349−
427+
428+-- a color can either be in the foreground or the background
429+data ColorSide = Foreground | Background
430+
431+-- get the capability for drawing a color on a specific side
432+setSideColor :: ColorSide -> TerminfoCaps -> CapExpression
433+setSideColor Foreground = setForeColor
434+setSideColor Background = setBackColor
435+
436+hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write
437+hardcodeColor side (r, g, b) =
438+ -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m"
439+ mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter
440+ , writeColor r, delimiter, writeColor g, delimiter, writeColor b
441+ , writeChar 'm']
442+ where
443+ writeChar = writeWord8 . fromIntegral . fromEnum
444+ writeStr = mconcat . map writeChar
445+ writeColor = writeStr . show
446+ delimiter = writeChar ';'
447+ -- 38/48 are used to set whether we should write to the
448+ -- foreground/background. I really don't want to know why.
449+ sideCode = case side of
450+ Foreground -> writeStr "38"
451+ Background -> writeStr "48"
452+
350−-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
453+-- | The color table used by a terminal is a 16 color set followed by a
351−-- be supported by the terminal.
454+-- 240 color set that might not be supported by the terminal.
352--
455--
353−-- This takes a Color which clearly identifies which pallete to use and computes the index
456+-- This takes a Color which clearly identifies which palette to use and
354−-- into the full 256 color pallete.
457+-- computes the index into the full 256 color palette.
355ansiColorIndex :: Color -> Int
458ansiColorIndex :: Color -> Int
356ansiColorIndex (ISOColor v) = fromEnum v
459ansiColorIndex (ISOColor v) = fromEnum v
357ansiColorIndex (Color240 v) = 16 + fromEnum v
460ansiColorIndex (Color240 v) = 16 + fromEnum v
461+ansiColorIndex (RGBColor _ _ _) =
462+ error $ unlines [ "Attempted to create color index from rgb color."
463+ , "This is currently unsupported, and shouldn't ever happen"
464+ ]
358
465
359-- | For terminals without setaf/setab
466-- | For terminals without setaf/setab
360--
467--
@@ -371,21 +478,28 @@ altColorIndex (ISOColor 6) = 3
371altColorIndex (ISOColor 7) = 7
478altColorIndex (ISOColor 7) = 7
372altColorIndex (ISOColor v) = fromEnum v
479altColorIndex (ISOColor v) = fromEnum v
373altColorIndex (Color240 v) = 16 + fromEnum v
480altColorIndex (Color240 v) = 16 + fromEnum v
481+altColorIndex (RGBColor _ _ _) =
482+ error $ unlines [ "Attempted to create color index from rgb color."
483+ , "This is currently unsupported, and shouldn't ever happen"
484+ ]
374
485
375−{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
486+{- | The sequence of terminfo caps to apply a given style are determined
376− -
487+ - according to these rules.
377− - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
378− - the full set display attribute state capability.
379 -
488 -
380− - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
489+ - 1. The assumption is that it's preferable to use the simpler
381− - display attributes are reset to defaults then the display attribute state is set.
490+ - enter/exit mode capabilities than the full set display attribute
491+ - state capability.
382 -
492 -
383− - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
493+ - 2. If a mode is supposed to be removed but there is not an exit
494+ - capability defined then the display attributes are reset to defaults
384− - display attribute state is set if possible. Otherwise the mode is not applied.
495+ - then the display attribute state is set.
385 -
496 -
497+ - 3. If a mode is supposed to be applied but there is not an enter
386− - 4. If the display attribute state is being set then just update the arguments to that for any
498+ - capability defined then then display attribute state is set if
387− - apply/remove.
499+ - possible. Otherwise the mode is not applied.
388 -
500 -
501+ - 4. If the display attribute state is being set then just update the
502+ - arguments to that for any apply/remove.
389 -}
503 -}
390data DisplayAttrSeq
504data DisplayAttrSeq
391 = EnterExitSeq [CapExpression]
505 = EnterExitSeq [CapExpression]
@@ -394,6 +508,8 @@ data DisplayAttrSeq
394data DisplayAttrState = DisplayAttrState
508data DisplayAttrState = DisplayAttrState
395 { applyStandout :: Bool
509 { applyStandout :: Bool
396 , applyUnderline :: Bool
510 , applyUnderline :: Bool
511+ , applyItalic :: Bool
512+ , applyStrikethrough :: Bool
397 , applyReverseVideo :: Bool
513 , applyReverseVideo :: Bool
398 , applyBlink :: Bool
514 , applyBlink :: Bool
399 , applyDim :: Bool
515 , applyDim :: Bool
@@ -415,19 +531,25 @@ sgrArgsForState attrState = map (\b -> if b then 1 else 0)
415
531
416reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
532reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
417reqDisplayCapSeqFor caps s diffs
533reqDisplayCapSeqFor caps s diffs
418− -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
534+ -- if the state transition implied by any diff cannot be supported
535+ -- with an enter/exit mode cap then either the state needs to be set
419− -- then either the state needs to be set or the attribute change ignored.
536+ -- or the attribute change ignored.
420 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
537 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
421 -- If all the diffs have an enter-exit cap then just use those
538 -- If all the diffs have an enter-exit cap then just use those
422 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
539 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
423− -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
540+ -- If not all the diffs have an enter-exit cap and there is no
424− -- all unsupported diffs and just apply the rest
541+ -- set state cap then filter out all unsupported diffs and just
542+ -- apply the rest
425 ( True, False ) -> EnterExitSeq $ map enterExitCap
543 ( True, False ) -> EnterExitSeq $ map enterExitCap
426 $ filter (not . noEnterExitCap) diffs
544 $ filter (not . noEnterExitCap) diffs
427− -- if not all the diffs have an enter-exit can and there is a set state cap then just use
545+ -- if not all the diffs have an enter-exit can and there is a
428− -- the set state cap.
546+ -- set state cap then just use the set state cap.
429 ( True, True ) -> SetState $ stateForStyle s
547 ( True, True ) -> SetState $ stateForStyle s
430 where
548 where
549+ noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps
550+ noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps
551+ noEnterExitCap ApplyItalic = isNothing $ enterItalic caps
552+ noEnterExitCap RemoveItalic = isNothing $ exitItalic caps
431 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
432 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
433 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -440,6 +562,10 @@ reqDisplayCapSeqFor caps s diffs
440 noEnterExitCap RemoveDim = True
562 noEnterExitCap RemoveDim = True
441 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
442 noEnterExitCap RemoveBold = True
564 noEnterExitCap RemoveBold = True
565+ enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps
566+ enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps
567+ enterExitCap ApplyItalic = fromJust $ enterItalic caps
568+ enterExitCap RemoveItalic = fromJust $ exitItalic caps
443 enterExitCap ApplyStandout = fromJust $ enterStandout caps
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
444 enterExitCap RemoveStandout = fromJust $ exitStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
445 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -453,6 +579,8 @@ stateForStyle :: Style -> DisplayAttrState
453stateForStyle s = DisplayAttrState
579stateForStyle s = DisplayAttrState
454 { applyStandout = isStyleSet standout
580 { applyStandout = isStyleSet standout
455 , applyUnderline = isStyleSet underline
581 , applyUnderline = isStyleSet underline
582+ , applyItalic = isStyleSet italic
583+ , applyStrikethrough = isStyleSet strikethrough
456 , applyReverseVideo = isStyleSet reverseVideo
584 , applyReverseVideo = isStyleSet reverseVideo
457 , applyBlink = isStyleSet blink
585 , applyBlink = isStyleSet blink
458 , applyDim = isStyleSet dim
586 , applyDim = isStyleSet dim
@@ -464,10 +592,12 @@ styleToApplySeq :: Style -> [StyleStateChange]
464styleToApplySeq s = concat
592styleToApplySeq s = concat
465 [ applyIfRequired ApplyStandout standout
593 [ applyIfRequired ApplyStandout standout
466 , applyIfRequired ApplyUnderline underline
594 , applyIfRequired ApplyUnderline underline
595+ , applyIfRequired ApplyItalic italic
596+ , applyIfRequired ApplyStrikethrough strikethrough
467 , applyIfRequired ApplyReverseVideo reverseVideo
597 , applyIfRequired ApplyReverseVideo reverseVideo
468 , applyIfRequired ApplyBlink blink
598 , applyIfRequired ApplyBlink blink
469 , applyIfRequired ApplyDim dim
599 , applyIfRequired ApplyDim dim
470− , applyIfRequired ApplyBlink bold
600+ , applyIfRequired ApplyBold bold
471 ]
601 ]
472 where
602 where
473 applyIfRequired op flag
603 applyIfRequired op flag
src/Graphics/Vty/Output/XTermColor.hs+53−36
@@ -1,56 +1,72 @@
1−{-# LANGUAGE CPP #-}
1+{-# Language CPP #-}
2−
3−#ifndef MIN_VERSION_base
4−#defined MIN_VERSION_base(x,y,z) 1
5−#endif
6−
7-- Copyright 2009-2010 Corey O'Connor
2-- Copyright 2009-2010 Corey O'Connor
3+-- | Xterm output driver. This uses the Terminfo driver with some
4+-- extensions for Xterm.
8−module Graphics.Vty.Output.XTermColor ( reserveTerminal )
5+module Graphics.Vty.Output.XTermColor
6+ ( reserveTerminal
7+ )
9− where
8+where
10
9
11import Graphics.Vty.Output.Interface
10import Graphics.Vty.Output.Interface
12import Graphics.Vty.Input.Mouse
11import Graphics.Vty.Input.Mouse
12+import Graphics.Vty.Input.Focus
13+import Graphics.Vty.Attributes.Color (ColorMode)
13import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
14
15
15import Blaze.ByteString.Builder (writeToByteString)
16import Blaze.ByteString.Builder (writeToByteString)
16import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
17
18
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+import Foreign.Ptr (castPtr)
22+
18import Control.Monad (void, when)
23import Control.Monad (void, when)
19import Control.Monad.Trans
24import Control.Monad.Trans
25+import Data.Char (toLower)
20import Data.IORef
26import Data.IORef
21
27
22−import System.Posix.IO (fdWrite)
28+import System.Posix.IO (fdWriteBuf)
23−import System.Posix.Types (Fd)
29+import System.Posix.Types (ByteCount, Fd)
24import System.Posix.Env (getEnv)
30import System.Posix.Env (getEnv)
25
31
26−#if !(MIN_VERSION_base(4,8,0))
27−import Control.Applicative
28−import Data.Foldable (foldMap)
29−#endif
30−
31import Data.List (isInfixOf)
32import Data.List (isInfixOf)
32import Data.Maybe (catMaybes)
33import Data.Maybe (catMaybes)
34+
35+#if !MIN_VERSION_base(4,11,0)
33import Data.Monoid ((<>))
36import Data.Monoid ((<>))
37+#endif
38+
39+-- | Write a 'ByteString' to an 'Fd'.
40+fdWrite :: Fd -> ByteString -> IO ByteCount
41+fdWrite fd s =
42+ BS8.useAsCStringLen s $ \(buf,len) -> do
43+ fdWriteBuf fd (castPtr buf) (fromIntegral len)
34
44
35−-- | Initialize the display to UTF-8.
45+-- | Construct an Xterm output driver. Initialize the display to UTF-8.
36−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
46+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
37−reserveTerminal variant outFd = liftIO $ do
47+reserveTerminal variant outFd colorMode = liftIO $ do
38 let flushedPut = void . fdWrite outFd
48 let flushedPut = void . fdWrite outFd
39− -- If the terminal variant is xterm-color use xterm instead since, more often than not,
49+ -- If the terminal variant is xterm-color use xterm instead since,
40− -- xterm-color is broken.
50+ -- more often than not, xterm-color is broken.
41 let variant' = if variant == "xterm-color" then "xterm" else variant
51 let variant' = if variant == "xterm-color" then "xterm" else variant
42
52
43 utf8a <- utf8Active
53 utf8a <- utf8Active
44 when (not utf8a) $ flushedPut setUtf8CharSet
54 when (not utf8a) $ flushedPut setUtf8CharSet
45− t <- TerminfoBased.reserveTerminal variant' outFd
55+ t <- TerminfoBased.reserveTerminal variant' outFd colorMode
46
56
47 mouseModeStatus <- newIORef False
57 mouseModeStatus <- newIORef False
58+ focusModeStatus <- newIORef False
48 pasteModeStatus <- newIORef False
59 pasteModeStatus <- newIORef False
49
60
50 let xtermSetMode t' m newStatus = do
61 let xtermSetMode t' m newStatus = do
51 curStatus <- getModeStatus t' m
62 curStatus <- getModeStatus t' m
52 when (newStatus /= curStatus) $
63 when (newStatus /= curStatus) $
53 case m of
64 case m of
65+ Focus -> liftIO $ do
66+ case newStatus of
67+ True -> flushedPut requestFocusEvents
68+ False -> flushedPut disableFocusEvents
69+ writeIORef focusModeStatus newStatus
54 Mouse -> liftIO $ do
70 Mouse -> liftIO $ do
55 case newStatus of
71 case newStatus of
56 True -> flushedPut requestMouseEvents
72 True -> flushedPut requestMouseEvents
@@ -61,9 +77,12 @@ reserveTerminal variant outFd = liftIO $ do
61 True -> flushedPut enableBracketedPastes
77 True -> flushedPut enableBracketedPastes
62 False -> flushedPut disableBracketedPastes
78 False -> flushedPut disableBracketedPastes
63 writeIORef pasteModeStatus newStatus
79 writeIORef pasteModeStatus newStatus
80+ Hyperlink -> setMode t Hyperlink newStatus
64
81
65 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
83+ xtermGetMode Focus = liftIO $ readIORef focusModeStatus
66 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85+ xtermGetMode Hyperlink = getModeStatus t Hyperlink
67
86
68 let t' = t
87 let t' = t
69 { terminalID = terminalID t ++ " (xterm-color)"
88 { terminalID = terminalID t ++ " (xterm-color)"
@@ -71,6 +90,7 @@ reserveTerminal variant outFd = liftIO $ do
71 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
90 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
72 setMode t' BracketedPaste False
91 setMode t' BracketedPaste False
73 setMode t' Mouse False
92 setMode t' Mouse False
93+ setMode t' Focus False
74 releaseTerminal t
94 releaseTerminal t
75 , mkDisplayContext = \tActual r -> do
95 , mkDisplayContext = \tActual r -> do
76 dc <- mkDisplayContext t tActual r
96 dc <- mkDisplayContext t tActual r
@@ -84,30 +104,27 @@ reserveTerminal variant outFd = liftIO $ do
84utf8Active :: IO Bool
104utf8Active :: IO Bool
85utf8Active = do
105utf8Active = do
86 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
87− results <- catMaybes <$> mapM getEnv vars
107+ results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars
88− let matches = filter ("UTF8" `isInfixOf`) results <>
108+ let matches = filter ("utf8" `isInfixOf`) results <>
89− filter ("UTF-8" `isInfixOf`) results
109+ filter ("utf-8" `isInfixOf`) results
90 return $ not $ null matches
110 return $ not $ null matches
91
111
92-- | Enable bracketed paste mode:
112-- | Enable bracketed paste mode:
93-- http://cirw.in/blog/bracketed-paste
113-- http://cirw.in/blog/bracketed-paste
94−enableBracketedPastes :: String
114+enableBracketedPastes :: ByteString
95−enableBracketedPastes = "\ESC[?2004h"
115+enableBracketedPastes = BS8.pack "\ESC[?2004h"
96
116
97-- | Disable bracketed paste mode:
117-- | Disable bracketed paste mode:
98−disableBracketedPastes :: String
118+disableBracketedPastes :: ByteString
99−disableBracketedPastes = "\ESC[?2004l"
119+disableBracketedPastes = BS8.pack "\ESC[?2004l"
100
120
101-- | These sequences set xterm based terminals to UTF-8 output.
121-- | These sequences set xterm based terminals to UTF-8 output.
102--
122--
103−-- \todo I don't know of a terminfo cap that is equivalent to this.
123+-- There is no known terminfo capability equivalent to this.
104−setUtf8CharSet, setDefaultCharSet :: String
124+setUtf8CharSet, setDefaultCharSet :: ByteString
105−setUtf8CharSet = "\ESC%G"
125+setUtf8CharSet = BS8.pack "\ESC%G"
106−setDefaultCharSet = "\ESC%@"
126+setDefaultCharSet = BS8.pack "\ESC%@"
107−
127+
108−-- | I think xterm is broken: Reseting the background color as the first bytes serialized on a
109−-- new line does not effect the background color xterm uses to clear the line. Which is used
110−-- *after* the next newline.
111xtermInlineHack :: Output -> IO ()
128xtermInlineHack :: Output -> IO ()
112xtermInlineHack t = do
129xtermInlineHack t = do
113 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
src/Graphics/Vty/Picture.hs+63−40
@@ -1,25 +1,36 @@
1−{-# LANGUAGE BangPatterns #-}
1+-- A 'Picture' is a background paired with a set of 'Image' layers. The
2−-- | The 'Picture' data structure is representative of the final terminal view.
2+-- 'Picture' data structure is representative of the final terminal
3−--
3+-- view.
4−-- A 'Picture' is a background paired with a layer of 'Image's.
5−module Graphics.Vty.Picture ( module Graphics.Vty.Picture
4+module Graphics.Vty.Picture
6− , module Graphics.Vty.Image
5+ ( Picture(..)
6+ , Cursor(..)
7+ , Background(..)
8+ , emptyPicture
9+ , addToTop
10+ , addToBottom
11+ , picForImage
12+ , picForLayers
13+ , picImage
7− )
14+ )
8− where
15+where
9
16
10import Graphics.Vty.Image
17import Graphics.Vty.Image
18+import Graphics.Vty.Attributes
11
19
12import Control.DeepSeq
20import Control.DeepSeq
13
21
14−-- | The type of images to be displayed using 'update'.
22+-- | A Vty picture.
15--
23--
16−-- Can be constructed directly or using `picForImage`. Which provides an initial instance with
24+-- These can be constructed directly or using `picForImage`.
17−-- reasonable defaults for picCursor and picBackground.
18data Picture = Picture
25data Picture = Picture
19 { picCursor :: Cursor
26 { picCursor :: Cursor
27+ -- ^ The picture's cursor.
20 , picLayers :: [Image]
28 , picLayers :: [Image]
29+ -- ^ The picture's image layers (top-most first).
21 , picBackground :: Background
30 , picBackground :: Background
22− }
31+ -- ^ The picture's background to be displayed in locations with no
32+ -- Image data.
33+ } deriving Eq
23
34
24instance Show Picture where
35instance Show Picture where
25 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -27,20 +38,21 @@ instance Show Picture where
27instance NFData Picture where
38instance NFData Picture where
28 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
39 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
29
40
30−-- | a picture with no cursor, background or image layers
41+-- | A picture with no cursor, background or image layers.
31emptyPicture :: Picture
42emptyPicture :: Picture
32emptyPicture = Picture NoCursor [] ClearBackground
43emptyPicture = Picture NoCursor [] ClearBackground
33
44
34−-- | The given 'Image' is added as the top layer of the 'Picture'
45+-- | Add an 'Image' as the top-most layer of a 'Picture'.
35addToTop :: Picture -> Image -> Picture
46addToTop :: Picture -> Image -> Picture
36addToTop p i = p {picLayers = i : picLayers p}
47addToTop p i = p {picLayers = i : picLayers p}
37
48
38−-- | The given 'Image' is added as the bottom layer of the 'Picture'
49+-- | Add an 'Image' as the bottom-most layer of a 'Picture'.
39addToBottom :: Picture -> Image -> Picture
50addToBottom :: Picture -> Image -> Picture
40addToBottom p i = p {picLayers = picLayers p ++ [i]}
51addToBottom p i = p {picLayers = picLayers p ++ [i]}
41
52
42−-- | Create a picture for display for the given image. The picture will not have a displayed cursor
53+-- | Create a picture from the given image. The picture will not have a
43−-- and no background pattern (ClearBackground) will be used.
54+-- displayed cursor and no background pattern (ClearBackground) will be
55+-- used.
44picForImage :: Image -> Picture
56picForImage :: Image -> Picture
45picForImage i = Picture
57picForImage i = Picture
46 { picCursor = NoCursor
58 { picCursor = NoCursor
@@ -48,12 +60,10 @@ picForImage i = Picture
48 , picBackground = ClearBackground
60 , picBackground = ClearBackground
49 }
61 }
50
62
51−-- | Create a picture for display with the given layers. Ordered top to bottom.
63+-- | Create a picture with the given layers, top-most first.
52−--
53−-- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be
54−-- used.
55--
64--
56−-- The first 'Image' is the top layer.
65+-- The picture will not have a displayed cursor and no background
66+-- pattern (ClearBackgroun) will be used.
57picForLayers :: [Image] -> Picture
67picForLayers :: [Image] -> Picture
58picForLayers is = Picture
68picForLayers is = Picture
59 { picCursor = NoCursor
69 { picCursor = NoCursor
@@ -61,32 +71,40 @@ picForLayers is = Picture
61 , picBackground = ClearBackground
71 , picBackground = ClearBackground
62 }
72 }
63
73
64−-- | A picture can be configured either to not show the cursor or show the cursor at the specified
74+-- | A picture can be configured to hide the cursor or to show the
65−-- character position.
75+-- cursor at the specified character position.
66−--
67−-- There is not a 1 to 1 map from character positions to a row and column on the screen due to
68−-- characters that take more than 1 column.
69--
76--
70−-- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the
77+-- There is not a 1:1 map from character positions to a row and column
71−-- output region. In this case the cursor will not be shown.
78+-- on the screen due to characters that take more than 1 column.
72data Cursor =
79data Cursor =
73− -- | Hide the cursor
80+ -- | Hide the cursor
74− NoCursor
81+ NoCursor
82+ -- | Set the terminal's cursor position without displaying a cursor
83+ -- character. This is important for accessibility with screen
84+ -- readers where a cursor position needs to be reported but we may
85+ -- not want to show a block cursor in that location for cosmetic
86+ -- reasons. The boolean argument indicates whether the positioning
87+ -- should be absolute as with 'AbsoluteCursor' ('True') or logical
88+ -- as with 'Cursor' ('False').
89+ | PositionOnly !Bool !Int !Int
75− -- | Show the cursor at the given logical column accounting for char width and row
90+ -- | Show the cursor at the given logical column accounting for
91+ -- character width in the presence of multi-column characters.
76 | Cursor !Int !Int
92 | Cursor !Int !Int
77− -- | Show the cursor at the given absolute terminal column and row
93+ -- | Show the cursor at the given absolute terminal column and row
78 | AbsoluteCursor !Int !Int
94 | AbsoluteCursor !Int !Int
95+ deriving Eq
79
96
80instance NFData Cursor where
97instance NFData Cursor where
81 rnf c = c `seq` ()
98 rnf c = c `seq` ()
82
99
83−-- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the
100+-- | A 'Picture' has a background pattern. The background is either:
84−-- layer below or is blank if the bottom layer. Or the background pattern is a character and a
85−-- display attribute. If the display attribute used previously should be used for a background fill
86−-- then use `currentAttr` for the background attribute.
87--
101--
88−-- \todo The current attribute is always set to the default attributes at the start of updating the
102+-- * ClearBackground, which shows the layer below or is blank if the
89−-- screen to a picture.
103+-- bottom layer
104+-- * A character and a display attribute
105+--
106+-- If the display attribute used previously should be used for a
107+-- background fill then use `currentAttr` for the background attribute.
90data Background
108data Background
91 = Background
109 = Background
92 { backgroundChar :: Char
110 { backgroundChar :: Char
@@ -98,11 +116,16 @@ data Background
98 --
116 --
99 -- * End of line if there are no remaining non-skip ops.
117 -- * End of line if there are no remaining non-skip ops.
100 | ClearBackground
118 | ClearBackground
119+ deriving Eq
101
120
102instance NFData Background where
121instance NFData Background where
103 rnf (Background c a) = c `seq` a `seq` ()
122 rnf (Background c a) = c `seq` a `seq` ()
104 rnf ClearBackground = ()
123 rnf ClearBackground = ()
105
124
125+-- | Return the top-most 'Image' layer for a picture. This is unsafe for
126+-- 'Picture's without at least one layer.
127+--
128+-- This is provided for compatibility with applications that do not use
106−-- | Compatibility with applications that do not use more than a single layer.
129+-- more than a single layer.
107picImage :: Picture -> Image
130picImage :: Picture -> Image
108picImage = head . picLayers
131picImage = head . picLayers
src/Graphics/Vty/PictureToSpans.hs+66−85
@@ -1,21 +1,14 @@
1-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
1-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE CPP #-}
4{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE NamedFieldPuns #-}
6{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TemplateHaskell #-}
8
7
9−#ifndef MIN_VERSION_base
10−#defined MIN_VERSION_base(x,y,z) 1
11−#endif
12−
13−{- | Transforms an image into rows of operations.
8+-- | Transforms an image into rows of operations.
14− -}
15module Graphics.Vty.PictureToSpans where
9module Graphics.Vty.PictureToSpans where
16
10
17−import Graphics.Vty.Prelude
11+import Graphics.Vty.Attributes (Attr, currentAttr)
18−
19import Graphics.Vty.Image
12import Graphics.Vty.Image
20import Graphics.Vty.Image.Internal
13import Graphics.Vty.Image.Internal
21import Graphics.Vty.Picture
14import Graphics.Vty.Picture
@@ -26,12 +19,7 @@ import Lens.Micro.Mtl
26import Lens.Micro.TH
19import Lens.Micro.TH
27import Control.Monad.Reader
20import Control.Monad.Reader
28import Control.Monad.State.Strict hiding ( state )
21import Control.Monad.State.Strict hiding ( state )
29−
30−#if __GLASGOW_HASKELL__ < 708
31−import Control.Monad.ST.Strict hiding ( unsafeIOToST )
32−#else
33import Control.Monad.ST.Strict
22import Control.Monad.ST.Strict
34−#endif
35
23
36import qualified Data.Vector as Vector hiding ( take, replicate )
24import qualified Data.Vector as Vector hiding ( take, replicate )
37import Data.Vector.Mutable ( MVector(..))
25import Data.Vector.Mutable ( MVector(..))
@@ -39,29 +27,27 @@ import qualified Data.Vector.Mutable as MVector
39
27
40import qualified Data.Text.Lazy as TL
28import qualified Data.Text.Lazy as TL
41
29
42−#if !(MIN_VERSION_base(4,8,0))
43−import Data.Monoid (mappend)
44−#endif
45−
46type MRowOps s = MVector s SpanOps
30type MRowOps s = MVector s SpanOps
47
31
48type MSpanOps s = MVector s SpanOp
32type MSpanOps s = MVector s SpanOp
49
33
50-- transform plus clip. More or less.
34-- transform plus clip. More or less.
51data BlitState = BlitState
35data BlitState = BlitState
52− -- we always snoc to the operation vectors. Thus the columnOffset = length of row at rowOffset
36+ -- we always snoc to the operation vectors. Thus the columnOffset =
37+ -- length of row at rowOffset although, one possibility is to merge
53− -- although, one possibility is to merge layers right in snocOp (naming it something else, of
38+ -- layers right in snocOp (naming it something else, of course). In
54− -- course). In which case columnnOffset would be applicable.
39+ -- which case columnnOffset would be applicable. Right now we need
55− -- Right now we need it to exist.
40+ -- it to exist.
56 { _columnOffset :: Int
41 { _columnOffset :: Int
57 , _rowOffset :: Int
42 , _rowOffset :: Int
58− -- clip coordinate space is in image space. Which means it's >= 0 and < imageWidth.
43+ -- clip coordinate space is in image space. Which means it's >= 0
44+ -- and < imageWidth.
59 , _skipColumns :: Int
45 , _skipColumns :: Int
60 -- >= 0 and < imageHeight
46 -- >= 0 and < imageHeight
61 , _skipRows :: Int
47 , _skipRows :: Int
62− -- includes consideration of skipColumns. In display space.
48+ -- includes consideration of skipColumns. In display space. The
63− -- The number of columns from the next column to be defined to the end of the display for the
49+ -- number of columns from the next column to be defined to the end
64− -- row.
50+ -- of the display for the row.
65 , _remainingColumns :: Int
51 , _remainingColumns :: Int
66 -- includes consideration of skipRows. In display space.
52 -- includes consideration of skipRows. In display space.
67 , _remainingRows :: Int
53 , _remainingRows :: Int
@@ -78,31 +64,29 @@ makeLenses ''BlitEnv
78
64
79type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
65type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
80
66
81−-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
67+-- | Produces the span ops that will render the given picture, possibly
82−-- specified region.
68+-- cropped or padded, into the specified region.
83displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
69displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
84displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
70displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
85
71
86−-- | Returns the DisplayOps for an image rendered to a window the size of the image.
72+-- | Returns the DisplayOps for an image rendered to a window the size
73+-- of the image.
87--
74--
88−-- largerly used only for debugging.
75+-- largely used only for debugging.
89displayOpsForImage :: Image -> DisplayOps
76displayOpsForImage :: Image -> DisplayOps
90displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
91
78
92-- | Produces the span ops for each layer then combines them.
79-- | Produces the span ops for each layer then combines them.
93−--
94−-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
95−-- region.
96combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
80combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
97combinedOpsForLayers pic r
81combinedOpsForLayers pic r
98 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
99 | otherwise = do
83 | otherwise = do
100− layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)
84+ layerOps <- mapM (`buildSpans` r) (picLayers pic)
101 case layerOps of
85 case layerOps of
102 [] -> fail "empty picture"
86 [] -> fail "empty picture"
103 [ops] -> substituteSkips (picBackground pic) ops
87 [ops] -> substituteSkips (picBackground pic) ops
104− -- instead of merging ops after generation the merging can be performed as part of
88+ -- instead of merging ops after generation the merging can
105− -- snocOp.
89+ -- be performed as part of snocOp.
106 topOps : lowerOps -> do
90 topOps : lowerOps -> do
107 ops <- foldM mergeUnder topOps lowerOps
91 ops <- foldM mergeUnder topOps lowerOps
108 substituteSkips (picBackground pic) ops
92 substituteSkips (picBackground pic) ops
@@ -111,21 +95,23 @@ substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)
111substituteSkips ClearBackground ops = do
95substituteSkips ClearBackground ops = do
112 forM_ [0 .. MVector.length ops - 1] $ \row -> do
96 forM_ [0 .. MVector.length ops - 1] $ \row -> do
113 rowOps <- MVector.read ops row
97 rowOps <- MVector.read ops row
114− -- the image operations assure that background fills are combined.
98+ -- the image operations assure that background fills are
115− -- clipping a background fill does not split the background fill.
99+ -- combined. clipping a background fill does not split the
116− -- merging of image layers can split a skip, but only by the insertion of a non skip.
100+ -- background fill. merging of image layers can split a skip,
101+ -- but only by the insertion of a non skip. all this combines to
117− -- all this combines to mean we can check the last operation and remove it if it's a skip
102+ -- mean we can check the last operation and remove it if it's a
118− -- todo: or does it?
103+ -- skip
119 let rowOps' = case Vector.last rowOps of
104 let rowOps' = case Vector.last rowOps of
120 Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w
105 Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w
121 _ -> rowOps
106 _ -> rowOps
122− -- now all the skips can be replaced by replications of ' ' of the required width.
107+ -- now all the skips can be replaced by replications of ' ' of
108+ -- the required width.
123 let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'
109 let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'
124 MVector.write ops row rowOps''
110 MVector.write ops row rowOps''
125 return ops
111 return ops
126substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do
112substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do
127− -- At this point we decide if the background character is single column or not.
113+ -- At this point we decide if the background character is single
128− -- obviously, single column is easier.
114+ -- column or not. obviously, single column is easier.
129 case safeWcwidth backgroundChar of
115 case safeWcwidth backgroundChar of
130 w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar
116 w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar
131 | w == 1 -> do
117 | w == 1 -> do
@@ -149,12 +135,12 @@ mergeUnder upper lower = do
149 MVector.write upper row rowOps
135 MVector.write upper row rowOps
150 return upper
136 return upper
151
137
152−-- fugly
153mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
154−mergeRowUnder upperRowOps lowerRowOps =
139+mergeRowUnder upperRowOps =
155− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps
140+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)
156 where
141 where
157− -- H: it will never be the case that we are out of upper ops before lower ops.
142+ -- H: it will never be the case that we are out of upper ops
143+ -- before lower ops.
158 onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
144 onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
159 onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =
145 onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =
160 let lowerOps' = dropOps w lowerOps
146 let lowerOps' = dropOps w lowerOps
@@ -189,30 +175,32 @@ swapSkipsForCharSpan w c a = Vector.map f
189 in TextSpan a ow cw txt
175 in TextSpan a ow cw txt
190 f v = v
176 f v = v
191
177
192−-- | Builds a vector of row operations that will output the given picture to the terminal.
178+-- | Builds a vector of row operations that will output the given
179+-- picture to the terminal.
193--
180--
194-- Crops to the given display region.
181-- Crops to the given display region.
195−--
196−-- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer.
197buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
182buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
198buildSpans image outRegion = do
183buildSpans image outRegion = do
199 -- First we create a mutable vector for each rows output operations.
184 -- First we create a mutable vector for each rows output operations.
200 outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
185 outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
201− -- \todo I think building the span operations in display order would provide better performance.
186+ -- It's possible that building the span operations in display order
202− -- However, I got stuck trying to implement an algorithm that did this. This will be considered
187+ -- would provide better performance.
203− -- as a possible future optimization.
204 --
188 --
205− -- A depth first traversal of the image is performed. ordered according to the column range
189+ -- A depth first traversal of the image is performed. ordered
190+ -- according to the column range defined by the image from least
206− -- defined by the image from least to greatest. The output row ops will at least have the
191+ -- to greatest. The output row ops will at least have the region
207− -- region of the image specified. Iterate over all output rows and output background fills for
192+ -- of the image specified. Iterate over all output rows and output
208− -- all unspecified columns.
193+ -- background fills for all unspecified columns.
209 --
194 --
210− -- The images are made into span operations from left to right. It's possible that this could
195+ -- The images are made into span operations from left to right. It's
211− -- easily be made to assure top to bottom output as well.
196+ -- possible that this could easily be made to assure top to bottom
197+ -- output as well.
212 when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do
198 when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do
213− -- The ops builder recursively descends the image and outputs span ops that would
199+ -- The ops builder recursively descends the image and outputs
200+ -- span ops that would display that image. The number of columns
214− -- display that image. The number of columns remaining in this row before exceeding the
201+ -- remaining in this row before exceeding the bounds is also
215− -- bounds is also provided. This is used to clip the span ops produced to the display.
202+ -- provided. This is used to clip the span ops produced to the
203+ -- display.
216 let fullBuild = do
204 let fullBuild = do
217 startImageBuild image
205 startImageBuild image
218 -- Fill in any unspecified columns with a skip.
206 -- Fill in any unspecified columns with a skip.
@@ -223,7 +211,8 @@ buildSpans image outRegion = do
223 return ()
211 return ()
224 return outOps
212 return outOps
225
213
226−-- | Add the operations required to build a given image to the current set of row operations.
214+-- | Add the operations required to build a given image to the current
215+-- set of row operations.
227startImageBuild :: Image -> BlitM s ()
216startImageBuild :: Image -> BlitM s ()
228startImageBuild image = do
217startImageBuild image = do
229 outOfBounds <- isOutOfBounds image <$> get
218 outOfBounds <- isOutOfBounds image <$> get
@@ -237,17 +226,16 @@ isOutOfBounds i s
237 | s ^. skipRows >= imageHeight i = True
226 | s ^. skipRows >= imageHeight i = True
238 | otherwise = False
227 | otherwise = False
239
228
240−-- | This adds an image that might be partially clipped to the output ops.
229+-- | This adds an image that might be partially clipped to the output
241−--
230+-- ops.
242−-- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom
243−-- implementations are odd. They pass the current tests but something seems terribly wrong about all
244−-- this.
245--
231--
246−-- \todo prove this cannot be called in an out of bounds case.
232+-- This is a very touchy algorithm. Too touchy. For instance, the
233+-- CropRight and CropBottom implementations are odd. They pass the
234+-- current tests but something seems terribly wrong about all this.
247addMaybeClipped :: forall s . Image -> BlitM s ()
235addMaybeClipped :: forall s . Image -> BlitM s ()
248addMaybeClipped EmptyImage = return ()
236addMaybeClipped EmptyImage = return ()
249addMaybeClipped (HorizText a textStr ow _cw) = do
237addMaybeClipped (HorizText a textStr ow _cw) = do
250− -- TODO: assumption that text spans are only 1 row high.
238+ -- This assumes that text spans are only 1 row high.
251 s <- use skipRows
239 s <- use skipRows
252 when (s < 1) $ do
240 when (s < 1) $ do
253 leftClip <- use skipColumns
241 leftClip <- use skipColumns
@@ -310,12 +298,11 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
310 state <- get
298 state <- get
311 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
312 case state^.skip of
300 case state^.skip of
313− s -- TODO: check if clipped in other dim. if not use addUnclipped
314− | s > size -> put $ state & skip -~ size
301+ s | s > size -> put $ state & skip %~ subtract size
315 | s == 0 -> if state^.remaining > i0Dim
302 | s == 0 -> if state^.remaining > i0Dim
316 then do
303 then do
317 addMaybeClipped i0
304 addMaybeClipped i0
318− put $ state & offset +~ i0Dim & remaining -~ i0Dim
305+ put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim
319 addMaybeClipped i1
306 addMaybeClipped i1
320 else addMaybeClipped i0
307 else addMaybeClipped i0
321 | s < i0Dim ->
308 | s < i0Dim ->
@@ -324,10 +311,10 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
324 then addMaybeClipped i0
311 then addMaybeClipped i0
325 else do
312 else do
326 addMaybeClipped i0
313 addMaybeClipped i0
327− put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0
314+ put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0
328 addMaybeClipped i1
315 addMaybeClipped i1
329 | s >= i0Dim -> do
316 | s >= i0Dim -> do
330− put $ state & skip -~ i0Dim
317+ put $ state & skip %~ subtract i0Dim
331 addMaybeClipped i1
318 addMaybeClipped i1
332 _ -> fail $ name ++ " has unhandled skip class"
319 _ -> fail $ name ++ " has unhandled skip class"
333
320
@@ -336,14 +323,14 @@ addUnclippedText a txt = do
336 let op = TextSpan a usedDisplayColumns
323 let op = TextSpan a usedDisplayColumns
337 (fromIntegral $ TL.length txt)
324 (fromIntegral $ TL.length txt)
338 txt
325 txt
339− usedDisplayColumns = wcswidth $ TL.unpack txt
326+ usedDisplayColumns = wctlwidth txt
340 use rowOffset >>= snocOp op
327 use rowOffset >>= snocOp op
341
328
342addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
343addRowCompletion displayRegion row = do
330addRowCompletion displayRegion row = do
344 allRowOps <- view mrowOps
331 allRowOps <- view mrowOps
345 rowOps <- lift $ lift $ MVector.read allRowOps row
332 rowOps <- lift $ lift $ MVector.read allRowOps row
346− let endX = spanOpsEffectedColumns rowOps
333+ let endX = spanOpsAffectedColumns rowOps
347 when (endX < regionWidth displayRegion) $ do
334 when (endX < regionWidth displayRegion) $ do
348 let ow = regionWidth displayRegion - endX
335 let ow = regionWidth displayRegion - endX
349 snocOp (Skip ow) row
336 snocOp (Skip ow) row
@@ -356,12 +343,6 @@ snocOp !op !row = do
356 lift $ lift $ do
343 lift $ lift $ do
357 ops <- MVector.read theMrowOps row
344 ops <- MVector.read theMrowOps row
358 let ops' = Vector.snoc ops op
345 let ops' = Vector.snoc ops op
359− when (spanOpsEffectedColumns ops' > regionWidth theRegion)
346+ when (spanOpsAffectedColumns ops' > regionWidth theRegion)
360 $ fail $ "row " ++ show row ++ " now exceeds region width"
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
361 MVector.write theMrowOps row ops'
348 MVector.write theMrowOps row ops'
362−
363−(-~) :: Num a => ASetter s t a a -> a -> s -> t
364−l -~ n = over l (subtract n)
365−
366−(+~) :: Num a => ASetter s t a a -> a -> s -> t
367−l +~ n = over l (n +)
src/Graphics/Vty/Prelude.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- | Prelude for Vty modules. Not particularly useful outside of Vty.
2−module Graphics.Vty.Prelude ( module Graphics.Vty.Prelude
3− , module Control.Applicative
4− , module Control.Monad
5− )
6−where
7−
8−import Control.Applicative hiding ((<|>))
9−import Control.Monad
10−
11−-- | Named alias for a Int pair
12−type DisplayRegion = (Int,Int)
13−
14−regionWidth :: DisplayRegion -> Int
15−regionWidth = fst
16−
17−regionHeight :: DisplayRegion -> Int
18−regionHeight = snd
src/Graphics/Vty/Span.hs+43−50
@@ -1,23 +1,15 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2−{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
5−{- | A picture is translated into a sequences of state changes and character spans.
3+-- | A picture is translated into a sequences of state changes and
6− - State changes are currently limited to new attribute values. The attribute is applied to all
4+-- character spans. The attribute is applied to all following spans,
7− - following spans. Including spans of the next row. The nth element of the sequence represents the
5+-- including spans of the next row. The nth element of the sequence
8− - nth row (from top to bottom) of the picture to render.
6+-- represents the nth row (from top to bottom) of the picture to render.
9− -
7+--
10− - A span op sequence will be defined for all rows and columns (and no more) of the region provided
8+-- A span op sequence will be defined for all rows and columns (and no
11− - with the picture to `spansForPic`.
9+-- more) of the region provided with the picture to 'spansForPic'.
12− -
13− - todo: Partition attribute changes into multiple categories according to the serialized
14− - representation of the various attributes.
15− -}
16−module Graphics.Vty.Span
10+module Graphics.Vty.Span where
17− where
18−
19−import Graphics.Vty.Prelude
20
11
12+import Graphics.Vty.Attributes (Attr)
21import Graphics.Vty.Image
13import Graphics.Vty.Image
22import Graphics.Vty.Image.Internal ( clipText )
14import Graphics.Vty.Image.Internal ( clipText )
23
15
@@ -25,40 +17,40 @@ import qualified Data.Text.Lazy as TL
25import Data.Vector (Vector)
17import Data.Vector (Vector)
26import qualified Data.Vector as Vector
18import qualified Data.Vector as Vector
27
19
28−-- | This represents an operation on the terminal. Either an attribute change or the output of a
20+-- | This represents an operation on the terminal: either an attribute
29−-- text string.
21+-- change or the output of a text string.
30data SpanOp =
22data SpanOp =
31− -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
23+ -- | A span of UTF-8 text occupies a specific number of screen space
24+ -- columns. A single UTF character does not necessarily represent 1
32− -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width
25+ -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width
33− -- TextSpan [Attr] [output width in columns] [number of characters] [data]
26+ -- in columns] [number of characters] [data]
34 TextSpan
27 TextSpan
35 { textSpanAttr :: !Attr
28 { textSpanAttr :: !Attr
36 , textSpanOutputWidth :: !Int
29 , textSpanOutputWidth :: !Int
37 , textSpanCharWidth :: !Int
30 , textSpanCharWidth :: !Int
38 , textSpanText :: DisplayText
31 , textSpanText :: DisplayText
39 }
32 }
40− -- | Skips the given number of columns
33+ -- | Skips the given number of columns.
41− -- A skip is transparent.... maybe? I am not sure how attribute changes interact.
42− -- todo: separate from this type.
43 | Skip !Int
34 | Skip !Int
44− -- | Marks the end of a row. specifies how many columns are remaining. These columns will not be
35+ -- | Marks the end of a row. Specifies how many columns are
36+ -- remaining. These columns will not be explicitly overwritten with
45− -- explicitly overwritten with the span ops. The terminal is require to assure the remaining
37+ -- the span ops. The terminal is require to assure the remaining
46 -- columns are clear.
38 -- columns are clear.
47− -- todo: separate from this type.
48 | RowEnd !Int
39 | RowEnd !Int
49 deriving Eq
40 deriving Eq
50
41
51−-- | vector of span operations. executed in succession. This represents the operations required to
42+-- | A vector of span operations executed in succession. This represents
43+-- the operations required to render a row of the terminal. The
52−-- render a row of the terminal. The operations in one row may effect subsequent rows.
44+-- operations in one row may affect subsequent rows. For example,
53−-- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground
45+-- setting the foreground color in one row will affect all subsequent
54−-- color is changed.
46+-- rows until the foreground color is changed.
55type SpanOps = Vector SpanOp
47type SpanOps = Vector SpanOp
56
48
57dropOps :: Int -> SpanOps -> SpanOps
49dropOps :: Int -> SpanOps -> SpanOps
58dropOps w = snd . splitOpsAt w
50dropOps w = snd . splitOpsAt w
59
51
60splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
61−splitOpsAt inW inOps = splitOpsAt' inW inOps
53+splitOpsAt = splitOpsAt'
62 where
54 where
63 splitOpsAt' 0 ops = (Vector.empty, ops)
55 splitOpsAt' 0 ops = (Vector.empty, ops)
64 splitOpsAt' remainingColumns ops = case Vector.head ops of
56 splitOpsAt' remainingColumns ops = case Vector.head ops of
@@ -90,7 +82,8 @@ splitOpsAt inW inOps = splitOpsAt' inW inOps
90 )
82 )
91 RowEnd _ -> error "cannot split ops containing a row end"
83 RowEnd _ -> error "cannot split ops containing a row end"
92
84
93−-- | vector of span operation vectors for display. One per row of the output region.
85+-- | A vector of span operation vectors for display, one per row of the
86+-- output region.
94type DisplayOps = Vector SpanOps
87type DisplayOps = Vector SpanOps
95
88
96instance Show SpanOp where
89instance Show SpanOp where
@@ -98,39 +91,39 @@ instance Show SpanOp where
98 show (Skip ow) = "Skip(" ++ show ow ++ ")"
91 show (Skip ow) = "Skip(" ++ show ow ++ ")"
99 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
92 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
100
93
101−-- | Number of columns the DisplayOps are defined for
94+-- | The number of columns the DisplayOps are defined for.
102--
95--
103−-- All spans are verified to define same number of columns. See: VerifySpanOps
96+-- All spans are verified to define same number of columns.
104displayOpsColumns :: DisplayOps -> Int
97displayOpsColumns :: DisplayOps -> Int
105displayOpsColumns ops
98displayOpsColumns ops
106 | Vector.length ops == 0 = 0
99 | Vector.length ops == 0 = 0
107 | otherwise = Vector.length $ Vector.head ops
100 | otherwise = Vector.length $ Vector.head ops
108
101
109−-- | Number of rows the DisplayOps are defined for
102+-- | The number of rows the DisplayOps are defined for.
110displayOpsRows :: DisplayOps -> Int
103displayOpsRows :: DisplayOps -> Int
111−displayOpsRows ops = Vector.length ops
104+displayOpsRows = Vector.length
112
105
113−effectedRegion :: DisplayOps -> DisplayRegion
106+affectedRegion :: DisplayOps -> DisplayRegion
114−effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
107+affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
115
108
116−-- | The number of columns a SpanOps effects.
109+-- | The number of columns a SpanOps affects.
117−spanOpsEffectedColumns :: SpanOps -> Int
110+spanOpsAffectedColumns :: SpanOps -> Int
118−spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
111+spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps
119 where
112 where
120− spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
113+ spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w
121− spanOpsEffectedColumns' t (Skip w) = t + w
114+ spanOpsAffectedColumns' t (Skip w) = t + w
122− spanOpsEffectedColumns' t (RowEnd w) = t + w
115+ spanOpsAffectedColumns' t (RowEnd w) = t + w
123
116
124−-- | The width of a single SpanOp in columns
117+-- | The width of a single SpanOp in columns.
125spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
126spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
119spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
127spanOpHasWidth (Skip ow) = Just (ow,ow)
120spanOpHasWidth (Skip ow) = Just (ow,ow)
128spanOpHasWidth (RowEnd ow) = Just (ow,ow)
121spanOpHasWidth (RowEnd ow) = Just (ow,ow)
129
122
130−-- | returns the number of columns to the character at the given position in the span op
123+-- | The number of columns to the character at the given position in the
124+-- span op.
131columnsToCharOffset :: Int -> SpanOp -> Int
125columnsToCharOffset :: Int -> SpanOp -> Int
132columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
126columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
133− let str = TL.unpack utf8Str
127+ wctlwidth (TL.take (fromIntegral cx) utf8Str)
134− in wcswidth (take cx str)
135columnsToCharOffset cx (Skip _) = cx
128columnsToCharOffset cx (Skip _) = cx
136columnsToCharOffset cx (RowEnd _) = cx
129columnsToCharOffset cx (RowEnd _) = cx
src/Graphics/Vty/UnicodeWidthTable/IO.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# LANGUAGE CPP #-}
2+module Graphics.Vty.UnicodeWidthTable.IO
3+ ( readUnicodeWidthTable
4+ , parseUnicodeWidthTable
5+ , writeUnicodeWidthTable
6+ )
7+where
8+
9+import Control.Monad (when, forM)
10+import Data.Binary
11+import Data.Binary.Get
12+import Data.Binary.Put
13+import qualified Data.ByteString.Lazy as BSL
14+#if !(MIN_VERSION_base(4,11,0))
15+import Data.Semigroup ((<>))
16+#endif
17+
18+import Graphics.Vty.UnicodeWidthTable.Types
19+
20+-- | Load a binary unicode width table from the specified file.
21+--
22+-- This either returns a successfully parsed table or a table parsing
23+-- error message. This does not handle I/O exceptions.
24+readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)
25+readUnicodeWidthTable path = parseUnicodeWidthTable <$> BSL.readFile path
26+
27+-- | Parse a binary unicode width table.
28+parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable
29+parseUnicodeWidthTable bs =
30+ case runGetOrFail tableParser bs of
31+ Left (_, _, msg) ->
32+ Left msg
33+
34+ -- Even if we parsed a table, leftover bytes indicate something
35+ -- could be wrong.
36+ Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->
37+ Left $ "Error: " <> show (BSL.length remainingBytes) <>
38+ " byte(s) left unconsumed"
39+
40+ Right (_, _, table) ->
41+ Right table
42+
43+-- | Write the unicode width table to the specified path.
44+--
45+-- This does not handle I/O exceptions.
46+writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
47+writeUnicodeWidthTable path table = do
48+ let body = runPut (tableV1Writer table)
49+ BSL.writeFile path body
50+
51+-- | Width table magic bytes for use in the binary format.
52+widthTableMagic :: Word32
53+widthTableMagic = 0xc1a9f7e0
54+
55+tableParser :: Get UnicodeWidthTable
56+tableParser = do
57+ magic <- getWord32le
58+
59+ when (magic /= widthTableMagic) $
60+ fail "Table magic number invalid"
61+
62+ version <- getWord8
63+
64+ case version of
65+ 1 -> tableV1Parser
66+ _ -> fail "Table version invalid"
67+
68+tableV1Parser :: Get UnicodeWidthTable
69+tableV1Parser = do
70+ numRanges <- getWord32le
71+
72+ let parseRange = do
73+ start <- getWord32le
74+ size <- getWord32le
75+ cols <- getWord8
76+ return WidthTableRange { rangeStart = start
77+ , rangeSize = size
78+ , rangeColumns = cols
79+ }
80+
81+ ranges <- forM [1..numRanges] $ const parseRange
82+
83+ return UnicodeWidthTable { unicodeWidthTableRanges = ranges
84+ }
85+
86+tableV1Writer :: UnicodeWidthTable -> Put
87+tableV1Writer table = do
88+ -- Magic bytes
89+ putWord32le widthTableMagic
90+
91+ -- Version
92+ putWord8 1
93+
94+ -- Number of ranges
95+ let ranges = unicodeWidthTableRanges table
96+ let numRanges = length ranges
97+ putWord32le (fromIntegral numRanges)
98+
99+ -- Ranges
100+ let putRange r = do
101+ putWord32le $ rangeStart r
102+ putWord32le $ rangeSize r
103+ putWord8 $ rangeColumns r
104+
105+ mapM_ putRange ranges
src/Graphics/Vty/UnicodeWidthTable/Install.hsnew file+129
@@ -0,0 +1,129 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+module Graphics.Vty.UnicodeWidthTable.Install
4+ ( TableInstallException(..)
5+ , installUnicodeWidthTable
6+ , isCustomTableReady
7+ )
8+where
9+
10+import Control.Monad (when, forM_)
11+import qualified Control.Exception as E
12+import GHC.Conc.Sync (withMVar)
13+import Control.Concurrent.MVar (MVar, newMVar)
14+import Data.Word (Word8, Word32)
15+#if !(MIN_VERSION_base(4,11,0))
16+import Data.Semigroup ((<>))
17+#endif
18+import System.IO.Unsafe (unsafePerformIO)
19+
20+import Graphics.Vty.UnicodeWidthTable.Types
21+
22+-- | The lock used to make functions in this module thread-safe.
23+installLock :: MVar ()
24+{-# NOINLINE installLock #-}
25+installLock = unsafePerformIO $ newMVar ()
26+
27+-- | Returns True if and only if a custom table has been allocated and
28+-- marked as ready for use.
29+--
30+-- This function is thread-safe.
31+isCustomTableReady :: IO Bool
32+isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady
33+
34+withInstallLock :: IO a -> IO a
35+withInstallLock act = withMVar installLock $ const act
36+
37+-- This is the size of the allocated custom character width table, in
38+-- character slots. It's important that this be large enough to hold all
39+-- possible Unicode character values. At the time of this writing, the
40+-- valid Unicode range is 0 - 0x10ffff, hence this value.
41+tableSize :: Int
42+tableSize = 0x110000
43+
44+-- | Exception type raised by 'installUnicodeWidthTable'.
45+data TableInstallException =
46+ TableInitFailure Int Int
47+ -- ^ The width table could not be initialized. Args: failure status,
48+ -- requested table size.
49+ | TableRangeFailure Int WidthTableRange
50+ -- ^ A code point range could not be configured. Args: failure
51+ -- status, offending range.
52+ | TableActivationFailure Int
53+ -- ^ The table could not be activated. Args: failure status.
54+ deriving (Eq, Show)
55+
56+instance E.Exception TableInstallException
57+
58+-- | Install a custom unicode character width
59+-- table. Such tables are obtained with
60+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and
61+-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.
62+--
63+-- ALERT! This function is probably not what you want to use because
64+-- it is automatically called by 'Graphics.Vty.mkVty'. You will only
65+-- ever need to call this function if you want to use functions
66+-- in 'Graphics.Text.Width' without controlling the terminal with
67+-- 'Graphics.Vty.mkVty'.
68+--
69+-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'
70+-- function and functions that call it. It does so by
71+-- changing global state available to the C implementation
72+-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your
73+-- program gets consistent results from evaluating calls to
74+-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table
75+-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in
76+-- your program.
77+--
78+-- This is best done at Vty startup, and if you use
79+-- 'Graphics.Vty.mkVty', that function calls this automatically based on
80+-- the Vty configuration's declared width tables. It is exposed as part
81+-- of the public API so that applications can call this as needed if
82+-- they don't want to control the terminal with 'mkVty' but do want to
83+-- make calls to 'Graphics.Vty.Image.wcwidth'.
84+--
85+-- It's also important to note that once a custom table has been
86+-- installed, it is permanent for the life of the process. No new table
87+-- can be installed, and the new custom table cannot be removed.
88+--
89+-- If this function fails for any reason -- if the table cannot be
90+-- installed or is invalid, or if a custom table already exists -- this
91+-- will raise a 'TableInstallException' exception.
92+--
93+-- This function is thread-safe.
94+installUnicodeWidthTable :: UnicodeWidthTable -> IO ()
95+installUnicodeWidthTable table = withInstallLock $ do
96+ initResult <- initCustomTable tableSize
97+ when (initResult /= 0) $
98+ E.throwIO $ TableInitFailure initResult tableSize
99+
100+ forM_ (unicodeWidthTableRanges table) $ \r -> do
101+ result <- setCustomTableRange (rangeStart r)
102+ (rangeSize r)
103+ (rangeColumns r)
104+
105+ when (result /= 0) $ do
106+ deallocateCustomTable
107+ E.throwIO $ TableRangeFailure result r
108+
109+ actResult <- activateCustomTable
110+ when (actResult /= 0) $
111+ E.throwIO $ TableActivationFailure actResult
112+
113+------------------------------------------------------------------------
114+-- C imports
115+
116+foreign import ccall unsafe "vty_init_custom_table"
117+ initCustomTable :: Int -> IO Int
118+
119+foreign import ccall unsafe "vty_set_custom_table_range"
120+ setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int
121+
122+foreign import ccall unsafe "vty_activate_custom_table"
123+ activateCustomTable :: IO Int
124+
125+foreign import ccall unsafe "vty_custom_table_ready"
126+ c_isCustomTableReady :: IO Int
127+
128+foreign import ccall unsafe "vty_deallocate_custom_table"
129+ deallocateCustomTable :: IO ()
src/Graphics/Vty/UnicodeWidthTable/Query.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# LANGUAGE TupleSections #-}
2+module Graphics.Vty.UnicodeWidthTable.Query
3+ ( buildUnicodeWidthTable
4+ , defaultUnicodeTableUpperBound
5+ )
6+where
7+
8+import Control.Monad (forM)
9+import Data.Char (generalCategory, GeneralCategory(..))
10+import System.Console.ANSI (getCursorPosition)
11+import Text.Printf (printf)
12+
13+import Graphics.Vty.UnicodeWidthTable.Types
14+
15+shouldConsider :: Char -> Bool
16+shouldConsider c =
17+ case generalCategory c of
18+ Control -> False
19+ NotAssigned -> False
20+ Surrogate -> False
21+ _ -> True
22+
23+charWidth :: Char -> IO Int
24+charWidth c = do
25+ printf "\r"
26+ putChar c
27+ Just (_, col) <- getCursorPosition
28+ return col
29+
30+-- | Convert a sequence of character/width pairs into a list of
31+-- run-length encoded ranges. This function assumes the pairs come
32+-- sorted by character ordinal value. It does not require that the
33+-- character range is fully covered by the sequence.
34+--
35+-- The result of this function is a list of ranges in reverse order
36+-- relative to the input sequence.
37+mkRanges :: [(Char, Int)] -> [WidthTableRange]
38+mkRanges pairs =
39+ let convertedPairs = convert <$> pairs
40+ convert (c, i) = (fromIntegral $ fromEnum c, fromIntegral i)
41+
42+ go Nothing finishedRanges [] = finishedRanges
43+ go (Just r) finishedRanges [] = r:finishedRanges
44+
45+ go Nothing finishedRanges ((c, width):rest) =
46+ go (Just $ WidthTableRange c 1 width) finishedRanges rest
47+
48+ go (Just r@(WidthTableRange prevCh sz prevWidth)) finishedRanges ((c, width):rest) =
49+ if c == prevCh + sz && prevWidth == width
50+ then go (Just (WidthTableRange prevCh (sz + 1) prevWidth)) finishedRanges rest
51+ else go (Just (WidthTableRange c 1 width)) (r:finishedRanges) rest
52+
53+ in go Nothing [] convertedPairs
54+
55+-- The uppermost code point to consider when building Unicode width
56+-- tables.
57+defaultUnicodeTableUpperBound :: Char
58+defaultUnicodeTableUpperBound = '\xe0000'
59+
60+-- | Construct a unicode character width table by querying the terminal
61+-- connected to stdout. This works by emitting characters to stdout
62+-- and then querying the terminal to determine the resulting cursor
63+-- position in order to measure character widths. Consequently this will
64+-- generate a lot of output and may take a while, depending on your
65+-- system performance. This should not be run in a terminal while it is
66+-- controlled by Vty.
67+--
68+-- The argument specifies the upper bound code point to test when
69+-- building the table. This allows callers to decide how much of the
70+-- Unicode code point space to scan when building the table.
71+--
72+-- This does not handle exceptions.
73+buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
74+buildUnicodeWidthTable tableUpperBound = do
75+ pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i ->
76+ (i,) <$> charWidth i
77+
78+ return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs
79+ }
src/Graphics/Vty/UnicodeWidthTable/Types.hsnew file+29
@@ -0,0 +1,29 @@
1+module Graphics.Vty.UnicodeWidthTable.Types
2+ ( UnicodeWidthTable(..)
3+ , WidthTableRange(..)
4+ )
5+where
6+
7+import Data.Word (Word8, Word32)
8+
9+-- | A range of code points in a width table.
10+data WidthTableRange =
11+ WidthTableRange { rangeStart :: Word32
12+ -- ^ The range's starting code point.
13+ , rangeSize :: Word32
14+ -- ^ The number of code points in the contiguous
15+ -- range, beginning with the starting code point
16+ -- ('rangeStart').
17+ , rangeColumns :: Word8
18+ -- ^ The terminal width, in columns, of all of the
19+ -- characters corresponding to the code points in
20+ -- this range.
21+ }
22+ deriving (Eq, Show)
23+
24+-- | A run-length-encoded table of Unicode character widths.
25+data UnicodeWidthTable =
26+ UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
27+ -- ^ The ranges in the table.
28+ }
29+ deriving (Show)
test/BenchImageFuzz.hs+1−3
@@ -8,8 +8,6 @@ import Verify
8import Control.Applicative
8import Control.Applicative
9import Control.Monad
9import Control.Monad
10
10
11−import Data.Default (def)
12−
13import System.Random
11import System.Random
14
12
15rand :: Arbitrary a => IO a
13rand :: Arbitrary a => IO a
@@ -21,7 +19,7 @@ randomImage = rand
21randomPicture = picForImage <$> randomImage
19randomPicture = picForImage <$> randomImage
22
20
23bench0 = do
21bench0 = do
24− vty <- mkVty def
22+ vty <- mkVty defaultConfig
25 (w,h) <- displayBounds $ outputIface vty
23 (w,h) <- displayBounds $ outputIface vty
26 let pictures = replicateM 3000 randomPicture
24 let pictures = replicateM 3000 randomPicture
27 bench ps = do
25 bench ps = do
test/BenchNoDiffOpt.hs+1−2
@@ -9,7 +9,6 @@ import Control.Concurrent( threadDelay )
9import Control.Monad( liftM2 )
9import Control.Monad( liftM2 )
10
10
11import qualified Data.ByteString.Char8 as B
11import qualified Data.ByteString.Char8 as B
12−import Data.Default (def)
13import Data.List
12import Data.List
14
13
15import System.Environment( getArgs )
14import System.Environment( getArgs )
@@ -19,7 +18,7 @@ import System.Random
19bench0 = do
18bench0 = do
20 let fixedGen = mkStdGen 0
19 let fixedGen = mkStdGen 0
21 setStdGen fixedGen
20 setStdGen fixedGen
22− vty <- mkVty def
21+ vty <- mkVty defaultConfig
23 (w,h) <- displayBounds $ outputIface vty
22 (w,h) <- displayBounds $ outputIface vty
24 let images = return $ (image0, image1)
23 let images = return $ (image0, image1)
25 image0 = charFill defAttr 'X' w h
24 image0 = charFill defAttr 'X' w h
test/BenchRenderChar.hs+6−8
@@ -1,7 +1,7 @@
1−{- benchmarks composing images using the renderChar operation.
1+-- benchmarks composing images using the renderChar operation. This is
2− - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally
2+-- what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar
3− - composed should provide no worse performance than a fill render op.
3+-- images horizontally composed should provide no worse performance than
4− -}
4+-- a fill render op.
5module BenchRenderChar where
5module BenchRenderChar where
6
6
7import Graphics.Vty
7import Graphics.Vty
@@ -9,10 +9,8 @@ import Verify
9
9
10import Control.Monad ( forM_ )
10import Control.Monad ( forM_ )
11
11
12−import Data.Default (def)
13−
14bench0 = do
12bench0 = do
15− vty <- mkVty def
13+ vty <- mkVty defaultConfig
16 (w,h) <- displayBounds $ outputIface vty
14 (w,h) <- displayBounds $ outputIface vty
17 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
15 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
18 bench d = do
16 bench d = do
@@ -28,7 +26,7 @@ testImageUsingChar c w h
28 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
26 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
29
27
30bench1 = do
28bench1 = do
31− vty <- mkVty def
29+ vty <- mkVty defaultConfig
32 (w,h) <- displayBounds $ outputIface vty
30 (w,h) <- displayBounds $ outputIface vty
33 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
31 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
34 bench d = do
32 bench d = do
test/BenchVerticalScroll.hs+1−2
@@ -6,7 +6,6 @@ import Verify
6import Control.Concurrent( threadDelay )
6import Control.Concurrent( threadDelay )
7import Control.Monad( liftM2 )
7import Control.Monad( liftM2 )
8
8
9−import Data.Default (def)
10import Data.List
9import Data.List
11import Data.Word
10import Data.Word
12
11
@@ -17,7 +16,7 @@ import System.Random
17bench0 = do
16bench0 = do
18 let fixedGen = mkStdGen 0
17 let fixedGen = mkStdGen 0
19 setStdGen fixedGen
18 setStdGen fixedGen
20− return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)
19+ return $ Bench (return ()) (\() -> mkVty defaultConfig >>= liftM2 (>>) run shutdown)
21
20
22run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)
21run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)
23
22
test/EventEcho.hs+1−2
@@ -6,7 +6,6 @@ import Control.Applicative
6import Control.Arrow
6import Control.Arrow
7import Control.Monad.RWS
7import Control.Monad.RWS
8
8
9−import Data.Default (def)
10import Data.Sequence (Seq, (<|) )
9import Data.Sequence (Seq, (<|) )
11import qualified Data.Sequence as Seq
10import qualified Data.Sequence as Seq
12import Data.Foldable
11import Data.Foldable
@@ -16,7 +15,7 @@ eventBufferSize = 1000
16type App = RWST Vty () (Seq String) IO
15type App = RWST Vty () (Seq String) IO
17
16
18main = do
17main = do
19− vty <- mkVty def
18+ vty <- mkVty defaultConfig
20 _ <- execRWST (vtyInteract False) vty Seq.empty
19 _ <- execRWST (vtyInteract False) vty Seq.empty
21 shutdown vty
20 shutdown vty
22
21
test/HereDoc.hs+2−4
@@ -1,8 +1,7 @@
1{-# LANGUAGE QuasiQuotes #-}
1{-# LANGUAGE QuasiQuotes #-}
2{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
3−{- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/
3+-- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/
4− - copyright unknown?
4+-- copyright unknown?
5− -}
6module HereDoc (heredoc) where
5module HereDoc (heredoc) where
7
6
8import Language.Haskell.TH.Quote
7import Language.Haskell.TH.Quote
@@ -11,4 +10,3 @@ import Language.Haskell.TH.Lib
11
10
12heredoc :: QuasiQuoter
11heredoc :: QuasiQuoter
13heredoc = QuasiQuoter (litE . stringL) (litP . stringL) undefined undefined
12heredoc = QuasiQuoter (litE . stringL) (litP . stringL) undefined undefined
14−
test/Issue18.hs+1−2
@@ -1,5 +1,4 @@
1−module Main
1+module Main where
2− where
3
2
4import Graphics.Vty
3import Graphics.Vty
5import Graphics.Vty.Debug
4import Graphics.Vty.Debug
test/MinimalExample.hs+1−3
@@ -2,10 +2,8 @@ module Main where
2
2
3import Graphics.Vty
3import Graphics.Vty
4
4
5−import Data.Default
6−
7main = do
5main = do
8− vty <- mkVty def
6+ vty <- mkVty defaultConfig
9 let line0 = string (def `withForeColor` green) "first line"
7 let line0 = string (def `withForeColor` green) "first line"
10 line1 = string (def `withBackColor` blue) "second line"
8 line1 = string (def `withBackColor` blue) "second line"
11 img = line0 <-> line1
9 img = line0 <-> line1
test/Rogue.hs+1−3
@@ -1,10 +1,8 @@
1−{-# LANGUAGE TemplateHaskell #-}
2module Main where
1module Main where
3
2
4import Graphics.Vty
3import Graphics.Vty
5
4
6import Data.Array
5import Data.Array
7−import Data.Default (def)
8
6
9import Control.Applicative
7import Control.Applicative
10import Control.Monad
8import Control.Monad
@@ -43,7 +41,7 @@ type Coord = (Int, Int)
43
41
44main :: IO ()
42main :: IO ()
45main = do
43main = do
46− vty <- mkVty def
44+ vty <- mkVty defaultConfig
47 level0 <- mkLevel 1
45 level0 <- mkLevel 1
48 let world0 = World (Player (levelStart level0)) level0
46 let world0 = World (Player (levelStart level0)) level0
49 (_finalWorld, ()) <- execRWST play vty world0
47 (_finalWorld, ()) <- execRWST play vty world0
test/Test2.hs+1
@@ -1,4 +1,5 @@
1module Main where
1module Main where
2+
2import Graphics.Vty
3import Graphics.Vty
3
4
4main = do
5main = do
test/Verify.hs+18−28
@@ -1,29 +1,29 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE CPP #-}
5{-# LANGUAGE TypeSynonymInstances #-}
4{-# LANGUAGE TypeSynonymInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE DisambiguateRecordFields #-}
7{-# LANGUAGE DisambiguateRecordFields #-}
9{-# LANGUAGE NamedFieldPuns #-}
8{-# LANGUAGE NamedFieldPuns #-}
10−module Verify ( module Verify
9+module Verify
10+ ( module Verify
11− , module Control.Applicative
11+ , module Control.Applicative
12− , module Control.DeepSeq
12+ , module Control.DeepSeq
13− , module Control.Exception
13+ , module Control.Exception
14− , module Control.Monad
14+ , module Control.Monad
15− , module Test.QuickCheck
15+ , module Test.QuickCheck
16− , module Test.QuickCheck.Modifiers
16+ , module Test.QuickCheck.Modifiers
17− , module Text.Printf
17+ , module Text.Printf
18− , succeeded
18+ , succeeded
19− , failed
19+ , failed
20− , monadicIO
20+ , monadicIO
21− , liftIO
21+ , liftIO
22− , liftBool
22+ , liftBool
23− , Test(..)
23+ , Test(..)
24− , Prop.Result(..)
24+ , Prop.Result(..)
25− )
25+ )
26− where
26+where
27
27
28import Control.Exception ( bracket, try, SomeException(..) )
28import Control.Exception ( bracket, try, SomeException(..) )
29
29
@@ -85,15 +85,5 @@ instance Arbitrary DoubleColumnChar where
85liftIOResult :: Testable prop => IO prop -> Property
85liftIOResult :: Testable prop => IO prop -> Property
86liftIOResult = ioProperty
86liftIOResult = ioProperty
87
87
88−#if __GLASGOW_HASKELL__ <= 701
89−instance Random Word where
90− random g =
91− let (i :: Int, g') = random g
92− in (toEnum i, g')
93− randomR (l,h) g =
94− let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g
95− in (toEnum i, g')
96−#endif
97−
98data Bench where
88data Bench where
99 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
89 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
test/Verify/Data/Terminfo/Parse.hs+5−4
@@ -1,7 +1,8 @@
1−module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse
1+module Verify.Data.Terminfo.Parse
2+ ( module Verify.Data.Terminfo.Parse
2− , module Data.Terminfo.Parse
3+ , module Data.Terminfo.Parse
3− )
4+ )
4− where
5+where
5
6
6import Data.Terminfo.Parse
7import Data.Terminfo.Parse
7import Data.Terminfo.Eval
8import Data.Terminfo.Eval
test/Verify/Graphics/Vty/Attributes.hs+5−4
@@ -1,7 +1,8 @@
1−module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes
1+module Verify.Graphics.Vty.Attributes
2+ ( module Verify.Graphics.Vty.Attributes
2− , module Graphics.Vty.Attributes
3+ , module Graphics.Vty.Attributes
3− )
4+ )
4− where
5+where
5
6
6import Graphics.Vty.Attributes
7import Graphics.Vty.Attributes
7import Verify
8import Verify
test/Verify/Graphics/Vty/DisplayAttributes.hs+5−5
@@ -1,8 +1,8 @@
1−module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes
1+module Verify.Graphics.Vty.DisplayAttributes
2+ ( module Verify.Graphics.Vty.DisplayAttributes
2− , module Graphics.Vty.DisplayAttributes
3+ , module Graphics.Vty.DisplayAttributes
3− )
4+ )
4− where
5+where
5
6
6import Graphics.Vty.DisplayAttributes
7import Graphics.Vty.DisplayAttributes
7import Verify
8import Verify
8−
test/Verify/Graphics/Vty/Image.hs+8−7
@@ -1,10 +1,11 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE DisambiguateRecordFields #-}
3{-# LANGUAGE DisambiguateRecordFields #-}
4−module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image
4+module Verify.Graphics.Vty.Image
5+ ( module Verify.Graphics.Vty.Image
5− , module Graphics.Vty.Image
6+ , module Graphics.Vty.Image
6− )
7+ )
7− where
8+where
8
9
9import Verify.Graphics.Vty.Attributes
10import Verify.Graphics.Vty.Attributes
10import Graphics.Vty.Image
11import Graphics.Vty.Image
@@ -100,9 +101,9 @@ instance Arbitrary ImageResize where
100
101
101instance Arbitrary SingleRowSingleAttrImage where
102instance Arbitrary SingleRowSingleAttrImage where
102 arbitrary = do
103 arbitrary = do
103− -- The text must contain at least one character. Otherwise the image simplifies to the
104+ -- The text must contain at least one character. Otherwise the
105+ -- image simplifies to the IdImage which has a height of 0. If
104− -- IdImage which has a height of 0. If this is to represent a single row then the height
106+ -- this is to represent a single row then the height must be 1
105− -- must be 1
106 singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)
107 singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)
107 a <- arbitrary
108 a <- arbitrary
108 let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]
109 let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]
test/Verify/Graphics/Vty/Output.hs+4−5
@@ -4,16 +4,15 @@ import Control.Applicative ((<$>))
4
4
5import Graphics.Vty.Output.Mock
5import Graphics.Vty.Output.Mock
6
6
7−import qualified Data.ByteString as BS
8import Data.IORef
7import Data.IORef
9import qualified Data.String.UTF8 as UTF8
8import qualified Data.String.UTF8 as UTF8
10
9
11import Test.QuickCheck.Property
10import Test.QuickCheck.Property
12
11
13−-- A list of terminals that should be supported.
12+-- A list of terminals that should be supported. This started with a
14−-- This started with a list of terminals ubuntu supported. Then those terminals that really could
13+-- list of terminals ubuntu supported. Then those terminals that really
15−-- not be supported were removed. Then a few more were pruned until a reasonable looking set was
14+-- could not be supported were removed. Then a few more were pruned
16−-- made.
15+-- until a reasonable looking set was made.
17terminalsOfInterest :: [String]
16terminalsOfInterest :: [String]
18terminalsOfInterest =
17terminalsOfInterest =
19 [ "vt100"
18 [ "vt100"
test/Verify/Graphics/Vty/Picture.hs+5−4
@@ -1,8 +1,9 @@
1{-# LANGUAGE DisambiguateRecordFields #-}
1{-# LANGUAGE DisambiguateRecordFields #-}
2−module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture
2+module Verify.Graphics.Vty.Picture
3+ ( module Verify.Graphics.Vty.Picture
3− , module Graphics.Vty.Picture
4+ , module Graphics.Vty.Picture
4− )
5+ )
5− where
6+where
6
7
7import Verify.Graphics.Vty.Prelude
8import Verify.Graphics.Vty.Prelude
8
9
test/Verify/Graphics/Vty/Prelude.hs+5−7
@@ -1,10 +1,8 @@
1−module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude
1+module Verify.Graphics.Vty.Prelude
2− , module Graphics.Vty.Prelude
2+ ( module Verify.Graphics.Vty.Prelude
3− , MockWindow(..)
3+ , MockWindow(..)
4− )
4+ )
5− where
5+where
6−
7−import Graphics.Vty.Prelude
8
6
9import Graphics.Vty.Debug
7import Graphics.Vty.Debug
10
8
test/Verify/Graphics/Vty/Span.hs+6−5
@@ -1,8 +1,9 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2−module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span
2+module Verify.Graphics.Vty.Span
3+ ( module Verify.Graphics.Vty.Span
3− , module Graphics.Vty.Span
4+ , module Graphics.Vty.Span
4− )
5+ )
5− where
6+where
6
7
7import Graphics.Vty.Debug
8import Graphics.Vty.Debug
8import Graphics.Vty.Span
9import Graphics.Vty.Span
@@ -19,7 +20,7 @@ isAttrSpanOp TextSpan {} = True
19isAttrSpanOp _ = False
20isAttrSpanOp _ = False
20
21
21verifyAllSpansHaveWidth i spans w
22verifyAllSpansHaveWidth i spans w
22− = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)
23+ = let v = map (\s -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)
23 in case any ((== True) . fst) v of
24 in case any ((== True) . fst) v of
24 False -> succeeded
25 False -> succeeded
25 True -> failed { reason = "Not all spans contained operations defining exactly "
26 True -> failed { reason = "Not all spans contained operations defining exactly "
test/VerifyAttributeOps.hsdeleted−9
@@ -1,9 +0,0 @@
1−module VerifyAttributeOps where
2−
3−import Verify.Graphics.Vty.Attributes
4−
5−import Verify
6−
7−tests :: IO [Test]
8−tests = return []
9−
test/VerifyColor240.hsnew file+269
@@ -0,0 +1,269 @@
1+module VerifyColor240 where
2+
3+import Data.Word(Word8)
4+import Verify
5+
6+import Graphics.Vty.Attributes.Color240(rgbColorToColor240)
7+
8+oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8
9+oldRgbColorToColor240 r g b
10+ | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
11+ | r == 8 && g == 8 && b == 8 = 216
12+ | r == 18 && g == 18 && b == 18 = 217
13+ | r == 28 && g == 28 && b == 28 = 218
14+ | r == 38 && g == 38 && b == 38 = 219
15+ | r == 48 && g == 48 && b == 48 = 220
16+ | r == 58 && g == 58 && b == 58 = 221
17+ | r == 68 && g == 68 && b == 68 = 222
18+ | r == 78 && g == 78 && b == 78 = 223
19+ | r == 88 && g == 88 && b == 88 = 224
20+ | r == 98 && g == 98 && b == 98 = 225
21+ | r == 108 && g == 108 && b == 108 = 226
22+ | r == 118 && g == 118 && b == 118 = 227
23+ | r == 128 && g == 128 && b == 128 = 228
24+ | r == 138 && g == 138 && b == 138 = 229
25+ | r == 148 && g == 148 && b == 148 = 230
26+ | r == 158 && g == 158 && b == 158 = 231
27+ | r == 168 && g == 168 && b == 168 = 232
28+ | r == 178 && g == 178 && b == 178 = 233
29+ | r == 188 && g == 188 && b == 188 = 234
30+ | r == 198 && g == 198 && b == 198 = 235
31+ | r == 208 && g == 208 && b == 208 = 236
32+ | r == 218 && g == 218 && b == 218 = 237
33+ | r == 228 && g == 228 && b == 228 = 238
34+ | r == 238 && g == 238 && b == 238 = 239
35+ | r <= 0 && g <= 0 && b <= 0 = 0
36+ | r <= 0 && g <= 0 && b <= 95 = 1
37+ | r <= 0 && g <= 0 && b <= 135 = 2
38+ | r <= 0 && g <= 0 && b <= 175 = 3
39+ | r <= 0 && g <= 0 && b <= 215 = 4
40+ | r <= 0 && g <= 0 && b <= 255 = 5
41+ | r <= 0 && g <= 95 && b <= 0 = 6
42+ | r <= 0 && g <= 95 && b <= 95 = 7
43+ | r <= 0 && g <= 95 && b <= 135 = 8
44+ | r <= 0 && g <= 95 && b <= 175 = 9
45+ | r <= 0 && g <= 95 && b <= 215 = 10
46+ | r <= 0 && g <= 95 && b <= 255 = 11
47+ | r <= 0 && g <= 135 && b <= 0 = 12
48+ | r <= 0 && g <= 135 && b <= 95 = 13
49+ | r <= 0 && g <= 135 && b <= 135 = 14
50+ | r <= 0 && g <= 135 && b <= 175 = 15
51+ | r <= 0 && g <= 135 && b <= 215 = 16
52+ | r <= 0 && g <= 135 && b <= 255 = 17
53+ | r <= 0 && g <= 175 && b <= 0 = 18
54+ | r <= 0 && g <= 175 && b <= 95 = 19
55+ | r <= 0 && g <= 175 && b <= 135 = 20
56+ | r <= 0 && g <= 175 && b <= 175 = 21
57+ | r <= 0 && g <= 175 && b <= 215 = 22
58+ | r <= 0 && g <= 175 && b <= 255 = 23
59+ | r <= 0 && g <= 215 && b <= 0 = 24
60+ | r <= 0 && g <= 215 && b <= 95 = 25
61+ | r <= 0 && g <= 215 && b <= 135 = 26
62+ | r <= 0 && g <= 215 && b <= 175 = 27
63+ | r <= 0 && g <= 215 && b <= 215 = 28
64+ | r <= 0 && g <= 215 && b <= 255 = 29
65+ | r <= 0 && g <= 255 && b <= 0 = 30
66+ | r <= 0 && g <= 255 && b <= 95 = 31
67+ | r <= 0 && g <= 255 && b <= 135 = 32
68+ | r <= 0 && g <= 255 && b <= 175 = 33
69+ | r <= 0 && g <= 255 && b <= 215 = 34
70+ | r <= 0 && g <= 255 && b <= 255 = 35
71+ | r <= 95 && g <= 0 && b <= 0 = 36
72+ | r <= 95 && g <= 0 && b <= 95 = 37
73+ | r <= 95 && g <= 0 && b <= 135 = 38
74+ | r <= 95 && g <= 0 && b <= 175 = 39
75+ | r <= 95 && g <= 0 && b <= 215 = 40
76+ | r <= 95 && g <= 0 && b <= 255 = 41
77+ | r <= 95 && g <= 95 && b <= 0 = 42
78+ | r <= 95 && g <= 95 && b <= 95 = 43
79+ | r <= 95 && g <= 95 && b <= 135 = 44
80+ | r <= 95 && g <= 95 && b <= 175 = 45
81+ | r <= 95 && g <= 95 && b <= 215 = 46
82+ | r <= 95 && g <= 95 && b <= 255 = 47
83+ | r <= 95 && g <= 135 && b <= 0 = 48
84+ | r <= 95 && g <= 135 && b <= 95 = 49
85+ | r <= 95 && g <= 135 && b <= 135 = 50
86+ | r <= 95 && g <= 135 && b <= 175 = 51
87+ | r <= 95 && g <= 135 && b <= 215 = 52
88+ | r <= 95 && g <= 135 && b <= 255 = 53
89+ | r <= 95 && g <= 175 && b <= 0 = 54
90+ | r <= 95 && g <= 175 && b <= 95 = 55
91+ | r <= 95 && g <= 175 && b <= 135 = 56
92+ | r <= 95 && g <= 175 && b <= 175 = 57
93+ | r <= 95 && g <= 175 && b <= 215 = 58
94+ | r <= 95 && g <= 175 && b <= 255 = 59
95+ | r <= 95 && g <= 215 && b <= 0 = 60
96+ | r <= 95 && g <= 215 && b <= 95 = 61
97+ | r <= 95 && g <= 215 && b <= 135 = 62
98+ | r <= 95 && g <= 215 && b <= 175 = 63
99+ | r <= 95 && g <= 215 && b <= 215 = 64
100+ | r <= 95 && g <= 215 && b <= 255 = 65
101+ | r <= 95 && g <= 255 && b <= 0 = 66
102+ | r <= 95 && g <= 255 && b <= 95 = 67
103+ | r <= 95 && g <= 255 && b <= 135 = 68
104+ | r <= 95 && g <= 255 && b <= 175 = 69
105+ | r <= 95 && g <= 255 && b <= 215 = 70
106+ | r <= 95 && g <= 255 && b <= 255 = 71
107+ | r <= 135 && g <= 0 && b <= 0 = 72
108+ | r <= 135 && g <= 0 && b <= 95 = 73
109+ | r <= 135 && g <= 0 && b <= 135 = 74
110+ | r <= 135 && g <= 0 && b <= 175 = 75
111+ | r <= 135 && g <= 0 && b <= 215 = 76
112+ | r <= 135 && g <= 0 && b <= 255 = 77
113+ | r <= 135 && g <= 95 && b <= 0 = 78
114+ | r <= 135 && g <= 95 && b <= 95 = 79
115+ | r <= 135 && g <= 95 && b <= 135 = 80
116+ | r <= 135 && g <= 95 && b <= 175 = 81
117+ | r <= 135 && g <= 95 && b <= 215 = 82
118+ | r <= 135 && g <= 95 && b <= 255 = 83
119+ | r <= 135 && g <= 135 && b <= 0 = 84
120+ | r <= 135 && g <= 135 && b <= 95 = 85
121+ | r <= 135 && g <= 135 && b <= 135 = 86
122+ | r <= 135 && g <= 135 && b <= 175 = 87
123+ | r <= 135 && g <= 135 && b <= 215 = 88
124+ | r <= 135 && g <= 135 && b <= 255 = 89
125+ | r <= 135 && g <= 175 && b <= 0 = 90
126+ | r <= 135 && g <= 175 && b <= 95 = 91
127+ | r <= 135 && g <= 175 && b <= 135 = 92
128+ | r <= 135 && g <= 175 && b <= 175 = 93
129+ | r <= 135 && g <= 175 && b <= 215 = 94
130+ | r <= 135 && g <= 175 && b <= 255 = 95
131+ | r <= 135 && g <= 215 && b <= 0 = 96
132+ | r <= 135 && g <= 215 && b <= 95 = 97
133+ | r <= 135 && g <= 215 && b <= 135 = 98
134+ | r <= 135 && g <= 215 && b <= 175 = 99
135+ | r <= 135 && g <= 215 && b <= 215 = 100
136+ | r <= 135 && g <= 215 && b <= 255 = 101
137+ | r <= 135 && g <= 255 && b <= 0 = 102
138+ | r <= 135 && g <= 255 && b <= 95 = 103
139+ | r <= 135 && g <= 255 && b <= 135 = 104
140+ | r <= 135 && g <= 255 && b <= 175 = 105
141+ | r <= 135 && g <= 255 && b <= 215 = 106
142+ | r <= 135 && g <= 255 && b <= 255 = 107
143+ | r <= 175 && g <= 0 && b <= 0 = 108
144+ | r <= 175 && g <= 0 && b <= 95 = 109
145+ | r <= 175 && g <= 0 && b <= 135 = 110
146+ | r <= 175 && g <= 0 && b <= 175 = 111
147+ | r <= 175 && g <= 0 && b <= 215 = 112
148+ | r <= 175 && g <= 0 && b <= 255 = 113
149+ | r <= 175 && g <= 95 && b <= 0 = 114
150+ | r <= 175 && g <= 95 && b <= 95 = 115
151+ | r <= 175 && g <= 95 && b <= 135 = 116
152+ | r <= 175 && g <= 95 && b <= 175 = 117
153+ | r <= 175 && g <= 95 && b <= 215 = 118
154+ | r <= 175 && g <= 95 && b <= 255 = 119
155+ | r <= 175 && g <= 135 && b <= 0 = 120
156+ | r <= 175 && g <= 135 && b <= 95 = 121
157+ | r <= 175 && g <= 135 && b <= 135 = 122
158+ | r <= 175 && g <= 135 && b <= 175 = 123
159+ | r <= 175 && g <= 135 && b <= 215 = 124
160+ | r <= 175 && g <= 135 && b <= 255 = 125
161+ | r <= 175 && g <= 175 && b <= 0 = 126
162+ | r <= 175 && g <= 175 && b <= 95 = 127
163+ | r <= 175 && g <= 175 && b <= 135 = 128
164+ | r <= 175 && g <= 175 && b <= 175 = 129
165+ | r <= 175 && g <= 175 && b <= 215 = 130
166+ | r <= 175 && g <= 175 && b <= 255 = 131
167+ | r <= 175 && g <= 215 && b <= 0 = 132
168+ | r <= 175 && g <= 215 && b <= 95 = 133
169+ | r <= 175 && g <= 215 && b <= 135 = 134
170+ | r <= 175 && g <= 215 && b <= 175 = 135
171+ | r <= 175 && g <= 215 && b <= 215 = 136
172+ | r <= 175 && g <= 215 && b <= 255 = 137
173+ | r <= 175 && g <= 255 && b <= 0 = 138
174+ | r <= 175 && g <= 255 && b <= 95 = 139
175+ | r <= 175 && g <= 255 && b <= 135 = 140
176+ | r <= 175 && g <= 255 && b <= 175 = 141
177+ | r <= 175 && g <= 255 && b <= 215 = 142
178+ | r <= 175 && g <= 255 && b <= 255 = 143
179+ | r <= 215 && g <= 0 && b <= 0 = 144
180+ | r <= 215 && g <= 0 && b <= 95 = 145
181+ | r <= 215 && g <= 0 && b <= 135 = 146
182+ | r <= 215 && g <= 0 && b <= 175 = 147
183+ | r <= 215 && g <= 0 && b <= 215 = 148
184+ | r <= 215 && g <= 0 && b <= 255 = 149
185+ | r <= 215 && g <= 95 && b <= 0 = 150
186+ | r <= 215 && g <= 95 && b <= 95 = 151
187+ | r <= 215 && g <= 95 && b <= 135 = 152
188+ | r <= 215 && g <= 95 && b <= 175 = 153
189+ | r <= 215 && g <= 95 && b <= 215 = 154
190+ | r <= 215 && g <= 95 && b <= 255 = 155
191+ | r <= 215 && g <= 135 && b <= 0 = 156
192+ | r <= 215 && g <= 135 && b <= 95 = 157
193+ | r <= 215 && g <= 135 && b <= 135 = 158
194+ | r <= 215 && g <= 135 && b <= 175 = 159
195+ | r <= 215 && g <= 135 && b <= 215 = 160
196+ | r <= 215 && g <= 135 && b <= 255 = 161
197+ | r <= 215 && g <= 175 && b <= 0 = 162
198+ | r <= 215 && g <= 175 && b <= 95 = 163
199+ | r <= 215 && g <= 175 && b <= 135 = 164
200+ | r <= 215 && g <= 175 && b <= 175 = 165
201+ | r <= 215 && g <= 175 && b <= 215 = 166
202+ | r <= 215 && g <= 175 && b <= 255 = 167
203+ | r <= 215 && g <= 215 && b <= 0 = 168
204+ | r <= 215 && g <= 215 && b <= 95 = 169
205+ | r <= 215 && g <= 215 && b <= 135 = 170
206+ | r <= 215 && g <= 215 && b <= 175 = 171
207+ | r <= 215 && g <= 215 && b <= 215 = 172
208+ | r <= 215 && g <= 215 && b <= 255 = 173
209+ | r <= 215 && g <= 255 && b <= 0 = 174
210+ | r <= 215 && g <= 255 && b <= 95 = 175
211+ | r <= 215 && g <= 255 && b <= 135 = 176
212+ | r <= 215 && g <= 255 && b <= 175 = 177
213+ | r <= 215 && g <= 255 && b <= 215 = 178
214+ | r <= 215 && g <= 255 && b <= 255 = 179
215+ | r <= 255 && g <= 0 && b <= 0 = 180
216+ | r <= 255 && g <= 0 && b <= 95 = 181
217+ | r <= 255 && g <= 0 && b <= 135 = 182
218+ | r <= 255 && g <= 0 && b <= 175 = 183
219+ | r <= 255 && g <= 0 && b <= 215 = 184
220+ | r <= 255 && g <= 0 && b <= 255 = 185
221+ | r <= 255 && g <= 95 && b <= 0 = 186
222+ | r <= 255 && g <= 95 && b <= 95 = 187
223+ | r <= 255 && g <= 95 && b <= 135 = 188
224+ | r <= 255 && g <= 95 && b <= 175 = 189
225+ | r <= 255 && g <= 95 && b <= 215 = 190
226+ | r <= 255 && g <= 95 && b <= 255 = 191
227+ | r <= 255 && g <= 135 && b <= 0 = 192
228+ | r <= 255 && g <= 135 && b <= 95 = 193
229+ | r <= 255 && g <= 135 && b <= 135 = 194
230+ | r <= 255 && g <= 135 && b <= 175 = 195
231+ | r <= 255 && g <= 135 && b <= 215 = 196
232+ | r <= 255 && g <= 135 && b <= 255 = 197
233+ | r <= 255 && g <= 175 && b <= 0 = 198
234+ | r <= 255 && g <= 175 && b <= 95 = 199
235+ | r <= 255 && g <= 175 && b <= 135 = 200
236+ | r <= 255 && g <= 175 && b <= 175 = 201
237+ | r <= 255 && g <= 175 && b <= 215 = 202
238+ | r <= 255 && g <= 175 && b <= 255 = 203
239+ | r <= 255 && g <= 215 && b <= 0 = 204
240+ | r <= 255 && g <= 215 && b <= 95 = 205
241+ | r <= 255 && g <= 215 && b <= 135 = 206
242+ | r <= 255 && g <= 215 && b <= 175 = 207
243+ | r <= 255 && g <= 215 && b <= 215 = 208
244+ | r <= 255 && g <= 215 && b <= 255 = 209
245+ | r <= 255 && g <= 255 && b <= 0 = 210
246+ | r <= 255 && g <= 255 && b <= 95 = 211
247+ | r <= 255 && g <= 255 && b <= 135 = 212
248+ | r <= 255 && g <= 255 && b <= 175 = 213
249+ | r <= 255 && g <= 255 && b <= 215 = 214
250+ | r <= 255 && g <= 255 && b <= 255 = 215
251+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
252+ (fromIntegral r :: Int)
253+ (fromIntegral g :: Int)
254+ (fromIntegral b :: Int))
255+
256+sameColor :: Int -> Int -> Int -> Bool
257+sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b
258+
259+genVal :: Gen Int
260+genVal = chooseInt (0, 255)
261+
262+sameColorCheck :: Property
263+sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g)))
264+
265+tests :: IO [Test]
266+tests = return
267+ [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck
268+ ]
269+
test/VerifyConfig.hs+1−3
@@ -4,7 +4,6 @@ module Main where
4import Graphics.Vty.Config
4import Graphics.Vty.Config
5import Graphics.Vty.Input.Events
5import Graphics.Vty.Input.Events
6
6
7−import Data.Default
8import Data.String.QQ
7import Data.String.QQ
9import qualified Data.ByteString.Char8 as B
8import qualified Data.ByteString.Char8 as B
10
9
@@ -24,7 +23,7 @@ debugLog "/tmp/vty-debug.txt"
24|]
23|]
25
24
26exampleConfigConfig :: Config
25exampleConfigConfig :: Config
27−exampleConfigConfig = def
26+exampleConfigConfig = defaultConfig
28 { debugLog = Just "/tmp/vty-debug.txt"
27 { debugLog = Just "/tmp/vty-debug.txt"
29 , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])
28 , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])
30 , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])
29 , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])
@@ -43,4 +42,3 @@ main :: IO ()
43main = defaultMain
42main = defaultMain
44 [ testCase "example config parses" $ exampleConfigParses
43 [ testCase "example config parses" $ exampleConfigParses
45 ]
44 ]
46−
test/VerifyEmptyImageProps.hs+2−1
@@ -1,9 +1,10 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
1module VerifyEmptyImageProps where
2module VerifyEmptyImageProps where
2
3
3import Verify
4import Verify
4
5
5-- should be exported by Graphics.Vty.Picture
6-- should be exported by Graphics.Vty.Picture
6−import Graphics.Vty.Picture ( Image, emptyImage )
7+import Graphics.Vty.Image ( Image, emptyImage )
7
8
8tests :: IO [Test]
9tests :: IO [Test]
9tests = do
10tests = do
test/VerifyEvalTerminfoCaps.hs+5−3
@@ -1,5 +1,6 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
3module VerifyEvalTerminfoCaps where
4module VerifyEvalTerminfoCaps where
4
5
5import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
6import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
@@ -24,7 +25,8 @@ import Foreign.Marshal.Alloc (mallocBytes)
24import Foreign.Ptr (Ptr, minusPtr)
25import Foreign.Ptr (Ptr, minusPtr)
25import Numeric
26import Numeric
26
27
27−-- If a terminal defines one of the caps then it's expected to be parsable.
28+-- If a terminal defines one of the caps then it's expected to be
29+-- parsable.
28capsOfInterest =
30capsOfInterest =
29 [ "cup"
31 [ "cup"
30 , "sc"
32 , "sc"
@@ -49,7 +51,8 @@ fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr na
49
51
50tests :: IO [Test]
52tests :: IO [Test]
51tests = do
53tests = do
52− evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)
54+ -- 1 MB should be big enough for any termcaps ;-)
55+ evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024)
53 fmap concat $ forM terminalsOfInterest $ \termName -> do
56 fmap concat $ forM terminalsOfInterest $ \termName -> do
54 putStrLn $ "adding tests for terminal: " ++ termName
57 putStrLn $ "adding tests for terminal: " ++ termName
55 mti <- try $ Terminfo.setupTerm termName
58 mti <- try $ Terminfo.setupTerm termName
@@ -87,4 +90,3 @@ verifyEvalCap evalBuffer expr !junkInt = do
87 }
90 }
88 | otherwise ->
91 | otherwise ->
89 return succeeded
92 return succeeded
90−
test/VerifyImageOps.hs+2−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
1module VerifyImageOps where
2module VerifyImageOps where
2
3
3import Graphics.Vty.Attributes
4import Graphics.Vty.Attributes
@@ -136,7 +137,7 @@ cropBottomLimitsHeight :: Image -> Int -> Property
136cropBottomLimitsHeight i v = v >= 0 ==>
137cropBottomLimitsHeight i v = v >= 0 ==>
137 v >= imageHeight (cropBottom v i)
138 v >= imageHeight (cropBottom v i)
138
139
139−-- rediculous tests just to satisfy my desire for nice code coverage :-P
140+-- ridiculous tests just to satisfy my desire for nice code coverage :-P
140canShowImage :: Image -> Bool
141canShowImage :: Image -> Bool
141canShowImage i = length (show i) > 0
142canShowImage i = length (show i) > 0
142
143
test/VerifyLayersSpanGeneration.hs+7−5
@@ -4,6 +4,7 @@ module VerifyLayersSpanGeneration where
4
4
5import Verify.Graphics.Vty.Prelude
5import Verify.Graphics.Vty.Prelude
6
6
7+import Verify.Graphics.Vty.Attributes
7import Verify.Graphics.Vty.Image
8import Verify.Graphics.Vty.Image
8import Verify.Graphics.Vty.Picture
9import Verify.Graphics.Vty.Picture
9import Verify.Graphics.Vty.Span
10import Verify.Graphics.Vty.Span
@@ -25,8 +26,9 @@ largerHorizSpanOcclusion row0 row1 =
25 ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)
26 ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)
26 in verifyOpsEquality expectedOps ops
27 in verifyOpsEquality expectedOps ops
27
28
28−-- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the
29+-- | Two rows stacked vertical is equivalent to the first row rendered
30+-- as the top layer and the second row rendered as a bottom layer with a
29−-- second row rendered as a bottom layer with a background fill where the first row would be.
31+-- background fill where the first row would be.
30vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
32vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
31vertStackLayerEquivalence0 row0 row1 =
33vertStackLayerEquivalence0 row0 row1 =
32 let i0 = rowImage row0
34 let i0 = rowImage row0
@@ -52,8 +54,9 @@ vertStackLayerEquivalence1 row0 row1 =
52 opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
54 opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
53 in verifyOpsEquality expectedOps opsLayered
55 in verifyOpsEquality expectedOps opsLayered
54
56
55−-- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the
57+-- | Two rows horiz joined is equivalent to the first row rendered as
58+-- the top layer and the second row rendered as a bottom layer with a
56−-- second row rendered as a bottom layer with a background fill where the first row would be.
59+-- background fill where the first row would be.
57horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
60horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
58horizJoinLayerEquivalence0 row0 row1 =
61horizJoinLayerEquivalence0 row0 row1 =
59 let i0 = rowImage row0
62 let i0 = rowImage row0
@@ -125,4 +128,3 @@ tests = return
125 -- , verify "alternating images using joins is the same as alternating images using layers (1)"
128 -- , verify "alternating images using joins is the same as alternating images using layers (1)"
126 -- horizJoinAlternate1
129 -- horizJoinAlternate1
127 ]
130 ]
128−
test/VerifyOutput.hs+12−9
@@ -1,8 +1,9 @@
1−{- We setup the environment to envoke certain terminals of interest.
1+-- We setup the environment to invoke certain terminals of interest.
2− - This assumes appropriate definitions exist in the current environment for the terminals of
2+-- This assumes appropriate definitions exist in the current environment
3− - interest.
3+-- for the terminals of interest.
4− -}
4+{-# LANGUAGE ScopedTypeVariables #-}
5module VerifyOutput where
5module VerifyOutput where
6+
6import Verify
7import Verify
7
8
8import Graphics.Vty
9import Graphics.Vty
@@ -12,10 +13,7 @@ import Verify.Graphics.Vty.Output
12
13
13import Control.Monad
14import Control.Monad
14
15
15−import Data.Default
16−
17import qualified System.Console.Terminfo as Terminfo
16import qualified System.Console.Terminfo as Terminfo
18−import System.Posix.Env
19import System.Posix.IO
17import System.Posix.IO
20
18
21tests :: IO [Test]
19tests :: IO [Test]
@@ -37,11 +35,16 @@ smokeTestTermNonMac termName i = liftIOResult $ do
37smokeTestTerm :: String -> Image -> IO Result
35smokeTestTerm :: String -> Image -> IO Result
38smokeTestTerm termName i = do
36smokeTestTerm termName i = do
39 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
38+ t <- outputForConfig $ defaultConfig
39+ { outputFd = Just nullOut
40− t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName }
40+ , termName = Just termName
41+ , colorMode = Just NoColor
42+ }
41 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
43 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
42 reserveDisplay t
44 reserveDisplay t
43 dc <- displayContext t (100,100)
45 dc <- displayContext t (100,100)
44− -- always show the cursor to produce tests for terminals with no cursor support.
46+ -- always show the cursor to produce tests for terminals with no
47+ -- cursor support.
45 let pic = (picForImage i) { picCursor = Cursor 0 0 }
48 let pic = (picForImage i) { picCursor = Cursor 0 0 }
46 outputPicture dc pic
49 outputPicture dc pic
47 setCursorPos t 0 0
50 setCursorPos t 0 0
test/VerifyParseTerminfoCaps.hs+1
@@ -1,4 +1,5 @@
1{-# LANGUAGE NamedFieldPuns #-}
1{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyParseTerminfoCaps where
3module VerifyParseTerminfoCaps where
3
4
4import Prelude hiding ( catch )
5import Prelude hiding ( catch )
test/VerifySimpleSpanGeneration.hs+8−8
@@ -25,7 +25,7 @@ unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool
25unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
25unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
26 let p = picForImage i
26 let p = picForImage i
27 ops = displayOpsForPic p (regionForWindow w)
27 ops = displayOpsForPic p (regionForWindow w)
28− in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
28+ in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
29
29
30horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
30horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
31horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
31horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
@@ -37,7 +37,7 @@ horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
37horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
37horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
38 let p = picForImage i
38 let p = picForImage i
39 ops = displayOpsForPic p (regionForWindow w)
39 ops = displayOpsForPic p (regionForWindow w)
40− in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
40+ in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
41
41
42horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result
42horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result
43horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
43horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
@@ -51,7 +51,7 @@ horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expected
51 let p = picForImage i
51 let p = picForImage i
52 w = MockWindow c 1
52 w = MockWindow c 1
53 ops = displayOpsForPic p (regionForWindow w)
53 ops = displayOpsForPic p (regionForWindow w)
54− in spanOpsEffectedRows ops == 1
54+ in spanOpsAffectedRows ops == 1
55
55
56horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result
56horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result
57horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
57horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
@@ -74,7 +74,7 @@ singleAttrSingleSpanStackCropped1 stack =
74 expectedRowCount = stackHeight stack `div` 2
74 expectedRowCount = stackHeight stack `div` 2
75 w = MockWindow (stackWidth stack) expectedRowCount
75 w = MockWindow (stackWidth stack) expectedRowCount
76 ops = displayOpsForPic p (regionForWindow w)
76 ops = displayOpsForPic p (regionForWindow w)
77− actualRowCount = spanOpsEffectedRows ops
77+ actualRowCount = spanOpsAffectedRows ops
78 in expectedRowCount == actualRowCount
78 in expectedRowCount == actualRowCount
79
79
80singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
80singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
@@ -90,7 +90,7 @@ singleAttrSingleSpanStackCropped3 stack0 stack1 =
90 w = MockWindow (imageWidth (picImage p)) expectedRowCount
90 w = MockWindow (imageWidth (picImage p)) expectedRowCount
91 ops = displayOpsForPic p (regionForWindow w)
91 ops = displayOpsForPic p (regionForWindow w)
92 expectedRowCount = imageHeight (picImage p) `div` 2
92 expectedRowCount = imageHeight (picImage p) `div` 2
93− actualRowCount = spanOpsEffectedRows ops
93+ actualRowCount = spanOpsAffectedRows ops
94 in expectedRowCount == actualRowCount
94 in expectedRowCount == actualRowCount
95
95
96singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
96singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
@@ -107,7 +107,7 @@ singleAttrSingleSpanStackCropped5 stack0 stack1 =
107 w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)
107 w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)
108 ops = displayOpsForPic p (regionForWindow w)
108 ops = displayOpsForPic p (regionForWindow w)
109 expectedRowCount = stackHeight stack0
109 expectedRowCount = stackHeight stack0
110− actualRowCount = spanOpsEffectedRows ops
110+ actualRowCount = spanOpsAffectedRows ops
111 in expectedRowCount == actualRowCount
111 in expectedRowCount == actualRowCount
112
112
113horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result
113horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result
@@ -123,13 +123,13 @@ arbImageIsCropped :: DefaultImage -> MockWindow -> Bool
123arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =
123arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =
124 let pic = picForImage image
124 let pic = picForImage image
125 ops = displayOpsForPic pic (regionForWindow win)
125 ops = displayOpsForPic pic (regionForWindow win)
126− in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w )
126+ in ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w )
127
127
128spanOpsActuallyFillRows :: DefaultPic -> Bool
128spanOpsActuallyFillRows :: DefaultPic -> Bool
129spanOpsActuallyFillRows (DefaultPic pic win) =
129spanOpsActuallyFillRows (DefaultPic pic win) =
130 let ops = displayOpsForPic pic (regionForWindow win)
130 let ops = displayOpsForPic pic (regionForWindow win)
131 expectedRowCount = regionHeight (regionForWindow win)
131 expectedRowCount = regionHeight (regionForWindow win)
132− actualRowCount = spanOpsEffectedRows ops
132+ actualRowCount = spanOpsAffectedRows ops
133 in expectedRowCount == actualRowCount
133 in expectedRowCount == actualRowCount
134
134
135spanOpsActuallyFillColumns :: DefaultPic -> Bool
135spanOpsActuallyFillColumns :: DefaultPic -> Bool
test/VerifyUsingMockInput.hs+26−22
@@ -1,8 +1,8 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
3−{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced
4+-- Generate some input bytes and delays between blocks of input bytes.
4− - are as expected.
5+-- Verify the events produced are as expected.
5− -}
6module Main where
6module Main where
7
7
8import Verify.Graphics.Vty.Output
8import Verify.Graphics.Vty.Output
@@ -12,14 +12,12 @@ import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Loop
12import Graphics.Vty.Input.Loop
13import Graphics.Vty.Input.Terminfo
13import Graphics.Vty.Input.Terminfo
14
14
15−import Control.Applicative
16import Control.Concurrent
15import Control.Concurrent
17import Control.Concurrent.STM
16import Control.Concurrent.STM
18import Control.Exception
17import Control.Exception
19import Lens.Micro ((^.))
18import Lens.Micro ((^.))
20import Control.Monad
19import Control.Monad
21
20
22−import Data.Default
23import Data.IORef
21import Data.IORef
24import Data.List (intersperse, reverse, nubBy)
22import Data.List (intersperse, reverse, nubBy)
25
23
@@ -36,7 +34,8 @@ import Test.SmallCheck.Series
36
34
37import Text.Printf
35import Text.Printf
38
36
39−-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
37+-- processing a block of 16 chars is the largest I can do without taking
38+-- too long to run the test.
40maxBlockSize :: Int
39maxBlockSize :: Int
41maxBlockSize = 16
40maxBlockSize = 16
42
41
@@ -47,8 +46,11 @@ forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
47forEachOf l = over (generate (\n -> take n l))
46forEachOf l = over (generate (\n -> take n l))
48
47
49data InputEvent
48data InputEvent
49+ = Bytes String
50− = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
50+ -- ^ Input sequence encoded as a string. Regardless, the input is
51+ -- read a byte at a time.
51− | Delay Int -- | microsecond delay
52+ | Delay Int
53+ -- ^ Microsecond delay
52 deriving Show
54 deriving Show
53
55
54type InputSpec = [InputEvent]
56type InputSpec = [InputEvent]
@@ -111,11 +113,11 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
111 (writeFd, readFd) <- openPseudoTerminal
113 (writeFd, readFd) <- openPseudoTerminal
112 (setTermAttr,_) <- attributeControl readFd
114 (setTermAttr,_) <- attributeControl readFd
113 setTermAttr
115 setTermAttr
114− let testConfig = def { inputFd = Just readFd
116+ let testConfig = defaultConfig { inputFd = Just readFd
115− , termName = Just "dummy"
117+ , termName = Just "dummy"
116− , vmin = Just 1
118+ , vmin = Just 1
117− , vtime = Just 100
119+ , vtime = Just 100
118− }
120+ }
119 input <- initInput testConfig table
121 input <- initInput testConfig table
120 eventsRef <- newIORef []
122 eventsRef <- newIORef []
121 let writeWaitClose = do
123 let writeWaitClose = do
@@ -130,7 +132,9 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
130 readLoop 0 = return ()
132 readLoop 0 = return ()
131 readLoop n = do
133 readLoop n = do
132 e <- atomically $ readTChan $ input^.eventChannel
134 e <- atomically $ readTChan $ input^.eventChannel
135+ case e of
133− modifyIORef eventsRef ((:) e)
136+ InputEvent ev -> modifyIORef eventsRef ((:) ev)
137+ ResumeAfterSignal -> return ()
134 readLoop (n - 1)
138 readLoop (n - 1)
135 genEventsUsingIoActions maxDuration writeWaitClose readEvents
139 genEventsUsingIoActions maxDuration writeWaitClose readEvents
136 outEvents <- reverse <$> readIORef eventsRef
140 outEvents <- reverse <$> readIORef eventsRef
@@ -163,8 +167,8 @@ verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
163
167
164verifyCapsSynInputToEvent :: Property IO
168verifyCapsSynInputToEvent :: Property IO
165verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
169verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
166− forEachOf terminalsOfInterest $ \termName -> monadic $ do
170+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
167− term <- setupTerm termName
171+ term <- setupTerm terminalName
168 let table = capsClassifyMap term keysFromCapsTable
172 let table = capsClassifyMap term keysFromCapsTable
169 inputSeq = gen table
173 inputSeq = gen table
170 events = map snd inputSeq
174 events = map snd inputSeq
@@ -183,9 +187,9 @@ verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
183
187
184verifyFullSynInputToEvent :: Property IO
188verifyFullSynInputToEvent :: Property IO
185verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
189verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
186− forEachOf terminalsOfInterest $ \termName -> monadic $ do
190+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
187− term <- setupTerm termName
191+ term <- setupTerm terminalName
188− let table = classifyMapForTerm termName term
192+ let table = classifyMapForTerm terminalName term
189 inputSeq = gen table
193 inputSeq = gen table
190 events = map snd inputSeq
194 events = map snd inputSeq
191 keydowns = map (Bytes . fst) inputSeq
195 keydowns = map (Bytes . fst) inputSeq
@@ -194,9 +198,9 @@ verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
194
198
195verifyFullSynInputToEvent_2x :: Property IO
199verifyFullSynInputToEvent_2x :: Property IO
196verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
200verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
197− forEachOf terminalsOfInterest $ \termName -> monadic $ do
201+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
198− term <- setupTerm termName
202+ term <- setupTerm terminalName
199− let table = classifyMapForTerm termName term
203+ let table = classifyMapForTerm terminalName term
200 inputSeq = gen table
204 inputSeq = gen table
201 events = concatMap ((\s -> [s,s]) . snd) inputSeq
205 events = concatMap ((\s -> [s,s]) . snd) inputSeq
202 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
206 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
test/VerifyUsingMockTerminal.hs+22−14
@@ -4,9 +4,11 @@ import Verify.Graphics.Vty.Prelude
4
4
5import Verify.Graphics.Vty.Picture
5import Verify.Graphics.Vty.Picture
6import Verify.Graphics.Vty.Image
6import Verify.Graphics.Vty.Image
7+import Verify.Graphics.Vty.Attributes
7import Verify.Graphics.Vty.Span
8import Verify.Graphics.Vty.Span
8import Verify.Graphics.Vty.Output
9import Verify.Graphics.Vty.Output
9import Graphics.Vty.Output
10import Graphics.Vty.Output
11+import Graphics.Vty.Output.Interface
10import Graphics.Vty.Output.Mock
12import Graphics.Vty.Output.Mock
11
13
12import Graphics.Vty.Debug
14import Graphics.Vty.Debug
@@ -39,13 +41,14 @@ singleTRow :: MockWindow -> Property
39singleTRow (MockWindow w h) = liftIOResult $ do
41singleTRow (MockWindow w h) = liftIOResult $ do
40 (mockData,t) <- mockTerminal (w,h)
42 (mockData,t) <- mockTerminal (w,h)
41 dc <- displayBounds t >>= displayContext t
43 dc <- displayBounds t >>= displayContext t
42− -- create an image that contains just the character T repeated for a single row
44+ -- create an image that contains just the character T repeated for a
45+ -- single row
43 let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')
46 let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')
44 pic = (picForImage i) { picBackground = Background 'B' defAttr }
47 pic = (picForImage i) { picBackground = Background 'B' defAttr }
45 outputPicture dc pic
48 outputPicture dc pic
46− -- The mock output string that represents the output bytes a single line containing the T
49+ -- The mock output string that represents the output bytes a single
50+ -- line containing the T string: Followed by h - 1 lines of a change
47− -- string: Followed by h - 1 lines of a change to the background attribute and then the
51+ -- to the background attribute and then the background character
48− -- background character
49 let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'
52 let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'
50 ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')
53 ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')
51 compareMockOutput mockData expected
54 compareMockOutput mockData expected
@@ -54,12 +57,14 @@ manyTRows :: MockWindow -> Property
54manyTRows (MockWindow w h) = liftIOResult $ do
57manyTRows (MockWindow w h) = liftIOResult $ do
55 (mockData, t) <- mockTerminal (w,h)
58 (mockData, t) <- mockTerminal (w,h)
56 dc <- displayBounds t >>= displayContext t
59 dc <- displayBounds t >>= displayContext t
57− -- create an image that contains the character 'T' repeated for all the rows
60+ -- create an image that contains the character 'T' repeated for all
61+ -- the rows
58 let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
62 let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
59 pic = (picForImage i) { picBackground = Background 'B' defAttr }
63 pic = (picForImage i) { picBackground = Background 'B' defAttr }
60 outputPicture dc pic
64 outputPicture dc pic
61− -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
65+ -- The UTF8 string that represents the output bytes is h repeats of
62− -- attribute change. 'A', followed by w 'T's
66+ -- a move, 'M', followed by an attribute change. 'A', followed by w
67+ -- 'T's
63 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
68 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
64 compareMockOutput mockData expected
69 compareMockOutput mockData expected
65
70
@@ -67,12 +72,14 @@ manyTRowsCroppedWidth :: MockWindow -> Property
67manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do
72manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do
68 (mockData,t) <- mockTerminal (w,h)
73 (mockData,t) <- mockTerminal (w,h)
69 dc <- displayBounds t >>= displayContext t
74 dc <- displayBounds t >>= displayContext t
70− -- create an image that contains the character 'T' repeated for all the rows
75+ -- create an image that contains the character 'T' repeated for all
76+ -- the rows
71 let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')
77 let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')
72 pic = (picForImage i) { picBackground = Background 'B' defAttr }
78 pic = (picForImage i) { picBackground = Background 'B' defAttr }
73 outputPicture dc pic
79 outputPicture dc pic
74− -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
80+ -- The UTF8 string that represents the output bytes is h repeats of
75− -- attribute change. 'A', followed by w 'T's
81+ -- a move, 'M', followed by an attribute change. 'A', followed by w
82+ -- 'T's
76 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
83 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
77 compareMockOutput mockData expected
84 compareMockOutput mockData expected
78
85
@@ -80,12 +87,14 @@ manyTRowsCroppedHeight :: MockWindow -> Property
80manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do
87manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do
81 (mockData,t) <- mockTerminal (w,h)
88 (mockData,t) <- mockTerminal (w,h)
82 dc <- displayBounds t >>= displayContext t
89 dc <- displayBounds t >>= displayContext t
83− -- create an image that contains the character 'T' repeated for all the rows
90+ -- create an image that contains the character 'T' repeated for all
91+ -- the rows
84 let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
92 let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
85 pic = (picForImage i) { picBackground = Background 'B' defAttr }
93 pic = (picForImage i) { picBackground = Background 'B' defAttr }
86 outputPicture dc pic
94 outputPicture dc pic
87− -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
95+ -- The UTF8 string that represents the output bytes is h repeats of
88− -- attribute change. 'A', followed by w count 'T's
96+ -- a move, 'M', followed by an attribute change. 'A', followed by w
97+ -- count 'T's
89 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
98 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
90 compareMockOutput mockData expected
99 compareMockOutput mockData expected
91
100
@@ -97,4 +106,3 @@ tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds
97 , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth
106 , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth
98 , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight
107 , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight
99 ]
108 ]
100−
test/VerifyUtf8Width.hs+2
@@ -1,9 +1,11 @@
1module VerifyUtf8Width where
1module VerifyUtf8Width where
2+
2import Verify
3import Verify
3
4
4import Graphics.Text.Width
5import Graphics.Text.Width
5import Graphics.Vty.Attributes
6import Graphics.Vty.Attributes
6import Graphics.Vty.Picture
7import Graphics.Vty.Picture
8+import Graphics.Vty.Image
7
9
8swIs1Column :: SingleColumnChar -> Bool
10swIs1Column :: SingleColumnChar -> Bool
9swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1
11swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1
test/YiIssue264.hs+1
@@ -1,4 +1,5 @@
1module Main where
1module Main where
2+
2import Graphics.Vty
3import Graphics.Vty
3import Control.Exception
4import Control.Exception
4
5
test/interactive_terminal_test.hs+2−3
@@ -12,7 +12,6 @@ import Control.Concurrent (threadDelay)
12import Control.Exception
12import Control.Exception
13import Control.Monad
13import Control.Monad
14
14
15−import Data.Default (def)
16import Data.List ( lookup )
15import Data.List ( lookup )
17import Data.Maybe ( isJust, fromJust )
16import Data.Maybe ( isJust, fromJust )
18import Data.Monoid
17import Data.Monoid
@@ -365,7 +364,7 @@ Did the test output match the description?
365|]
364|]
366 defaultSuccessConfirmResults
365 defaultSuccessConfirmResults
367
366
368−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
369-- This avoids any issues with how the compiler represents string literals.
368-- This avoids any issues with how the compiler represents string literals.
370--
369--
371-- This document is UTF-8 encoded so the UTF-8 string is still included for
370-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -938,7 +937,7 @@ cursorHideTest0 = Test
938 { testName = "Verify the cursor is hid and re-shown. issue #7"
937 { testName = "Verify the cursor is hid and re-shown. issue #7"
939 , testID = "cursorHideTest0"
938 , testID = "cursorHideTest0"
940 , testAction = do
939 , testAction = do
941− vty <- mkVty def
940+ vty <- mkVty defaultConfig
942 showCursor $ outputIface vty
941 showCursor $ outputIface vty
943 setCursorPos (outputIface vty) 5 5
942 setCursorPos (outputIface vty) 5 5
944 nextEvent vty
943 nextEvent vty
test/vty-examples.cabal+5−5
@@ -1,5 +1,5 @@
1name: vty-examples
1name: vty-examples
2−version: 5.6
2+version: 5.7
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
@@ -41,7 +41,7 @@ executable vty-interactive-terminal-test
41 default-extensions: ScopedTypeVariables
41 default-extensions: ScopedTypeVariables
42 ghc-options: -threaded
42 ghc-options: -threaded
43
43
44− build-depends: vty >= 5.2.11,
44+ build-depends: vty >= 5.15,
45 base >= 4 && < 5,
45 base >= 4 && < 5,
46 bytestring,
46 bytestring,
47 containers,
47 containers,
@@ -69,7 +69,7 @@ executable vty-event-echo
69 FlexibleContexts
69 FlexibleContexts
70 ghc-options: -threaded
70 ghc-options: -threaded
71
71
72− build-depends: vty >= 5.2.11,
72+ build-depends: vty >= 5.15,
73 base >= 4 && < 5,
73 base >= 4 && < 5,
74 array,
74 array,
75 bytestring,
75 bytestring,
@@ -89,7 +89,7 @@ executable vty-rogue
89 default-extensions: ScopedTypeVariables
89 default-extensions: ScopedTypeVariables
90 ghc-options: -threaded
90 ghc-options: -threaded
91
91
92− build-depends: vty >= 5.2.11,
92+ build-depends: vty >= 5.15,
93 base >= 4 && < 5,
93 base >= 4 && < 5,
94 array,
94 array,
95 bytestring,
95 bytestring,
@@ -110,7 +110,7 @@ executable vty-benchmark
110 default-extensions: ScopedTypeVariables
110 default-extensions: ScopedTypeVariables
111 ghc-options: -threaded
111 ghc-options: -threaded
112
112
113− build-depends: vty >= 5.2.11,
113+ build-depends: vty >= 5.15,
114 base >= 4 && < 5,
114 base >= 4 && < 5,
115 bytestring,
115 bytestring,
116 Cabal,
116 Cabal,
tools/BuildWidthTable.hsnew file+144
@@ -0,0 +1,144 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE CPP #-}
3+module Main where
4+
5+import qualified Control.Exception as E
6+import Control.Monad (when)
7+import Data.Maybe (fromMaybe)
8+#if !(MIN_VERSION_base(4,11,0))
9+import Data.Semigroup ((<>))
10+#endif
11+import System.Directory (createDirectoryIfMissing)
12+import System.Environment (getArgs, getProgName)
13+import System.FilePath (takeDirectory)
14+import System.Exit (exitFailure)
15+import System.Console.GetOpt
16+import Text.Read (readMaybe)
17+
18+import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName
19+ , vtyConfigPath, addConfigWidthMap
20+ , ConfigUpdateResult(..)
21+ )
22+import Graphics.Vty.UnicodeWidthTable.IO
23+import Graphics.Vty.UnicodeWidthTable.Query
24+
25+data Arg = Help
26+ | OutputPath String
27+ | TableUpperBound String
28+ | UpdateConfig
29+ | VtyConfigPath String
30+ deriving (Eq, Show)
31+
32+options :: Config -> [OptDescr Arg]
33+options config =
34+ [ Option "h" ["help"] (NoArg Help)
35+ "This help output"
36+ , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")
37+ ("The maximum Unicode code point to test when building the table " <>
38+ "(default: " <> (show $ fromEnum $ configBound config) <> ")")
39+ , Option "p" ["path"] (ReqArg OutputPath "PATH")
40+ ("The output path to write to (default: " <>
41+ fromMaybe "<none>" (configOutputPath config) <> ")")
42+ , Option "u" ["update-config"] (NoArg UpdateConfig)
43+ "Create or update the Vty configuration file to use the new table (default: no)"
44+ , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")
45+ ("Update the specified Vty configuration file path when -u is set (default: " <>
46+ configPath config <> ")")
47+ ]
48+
49+data Config =
50+ Config { configOutputPath :: Maybe FilePath
51+ , configBound :: Char
52+ , configUpdate :: Bool
53+ , configPath :: FilePath
54+ }
55+ deriving (Show)
56+
57+mkDefaultConfig :: IO Config
58+mkDefaultConfig = do
59+ Config <$> terminalWidthTablePath
60+ <*> pure defaultUnicodeTableUpperBound
61+ <*> pure False
62+ <*> vtyConfigPath
63+
64+usage :: IO ()
65+usage = do
66+ config <- mkDefaultConfig
67+ pn <- getProgName
68+ putStrLn $ "Usage: " <> pn <> " [options]"
69+ putStrLn ""
70+ putStrLn "This tool queries the terminal on stdout to determine the widths"
71+ putStrLn "of Unicode characters rendered to the terminal. The resulting data"
72+ putStrLn "is written to a table at the specified output path for later"
73+ putStrLn "loading by Vty-based applications."
74+ putStrLn ""
75+
76+ putStrLn $ usageInfo pn (options config)
77+
78+updateConfigFromArg :: Arg -> Config -> Config
79+updateConfigFromArg Help c =
80+ c
81+updateConfigFromArg UpdateConfig c =
82+ c { configUpdate = True }
83+updateConfigFromArg (VtyConfigPath p) c =
84+ c { configPath = p }
85+updateConfigFromArg (TableUpperBound s) c =
86+ case readMaybe s of
87+ Nothing -> error $ "Invalid table upper bound: " <> show s
88+ Just v -> c { configBound = toEnum v }
89+updateConfigFromArg (OutputPath p) c =
90+ c { configOutputPath = Just p }
91+
92+main :: IO ()
93+main = do
94+ defConfig <- mkDefaultConfig
95+ strArgs <- getArgs
96+ let (args, unused, errors) = getOpt Permute (options defConfig) strArgs
97+
98+ when (not $ null errors) $ do
99+ mapM_ putStrLn errors
100+ exitFailure
101+
102+ when ((not $ null unused) || (Help `elem` args)) $ do
103+ usage
104+ exitFailure
105+
106+ let config = foldr updateConfigFromArg defConfig args
107+
108+ outputPath <- case configOutputPath config of
109+ Nothing -> do
110+ putStrLn "Error: could not obtain terminal width table path"
111+ exitFailure
112+ Just path -> return path
113+
114+ putStrLn "Querying terminal:"
115+ builtTable <- buildUnicodeWidthTable $ configBound config
116+
117+ let dir = takeDirectory outputPath
118+ createDirectoryIfMissing True dir
119+ writeUnicodeWidthTable outputPath builtTable
120+
121+ putStrLn $ "\nOutput table written to " <> outputPath
122+
123+ when (configUpdate config) $ do
124+ let cPath = configPath config
125+ Just tName <- currentTerminalName
126+
127+ result <- E.try $ addConfigWidthMap cPath tName outputPath
128+
129+ case result of
130+ Left (e::E.SomeException) -> do
131+ putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>
132+ show e
133+ exitFailure
134+ Right ConfigurationCreated -> do
135+ putStrLn $ "Configuration file created: " <> cPath
136+ Right ConfigurationModified -> do
137+ putStrLn $ "Configuration file updated: " <> cPath
138+ Right (ConfigurationConflict other) -> do
139+ putStrLn $ "Configuration file not updated: uses a different table " <>
140+ "for TERM=" <> tName <> ": " <> other
141+ Right ConfigurationRedundant -> do
142+ putStrLn $ "Configuration file not updated: configuration " <>
143+ cPath <> " already uses table " <> outputPath <>
144+ " for TERM=" <> tName
vty.cabal+100−98
@@ -1,5 +1,5 @@
1name: vty
1name: vty
2−version: 5.14
2+version: 5.35.1
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
@@ -12,26 +12,25 @@ description:
12 be easy to use, have no confusing corner cases, and good support for
12 be easy to use, have no confusing corner cases, and good support for
13 common terminal types.
13 common terminal types.
14 .
14 .
15− Included in the source distribution is a program
15+ See the @vty-examples@ package as well as the program
16− test/interactive_terminal_test.hs that demonstrates the various
16+ @test/interactive_terminal_test.hs@ included in the @vty@ package for
17− features.
17+ examples on how to use the library.
18 .
18 .
19− Developers: See the "Graphics.Vty" module.
19+ Import the "Graphics.Vty" convenience module to get access to the core
20− .
20+ parts of the library.
21− Users: See the "Graphics.Vty.Config" module.
22 .
21 .
23 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
22 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
24 .
23 .
25 &#169; Corey O'Connor; BSD3 license.
24 &#169; Corey O'Connor; BSD3 license.
26 .
25 .
27 &#169; Jonathan Daugherty; BSD3 license.
26 &#169; Jonathan Daugherty; BSD3 license.
28−cabal-version: >= 1.18
27+cabal-version: 1.18
29build-type: Simple
28build-type: Simple
30−data-files: README.md,
29+extra-doc-files: README.md,
31 AUTHORS,
30 AUTHORS,
32 CHANGELOG.md,
31 CHANGELOG.md,
33 LICENSE
32 LICENSE
34−tested-with: GHC >= 7.6.2
33+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5
35
34
36source-repository head
35source-repository head
37 type: git
36 type: git
@@ -39,18 +38,16 @@ source-repository head
39
38
40library
39library
41 default-language: Haskell2010
40 default-language: Haskell2010
42− build-depends: base >= 4.6 && < 5,
41+ build-depends: base >= 4.8 && < 5,
43 blaze-builder >= 0.3.3.2 && < 0.5,
42 blaze-builder >= 0.3.3.2 && < 0.5,
44 bytestring,
43 bytestring,
45 containers,
44 containers,
46− data-default >= 0.5.3,
47 deepseq >= 1.1 && < 1.5,
45 deepseq >= 1.1 && < 1.5,
48 directory,
46 directory,
49 filepath >= 1.0 && < 2.0,
47 filepath >= 1.0 && < 2.0,
50− microlens,
48+ microlens < 0.4.13,
51 microlens-mtl,
49 microlens-mtl,
52 microlens-th,
50 microlens-th,
53− -- required for nice installation with yi
54 hashable >= 1.2,
51 hashable >= 1.2,
55 mtl >= 1.1.1.0 && < 2.3,
52 mtl >= 1.1.1.0 && < 2.3,
56 parallel >= 2.2 && < 3.3,
53 parallel >= 2.2 && < 3.3,
@@ -61,10 +58,18 @@ library
61 text >= 0.11.3,
58 text >= 0.11.3,
62 unix,
59 unix,
63 utf8-string >= 0.3 && < 1.1,
60 utf8-string >= 0.3 && < 1.1,
64− vector >= 0.7
61+ vector >= 0.7,
62+ binary,
63+ ansi-terminal >= 0.10.3
64+
65+ if !impl(ghc >= 8.0)
66+ build-depends: semigroups >= 0.16,
67+ fail
65
68
66 exposed-modules: Graphics.Vty
69 exposed-modules: Graphics.Vty
67 Graphics.Vty.Attributes
70 Graphics.Vty.Attributes
71+ Graphics.Vty.Attributes.Color
72+ Graphics.Vty.Attributes.Color240
68 Graphics.Vty.Config
73 Graphics.Vty.Config
69 Graphics.Vty.Error
74 Graphics.Vty.Error
70 Graphics.Vty.Image
75 Graphics.Vty.Image
@@ -73,10 +78,8 @@ library
73 Graphics.Vty.Input
78 Graphics.Vty.Input
74 Graphics.Vty.Input.Events
79 Graphics.Vty.Input.Events
75 Graphics.Vty.Picture
80 Graphics.Vty.Picture
76− Graphics.Vty.Prelude
77 Graphics.Vty.Output
81 Graphics.Vty.Output
78 Graphics.Text.Width
82 Graphics.Text.Width
79− -- the modules below are only meant to be used by the tests.
80 Codec.Binary.UTF8.Debug
83 Codec.Binary.UTF8.Debug
81 Data.Terminfo.Parse
84 Data.Terminfo.Parse
82 Data.Terminfo.Eval
85 Data.Terminfo.Eval
@@ -88,6 +91,7 @@ library
88 Graphics.Vty.Input.Classify.Parse
91 Graphics.Vty.Input.Classify.Parse
89 Graphics.Vty.Input.Loop
92 Graphics.Vty.Input.Loop
90 Graphics.Vty.Input.Mouse
93 Graphics.Vty.Input.Mouse
94+ Graphics.Vty.Input.Focus
91 Graphics.Vty.Input.Paste
95 Graphics.Vty.Input.Paste
92 Graphics.Vty.Input.Terminfo
96 Graphics.Vty.Input.Terminfo
93 Graphics.Vty.PictureToSpans
97 Graphics.Vty.PictureToSpans
@@ -96,41 +100,52 @@ library
96 Graphics.Vty.Output.Interface
100 Graphics.Vty.Output.Interface
97 Graphics.Vty.Output.XTermColor
101 Graphics.Vty.Output.XTermColor
98 Graphics.Vty.Output.TerminfoBased
102 Graphics.Vty.Output.TerminfoBased
103+ Graphics.Vty.UnicodeWidthTable.Types
104+ Graphics.Vty.UnicodeWidthTable.IO
105+ Graphics.Vty.UnicodeWidthTable.Query
106+ Graphics.Vty.UnicodeWidthTable.Install
99
107
100− other-modules: Graphics.Vty.Attributes.Color
108+ other-modules: Graphics.Vty.Debug.Image
101− Graphics.Vty.Attributes.Color240
102− Graphics.Vty.Debug.Image
103 Graphics.Vty.Input.Terminfo.ANSIVT
109 Graphics.Vty.Input.Terminfo.ANSIVT
104
110
105 c-sources: cbits/gwinsz.c
111 c-sources: cbits/gwinsz.c
106 cbits/set_term_timing.c
112 cbits/set_term_timing.c
113+ cbits/get_tty_erase.c
107 cbits/mk_wcwidth.c
114 cbits/mk_wcwidth.c
108
115
109 include-dirs: cbits
116 include-dirs: cbits
110
117
111 hs-source-dirs: src
118 hs-source-dirs: src
112
119
113− default-extensions: ScopedTypeVariables
114− ForeignFunctionInterface
115−
116 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
117
121
118 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
119
123
124+executable vty-build-width-table
125+ main-is: BuildWidthTable.hs
126+ hs-source-dirs: tools
127+
128+ default-language: Haskell2010
120− cc-options: -O2
129+ ghc-options: -threaded -Wall
130+
131+ if !impl(ghc >= 8.0)
132+ build-depends: semigroups >= 0.16
133+
134+ build-depends: vty,
135+ directory,
136+ filepath,
137+ base >= 4.8 && < 5
121
138
122executable vty-mode-demo
139executable vty-mode-demo
123 main-is: ModeDemo.hs
140 main-is: ModeDemo.hs
124 hs-source-dirs: demos
141 hs-source-dirs: demos
125
142
126 default-language: Haskell2010
143 default-language: Haskell2010
127− default-extensions: ScopedTypeVariables
128 ghc-options: -threaded
144 ghc-options: -threaded
129
145
130 build-depends: vty,
146 build-depends: vty,
131− base >= 4.6 && < 5,
147+ base >= 4.8 && < 5,
132 containers,
148 containers,
133− data-default >= 0.5.3,
134 microlens,
149 microlens,
135 microlens-mtl,
150 microlens-mtl,
136 mtl >= 1.1.1.0 && < 2.3
151 mtl >= 1.1.1.0 && < 2.3
@@ -140,40 +155,17 @@ executable vty-demo
140 hs-source-dirs: demos
155 hs-source-dirs: demos
141
156
142 default-language: Haskell2010
157 default-language: Haskell2010
143− default-extensions: ScopedTypeVariables
144 ghc-options: -threaded
158 ghc-options: -threaded
145
159
146 build-depends: vty,
160 build-depends: vty,
147− base >= 4.6 && < 5,
161+ base >= 4.8 && < 5,
148 containers,
162 containers,
149− data-default >= 0.5.3,
150 microlens,
163 microlens,
151 microlens-mtl,
164 microlens-mtl,
152 mtl >= 1.1.1.0 && < 2.3
165 mtl >= 1.1.1.0 && < 2.3
153
166
154−test-suite verify-attribute-ops
155− default-language: Haskell2010
156− default-extensions: ScopedTypeVariables
157− type: detailed-0.9
158− hs-source-dirs: test
159− test-module: VerifyAttributeOps
160− build-depends: vty,
161− Cabal >= 1.20,
162− QuickCheck >= 2.7,
163− random >= 1.0 && < 1.2,
164− base >= 4.6 && < 5,
165− bytestring,
166− containers,
167− deepseq >= 1.1 && < 1.5,
168− mtl >= 1.1.1.0 && < 2.3,
169− text >= 0.11.3,
170− unix,
171− utf8-string >= 0.3 && < 1.1,
172− vector >= 0.7
173−
174test-suite verify-using-mock-terminal
167test-suite verify-using-mock-terminal
175 default-language: Haskell2010
168 default-language: Haskell2010
176− default-extensions: ScopedTypeVariables
177
169
178 type: detailed-0.9
170 type: detailed-0.9
179
171
@@ -192,8 +184,8 @@ test-suite verify-using-mock-terminal
192 build-depends: vty,
184 build-depends: vty,
193 Cabal >= 1.20,
185 Cabal >= 1.20,
194 QuickCheck >= 2.7,
186 QuickCheck >= 2.7,
195− random >= 1.0 && < 1.2,
187+ random >= 1.0 && < 1.3,
196− base >= 4.6 && < 5,
188+ base >= 4.8 && < 5,
197 bytestring,
189 bytestring,
198 containers,
190 containers,
199 deepseq >= 1.1 && < 1.5,
191 deepseq >= 1.1 && < 1.5,
@@ -206,7 +198,6 @@ test-suite verify-using-mock-terminal
206
198
207test-suite verify-terminal
199test-suite verify-terminal
208 default-language: Haskell2010
200 default-language: Haskell2010
209− default-extensions: ScopedTypeVariables
210
201
211 type: detailed-0.9
202 type: detailed-0.9
212
203
@@ -225,11 +216,10 @@ test-suite verify-terminal
225 build-depends: vty,
216 build-depends: vty,
226 Cabal >= 1.20,
217 Cabal >= 1.20,
227 QuickCheck >= 2.7,
218 QuickCheck >= 2.7,
228− random >= 1.0 && < 1.2,
219+ random >= 1.0 && < 1.3,
229− base >= 4.6 && < 5,
220+ base >= 4.8 && < 5,
230 bytestring,
221 bytestring,
231 containers,
222 containers,
232− data-default >= 0.5.3,
233 deepseq >= 1.1 && < 1.5,
223 deepseq >= 1.1 && < 1.5,
234 mtl >= 1.1.1.0 && < 2.3,
224 mtl >= 1.1.1.0 && < 2.3,
235 terminfo >= 0.3 && < 0.5,
225 terminfo >= 0.3 && < 0.5,
@@ -240,7 +230,6 @@ test-suite verify-terminal
240
230
241test-suite verify-display-attributes
231test-suite verify-display-attributes
242 default-language: Haskell2010
232 default-language: Haskell2010
243− default-extensions: ScopedTypeVariables
244
233
245 type: detailed-0.9
234 type: detailed-0.9
246
235
@@ -259,8 +248,8 @@ test-suite verify-display-attributes
259 build-depends: vty,
248 build-depends: vty,
260 Cabal >= 1.20,
249 Cabal >= 1.20,
261 QuickCheck >= 2.7,
250 QuickCheck >= 2.7,
262− random >= 1.0 && < 1.2,
251+ random >= 1.0 && < 1.3,
263− base >= 4.6 && < 5,
252+ base >= 4.8 && < 5,
264 bytestring,
253 bytestring,
265 containers,
254 containers,
266 deepseq >= 1.1 && < 1.5,
255 deepseq >= 1.1 && < 1.5,
@@ -272,7 +261,6 @@ test-suite verify-display-attributes
272
261
273test-suite verify-empty-image-props
262test-suite verify-empty-image-props
274 default-language: Haskell2010
263 default-language: Haskell2010
275− default-extensions: ScopedTypeVariables
276
264
277 type: detailed-0.9
265 type: detailed-0.9
278
266
@@ -285,8 +273,8 @@ test-suite verify-empty-image-props
285 build-depends: vty,
273 build-depends: vty,
286 Cabal >= 1.20,
274 Cabal >= 1.20,
287 QuickCheck >= 2.7,
275 QuickCheck >= 2.7,
288− random >= 1.0 && < 1.2,
276+ random >= 1.0 && < 1.3,
289− base >= 4.6 && < 5,
277+ base >= 4.8 && < 5,
290 bytestring,
278 bytestring,
291 containers,
279 containers,
292 deepseq >= 1.1 && < 1.5,
280 deepseq >= 1.1 && < 1.5,
@@ -298,7 +286,6 @@ test-suite verify-empty-image-props
298
286
299test-suite verify-eval-terminfo-caps
287test-suite verify-eval-terminfo-caps
300 default-language: Haskell2010
288 default-language: Haskell2010
301− default-extensions: ScopedTypeVariables
302
289
303 type: detailed-0.9
290 type: detailed-0.9
304
291
@@ -312,8 +299,8 @@ test-suite verify-eval-terminfo-caps
312 build-depends: vty,
299 build-depends: vty,
313 Cabal >= 1.20,
300 Cabal >= 1.20,
314 QuickCheck >= 2.7,
301 QuickCheck >= 2.7,
315− random >= 1.0 && < 1.2,
302+ random >= 1.0 && < 1.3,
316− base >= 4.6 && < 5,
303+ base >= 4.8 && < 5,
317 blaze-builder >= 0.3.3.2 && < 0.5,
304 blaze-builder >= 0.3.3.2 && < 0.5,
318 bytestring,
305 bytestring,
319 containers,
306 containers,
@@ -327,7 +314,6 @@ test-suite verify-eval-terminfo-caps
327
314
328test-suite verify-image-ops
315test-suite verify-image-ops
329 default-language: Haskell2010
316 default-language: Haskell2010
330− default-extensions: ScopedTypeVariables
331
317
332 type: detailed-0.9
318 type: detailed-0.9
333
319
@@ -342,8 +328,8 @@ test-suite verify-image-ops
342 build-depends: vty,
328 build-depends: vty,
343 Cabal >= 1.20,
329 Cabal >= 1.20,
344 QuickCheck >= 2.7,
330 QuickCheck >= 2.7,
345− random >= 1.0 && < 1.2,
331+ random >= 1.0 && < 1.3,
346− base >= 4.6 && < 5,
332+ base >= 4.8 && < 5,
347 bytestring,
333 bytestring,
348 containers,
334 containers,
349 deepseq >= 1.1 && < 1.5,
335 deepseq >= 1.1 && < 1.5,
@@ -355,7 +341,6 @@ test-suite verify-image-ops
355
341
356test-suite verify-image-trans
342test-suite verify-image-trans
357 default-language: Haskell2010
343 default-language: Haskell2010
358− default-extensions: ScopedTypeVariables
359
344
360 type: detailed-0.9
345 type: detailed-0.9
361
346
@@ -370,8 +355,8 @@ test-suite verify-image-trans
370 build-depends: vty,
355 build-depends: vty,
371 Cabal >= 1.20,
356 Cabal >= 1.20,
372 QuickCheck >= 2.7,
357 QuickCheck >= 2.7,
373− random >= 1.0 && < 1.2,
358+ random >= 1.0 && < 1.3,
374− base >= 4.6 && < 5,
359+ base >= 4.8 && < 5,
375 bytestring,
360 bytestring,
376 containers,
361 containers,
377 deepseq >= 1.1 && < 1.5,
362 deepseq >= 1.1 && < 1.5,
@@ -383,7 +368,6 @@ test-suite verify-image-trans
383
368
384test-suite verify-inline
369test-suite verify-inline
385 default-language: Haskell2010
370 default-language: Haskell2010
386− default-extensions: ScopedTypeVariables
387
371
388 type: detailed-0.9
372 type: detailed-0.9
389
373
@@ -397,8 +381,8 @@ test-suite verify-inline
397 build-depends: vty,
381 build-depends: vty,
398 Cabal >= 1.20,
382 Cabal >= 1.20,
399 QuickCheck >= 2.7,
383 QuickCheck >= 2.7,
400− random >= 1.0 && < 1.2,
384+ random >= 1.0 && < 1.3,
401− base >= 4.6 && < 5,
385+ base >= 4.8 && < 5,
402 bytestring,
386 bytestring,
403 containers,
387 containers,
404 deepseq >= 1.1 && < 1.5,
388 deepseq >= 1.1 && < 1.5,
@@ -410,7 +394,6 @@ test-suite verify-inline
410
394
411test-suite verify-parse-terminfo-caps
395test-suite verify-parse-terminfo-caps
412 default-language: Haskell2010
396 default-language: Haskell2010
413− default-extensions: ScopedTypeVariables
414
397
415 type: detailed-0.9
398 type: detailed-0.9
416
399
@@ -425,8 +408,8 @@ test-suite verify-parse-terminfo-caps
425 build-depends: vty,
408 build-depends: vty,
426 Cabal >= 1.20,
409 Cabal >= 1.20,
427 QuickCheck >= 2.7,
410 QuickCheck >= 2.7,
428− random >= 1.0 && < 1.2,
411+ random >= 1.0 && < 1.3,
429− base >= 4.6 && < 5,
412+ base >= 4.8 && < 5,
430 bytestring,
413 bytestring,
431 containers,
414 containers,
432 deepseq >= 1.1 && < 1.5,
415 deepseq >= 1.1 && < 1.5,
@@ -439,7 +422,6 @@ test-suite verify-parse-terminfo-caps
439
422
440test-suite verify-simple-span-generation
423test-suite verify-simple-span-generation
441 default-language: Haskell2010
424 default-language: Haskell2010
442− default-extensions: ScopedTypeVariables
443
425
444 type: detailed-0.9
426 type: detailed-0.9
445
427
@@ -457,8 +439,8 @@ test-suite verify-simple-span-generation
457 build-depends: vty,
439 build-depends: vty,
458 Cabal >= 1.20,
440 Cabal >= 1.20,
459 QuickCheck >= 2.7,
441 QuickCheck >= 2.7,
460− random >= 1.0 && < 1.2,
442+ random >= 1.0 && < 1.3,
461− base >= 4.6 && < 5,
443+ base >= 4.8 && < 5,
462 bytestring,
444 bytestring,
463 containers,
445 containers,
464 deepseq >= 1.1 && < 1.5,
446 deepseq >= 1.1 && < 1.5,
@@ -471,7 +453,6 @@ test-suite verify-simple-span-generation
471
453
472test-suite verify-crop-span-generation
454test-suite verify-crop-span-generation
473 default-language: Haskell2010
455 default-language: Haskell2010
474− default-extensions: ScopedTypeVariables
475
456
476 type: detailed-0.9
457 type: detailed-0.9
477
458
@@ -489,8 +470,8 @@ test-suite verify-crop-span-generation
489 build-depends: vty,
470 build-depends: vty,
490 Cabal >= 1.20,
471 Cabal >= 1.20,
491 QuickCheck >= 2.7,
472 QuickCheck >= 2.7,
492− random >= 1.0 && < 1.2,
473+ random >= 1.0 && < 1.3,
493− base >= 4.6 && < 5,
474+ base >= 4.8 && < 5,
494 bytestring,
475 bytestring,
495 containers,
476 containers,
496 deepseq >= 1.1 && < 1.5,
477 deepseq >= 1.1 && < 1.5,
@@ -503,7 +484,6 @@ test-suite verify-crop-span-generation
503
484
504test-suite verify-layers-span-generation
485test-suite verify-layers-span-generation
505 default-language: Haskell2010
486 default-language: Haskell2010
506− default-extensions: ScopedTypeVariables
507
487
508 type: detailed-0.9
488 type: detailed-0.9
509
489
@@ -521,8 +501,33 @@ test-suite verify-layers-span-generation
521 build-depends: vty,
501 build-depends: vty,
522 Cabal >= 1.20,
502 Cabal >= 1.20,
523 QuickCheck >= 2.7,
503 QuickCheck >= 2.7,
524− random >= 1.0 && < 1.2,
504+ random >= 1.0 && < 1.3,
505+ base >= 4.8 && < 5,
506+ bytestring,
507+ containers,
508+ deepseq >= 1.1 && < 1.5,
509+ mtl >= 1.1.1.0 && < 2.3,
510+ text >= 0.11.3,
511+ unix,
512+ utf8-string >= 0.3 && < 1.1,
513+ vector >= 0.7
514+
515+test-suite verify-color-mapping
516+ default-language: Haskell2010
517+
518+ type: detailed-0.9
519+
520+ hs-source-dirs: test
521+
522+ test-module: VerifyColor240
523+
524+ other-modules: Verify
525+
526+ build-depends: vty,
527+ Cabal >= 1.20,
528+ QuickCheck >= 2.7,
529+ random >= 1.0 && < 1.3,
525− base >= 4.6 && < 5,
530+ base >= 4.8 && < 5,
526 bytestring,
531 bytestring,
527 containers,
532 containers,
528 deepseq >= 1.1 && < 1.5,
533 deepseq >= 1.1 && < 1.5,
@@ -534,7 +539,6 @@ test-suite verify-layers-span-generation
534
539
535test-suite verify-utf8-width
540test-suite verify-utf8-width
536 default-language: Haskell2010
541 default-language: Haskell2010
537− default-extensions: ScopedTypeVariables
538
542
539 type: detailed-0.9
543 type: detailed-0.9
540
544
@@ -547,8 +551,8 @@ test-suite verify-utf8-width
547 build-depends: vty,
551 build-depends: vty,
548 Cabal >= 1.20,
552 Cabal >= 1.20,
549 QuickCheck >= 2.7,
553 QuickCheck >= 2.7,
550− random >= 1.0 && < 1.2,
554+ random >= 1.0 && < 1.3,
551− base >= 4.6 && < 5,
555+ base >= 4.8 && < 5,
552 bytestring,
556 bytestring,
553 containers,
557 containers,
554 deepseq >= 1.1 && < 1.5,
558 deepseq >= 1.1 && < 1.5,
@@ -560,7 +564,6 @@ test-suite verify-utf8-width
560
564
561test-suite verify-using-mock-input
565test-suite verify-using-mock-input
562 default-language: Haskell2010
566 default-language: Haskell2010
563− default-extensions: ScopedTypeVariables
564
567
565 type: exitcode-stdio-1.0
568 type: exitcode-stdio-1.0
566
569
@@ -568,16 +571,17 @@ test-suite verify-using-mock-input
568
571
569 main-is: VerifyUsingMockInput.hs
572 main-is: VerifyUsingMockInput.hs
570
573
574+ other-modules: Verify.Graphics.Vty.Output
575+
571 build-depends: vty,
576 build-depends: vty,
572 Cabal >= 1.20,
577 Cabal >= 1.20,
573− data-default >= 0.5.3,
574 QuickCheck >= 2.7,
578 QuickCheck >= 2.7,
575 smallcheck == 1.*,
579 smallcheck == 1.*,
576 quickcheck-assertions >= 0.1.1,
580 quickcheck-assertions >= 0.1.1,
577 test-framework == 0.8.*,
581 test-framework == 0.8.*,
578 test-framework-smallcheck == 0.2.*,
582 test-framework-smallcheck == 0.2.*,
579− random >= 1.0 && < 1.2,
583+ random >= 1.0 && < 1.3,
580− base >= 4.6 && < 5,
584+ base >= 4.8 && < 5,
581 bytestring,
585 bytestring,
582 containers,
586 containers,
583 deepseq >= 1.1 && < 1.5,
587 deepseq >= 1.1 && < 1.5,
@@ -595,7 +599,6 @@ test-suite verify-using-mock-input
595
599
596test-suite verify-config
600test-suite verify-config
597 default-language: Haskell2010
601 default-language: Haskell2010
598− default-extensions: ScopedTypeVariables
599
602
600 type: exitcode-stdio-1.0
603 type: exitcode-stdio-1.0
601
604
@@ -605,7 +608,6 @@ test-suite verify-config
605
608
606 build-depends: vty,
609 build-depends: vty,
607 Cabal >= 1.20,
610 Cabal >= 1.20,
608− data-default >= 0.5.3,
609 HUnit,
611 HUnit,
610 QuickCheck >= 2.7,
612 QuickCheck >= 2.7,
611 smallcheck == 1.*,
613 smallcheck == 1.*,
@@ -613,8 +615,8 @@ test-suite verify-config
613 test-framework == 0.8.*,
615 test-framework == 0.8.*,
614 test-framework-smallcheck == 0.2.*,
616 test-framework-smallcheck == 0.2.*,
615 test-framework-hunit,
617 test-framework-hunit,
616− random >= 1.0 && < 1.2,
618+ random >= 1.0 && < 1.3,
617− base >= 4.6 && < 5,
619+ base >= 4.8 && < 5,
618 bytestring,
620 bytestring,
619 containers,
621 containers,
620 deepseq >= 1.1 && < 1.5,
622 deepseq >= 1.1 && < 1.5,