on master help sign in
.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−17
@@ -1,26 +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.22 GHCVER=7.10.1
45+ - HC=${CC}
12− - CABALVER=1.24 GHCVER=8.0.1
46+ - HCPKG=${HC/ghc/ghc-pkg}
13− - CABALVER=1.24 GHCVER=8.0.2
47+ - unset CC
14− - CABALVER=head GHCVER=head
48+ - ROOTDIR=$(pwd)
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
15
53
16install:
54install:
17− - ./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)
18
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.
19script:
83script:
20− - ./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
21
96
22−before_install:
97+ # build & run tests, build benchmarks
23− - sudo add-apt-repository -y ppa:hvr/ghc
98+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
24− - sudo apt-get update
99+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
25− - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
100+
26− - 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+119−53
@@ -7,7 +7,7 @@ interface for doing terminal I/O. Vty is supported on GHC versions
7Install via `git` with:
7Install via `git` with:
8
8
9```
9```
10−git clone git://github.com/coreyoconnor/vty.git
10+git clone git://github.com/jtdaugherty/vty.git
11```
11```
12
12
13Install via `cabal` with:
13Install via `cabal` with:
@@ -18,24 +18,21 @@ cabal install vty
18
18
19# Features
19# Features
20
20
21−* Supports a large number of terminals. vt100, ansi, hurd, linux,
21+* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,
22− screen, etc., or anything with a sufficient terminfo entry.
22+ `screen`, etc., or anything with a sufficient terminfo entry.
23
23
24−* Automatic handling of window resizes.
24+* Automatically handles window resizes.
25
25
26−* Unicode output on terminals with UTF-8 support.
26+* Supports Unicode output on terminals with UTF-8 support.
27
27
28−* Handles multi-column glyphs. (Requires user to properly configure
29− terminal.)
30−
31−* Efficient output. Output buffering and terminal state changes are
28+* Provides an efficient output algorithm. Output buffering and terminal
32− minimized.
29+ state changes are minimized.
33
30
34* Minimizes repaint area, which virtually eliminates the flicker
31* Minimizes repaint area, which virtually eliminates the flicker
35 problems that plague ncurses programs.
32 problems that plague ncurses programs.
36
33
37−* A pure, compositional interface for efficiently constructing display
34+* Provides a pure, compositional interface for efficiently constructing
38− images.
35+ display images.
39
36
40* Automatically decodes keyboard keys into (key,[modifier]) tuples.
37* Automatically decodes keyboard keys into (key,[modifier]) tuples.
41
38
@@ -44,7 +41,7 @@ cabal install vty
44* Supports a keypress timeout after for lone ESC. The timeout is
41* Supports a keypress timeout after for lone ESC. The timeout is
45 customizable.
42 customizable.
46
43
47−* The interface is designed for easy extension.
44+* Provides extensible input and output interfaces.
48
45
49* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
46* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
50 with a type-safe interface and graceful fallback for terminals
47 with a type-safe interface and graceful fallback for terminals
@@ -60,16 +57,106 @@ cabal install vty
60* Supports bracketed paste mode as described at
57* Supports bracketed paste mode as described at
61 http://cirw.in/blog/bracketed-paste
58 http://cirw.in/blog/bracketed-paste
62
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+
63# Platform Support
71# Platform Support
64
72
65## Posix Terminals
73## Posix Terminals
66
74
67−Uses terminfo to determine terminal protocol. With some special rules to
75+For the most part, Vty uses `terminfo` to determine terminal protocol
68−handle some omissions from terminfo.
76+with some special rules to handle some omissions from `terminfo`.
69
77
70## Windows
78## Windows
71
79
72−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.,
124+
125+```
126+widthMap "xterm" "/path/to/map.dat"
127+```
128+
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.
73
160
74# Contributing
161# Contributing
75
162
@@ -83,45 +170,13 @@ should consider to make submitting patches easier for all concerned:
83 conventions already used in the codebase.
170 conventions already used in the codebase.
84 - Please provide Haddock documentation for any changes you make.
171 - Please provide Haddock documentation for any changes you make.
85
172
86−# Development Notes
87−
88−## Under NixOS
89−
90−### Using cabal
91−
92−After installing `ncurses` to the user environment:
93−
94−~~~
95−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib
96−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build
97−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test
98−~~~
99−
100−## Code Coverage
101−
102−As of last testing, profiling causes issues with coverage when enabled.
103−To evaluate coverage, configure as follows:
104−
105−~~~
106−rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \
107− --disable-library-profiling \
108− --disable-executable-profiling
109−~~~
110−
111−## Profiling
112−
113−~~~
114−rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
115− --enable-library-profiling \
116− --enable-executable-profiling
117−~~~
118−
119# Known Issues
173# Known Issues
120
174
121−* Terminals have numerous quirks and bugs. Vty picks what works best for
175+* Terminals have numerous quirks and bugs, so mileage may vary. Please
122− the author in ambiguous or buggy situations.
176+ report issues as you encounter them and provide details on your
177+ terminal emulator, operating system, etc.
123
178
124−* Signal handling of STOP, TERM and INT are nonexistent.
179+* STOP, TERM and INT signals are not handled.
125
180
126* The character encoding of the terminal is assumed to be UTF-8 if
181* The character encoding of the terminal is assumed to be UTF-8 if
127 unicode is used.
182 unicode is used.
@@ -131,5 +186,16 @@ rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
131 (shifted F10 etc). See `Config` for customizing vty's behavior for a
186 (shifted F10 etc). See `Config` for customizing vty's behavior for a
132 particular terminal.
187 particular terminal.
133
188
134−* Uses the `TIOCGWINSZ` ioctl to find the current window size, which
189+* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which
135 appears to be limited to Linux and BSD.
190 appears to be limited to Linux and BSD.
191+
192+# Further Reading
193+
194+Good sources of documentation for terminal programming are:
195+
196+* https://github.com/b4winckler/vim/blob/master/src/term.c
197+* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
198+* http://ulisse.elettra.trieste.it/services/doc/serial/config.html
199+* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html
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−7
@@ -7,7 +7,6 @@ import Control.Applicative hiding ((<|>))
7import Control.Arrow
7import Control.Arrow
8import Control.Monad.RWS
8import Control.Monad.RWS
9
9
10−import Data.Default (def)
11import Data.Sequence (Seq, (<|) )
10import Data.Sequence (Seq, (<|) )
12import qualified Data.Sequence as Seq
11import qualified Data.Sequence as Seq
13import Data.Foldable
12import Data.Foldable
@@ -18,8 +17,8 @@ type App = RWST Vty () (Seq String) IO
18
17
19main = do
18main = do
20 vty <- if True -- change to false for emacs-like input processing
19 vty <- if True -- change to false for emacs-like input processing
21− then mkVty def
20+ then mkVty defaultConfig
22− else mkVty (def { vmin = Just 2, vtime = Just 300 } )
21+ else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )
23 _ <- execRWST (vtyInteract False) vty Seq.empty
22 _ <- execRWST (vtyInteract False) vty Seq.empty
24 shutdown vty
23 shutdown vty
25
24
@@ -32,7 +31,8 @@ introText = vertCat $ map (string defAttr)
32 [ "this line is hidden by the top layer"
31 [ "this line is hidden by the top layer"
33 , "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."
34 , "Below there is a 240 color box."
33 , "Below there is a 240 color box."
35− , "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."
36 , "If the 240 color box is not visible then the terminal"
36 , "If the 240 color box is not visible then the terminal"
37 , "claims 240 colors are not supported."
37 , "claims 240 colors are not supported."
38 , "Try setting TERM to xterm-256color"
38 , "Try setting TERM to xterm-256color"
@@ -43,12 +43,19 @@ introText = vertCat $ map (string defAttr)
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
44 ]
44 ]
45
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+
46colorbox_240 :: Image
55colorbox_240 :: Image
47colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
48 where
57 where
49 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
50− splitColorImages [] = []
51− splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
52
59
53colorbox_16 :: Image
60colorbox_16 :: Image
54colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
61colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
@@ -71,7 +78,7 @@ updateDisplay = do
71 "Press ESC to exit. Events for keys below."
78 "Press ESC to exit. Events for keys below."
72 eventLog <- foldMap (string defAttr) <$> get
79 eventLog <- foldMap (string defAttr) <$> get
73 let pic = picForImage (info <-> eventLog)
80 let pic = picForImage (info <-> eventLog)
74− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
81+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
75 vty <- ask
82 vty <- ask
76 liftIO $ update vty pic
83 liftIO $ update vty pic
77
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+1−2
@@ -14,5 +14,4 @@ utf8FromIso :: [Int] -> [Word8]
14utf8FromIso = encode . map toEnum
14utf8FromIso = encode . map toEnum
15
15
16ppUtf8 :: [Int] -> IO ()
16ppUtf8 :: [Int] -> IO ()
17−ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso
17+ppUtf8 = print . map (`showHex` "") . utf8FromIso
18−
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+3−3
@@ -42,7 +42,7 @@ pop = do
42
42
43readParam :: Word -> Eval CapParam
43readParam :: Word -> Eval CapParam
44readParam pn = do
44readParam pn = do
45− !params <- get >>= return . evalParams
45+ !params <- evalParams <$> get
46 return $! genericIndex params pn
46 return $! genericIndex params pn
47
47
48push :: CapParam -> Eval ()
48push :: CapParam -> Eval ()
@@ -64,11 +64,11 @@ writeCapExpr cap params =
64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
65
65
66writeCapOps :: CapOps -> Eval ()
66writeCapOps :: CapOps -> Eval ()
67−writeCapOps ops = mapM_ writeCapOp ops
67+writeCapOps = mapM_ writeCapOp
68
68
69writeCapOp :: CapOp -> Eval ()
69writeCapOp :: CapOp -> Eval ()
70writeCapOp (Bytes !offset !count) = do
70writeCapOp (Bytes !offset !count) = do
71− !cap <- get >>= return . evalExpression
71+ !cap <- evalExpression <$> get
72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
73 Vector.forM_ bytes $ tell.writeWord8
73 Vector.forM_ bytes $ tell.writeWord8
74writeCapOp DecOut = do
74writeCapOp DecOut = do
src/Data/Terminfo/Parse.hs+22−13
@@ -1,8 +1,9 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE CPP #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6+{-# OPTIONS_HADDOCK hide #-}
6
7
7module Data.Terminfo.Parse
8module Data.Terminfo.Parse
8 ( module Data.Terminfo.Parse
9 ( module Data.Terminfo.Parse
@@ -13,6 +14,9 @@ where
13import Control.Monad ( liftM )
14import Control.Monad ( liftM )
14import Control.DeepSeq
15import Control.DeepSeq
15
16
17+#if !(MIN_VERSION_base(4,11,0))
18+import Data.Semigroup (Semigroup(..))
19+#endif
16import Data.Word
20import Data.Word
17import qualified Data.Vector.Unboxed as Vector
21import qualified Data.Vector.Unboxed as Vector
18
22
@@ -35,7 +39,7 @@ instance Show CapExpression where
35 ++ " <= " ++ show (sourceString c)
39 ++ " <= " ++ show (sourceString c)
36 where
40 where
37 hexDump :: [Word8] -> String
41 hexDump :: [Word8] -> String
38− hexDump = foldr (\b s -> showHex b s) ""
42+ hexDump = foldr showHex ""
39
43
40instance NFData CapExpression where
44instance NFData CapExpression where
41 rnf (CapExpression ops !_bytes !str !c !pOps)
45 rnf (CapExpression ops !_bytes !str !c !pOps)
@@ -95,7 +99,7 @@ parseCapExpression capString =
95 Left e -> Left e
99 Left e -> Left e
96 Right buildResults -> Right $ constructCapExpression capString buildResults
100 Right buildResults -> Right $ constructCapExpression capString buildResults
97
101
98−constructCapExpression :: [Char] -> BuildResults -> CapExpression
102+constructCapExpression :: String -> BuildResults -> CapExpression
99constructCapExpression capString buildResults =
103constructCapExpression capString buildResults =
100 let expr = CapExpression
104 let expr = CapExpression
101 { capOps = outCapOps buildResults
105 { capOps = outCapOps buildResults
@@ -124,7 +128,7 @@ paramEscapeParser = do
124literalPercentParser :: CapParser BuildResults
128literalPercentParser :: CapParser BuildResults
125literalPercentParser = do
129literalPercentParser = do
126 _ <- char '%'
130 _ <- char '%'
127− startOffset <- getState >>= return . nextOffset
131+ startOffset <- nextOffset <$> getState
128 incOffset 1
132 incOffset 1
129 return $ BuildResults 0 [Bytes startOffset 1] []
133 return $ BuildResults 0 [Bytes startOffset 1] []
130
134
@@ -150,7 +154,7 @@ incrementOpParser = do
150pushOpParser :: CapParser BuildResults
154pushOpParser :: CapParser BuildResults
151pushOpParser = do
155pushOpParser = do
152 _ <- char 'p'
156 _ <- char 'p'
153− paramN <- digit >>= return . (\d -> read [d])
157+ paramN <- read . pure <$> digit
154 incOffset 2
158 incOffset 2
155 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
156
160
@@ -295,7 +299,7 @@ compareOpParser
295bytesOpParser :: CapParser BuildResults
299bytesOpParser :: CapParser BuildResults
296bytesOpParser = do
300bytesOpParser = do
297 bytes <- many1 $ satisfy (/= '%')
301 bytes <- many1 $ satisfy (/= '%')
298− startOffset <- getState >>= return . nextOffset
302+ startOffset <- nextOffset <$> getState
299 let !c = length bytes
303 let !c = length bytes
300 !s <- getState
304 !s <- getState
301 let s' = s { nextOffset = startOffset + c }
305 let s' = s { nextOffset = startOffset + c }
@@ -329,11 +333,16 @@ data BuildResults = BuildResults
329 , outParamOps :: !ParamOps
333 , outParamOps :: !ParamOps
330 }
334 }
331
335
332−instance Monoid BuildResults where
336+instance Semigroup BuildResults where
333− mempty = BuildResults 0 [] []
334− v0 `mappend` v1
337+ v0 <> v1
335 = BuildResults
338 = BuildResults
336− { outParamCount = (outParamCount v0) `max` (outParamCount v1)
339+ { outParamCount = outParamCount v0 `max` outParamCount v1
337− , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
340+ , outCapOps = outCapOps v0 <> outCapOps v1
338− , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
341+ , outParamOps = outParamOps v0 <> outParamOps v1
339 }
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+42−11
@@ -1,33 +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@.
4module Graphics.Text.Width
13module Graphics.Text.Width
5 ( wcwidth
14 ( wcwidth
6 , wcswidth
15 , wcswidth
16+ , wctwidth
17+ , wctlwidth
7 , safeWcwidth
18 , safeWcwidth
8 , safeWcswidth
19 , safeWcswidth
20+ , safeWctwidth
21+ , safeWctlwidth
9 )
22 )
10where
23where
11
24
25+import Data.List (foldl')
26+import qualified Data.Text as T
27+import qualified Data.Text.Lazy as TL
28+
12foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
29foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
13
30
14wcswidth :: String -> Int
31wcswidth :: String -> Int
15−wcswidth = sum . map wcwidth
32+wcswidth = foldl' (\l c -> wcwidth c + l) 0
33+{-# INLINE [1] wcswidth #-}
16
34
17−-- XXX: Characters with unknown widths occupy 1 column?
35+wctwidth :: T.Text -> Int
18−--
36+wctwidth = T.foldl' (\l c -> wcwidth c + l) 0
19−-- Not sure if this is actually correct. I presume there is a
37+
20−-- replacement character that is output by the terminal instead of the
38+wctlwidth :: TL.Text -> Int
21−-- character and this replacement character is 1 column wide. If this is
39+wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0
22−-- not true for all terminals then a per-terminal replacement character
40+
23−-- width needs to be implemented.
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+ #-}
24
45
25-- | Returns the display width of a character. Assumes all characters
46-- | Returns the display width of a character. Assumes all characters
26−-- with unknown widths are 0 width
47+-- with unknown widths are 0 width.
27safeWcwidth :: Char -> Int
48safeWcwidth :: Char -> Int
28safeWcwidth = max 0 . wcwidth
49safeWcwidth = max 0 . wcwidth
29
50
30-- | Returns the display width of a string. Assumes all characters with
51-- | Returns the display width of a string. Assumes all characters with
31−-- unknown widths are 0 width
52+-- unknown widths are 0 width.
32safeWcswidth :: String -> Int
53safeWcswidth :: String -> Int
33−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+165−93
@@ -1,21 +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
3+
4−-- 'Event's.
4+-- | Vty provides interfaces for both terminal input and terminal
5−--
5+-- output.
6−-- - The output is defined by a 'Picture'. Which is one or more layers
7−-- of 'Image's.
8−--
9−-- - The module "Graphics.Vty.Image" provides a number of
10−-- constructor equations that will build correct 'Image' values.
11−-- See 'string', '<|>', and '<->' for starters.
12--
6--
13−-- - The constructors in "Graphics.Vty.Image.Internal" should not
7+-- - Input to the terminal is provided to the Vty application as a
14−-- be used.
8+-- sequence of 'Event's.
15--
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)
16−-- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
14+-- values in the "Graphics.Vty.Attributes" module.
17--
15--
18−-- 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.
19--
18--
20-- @
19-- @
21-- import "Graphics.Vty"
20-- import "Graphics.Vty"
@@ -23,10 +22,8 @@
23-- main = do
22-- main = do
24-- cfg <- 'standardIOConfig'
23-- cfg <- 'standardIOConfig'
25-- vty <- 'mkVty' cfg
24-- vty <- 'mkVty' cfg
26−-- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green')
25+-- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\"
27−-- \"first line\"
28−-- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue')
26+-- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\"
29−-- \"second line\"
30-- img = line0 '<->' line1
27-- img = line0 '<->' line1
31-- pic = 'picForImage' img
28-- pic = 'picForImage' img
32-- 'update' vty pic
29-- 'update' vty pic
@@ -34,23 +31,11 @@
34-- 'shutdown' vty
31-- 'shutdown' vty
35-- 'print' (\"Last event was: \" '++' 'show' e)
32-- 'print' (\"Last event was: \" '++' 'show' e)
36-- @
33-- @
37−--
38−-- Good sources of documentation for terminal programming are:
39−--
40−-- - <https://github.com/b4winckler/vim/blob/master/src/term.c>
41−--
42−-- - <http://invisible-island.net/xterm/ctlseqs/ctlseqs.html>
43−--
44−-- - <http://ulisse.elettra.trieste.it/services/doc/serial/config.html>
45−--
46−-- - <http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html>
47−--
48−-- - <http://www.unixwiz.net/techtips/termios-vmin-vtime.html>
49−--
50−-- - <http://vt100.net/docs/vt100-ug/chapter3.html vt100 control sequences>
51module Graphics.Vty
34module Graphics.Vty
52 ( Vty(..)
35 ( Vty(..)
53 , mkVty
36 , mkVty
37+ , setWindowTitle
38+ , Mode(..)
54 , module Graphics.Vty.Config
39 , module Graphics.Vty.Config
55 , module Graphics.Vty.Input
40 , module Graphics.Vty.Input
56 , module Graphics.Vty.Output
41 , module Graphics.Vty.Output
@@ -58,85 +43,141 @@ module Graphics.Vty
58 , module Graphics.Vty.Picture
43 , module Graphics.Vty.Picture
59 , module Graphics.Vty.Image
44 , module Graphics.Vty.Image
60 , module Graphics.Vty.Attributes
45 , module Graphics.Vty.Attributes
61− , Mode(..)
62 )
46 )
63where
47where
64
48
65import Graphics.Vty.Config
49import Graphics.Vty.Config
66import Graphics.Vty.Input
50import Graphics.Vty.Input
51+import Graphics.Vty.Input.Events
67import Graphics.Vty.Output
52import Graphics.Vty.Output
68import Graphics.Vty.Output.Interface
53import Graphics.Vty.Output.Interface
69import Graphics.Vty.Picture
54import Graphics.Vty.Picture
70import Graphics.Vty.Image
55import Graphics.Vty.Image
71import Graphics.Vty.Attributes
56import Graphics.Vty.Attributes
57+import Graphics.Vty.UnicodeWidthTable.IO
58+import Graphics.Vty.UnicodeWidthTable.Install
59+
60+import Data.Char (isPrint, showLitChar)
61+import qualified Data.ByteString.Char8 as BS8
72
62
63+import qualified Control.Exception as E
64+import Control.Monad (when)
73import Control.Concurrent.STM
65import Control.Concurrent.STM
74
66
75import Data.IORef
67import Data.IORef
68+#if !(MIN_VERSION_base(4,11,0))
76−import Data.Monoid
69+import Data.Semigroup ((<>))
70+#endif
77
71
78−-- | 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.
79--
74--
80-- The use of Vty typically follows this process:
75-- The use of Vty typically follows this process:
81--
76--
82−-- 0. initialize vty
77+-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
83−--
78+--
84−-- 1. use the update equation of Vty to display a picture
79+-- 2. Use 'update' to display a picture.
85−--
86−-- 2. repeat
87−--
80+--
88−-- 3. shutdown vty.
81+-- 3. Use 'nextEvent' to get the next input event.
89−--
82+--
90−-- An alternative to tracking the Vty instance is to use 'withVty' in
83+-- 4. Depending on the event, go to 2 or 5.
91−-- "Graphics.Vty.Inline.Unsafe".
84+--
85+-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
86+-- this point the 'Vty' handle cannot be used again.
92−--
87+--
93−-- This does not assure any thread safety. In theory, as long as an
88+-- Operations on Vty handles are not thread-safe.
94−-- update action is not executed when another update action is already
95−-- then it's safe to call this on multiple threads.
96−data Vty = Vty
89+data Vty =
97− { -- | Outputs the given Picture. Equivalent to 'outputPicture'
98− -- applied to a display context implicitly managed by Vty. The
99− -- managed display context is reset on resize.
100− update :: Picture -> IO ()
90+ Vty { update :: Picture -> IO ()
101− -- | Get one Event object, blocking if necessary. This will
91+ -- ^ Outputs the given 'Picture'.
102− -- refresh the terminal if the event is a 'EvResize'.
92+ , nextEvent :: IO Event
93+ -- ^ Return the next 'Event' or block until one becomes
94+ -- available.
95+ , nextEventNonblocking :: IO (Maybe Event)
103− , nextEvent :: IO Event
96+ -- ^ Non-blocking version of 'nextEvent'.
104− -- | The input interface. See 'Input'
105− , inputIface :: Input
97+ , inputIface :: Input
106− -- | The output interface. See 'Output'
98+ -- ^ The input interface. See 'Input'.
107− , outputIface :: Output
99+ , outputIface :: Output
108− -- | Refresh the display. 'nextEvent' will refresh the display if
100+ -- ^ The output interface. See 'Output'.
101+ , refresh :: IO ()
109− -- a resize occurs. If other programs output to the terminal and
102+ -- ^ Refresh the display. If other programs output to the
110− -- mess up the display then the application might want to force a
103+ -- terminal and mess up the display then the application might
111− -- refresh.
104+ -- want to force a refresh using this function.
112− , refresh :: IO ()
105+ , shutdown :: IO ()
113− -- | 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.
114− -- The above methods will throw an exception if executed after
108+ -- The above methods will throw an exception if executed after
115− -- this is executed.
109+ -- this is executed. Idempotent.
116− , shutdown :: IO ()
110+ , isShutdown :: IO Bool
117− }
111+ }
118−
112+
119−-- | Set up the state object for using vty. At most one state object
113+-- | Create a Vty handle. At most one handle should be created at a time
120−-- should be created at a time for a given terminal device.
114+-- for a given terminal device.
121−--
115+--
122−-- The specified config is added to the 'userConfig'. With the
116+-- The specified configuration is added to the the configuration
117+-- loaded by 'userConfig' with the 'userConfig' configuration taking
123−-- 'userConfig' taking precedence. See "Graphics.Vty.Config"
118+-- precedence. See "Graphics.Vty.Config".
124−--
119+--
125−-- For most applications @mkVty def@ is sufficient.
120+-- For most applications @mkVty defaultConfig@ is sufficient.
126mkVty :: Config -> IO Vty
121mkVty :: Config -> IO Vty
127mkVty appConfig = do
122mkVty appConfig = do
128 config <- (<> appConfig) <$> userConfig
123 config <- (<> appConfig) <$> userConfig
129− input <- inputForConfig config
130− out <- outputForConfig config
131− intMkVty input out
132
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+
133−intMkVty :: Input -> Output -> IO Vty
167+internalMkVty :: Input -> Output -> IO Vty
134−intMkVty input out = do
168+internalMkVty input out = do
135 reserveDisplay out
169 reserveDisplay out
170+
171+ shutdownVar <- newTVarIO False
136 let shutdownIo = do
172 let shutdownIo = do
173+ alreadyShutdown <- atomically $ swapTVar shutdownVar True
174+ when (not alreadyShutdown) $ do
137− shutdownInput input
175+ shutdownInput input
138− releaseDisplay out
176+ releaseDisplay out
139− releaseTerminal out
177+ releaseTerminal out
178+
179+ let shutdownStatus = readTVarIO shutdownVar
180+
140 lastPicRef <- newIORef Nothing
181 lastPicRef <- newIORef Nothing
141 lastUpdateRef <- newIORef Nothing
182 lastUpdateRef <- newIORef Nothing
142
183
@@ -168,16 +209,47 @@ intMkVty input out = do
168 mPic <- readIORef lastPicRef
209 mPic <- readIORef lastPicRef
169 maybe (return ()) innerUpdate mPic
210 maybe (return ()) innerUpdate mPic
170
211
212+ let mkResize = uncurry EvResize <$> displayBounds out
213+
214+ translateInternalEvent ResumeAfterSignal = mkResize
215+ translateInternalEvent (InputEvent e) = return e
216+
217+ gkey = do
171− 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
172− case k of
222+ case mEv of
173− (EvResize _ _) -> displayBounds out
223+ Just e -> Just <$> translateInternalEvent e
174− >>= return . (\(w,h)-> EvResize w h)
175− _ -> return k
224+ Nothing -> return Nothing
176
225
177 return $ Vty { update = innerUpdate
226 return $ Vty { update = innerUpdate
178 , nextEvent = gkey
227 , nextEvent = gkey
228+ , nextEventNonblocking = gkey'
179 , inputIface = input
229 , inputIface = input
180 , outputIface = out
230 , outputIface = out
181 , refresh = innerRefresh
231 , refresh = innerRefresh
182 , shutdown = shutdownIo
232 , shutdown = shutdownIo
233+ , isShutdown = shutdownStatus
183 }
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+85−82
@@ -1,46 +1,71 @@
1−{-# LANGUAGE StandaloneDeriving #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE DeriveAnyClass #-}
4
4
5-- | Display attributes
5-- | Display attributes
6--
6--
7−-- Typically the values 'defAttr' or 'currentAttr' are modified to form
7+-- Attributes have three components: a foreground color, a background
8−-- attributes:
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.,
9--
11--
10-- @
12-- @
11−-- defAttr `withForeColor` red
13+-- defAttr \`withForeColor\` red
12-- @
14-- @
13--
15--
14−-- Is the attribute that will set the foreground color to red and the
16+-- 'Image' constructors often require an 'Attr' to indicate the
15−-- background color to the default.
17+-- attributes used in the image, e.g.,
16−--
17−-- This can then be used to build an image with a red foreground like
18−-- so:
19--
18--
20-- @
19-- @
21−-- string (defAttr `withForeColor` red) "this text will be red"
20+-- string (defAttr \`withForeColor\` red) "this text will be red"
22-- @
21-- @
23--
22--
24−-- The default attributes set by 'defAttr' have a presentation
23+-- The appearance of 'Image's using 'defAttr' is determined by the The
25−-- determined by the terminal. This is not something VTY can control.
24+-- terminal, so this is not something VTY can control. The user is free
26−-- The user is free to define the color scheme of the terminal as they
25+-- to The define the color scheme of the terminal as they see fit.
27−-- see fit. Up to the limits of the terminal anyways.
28--
26--
29-- The value 'currentAttr' will keep the attributes of whatever was
27-- The value 'currentAttr' will keep the attributes of whatever was
30-- output previously.
28-- output previously.
31module Graphics.Vty.Attributes
29module Graphics.Vty.Attributes
32− ( module Graphics.Vty.Attributes
30+ ( module Graphics.Vty.Attributes.Color
33− , module Graphics.Vty.Attributes.Color
31+
34− , module Graphics.Vty.Attributes.Color240
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
35 )
59 )
36where
60where
37
61
62+import Control.DeepSeq
38import Data.Bits
63import Data.Bits
39−import Data.Default
64+import Data.Text (Text)
40import Data.Word
65import Data.Word
66+import GHC.Generics
41
67
42import Graphics.Vty.Attributes.Color
68import Graphics.Vty.Attributes.Color
43−import Graphics.Vty.Attributes.Color240
44
69
45-- | A display attribute defines the Color and Style of all the
70-- | A display attribute defines the Color and Style of all the
46-- characters rendered after the attribute is applied.
71-- characters rendered after the attribute is applied.
@@ -53,7 +78,8 @@ data Attr = Attr
53 { attrStyle :: !(MaybeDefault Style)
78 { attrStyle :: !(MaybeDefault Style)
54 , attrForeColor :: !(MaybeDefault Color)
79 , attrForeColor :: !(MaybeDefault Color)
55 , attrBackColor :: !(MaybeDefault Color)
80 , attrBackColor :: !(MaybeDefault Color)
81+ , attrURL :: !(MaybeDefault Text)
56− } deriving ( Eq, Show, Read )
82+ } deriving ( Eq, Show, Read, Generic, NFData )
57
83
58-- This could be encoded into a single 32 bit word. The 32 bit word is
84-- This could be encoded into a single 32 bit word. The 32 bit word is
59-- first divided into 4 groups of 8 bits where: The first group codes
85-- first divided into 4 groups of 8 bits where: The first group codes
@@ -74,25 +100,19 @@ data Attr = Attr
74-- __ - unused
100-- __ - unused
75--
101--
76-- Next is the style flags
102-- Next is the style flags
77−-- SURBDO__
103+-- SURBDOI_
78-- S - standout
104-- S - standout
79-- U - underline
105-- U - underline
80-- R - reverse video
106-- R - reverse video
81-- B - blink
107-- B - blink
82-- D - dim
108-- D - dim
83-- O - bold
109-- O - bold
110+-- I - italic
84−-- __ - unused
111+-- _ - unused
85--
112--
86-- Then the foreground color encoded into 8 bits.
113-- Then the foreground color encoded into 8 bits.
87-- Then the background color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
88
115
89−instance Monoid Attr where
90− mempty = Attr mempty mempty mempty
91− mappend attr0 attr1 =
92− Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
93− ( attrForeColor attr0 `mappend` attrForeColor attr1 )
94− ( attrBackColor attr0 `mappend` attrBackColor attr1 )
95−
96-- | Specifies the display attributes such that the final style and
116-- | Specifies the display attributes such that the final style and
97-- color values do not depend on the previously applied display
117-- color values do not depend on the previously applied display
98-- attribute. The display attributes can still depend on the terminal's
118-- attribute. The display attributes can still depend on the terminal's
@@ -101,61 +121,26 @@ data FixedAttr = FixedAttr
101 { fixedStyle :: !Style
121 { fixedStyle :: !Style
102 , fixedForeColor :: !(Maybe Color)
122 , fixedForeColor :: !(Maybe Color)
103 , fixedBackColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
124+ , fixedURL :: !(Maybe Text)
104 } deriving ( Eq, Show )
125 } deriving ( Eq, Show )
105
126
106-- | The style and color attributes can either be the terminal defaults.
127-- | The style and color attributes can either be the terminal defaults.
107-- Or be equivalent to the previously applied style. Or be a specific
128-- Or be equivalent to the previously applied style. Or be a specific
108-- value.
129-- value.
109−data MaybeDefault v where
130+data MaybeDefault v = Default | KeepCurrent | SetTo !v
110− Default :: MaybeDefault v
131+ deriving (Eq, Read, Show)
111− KeepCurrent :: MaybeDefault v
132+
112− SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
113−
114−deriving instance Eq v => Eq (MaybeDefault v)
115−deriving instance Eq v => Show (MaybeDefault v)
116−deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
117−
118−instance Eq v => Monoid ( MaybeDefault v ) where
133+instance (NFData v) => NFData (MaybeDefault v) where
119− mempty = KeepCurrent
134+ rnf Default = ()
120− mappend Default Default = Default
121− mappend Default KeepCurrent = Default
122− mappend Default ( SetTo v ) = SetTo v
123− mappend KeepCurrent Default = Default
124− mappend KeepCurrent KeepCurrent = KeepCurrent
135+ rnf KeepCurrent = ()
125− mappend KeepCurrent ( SetTo v ) = SetTo v
136+ rnf (SetTo v) = rnf v
126− mappend ( SetTo _v ) Default = Default
127− mappend ( SetTo v ) KeepCurrent = SetTo v
128− mappend ( SetTo _ ) ( SetTo v ) = SetTo v
129−
130−-- | Standard 8-color ANSI terminal color codes.
131−black, red, green, yellow, blue, magenta, cyan, white :: Color
132−black = ISOColor 0
133−red = ISOColor 1
134−green = ISOColor 2
135−yellow = ISOColor 3
136−blue = ISOColor 4
137−magenta= ISOColor 5
138−cyan = ISOColor 6
139−white = ISOColor 7
140−
141−-- | Bright/Vivid variants of the standard 8-color ANSI
142−brightBlack, brightRed, brightGreen, brightYellow :: Color
143−brightBlue, brightMagenta, brightCyan, brightWhite :: Color
144−brightBlack = ISOColor 8
145−brightRed = ISOColor 9
146−brightGreen = ISOColor 10
147−brightYellow = ISOColor 11
148−brightBlue = ISOColor 12
149−brightMagenta= ISOColor 13
150−brightCyan = ISOColor 14
151−brightWhite = ISOColor 15
152
137
153-- | Styles are represented as an 8 bit word. Each bit in the word is 1
138-- | Styles are represented as an 8 bit word. Each bit in the word is 1
154-- if the style attribute assigned to that bit should be applied and 0
139-- if the style attribute assigned to that bit should be applied and 0
155-- if the style attribute should not be applied.
140-- if the style attribute should not be applied.
156type Style = Word8
141type Style = Word8
157
142
158−-- | The 6 possible style attributes:
143+-- | Valid style attributes include:
159--
144--
160-- * standout
145-- * standout
161--
146--
@@ -169,15 +154,21 @@ type Style = Word8
169--
154--
170-- * bold/bright
155-- * bold/bright
171--
156--
157+-- * italic
158+--
159+-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160+--
172-- (The invisible, protect, and altcharset display attributes some
161-- (The invisible, protect, and altcharset display attributes some
173-- terminals support are not supported via VTY.)
162-- terminals support are not supported via VTY.)
174−standout, underline, reverseVideo, blink, dim, bold :: Style
163+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
175standout = 0x01
164standout = 0x01
176underline = 0x02
165underline = 0x02
177−reverseVideo = 0x04
166+reverseVideo = 0x04
178blink = 0x08
167blink = 0x08
179dim = 0x10
168dim = 0x10
180bold = 0x20
169bold = 0x20
170+italic = 0x40
171+strikethrough = 0x80
181
172
182defaultStyleMask :: Style
173defaultStyleMask :: Style
183defaultStyleMask = 0x00
174defaultStyleMask = 0x00
@@ -203,16 +194,28 @@ withBackColor attr c = attr { attrBackColor = SetTo c }
203
194
204-- | Add the given style attribute
195-- | Add the given style attribute
205withStyle :: Attr -> Style -> Attr
196withStyle :: Attr -> Style -> Attr
197+withStyle attr 0 = attr
206withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
207
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+
208-- | Sets the style, background color and foreground color to the
214-- | Sets the style, background color and foreground color to the
209-- default values for the terminal. There is no easy way to determine
215-- default values for the terminal. There is no easy way to determine
210-- what the default background and foreground colors are.
216-- what the default background and foreground colors are.
211defAttr :: Attr
217defAttr :: Attr
212−defAttr = Attr Default Default Default
218+defAttr = Attr Default Default Default Default
213−
214−instance Default Attr where
215− def = defAttr
216
219
217-- | Keeps the style, background color and foreground color that was
220-- | Keeps the style, background color and foreground color that was
218-- previously set. Used to override some part of the previous style.
221-- previously set. Used to override some part of the previous style.
@@ -222,4 +225,4 @@ instance Default Attr where
222-- Would be the currently applied style (be it underline, bold, etc) but
225-- Would be the currently applied style (be it underline, bold, etc) but
223-- with the foreground color set to brightMagenta.
226-- with the foreground color set to brightMagenta.
224currentAttr :: Attr
227currentAttr :: Attr
225−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
228+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs+137−4
@@ -1,6 +1,61 @@
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
2
48
3import 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
4
59
5-- | Abstract data type representing a color.
60-- | Abstract data type representing a color.
6--
61--
@@ -40,7 +95,7 @@ import Data.Word
40-- reported then the color reproduction will be incorrect.
95-- reported then the color reproduction will be incorrect.
41--
96--
42-- If the terminal reports <= 16 colors then the 240 color palette
97-- If the terminal reports <= 16 colors then the 240 color palette
43−-- points are only mapped to the 8 color pallete. I'm not sure of
98+-- points are only mapped to the 8 color palette. I'm not sure of
44-- 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
45-- addressable via the 240 color palette.
100-- addressable via the 240 color palette.
46--
101--
@@ -54,5 +109,83 @@ import Data.Word
54-- terminfo but I don't know it.
109-- terminfo but I don't know it.
55--
110--
56-- Seriously, terminal color support is INSANE.
111-- Seriously, terminal color support is INSANE.
57−data Color = ISOColor !Word8 | Color240 !Word8
112+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8
58− 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+290−250
@@ -1,258 +1,298 @@
1-- This header file was generated by ./256colres.pl
1-- This header file was generated by ./256colres.pl
2−module Graphics.Vty.Attributes.Color240 where
2+module Graphics.Vty.Attributes.Color240
3−
3+ ( rgbColorToColor240
4−import Graphics.Vty.Attributes.Color
4+ , color240CodeToRGB
5+ )
6+where
5
7
8+import Data.Word (Word8)
6import Text.Printf
9import Text.Printf
7
10
8−-- | RGB color to 240 color palette.
11+-- Note: rgbColor's mapping from RGB to 240 colors was generated from
9−--
10−-- generated from 256colres.pl which is forked from xterm 256colres.pl
12+-- 256colres.pl which is forked from xterm 256colres.pl.
13+
14+-- | Create a value in the Color240 set from an RGB triple
11−rgbColor :: Integral i => i -> i -> i -> Color
15+rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
12−rgbColor r g b
16+rgbColorToColor240 r g b
13 | 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"
14− | r == 8 && g == 8 && b == 8 = Color240 216
18+ | r == 8 && g == 8 && b == 8 = 216
15− | r == 18 && g == 18 && b == 18 = Color240 217
19+ | r == 18 && g == 18 && b == 18 = 217
16− | r == 28 && g == 28 && b == 28 = Color240 218
20+ | r == 28 && g == 28 && b == 28 = 218
17− | r == 38 && g == 38 && b == 38 = Color240 219
21+ | r == 38 && g == 38 && b == 38 = 219
18− | r == 48 && g == 48 && b == 48 = Color240 220
22+ | r == 48 && g == 48 && b == 48 = 220
19− | r == 58 && g == 58 && b == 58 = Color240 221
23+ | r == 58 && g == 58 && b == 58 = 221
20− | r == 68 && g == 68 && b == 68 = Color240 222
24+ | r == 68 && g == 68 && b == 68 = 222
21− | r == 78 && g == 78 && b == 78 = Color240 223
25+ | r == 78 && g == 78 && b == 78 = 223
22− | r == 88 && g == 88 && b == 88 = Color240 224
26+ | r == 88 && g == 88 && b == 88 = 224
23− | r == 98 && g == 98 && b == 98 = Color240 225
27+ | r == 98 && g == 98 && b == 98 = 225
24− | r == 108 && g == 108 && b == 108 = Color240 226
28+ | r == 108 && g == 108 && b == 108 = 226
25− | r == 118 && g == 118 && b == 118 = Color240 227
29+ | r == 118 && g == 118 && b == 118 = 227
26− | r == 128 && g == 128 && b == 128 = Color240 228
30+ | r == 128 && g == 128 && b == 128 = 228
27− | r == 138 && g == 138 && b == 138 = Color240 229
31+ | r == 138 && g == 138 && b == 138 = 229
28− | r == 148 && g == 148 && b == 148 = Color240 230
32+ | r == 148 && g == 148 && b == 148 = 230
29− | r == 158 && g == 158 && b == 158 = Color240 231
33+ | r == 158 && g == 158 && b == 158 = 231
30− | r == 168 && g == 168 && b == 168 = Color240 232
34+ | r == 168 && g == 168 && b == 168 = 232
31− | r == 178 && g == 178 && b == 178 = Color240 233
35+ | r == 178 && g == 178 && b == 178 = 233
32− | r == 188 && g == 188 && b == 188 = Color240 234
36+ | r == 188 && g == 188 && b == 188 = 234
33− | r == 198 && g == 198 && b == 198 = Color240 235
37+ | r == 198 && g == 198 && b == 198 = 235
34− | r == 208 && g == 208 && b == 208 = Color240 236
38+ | r == 208 && g == 208 && b == 208 = 236
35− | r == 218 && g == 218 && b == 218 = Color240 237
39+ | r == 218 && g == 218 && b == 218 = 237
36− | r == 228 && g == 228 && b == 228 = Color240 238
40+ | r == 228 && g == 228 && b == 228 = 238
37− | r == 238 && g == 238 && b == 238 = Color240 239
41+ | r == 238 && g == 238 && b == 238 = 239
38− | r <= 0 && g <= 0 && b <= 0 = Color240 0
42+ | otherwise = 36 * go r + 6 * go g + go b
39− | 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."
40− | r <= 0 && g <= 0 && b <= 135 = Color240 2
41− | r <= 0 && g <= 0 && b <= 175 = Color240 3
42− | r <= 0 && g <= 0 && b <= 215 = Color240 4
43− | r <= 0 && g <= 0 && b <= 255 = Color240 5
44− | r <= 0 && g <= 95 && b <= 0 = Color240 6
45− | r <= 0 && g <= 95 && b <= 95 = Color240 7
46− | r <= 0 && g <= 95 && b <= 135 = Color240 8
47− | r <= 0 && g <= 95 && b <= 175 = Color240 9
48− | r <= 0 && g <= 95 && b <= 215 = Color240 10
49− | r <= 0 && g <= 95 && b <= 255 = Color240 11
50− | r <= 0 && g <= 135 && b <= 0 = Color240 12
51− | r <= 0 && g <= 135 && b <= 95 = Color240 13
52− | r <= 0 && g <= 135 && b <= 135 = Color240 14
53− | r <= 0 && g <= 135 && b <= 175 = Color240 15
54− | r <= 0 && g <= 135 && b <= 215 = Color240 16
55− | r <= 0 && g <= 135 && b <= 255 = Color240 17
56− | r <= 0 && g <= 175 && b <= 0 = Color240 18
57− | r <= 0 && g <= 175 && b <= 95 = Color240 19
58− | r <= 0 && g <= 175 && b <= 135 = Color240 20
59− | r <= 0 && g <= 175 && b <= 175 = Color240 21
60− | r <= 0 && g <= 175 && b <= 215 = Color240 22
61− | r <= 0 && g <= 175 && b <= 255 = Color240 23
62− | r <= 0 && g <= 215 && b <= 0 = Color240 24
63− | r <= 0 && g <= 215 && b <= 95 = Color240 25
64− | r <= 0 && g <= 215 && b <= 135 = Color240 26
65− | r <= 0 && g <= 215 && b <= 175 = Color240 27
66− | r <= 0 && g <= 215 && b <= 215 = Color240 28
67− | r <= 0 && g <= 215 && b <= 255 = Color240 29
68− | r <= 0 && g <= 255 && b <= 0 = Color240 30
69− | r <= 0 && g <= 255 && b <= 95 = Color240 31
70− | r <= 0 && g <= 255 && b <= 135 = Color240 32
71− | r <= 0 && g <= 255 && b <= 175 = Color240 33
72− | r <= 0 && g <= 255 && b <= 215 = Color240 34
73− | r <= 0 && g <= 255 && b <= 255 = Color240 35
74− | r <= 95 && g <= 0 && b <= 0 = Color240 36
75− | r <= 95 && g <= 0 && b <= 95 = Color240 37
76− | r <= 95 && g <= 0 && b <= 135 = Color240 38
77− | r <= 95 && g <= 0 && b <= 175 = Color240 39
78− | r <= 95 && g <= 0 && b <= 215 = Color240 40
79− | r <= 95 && g <= 0 && b <= 255 = Color240 41
80− | r <= 95 && g <= 95 && b <= 0 = Color240 42
81− | r <= 95 && g <= 95 && b <= 95 = Color240 43
82− | r <= 95 && g <= 95 && b <= 135 = Color240 44
83− | r <= 95 && g <= 95 && b <= 175 = Color240 45
84− | r <= 95 && g <= 95 && b <= 215 = Color240 46
85− | r <= 95 && g <= 95 && b <= 255 = Color240 47
86− | r <= 95 && g <= 135 && b <= 0 = Color240 48
87− | r <= 95 && g <= 135 && b <= 95 = Color240 49
88− | r <= 95 && g <= 135 && b <= 135 = Color240 50
89− | r <= 95 && g <= 135 && b <= 175 = Color240 51
90− | r <= 95 && g <= 135 && b <= 215 = Color240 52
91− | r <= 95 && g <= 135 && b <= 255 = Color240 53
92− | r <= 95 && g <= 175 && b <= 0 = Color240 54
93− | r <= 95 && g <= 175 && b <= 95 = Color240 55
94− | r <= 95 && g <= 175 && b <= 135 = Color240 56
95− | r <= 95 && g <= 175 && b <= 175 = Color240 57
96− | r <= 95 && g <= 175 && b <= 215 = Color240 58
97− | r <= 95 && g <= 175 && b <= 255 = Color240 59
98− | r <= 95 && g <= 215 && b <= 0 = Color240 60
99− | r <= 95 && g <= 215 && b <= 95 = Color240 61
100− | r <= 95 && g <= 215 && b <= 135 = Color240 62
101− | r <= 95 && g <= 215 && b <= 175 = Color240 63
102− | r <= 95 && g <= 215 && b <= 215 = Color240 64
103− | r <= 95 && g <= 215 && b <= 255 = Color240 65
104− | r <= 95 && g <= 255 && b <= 0 = Color240 66
105− | r <= 95 && g <= 255 && b <= 95 = Color240 67
106− | r <= 95 && g <= 255 && b <= 135 = Color240 68
107− | r <= 95 && g <= 255 && b <= 175 = Color240 69
108− | r <= 95 && g <= 255 && b <= 215 = Color240 70
109− | r <= 95 && g <= 255 && b <= 255 = Color240 71
110− | r <= 135 && g <= 0 && b <= 0 = Color240 72
111− | r <= 135 && g <= 0 && b <= 95 = Color240 73
112− | r <= 135 && g <= 0 && b <= 135 = Color240 74
113− | r <= 135 && g <= 0 && b <= 175 = Color240 75
114− | r <= 135 && g <= 0 && b <= 215 = Color240 76
115− | r <= 135 && g <= 0 && b <= 255 = Color240 77
116− | r <= 135 && g <= 95 && b <= 0 = Color240 78
117− | r <= 135 && g <= 95 && b <= 95 = Color240 79
118− | r <= 135 && g <= 95 && b <= 135 = Color240 80
119− | r <= 135 && g <= 95 && b <= 175 = Color240 81
120− | r <= 135 && g <= 95 && b <= 215 = Color240 82
121− | r <= 135 && g <= 95 && b <= 255 = Color240 83
122− | r <= 135 && g <= 135 && b <= 0 = Color240 84
123− | r <= 135 && g <= 135 && b <= 95 = Color240 85
124− | r <= 135 && g <= 135 && b <= 135 = Color240 86
125− | r <= 135 && g <= 135 && b <= 175 = Color240 87
126− | r <= 135 && g <= 135 && b <= 215 = Color240 88
127− | r <= 135 && g <= 135 && b <= 255 = Color240 89
128− | r <= 135 && g <= 175 && b <= 0 = Color240 90
129− | r <= 135 && g <= 175 && b <= 95 = Color240 91
130− | r <= 135 && g <= 175 && b <= 135 = Color240 92
131− | r <= 135 && g <= 175 && b <= 175 = Color240 93
132− | r <= 135 && g <= 175 && b <= 215 = Color240 94
133− | r <= 135 && g <= 175 && b <= 255 = Color240 95
134− | r <= 135 && g <= 215 && b <= 0 = Color240 96
135− | r <= 135 && g <= 215 && b <= 95 = Color240 97
136− | r <= 135 && g <= 215 && b <= 135 = Color240 98
137− | r <= 135 && g <= 215 && b <= 175 = Color240 99
138− | r <= 135 && g <= 215 && b <= 215 = Color240 100
139− | r <= 135 && g <= 215 && b <= 255 = Color240 101
140− | r <= 135 && g <= 255 && b <= 0 = Color240 102
141− | r <= 135 && g <= 255 && b <= 95 = Color240 103
142− | r <= 135 && g <= 255 && b <= 135 = Color240 104
143− | r <= 135 && g <= 255 && b <= 175 = Color240 105
144− | r <= 135 && g <= 255 && b <= 215 = Color240 106
145− | r <= 135 && g <= 255 && b <= 255 = Color240 107
146− | r <= 175 && g <= 0 && b <= 0 = Color240 108
147− | r <= 175 && g <= 0 && b <= 95 = Color240 109
148− | r <= 175 && g <= 0 && b <= 135 = Color240 110
149− | r <= 175 && g <= 0 && b <= 175 = Color240 111
150− | r <= 175 && g <= 0 && b <= 215 = Color240 112
151− | r <= 175 && g <= 0 && b <= 255 = Color240 113
152− | r <= 175 && g <= 95 && b <= 0 = Color240 114
153− | r <= 175 && g <= 95 && b <= 95 = Color240 115
154− | r <= 175 && g <= 95 && b <= 135 = Color240 116
155− | r <= 175 && g <= 95 && b <= 175 = Color240 117
156− | r <= 175 && g <= 95 && b <= 215 = Color240 118
157− | r <= 175 && g <= 95 && b <= 255 = Color240 119
158− | r <= 175 && g <= 135 && b <= 0 = Color240 120
159− | r <= 175 && g <= 135 && b <= 95 = Color240 121
160− | r <= 175 && g <= 135 && b <= 135 = Color240 122
161− | r <= 175 && g <= 135 && b <= 175 = Color240 123
162− | r <= 175 && g <= 135 && b <= 215 = Color240 124
163− | r <= 175 && g <= 135 && b <= 255 = Color240 125
164− | r <= 175 && g <= 175 && b <= 0 = Color240 126
165− | r <= 175 && g <= 175 && b <= 95 = Color240 127
166− | r <= 175 && g <= 175 && b <= 135 = Color240 128
167− | r <= 175 && g <= 175 && b <= 175 = Color240 129
168− | r <= 175 && g <= 175 && b <= 215 = Color240 130
169− | r <= 175 && g <= 175 && b <= 255 = Color240 131
170− | r <= 175 && g <= 215 && b <= 0 = Color240 132
171− | r <= 175 && g <= 215 && b <= 95 = Color240 133
172− | r <= 175 && g <= 215 && b <= 135 = Color240 134
173− | r <= 175 && g <= 215 && b <= 175 = Color240 135
174− | r <= 175 && g <= 215 && b <= 215 = Color240 136
175− | r <= 175 && g <= 215 && b <= 255 = Color240 137
176− | r <= 175 && g <= 255 && b <= 0 = Color240 138
177− | r <= 175 && g <= 255 && b <= 95 = Color240 139
178− | r <= 175 && g <= 255 && b <= 135 = Color240 140
179− | r <= 175 && g <= 255 && b <= 175 = Color240 141
180− | r <= 175 && g <= 255 && b <= 215 = Color240 142
181− | r <= 175 && g <= 255 && b <= 255 = Color240 143
182− | r <= 215 && g <= 0 && b <= 0 = Color240 144
183− | r <= 215 && g <= 0 && b <= 95 = Color240 145
184− | r <= 215 && g <= 0 && b <= 135 = Color240 146
185− | r <= 215 && g <= 0 && b <= 175 = Color240 147
186− | r <= 215 && g <= 0 && b <= 215 = Color240 148
187− | r <= 215 && g <= 0 && b <= 255 = Color240 149
188− | r <= 215 && g <= 95 && b <= 0 = Color240 150
189− | r <= 215 && g <= 95 && b <= 95 = Color240 151
190− | r <= 215 && g <= 95 && b <= 135 = Color240 152
191− | r <= 215 && g <= 95 && b <= 175 = Color240 153
192− | r <= 215 && g <= 95 && b <= 215 = Color240 154
193− | r <= 215 && g <= 95 && b <= 255 = Color240 155
194− | r <= 215 && g <= 135 && b <= 0 = Color240 156
195− | r <= 215 && g <= 135 && b <= 95 = Color240 157
196− | r <= 215 && g <= 135 && b <= 135 = Color240 158
197− | r <= 215 && g <= 135 && b <= 175 = Color240 159
198− | r <= 215 && g <= 135 && b <= 215 = Color240 160
199− | r <= 215 && g <= 135 && b <= 255 = Color240 161
200− | r <= 215 && g <= 175 && b <= 0 = Color240 162
201− | r <= 215 && g <= 175 && b <= 95 = Color240 163
202− | r <= 215 && g <= 175 && b <= 135 = Color240 164
203− | r <= 215 && g <= 175 && b <= 175 = Color240 165
204− | r <= 215 && g <= 175 && b <= 215 = Color240 166
205− | r <= 215 && g <= 175 && b <= 255 = Color240 167
206− | r <= 215 && g <= 215 && b <= 0 = Color240 168
207− | r <= 215 && g <= 215 && b <= 95 = Color240 169
208− | r <= 215 && g <= 215 && b <= 135 = Color240 170
209− | r <= 215 && g <= 215 && b <= 175 = Color240 171
210− | r <= 215 && g <= 215 && b <= 215 = Color240 172
211− | r <= 215 && g <= 215 && b <= 255 = Color240 173
212− | r <= 215 && g <= 255 && b <= 0 = Color240 174
213− | r <= 215 && g <= 255 && b <= 95 = Color240 175
214− | r <= 215 && g <= 255 && b <= 135 = Color240 176
215− | r <= 215 && g <= 255 && b <= 175 = Color240 177
216− | r <= 215 && g <= 255 && b <= 215 = Color240 178
217− | r <= 215 && g <= 255 && b <= 255 = Color240 179
218− | r <= 255 && g <= 0 && b <= 0 = Color240 180
219− | r <= 255 && g <= 0 && b <= 95 = Color240 181
220− | r <= 255 && g <= 0 && b <= 135 = Color240 182
221− | r <= 255 && g <= 0 && b <= 175 = Color240 183
222− | r <= 255 && g <= 0 && b <= 215 = Color240 184
223− | r <= 255 && g <= 0 && b <= 255 = Color240 185
224− | r <= 255 && g <= 95 && b <= 0 = Color240 186
225− | r <= 255 && g <= 95 && b <= 95 = Color240 187
226− | r <= 255 && g <= 95 && b <= 135 = Color240 188
227− | r <= 255 && g <= 95 && b <= 175 = Color240 189
228− | r <= 255 && g <= 95 && b <= 215 = Color240 190
229− | r <= 255 && g <= 95 && b <= 255 = Color240 191
230− | r <= 255 && g <= 135 && b <= 0 = Color240 192
231− | r <= 255 && g <= 135 && b <= 95 = Color240 193
232− | r <= 255 && g <= 135 && b <= 135 = Color240 194
233− | r <= 255 && g <= 135 && b <= 175 = Color240 195
234− | r <= 255 && g <= 135 && b <= 215 = Color240 196
235− | r <= 255 && g <= 135 && b <= 255 = Color240 197
236− | r <= 255 && g <= 175 && b <= 0 = Color240 198
237− | r <= 255 && g <= 175 && b <= 95 = Color240 199
238− | r <= 255 && g <= 175 && b <= 135 = Color240 200
239− | r <= 255 && g <= 175 && b <= 175 = Color240 201
240− | r <= 255 && g <= 175 && b <= 215 = Color240 202
241− | r <= 255 && g <= 175 && b <= 255 = Color240 203
242− | r <= 255 && g <= 215 && b <= 0 = Color240 204
243− | r <= 255 && g <= 215 && b <= 95 = Color240 205
244− | r <= 255 && g <= 215 && b <= 135 = Color240 206
245− | r <= 255 && g <= 215 && b <= 175 = Color240 207
246− | r <= 255 && g <= 215 && b <= 215 = Color240 208
247− | r <= 255 && g <= 215 && b <= 255 = Color240 209
248− | r <= 255 && g <= 255 && b <= 0 = Color240 210
249− | r <= 255 && g <= 255 && b <= 95 = Color240 211
250− | r <= 255 && g <= 255 && b <= 135 = Color240 212
251− | r <= 255 && g <= 255 && b <= 175 = Color240 213
252− | r <= 255 && g <= 255 && b <= 215 = Color240 214
253− | r <= 255 && g <= 255 && b <= 255 = Color240 215
254− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
255 (fromIntegral r :: Int)
44 (fromIntegral r :: Int)
256 (fromIntegral g :: Int)
45 (fromIntegral g :: Int)
257− (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
258
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+277−100
@@ -1,24 +1,15 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE LambdaCase, MultiWayIf #-}
7+-- | Vty supports a configuration file format and associated 'Config'
5−-- | A 'Config' can be provided to mkVty to customize the applications
8+-- data type. The 'Config' can be provided to 'mkVty' to customize the
6−-- use of vty. A config file can be used to customize vty for a user's
9+-- application's use of Vty.
7−-- system.
8−--
9−-- The 'Config' provided is mappend'd to 'Config's loaded from
10−-- @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@. The
11−-- @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the
12−-- application provided 'Config'.
13--
10--
14-- Lines in config files that fail to parse are ignored. Later entries
11-- Lines in config files that fail to parse are ignored. Later entries
15−-- take precedence over earlier.
12+-- take precedence over earlier ones.
16−--
17−-- For all directives:
18−--
19−-- @
20−-- string := \"\\\"\" chars+ \"\\\"\"
21−-- @
22--
13--
23-- = Debug
14-- = Debug
24--
15--
@@ -48,7 +39,7 @@
48-- term := "_" | string
39-- term := "_" | string
49-- @
40-- @
50--
41--
51−-- EG: If the contents are
42+-- E.g., if the contents are
52--
43--
53-- @
44-- @
54-- map _ \"\\ESC[B\" KUp []
45-- map _ \"\\ESC[B\" KUp []
@@ -62,11 +53,35 @@
62-- result in the KLeft event when @TERM@ is @xterm@.
53-- result in the KLeft event when @TERM@ is @xterm@.
63--
54--
64-- If a debug log is requested then vty will output the current input
55-- If a debug log is requested then vty will output the current input
65−-- table to the log in the above format.
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
66--
61--
67−-- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings.
62+-- == @widthMap@
68−-- Add corrected mappings to .vty/config
63+--
64+-- Format:
65+--
66+-- @
67+-- \"widthMap\" string string
68+-- @
69+--
70+-- E.g.,
71+--
72+-- @
73+-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"
74+-- @
69--
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.
70module Graphics.Vty.Config
85module Graphics.Vty.Config
71 ( InputMap
86 ( InputMap
72 , Config(..)
87 , Config(..)
@@ -76,6 +91,18 @@ module Graphics.Vty.Config
76 , standardIOConfig
91 , standardIOConfig
77 , runParseConfig
92 , runParseConfig
78 , 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
79 )
106 )
80where
107where
81
108
@@ -87,116 +114,186 @@ import Control.Exception (catch, IOException, Exception(..), throwIO)
87import Control.Monad (liftM, guard, void)
114import Control.Monad (liftM, guard, void)
88
115
89import qualified Data.ByteString as BS
116import qualified Data.ByteString as BS
117+#if !(MIN_VERSION_base(4,8,0))
90−import Data.Default
118+import Data.Monoid (Monoid(..))
119+#endif
120+#if !(MIN_VERSION_base(4,11,0))
91−import Data.Monoid
121+import Data.Semigroup (Semigroup(..))
122+#endif
92import Data.Typeable (Typeable)
123import Data.Typeable (Typeable)
93
124
94import Graphics.Vty.Input.Events
125import Graphics.Vty.Input.Events
126+import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
95
127
96import GHC.Generics
128import GHC.Generics
97
129
98−import System.Directory (getAppUserDataDirectory)
130+import System.Directory ( getAppUserDataDirectory, doesFileExist
131+ , createDirectoryIfMissing
132+ )
99−import System.Posix.Env (getEnv)
133+import System.Environment (lookupEnv)
134+import System.FilePath ((</>), takeDirectory)
100import System.Posix.IO (stdInput, stdOutput)
135import System.Posix.IO (stdInput, stdOutput)
101import System.Posix.Types (Fd(..))
136import System.Posix.Types (Fd(..))
137+import Foreign.C.Types (CInt(..), CChar(..))
102
138
103import Text.Parsec hiding ((<|>))
139import Text.Parsec hiding ((<|>))
104import Text.Parsec.Token ( GenLanguageDef(..) )
140import Text.Parsec.Token ( GenLanguageDef(..) )
105import qualified Text.Parsec.Token as P
141import qualified Text.Parsec.Token as P
106
142
107-- | Type of errors that can be thrown when configuring VTY
143-- | Type of errors that can be thrown when configuring VTY
108−data VtyConfigurationError
144+data VtyConfigurationError =
145+ VtyMissingTermEnvVar
109− = VtyMissingTermEnvVar -- ^ TERM environment variable not set
146+ -- ^ TERM environment variable not set
110− deriving (Show, Eq, Typeable)
147+ deriving (Show, Eq, Typeable)
111
148
112instance Exception VtyConfigurationError where
149instance Exception VtyConfigurationError where
113− displayException VtyMissingTermEnvVar = "TERM environment variable not set"
150+ displayException VtyMissingTermEnvVar = "TERM environment variable not set"
114
151
115-- | Mappings from input bytes to event in the order specified. Later
152-- | Mappings from input bytes to event in the order specified. Later
116-- entries take precedence over earlier in the case multiple entries
153-- entries take precedence over earlier in the case multiple entries
117-- have the same byte string.
154-- have the same byte string.
118type InputMap = [(Maybe String, String, Event)]
155type InputMap = [(Maybe String, String, Event)]
119
156
157+-- | A Vty configuration.
120−data Config = Config
158+data Config =
121− {
122− -- | The default is 1 character.
123− vmin :: Maybe Int
159+ Config { vmin :: Maybe Int
160+ -- ^ The default is 1 character.
161+ , vtime :: Maybe Int
124− -- | The default is 100 milliseconds, 0.1 seconds.
162+ -- ^ The default is 100 milliseconds, 0.1 seconds.
125− , vtime :: Maybe Int
163+ , mouseMode :: Maybe Bool
126− -- | The default is False.
164+ -- ^ The default is False.
127− , mouseMode :: Maybe Bool
165+ , bracketedPasteMode :: Maybe Bool
128− -- | The default is False.
166+ -- ^ The default is False.
129− , bracketedPasteMode :: Maybe Bool
167+ , debugLog :: Maybe FilePath
130− -- | Debug information is appended to this file if not Nothing.
168+ -- ^ Debug information is appended to this file if not
131− , debugLog :: Maybe FilePath
169+ -- Nothing.
170+ , inputMap :: InputMap
132− -- | The (input byte, output event) pairs extend the internal input
171+ -- ^ The (input byte, output event) pairs extend the internal
133− -- table of VTY and the table from terminfo.
172+ -- input table of VTY and the table from terminfo.
134− --
173+ --
135− -- See "Graphics.Vty.Config" module documentation for documentation
174+ -- See "Graphics.Vty.Config" module documentation for
136− -- of the @map@ directive.
175+ -- documentation of the @map@ directive.
137− , inputMap :: InputMap
176+ , inputFd :: Maybe Fd
138− -- | The input file descriptor to use. The default is
177+ -- ^ The input file descriptor to use. The default is
139− -- 'System.Posix.IO.stdInput'
178+ -- 'System.Posix.IO.stdInput'
140− , inputFd :: Maybe Fd
179+ , outputFd :: Maybe Fd
141− -- | The output file descriptor to use. The default is
180+ -- ^ The output file descriptor to use. The default is
142− -- 'System.Posix.IO.stdOutput'
181+ -- 'System.Posix.IO.stdOutput'
143− , outputFd :: Maybe Fd
182+ , termName :: Maybe String
144− -- | The terminal name used to look up terminfo capabilities.
183+ -- ^ The terminal name used to look up terminfo capabilities.
145− -- The default is the value of the TERM environment variable.
184+ -- The default is the value of the TERM environment variable.
146− , 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+ }
147− } deriving (Show, Eq)
202+ deriving (Show, Eq)
148−
203+
204+defaultConfig :: Config
205+defaultConfig = mempty
206+
149−instance Default Config where
207+instance Semigroup Config where
150− 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+ }
151
224
152instance Monoid Config where
225instance Monoid Config where
153− mempty = Config
226+ mempty =
154− { vmin = Nothing
227+ Config { vmin = Nothing
155− , vtime = Nothing
228+ , vtime = Nothing
156− , mouseMode = Nothing
229+ , mouseMode = Nothing
157− , bracketedPasteMode = Nothing
230+ , bracketedPasteMode = Nothing
158− , debugLog = mempty
231+ , debugLog = mempty
159− , inputMap = mempty
232+ , inputMap = mempty
160− , inputFd = Nothing
233+ , inputFd = Nothing
161− , outputFd = Nothing
234+ , outputFd = Nothing
162− , termName = Nothing
235+ , termName = Nothing
236+ , termWidthMaps = []
237+ , allowCustomUnicodeWidthTables = Nothing
238+ , colorMode = Nothing
163− }
239+ }
240+#if !(MIN_VERSION_base(4,11,0))
164− mappend c0 c1 = Config
241+ mappend = (<>)
165− -- latter config takes priority for everything but inputMap
242+#endif
166− { vmin = vmin c1 <|> vmin c0
243+
167− , vtime = vtime c1 <|> vtime c0
244+vtyDataDirectory :: IO FilePath
168− , mouseMode = mouseMode c1
245+vtyDataDirectory = getAppUserDataDirectory "vty"
169− , bracketedPasteMode = bracketedPasteMode c1
246+
170− , debugLog = debugLog c1 <|> debugLog c0
247+vtyConfigPath :: IO FilePath
171− , inputMap = inputMap c0 <> inputMap c1
248+vtyConfigPath = do
172− , inputFd = inputFd c1 <|> inputFd c0
249+ dir <- vtyDataDirectory
173− , outputFd = outputFd c1 <|> outputFd c0
250+ return $ dir </> "config"
174− , termName = termName c1 <|> termName c0
251+
175− }
252+vtyConfigFileEnvName :: String
176−
253+vtyConfigFileEnvName = "VTY_CONFIG_FILE"
177−-- | Config from @'getAppUserDataDirectory'/config@ and
254+
178−-- @$VTY_CONFIG_FILE@
255+-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
179userConfig :: IO Config
256userConfig :: IO Config
180userConfig = do
257userConfig = do
181− configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
258+ configFile <- vtyConfigPath >>= parseConfigFile
182− overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
259+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
260+ lookupEnv vtyConfigFileEnvName
183 let base = configFile <> overrideConfig
261 let base = configFile <> overrideConfig
184 mappend base <$> overrideEnvConfig
262 mappend base <$> overrideEnvConfig
185
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+
186overrideEnvConfig :: IO Config
282overrideEnvConfig :: IO Config
187overrideEnvConfig = do
283overrideEnvConfig = do
188− d <- getEnv "VTY_DEBUG_LOG"
284+ d <- lookupEnv "VTY_DEBUG_LOG"
189− return $ def { debugLog = d }
285+ return $ defaultConfig { debugLog = d }
190
286
191−-- | Configures VTY using defaults suitable for terminals. This action
287+-- | Configures VTY using defaults suitable for terminals. This function
192-- can raise 'VtyConfigurationError'.
288-- can raise 'VtyConfigurationError'.
193standardIOConfig :: IO Config
289standardIOConfig :: IO Config
194standardIOConfig = do
290standardIOConfig = do
195− mb <- getEnv "TERM"
291+ mb <- lookupEnv termVariable
196 case mb of
292 case mb of
197 Nothing -> throwIO VtyMissingTermEnvVar
293 Nothing -> throwIO VtyMissingTermEnvVar
198− Just t ->
294+ Just t -> do
295+ mcolorMode <- detectColorMode t
199− return def
296+ return defaultConfig
200 { vmin = Just 1
297 { vmin = Just 1
201 , mouseMode = Just False
298 , mouseMode = Just False
202 , bracketedPasteMode = Just False
299 , bracketedPasteMode = Just False
@@ -204,25 +301,24 @@ standardIOConfig = do
204 , inputFd = Just stdInput
301 , inputFd = Just stdInput
205 , outputFd = Just stdOutput
302 , outputFd = Just stdOutput
206 , termName = Just t
303 , termName = Just t
304+ , colorMode = Just mcolorMode
207 }
305 }
208
306
209parseConfigFile :: FilePath -> IO Config
307parseConfigFile :: FilePath -> IO Config
210parseConfigFile path = do
308parseConfigFile path = do
211 catch (runParseConfig path <$> BS.readFile path)
309 catch (runParseConfig path <$> BS.readFile path)
212− (\(_ :: IOException) -> return def)
310+ (\(_ :: IOException) -> return defaultConfig)
213
311
214runParseConfig :: String -> BS.ByteString -> Config
312runParseConfig :: String -> BS.ByteString -> Config
215runParseConfig name cfgTxt =
313runParseConfig name cfgTxt =
216 case runParser parseConfig () name cfgTxt of
314 case runParser parseConfig () name cfgTxt of
217 Right cfg -> cfg
315 Right cfg -> cfg
218− Left{} -> def
316+ Left{} -> defaultConfig
219
317
220------------------------------------------------------------------------
318------------------------------------------------------------------------
221
319
222type Parser = Parsec BS.ByteString ()
320type Parser = Parsec BS.ByteString ()
223
321
224−-- I tried to use the haskellStyle here but that was specialized
225−-- (without requirement?) to the String stream type.
226configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
322configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
227configLanguage = LanguageDef
323configLanguage = LanguageDef
228 { commentStart = "{-"
324 { commentStart = "{-"
@@ -249,13 +345,20 @@ mapDecl = do
249 bytes <- P.stringLiteral configLexer
345 bytes <- P.stringLiteral configLexer
250 key <- parseValue
346 key <- parseValue
251 modifiers <- parseValue
347 modifiers <- parseValue
252− return def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
348+ return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
253
349
254debugLogDecl :: Parser Config
350debugLogDecl :: Parser Config
255debugLogDecl = do
351debugLogDecl = do
256 "debugLog" <- P.identifier configLexer
352 "debugLog" <- P.identifier configLexer
257 path <- P.stringLiteral configLexer
353 path <- P.stringLiteral configLexer
258− 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)] }
259
362
260ignoreLine :: Parser ()
363ignoreLine :: Parser ()
261ignoreLine = void $ manyTill anyChar newline
364ignoreLine = void $ manyTill anyChar newline
@@ -263,8 +366,8 @@ ignoreLine = void $ manyTill anyChar newline
263parseConfig :: Parser Config
366parseConfig :: Parser Config
264parseConfig = liftM mconcat $ many $ do
367parseConfig = liftM mconcat $ many $ do
265 P.whiteSpace configLexer
368 P.whiteSpace configLexer
266− let directives = [try mapDecl, try debugLogDecl]
369+ let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]
267− choice directives <|> (ignoreLine >> return def)
370+ choice directives <|> (ignoreLine >> return defaultConfig)
268
371
269class Parse a where parseValue :: Parser a
372class Parse a where parseValue :: Parser a
270instance Parse Char where parseValue = P.charLiteral configLexer
373instance Parse Char where parseValue = P.charLiteral configLexer
@@ -309,3 +412,77 @@ instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
309 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
412 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
310
413
311instance 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+6−6
@@ -12,16 +12,16 @@ import 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+47−4
@@ -1,11 +1,18 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE CPP #-}
3
4
4module Graphics.Vty.DisplayAttributes where
5module Graphics.Vty.DisplayAttributes where
5
6
6import Graphics.Vty.Attributes
7import Graphics.Vty.Attributes
7
8
8import Data.Bits ((.&.))
9import Data.Bits ((.&.))
10+import Data.ByteString (ByteString)
11+#if !(MIN_VERSION_base(4,11,0))
12+import Data.Semigroup (Semigroup(..))
13+#endif
14+import Data.Text (Text)
15+import Data.Text.Encoding (encodeUtf8)
9
16
10-- | Given the previously applied display attributes as a FixedAttr and
17-- | Given the previously applied display attributes as a FixedAttr and
11-- the current display attributes as an Attr produces a FixedAttr that
18-- the current display attributes as an Attr produces a FixedAttr that
@@ -17,6 +24,7 @@ fixDisplayAttr fattr attr
17 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
24 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
18 (fixColor (fixedForeColor fattr) (attrForeColor attr))
25 (fixColor (fixedForeColor fattr) (attrForeColor attr))
19 (fixColor (fixedBackColor fattr) (attrBackColor attr))
26 (fixColor (fixedBackColor fattr) (attrBackColor attr))
27+ (fixURL (fixedURL fattr) (attrURL attr))
20 where
28 where
21 fixStyle _s Default = defaultStyleMask
29 fixStyle _s Default = defaultStyleMask
22 fixStyle s KeepCurrent = s
30 fixStyle s KeepCurrent = s
@@ -24,6 +32,9 @@ fixDisplayAttr fattr attr
24 fixColor _c Default = Nothing
32 fixColor _c Default = Nothing
25 fixColor c KeepCurrent = c
33 fixColor c KeepCurrent = c
26 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
27
38
28-- | difference between two display attributes. Used in the calculation
39-- | difference between two display attributes. Used in the calculation
29-- of the operations required to go from one display attribute to the
40-- of the operations required to go from one display attribute to the
@@ -36,16 +47,23 @@ data DisplayAttrDiff = DisplayAttrDiff
36 { styleDiffs :: [StyleStateChange]
47 { styleDiffs :: [StyleStateChange]
37 , foreColorDiff :: DisplayColorDiff
48 , foreColorDiff :: DisplayColorDiff
38 , backColorDiff :: DisplayColorDiff
49 , backColorDiff :: DisplayColorDiff
50+ , urlDiff :: URLDiff
39 }
51 }
40 deriving (Show)
52 deriving (Show)
41
53
42−instance Monoid DisplayAttrDiff where
54+instance Semigroup DisplayAttrDiff where
43− mempty = DisplayAttrDiff [] NoColorChange NoColorChange
44− mappend d0 d1 =
55+ d0 <> d1 =
45 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
56 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
46 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
57 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
47 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
58 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
59+ ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
48− 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
49
67
50-- | Used in the computation of a final style attribute change.
68-- | Used in the computation of a final style attribute change.
51simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
@@ -58,6 +76,12 @@ simplifyColorDiffs _cd ColorToDefault = ColorToDefault
58simplifyColorDiffs cd NoColorChange = cd
76simplifyColorDiffs cd NoColorChange = cd
59simplifyColorDiffs _cd (SetColor !c) = SetColor c
77simplifyColorDiffs _cd (SetColor !c) = SetColor c
60
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+
61-- | Difference between two display color attribute changes.
85-- | Difference between two display color attribute changes.
62data DisplayColorDiff
86data DisplayColorDiff
63 = ColorToDefault
87 = ColorToDefault
@@ -70,6 +94,10 @@ data DisplayColorDiff
70data StyleStateChange
94data StyleStateChange
71 = ApplyStandout
95 = ApplyStandout
72 | RemoveStandout
96 | RemoveStandout
97+ | ApplyItalic
98+ | RemoveItalic
99+ | ApplyStrikethrough
100+ | RemoveStrikethrough
73 | ApplyUnderline
101 | ApplyUnderline
74 | RemoveUnderline
102 | RemoveUnderline
75 | ApplyReverseVideo
103 | ApplyReverseVideo
@@ -82,6 +110,13 @@ data StyleStateChange
82 | RemoveBold
110 | RemoveBold
83 deriving (Show, Eq)
111 deriving (Show, Eq)
84
112
113+-- Setting and unsetting hyperlinks
114+data URLDiff
115+ = LinkTo !ByteString
116+ | NoLinkChange
117+ | EndLink
118+ deriving (Show, Eq)
119+
85-- | Determines the diff between two display&color attributes. This diff
120-- | Determines the diff between two display&color attributes. This diff
86-- determines the operations that actually get output to the terminal.
121-- determines the operations that actually get output to the terminal.
87displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
@@ -89,8 +124,14 @@ displayAttrDiffs attr attr' = DisplayAttrDiff
89 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
124 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
90 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
125 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
91 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
126 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
127+ , urlDiff = diffURL (fixedURL attr) (fixedURL attr')
92 }
128 }
93
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+
94diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
135diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
95diffColor Nothing (Just c') = SetColor c'
136diffColor Nothing (Just c') = SetColor c'
96diffColor (Just c) (Just c')
137diffColor (Just c) (Just c')
@@ -104,6 +145,8 @@ diffStyles prev cur
104 = mconcat
145 = mconcat
105 [ styleDiff standout ApplyStandout RemoveStandout
146 [ styleDiff standout ApplyStandout RemoveStandout
106 , styleDiff underline ApplyUnderline RemoveUnderline
147 , styleDiff underline ApplyUnderline RemoveUnderline
148+ , styleDiff italic ApplyItalic RemoveItalic
149+ , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
107 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
108 , styleDiff blink ApplyBlink RemoveBlink
151 , styleDiff blink ApplyBlink RemoveBlink
109 , styleDiff dim ApplyDim RemoveDim
152 , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Image.hs+146−84
@@ -1,36 +1,35 @@
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.
5module Graphics.Vty.Image
7module Graphics.Vty.Image
6− ( DisplayText
8+ (
7− , DisplayRegion
9+ -- * Images
8− , regionWidth
9− , regionHeight
10− , Image
10+ Image
11 , imageWidth
11 , imageWidth
12 , imageHeight
12 , imageHeight
13− , horizJoin
13+ -- * Image constructors
14− , (<|>)
14+ , emptyImage
15− , vertJoin
16− , (<->)
17− , horizCat
18− , vertCat
19− , backgroundFill
20− , text
21− , text'
22 , char
15 , char
23 , string
16 , string
24 , iso10646String
17 , iso10646String
25 , utf8String
18 , utf8String
19+ , text
20+ , text'
21+ , backgroundFill
26 , utf8Bytestring
22 , utf8Bytestring
27 , utf8Bytestring'
23 , utf8Bytestring'
28 , charFill
24 , charFill
29− , emptyImage
25+ -- * Combinators
30− , safeWcwidth
26+ , horizJoin
31− , safeWcswidth
27+ , (<|>)
32− , wcwidth
28+ , vertJoin
33− , wcswidth
29+ , (<->)
30+ , horizCat
31+ , vertCat
32+ -- * Image modifications
34 , crop
33 , crop
35 , cropRight
34 , cropRight
36 , cropLeft
35 , cropLeft
@@ -43,6 +42,20 @@ module Graphics.Vty.Image
43 , translate
42 , translate
44 , translateX
43 , translateX
45 , translateY
44 , translateY
45+ -- * Character width functions
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
46 )
59 )
47where
60where
48
61
@@ -58,7 +71,7 @@ import qualified Data.Text.Lazy as TL
58import qualified Data.Text.Lazy.Encoding as TL
71import qualified Data.Text.Lazy.Encoding as TL
59import Data.Word
72import Data.Word
60
73
61−-- | Named alias for a Int pair
74+-- | A region of the display (first width, then height)
62type DisplayRegion = (Int,Int)
75type DisplayRegion = (Int,Int)
63
76
64regionWidth :: DisplayRegion -> Int
77regionWidth :: DisplayRegion -> Int
@@ -70,57 +83,68 @@ regionHeight = snd
70infixr 5 <|>
83infixr 5 <|>
71infixr 4 <->
84infixr 4 <->
72
85
73−-- | An area of the picture's bacground (See Background) of w columns
86+-- | An area of the picture's background (See 'Background').
74−-- and h rows.
75−backgroundFill :: Int -> Int -> Image
87+backgroundFill :: Int
88+ -- ^ Fill width in columns
89+ -> Int
90+ -- ^ Fill height in rows
91+ -> Image
76backgroundFill w h
92backgroundFill w h
77 | w == 0 = EmptyImage
93 | w == 0 = EmptyImage
78 | h == 0 = EmptyImage
94 | h == 0 = EmptyImage
79 | otherwise = BGFill w h
95 | otherwise = BGFill w h
80
96
81−-- | Combines two images horizontally. Alias for horizJoin
97+-- | Combines two images horizontally. This is an alias for 'horizJoin'.
82--
98--
83-- infixr 5
99-- infixr 5
84(<|>) :: Image -> Image -> Image
100(<|>) :: Image -> Image -> Image
85(<|>) = horizJoin
101(<|>) = horizJoin
86
102
87−-- | Combines two images vertically. Alias for vertJoin
103+-- | Combines two images vertically. This is an alias for 'vertJoin'.
88--
104--
89-- infixr 4
105-- infixr 4
90(<->) :: Image -> Image -> Image
106(<->) :: Image -> Image -> Image
91(<->) = vertJoin
107(<->) = vertJoin
92
108
93−-- | Compose any number of images horizontally.
109+-- | Compose any number of images together horizontally, with the first
110+-- in the list being leftmost.
94horizCat :: [Image] -> Image
111horizCat :: [Image] -> Image
95horizCat = foldr horizJoin EmptyImage
112horizCat = foldr horizJoin EmptyImage
96
113
97−-- | Compose any number of images vertically.
114+-- | Compose any number of images vertically, with the first in the list
115+-- being topmost.
98vertCat :: [Image] -> Image
116vertCat :: [Image] -> Image
99vertCat = foldr vertJoin EmptyImage
117vertCat = foldr vertJoin EmptyImage
100
118
101−-- | 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.
102text :: Attr -> TL.Text -> Image
122text :: Attr -> TL.Text -> Image
103−text a txt = let displayWidth = safeWcswidth (TL.unpack txt)
123+text a txt = let displayWidth = safeWctlwidth txt
104 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
105
125
106−-- | 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.
107text' :: Attr -> T.Text -> Image
129text' :: Attr -> T.Text -> Image
108−text' a txt = let displayWidth = safeWcswidth (T.unpack txt)
130+text' a txt = let displayWidth = safeWctwidth txt
109 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
110
132
111−-- | An image of a single character. This is a standard Haskell 31-bit
133+-- | Make an image from a single character. This is a standard Haskell
112−-- character assumed to be in the ISO-10646 encoding.
134+-- 31-bit character assumed to be in the ISO-10646 encoding.
113char :: Attr -> Char -> Image
135char :: Attr -> Char -> Image
114char a c =
136char a c =
115 let displayWidth = safeWcwidth c
137 let displayWidth = safeWcwidth c
116 in HorizText a (TL.singleton c) displayWidth 1
138 in HorizText a (TL.singleton c) displayWidth 1
117
139
118−-- | A string of characters layed out on a single row with the same
140+-- | Make an image from a string of characters laid out on a single
119−-- display attribute. The string is assumed to be a sequence of
141+-- row with the same display attribute. The string is assumed to be a
120−-- ISO-10646 characters.
142+-- sequence of ISO-10646 characters. The input string should be
143+-- sanitized of escape sequences (ASCII 27) and carriage returns;
144+-- otherwise layout and attribute problems may result.
121--
145--
122-- Note: depending on how the Haskell compiler represents string
146-- Note: depending on how the Haskell compiler represents string
123−-- literals a string literal in a UTF-8 encoded source file, for
147+-- literals, a string literal in a UTF-8 encoded source file, for
124-- example, may be represented as a ISO-10646 string. That is, I think,
148-- example, may be represented as a ISO-10646 string. That is, I think,
125-- the case with GHC 6.10. This means, for the most part, you don't need
149-- the case with GHC 6.10. This means, for the most part, you don't need
126-- to worry about the encoding format when outputting string literals.
150-- to worry about the encoding format when outputting string literals.
@@ -130,9 +154,11 @@ iso10646String a str =
130 let displayWidth = safeWcswidth str
154 let displayWidth = safeWcswidth str
131 in HorizText a (TL.pack str) displayWidth (length str)
155 in HorizText a (TL.pack str) displayWidth (length str)
132
156
157+-- | Make an 'Image' from a 'String'.
158+--
133−-- | Alias for iso10646String. Since the usual case is that a literal
159+-- This is an alias for iso10646String since the usual case is that a
134−-- string like "foo" is represented internally as a list of ISO 10646 31
160+-- literal string like "foo" is represented internally as a list of ISO
135−-- bit characters.
161+-- 10646 31 bit characters.
136--
162--
137-- Note: Keep in mind that GHC will compile source encoded as UTF-8
163-- Note: Keep in mind that GHC will compile source encoded as UTF-8
138-- but the literal strings, while UTF-8 encoded in the source, will be
164-- but the literal strings, while UTF-8 encoded in the source, will be
@@ -140,40 +166,63 @@ iso10646String a str =
140string :: Attr -> String -> Image
166string :: Attr -> String -> Image
141string = iso10646String
167string = iso10646String
142
168
143−-- | A string of characters layed out on a single row. The input is
169+-- | Make an 'Image' from a string of characters layed out on a single
144−-- assumed to be the bytes for UTF-8 encoded text.
170+-- row. The input is assumed to be the bytes for UTF-8 encoded text.
145utf8String :: Attr -> [Word8] -> Image
171utf8String :: Attr -> [Word8] -> Image
146utf8String a bytes = utf8Bytestring a (BL.pack bytes)
172utf8String a bytes = utf8Bytestring a (BL.pack bytes)
147
173
148−-- | Renders a UTF-8 encoded lazy bytestring.
174+-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
149utf8Bytestring :: Attr -> BL.ByteString -> Image
175utf8Bytestring :: Attr -> BL.ByteString -> Image
150utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
151
177
152−-- | Renders a UTF-8 encoded strict bytestring.
178+-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
153utf8Bytestring' :: Attr -> B.ByteString -> Image
179utf8Bytestring' :: Attr -> B.ByteString -> Image
154utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
155
181
156−-- | Creates a fill of the specified character. The dimensions are in
182+-- | Make an image filling a region with the specified character.
157−-- number of characters wide and 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.
158−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
159−charFill _a _c 0 _h = EmptyImage
196+charFill a c w h
160−charFill _a _c _w 0 = EmptyImage
197+ | w <= 0 || h <= 0 = EmptyImage
161−charFill a c w h =
198+ | otherwise = vertCat
199+ $ replicate (fromIntegral h)
162− vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth
200+ $ HorizText a txt displayWidth charWidth
163− where
201+ where
164− txt = TL.replicate (fromIntegral w) (TL.singleton c)
202+ txt = TL.replicate charWidth (TL.singleton c)
165− displayWidth = safeWcwidth c * (fromIntegral w)
203+ displayWidth = safeWcwidth c * charWidth
204+
205+ charWidth :: Num a => a
166− charWidth = fromIntegral w
206+ charWidth = fromIntegral w
167
207
168-- | The empty image. Useful for fold combinators. These occupy no space
208-- | The empty image. Useful for fold combinators. These occupy no space
169−-- nor define any display attributes.
209+-- and do not affect display attributes.
170emptyImage :: Image
210emptyImage :: Image
171emptyImage = EmptyImage
211emptyImage = EmptyImage
172
212
173-- | Pad the given image. This adds background character fills to the
213-- | Pad the given image. This adds background character fills to the
174−-- left, top, right, bottom. The pad values are how many display columns
214+-- left, top, right, bottom.
175−-- or rows to add.
215+pad :: Int
176−pad :: Int -> Int -> Int -> Int -> Image -> Image
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
177pad 0 0 0 0 i = i
226pad 0 0 0 0 i = i
178pad inL inT inR inB inImage
227pad inL inT inR inB inImage
179 | 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"
@@ -194,24 +243,29 @@ pad inL inT inR inB inImage
194 h = imageHeight i
243 h = imageHeight i
195
244
196-- | Translates an image by padding or cropping the left and top.
245-- | Translates an image by padding or cropping the left and top.
197−-- First param is amount to translate left. Second param is amount to
198−-- translate top.
199--
246--
200−-- This can have an unexpected effect: Translating an image to less than
247+-- If translation offsets are negative then the image is cropped.
201−-- (0,0) then to greater than (0,0) will crop the image.
202−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
203translate x y i = translateX x (translateY y i)
255translate x y i = translateX x (translateY y i)
204
256
205−-- | translates an image by padding or cropping the left
257+-- | Translates an image by padding or cropping its left side.
206translateX :: Int -> Image -> Image
258translateX :: Int -> Image -> Image
207translateX x i
259translateX x i
260+ | x < 0 && (abs x > imageWidth i) = emptyImage
208 | 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)
209 | x == 0 = i
262 | x == 0 = i
210 | 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
211
264
212−-- | translates an image by padding or cropping the top
265+-- | Translates an image by padding or cropping its top.
213translateY :: Int -> Image -> Image
266translateY :: Int -> Image -> Image
214translateY y i
267translateY y i
268+ | y < 0 && (abs y > imageHeight i) = emptyImage
215 | 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)
216 | y == 0 = i
270 | y == 0 = i
217 | 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)
@@ -219,16 +273,22 @@ translateY y i
219-- | Ensure an image is no larger than the provided size. If the image
273-- | Ensure an image is no larger than the provided size. If the image
220-- is larger then crop the right or bottom.
274-- is larger then crop the right or bottom.
221--
275--
222−-- This is transformed to a vertical crop from the bottom followed by
276+-- This is equivalent to a vertical crop from the bottom followed by
223-- horizontal crop from the right.
277-- horizontal crop from the right.
224−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
225crop 0 _ _ = EmptyImage
285crop 0 _ _ = EmptyImage
226crop _ 0 _ = EmptyImage
286crop _ 0 _ = EmptyImage
227crop w h i = cropBottom h (cropRight w i)
287crop w h i = cropBottom h (cropRight w i)
228
288
229−-- | crop the display height. If the image is less than or equal in
289+-- | Crop an image's height. If the image's height is less than or equal
230−-- height then this operation has no effect. Otherwise the image is
290+-- to the specified height then this operation has no effect. Otherwise
231−-- cropped from the bottom.
291+-- the image is cropped from the bottom.
232cropBottom :: Int -> Image -> Image
292cropBottom :: Int -> Image -> Image
233cropBottom 0 _ = EmptyImage
293cropBottom 0 _ = EmptyImage
234cropBottom h inI
294cropBottom h inI
@@ -243,8 +303,9 @@ cropBottom h inI
243 | h >= imageHeight i = i
303 | h >= imageHeight i = i
244 | otherwise = CropBottom i (imageWidth i) h
304 | otherwise = CropBottom i (imageWidth i) h
245
305
246−-- | ensure the image is no wider than the given width. If the image is
306+-- | Crop an image's width. If the image's width is less than or equal
247−-- wider then crop the right side.
307+-- to the specified width then this operation has no effect. Otherwise
308+-- the image is cropped from the right.
248cropRight :: Int -> Image -> Image
309cropRight :: Int -> Image -> Image
249cropRight 0 _ = EmptyImage
310cropRight 0 _ = EmptyImage
250cropRight w inI
311cropRight w inI
@@ -259,8 +320,9 @@ cropRight w inI
259 | w >= imageWidth i = i
320 | w >= imageWidth i = i
260 | otherwise = CropRight i w (imageHeight i)
321 | otherwise = CropRight i w (imageHeight i)
261
322
262−-- | ensure the image is no wider than the given width. If the image is
323+-- | Crop an image's width. If the image's width is less than or equal
263−-- wider then crop the left side.
324+-- to the specified width then this operation has no effect. Otherwise
325+-- the image is cropped from the left.
264cropLeft :: Int -> Image -> Image
326cropLeft :: Int -> Image -> Image
265cropLeft 0 _ = EmptyImage
327cropLeft 0 _ = EmptyImage
266cropLeft w inI
328cropLeft w inI
@@ -277,9 +339,9 @@ cropLeft w inI
277 | imageWidth i <= w = i
339 | imageWidth i <= w = i
278 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
340 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
279
341
280−-- | crop the display height. If the image is less than or equal in
342+-- | Crop an image's height. If the image's height is less than or equal
281−-- height then this operation has no effect. Otherwise the image is
343+-- to the specified height then this operation has no effect. Otherwise
282−-- cropped from the top.
344+-- the image is cropped from the top.
283cropTop :: Int -> Image -> Image
345cropTop :: Int -> Image -> Image
284cropTop 0 _ = EmptyImage
346cropTop 0 _ = EmptyImage
285cropTop h inI
347cropTop h inI
@@ -296,14 +358,14 @@ cropTop h inI
296 | imageHeight i <= h = i
358 | imageHeight i <= h = i
297 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
359 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
298
360
299−-- | Generic resize. Pads and crops as required to assure the given
361+-- | Generic resize. Pads and crops are added to ensure that the
362+-- resulting image matches the specified dimensions. This is biased to
300−-- display width and height. This is biased to pad/crop the right and
363+-- pad/crop the right and bottom.
301−-- bottom.
302resize :: Int -> Int -> Image -> Image
364resize :: Int -> Int -> Image -> Image
303resize w h i = resizeHeight h (resizeWidth w i)
365resize w h i = resizeHeight h (resizeWidth w i)
304
366
305-- | Resize the width. Pads and crops as required to assure the given
367-- | Resize the width. Pads and crops as required to assure the given
306−-- display width. This is biased to pad/crop the right.
368+-- display width. This is biased to pad/crop on the right.
307resizeWidth :: Int -> Image -> Image
369resizeWidth :: Int -> Image -> Image
308resizeWidth w i = case w `compare` imageWidth i of
370resizeWidth w i = case w `compare` imageWidth i of
309 LT -> cropRight w i
371 LT -> cropRight w i
@@ -311,7 +373,7 @@ resizeWidth w i = case w `compare` imageWidth i of
311 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
373 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
312
374
313-- | Resize the height. Pads and crops as required to assure the given
375-- | Resize the height. Pads and crops as required to assure the given
314−-- display height. This is biased to pad/crop the bottom.
376+-- display height. This is biased to pad/crop on the bottom.
315resizeHeight :: Int -> Image -> Image
377resizeHeight :: Int -> Image -> Image
316resizeHeight h i = case h `compare` imageHeight i of
378resizeHeight h i = case h `compare` imageHeight i of
317 LT -> cropBottom h i
379 LT -> cropBottom h i
src/Graphics/Vty/Image/Internal.hs+16−32
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
3{-# OPTIONS_HADDOCK hide #-}
4{-# OPTIONS_HADDOCK hide #-}
@@ -11,6 +12,9 @@ import GHC.Generics
11
12
12import Control.DeepSeq
13import Control.DeepSeq
13
14
15+#if !(MIN_VERSION_base(4,11,0))
16+import Data.Semigroup (Semigroup(..))
17+#endif
14import qualified Data.Text.Lazy as TL
18import qualified Data.Text.Lazy as TL
15
19
16-- | A display text is a Data.Text.Lazy
20-- | A display text is a Data.Text.Lazy
@@ -138,37 +142,11 @@ data Image =
138 --
142 --
139 -- Any image of zero size equals the empty image.
143 -- Any image of zero size equals the empty image.
140 | EmptyImage
144 | EmptyImage
141− deriving (Eq, Generic)
145+ deriving (Eq, Generic, Show, Read)
142−
143−instance Show Image where
144− show ( HorizText { attr, displayText, outputWidth, charWidth } )
145− = "HorizText " ++ show displayText
146− ++ "@(" ++ show attr ++ ","
147− ++ show outputWidth ++ ","
148− ++ show charWidth ++ ")"
149− show ( BGFill { outputWidth, outputHeight } )
150− = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"
151− show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )
152− = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
153− show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )
154− = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
155− show ( CropRight { croppedImage, outputWidth, outputHeight } )
156− = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
157− ++ " (" ++ show croppedImage ++ ")"
158− show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )
159− = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
160− ++ " (" ++ show croppedImage ++ ")"
161− show ( CropBottom { croppedImage, outputWidth, outputHeight } )
162− = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
163− ++ " (" ++ show croppedImage ++ ")"
164− show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )
165− = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
166− ++ " (" ++ show croppedImage ++ ")"
167− show ( EmptyImage ) = "EmptyImage"
168
146
169-- | pretty print just the structure of an image.
147-- | pretty print just the structure of an image.
170ppImageStructure :: Image -> String
148ppImageStructure :: Image -> String
171−ppImageStructure inImg = go 0 inImg
149+ppImageStructure = go 0
172 where
150 where
173 go indent img = tab indent ++ pp indent img
151 go indent img = tab indent ++ pp indent img
174 tab indent = concat $ replicate indent " "
152 tab indent = concat $ replicate indent " "
@@ -232,10 +210,16 @@ imageHeight CropBottom { outputHeight = h } = h
232imageHeight CropTop { outputHeight = h } = h
210imageHeight CropTop { outputHeight = h } = h
233imageHeight EmptyImage = 0
211imageHeight EmptyImage = 0
234
212
213+-- | Append in the 'Semigroup' instance is equivalent to '<->'.
214+instance Semigroup Image where
215+ (<>) = vertJoin
216+
235−-- | Append in the Monoid instance is equivalent to <->.
217+-- | Append in the 'Monoid' instance is equivalent to '<->'.
236instance Monoid Image where
218instance Monoid Image where
237 mempty = EmptyImage
219 mempty = EmptyImage
220+#if !(MIN_VERSION_base(4,11,0))
238− mappend = vertJoin
221+ mappend = (<>)
222+#endif
239
223
240-- | combines two images side by side
224-- | combines two images side by side
241--
225--
@@ -244,7 +228,7 @@ instance Monoid Image where
244--
228--
245-- The result image will have a width equal to the sum of the two images
229-- The result image will have a width equal to the sum of the two images
246-- width. And the height will equal the largest height of the two
230-- width. And the height will equal the largest height of the two
247−-- images. The area not defined in one image due to a height missmatch
231+-- images. The area not defined in one image due to a height mismatch
248-- will be filled with the background pattern.
232-- will be filled with the background pattern.
249horizJoin :: Image -> Image -> Image
233horizJoin :: Image -> Image -> Image
250horizJoin EmptyImage i = i
234horizJoin EmptyImage i = i
@@ -275,7 +259,7 @@ horizJoin _ _ = error "horizJoin applied to undefined values."
275--
259--
276-- The result image will have a height equal to the sum of the heights
260-- The result image will have a height equal to the sum of the heights
277-- of both images. The width will equal the largest width of the two
261-- of both images. The width will equal the largest width of the two
278−-- images. The area not defined in one image due to a width missmatch
262+-- images. The area not defined in one image due to a width mismatch
279-- will be filled with the background pattern.
263-- will be filled with the background pattern.
280vertJoin :: Image -> Image -> Image
264vertJoin :: Image -> Image -> Image
281vertJoin EmptyImage i = i
265vertJoin EmptyImage i = i
src/Graphics/Vty/Inline.hs+42−32
@@ -1,14 +1,12 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3-- | The inline module provides a limited interface to changing the
1-- | The inline module provides a limited interface to changing the
4-- style of terminal output. The intention is for this interface to be
2-- style of terminal output. The intention is for this interface to be
5-- used inline with other output systems.
3-- used inline with other output systems.
6--
4--
7-- The changes specified by the InlineM monad are applied to the
5-- The changes specified by the InlineM monad are applied to the
8−-- terminals display attributes. These display attributes effect the
6+-- terminal's display attributes. These display attributes affect the
9-- display of all following text output to the terminal file descriptor.
7-- display of all following text output to the terminal file descriptor.
10--
8--
11−-- For example, in an IO monad the following code with print the text
9+-- For example, in an IO monad the following code will print the text
12-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
10-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
13-- background and underlined.
11-- background and underlined.
14--
12--
@@ -22,11 +20,11 @@
22-- putStrLn \"Not styled.\"
20-- putStrLn \"Not styled.\"
23-- @
21-- @
24--
22--
25−-- 'putAttrChange' outputs the control codes to the terminal device
23+-- 'putAttrChange' emits the control codes to the terminal device
26−-- 'Handle'. This is a duplicate of the 'stdout' handle when the
24+-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when
27−-- 'terminalHandle' was (first) acquired. If 'stdout' has since been
25+-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been
28−-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a
26+-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a
29−-- different 'Handle' than 'putAttrChange'
27+-- different 'Handle' than 'putAttrChange'.
30--
28--
31-- Copyright 2009-2010 Corey O'Connor
29-- Copyright 2009-2010 Corey O'Connor
32module Graphics.Vty.Inline
30module Graphics.Vty.Inline
@@ -48,39 +46,52 @@ import Data.IORef
48
46
49import System.IO
47import System.IO
50
48
51−type InlineM v = State Attr v
49+type InlineM v = State InlineState v
50+
51+data InlineState =
52+ InlineState { inlineAttr :: Attr
53+ , inlineUrlsEnabled :: Bool
54+ }
52
55
53−-- | Set the background color to the provided 'Color'
56+-- | Set the background color to the provided 'Color'.
54backColor :: Color -> InlineM ()
57backColor :: Color -> InlineM ()
55−backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )
58+backColor c = modify $ \s ->
59+ s { inlineAttr = inlineAttr s `withBackColor` c
60+ }
56
61
57−-- | Set the foreground color to the provided 'Color'
62+-- | Set the foreground color to the provided 'Color'.
58foreColor :: Color -> InlineM ()
63foreColor :: Color -> InlineM ()
59−foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )
64+foreColor c = modify $ \s ->
65+ s { inlineAttr = inlineAttr s `withForeColor` c
66+ }
60
67
61−-- | Attempt to change the 'Style' of the following text.
68+-- | Attempt to change the 'Style' of the following text..
62--
69--
63−-- If the terminal does not support the style change no error is
70+-- If the terminal does not support the style change then no error is
64-- produced. The style can still be removed.
71-- produced. The style can still be removed.
65applyStyle :: Style -> InlineM ()
72applyStyle :: Style -> InlineM ()
66−applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
73+applyStyle st = modify $ \s ->
74+ s { inlineAttr = inlineAttr s `withStyle` st
75+ }
67
76
68-- | Attempt to remove the specified 'Style' from the display of the
77-- | Attempt to remove the specified 'Style' from the display of the
69-- following text.
78-- following text.
70--
79--
71−-- This will fail if applyStyle for the given style has not been
80+-- This will fail if 'applyStyle' for the given style has not been
72-- previously called.
81-- previously called.
73removeStyle :: Style -> InlineM ()
82removeStyle :: Style -> InlineM ()
74−removeStyle sMask = modify $ \attr ->
83+removeStyle sMask = modify $ \s ->
84+ s { inlineAttr =
75− let style' = case attrStyle attr of
85+ let style' = case attrStyle (inlineAttr s) of
76− Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
86+ Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
77− KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
87+ KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
78− SetTo s -> s .&. complement sMask
88+ SetTo st -> st .&. complement sMask
79− in attr { attrStyle = SetTo style' }
89+ in (inlineAttr s) { attrStyle = SetTo style' }
90+ }
80
91
81−-- | Reset the display attributes
92+-- | Reset the display attributes.
82defaultAll :: InlineM ()
93defaultAll :: InlineM ()
83−defaultAll = put defAttr
94+defaultAll = modify $ \s -> s { inlineAttr = defAttr }
84
95
85-- | Apply the provided display attribute changes to the given terminal
96-- | Apply the provided display attribute changes to the given terminal
86-- output device.
97-- output device.
@@ -93,20 +104,19 @@ putAttrChange out c = liftIO $ do
93 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
94 fattr <- case mfattr of
105 fattr <- case mfattr of
95 Nothing -> do
106 Nothing -> do
96− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
107+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
97− return $ FixedAttr defaultStyleMask Nothing Nothing
108+ return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
98 Just v -> return v
109 Just v -> return v
99− let attr = execState c currentAttr
110+ let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
100 attr' = limitAttrForDisplay out attr
111 attr' = limitAttrForDisplay out attr
101 fattr' = fixDisplayAttr fattr attr'
112 fattr' = fixDisplayAttr fattr attr'
102 diffs = displayAttrDiffs fattr fattr'
113 diffs = displayAttrDiffs fattr fattr'
103− outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
114+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
104 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
105 inlineHack dc
116 inlineHack dc
106
117
107-- | Apply the provided display attributes changes to the terminal
118-- | Apply the provided display attributes changes to the terminal
108−-- output device that was current at the time this was first used.
119+-- output device.
109−-- Which, for most use cases, is the current terminal.
110--
120--
111-- This will flush the terminal output.
121-- This will flush the terminal output.
112putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
122putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
src/Graphics/Vty/Inline/Unsafe.hs+1−2
@@ -4,7 +4,6 @@ module Graphics.Vty.Inline.Unsafe where
4
4
5import Graphics.Vty
5import Graphics.Vty
6
6
7−import Data.Default
8import Data.IORef
7import Data.IORef
9
8
10import GHC.IO.Handle (hDuplicate)
9import GHC.IO.Handle (hDuplicate)
@@ -29,7 +28,7 @@ mkDupeConfig = do
29 hSetBuffering stdin NoBuffering
28 hSetBuffering stdin NoBuffering
30 stdinDupe <- hDuplicate stdin >>= handleToFd
29 stdinDupe <- hDuplicate stdin >>= handleToFd
31 stdoutDupe <- hDuplicate stdout >>= handleToFd
30 stdoutDupe <- hDuplicate stdout >>= handleToFd
32− return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
31+ return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
33
32
34-- | This will create a Vty instance using 'mkVty' and execute an IO
33-- | This will create a Vty instance using 'mkVty' and execute an IO
35-- action provided that instance. The created Vty instance will be
34-- action provided that instance. The created Vty instance will be
src/Graphics/Vty/Input.hs+68−110
@@ -1,142 +1,116 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
2
2
3−-- | The input layer for VTY. This provides methods for initializing an
3+-- | This module provides the input layer for Vty, including methods
4−-- 'Input' structure which can then be used to read 'Event's from the
4+-- for initializing an 'Input' structure and reading 'Event's from the
5-- terminal.
5-- terminal.
6--
6--
7−-- The history of terminals has resulted in a broken input process. Some
7+-- Note that due to the evolution of terminal emulators, some keys
8−-- keys and combinations will not reliably map to the expected events
8+-- and combinations will not reliably map to the expected events by
9−-- by any terminal program. Even those not using vty. There is no 1:1
9+-- any terminal program. There is no 1:1 mapping from key events to
10−-- mapping from key events to bytes read from the terminal input device.
10+-- bytes read from the terminal input device. In very limited cases the
11−-- In very limited cases the terminal and vty's input process can be
11+-- terminal and vty's input process can be customized to resolve these
12−-- customized to resolve these issues.
13−--
14−-- See "Graphics.Vty.Config" for how to configure vty's input
12+-- issues; see "Graphics.Vty.Config" for how to configure vty's input
15−-- processing. Customizing terminfo and the terminal is beyond the scope
13+-- processing.
16−-- of this documentation.
17--
14--
18-- = VTY's Implementation
15-- = VTY's Implementation
19--
16--
20-- There are two input modes:
17-- There are two input modes:
21--
18--
22−-- 1. 7 bit
19+-- 1. 7-bit
23--
20--
24−-- 2. 8 bit
21+-- 2. 8-bit
25--
22--
26−-- 7 bit input is the default and the expected in most use cases. This
23+-- The 7-bit input mode is the default and the expected mode in most use
27−-- is what vty uses.
24+-- cases. This is what Vty uses.
28--
25--
29−-- == 7 bit input encoding
26+-- == 7-bit input encoding
30--
27--
31-- Control key combinations are represented by masking the two high bits
28-- Control key combinations are represented by masking the two high bits
32−-- of the 7bit input. Back in the day the control key actually grounded
29+-- of the 7-bit input. Historically the control key actually grounded
33−-- the two high bit wires: 6 and 7. This is why control key combos map
30+-- the two high bit wires: 6 and 7. This is why control key combos
34−-- to single character events: The input bytes are identical. The input
31+-- map to single character events: the input bytes are identical. The
35−-- byte is the bit encoding of the character with bits 6 and 7 masked.
32+-- input byte is the bit encoding of the character with bits 6 and 7
36−-- Bit 6 is set by shift. Bit 6 and 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,
37--
35--
38−-- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become
36+-- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become
39−-- `00001001`. Which is the ASCII and UTF-8 encoding of the tab key.
37+-- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key.
40--
38--
41-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
39-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
42−-- which makes `0000011` and is the "End of Text" code.
40+-- which is `0000011` and is the "End of Text" code.
43--
41--
44−-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This
42+-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this
45-- is the value 1 with bit 7 set and 6 unset.
43-- is the value 1 with bit 7 set and 6 unset.
46--
44--
47-- * Hypothesis: Bit 6 is unset by upper case letters because,
45-- * Hypothesis: Bit 6 is unset by upper case letters because,
48-- initially, there were only upper case letters used and a 5 bit
46-- initially, there were only upper case letters used and a 5 bit
49-- encoding.
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
51+-- The 8th bit was originally used for parity checking which is useless
54−-- emulators. Some terminal emulators support a 8 bit input encoding.
52+-- for terminal emulators. Some terminal emulators support an 8-bit
55−-- While this provides some advantages the actual usage is low. Most
53+-- input encoding. While this provides some advantages, the actual usage
56−-- systems use 7bit mode but recognize 8bit control characters when
54+-- is low. Most systems use 7-bit mode but recognize 8-bit control
57−-- escaped. This is what vty does.
55+-- characters when escaped. This is what Vty does.
58--
56--
59-- == Escaped Control Keys
57-- == Escaped Control Keys
60--
58--
61−-- Using 7 bit input encoding the @ESC@ byte can signal the start of
59+-- Using 7-bit input encoding, the @ESC@ byte can signal the start of
62−-- an encoded control key. To differentiate a single @ESC@ eventfrom a
60+-- an encoded control key. To differentiate a single @ESC@ event from a
63−-- control key the timing of the input is used.
61+-- control key, the timing of the input is used.
64--
62--
65−-- 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.
66--
65--
67−-- 2. control keys that contain @ESC@ in their encoding: The @ESC byte;
66+-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte
68−-- followed by more bytes read within 'singleEscPeriod'. All bytes up
67+-- is followed by more bytes read within 'VMIN' milliseconds. All bytes
69−-- until the next valid input block are passed to the classifier.
68+-- up until the next valid input block are passed to the classifier.
70--
69--
71-- If the current runtime is the threaded runtime then the terminal's
70-- If the current runtime is the threaded runtime then the terminal's
72-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
71-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
73−-- the current runtime does not support forkOS then there is currently
72+-- the current runtime does not support 'forkOS' then there is currently
74-- no implementation.
73-- no implementation.
75--
74--
76−-- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop
77−-- which did tricky things with non-blocking reads and timers. The
78−-- implementation was not reliable. A reliable implementation is
79−-- possible, but there are no plans to implement this.
80−--
81-- == Unicode Input and Escaped Control Key Sequences
75-- == Unicode Input and Escaped Control Key Sequences
82--
76--
83-- The input encoding determines how UTF-8 encoded characters are
77-- The input encoding determines how UTF-8 encoded characters are
84−-- recognize.
78+-- recognized.
85--
79--
86−-- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is
80+-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
87-- a superset of ASCII. UTF-8 does not overlap escaped control key
81-- a superset of ASCII. UTF-8 does not overlap escaped control key
88-- sequences. However, the escape key must be differentiated from
82-- sequences. However, the escape key must be differentiated from
89-- escaped control key sequences by the timing of the input bytes.
83-- escaped control key sequences by the timing of the input bytes.
90--
84--
91−-- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not
85+-- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not
92-- require using the timing of input bytes to differentiate the escape
86-- require using the timing of input bytes to differentiate the escape
93−-- key. Many terminals do not support 8 bit mode.
87+-- key. Many terminals do not support 8-bit mode.
94--
88--
95-- == Terminfo
89-- == Terminfo
96--
90--
97-- The terminfo system is used to determine how some keys are encoded.
91-- The terminfo system is used to determine how some keys are encoded.
98−-- Terminfo is incomplete. In some cases terminfo is incorrect. Vty
92+-- Terminfo is incomplete and in some cases terminfo is incorrect. Vty
99-- assumes terminfo is correct but provides a mechanism to override
93-- assumes terminfo is correct but provides a mechanism to override
100−-- terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'.
94+-- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'.
101--
95--
102-- == Terminal Input is Broken
96-- == Terminal Input is Broken
103--
97--
104−-- Clearly terminal input has fundemental issues. There is no easy way
98+-- Clearly terminal input has fundamental issues. There is no easy way
105-- to reliably resolve these issues.
99-- to reliably resolve these issues.
106--
100--
107-- One resolution would be to ditch standard terminal interfaces
101-- One resolution would be to ditch standard terminal interfaces
108−-- entirely and just go directly to scancodes. A reasonable option for
102+-- entirely and just go directly to scancodes. This would be a
109−-- vty if everybody used the linux kernel console. I hear GUIs are
103+-- reasonable option for Vty if everybody used the linux kernel console
110−-- popular these days. Sadly, GUI terminal emulators don't provide
104+-- but for obvious reasons this is not possible.
111−-- access to scancodes AFAIK.
112−--
113−-- All is lost? Not really. "Graphics.Vty.Config" supports customizing
114−-- the input byte to event mapping and xterm supports customizing the
115−-- scancode to input byte mapping. With a lot of work a user's system
116−-- can be set up to encode all the key combos in an almost-sane manner.
117−--
118−-- There are other tricky work arounds that can be done. I have no
119−-- interest in implementing most of these. They are not really worth the
120−-- time.
121−--
122−-- == Terminal Output is Also Broken
123--
105--
124−-- This isn't the only odd aspect of terminals due to historical
106+-- The "Graphics.Vty.Config" module supports customizing the
125−-- aspects that no longer apply. EG: Some terminfo capabilities specify
107+-- input-byte-to-event mapping and xterm supports customizing the
126−-- millisecond delays. (Capabilities are how terminfo describes the
108+-- scancode-to-input-byte mapping. With a lot of work a user's system
127−-- control sequence to output red, for instance) This is to account for
109+-- can be set up to encode all the key combos in an almost-sane manner.
128−-- the slow speed of hardcopy teletype interfaces. Cause, uh, we totally
129−-- still use those.
130−--
131−-- The output encoding of colors and attributes are also rife with
132−-- issues.
133--
110--
134-- == See also
111-- == See also
135--
112--
136-- * http://www.leonerd.org.uk/hacks/fixterms/
113-- * http://www.leonerd.org.uk/hacks/fixterms/
137−--
138−-- In my experience this cannot resolve the issues without changes to
139−-- the terminal emulator and device.
140module Graphics.Vty.Input
114module Graphics.Vty.Input
141 ( Key(..)
115 ( Key(..)
142 , Modifier(..)
116 , Modifier(..)
@@ -158,38 +132,19 @@ import Lens.Micro
158import qualified System.Console.Terminfo as Terminfo
132import qualified System.Console.Terminfo as Terminfo
159import System.Posix.Signals.Exts
133import System.Posix.Signals.Exts
160
134
135+#if !MIN_VERSION_base(4,11,0)
161import Data.Monoid ((<>))
136import Data.Monoid ((<>))
137+#endif
162
138
163-- | Set up the terminal with file descriptor `inputFd` for input.
139-- | Set up the terminal with file descriptor `inputFd` for input.
164−-- Returns a 'Input'.
140+-- Returns an 'Input'.
165--
141--
166-- The table used to determine the 'Events' to produce for the input
142-- The table used to determine the 'Events' to produce for the input
167−-- bytes comes from 'classifyMapForTerm'. Which is then overridden by
143+-- bytes comes from 'classifyMapForTerm' which is then overridden by
168−-- the the applicable entries from 'inputMap'.
144+-- the the applicable entries from the configuration's 'inputMap'.
169−--
170−-- The terminal device is configured with the attributes:
171−--
172−-- * IXON disabled
173−-- - disables software flow control on outgoing data. This stops
174−-- the process from being suspended if the output terminal cannot
175−-- keep up. I presume this has little effect these days. I hope
176−-- this means that output will be buffered if the terminal cannot
177−-- keep up. In the old days the output might of been dropped?
178−--
179−-- "raw" mode is used for input.
180−--
181−-- * ISIG disabled
182−-- - enables keyboard combinations that result in signals.
183−--
184−-- * ECHO disabled
185−-- - input is not echoed to the output.
186−--
187−-- * ICANON disabled
188−-- - canonical mode (line mode) input is not used.
189−--
190−-- * IEXTEN disabled
191−-- - extended functions are disabled.
192--
145--
146+-- The terminal device's mode flags are configured by the
147+-- 'attributeControl' function.
193inputForConfig :: Config -> IO Input
148inputForConfig :: Config -> IO Input
194inputForConfig config@Config{ termName = Just termName
149inputForConfig config@Config{ termName = Just termName
195 , inputFd = Just termFd
150 , inputFd = Just termFd
@@ -199,20 +154,23 @@ inputForConfig config@Config{ termName = Just termName
199 terminal <- Terminfo.setupTerm termName
154 terminal <- Terminfo.setupTerm termName
200 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]
201 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
202− (setAttrs,unsetAttrs) <- attributeControl termFd
157+ (setAttrs, unsetAttrs) <- attributeControl termFd
203 setAttrs
158 setAttrs
204 input <- initInput config activeInputMap
159 input <- initInput config activeInputMap
205 let pokeIO = Catch $ do
160 let pokeIO = Catch $ do
206− let e = error "vty internal failure: this value should not propagate to users"
207 setAttrs
161 setAttrs
208− atomically $ writeTChan (input^.eventChannel) (EvResize e e)
162+ atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
209 _ <- installHandler windowChange pokeIO Nothing
163 _ <- installHandler windowChange pokeIO Nothing
210 _ <- installHandler continueProcess pokeIO Nothing
164 _ <- installHandler continueProcess pokeIO Nothing
165+
166+ let restore = unsetAttrs
167+
211 return $ input
168 return $ input
212 { shutdownInput = do
169 { shutdownInput = do
213 shutdownInput input
170 shutdownInput input
214 _ <- installHandler windowChange Ignore Nothing
171 _ <- installHandler windowChange Ignore Nothing
215 _ <- installHandler continueProcess Ignore Nothing
172 _ <- installHandler continueProcess Ignore Nothing
216− unsetAttrs
173+ restore
174+ , restoreInputState = restoreInputState input >> restore
217 }
175 }
218inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Classify.hs+54−28
@@ -1,39 +1,55 @@
1{-# OPTIONS_HADDOCK hide #-}
1{-# OPTIONS_HADDOCK hide #-}
2−-- This makes a kind of tri. Has space efficiency issues with large
2+-- This makes a kind of trie. Has space efficiency issues with large
3-- input blocks. Likely building a parser and just applying that would
3-- input blocks. Likely building a parser and just applying that would
4-- be better.
4-- be better.
5module Graphics.Vty.Input.Classify
5module Graphics.Vty.Input.Classify
6 ( classify
6 ( classify
7 , KClass(..)
7 , KClass(..)
8+ , ClassifierState(..)
8 )
9 )
9where
10where
10
11
11import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Mouse
13import Graphics.Vty.Input.Mouse
14+import Graphics.Vty.Input.Focus
13import Graphics.Vty.Input.Paste
15import Graphics.Vty.Input.Paste
14import Graphics.Vty.Input.Classify.Types
16import Graphics.Vty.Input.Classify.Types
15
17
16import Codec.Binary.UTF8.Generic (decode)
18import Codec.Binary.UTF8.Generic (decode)
17
19
18−import Data.List (inits)
20+import Control.Arrow (first)
19import qualified Data.Map as M( fromList, lookup )
21import qualified Data.Map as M( fromList, lookup )
20import Data.Maybe ( mapMaybe )
22import Data.Maybe ( mapMaybe )
21import qualified Data.Set as S( fromList, member )
23import qualified Data.Set as S( fromList, member )
22
24
23−import Data.Char
24import Data.Word
25import Data.Word
25
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+
26−compile :: ClassifyMap -> [Char] -> KClass
42+compile :: ClassifyMap -> ByteString -> KClass
27compile table = cl' where
43compile table = cl' where
28 -- take all prefixes and create a set of these
44 -- take all prefixes and create a set of these
29− prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
45+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
30 maxValidInputLength = maximum (map (length . fst) table)
46 maxValidInputLength = maximum (map (length . fst) table)
31− eventForInput = M.fromList table
47+ eventForInput = M.fromList $ map (first BS8.pack) table
32− cl' [] = Prefix
48+ cl' inputBlock | BS8.null inputBlock = Prefix
33 cl' inputBlock = case M.lookup inputBlock eventForInput of
49 cl' inputBlock = case M.lookup inputBlock eventForInput of
34 -- if the inputBlock is exactly what is expected for an
50 -- if the inputBlock is exactly what is expected for an
35 -- event then consume the whole block and return the event
51 -- event then consume the whole block and return the event
36− Just e -> Valid e []
52+ Just e -> Valid e BS8.empty
37 Nothing -> case S.member inputBlock prefixSet of
53 Nothing -> case S.member inputBlock prefixSet of
38 True -> Prefix
54 True -> Prefix
39 -- look up progressively smaller tails of the input
55 -- look up progressively smaller tails of the input
@@ -44,39 +60,49 @@ compile table = cl' where
44 -- H: There will always be one match. The prefixSet
60 -- H: There will always be one match. The prefixSet
45 -- contains, by definition, all prefixes of an event.
61 -- contains, by definition, all prefixes of an event.
46 False ->
62 False ->
47− let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
63+ let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
48 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
49− (s,e) : _ -> Valid e (drop (length s) inputBlock)
65+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
50 -- neither a prefix or a full event.
66 -- neither a prefix or a full event.
51 [] -> Invalid
67 [] -> Invalid
52
68
53−classify :: ClassifyMap -> [Char] -> KClass
69+classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
54−classify table =
70+classify table = process
71+ where
55− let standardClassifier = compile table
72+ standardClassifier = compile table
73+
74+ process ClassifierStart s =
56− in \s -> case s of
75+ case BS.uncons s of
57− _ | 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 =
58 if bracketedPasteFinished s
86 if bracketedPasteFinished s
59− then parseBracketedPaste s
87+ then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
60− else Prefix
88+ else Chunk
61− _ | isMouseEvent s -> classifyMouseEvent s
89+ process ClassifierInChunk{} _ = Invalid
62− c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
63− _ -> standardClassifier s
64
90
65−classifyUtf8 :: Char -> [Char] -> KClass
91+classifyUtf8 :: Word8 -> ByteString -> KClass
66classifyUtf8 c cs =
92classifyUtf8 c cs =
67− let n = utf8Length (ord c)
93+ let n = utf8Length c
68− (codepoint,rest) = splitAt n (c:cs)
94+ (codepoint,rest) = BS8.splitAt (n - 1) cs
69
95
70 codepoint8 :: [Word8]
96 codepoint8 :: [Word8]
71− codepoint8 = map (fromIntegral . ord) codepoint
97+ codepoint8 = c:BS.unpack codepoint
72
98
73 in case decode codepoint8 of
99 in case decode codepoint8 of
74− _ | n < length codepoint -> Prefix
100+ _ | n < BS.length codepoint + 1 -> Prefix
75− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
101+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
76 -- something bad happened; just ignore and continue.
102 -- something bad happened; just ignore and continue.
77− Nothing -> Invalid
103+ Nothing -> Invalid
78
104
79−utf8Length :: (Num t, Ord a, Num a) => a -> t
105+utf8Length :: Word8 -> Int
80utf8Length c
106utf8Length c
81 | c < 0x80 = 1
107 | c < 0x80 = 1
82 | c < 0xE0 = 2
108 | c < 0xE0 = 2
src/Graphics/Vty/Input/Classify/Parse.hs+10−7
@@ -16,12 +16,15 @@ import Graphics.Vty.Input.Classify.Types
16import Control.Monad.Trans.Maybe
16import Control.Monad.Trans.Maybe
17import Control.Monad.State
17import Control.Monad.State
18
18
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+
19−type Parser a = MaybeT (State String) a
22+type Parser a = MaybeT (State ByteString) a
20
23
21-- | 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
22-- 'Invalid'. Otherwise return the valid event ('Valid') and the
25-- 'Invalid'. Otherwise return the valid event ('Valid') and the
23-- remaining unparsed characters.
26-- remaining unparsed characters.
24−runParser :: String -> Parser Event -> KClass
27+runParser :: ByteString -> Parser Event -> KClass
25runParser s parser =
28runParser s parser =
26 case runState (runMaybeT parser) s of
29 case runState (runMaybeT parser) s of
27 (Nothing, _) -> Invalid
30 (Nothing, _) -> Invalid
@@ -36,9 +39,9 @@ failParse = fail "invalid parse"
36-- return '123' and consume those characters.
39-- return '123' and consume those characters.
37readInt :: Parser Int
40readInt :: Parser Int
38readInt = do
41readInt = do
39− s <- get
42+ s <- BS8.unpack <$> get
40 case (reads :: ReadS Int) s of
43 case (reads :: ReadS Int) s of
41− [(i, rest)] -> put rest >> return i
44+ [(i, rest)] -> put (BS8.pack rest) >> return i
42 _ -> failParse
45 _ -> failParse
43
46
44-- | 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.
@@ -46,9 +49,9 @@ readInt = do
46readChar :: Parser Char
49readChar :: Parser Char
47readChar = do
50readChar = do
48 s <- get
51 s <- get
49− case s of
52+ case BS8.uncons s of
50− c:rest -> put rest >> return c
53+ Just (c,rest) -> put rest >> return c
51− _ -> failParse
54+ Nothing -> failParse
52
55
53-- | 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
54-- not the specified character.
57-- not the specified character.
src/Graphics/Vty/Input/Classify/Types.hs+7−1
@@ -1,5 +1,6 @@
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(..)
5 )
6 )
@@ -7,8 +8,10 @@ where
7
8
8import Graphics.Vty.Input.Events
9import Graphics.Vty.Input.Events
9
10
11+import Data.ByteString.Char8 (ByteString)
12+
10data KClass
13data KClass
11− = Valid Event [Char]
14+ = Valid Event ByteString
12 -- ^ A valid event was parsed. Any unused characters from the input
15 -- ^ A valid event was parsed. Any unused characters from the input
13 -- stream are also provided.
16 -- stream are also provided.
14 | Invalid
17 | Invalid
@@ -16,4 +19,7 @@ data KClass
16 | Prefix
19 | Prefix
17 -- ^ The input characters form the prefix of a valid event character
20 -- ^ The input characters form the prefix of a valid event character
18 -- 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.
19 deriving(Show, Eq)
25 deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs+29−7
@@ -1,6 +1,8 @@
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
@@ -14,23 +16,29 @@ import GHC.Generics
14--
16--
15-- * Actually, support for most of these but KEsc, KChar, KBS, and
17-- * Actually, support for most of these but KEsc, KChar, KBS, and
16-- KEnter vary by terminal and keyboard.
18-- KEnter vary by terminal and keyboard.
17−data Key = KEsc | KChar Char | KBS | KEnter
19+data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter
18 | KLeft | KRight | KUp | KDown
20 | KLeft | KRight | KUp | KDown
19 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
21 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
20− | KFun Int | KBackTab | KPrtScr | KPause | KIns
22+ | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns
21 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
23 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
22 deriving (Eq,Show,Read,Ord,Generic)
24 deriving (Eq,Show,Read,Ord,Generic)
23
25
26+instance NFData Key
27+
24-- | Modifier keys. Key codes are interpreted such that users are more
28-- | Modifier keys. Key codes are interpreted such that users are more
25-- likely to have Meta than Alt; for instance on the PC Linux console,
29-- likely to have Meta than Alt; for instance on the PC Linux console,
26-- 'MMeta' will generally correspond to the physical Alt key.
30-- 'MMeta' will generally correspond to the physical Alt key.
27data Modifier = MShift | MCtrl | MMeta | MAlt
31data Modifier = MShift | MCtrl | MMeta | MAlt
28 deriving (Eq,Show,Read,Ord,Generic)
32 deriving (Eq,Show,Read,Ord,Generic)
29
33
34+instance NFData Modifier
35+
30-- | Mouse buttons.
36-- | Mouse buttons.
31−data Button = BLeft | BMiddle | BRight
37+data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
32 deriving (Eq,Show,Read,Ord,Generic)
38 deriving (Eq,Show,Read,Ord,Generic)
33
39
40+instance NFData Button
41+
34-- | Events.
42-- | Events.
35data Event
43data Event
36 = EvKey Key [Modifier]
44 = EvKey Key [Modifier]
@@ -44,10 +52,8 @@ data Event
44 -- without specifying which one; in that case, Nothing is provided.
52 -- without specifying which one; in that case, Nothing is provided.
45 -- Otherwise Just the button released is included in the event.
53 -- Otherwise Just the button released is included in the event.
46 | EvResize Int Int
54 | EvResize Int Int
47− -- ^ 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
48− -- signal. If read from 'nextEvent' this is the size at the time the
56+ -- integer fields (width, height).
49− -- event was processed by Vty. Typically these are the same, but if
50− -- somebody is resizing the terminal quickly they can be different.
51 | EvPaste ByteString
57 | EvPaste ByteString
52 -- ^ A paste event occurs when a bracketed paste input sequence is
58 -- ^ A paste event occurs when a bracketed paste input sequence is
53 -- received. For terminals that support bracketed paste mode, these
59 -- received. For terminals that support bracketed paste mode, these
@@ -56,6 +62,22 @@ data Event
56 -- 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
57 -- 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
58 -- 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.
59 deriving (Eq,Show,Read,Ord,Generic)
69 deriving (Eq,Show,Read,Ord,Generic)
60
70
71+instance NFData Event
72+
61type 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+87−30
@@ -1,8 +1,9 @@
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
7-- | The input layer used to be a single function that correctly
7-- accounted for the non-threaded runtime by emulating the terminal
8-- accounted for the non-threaded runtime by emulating the terminal
8-- VMIN adn VTIME handling. This has been removed and replace with a
9-- VMIN adn VTIME handling. This has been removed and replace with a
@@ -24,7 +25,7 @@ import Control.Applicative
24import Control.Concurrent
25import Control.Concurrent
25import Control.Concurrent.STM
26import Control.Concurrent.STM
26import Control.Exception (mask, try, SomeException)
27import Control.Exception (mask, try, SomeException)
27−import Lens.Micro
28+import Lens.Micro hiding ((<>~))
28import Lens.Micro.Mtl
29import Lens.Micro.Mtl
29import Lens.Micro.TH
30import Lens.Micro.TH
30import Control.Monad (when, mzero, forM_)
31import Control.Monad (when, mzero, forM_)
@@ -33,12 +34,15 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)
33import Control.Monad.State.Class (MonadState, modify)
34import Control.Monad.State.Class (MonadState, modify)
34import Control.Monad.Trans.Reader (ReaderT(..))
35import Control.Monad.Trans.Reader (ReaderT(..))
35
36
36−import Data.Char
37+import qualified Data.ByteString.Char8 as BS8
38+import qualified Data.ByteString as BS
39+import Data.ByteString.Char8 (ByteString)
37import Data.IORef
40import Data.IORef
38import Data.Word (Word8)
41import Data.Word (Word8)
39
42
40−import Foreign ( allocaArray, peekArray, Ptr )
43+import Foreign (allocaArray)
41import Foreign.C.Types (CInt(..))
44import Foreign.C.Types (CInt(..))
45+import Foreign.Ptr (Ptr, castPtr)
42
46
43import System.IO
47import System.IO
44import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
48import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
@@ -51,10 +55,15 @@ data Input = Input
51 { -- | Channel of events direct from input processing. Unlike
55 { -- | Channel of events direct from input processing. Unlike
52 -- 'nextEvent' this will not refresh the display if the next event
56 -- 'nextEvent' this will not refresh the display if the next event
53 -- is an 'EvResize'.
57 -- is an 'EvResize'.
54− _eventChannel :: TChan Event
58+ _eventChannel :: TChan InternalEvent
55− -- | Shuts down the input processing. This should return the
59+ -- | Shuts down the input processing. As part of shutting down the
56− -- terminal input state to before he input initialized.
60+ -- input, this should also restore the input state.
57 , 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 ()
58 -- | Changes to this value are reflected after the next event.
67 -- | Changes to this value are reflected after the next event.
59 , _configRef :: IORef Config
68 , _configRef :: IORef Config
60 -- | input debug log
69 -- | input debug log
@@ -71,10 +80,11 @@ data InputBuffer = InputBuffer
71makeLenses ''InputBuffer
80makeLenses ''InputBuffer
72
81
73data InputState = InputState
82data InputState = InputState
74− { _unprocessedBytes :: String
83+ { _unprocessedBytes :: ByteString
84+ , _classifierState :: ClassifierState
75 , _appliedConfig :: Config
85 , _appliedConfig :: Config
76 , _inputBuffer :: InputBuffer
86 , _inputBuffer :: InputBuffer
77− , _classifier :: String -> KClass
87+ , _classifier :: ClassifierState -> ByteString -> KClass
78 }
88 }
79
89
80makeLenses ''InputState
90makeLenses ''InputState
@@ -99,20 +109,20 @@ loopInputProcessor = do
99 dropInvalid
109 dropInvalid
100 loopInputProcessor
110 loopInputProcessor
101
111
102−addBytesToProcess :: String -> InputM ()
112+addBytesToProcess :: ByteString -> InputM ()
103addBytesToProcess block = unprocessedBytes <>= block
113addBytesToProcess block = unprocessedBytes <>= block
104
114
105emit :: Event -> InputM ()
115emit :: Event -> InputM ()
106emit event = do
116emit event = do
107 logMsg $ "parsed event: " ++ show event
117 logMsg $ "parsed event: " ++ show event
108− view eventChannel >>= liftIO . atomically . flip writeTChan event
118+ view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
109
119
110-- The timing requirements are assured by the VMIN and VTIME set for the
120-- The timing requirements are assured by the VMIN and VTIME set for the
111-- device.
121-- device.
112--
122--
113-- Precondition: Under the threaded runtime. Only current use is from a
123-- Precondition: Under the threaded runtime. Only current use is from a
114-- forkOS thread. That case satisfies precondition.
124-- forkOS thread. That case satisfies precondition.
115−readFromDevice :: InputM String
125+readFromDevice :: InputM ByteString
116readFromDevice = do
126readFromDevice = do
117 newConfig <- view configRef >>= liftIO . readIORef
127 newConfig <- view configRef >>= liftIO . readIORef
118 oldConfig <- use appliedConfig
128 oldConfig <- use appliedConfig
@@ -132,9 +142,10 @@ readFromDevice = do
132 threadWaitRead fd
142 threadWaitRead fd
133 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
134 if bytesRead > 0
144 if bytesRead > 0
135− then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
145+ then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
136− else return []
146+ else return BS.empty
147+ when (not $ BS.null stringRep) $
137− when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
148+ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
138 return stringRep
149 return stringRep
139
150
140applyConfig :: Fd -> Config -> IO ()
151applyConfig :: Fd -> Config -> IO ()
@@ -145,41 +156,86 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat
145parseEvent :: InputM Event
156parseEvent :: InputM Event
146parseEvent = do
157parseEvent = do
147 c <- use classifier
158 c <- use classifier
159+ s <- use classifierState
148 b <- use unprocessedBytes
160 b <- use unprocessedBytes
149− case c b of
161+ case c s b of
150 Valid e remaining -> do
162 Valid e remaining -> do
151 logMsg $ "valid parse: " ++ show e
163 logMsg $ "valid parse: " ++ show e
152 logMsg $ "remaining: " ++ show remaining
164 logMsg $ "remaining: " ++ show remaining
165+ classifierState .= ClassifierStart
153 unprocessedBytes .= remaining
166 unprocessedBytes .= remaining
154 return e
167 return e
155− _ -> mzero
168+ _ -> mzero
156
169
157dropInvalid :: InputM ()
170dropInvalid :: InputM ()
158dropInvalid = do
171dropInvalid = do
159 c <- use classifier
172 c <- use classifier
173+ s <- use classifierState
160 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
161− when (c b == Invalid) $ do
182+ Invalid -> do
162− logMsg "dropping input bytes"
183+ logMsg "dropping input bytes"
184+ classifierState .= ClassifierStart
163− unprocessedBytes .= []
185+ unprocessedBytes .= BS8.empty
186+ _ -> return ()
164
187
165runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
166runInputProcessorLoop classifyTable input = do
189runInputProcessorLoop classifyTable input = do
167 let bufferSize = 1024
190 let bufferSize = 1024
168 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
192+ s0 <- InputState BS8.empty ClassifierStart
169− s0 <- InputState [] <$> readIORef (_configRef input)
193+ <$> readIORef (_configRef input)
170− <*> pure (InputBuffer bufferPtr bufferSize)
194+ <*> pure (InputBuffer bufferPtr bufferSize)
171− <*> pure (classify classifyTable)
195+ <*> pure (classify classifyTable)
172 runReaderT (evalStateT loopInputProcessor s0) input
196 runReaderT (evalStateT loopInputProcessor s0) input
173
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)
174attributeControl :: Fd -> IO (IO (), IO ())
223attributeControl :: Fd -> IO (IO (), IO ())
175attributeControl fd = do
224attributeControl fd = do
176 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
177− let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
231+ , KeyboardInterrupts -- ISIG
232+ , EnableEcho -- ECHO
233+ , ProcessInput -- ICANON
178− , EnableEcho, ProcessInput, ExtendedFunctions
234+ , ExtendedFunctions -- IEXTEN
179− ]
235+ ]
180 let setAttrs = setTerminalAttributes fd vtyMode Immediately
236 let setAttrs = setTerminalAttributes fd vtyMode Immediately
181 unsetAttrs = setTerminalAttributes fd original Immediately
237 unsetAttrs = setTerminalAttributes fd original Immediately
182− return (setAttrs,unsetAttrs)
238+ return (setAttrs, unsetAttrs)
183
239
184logInitialInputState :: Input -> ClassifyMap -> IO()
240logInitialInputState :: Input -> ClassifyMap -> IO()
185logInitialInputState input classifyTable = case _inputDebug input of
241logInitialInputState input classifyTable = case _inputDebug input of
@@ -187,7 +243,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
187 Just h -> do
243 Just h -> do
188 Config{ vmin = Just theVmin
244 Config{ vmin = Just theVmin
189 , vtime = Just theVtime
245 , vtime = Just theVtime
190− , termName = Just theTerm, .. } <- readIORef $ _configRef input
246+ , termName = Just theTerm } <- readIORef $ _configRef input
191 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
192 forM_ classifyTable $ \i -> case i of
248 forM_ classifyTable $ \i -> case i of
193 (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)
@@ -203,6 +259,7 @@ initInput config classifyTable = do
203 applyConfig fd config
259 applyConfig fd config
204 stopSync <- newEmptyMVar
260 stopSync <- newEmptyMVar
205 input <- Input <$> atomically newTChan
261 input <- Input <$> atomically newTChan
262+ <*> pure (return ())
206 <*> pure (return ())
263 <*> pure (return ())
207 <*> newIORef config
264 <*> newIORef config
208 <*> maybe (return Nothing)
265 <*> maybe (return Nothing)
src/Graphics/Vty/Input/Mouse.hs+28−18
@@ -15,10 +15,12 @@ import Graphics.Vty.Input.Classify.Types
15import Graphics.Vty.Input.Classify.Parse
15import Graphics.Vty.Input.Classify.Parse
16
16
17import Control.Monad.State
17import Control.Monad.State
18−import Data.List (isPrefixOf)
19import Data.Maybe (catMaybes)
18import Data.Maybe (catMaybes)
20import Data.Bits ((.&.))
19import Data.Bits ((.&.))
21
20
21+import qualified Data.ByteString.Char8 as BS8
22+import Data.ByteString.Char8 (ByteString)
23+
22-- A mouse event in SGR extended mode is
24-- A mouse event in SGR extended mode is
23--
25--
24-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
26-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
@@ -32,28 +34,28 @@ import Data.Bits ((.&.))
32
34
33-- | These sequences set xterm-based terminals to send mouse event
35-- | These sequences set xterm-based terminals to send mouse event
34-- sequences.
36-- sequences.
35−requestMouseEvents :: String
37+requestMouseEvents :: ByteString
36−requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h\ESC[?1005h"
38+requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
37
39
38-- | These sequences disable mouse events.
40-- | These sequences disable mouse events.
39−disableMouseEvents :: String
41+disableMouseEvents :: ByteString
40−disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l\ESC[?1005l"
42+disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
41
43
42-- | Does the specified string begin with a mouse event?
44-- | Does the specified string begin with a mouse event?
43−isMouseEvent :: String -> Bool
45+isMouseEvent :: ByteString -> Bool
44isMouseEvent s = isSGREvent s || isNormalEvent s
46isMouseEvent s = isSGREvent s || isNormalEvent s
45
47
46−isSGREvent :: String -> Bool
48+isSGREvent :: ByteString -> Bool
47−isSGREvent = isPrefixOf sgrPrefix
49+isSGREvent = BS8.isPrefixOf sgrPrefix
48
50
49−sgrPrefix :: String
51+sgrPrefix :: ByteString
50−sgrPrefix = "\ESC[M"
52+sgrPrefix = BS8.pack "\ESC[M"
51
53
52−isNormalEvent :: String -> Bool
54+isNormalEvent :: ByteString -> Bool
53−isNormalEvent = isPrefixOf normalPrefix
55+isNormalEvent = BS8.isPrefixOf normalPrefix
54
56
55−normalPrefix :: String
57+normalPrefix :: ByteString
56−normalPrefix = "\ESC[<"
58+normalPrefix = BS8.pack "\ESC[<"
57
59
58-- Modifier bits:
60-- Modifier bits:
59shiftBit :: Int
61shiftBit :: Int
@@ -67,7 +69,7 @@ ctrlBit = 16
67
69
68-- These bits indicate the buttons involved:
70-- These bits indicate the buttons involved:
69buttonMask :: Int
71buttonMask :: Int
70−buttonMask = 3
72+buttonMask = 67
71
73
72leftButton :: Int
74leftButton :: Int
73leftButton = 0
75leftButton = 0
@@ -78,11 +80,17 @@ middleButton = 1
78rightButton :: Int
80rightButton :: Int
79rightButton = 2
81rightButton = 2
80
82
83+scrollUp :: Int
84+scrollUp = 64
85+
86+scrollDown :: Int
87+scrollDown = 65
88+
81hasBitSet :: Int -> Int -> Bool
89hasBitSet :: Int -> Int -> Bool
82hasBitSet val bit = val .&. bit > 0
90hasBitSet val bit = val .&. bit > 0
83
91
84−-- | Attempt to lassify an input string as a mouse event.
92+-- | Attempt to classify an input string as a mouse event.
85−classifyMouseEvent :: String -> KClass
93+classifyMouseEvent :: ByteString -> KClass
86classifyMouseEvent s = runParser s $ do
94classifyMouseEvent s = runParser s $ do
87 when (not $ isMouseEvent s) failParse
95 when (not $ isMouseEvent s) failParse
88
96
@@ -94,12 +102,14 @@ classifyMouseEvent s = runParser s $ do
94 'M' -> classifyNormalMouseEvent
102 'M' -> classifyNormalMouseEvent
95 _ -> failParse
103 _ -> failParse
96
104
97−-- Given a modifer/button value, determine which button was indicated
105+-- Given a modifier/button value, determine which button was indicated
98getSGRButton :: Int -> Parser Button
106getSGRButton :: Int -> Parser Button
99getSGRButton mods =
107getSGRButton mods =
100 let buttonMap = [ (leftButton, BLeft)
108 let buttonMap = [ (leftButton, BLeft)
101 , (middleButton, BMiddle)
109 , (middleButton, BMiddle)
102 , (rightButton, BRight)
110 , (rightButton, BRight)
111+ , (scrollUp, BScrollUp)
112+ , (scrollDown, BScrollDown)
103 ]
113 ]
104 in case lookup (mods .&. buttonMask) buttonMap of
114 in case lookup (mods .&. buttonMask) buttonMap of
105 Nothing -> failParse
115 Nothing -> failParse
src/Graphics/Vty/Input/Paste.hs+16−24
@@ -9,41 +9,33 @@ module Graphics.Vty.Input.Paste
9where
9where
10
10
11import qualified Data.ByteString.Char8 as BS8
11import qualified Data.ByteString.Char8 as BS8
12+import Data.ByteString.Char8 (ByteString)
12
13
13import Graphics.Vty.Input.Events
14import Graphics.Vty.Input.Events
14import Graphics.Vty.Input.Classify.Types
15import Graphics.Vty.Input.Classify.Types
15
16
16−import Data.List (isPrefixOf, isInfixOf)
17+bracketedPasteStart :: ByteString
18+bracketedPasteStart = BS8.pack "\ESC[200~"
17
19
18−bracketedPasteStart :: String
19−bracketedPasteStart = "\ESC[200~"
20−
21−bracketedPasteEnd :: String
20+bracketedPasteEnd :: ByteString
22−bracketedPasteEnd = "\ESC[201~"
21+bracketedPasteEnd = BS8.pack "\ESC[201~"
23
22
24-- | Does the input start a bracketed paste?
23-- | Does the input start a bracketed paste?
25−bracketedPasteStarted :: String -> Bool
24+bracketedPasteStarted :: ByteString -> Bool
26−bracketedPasteStarted = isPrefixOf bracketedPasteStart
25+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart
27
26
28-- | Does the input contain a complete bracketed paste?
27-- | Does the input contain a complete bracketed paste?
29−bracketedPasteFinished :: String -> Bool
28+bracketedPasteFinished :: ByteString -> Bool
30−bracketedPasteFinished = isInfixOf bracketedPasteEnd
29+bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd
31
30
32-- | 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
33-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
32-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
34-- 'True'.
33-- 'True'.
35−parseBracketedPaste :: String -> KClass
34+parseBracketedPaste :: ByteString -> KClass
36parseBracketedPaste s =
35parseBracketedPaste s =
37− let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd
38− rest' = if bracketedPasteEnd `isPrefixOf` rest
39− then drop (length bracketedPasteEnd) rest
40− else rest
41− in Valid (EvPaste $ BS8.pack p) rest'
36+ Valid (EvPaste p) (BS8.drop endLen rest')
42−
37+ where
43−takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])
38+ startLen = BS8.length bracketedPasteStart
44−takeUntil [] _ = ([], [])
39+ endLen = BS8.length bracketedPasteEnd
45−takeUntil cs sub
40+ (_, rest ) = BS8.breakSubstring bracketedPasteStart s
46− | length cs < length sub = (cs, [])
41+ (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest
47− | take (length sub) cs == sub = ([], drop (length sub) cs)
48− | otherwise = let (pre, suf) = takeUntil (tail cs) sub
49− in (head cs:pre, suf)
src/Graphics/Vty/Input/Terminfo.hs+23−21
@@ -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
10+-- | Queries the terminal for all capability-based input sequences and
11−-- adds on a terminal dependent 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,25 +20,26 @@ 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
23+-- Terminfo is incomplete. The vim source implies that terminfo is also
24−-- terminfo is also incorrect. Vty assumes that the an internal terminfo
24+-- incorrect. Vty assumes that the internal terminfo table added to the
25−-- table added to the system provided terminfo table is 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+-- 3. Add internally-defined table for given terminal type.
34+--
33−-- Precedence is currently implicit in the 'compile' algorithm. Which is
35+-- Precedence is currently implicit in the 'compile' algorithm.
34−-- a bit odd.
35classifyMapForTerm :: String -> Terminal -> ClassifyMap
36classifyMapForTerm :: String -> Terminal -> ClassifyMap
36classifyMapForTerm termName term =
37classifyMapForTerm termName term =
37 concat $ capsClassifyMap term keysFromCapsTable
38 concat $ capsClassifyMap term keysFromCapsTable
38 : universalTable
39 : universalTable
39 : termSpecificTables termName
40 : termSpecificTables termName
40
41
41−-- | key table applicable to all terminals.
42+-- | The key table applicable to all terminals.
42--
43--
43-- Note that some of these entries are probably only applicable to
44-- Note that some of these entries are probably only applicable to
44-- ANSI/VT100 terminals.
45-- ANSI/VT100 terminals.
@@ -66,14 +67,14 @@ visibleChars = [ ([x], EvKey (KChar x) [])
66 | x <- [' ' .. toEnum 0xC1]
67 | x <- [' ' .. toEnum 0xC1]
67 ]
68 ]
68
69
69−-- | Non visible characters in the ISO-8859-1 and UTF-8 common set
70+-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set
70-- translated to ctrl + char.
71-- translated to ctrl + char.
71--
72--
72-- This treats CTRL-i the same as tab.
73-- This treats CTRL-i the same as tab.
73ctrlChars :: ClassifyMap
74ctrlChars :: ClassifyMap
74ctrlChars =
75ctrlChars =
75 [ ([toEnum x],EvKey (KChar y) [MCtrl])
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
76− | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
77+ | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
77 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
78 , y /= 'h' -- CTRL-h should not hide BS
79 , y /= 'h' -- CTRL-h should not hide BS
79 ]
80 ]
@@ -82,22 +83,23 @@ ctrlChars =
82ctrlMetaChars :: ClassifyMap
83ctrlMetaChars :: ClassifyMap
83ctrlMetaChars = 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
84
85
85−-- | esc, meta esc, delete, meta delete, enter, meta enter
86+-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
86specialSupportKeys :: ClassifyMap
87specialSupportKeys :: ClassifyMap
87specialSupportKeys =
88specialSupportKeys =
89+ [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90+ , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
88− [ -- special support for ESC
91+ -- special support for ESC
89− ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
92+ , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
90 -- Special support for backspace
93 -- Special support for backspace
91− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
94+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
92 -- Special support for Enter
95 -- Special support for Enter
93 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
94 -- explicit support for tab
97 -- explicit support for tab
95 , ("\t", EvKey (KChar '\t') [])
98 , ("\t", EvKey (KChar '\t') [])
96 ]
99 ]
97
100
98−-- | classify table directly generated from terminfo cap strings
101+-- | A classification table directly generated from terminfo cap
99−--
102+-- strings. These are:
100−-- these are:
101--
103--
102-- * ka1 - keypad up-left
104-- * ka1 - keypad up-left
103--
105--
@@ -179,6 +181,6 @@ keysFromCapsTable =
179 , ("kcuu1", EvKey KUp [])
181 , ("kcuu1", EvKey KUp [])
180 ] ++ functionKeyCapsTable
182 ] ++ functionKeyCapsTable
181
183
182−-- | cap names for function keys
184+-- | Cap names for function keys.
183functionKeyCapsTable :: ClassifyMap
185functionKeyCapsTable :: ClassifyMap
184functionKeyCapsTable = 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+1−1
@@ -59,7 +59,7 @@ navKeys3 =
59-- This encoding depends on the terminal.
59-- This encoding depends on the terminal.
60functionKeys1 :: ClassifyMap
60functionKeys1 :: ClassifyMap
61functionKeys1 =
61functionKeys1 =
62− 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
63 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] ]
64
64
65-- | encoding for meta plus char
65-- | encoding for meta plus char
src/Graphics/Vty/Output.hs+29−32
@@ -1,27 +1,24 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
2−{-# LANGUAGE NamedFieldPuns #-}
2+-- | This module provides functions for accessing the current terminal
3−-- | Output functions.
4−--
5−-- Access to the current terminal or a specific terminal device.
3+-- or a specific terminal device.
6--
4--
7-- See also:
5-- See also:
8--
6--
9−-- 1. "Graphics.Vty.Output": This instantiates an abtract interface to
7+-- 1. "Graphics.Vty.Output": This instantiates an abtract interface
10−-- the terminal interface based on the TERM and COLORTERM environment
8+-- to the terminal based on the @TERM@ and @COLORTERM@ environment
11-- variables.
9-- variables.
12--
10--
13-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
11-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
14−-- terminals need to implement.
12+-- terminal modules need to implement.
15--
13--
16-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
14-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
17-- that uses terminfo for all control strings. No attempt is made to
15-- that uses terminfo for all control strings. No attempt is made to
18−-- change the character set to UTF-8 for these terminals. I don't know a
16+-- change the character set to UTF-8 for these terminals.
19−-- way to reliably determine if that is required or how to do so.
20--
17--
21-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
18-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
22-- interface suitable for xterm-like terminals. These are the terminals
19-- interface suitable for xterm-like terminals. These are the terminals
23−-- where TERM == xterm. This does use terminfo for as many control codes
20+-- where @TERM@ begins with @xterm@. This does use terminfo for as many
24−-- as possible.
21+-- control codes as possible.
25module Graphics.Vty.Output
22module Graphics.Vty.Output
26 ( outputForConfig
23 ( outputForConfig
27 , setCursorPos
24 , setCursorPos
@@ -40,33 +37,33 @@ import Graphics.Vty.Output.TerminfoBased as TerminfoBased
40
37
41import Blaze.ByteString.Builder (writeToByteString)
38import Blaze.ByteString.Builder (writeToByteString)
42
39
43−import Control.Monad.Trans
44−
45import Data.List (isPrefixOf)
40import Data.List (isPrefixOf)
41+
42+#if !MIN_VERSION_base(4,11,0)
46import Data.Monoid ((<>))
43import Data.Monoid ((<>))
44+#endif
47
45
48−-- | Returns a `Output` for the terminal specified in `Config`
46+-- | Returns an `Output` for the terminal specified in `Config`.
49--
47--
50-- The specific Output implementation used is hidden from the API user.
48-- The specific Output implementation used is hidden from the API user.
51-- All terminal implementations are assumed to perform more, or less,
49-- All terminal implementations are assumed to perform more, or less,
52-- the same. Currently, all implementations use terminfo for at least
50-- the same. Currently, all implementations use terminfo for at least
53-- some terminal specific information.
51-- some terminal specific information.
54--
52--
55−-- Specifics about it being based on terminfo are hidden from the API
56−-- user. If a terminal implementation is developed for a terminal
53+-- If a terminal implementation is developed for a terminal without
57−-- without terminfo support then Vty should work as expected on that
54+-- terminfo support then Vty should work as expected on that terminal.
58−-- terminal.
59--
55--
60-- Selection of a terminal is done as follows:
56-- Selection of a terminal is done as follows:
61--
57--
62-- * If TERM contains "xterm" or "screen", use XTermColor.
58-- * If TERM contains "xterm" or "screen", use XTermColor.
63-- * otherwise use the TerminfoBased driver.
59-- * otherwise use the TerminfoBased driver.
64outputForConfig :: Config -> IO Output
60outputForConfig :: Config -> IO Output
65−outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do
61+outputForConfig Config{ outputFd = Just fd, termName = Just termName
62+ , colorMode = Just colorMode, .. } = do
66 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
67− then XTermColor.reserveTerminal termName fd
64+ then XTermColor.reserveTerminal termName fd colorMode
68 -- Not an xterm-like terminal. try for generic terminfo.
65 -- Not an xterm-like terminal. try for generic terminfo.
69− else TerminfoBased.reserveTerminal termName fd
66+ else TerminfoBased.reserveTerminal termName fd colorMode
70
67
71 case mouseMode of
68 case mouseMode of
72 Just s -> setMode t Mouse s
69 Just s -> setMode t Mouse s
@@ -81,30 +78,30 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
81
78
82-- | Sets the cursor position to the given output column and row.
79-- | Sets the cursor position to the given output column and row.
83--
80--
84−-- This is not necessarially the same as the character position with the
81+-- This is not necessarily the same as the character position with the
85-- same coordinates. Characters can be a variable number of columns in
82-- same coordinates. Characters can be a variable number of columns in
86-- width.
83-- width.
87--
84--
88-- Currently, the only way to set the cursor position to a given
85-- Currently, the only way to set the cursor position to a given
89-- character coordinate is to specify the coordinate in the Picture
86-- character coordinate is to specify the coordinate in the Picture
90−-- instance provided to outputPicture or refresh.
87+-- instance provided to 'outputPicture' or 'refresh'.
91−setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()
88+setCursorPos :: Output -> Int -> Int -> IO ()
92setCursorPos t x y = do
89setCursorPos t x y = do
93 bounds <- displayBounds t
90 bounds <- displayBounds t
94 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
95 dc <- displayContext t bounds
92 dc <- displayContext t bounds
96− liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
93+ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
97
94
98−-- | Hides the cursor
95+-- | Hides the cursor.
99−hideCursor :: MonadIO m => Output -> m ()
96+hideCursor :: Output -> IO ()
100hideCursor t = do
97hideCursor t = do
101 bounds <- displayBounds t
98 bounds <- displayBounds t
102 dc <- displayContext t bounds
99 dc <- displayContext t bounds
103− liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
100+ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
104
101
105−-- | Shows the cursor
102+-- | Shows the cursor.
106−showCursor :: MonadIO m => Output -> m ()
103+showCursor :: Output -> IO ()
107showCursor t = do
104showCursor t = do
108 bounds <- displayBounds t
105 bounds <- displayBounds t
109 dc <- displayContext t bounds
106 dc <- displayContext t bounds
110− liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
107+ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+135−99
@@ -1,11 +1,11 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2−-- General philosophy is: MonadIO is for equations exposed to clients.
3−{-# LANGUAGE BangPatterns #-}
4{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
7{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
8−
6+{-# LANGUAGE ScopedTypeVariables #-}
7+-- | This module provides an abstract interface for performing terminal
8+-- output. The only user-facing part of this API is 'Output'.
9module Graphics.Vty.Output.Interface
9module Graphics.Vty.Output.Interface
10 ( Output(..)
10 ( Output(..)
11 , AssumedState(..)
11 , AssumedState(..)
@@ -29,8 +29,6 @@ import Graphics.Vty.DisplayAttributes
29import Blaze.ByteString.Builder (Write, writeToByteString)
29import Blaze.ByteString.Builder (Write, writeToByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
31
31
32−import Control.Monad.Trans
33−
34import qualified Data.ByteString as BS
32import qualified Data.ByteString as BS
35import Data.IORef
33import Data.IORef
36import qualified Data.Text.Encoding as T
34import qualified Data.Text.Encoding as T
@@ -39,63 +37,89 @@ import qualified Data.Vector as Vector
39
37
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
63+ -- | Clear the display and initialize the terminal to some initial
50− -- display state.
64+ -- display state.
51− --
65+ --
52− -- The expectation of a program is that the display starts in some
66+ -- The expectation of a program is that the display starts in some
53− -- The initial state. initial state would consist of fixed values:
67+ -- The initial state. initial state would consist of fixed values:
54− --
68+ --
55− -- - cursor at top left
69+ -- - cursor at top left
56− -- - UTF-8 character encoding
70+ -- - UTF-8 character encoding
57− -- - drawing characteristics are the default
71+ -- - drawing characteristics are the default
58− --
59− -- The abstract operation I think all these behaviors are instances
60− -- of is reserving exclusive access to a display such that:
61− --
62− -- - The previous state cannot be determined
63− -- - When exclusive access to a display is released the display
64− -- returns to the previous state.
65− , reserveDisplay :: forall m. MonadIO m => m ()
72+ , reserveDisplay :: IO ()
66− -- | Return the display to the state before `reserveDisplay`
73+ -- | Return the display to the state before `reserveDisplay` If no
67− -- If no previous state then set the display state to the initial
74+ -- previous state then set the display state to the initial state.
68− -- state.
69− , releaseDisplay :: forall m. MonadIO m => m ()
75+ , releaseDisplay :: IO ()
76+ -- | Sets the current display bounds (width, height).
77+ , setDisplayBounds :: (Int, Int) -> IO ()
70− -- | Returns the current display bounds.
78+ -- | Returns the current display bounds.
71− , displayBounds :: forall m. MonadIO m => m DisplayRegion
79+ , displayBounds :: IO DisplayRegion
72− -- | Output the byte string to the terminal device.
80+ -- | Output the bytestring to the terminal device.
73 , outputByteBuffer :: BS.ByteString -> IO ()
81 , outputByteBuffer :: BS.ByteString -> IO ()
74− -- | Maximum number of colors supported by the context.
75− , contextColorCount :: Int
76− -- | if the cursor can be shown / hidden
82+ -- | Specifies whether the cursor can be shown / hidden.
77 , supportsCursorVisibility :: Bool
83 , supportsCursorVisibility :: Bool
78− -- | Indicates support for terminal modes for this output device
84+ -- | Indicates support for terminal modes for this output device.
79 , supportsMode :: Mode -> Bool
85 , supportsMode :: Mode -> Bool
80− -- | Enables or disables a mode (does nothing if the mode is
86+ -- | Enables or disables a mode (does nothing if the mode is
81− -- unsupported)
87+ -- unsupported).
82− , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()
88+ , setMode :: Mode -> Bool -> IO ()
83− -- | Returns whether a mode is enabled
89+ -- | Returns whether a mode is enabled.
84− , getModeStatus :: forall m. MonadIO m => Mode -> m Bool
90+ , getModeStatus :: Mode -> IO Bool
85 , assumedStateRef :: IORef AssumedState
91 , assumedStateRef :: IORef AssumedState
86− -- | Acquire display access to the given region of the display.
92+ -- | Acquire display access to the given region of the display.
87− -- Currently all regions have the upper left corner of (0,0) and
93+ -- Currently all regions have the upper left corner of (0,0) and
88− -- the lower right corner at (max displayWidth providedWidth, max
94+ -- the lower right corner at (max displayWidth providedWidth, max
89− -- displayHeight providedHeight)
95+ -- displayHeight providedHeight)
90− , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
96+ , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
91− -- | Ring the terminal bell if supported.
97+ -- | Ring the terminal bell if supported.
92− , ringTerminalBell :: forall m. MonadIO m => m ()
98+ , ringTerminalBell :: IO ()
93− -- | Returns whether the terminal has an audio bell feature.
99+ -- | Returns whether the terminal has an audio bell feature.
94− , 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
95 }
119 }
96
120
97−displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
121+displayContext :: Output -> DisplayRegion -> IO DisplayContext
98−displayContext t = liftIO . mkDisplayContext t t
122+displayContext t = mkDisplayContext t t
99
123
100data AssumedState = AssumedState
124data AssumedState = AssumedState
101 { prevFattr :: Maybe FixedAttr
125 { prevFattr :: Maybe FixedAttr
@@ -109,16 +133,16 @@ data DisplayContext = DisplayContext
109 { contextDevice :: Output
133 { contextDevice :: Output
110 -- | Provide the bounds of the display context.
134 -- | Provide the bounds of the display context.
111 , contextRegion :: DisplayRegion
135 , contextRegion :: DisplayRegion
112− -- | sets the output position to the specified row and column.
136+ -- | Sets the output position to the specified row and column
113− -- Where the number of bytes required for the control codes can be
137+ -- where the number of bytes required for the control codes can be
114 -- specified seperate from the actual byte sequence.
138 -- specified seperate from the actual byte sequence.
115 , writeMoveCursor :: Int -> Int -> Write
139 , writeMoveCursor :: Int -> Int -> Write
116 , writeShowCursor :: Write
140 , writeShowCursor :: Write
117 , writeHideCursor :: Write
141 , writeHideCursor :: Write
118− -- | Assure the specified output attributes will be applied to
142+ -- Ensure that the specified output attributes will be applied to
119− -- all the following text until the next output attribute change.
143+ -- all the following text until the next output attribute change
120− -- Where the number of bytes required for the control codes can be
144+ -- where the number of bytes required for the control codes can be
121− -- specified seperate from the actual byte sequence. The required
145+ -- specified seperately from the actual byte sequence. The required
122 -- number of bytes must be at least the maximum number of bytes
146 -- number of bytes must be at least the maximum number of bytes
123 -- required by any attribute changes. The serialization equations
147 -- required by any attribute changes. The serialization equations
124 -- must provide the ptr to the next byte to be specified in the
148 -- must provide the ptr to the next byte to be specified in the
@@ -130,9 +154,9 @@ data DisplayContext = DisplayContext
130 -- to support this the currently applied display attributes are
154 -- to support this the currently applied display attributes are
131 -- required. In addition it may be possible to optimize the state
155 -- required. In addition it may be possible to optimize the state
132 -- changes based off the currently applied display attributes.
156 -- changes based off the currently applied display attributes.
133− , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
157+ , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
134− -- | Reset the display attributes to the default display attributes
158+ -- | Reset the display attributes to the default display attributes.
135− , writeDefaultAttr :: Write
159+ , writeDefaultAttr :: Bool -> Write
136 , writeRowEnd :: Write
160 , writeRowEnd :: Write
137 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
138 , inlineHack :: IO ()
162 , inlineHack :: IO ()
@@ -145,33 +169,33 @@ writeUtf8Text = writeByteString
145
169
146-- | Displays the given `Picture`.
170-- | Displays the given `Picture`.
147--
171--
148−-- 0. The image is cropped to the display size.
172+-- 1. The image is cropped to the display size.
149--
173--
150−-- 1. Converted into a sequence of attribute changes and text spans.
174+-- 2. Converted into a sequence of attribute changes and text spans.
151--
175--
152−-- 2. The cursor is hidden.
176+-- 3. The cursor is hidden.
153--
177--
154−-- 3. Serialized to the display.
178+-- 4. Serialized to the display.
155--
179--
156−-- 4. The cursor is then shown and positioned or kept hidden.
180+-- 5. The cursor is then shown and positioned or kept hidden.
157−outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
181+outputPicture :: DisplayContext -> Picture -> IO ()
158−outputPicture dc pic = liftIO $ do
182+outputPicture dc pic = do
183+ urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
159 as <- readIORef (assumedStateRef $ contextDevice dc)
184 as <- readIORef (assumedStateRef $ contextDevice dc)
160 let manipCursor = supportsCursorVisibility (contextDevice dc)
185 let manipCursor = supportsCursorVisibility (contextDevice dc)
161 r = contextRegion dc
186 r = contextRegion dc
162 ops = displayOpsForPic pic r
187 ops = displayOpsForPic pic r
163− initialAttr = FixedAttr defaultStyleMask Nothing Nothing
188+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
164 -- Diff the previous output against the requested output.
189 -- Diff the previous output against the requested output.
165 -- Differences are currently on a per-row basis.
190 -- Differences are currently on a per-row basis.
166 diffs :: [Bool] = case prevOutputOps as of
191 diffs :: [Bool] = case prevOutputOps as of
167− Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True
192+ Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
168− Just previousOps -> if effectedRegion previousOps /= effectedRegion ops
193+ Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
169 then replicate (displayOpsRows ops) True
194 then replicate (displayOpsRows ops) True
170− else zipWith (/=) (Vector.toList previousOps)
195+ else Vector.toList $ Vector.zipWith (/=) previousOps ops
171− (Vector.toList ops)
172 -- build the Write corresponding to the output image
196 -- build the Write corresponding to the output image
173 out = (if manipCursor then writeHideCursor dc else mempty)
197 out = (if manipCursor then writeHideCursor dc else mempty)
174− `mappend` writeOutputOps dc initialAttr diffs ops
198+ `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
175 `mappend`
199 `mappend`
176 (let (w,h) = contextRegion dc
200 (let (w,h) = contextRegion dc
177 clampX = max 0 . min (w-1)
201 clampX = max 0 . min (w-1)
@@ -182,9 +206,15 @@ outputPicture dc pic = liftIO $ do
182 AbsoluteCursor x y ->
206 AbsoluteCursor x y ->
183 writeShowCursor dc `mappend`
207 writeShowCursor dc `mappend`
184 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)
185 Cursor x y ->
215 Cursor x y ->
186 let m = cursorOutputMap ops $ picCursor pic
216 let m = cursorOutputMap ops $ picCursor pic
187− (ox, oy) = charToOutputPos m (x,y)
217+ (ox, oy) = charToOutputPos m (clampX x, clampY y)
188 in writeShowCursor dc `mappend`
218 in writeShowCursor dc `mappend`
189 writeMoveCursor dc (clampX ox) (clampY oy)
219 writeMoveCursor dc (clampX ox) (clampY oy)
190 )
220 )
@@ -194,15 +224,15 @@ outputPicture dc pic = liftIO $ do
194 let as' = as { prevOutputOps = Just ops }
224 let as' = as { prevOutputOps = Just ops }
195 writeIORef (assumedStateRef $ contextDevice dc) as'
225 writeIORef (assumedStateRef $ contextDevice dc) as'
196
226
197−writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
227+writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
198−writeOutputOps dc initialAttr diffs ops =
228+writeOutputOps urlsEnabled dc initialAttr diffs ops =
199 let (_, out, _) = Vector.foldl' writeOutputOps'
229 let (_, out, _) = Vector.foldl' writeOutputOps'
200 (0, mempty, diffs)
230 (0, mempty, diffs)
201 ops
231 ops
202 in out
232 in out
203 where
233 where
204 writeOutputOps' (y, out, True : diffs') spanOps
234 writeOutputOps' (y, out, True : diffs') spanOps
205− = let spanOut = writeSpanOps dc y initialAttr spanOps
235+ = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
206 out' = out `mappend` spanOut
236 out' = out `mappend` spanOut
207 in (y+1, out', diffs')
237 in (y+1, out', diffs')
208 writeOutputOps' (y, out, False : diffs') _spanOps
238 writeOutputOps' (y, out, False : diffs') _spanOps
@@ -210,27 +240,27 @@ writeOutputOps dc initialAttr diffs ops =
210 writeOutputOps' (_y, _out, []) _spanOps
240 writeOutputOps' (_y, _out, []) _spanOps
211 = error "vty - output spans without a corresponding diff."
241 = error "vty - output spans without a corresponding diff."
212
242
213−writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
243+writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
214−writeSpanOps dc y initialAttr spanOps =
244+writeSpanOps urlsEnabled dc y initialAttr spanOps =
215 -- 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
216− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
246+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
217 -- then the span ops are serialized in the order specified
247 -- then the span ops are serialized in the order specified
218− 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
219 (opOut, fattr') -> (out `mappend` opOut, fattr')
249 (opOut, fattr') -> (out `mappend` opOut, fattr')
220 )
250 )
221 (start, initialAttr)
251 (start, initialAttr)
222 spanOps
252 spanOps
223
253
224−writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
254+writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
225−writeSpanOp dc (TextSpan attr _ _ str) fattr =
255+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
226 let attr' = limitAttrForDisplay (contextDevice dc) attr
256 let attr' = limitAttrForDisplay (contextDevice dc) attr
227 fattr' = fixDisplayAttr fattr attr'
257 fattr' = fixDisplayAttr fattr attr'
228 diffs = displayAttrDiffs fattr fattr'
258 diffs = displayAttrDiffs fattr fattr'
229− out = writeSetAttr dc fattr attr' diffs
259+ out = writeSetAttr dc urlsEnabled fattr attr' diffs
230 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
260 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
231 in (out, fattr')
261 in (out, fattr')
232−writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
262+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
233−writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
263+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
234
264
235-- | The cursor position is given in X,Y character offsets. Due to
265-- | The cursor position is given in X,Y character offsets. Due to
236-- multi-column characters this needs to be translated to column, row
266-- multi-column characters this needs to be translated to column, row
@@ -279,17 +309,23 @@ limitAttrForDisplay t attr
279 where
309 where
280 clampColor Default = Default
310 clampColor Default = Default
281 clampColor KeepCurrent = KeepCurrent
311 clampColor KeepCurrent = KeepCurrent
282− clampColor (SetTo c) = clampColor' c
312+ clampColor (SetTo c) = clampColor' (outputColorMode t) c
313+
283− clampColor' (ISOColor v)
314+ clampColor' NoColor _ = Default
284− | contextColorCount t < 8 = Default
315+
316+ clampColor' ColorMode8 (ISOColor v)
285− | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
317+ | v >= 8 = SetTo $ ISOColor (v - 8)
286− | otherwise = SetTo $ ISOColor v
318+ | otherwise = SetTo $ ISOColor v
287− clampColor' (Color240 v)
319+ clampColor' ColorMode8 _ = Default
288− -- Should we choose closest ISO color?
320+
289− | contextColorCount t < 8 = Default
321+ clampColor' ColorMode16 c@(ISOColor _) = SetTo c
290− | contextColorCount t < 16 = Default
322+ clampColor' ColorMode16 _ = Default
291− | 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
292− | otherwise
327+ | otherwise = Default
293− = let p :: Double = fromIntegral v / 240.0
328+ clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
294− v' = floor $ p * (fromIntegral $ contextColorCount t)
329+ clampColor' colorMode (color240 r g b)
295− in SetTo $ Color240 v'
330+
331+ clampColor' FullColor c = SetTo c
src/Graphics/Vty/Output/Mock.hs+10−6
@@ -2,8 +2,8 @@
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4-- | This provides a mock terminal implementation that is nice for
4-- | This provides a mock terminal implementation that is nice for
5−-- testing. This transforms the output operations to visible characters.
5+-- testing. This transforms the output operations to visible characters
6−-- Which is nice for some tests.
6+-- which is useful for testing.
7module Graphics.Vty.Output.Mock
7module Graphics.Vty.Output.Mock
8 ( MockData
8 ( MockData
9 , mockTerminal
9 , mockTerminal
@@ -11,6 +11,7 @@ module Graphics.Vty.Output.Mock
11where
11where
12
12
13import Graphics.Vty.Image (DisplayRegion)
13import Graphics.Vty.Image (DisplayRegion)
14+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
14import Graphics.Vty.Output.Interface
15import Graphics.Vty.Output.Interface
15
16
16import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
@@ -30,7 +31,7 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString)
30-- without considering terminal specific issues.
31-- without considering terminal specific issues.
31--
32--
32-- The mock implementation is useful in manually determining if the
33-- The mock implementation is useful in manually determining if the
33−-- sequence of terminal operations matches the expected sequence. So
34+-- sequence of terminal operations matches the expected sequence. The
34-- requirement of the produced representation is simplicity in parsing
35-- requirement of the produced representation is simplicity in parsing
35-- the text representation and determining how the picture was mapped to
36-- the text representation and determining how the picture was mapped to
36-- terminal operations.
37-- terminal operations.
@@ -48,16 +49,19 @@ mockTerminal r = liftIO $ do
48 , releaseDisplay = return ()
49 , releaseDisplay = return ()
49 , ringTerminalBell = return ()
50 , ringTerminalBell = return ()
50 , supportsBell = return False
51 , supportsBell = return False
52+ , supportsItalics = return False
53+ , supportsStrikethrough = return False
54+ , setDisplayBounds = const $ return ()
51 , displayBounds = return r
55 , displayBounds = return r
52 , outputByteBuffer = \bytes -> do
56 , outputByteBuffer = \bytes -> do
53 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
57 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
54 writeIORef outRef $ UTF8.fromRep bytes
58 writeIORef outRef $ UTF8.fromRep bytes
55− , contextColorCount = 16
56 , supportsCursorVisibility = True
59 , supportsCursorVisibility = True
57 , supportsMode = const False
60 , supportsMode = const False
58 , setMode = const $ const $ return ()
61 , setMode = const $ const $ return ()
59 , getModeStatus = const $ return False
62 , getModeStatus = const $ return False
60 , assumedStateRef = newAssumedStateRef
63 , assumedStateRef = newAssumedStateRef
64+ , outputColorMode = ColorMode16
61 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
65 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
62 { contextRegion = rActual
66 { contextRegion = rActual
63 , contextDevice = tActual
67 , contextDevice = tActual
@@ -72,10 +76,10 @@ mockTerminal r = liftIO $ do
72 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
76 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
73 -- An attr change is always visualized as the single
77 -- An attr change is always visualized as the single
74 -- character 'A'
78 -- character 'A'
75− , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
79+ , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
76 -- default attr is always visualized as the single
80 -- default attr is always visualized as the single
77 -- character 'D'
81 -- character 'D'
78− , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'
82+ , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
79 -- row end is always visualized as the single character
83 -- row end is always visualized as the single character
80 -- 'E'
84 -- 'E'
81 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
85 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
src/Graphics/Vty/Output/TerminfoBased.hs+199−74
@@ -1,21 +1,21 @@
1−{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
3{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# CFILES gwinsz.c #-}
5{-# CFILES gwinsz.c #-}
5
6
6−-- | Terminfo based terminal handling.
7+-- | Terminfo-based terminal output driver.
7−--
8−-- The color handling assumes tektronix like. No HP support provided. If
9−-- the terminal is not one I have easy access to then color support is
10−-- entirely based of the docs. Probably with some assumptions mixed in.
11--
8--
12-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
13module Graphics.Vty.Output.TerminfoBased
10module Graphics.Vty.Output.TerminfoBased
14 ( reserveTerminal
11 ( reserveTerminal
12+ , setWindowSize
15 )
13 )
16where
14where
17
15
18import Control.Monad (when)
16import Control.Monad (when)
17+import Data.Bits (shiftL, (.&.))
18+import qualified Data.ByteString as BS
19import Data.ByteString.Internal (toForeignPtr)
19import Data.ByteString.Internal (toForeignPtr)
20import Data.Terminfo.Parse
20import Data.Terminfo.Parse
21import Data.Terminfo.Eval
21import Data.Terminfo.Eval
@@ -25,15 +25,16 @@ import Graphics.Vty.Image (DisplayRegion)
25import Graphics.Vty.DisplayAttributes
25import Graphics.Vty.DisplayAttributes
26import Graphics.Vty.Output.Interface
26import Graphics.Vty.Output.Interface
27
27
28−import Blaze.ByteString.Builder (Write, writeToByteString)
28+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
29−
30−import Control.Monad.Trans
31
29
32−import Data.Bits ((.&.))
33import Data.IORef
30import Data.IORef
34import Data.Maybe (isJust, isNothing, fromJust)
31import Data.Maybe (isJust, isNothing, fromJust)
35import Data.Word
32import Data.Word
36
33
34+#if !MIN_VERSION_base(4,8,0)
35+import Data.Foldable (foldMap)
36+#endif
37+
37import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.Ptr (Ptr, plusPtr)
40import Foreign.Ptr (Ptr, plusPtr)
@@ -48,7 +49,6 @@ data TerminfoCaps = TerminfoCaps
48 , cup :: CapExpression
49 , cup :: CapExpression
49 , cnorm :: Maybe CapExpression
50 , cnorm :: Maybe CapExpression
50 , civis :: Maybe CapExpression
51 , civis :: Maybe CapExpression
51− , supportsNoColors :: Bool
52 , useAltColorMap :: Bool
52 , useAltColorMap :: Bool
53 , setForeColor :: CapExpression
53 , setForeColor :: CapExpression
54 , setBackColor :: CapExpression
54 , setBackColor :: CapExpression
@@ -63,6 +63,10 @@ data DisplayAttrCaps = DisplayAttrCaps
63 { setAttrStates :: Maybe CapExpression
63 { setAttrStates :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
66+ , enterItalic :: Maybe CapExpression
67+ , exitItalic :: Maybe CapExpression
68+ , enterStrikethrough :: Maybe CapExpression
69+ , exitStrikethrough :: Maybe CapExpression
66 , enterUnderline :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
67 , exitUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
68 , enterReverseVideo :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
@@ -89,70 +93,95 @@ sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
89sendCapToTerminal t cap capParams = do
93sendCapToTerminal t cap capParams = do
90 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
94 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
91
95
96+-- | Constructs an output driver that uses terminfo for all control
92−-- | Uses terminfo for all control codes. While this should provide the
97+-- codes. While this should provide the most compatible terminal,
93−-- most compatible terminal terminfo does not support some features that
98+-- terminfo does not support some features that would increase
94−-- would increase efficiency and improve compatibility:
99+-- efficiency and improve compatibility:
95--
100--
96−-- * determine the character encoding supported by the terminal. Should
101+-- * determining the character encoding supported by the terminal.
97−-- this be taken from the LANG environment variable?
102+-- Should this be taken from the LANG environment variable?
98--
103--
99−-- * Provide independent string capabilities for all display attributes.
104+-- * Providing independent string capabilities for all display
105+-- attributes.
100−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
106+reserveTerminal :: String -> Fd -> ColorMode -> IO Output
101−reserveTerminal termName outFd = liftIO $ do
107+reserveTerminal termName outFd colorMode = do
102 ti <- Terminfo.setupTerm termName
108 ti <- Terminfo.setupTerm termName
103 -- assumes set foreground always implies set background exists.
109 -- assumes set foreground always implies set background exists.
104 -- if set foreground is not set then all color changing style
110 -- if set foreground is not set then all color changing style
105 -- attributes are filtered.
111 -- attributes are filtered.
106 msetaf <- probeCap ti "setaf"
112 msetaf <- probeCap ti "setaf"
107 msetf <- probeCap ti "setf"
113 msetf <- probeCap ti "setf"
108− let (noColors, useAlt, setForeCap)
114+ let (useAlt, setForeCap)
109 = case msetaf of
115 = case msetaf of
110− Just setaf -> (False, False, setaf)
116+ Just setaf -> (False, setaf)
111 Nothing -> case msetf of
117 Nothing -> case msetf of
112− Just setf -> (False, True, setf)
118+ Just setf -> (True, setf)
113− Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
119+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
114 msetab <- probeCap ti "setab"
120 msetab <- probeCap ti "setab"
115 msetb <- probeCap ti "setb"
121 msetb <- probeCap ti "setb"
116− let set_back_cap
122+ let setBackCap
117 = case msetab of
123 = case msetab of
124+ Just setab -> setab
118 Nothing -> case msetb of
125 Nothing -> case msetb of
119 Just setb -> setb
126 Just setb -> setb
120 Nothing -> error $ "no back color support for terminal " ++ termName
127 Nothing -> error $ "no back color support for terminal " ++ termName
121− 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+
122 terminfoCaps <- pure TerminfoCaps
147 terminfoCaps <- pure TerminfoCaps
123 <*> probeCap ti "smcup"
148 <*> probeCap ti "smcup"
124 <*> probeCap ti "rmcup"
149 <*> probeCap ti "rmcup"
125 <*> requireCap ti "cup"
150 <*> requireCap ti "cup"
126 <*> probeCap ti "cnorm"
151 <*> probeCap ti "cnorm"
127 <*> probeCap ti "civis"
152 <*> probeCap ti "civis"
128− <*> pure noColors
129 <*> pure useAlt
153 <*> pure useAlt
130 <*> pure setForeCap
154 <*> pure setForeCap
131− <*> pure set_back_cap
155+ <*> pure setBackCap
132 <*> requireCap ti "sgr0"
156 <*> requireCap ti "sgr0"
133 <*> requireCap ti "clear"
157 <*> requireCap ti "clear"
134 <*> requireCap ti "el"
158 <*> requireCap ti "el"
135 <*> currentDisplayAttrCaps ti
159 <*> currentDisplayAttrCaps ti
136 <*> probeCap ti "bel"
160 <*> probeCap ti "bel"
137− newAssumedStateRef <- newIORef initialAssumedState
138 let t = Output
161 let t = Output
139 { terminalID = termName
162 { terminalID = termName
140− , releaseTerminal = liftIO $ do
163+ , releaseTerminal = do
141 sendCap setDefaultAttr []
164 sendCap setDefaultAttr []
142 maybeSendCap cnorm []
165 maybeSendCap cnorm []
143 , 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))
144− , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
171+ , ringTerminalBell = maybeSendCap ringBellAudio []
145− , reserveDisplay = liftIO $ do
172+ , reserveDisplay = do
146 -- If there is no support for smcup: Clear the screen
173 -- If there is no support for smcup: Clear the screen
147 -- and then move the mouse to the home position to
174 -- and then move the mouse to the home position to
148 -- approximate the behavior.
175 -- approximate the behavior.
149 maybeSendCap smcup []
176 maybeSendCap smcup []
150 sendCap clearScreen []
177 sendCap clearScreen []
151− , releaseDisplay = liftIO $ do
178+ , releaseDisplay = do
152 maybeSendCap rmcup []
179 maybeSendCap rmcup []
153 maybeSendCap cnorm []
180 maybeSendCap cnorm []
181+ , setDisplayBounds = \(w, h) ->
182+ setWindowSize outFd (w, h)
154 , displayBounds = do
183 , displayBounds = do
155− rawSize <- liftIO $ getWindowSize outFd
184+ rawSize <- getWindowSize outFd
156 case rawSize of
185 case rawSize of
157 (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
158 | otherwise -> return (w,h)
187 | otherwise -> return (w,h)
@@ -163,51 +192,48 @@ reserveTerminal termName outFd = liftIO $ do
163 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
164 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
165 ++ " Please report this bug to vty project."
194 ++ " Please report this bug to vty project."
166− , contextColorCount
167− = case supportsNoColors terminfoCaps of
168− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
169− Nothing -> 8
170− Just v -> toEnum v
171− True -> 1
172 , supportsCursorVisibility = isJust $ civis terminfoCaps
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
173− , supportsMode = const False
196+ , supportsMode = terminfoModeSupported
174− , setMode = const $ const $ return ()
197+ , setMode = terminfoSetMode
175− , getModeStatus = const $ return False
198+ , getModeStatus = terminfoModeStatus
176 , assumedStateRef = newAssumedStateRef
199 , assumedStateRef = newAssumedStateRef
200+ , outputColorMode = colorMode
177 -- I think fix would help assure tActual is the only
201 -- I think fix would help assure tActual is the only
178 -- reference. I was having issues tho.
202 -- reference. I was having issues tho.
179− , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
203+ , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
180 }
204 }
181 sendCap s = sendCapToTerminal t (s terminfoCaps)
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
182 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
183 return t
207 return t
184
208
185−requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
209+requireCap :: Terminfo.Terminal -> String -> IO CapExpression
186requireCap ti capName
210requireCap ti capName
187 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
188 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
189 Just capStr -> parseCap capStr
213 Just capStr -> parseCap capStr
190
214
191−probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
215+probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
192probeCap ti capName
216probeCap ti capName
193 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
194 Nothing -> return Nothing
218 Nothing -> return Nothing
195 Just capStr -> Just <$> parseCap capStr
219 Just capStr -> Just <$> parseCap capStr
196
220
197−parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
221+parseCap :: String -> IO CapExpression
198parseCap capStr = do
222parseCap capStr = do
199 case parseCapExpression capStr of
223 case parseCapExpression capStr of
200 Left e -> fail $ show e
224 Left e -> fail $ show e
201 Right cap -> return cap
225 Right cap -> return cap
202
226
203−currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
227+currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
204− => Terminfo.Terminal
205− -> m DisplayAttrCaps
206currentDisplayAttrCaps ti
228currentDisplayAttrCaps ti
207 = pure DisplayAttrCaps
229 = pure DisplayAttrCaps
208 <*> probeCap ti "sgr"
230 <*> probeCap ti "sgr"
209 <*> probeCap ti "smso"
231 <*> probeCap ti "smso"
210 <*> probeCap ti "rmso"
232 <*> probeCap ti "rmso"
233+ <*> probeCap ti "sitm"
234+ <*> probeCap ti "ritm"
235+ <*> probeCap ti "smxx"
236+ <*> probeCap ti "rmxx"
211 <*> probeCap ti "smul"
237 <*> probeCap ti "smul"
212 <*> probeCap ti "rmul"
238 <*> probeCap ti "rmul"
213 <*> probeCap ti "rev"
239 <*> probeCap ti "rev"
@@ -221,6 +247,13 @@ getWindowSize fd = do
221 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
222 return (fromIntegral b, fromIntegral a)
248 return (fromIntegral b, fromIntegral a)
223
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+
224terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
225terminfoDisplayContext tActual terminfoCaps r = return dc
258terminfoDisplayContext tActual terminfoCaps r = return dc
226 where dc = DisplayContext
259 where dc = DisplayContext
@@ -234,15 +267,35 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
234 Nothing -> error "this terminal does not support hide cursor"
267 Nothing -> error "this terminal does not support hide cursor"
235 Just c -> writeCapExpr c []
268 Just c -> writeCapExpr c []
236 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270+ , writeDefaultAttr = \urlsEnabled ->
237− , 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+ )
238 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
239 , inlineHack = return ()
278 , inlineHack = return ()
240 }
279 }
241
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+
242-- | 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.
243--
296--
244-- If the terminal supports the sgr capability (which sets the on/off
297-- If the terminal supports the sgr capability (which sets the on/off
245−-- state of each style directly ; and, for no good reason, resets the
298+-- state of each style directly; and, for no good reason, resets the
246-- colors to the default) this procedure is used:
299-- colors to the default) this procedure is used:
247--
300--
248-- 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.
@@ -275,30 +328,30 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
275--
328--
276-- Note that this optimizes for fewer state changes followed by fewer
329-- Note that this optimizes for fewer state changes followed by fewer
277-- bytes.
330-- bytes.
278−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
331+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
279−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
332+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
280− case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
333+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
281 -- The only way to reset either color, portably, to the default
334 -- The only way to reset either color, portably, to the default
282 -- is to use either the set state capability or the set default
335 -- is to use either the set state capability or the set default
283 -- capability.
336 -- capability.
284− True -> do
337+ True -> do
285 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
286− (fixedStyle attr )
339+ (fixedStyle attr)
287 (styleToApplySeq $ fixedStyle attr) of
340 (styleToApplySeq $ fixedStyle attr) of
288 -- only way to reset a color to the defaults
341 -- only way to reset a color to the defaults
289− EnterExitSeq caps -> writeDefaultAttr dc
342+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
290 `mappend`
343 `mappend`
291 foldMap (\cap -> writeCapExpr cap []) caps
344 foldMap (\cap -> writeCapExpr cap []) caps
292 `mappend`
345 `mappend`
293 setColors
346 setColors
294 -- implicitly resets the colors to the defaults
347 -- implicitly resets the colors to the defaults
295 SetState state -> writeCapExpr (fromJust $ setAttrStates
348 SetState state -> writeCapExpr (fromJust $ setAttrStates
296− $ displayAttrCaps
349+ $ displayAttrCaps terminfoCaps
297− $ terminfoCaps
298 )
350 )
299 (sgrArgsForState state)
351 (sgrArgsForState state)
300− `mappend`
352+ `mappend` setItalics
353+ `mappend` setStrikethrough
301− setColors
354+ `mappend` setColors
302 -- Otherwise the display colors are not changing or changing
355 -- Otherwise the display colors are not changing or changing
303 -- between two non-default points.
356 -- between two non-default points.
304 False -> do
357 False -> do
@@ -316,45 +369,99 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
316 -- 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]
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"
349
452
350-- | The color table used by a terminal is a 16 color set followed by a
453-- | The color table used by a terminal is a 16 color set followed by a
351-- 240 color set that might not 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
456+-- This takes a Color which clearly identifies which palette to use and
354−-- computes the index 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,6 +478,10 @@ 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
486{- | The sequence of terminfo caps to apply a given style are determined
376 - according to these rules.
487 - according to these rules.
@@ -397,6 +508,8 @@ data DisplayAttrSeq
397data DisplayAttrState = DisplayAttrState
508data DisplayAttrState = DisplayAttrState
398 { applyStandout :: Bool
509 { applyStandout :: Bool
399 , applyUnderline :: Bool
510 , applyUnderline :: Bool
511+ , applyItalic :: Bool
512+ , applyStrikethrough :: Bool
400 , applyReverseVideo :: Bool
513 , applyReverseVideo :: Bool
401 , applyBlink :: Bool
514 , applyBlink :: Bool
402 , applyDim :: Bool
515 , applyDim :: Bool
@@ -433,6 +546,10 @@ reqDisplayCapSeqFor caps s diffs
433 -- set state cap then just use the set state cap.
546 -- set state cap then just use the set state cap.
434 ( True, True ) -> SetState $ stateForStyle s
547 ( True, True ) -> SetState $ stateForStyle s
435 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
436 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
437 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
438 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -445,6 +562,10 @@ reqDisplayCapSeqFor caps s diffs
445 noEnterExitCap RemoveDim = True
562 noEnterExitCap RemoveDim = True
446 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
447 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
448 enterExitCap ApplyStandout = fromJust $ enterStandout caps
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
449 enterExitCap RemoveStandout = fromJust $ exitStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
450 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -458,6 +579,8 @@ stateForStyle :: Style -> DisplayAttrState
458stateForStyle s = DisplayAttrState
579stateForStyle s = DisplayAttrState
459 { applyStandout = isStyleSet standout
580 { applyStandout = isStyleSet standout
460 , applyUnderline = isStyleSet underline
581 , applyUnderline = isStyleSet underline
582+ , applyItalic = isStyleSet italic
583+ , applyStrikethrough = isStyleSet strikethrough
461 , applyReverseVideo = isStyleSet reverseVideo
584 , applyReverseVideo = isStyleSet reverseVideo
462 , applyBlink = isStyleSet blink
585 , applyBlink = isStyleSet blink
463 , applyDim = isStyleSet dim
586 , applyDim = isStyleSet dim
@@ -469,10 +592,12 @@ styleToApplySeq :: Style -> [StyleStateChange]
469styleToApplySeq s = concat
592styleToApplySeq s = concat
470 [ applyIfRequired ApplyStandout standout
593 [ applyIfRequired ApplyStandout standout
471 , applyIfRequired ApplyUnderline underline
594 , applyIfRequired ApplyUnderline underline
595+ , applyIfRequired ApplyItalic italic
596+ , applyIfRequired ApplyStrikethrough strikethrough
472 , applyIfRequired ApplyReverseVideo reverseVideo
597 , applyIfRequired ApplyReverseVideo reverseVideo
473 , applyIfRequired ApplyBlink blink
598 , applyIfRequired ApplyBlink blink
474 , applyIfRequired ApplyDim dim
599 , applyIfRequired ApplyDim dim
475− , applyIfRequired ApplyBlink bold
600+ , applyIfRequired ApplyBold bold
476 ]
601 ]
477 where
602 where
478 applyIfRequired op flag
603 applyIfRequired op flag
src/Graphics/Vty/Output/XTermColor.hs+45−19
@@ -1,4 +1,7 @@
1+{-# Language CPP #-}
1-- 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.
2module Graphics.Vty.Output.XTermColor
5module Graphics.Vty.Output.XTermColor
3 ( reserveTerminal
6 ( reserveTerminal
4 )
7 )
@@ -6,26 +9,42 @@ where
6
9
7import Graphics.Vty.Output.Interface
10import Graphics.Vty.Output.Interface
8import Graphics.Vty.Input.Mouse
11import Graphics.Vty.Input.Mouse
12+import Graphics.Vty.Input.Focus
13+import Graphics.Vty.Attributes.Color (ColorMode)
9import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
10
15
11import Blaze.ByteString.Builder (writeToByteString)
16import Blaze.ByteString.Builder (writeToByteString)
12import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
13
18
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+import Foreign.Ptr (castPtr)
22+
14import Control.Monad (void, when)
23import Control.Monad (void, when)
15import Control.Monad.Trans
24import Control.Monad.Trans
25+import Data.Char (toLower)
16import Data.IORef
26import Data.IORef
17
27
18−import System.Posix.IO (fdWrite)
28+import System.Posix.IO (fdWriteBuf)
19−import System.Posix.Types (Fd)
29+import System.Posix.Types (ByteCount, Fd)
20import System.Posix.Env (getEnv)
30import System.Posix.Env (getEnv)
21
31
22import Data.List (isInfixOf)
32import Data.List (isInfixOf)
23import Data.Maybe (catMaybes)
33import Data.Maybe (catMaybes)
34+
35+#if !MIN_VERSION_base(4,11,0)
24import Data.Monoid ((<>))
36import Data.Monoid ((<>))
37+#endif
25
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)
44+
26−-- | Initialize the display to UTF-8.
45+-- | Construct an Xterm output driver. Initialize the display to UTF-8.
27−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
46+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
28−reserveTerminal variant outFd = liftIO $ do
47+reserveTerminal variant outFd colorMode = liftIO $ do
29 let flushedPut = void . fdWrite outFd
48 let flushedPut = void . fdWrite outFd
30 -- If the terminal variant is xterm-color use xterm instead since,
49 -- If the terminal variant is xterm-color use xterm instead since,
31 -- more often than not, xterm-color is broken.
50 -- more often than not, xterm-color is broken.
@@ -33,15 +52,21 @@ reserveTerminal variant outFd = liftIO $ do
33
52
34 utf8a <- utf8Active
53 utf8a <- utf8Active
35 when (not utf8a) $ flushedPut setUtf8CharSet
54 when (not utf8a) $ flushedPut setUtf8CharSet
36− t <- TerminfoBased.reserveTerminal variant' outFd
55+ t <- TerminfoBased.reserveTerminal variant' outFd colorMode
37
56
38 mouseModeStatus <- newIORef False
57 mouseModeStatus <- newIORef False
58+ focusModeStatus <- newIORef False
39 pasteModeStatus <- newIORef False
59 pasteModeStatus <- newIORef False
40
60
41 let xtermSetMode t' m newStatus = do
61 let xtermSetMode t' m newStatus = do
42 curStatus <- getModeStatus t' m
62 curStatus <- getModeStatus t' m
43 when (newStatus /= curStatus) $
63 when (newStatus /= curStatus) $
44 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
45 Mouse -> liftIO $ do
70 Mouse -> liftIO $ do
46 case newStatus of
71 case newStatus of
47 True -> flushedPut requestMouseEvents
72 True -> flushedPut requestMouseEvents
@@ -52,9 +77,12 @@ reserveTerminal variant outFd = liftIO $ do
52 True -> flushedPut enableBracketedPastes
77 True -> flushedPut enableBracketedPastes
53 False -> flushedPut disableBracketedPastes
78 False -> flushedPut disableBracketedPastes
54 writeIORef pasteModeStatus newStatus
79 writeIORef pasteModeStatus newStatus
80+ Hyperlink -> setMode t Hyperlink newStatus
55
81
56 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
83+ xtermGetMode Focus = liftIO $ readIORef focusModeStatus
57 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85+ xtermGetMode Hyperlink = getModeStatus t Hyperlink
58
86
59 let t' = t
87 let t' = t
60 { terminalID = terminalID t ++ " (xterm-color)"
88 { terminalID = terminalID t ++ " (xterm-color)"
@@ -62,6 +90,7 @@ reserveTerminal variant outFd = liftIO $ do
62 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
90 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
63 setMode t' BracketedPaste False
91 setMode t' BracketedPaste False
64 setMode t' Mouse False
92 setMode t' Mouse False
93+ setMode t' Focus False
65 releaseTerminal t
94 releaseTerminal t
66 , mkDisplayContext = \tActual r -> do
95 , mkDisplayContext = \tActual r -> do
67 dc <- mkDisplayContext t tActual r
96 dc <- mkDisplayContext t tActual r
@@ -75,30 +104,27 @@ reserveTerminal variant outFd = liftIO $ do
75utf8Active :: IO Bool
104utf8Active :: IO Bool
76utf8Active = do
105utf8Active = do
77 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
78− results <- catMaybes <$> mapM getEnv vars
107+ results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars
79− let matches = filter ("UTF8" `isInfixOf`) results <>
108+ let matches = filter ("utf8" `isInfixOf`) results <>
80− filter ("UTF-8" `isInfixOf`) results
109+ filter ("utf-8" `isInfixOf`) results
81 return $ not $ null matches
110 return $ not $ null matches
82
111
83-- | Enable bracketed paste mode:
112-- | Enable bracketed paste mode:
84-- http://cirw.in/blog/bracketed-paste
113-- http://cirw.in/blog/bracketed-paste
85−enableBracketedPastes :: String
114+enableBracketedPastes :: ByteString
86−enableBracketedPastes = "\ESC[?2004h"
115+enableBracketedPastes = BS8.pack "\ESC[?2004h"
87
116
88-- | Disable bracketed paste mode:
117-- | Disable bracketed paste mode:
89−disableBracketedPastes :: String
118+disableBracketedPastes :: ByteString
90−disableBracketedPastes = "\ESC[?2004l"
119+disableBracketedPastes = BS8.pack "\ESC[?2004l"
91
120
92-- | These sequences set xterm based terminals to UTF-8 output.
121-- | These sequences set xterm based terminals to UTF-8 output.
93--
122--
94-- There is no known terminfo capability equivalent to this.
123-- There is no known terminfo capability equivalent to this.
95−setUtf8CharSet, setDefaultCharSet :: String
124+setUtf8CharSet, setDefaultCharSet :: ByteString
96−setUtf8CharSet = "\ESC%G"
125+setUtf8CharSet = BS8.pack "\ESC%G"
97−setDefaultCharSet = "\ESC%@"
126+setDefaultCharSet = BS8.pack "\ESC%@"
98
127
99−-- | I think xterm is broken: Reseting the background color as the first
100−-- bytes serialized on a new line does not effect the background color
101−-- xterm uses to clear the line. Which is used *after* the next newline.
102xtermInlineHack :: Output -> IO ()
128xtermInlineHack :: Output -> IO ()
103xtermInlineHack t = do
129xtermInlineHack t = do
104 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
src/Graphics/Vty/Picture.hs+50−38
@@ -1,8 +1,6 @@
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
2+-- 'Picture' data structure is representative of the final terminal
3−-- terminal view.
3+-- view.
4−--
5−-- A 'Picture' is a background paired with a layer of 'Image's.
6module Graphics.Vty.Picture
4module Graphics.Vty.Picture
7 ( Picture(..)
5 ( Picture(..)
8 , Cursor(..)
6 , Cursor(..)
@@ -21,16 +19,18 @@ import Graphics.Vty.Attributes
21
19
22import Control.DeepSeq
20import Control.DeepSeq
23
21
24−-- | The type of images to be displayed using 'update'.
22+-- | A Vty picture.
25--
23--
26−-- Can be constructed directly or using `picForImage`. Which provides
24+-- These can be constructed directly or using `picForImage`.
27−-- an initial instance with reasonable defaults for picCursor and
28−-- picBackground.
29data Picture = Picture
25data Picture = Picture
30 { picCursor :: Cursor
26 { picCursor :: Cursor
27+ -- ^ The picture's cursor.
31 , picLayers :: [Image]
28 , picLayers :: [Image]
29+ -- ^ The picture's image layers (top-most first).
32 , picBackground :: Background
30 , picBackground :: Background
33− }
31+ -- ^ The picture's background to be displayed in locations with no
32+ -- Image data.
33+ } deriving Eq
34
34
35instance Show Picture where
35instance Show Picture where
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -38,21 +38,21 @@ instance Show Picture where
38instance NFData Picture where
38instance NFData Picture where
39 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
39 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
40
40
41−-- | a picture with no cursor, background or image layers
41+-- | A picture with no cursor, background or image layers.
42emptyPicture :: Picture
42emptyPicture :: Picture
43emptyPicture = Picture NoCursor [] ClearBackground
43emptyPicture = Picture NoCursor [] ClearBackground
44
44
45−-- | The given 'Image' is added as the top layer of the 'Picture'
45+-- | Add an 'Image' as the top-most layer of a 'Picture'.
46addToTop :: Picture -> Image -> Picture
46addToTop :: Picture -> Image -> Picture
47addToTop p i = p {picLayers = i : picLayers p}
47addToTop p i = p {picLayers = i : picLayers p}
48
48
49−-- | The given 'Image' is added as the bottom layer of the 'Picture'
49+-- | Add an 'Image' as the bottom-most layer of a 'Picture'.
50addToBottom :: Picture -> Image -> Picture
50addToBottom :: Picture -> Image -> Picture
51addToBottom p i = p {picLayers = picLayers p ++ [i]}
51addToBottom p i = p {picLayers = picLayers p ++ [i]}
52
52
53−-- | Create a picture for display for the given image. The picture
53+-- | Create a picture from the given image. The picture will not have a
54−-- will not have a displayed cursor and no background pattern
54+-- displayed cursor and no background pattern (ClearBackground) will be
55−-- (ClearBackground) will be used.
55+-- used.
56picForImage :: Image -> Picture
56picForImage :: Image -> Picture
57picForImage i = Picture
57picForImage i = Picture
58 { picCursor = NoCursor
58 { picCursor = NoCursor
@@ -60,13 +60,10 @@ picForImage i = Picture
60 , picBackground = ClearBackground
60 , picBackground = ClearBackground
61 }
61 }
62
62
63−-- | Create a picture for display with the given layers. Ordered top to
63+-- | Create a picture with the given layers, top-most first.
64−-- bottom.
65--
64--
66-- The picture will not have a displayed cursor and no background
65-- The picture will not have a displayed cursor and no background
67−-- apttern (ClearBackgroun) will be used.
66+-- pattern (ClearBackgroun) will be used.
68−--
69−-- The first 'Image' is the top layer.
70picForLayers :: [Image] -> Picture
67picForLayers :: [Image] -> Picture
71picForLayers is = Picture
68picForLayers is = Picture
72 { picCursor = NoCursor
69 { picCursor = NoCursor
@@ -74,29 +71,40 @@ picForLayers is = Picture
74 , picBackground = ClearBackground
71 , picBackground = ClearBackground
75 }
72 }
76
73
77−-- | A picture can be configured either to not show the cursor or show
74+-- | A picture can be configured to hide the cursor or to show the
78−-- the cursor at the specified character position.
75+-- cursor at the specified character position.
79--
76--
80−-- There is not a 1 to 1 map from character positions to a row and
77+-- There is not a 1:1 map from character positions to a row and column
81−-- column on the screen due to characters that take more than 1 column.
78+-- on the screen due to characters that take more than 1 column.
82data Cursor =
79data Cursor =
83− -- | Hide the cursor
80+ -- | Hide the cursor
84− 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
85− -- | Show the cursor at the given logical column accounting for
90+ -- | Show the cursor at the given logical column accounting for
86− -- char width and row
91+ -- character width in the presence of multi-column characters.
87 | Cursor !Int !Int
92 | Cursor !Int !Int
88− -- | Show the cursor at the given absolute terminal column and row
93+ -- | Show the cursor at the given absolute terminal column and row
89 | AbsoluteCursor !Int !Int
94 | AbsoluteCursor !Int !Int
95+ deriving Eq
90
96
91instance NFData Cursor where
97instance NFData Cursor where
92 rnf c = c `seq` ()
98 rnf c = c `seq` ()
93
99
94−-- | A 'Picture' has a background pattern. The background is either
100+-- | A 'Picture' has a background pattern. The background is either:
101+--
95−-- ClearBackground. Which shows the layer below or is blank if the
102+-- * ClearBackground, which shows the layer below or is blank if the
103+-- bottom layer
96−-- bottom layer. Or the background pattern is a character and a display
104+-- * A character and a display attribute
105+--
97−-- attribute. If the display attribute used previously should be used
106+-- If the display attribute used previously should be used for a
98−-- for a background fill then use `currentAttr` for the background
107+-- background fill then use `currentAttr` for the background attribute.
99−-- attribute.
100data Background
108data Background
101 = Background
109 = Background
102 { backgroundChar :: Char
110 { backgroundChar :: Char
@@ -108,12 +116,16 @@ data Background
108 --
116 --
109 -- * End of line if there are no remaining non-skip ops.
117 -- * End of line if there are no remaining non-skip ops.
110 | ClearBackground
118 | ClearBackground
119+ deriving Eq
111
120
112instance NFData Background where
121instance NFData Background where
113 rnf (Background c a) = c `seq` a `seq` ()
122 rnf (Background c a) = c `seq` a `seq` ()
114 rnf ClearBackground = ()
123 rnf ClearBackground = ()
115
124
125+-- | Return the top-most 'Image' layer for a picture. This is unsafe for
126+-- 'Picture's without at least one layer.
127+--
116−-- | Compatibility with applications that do not use more than a single
128+-- This is provided for compatibility with applications that do not use
117−-- layer.
129+-- more than a single layer.
118picImage :: Picture -> Image
130picImage :: Picture -> Image
119picImage = head . picLayers
131picImage = head . picLayers
src/Graphics/Vty/PictureToSpans.hs+11−17
@@ -72,7 +72,7 @@ displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
72-- | Returns the DisplayOps for an image rendered to a window the size
72-- | Returns the DisplayOps for an image rendered to a window the size
73-- of the image.
73-- of the image.
74--
74--
75−-- largerly used only for debugging.
75+-- largely used only for debugging.
76displayOpsForImage :: Image -> DisplayOps
76displayOpsForImage :: Image -> DisplayOps
77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
78
78
@@ -81,7 +81,7 @@ combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
81combinedOpsForLayers pic r
81combinedOpsForLayers pic r
82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
83 | otherwise = do
83 | otherwise = do
84− layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)
84+ layerOps <- mapM (`buildSpans` r) (picLayers pic)
85 case layerOps of
85 case layerOps of
86 [] -> fail "empty picture"
86 [] -> fail "empty picture"
87 [ops] -> substituteSkips (picBackground pic) ops
87 [ops] -> substituteSkips (picBackground pic) ops
@@ -136,8 +136,8 @@ mergeUnder upper lower = do
136 return upper
136 return upper
137
137
138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
139−mergeRowUnder upperRowOps lowerRowOps =
139+mergeRowUnder upperRowOps =
140− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps
140+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)
141 where
141 where
142 -- H: it will never be the case that we are out of upper ops
142 -- H: it will never be the case that we are out of upper ops
143 -- before lower ops.
143 -- before lower ops.
@@ -298,11 +298,11 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
298 state <- get
298 state <- get
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
300 case state^.skip of
300 case state^.skip of
301− s | s > size -> put $ state & skip -~ size
301+ s | s > size -> put $ state & skip %~ subtract size
302 | s == 0 -> if state^.remaining > i0Dim
302 | s == 0 -> if state^.remaining > i0Dim
303 then do
303 then do
304 addMaybeClipped i0
304 addMaybeClipped i0
305− put $ state & offset +~ i0Dim & remaining -~ i0Dim
305+ put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim
306 addMaybeClipped i1
306 addMaybeClipped i1
307 else addMaybeClipped i0
307 else addMaybeClipped i0
308 | s < i0Dim ->
308 | s < i0Dim ->
@@ -311,10 +311,10 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
311 then addMaybeClipped i0
311 then addMaybeClipped i0
312 else do
312 else do
313 addMaybeClipped i0
313 addMaybeClipped i0
314− put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0
314+ put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0
315 addMaybeClipped i1
315 addMaybeClipped i1
316 | s >= i0Dim -> do
316 | s >= i0Dim -> do
317− put $ state & skip -~ i0Dim
317+ put $ state & skip %~ subtract i0Dim
318 addMaybeClipped i1
318 addMaybeClipped i1
319 _ -> fail $ name ++ " has unhandled skip class"
319 _ -> fail $ name ++ " has unhandled skip class"
320
320
@@ -323,14 +323,14 @@ addUnclippedText a txt = do
323 let op = TextSpan a usedDisplayColumns
323 let op = TextSpan a usedDisplayColumns
324 (fromIntegral $ TL.length txt)
324 (fromIntegral $ TL.length txt)
325 txt
325 txt
326− usedDisplayColumns = wcswidth $ TL.unpack txt
326+ usedDisplayColumns = wctlwidth txt
327 use rowOffset >>= snocOp op
327 use rowOffset >>= snocOp op
328
328
329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
330addRowCompletion displayRegion row = do
330addRowCompletion displayRegion row = do
331 allRowOps <- view mrowOps
331 allRowOps <- view mrowOps
332 rowOps <- lift $ lift $ MVector.read allRowOps row
332 rowOps <- lift $ lift $ MVector.read allRowOps row
333− let endX = spanOpsEffectedColumns rowOps
333+ let endX = spanOpsAffectedColumns rowOps
334 when (endX < regionWidth displayRegion) $ do
334 when (endX < regionWidth displayRegion) $ do
335 let ow = regionWidth displayRegion - endX
335 let ow = regionWidth displayRegion - endX
336 snocOp (Skip ow) row
336 snocOp (Skip ow) row
@@ -343,12 +343,6 @@ snocOp !op !row = do
343 lift $ lift $ do
343 lift $ lift $ do
344 ops <- MVector.read theMrowOps row
344 ops <- MVector.read theMrowOps row
345 let ops' = Vector.snoc ops op
345 let ops' = Vector.snoc ops op
346− when (spanOpsEffectedColumns ops' > regionWidth theRegion)
346+ when (spanOpsAffectedColumns ops' > regionWidth theRegion)
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
348 MVector.write theMrowOps row ops'
348 MVector.write theMrowOps row ops'
349−
350−(-~) :: Num a => ASetter s t a a -> a -> s -> t
351−l -~ n = over l (subtract n)
352−
353−(+~) :: Num a => ASetter s t a a -> a -> s -> t
354−l +~ n = over l (n +)
src/Graphics/Vty/Span.hs+33−40
@@ -1,15 +1,12 @@
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
3-- | A picture is translated into a sequences of state changes and
6−-- character spans. State changes are currently limited to new attribute
7−-- values. The attribute is applied to all following spans. Including
4+-- character spans. The attribute is applied to all following spans,
8−-- 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
9−-- 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.
10--
7--
11-- A span op sequence will be defined for all rows and columns (and no
8-- A span op sequence will be defined for all rows and columns (and no
12−-- more) of the region provided with the picture to `spansForPic`.
9+-- more) of the region provided with the picture to 'spansForPic'.
13module Graphics.Vty.Span where
10module Graphics.Vty.Span where
14
11
15import Graphics.Vty.Attributes (Attr)
12import Graphics.Vty.Attributes (Attr)
@@ -20,42 +17,40 @@ import qualified Data.Text.Lazy as TL
20import Data.Vector (Vector)
17import Data.Vector (Vector)
21import qualified Data.Vector as Vector
18import qualified Data.Vector as Vector
22
19
23−-- | This represents an operation on the terminal. Either an attribute
20+-- | This represents an operation on the terminal: either an attribute
24-- change or the output of a text string.
21-- change or the output of a text string.
25data SpanOp =
22data SpanOp =
26− -- | a span of UTF-8 text occupies a specific number of screen space
23+ -- | A span of UTF-8 text occupies a specific number of screen space
27− -- columns. A single UTF character does not necessarially represent
24+ -- columns. A single UTF character does not necessarily represent 1
28− -- 1 colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output
25+ -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width
29− -- width in columns] [number of characters] [data]
26+ -- in columns] [number of characters] [data]
30 TextSpan
27 TextSpan
31 { textSpanAttr :: !Attr
28 { textSpanAttr :: !Attr
32 , textSpanOutputWidth :: !Int
29 , textSpanOutputWidth :: !Int
33 , textSpanCharWidth :: !Int
30 , textSpanCharWidth :: !Int
34 , textSpanText :: DisplayText
31 , textSpanText :: DisplayText
35 }
32 }
36− -- | Skips the given number of columns
33+ -- | Skips the given number of columns.
37− -- A skip is transparent.... maybe? I am not sure how attribute
38− -- changes interact.
39 | Skip !Int
34 | Skip !Int
40− -- | Marks the end of a row. specifies how many columns are
35+ -- | Marks the end of a row. Specifies how many columns are
41 -- remaining. These columns will not be explicitly overwritten with
36 -- remaining. These columns will not be explicitly overwritten with
42 -- the span ops. The terminal is require to assure the remaining
37 -- the span ops. The terminal is require to assure the remaining
43 -- columns are clear.
38 -- columns are clear.
44 | RowEnd !Int
39 | RowEnd !Int
45 deriving Eq
40 deriving Eq
46
41
47−-- | vector of span operations. executed in succession. This represents
42+-- | A vector of span operations executed in succession. This represents
48-- the operations required to render a row of the terminal. The
43-- the operations required to render a row of the terminal. The
49−-- operations in one row may effect subsequent rows.
44+-- operations in one row may affect subsequent rows. For example,
50−-- EG: Setting the foreground color in one row will effect all
45+-- setting the foreground color in one row will affect all subsequent
51−-- subsequent rows until the foreground color is changed.
46+-- rows until the foreground color is changed.
52type SpanOps = Vector SpanOp
47type SpanOps = Vector SpanOp
53
48
54dropOps :: Int -> SpanOps -> SpanOps
49dropOps :: Int -> SpanOps -> SpanOps
55dropOps w = snd . splitOpsAt w
50dropOps w = snd . splitOpsAt w
56
51
57splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
58−splitOpsAt inW inOps = splitOpsAt' inW inOps
53+splitOpsAt = splitOpsAt'
59 where
54 where
60 splitOpsAt' 0 ops = (Vector.empty, ops)
55 splitOpsAt' 0 ops = (Vector.empty, ops)
61 splitOpsAt' remainingColumns ops = case Vector.head ops of
56 splitOpsAt' remainingColumns ops = case Vector.head ops of
@@ -87,7 +82,7 @@ splitOpsAt inW inOps = splitOpsAt' inW inOps
87 )
82 )
88 RowEnd _ -> error "cannot split ops containing a row end"
83 RowEnd _ -> error "cannot split ops containing a row end"
89
84
90−-- | vector of span operation vectors for display. One per row of the
85+-- | A vector of span operation vectors for display, one per row of the
91-- output region.
86-- output region.
92type DisplayOps = Vector SpanOps
87type DisplayOps = Vector SpanOps
93
88
@@ -96,41 +91,39 @@ instance Show SpanOp where
96 show (Skip ow) = "Skip(" ++ show ow ++ ")"
91 show (Skip ow) = "Skip(" ++ show ow ++ ")"
97 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
92 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
98
93
99−-- | Number of columns the DisplayOps are defined for
94+-- | The number of columns the DisplayOps are defined for.
100--
95--
101−-- All spans are verified to define same number of columns. See:
96+-- All spans are verified to define same number of columns.
102−-- VerifySpanOps
103displayOpsColumns :: DisplayOps -> Int
97displayOpsColumns :: DisplayOps -> Int
104displayOpsColumns ops
98displayOpsColumns ops
105 | Vector.length ops == 0 = 0
99 | Vector.length ops == 0 = 0
106 | otherwise = Vector.length $ Vector.head ops
100 | otherwise = Vector.length $ Vector.head ops
107
101
108−-- | Number of rows the DisplayOps are defined for
102+-- | The number of rows the DisplayOps are defined for.
109displayOpsRows :: DisplayOps -> Int
103displayOpsRows :: DisplayOps -> Int
110−displayOpsRows ops = Vector.length ops
104+displayOpsRows = Vector.length
111
105
112−effectedRegion :: DisplayOps -> DisplayRegion
106+affectedRegion :: DisplayOps -> DisplayRegion
113−effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
107+affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
114
108
115−-- | The number of columns a SpanOps effects.
109+-- | The number of columns a SpanOps affects.
116−spanOpsEffectedColumns :: SpanOps -> Int
110+spanOpsAffectedColumns :: SpanOps -> Int
117−spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
111+spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps
118 where
112 where
119− spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
113+ spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w
120− spanOpsEffectedColumns' t (Skip w) = t + w
114+ spanOpsAffectedColumns' t (Skip w) = t + w
121− spanOpsEffectedColumns' t (RowEnd w) = t + w
115+ spanOpsAffectedColumns' t (RowEnd w) = t + w
122
116
123−-- | The width of a single SpanOp in columns
117+-- | The width of a single SpanOp in columns.
124spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
125spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
119spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
126spanOpHasWidth (Skip ow) = Just (ow,ow)
120spanOpHasWidth (Skip ow) = Just (ow,ow)
127spanOpHasWidth (RowEnd ow) = Just (ow,ow)
121spanOpHasWidth (RowEnd ow) = Just (ow,ow)
128
122
129−-- | returns the number of columns to the character at the given
123+-- | The number of columns to the character at the given position in the
130−-- position in the span op
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+2−4
@@ -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/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/Verify/Graphics/Vty/Output.hs−1
@@ -4,7 +4,6 @@ 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
test/Verify/Graphics/Vty/Span.hs+1−1
@@ -20,7 +20,7 @@ isAttrSpanOp TextSpan {} = True
20isAttrSpanOp _ = False
20isAttrSpanOp _ = False
21
21
22verifyAllSpansHaveWidth i spans w
22verifyAllSpansHaveWidth i spans w
23− = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)
23+ = let v = map (\s -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)
24 in case any ((== True) . fst) v of
24 in case any ((== True) . fst) v of
25 False -> succeeded
25 False -> succeeded
26 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+1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
1module VerifyEmptyImageProps where
2module VerifyEmptyImageProps where
2
3
3import Verify
4import Verify
test/VerifyEvalTerminfoCaps.hs+1
@@ -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)
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/VerifyOutput.hs+7−5
@@ -1,6 +1,7 @@
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
2-- This assumes appropriate definitions exist in the current environment
3-- for the terminals of interest.
3-- for the terminals of interest.
4+{-# LANGUAGE ScopedTypeVariables #-}
4module VerifyOutput where
5module VerifyOutput where
5
6
6import Verify
7import Verify
@@ -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,7 +35,11 @@ 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)
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+17−15
@@ -1,5 +1,6 @@
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.
4-- Generate some input bytes and delays between blocks of input bytes.
4-- Verify the events produced are as expected.
5-- Verify the events produced are as expected.
5module Main where
6module Main where
@@ -17,7 +18,6 @@ import Control.Exception
17import Lens.Micro ((^.))
18import Lens.Micro ((^.))
18import Control.Monad
19import Control.Monad
19
20
20−import Data.Default
21import Data.IORef
21import Data.IORef
22import Data.List (intersperse, reverse, nubBy)
22import Data.List (intersperse, reverse, nubBy)
23
23
@@ -113,11 +113,11 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
113 (writeFd, readFd) <- openPseudoTerminal
113 (writeFd, readFd) <- openPseudoTerminal
114 (setTermAttr,_) <- attributeControl readFd
114 (setTermAttr,_) <- attributeControl readFd
115 setTermAttr
115 setTermAttr
116− let testConfig = def { inputFd = Just readFd
116+ let testConfig = defaultConfig { inputFd = Just readFd
117− , termName = Just "dummy"
117+ , termName = Just "dummy"
118− , vmin = Just 1
118+ , vmin = Just 1
119− , vtime = Just 100
119+ , vtime = Just 100
120− }
120+ }
121 input <- initInput testConfig table
121 input <- initInput testConfig table
122 eventsRef <- newIORef []
122 eventsRef <- newIORef []
123 let writeWaitClose = do
123 let writeWaitClose = do
@@ -132,7 +132,9 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
132 readLoop 0 = return ()
132 readLoop 0 = return ()
133 readLoop n = do
133 readLoop n = do
134 e <- atomically $ readTChan $ input^.eventChannel
134 e <- atomically $ readTChan $ input^.eventChannel
135+ case e of
135− modifyIORef eventsRef ((:) e)
136+ InputEvent ev -> modifyIORef eventsRef ((:) ev)
137+ ResumeAfterSignal -> return ()
136 readLoop (n - 1)
138 readLoop (n - 1)
137 genEventsUsingIoActions maxDuration writeWaitClose readEvents
139 genEventsUsingIoActions maxDuration writeWaitClose readEvents
138 outEvents <- reverse <$> readIORef eventsRef
140 outEvents <- reverse <$> readIORef eventsRef
@@ -165,8 +167,8 @@ verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
165
167
166verifyCapsSynInputToEvent :: Property IO
168verifyCapsSynInputToEvent :: Property IO
167verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
169verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
168− forEachOf terminalsOfInterest $ \termName -> monadic $ do
170+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
169− term <- setupTerm termName
171+ term <- setupTerm terminalName
170 let table = capsClassifyMap term keysFromCapsTable
172 let table = capsClassifyMap term keysFromCapsTable
171 inputSeq = gen table
173 inputSeq = gen table
172 events = map snd inputSeq
174 events = map snd inputSeq
@@ -185,9 +187,9 @@ verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
185
187
186verifyFullSynInputToEvent :: Property IO
188verifyFullSynInputToEvent :: Property IO
187verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
189verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
188− forEachOf terminalsOfInterest $ \termName -> monadic $ do
190+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
189− term <- setupTerm termName
191+ term <- setupTerm terminalName
190− let table = classifyMapForTerm termName term
192+ let table = classifyMapForTerm terminalName term
191 inputSeq = gen table
193 inputSeq = gen table
192 events = map snd inputSeq
194 events = map snd inputSeq
193 keydowns = map (Bytes . fst) inputSeq
195 keydowns = map (Bytes . fst) inputSeq
@@ -196,9 +198,9 @@ verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
196
198
197verifyFullSynInputToEvent_2x :: Property IO
199verifyFullSynInputToEvent_2x :: Property IO
198verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
200verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
199− forEachOf terminalsOfInterest $ \termName -> monadic $ do
201+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
200− term <- setupTerm termName
202+ term <- setupTerm terminalName
201− let table = classifyMapForTerm termName term
203+ let table = classifyMapForTerm terminalName term
202 inputSeq = gen table
204 inputSeq = gen table
203 events = concatMap ((\s -> [s,s]) . snd) inputSeq
205 events = concatMap ((\s -> [s,s]) . snd) inputSeq
204 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
206 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
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−97
@@ -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
@@ -75,7 +80,6 @@ library
75 Graphics.Vty.Picture
80 Graphics.Vty.Picture
76 Graphics.Vty.Output
81 Graphics.Vty.Output
77 Graphics.Text.Width
82 Graphics.Text.Width
78− -- the modules below are only meant to be used by the tests.
79 Codec.Binary.UTF8.Debug
83 Codec.Binary.UTF8.Debug
80 Data.Terminfo.Parse
84 Data.Terminfo.Parse
81 Data.Terminfo.Eval
85 Data.Terminfo.Eval
@@ -87,6 +91,7 @@ library
87 Graphics.Vty.Input.Classify.Parse
91 Graphics.Vty.Input.Classify.Parse
88 Graphics.Vty.Input.Loop
92 Graphics.Vty.Input.Loop
89 Graphics.Vty.Input.Mouse
93 Graphics.Vty.Input.Mouse
94+ Graphics.Vty.Input.Focus
90 Graphics.Vty.Input.Paste
95 Graphics.Vty.Input.Paste
91 Graphics.Vty.Input.Terminfo
96 Graphics.Vty.Input.Terminfo
92 Graphics.Vty.PictureToSpans
97 Graphics.Vty.PictureToSpans
@@ -95,41 +100,52 @@ library
95 Graphics.Vty.Output.Interface
100 Graphics.Vty.Output.Interface
96 Graphics.Vty.Output.XTermColor
101 Graphics.Vty.Output.XTermColor
97 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
98
107
99− other-modules: Graphics.Vty.Attributes.Color
108+ other-modules: Graphics.Vty.Debug.Image
100− Graphics.Vty.Attributes.Color240
101− Graphics.Vty.Debug.Image
102 Graphics.Vty.Input.Terminfo.ANSIVT
109 Graphics.Vty.Input.Terminfo.ANSIVT
103
110
104 c-sources: cbits/gwinsz.c
111 c-sources: cbits/gwinsz.c
105 cbits/set_term_timing.c
112 cbits/set_term_timing.c
113+ cbits/get_tty_erase.c
106 cbits/mk_wcwidth.c
114 cbits/mk_wcwidth.c
107
115
108 include-dirs: cbits
116 include-dirs: cbits
109
117
110 hs-source-dirs: src
118 hs-source-dirs: src
111
119
112− default-extensions: ScopedTypeVariables
113− ForeignFunctionInterface
114−
115 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
116
121
117 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
118
123
124+executable vty-build-width-table
125+ main-is: BuildWidthTable.hs
126+ hs-source-dirs: tools
127+
128+ default-language: Haskell2010
119− 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
120
138
121executable vty-mode-demo
139executable vty-mode-demo
122 main-is: ModeDemo.hs
140 main-is: ModeDemo.hs
123 hs-source-dirs: demos
141 hs-source-dirs: demos
124
142
125 default-language: Haskell2010
143 default-language: Haskell2010
126− default-extensions: ScopedTypeVariables
127 ghc-options: -threaded
144 ghc-options: -threaded
128
145
129 build-depends: vty,
146 build-depends: vty,
130− base >= 4.6 && < 5,
147+ base >= 4.8 && < 5,
131 containers,
148 containers,
132− data-default >= 0.5.3,
133 microlens,
149 microlens,
134 microlens-mtl,
150 microlens-mtl,
135 mtl >= 1.1.1.0 && < 2.3
151 mtl >= 1.1.1.0 && < 2.3
@@ -139,40 +155,17 @@ executable vty-demo
139 hs-source-dirs: demos
155 hs-source-dirs: demos
140
156
141 default-language: Haskell2010
157 default-language: Haskell2010
142− default-extensions: ScopedTypeVariables
143 ghc-options: -threaded
158 ghc-options: -threaded
144
159
145 build-depends: vty,
160 build-depends: vty,
146− base >= 4.6 && < 5,
161+ base >= 4.8 && < 5,
147 containers,
162 containers,
148− data-default >= 0.5.3,
149 microlens,
163 microlens,
150 microlens-mtl,
164 microlens-mtl,
151 mtl >= 1.1.1.0 && < 2.3
165 mtl >= 1.1.1.0 && < 2.3
152
166
153−test-suite verify-attribute-ops
154− default-language: Haskell2010
155− default-extensions: ScopedTypeVariables
156− type: detailed-0.9
157− hs-source-dirs: test
158− test-module: VerifyAttributeOps
159− build-depends: vty,
160− Cabal >= 1.20,
161− QuickCheck >= 2.7,
162− random >= 1.0 && < 1.2,
163− base >= 4.6 && < 5,
164− bytestring,
165− containers,
166− deepseq >= 1.1 && < 1.5,
167− mtl >= 1.1.1.0 && < 2.3,
168− text >= 0.11.3,
169− unix,
170− utf8-string >= 0.3 && < 1.1,
171− vector >= 0.7
172−
173test-suite verify-using-mock-terminal
167test-suite verify-using-mock-terminal
174 default-language: Haskell2010
168 default-language: Haskell2010
175− default-extensions: ScopedTypeVariables
176
169
177 type: detailed-0.9
170 type: detailed-0.9
178
171
@@ -191,8 +184,8 @@ test-suite verify-using-mock-terminal
191 build-depends: vty,
184 build-depends: vty,
192 Cabal >= 1.20,
185 Cabal >= 1.20,
193 QuickCheck >= 2.7,
186 QuickCheck >= 2.7,
194− random >= 1.0 && < 1.2,
187+ random >= 1.0 && < 1.3,
195− base >= 4.6 && < 5,
188+ base >= 4.8 && < 5,
196 bytestring,
189 bytestring,
197 containers,
190 containers,
198 deepseq >= 1.1 && < 1.5,
191 deepseq >= 1.1 && < 1.5,
@@ -205,7 +198,6 @@ test-suite verify-using-mock-terminal
205
198
206test-suite verify-terminal
199test-suite verify-terminal
207 default-language: Haskell2010
200 default-language: Haskell2010
208− default-extensions: ScopedTypeVariables
209
201
210 type: detailed-0.9
202 type: detailed-0.9
211
203
@@ -224,11 +216,10 @@ test-suite verify-terminal
224 build-depends: vty,
216 build-depends: vty,
225 Cabal >= 1.20,
217 Cabal >= 1.20,
226 QuickCheck >= 2.7,
218 QuickCheck >= 2.7,
227− random >= 1.0 && < 1.2,
219+ random >= 1.0 && < 1.3,
228− base >= 4.6 && < 5,
220+ base >= 4.8 && < 5,
229 bytestring,
221 bytestring,
230 containers,
222 containers,
231− data-default >= 0.5.3,
232 deepseq >= 1.1 && < 1.5,
223 deepseq >= 1.1 && < 1.5,
233 mtl >= 1.1.1.0 && < 2.3,
224 mtl >= 1.1.1.0 && < 2.3,
234 terminfo >= 0.3 && < 0.5,
225 terminfo >= 0.3 && < 0.5,
@@ -239,7 +230,6 @@ test-suite verify-terminal
239
230
240test-suite verify-display-attributes
231test-suite verify-display-attributes
241 default-language: Haskell2010
232 default-language: Haskell2010
242− default-extensions: ScopedTypeVariables
243
233
244 type: detailed-0.9
234 type: detailed-0.9
245
235
@@ -258,8 +248,8 @@ test-suite verify-display-attributes
258 build-depends: vty,
248 build-depends: vty,
259 Cabal >= 1.20,
249 Cabal >= 1.20,
260 QuickCheck >= 2.7,
250 QuickCheck >= 2.7,
261− random >= 1.0 && < 1.2,
251+ random >= 1.0 && < 1.3,
262− base >= 4.6 && < 5,
252+ base >= 4.8 && < 5,
263 bytestring,
253 bytestring,
264 containers,
254 containers,
265 deepseq >= 1.1 && < 1.5,
255 deepseq >= 1.1 && < 1.5,
@@ -271,7 +261,6 @@ test-suite verify-display-attributes
271
261
272test-suite verify-empty-image-props
262test-suite verify-empty-image-props
273 default-language: Haskell2010
263 default-language: Haskell2010
274− default-extensions: ScopedTypeVariables
275
264
276 type: detailed-0.9
265 type: detailed-0.9
277
266
@@ -284,8 +273,8 @@ test-suite verify-empty-image-props
284 build-depends: vty,
273 build-depends: vty,
285 Cabal >= 1.20,
274 Cabal >= 1.20,
286 QuickCheck >= 2.7,
275 QuickCheck >= 2.7,
287− random >= 1.0 && < 1.2,
276+ random >= 1.0 && < 1.3,
288− base >= 4.6 && < 5,
277+ base >= 4.8 && < 5,
289 bytestring,
278 bytestring,
290 containers,
279 containers,
291 deepseq >= 1.1 && < 1.5,
280 deepseq >= 1.1 && < 1.5,
@@ -297,7 +286,6 @@ test-suite verify-empty-image-props
297
286
298test-suite verify-eval-terminfo-caps
287test-suite verify-eval-terminfo-caps
299 default-language: Haskell2010
288 default-language: Haskell2010
300− default-extensions: ScopedTypeVariables
301
289
302 type: detailed-0.9
290 type: detailed-0.9
303
291
@@ -311,8 +299,8 @@ test-suite verify-eval-terminfo-caps
311 build-depends: vty,
299 build-depends: vty,
312 Cabal >= 1.20,
300 Cabal >= 1.20,
313 QuickCheck >= 2.7,
301 QuickCheck >= 2.7,
314− random >= 1.0 && < 1.2,
302+ random >= 1.0 && < 1.3,
315− base >= 4.6 && < 5,
303+ base >= 4.8 && < 5,
316 blaze-builder >= 0.3.3.2 && < 0.5,
304 blaze-builder >= 0.3.3.2 && < 0.5,
317 bytestring,
305 bytestring,
318 containers,
306 containers,
@@ -326,7 +314,6 @@ test-suite verify-eval-terminfo-caps
326
314
327test-suite verify-image-ops
315test-suite verify-image-ops
328 default-language: Haskell2010
316 default-language: Haskell2010
329− default-extensions: ScopedTypeVariables
330
317
331 type: detailed-0.9
318 type: detailed-0.9
332
319
@@ -341,8 +328,8 @@ test-suite verify-image-ops
341 build-depends: vty,
328 build-depends: vty,
342 Cabal >= 1.20,
329 Cabal >= 1.20,
343 QuickCheck >= 2.7,
330 QuickCheck >= 2.7,
344− random >= 1.0 && < 1.2,
331+ random >= 1.0 && < 1.3,
345− base >= 4.6 && < 5,
332+ base >= 4.8 && < 5,
346 bytestring,
333 bytestring,
347 containers,
334 containers,
348 deepseq >= 1.1 && < 1.5,
335 deepseq >= 1.1 && < 1.5,
@@ -354,7 +341,6 @@ test-suite verify-image-ops
354
341
355test-suite verify-image-trans
342test-suite verify-image-trans
356 default-language: Haskell2010
343 default-language: Haskell2010
357− default-extensions: ScopedTypeVariables
358
344
359 type: detailed-0.9
345 type: detailed-0.9
360
346
@@ -369,8 +355,8 @@ test-suite verify-image-trans
369 build-depends: vty,
355 build-depends: vty,
370 Cabal >= 1.20,
356 Cabal >= 1.20,
371 QuickCheck >= 2.7,
357 QuickCheck >= 2.7,
372− random >= 1.0 && < 1.2,
358+ random >= 1.0 && < 1.3,
373− base >= 4.6 && < 5,
359+ base >= 4.8 && < 5,
374 bytestring,
360 bytestring,
375 containers,
361 containers,
376 deepseq >= 1.1 && < 1.5,
362 deepseq >= 1.1 && < 1.5,
@@ -382,7 +368,6 @@ test-suite verify-image-trans
382
368
383test-suite verify-inline
369test-suite verify-inline
384 default-language: Haskell2010
370 default-language: Haskell2010
385− default-extensions: ScopedTypeVariables
386
371
387 type: detailed-0.9
372 type: detailed-0.9
388
373
@@ -396,8 +381,8 @@ test-suite verify-inline
396 build-depends: vty,
381 build-depends: vty,
397 Cabal >= 1.20,
382 Cabal >= 1.20,
398 QuickCheck >= 2.7,
383 QuickCheck >= 2.7,
399− random >= 1.0 && < 1.2,
384+ random >= 1.0 && < 1.3,
400− base >= 4.6 && < 5,
385+ base >= 4.8 && < 5,
401 bytestring,
386 bytestring,
402 containers,
387 containers,
403 deepseq >= 1.1 && < 1.5,
388 deepseq >= 1.1 && < 1.5,
@@ -409,7 +394,6 @@ test-suite verify-inline
409
394
410test-suite verify-parse-terminfo-caps
395test-suite verify-parse-terminfo-caps
411 default-language: Haskell2010
396 default-language: Haskell2010
412− default-extensions: ScopedTypeVariables
413
397
414 type: detailed-0.9
398 type: detailed-0.9
415
399
@@ -424,8 +408,8 @@ test-suite verify-parse-terminfo-caps
424 build-depends: vty,
408 build-depends: vty,
425 Cabal >= 1.20,
409 Cabal >= 1.20,
426 QuickCheck >= 2.7,
410 QuickCheck >= 2.7,
427− random >= 1.0 && < 1.2,
411+ random >= 1.0 && < 1.3,
428− base >= 4.6 && < 5,
412+ base >= 4.8 && < 5,
429 bytestring,
413 bytestring,
430 containers,
414 containers,
431 deepseq >= 1.1 && < 1.5,
415 deepseq >= 1.1 && < 1.5,
@@ -438,7 +422,6 @@ test-suite verify-parse-terminfo-caps
438
422
439test-suite verify-simple-span-generation
423test-suite verify-simple-span-generation
440 default-language: Haskell2010
424 default-language: Haskell2010
441− default-extensions: ScopedTypeVariables
442
425
443 type: detailed-0.9
426 type: detailed-0.9
444
427
@@ -456,8 +439,8 @@ test-suite verify-simple-span-generation
456 build-depends: vty,
439 build-depends: vty,
457 Cabal >= 1.20,
440 Cabal >= 1.20,
458 QuickCheck >= 2.7,
441 QuickCheck >= 2.7,
459− random >= 1.0 && < 1.2,
442+ random >= 1.0 && < 1.3,
460− base >= 4.6 && < 5,
443+ base >= 4.8 && < 5,
461 bytestring,
444 bytestring,
462 containers,
445 containers,
463 deepseq >= 1.1 && < 1.5,
446 deepseq >= 1.1 && < 1.5,
@@ -470,7 +453,6 @@ test-suite verify-simple-span-generation
470
453
471test-suite verify-crop-span-generation
454test-suite verify-crop-span-generation
472 default-language: Haskell2010
455 default-language: Haskell2010
473− default-extensions: ScopedTypeVariables
474
456
475 type: detailed-0.9
457 type: detailed-0.9
476
458
@@ -488,8 +470,8 @@ test-suite verify-crop-span-generation
488 build-depends: vty,
470 build-depends: vty,
489 Cabal >= 1.20,
471 Cabal >= 1.20,
490 QuickCheck >= 2.7,
472 QuickCheck >= 2.7,
491− random >= 1.0 && < 1.2,
473+ random >= 1.0 && < 1.3,
492− base >= 4.6 && < 5,
474+ base >= 4.8 && < 5,
493 bytestring,
475 bytestring,
494 containers,
476 containers,
495 deepseq >= 1.1 && < 1.5,
477 deepseq >= 1.1 && < 1.5,
@@ -502,7 +484,6 @@ test-suite verify-crop-span-generation
502
484
503test-suite verify-layers-span-generation
485test-suite verify-layers-span-generation
504 default-language: Haskell2010
486 default-language: Haskell2010
505− default-extensions: ScopedTypeVariables
506
487
507 type: detailed-0.9
488 type: detailed-0.9
508
489
@@ -520,8 +501,33 @@ test-suite verify-layers-span-generation
520 build-depends: vty,
501 build-depends: vty,
521 Cabal >= 1.20,
502 Cabal >= 1.20,
522 QuickCheck >= 2.7,
503 QuickCheck >= 2.7,
523− 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,
524− base >= 4.6 && < 5,
530+ base >= 4.8 && < 5,
525 bytestring,
531 bytestring,
526 containers,
532 containers,
527 deepseq >= 1.1 && < 1.5,
533 deepseq >= 1.1 && < 1.5,
@@ -533,7 +539,6 @@ test-suite verify-layers-span-generation
533
539
534test-suite verify-utf8-width
540test-suite verify-utf8-width
535 default-language: Haskell2010
541 default-language: Haskell2010
536− default-extensions: ScopedTypeVariables
537
542
538 type: detailed-0.9
543 type: detailed-0.9
539
544
@@ -546,8 +551,8 @@ test-suite verify-utf8-width
546 build-depends: vty,
551 build-depends: vty,
547 Cabal >= 1.20,
552 Cabal >= 1.20,
548 QuickCheck >= 2.7,
553 QuickCheck >= 2.7,
549− random >= 1.0 && < 1.2,
554+ random >= 1.0 && < 1.3,
550− base >= 4.6 && < 5,
555+ base >= 4.8 && < 5,
551 bytestring,
556 bytestring,
552 containers,
557 containers,
553 deepseq >= 1.1 && < 1.5,
558 deepseq >= 1.1 && < 1.5,
@@ -559,7 +564,6 @@ test-suite verify-utf8-width
559
564
560test-suite verify-using-mock-input
565test-suite verify-using-mock-input
561 default-language: Haskell2010
566 default-language: Haskell2010
562− default-extensions: ScopedTypeVariables
563
567
564 type: exitcode-stdio-1.0
568 type: exitcode-stdio-1.0
565
569
@@ -567,16 +571,17 @@ test-suite verify-using-mock-input
567
571
568 main-is: VerifyUsingMockInput.hs
572 main-is: VerifyUsingMockInput.hs
569
573
574+ other-modules: Verify.Graphics.Vty.Output
575+
570 build-depends: vty,
576 build-depends: vty,
571 Cabal >= 1.20,
577 Cabal >= 1.20,
572− data-default >= 0.5.3,
573 QuickCheck >= 2.7,
578 QuickCheck >= 2.7,
574 smallcheck == 1.*,
579 smallcheck == 1.*,
575 quickcheck-assertions >= 0.1.1,
580 quickcheck-assertions >= 0.1.1,
576 test-framework == 0.8.*,
581 test-framework == 0.8.*,
577 test-framework-smallcheck == 0.2.*,
582 test-framework-smallcheck == 0.2.*,
578− random >= 1.0 && < 1.2,
583+ random >= 1.0 && < 1.3,
579− base >= 4.6 && < 5,
584+ base >= 4.8 && < 5,
580 bytestring,
585 bytestring,
581 containers,
586 containers,
582 deepseq >= 1.1 && < 1.5,
587 deepseq >= 1.1 && < 1.5,
@@ -594,7 +599,6 @@ test-suite verify-using-mock-input
594
599
595test-suite verify-config
600test-suite verify-config
596 default-language: Haskell2010
601 default-language: Haskell2010
597− default-extensions: ScopedTypeVariables
598
602
599 type: exitcode-stdio-1.0
603 type: exitcode-stdio-1.0
600
604
@@ -604,7 +608,6 @@ test-suite verify-config
604
608
605 build-depends: vty,
609 build-depends: vty,
606 Cabal >= 1.20,
610 Cabal >= 1.20,
607− data-default >= 0.5.3,
608 HUnit,
611 HUnit,
609 QuickCheck >= 2.7,
612 QuickCheck >= 2.7,
610 smallcheck == 1.*,
613 smallcheck == 1.*,
@@ -612,8 +615,8 @@ test-suite verify-config
612 test-framework == 0.8.*,
615 test-framework == 0.8.*,
613 test-framework-smallcheck == 0.2.*,
616 test-framework-smallcheck == 0.2.*,
614 test-framework-hunit,
617 test-framework-hunit,
615− random >= 1.0 && < 1.2,
618+ random >= 1.0 && < 1.3,
616− base >= 4.6 && < 5,
619+ base >= 4.8 && < 5,
617 bytestring,
620 bytestring,
618 containers,
621 containers,
619 deepseq >= 1.1 && < 1.5,
622 deepseq >= 1.1 && < 1.5,