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+777−344
@@ -1,428 +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+
15.15
3585.15
359+----
360+
2Package changes:
361Package changes:
3− - Discontinued support for GHC versions prior to 7.10.1.
362+* Discontinued support for GHC versions prior to 7.10.1.
4− - Removed instructions and configuration for Stack builds since they
363+* Removed instructions and configuration for Stack builds since they
5− are no longer supported.
364+ are no longer supported.
6− - Clarified README mention of (lack of) Windows support (contributors
365+* Clarified README mention of (lack of) Windows support (contributors
7− wanted, though!)
366+ wanted, though!)
8− - Removed dependency on data-default (see below).
367+* Removed dependency on data-default (see below).
9
368
10API changes:
369API changes:
11− - Moved color definitions from Attributes to Color module.
370+* Moved color definitions from Attributes to Color module.
12− - In lieu of data-default (Default) instances for Attr and Config, use
371+* In lieu of data-default (Default) instances for Attr and Config, use
13− 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
372+ 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
14− - Graphics.Vty.Output no longer re-exports
373+* Graphics.Vty.Output no longer re-exports
15− Graphics.Vty.Output.Interface.
374+ Graphics.Vty.Output.Interface.
16− - Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
375+* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
17− accessors to Graphics.Vty.Image.
376+ accessors to Graphics.Vty.Image.
18− - Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
377+* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
19− - Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
378+* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
20
379
215.14
3805.14
381+----
382+
22− - addMaybeClippedJoin: instead of raising an exception when the join
383+* addMaybeClippedJoin: instead of raising an exception when the join
23− is totally clipped, just reduce the clip amount and continue
384+ is totally clipped, just reduce the clip amount and continue
24− - addMaybeClipped: skip blit of joins when their primary dimension is
385+* addMaybeClipped: skip blit of joins when their primary dimension is
25− zero
386+ zero
26− - 'string' and related text functions no longer treat an empty string
387+* 'string' and related text functions no longer treat an empty string
27− 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
28− 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.
29
390
305.13
3915.13
392+----
393+
31− - Reverted changes in 5.12 due to disagreements between terminal
394+* Reverted changes in 5.12 due to disagreements between terminal
32− emulators and utf8proc; for more details, please see the ticket
395+ emulators and utf8proc; for more details, please see the ticket
33− discussion at
396+ discussion at
34− https://github.com/coreyoconnor/vty/issues/115
397+ https://github.com/coreyoconnor/vty/issues/115
35
398
365.12
3995.12
400+----
401+
37− - Replaced 'wcwidth' with a call to the utf8proc library's character
402+* Replaced 'wcwidth' with a call to the utf8proc library's character
38− 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
39− 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
40− characters.
405+ characters.
41− - Added a bundled version of the utf8proc C library.
406+* Added a bundled version of the utf8proc C library.
42
407
435.11.3
4085.11.3
409+------
410+
44− - Fix mouse event offsets in mouse-up events
411+* Fix mouse event offsets in mouse-up events
45
412
465.11.2
4135.11.2
414+------
415+
47− - 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
48− window is (0,0) rather than (1,1).
417+ is (0,0) rather than (1,1).
49
418
505.11.1
4195.11.1
420+------
421+
51− - Add Generic instance for Image
422+* Add Generic instance for Image
52− - nextEvent: stop trying to refresh on a resize event (fixes segfault
423+* nextEvent: stop trying to refresh on a resize event (fixes segfault
53− on refresh with normal cursor positioning mode)
424+ on refresh with normal cursor positioning mode)
54− - Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
425+* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
55− - Update maintainer
426+* Update maintainer
56
427
575.11
4285.11
429+----
430+
58− - Vty now raises a VtyConfigurationError exception when the TERM
431+* Vty now raises a VtyConfigurationError exception when the TERM
59− evironment variable is missing (thanks Eric Mertens)
432+ evironment variable is missing (thanks Eric Mertens)
60− - Graphics.Vty.Config got an explicit export list to avoid accidentally
433+* Graphics.Vty.Config got an explicit export list to avoid accidentally
61− exporting internal types (thanks Eric Mertens)
434+ exporting internal types (thanks Eric Mertens)
62
435
635.10
4365.10
437+----
438+
64− - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
439+* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
65− mode provides greater control over cursor positioning by bypassing
440+ mode provides greater control over cursor positioning by bypassing
66− the logical positioning provided by default. Rather than positioning
441+ the logical positioning provided by default. Rather than positioning
67− the cursor by looking at the widths of characters involved, this
442+ the cursor by looking at the widths of characters involved, this
68− constructor lets you provide a physical row and column instead. This
443+ constructor lets you provide a physical row and column instead. This
69− is useful in more sophisticated programs. (thanks Eric Mertens)
444+ is useful in more sophisticated programs. (thanks Eric Mertens)
70− - Added a new Generic-derived config parser (thanks Eric Mertens)
445+* Added a new Generic-derived config parser (thanks Eric Mertens)
71− - Fixed the MShift case in the configuration file parser (thanks Eric
446+* Fixed the MShift case in the configuration file parser (thanks Eric
72− Mertens)
447+ Mertens)
73− - Fixed wcwidth import and matched safeWcswidth to its documented
448+* Fixed wcwidth import and matched safeWcswidth to its documented
74− behavior. Previously vty_mk_wcwidth was being imported with
449+ behavior. Previously vty_mk_wcwidth was being imported with the
75− 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
76− wrong Int value. Additionally safeWcswidth was using the unsafe
451+ value. Additionally safeWcswidth was using the unsafe character width
77− character width function and only ensuring that the final result was
452+ function and only ensuring that the final result was non-negative.
78− non-negative. (thanks Eric Mertens)
453+ (thanks Eric Mertens)
79
454
805.9.1
4555.9.1
456+-----
457+
81− - Vty now only emits UTF8 charset sequences in terminals without a
458+* Vty now only emits UTF8 charset sequences in terminals without a
82− preexisting UTF8 declaration to avoid emitting garbage sequences
459+ preexisting UTF8 declaration to avoid emitting garbage sequences
83− (fixes #89)
460+ (fixes #89)
84
461
855.9
4625.9
463+---
464+
86− - Added new Output methods supportsBell and ringTerminalBell to find
465+* Added new Output methods supportsBell and ringTerminalBell to find out
87− 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)
88− #102)
89
467
905.8.1
4685.8.1
469+-----
470+
91− - Fixed "refresh" to work as advertised (see #104)
471+* Fixed "refresh" to work as advertised (see #104)
92
472
935.8
4735.8
474+---
475+
94− - 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
95− ByteString rather than a String to allow the application to decode
477+ ByteString rather than a String to allow the application to decode how
96− how best to decode it
478+ best to decode it
97
479
985.7.1
4805.7.1
481+-----
482+
99− - ModeDemo: added an explicit Control.Applicative import for older
483+* ModeDemo: added an explicit Control.Applicative import for older GHCs
100− GHCs
101
484
1025.7
4855.7
486+---
487+
103− - Mouse and paste modes are now off by default.
488+* Mouse and paste modes are now off by default.
104− - The Config type got new fields: mouseMode and bracketedPasteMode.
489+* The Config type got new fields: mouseMode and bracketedPasteMode.
105− These determine whether these modes are enabled initially (for
490+ These determine whether these modes are enabled initially (for
106− terminals that support them).
491+ terminals that support them).
107− - Added a Mode type for modal terminal features (mouse events,
492+* Added a Mode type for modal terminal features (mouse events,
108− bracketed paste mode) that is used with new Output interface
493+ bracketed paste mode) that is used with new Output interface
109− functions:
494+ functions:
110− * supportsMode :: Mode -> Bool tells whether the device supports a
495+ * supportsMode :: Mode -> Bool tells whether the device supports a
111− mode
496+ mode
112− * setMode :: Mode -> Bool -> IO () turns a mode on or off
497+ * setMode :: Mode -> Bool -> IO () turns a mode on or off
113− * 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
114− off
499+ off
115− - 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
116
501
1175.6
5025.6
503+---
504+
118− - Added support for normal and extended mouse modes in Xterm-like
505+* Added support for normal and extended mouse modes in Xterm-like
119− terminals via the MouseDown and MouseUp Event constructors
506+ terminals via the MouseDown and MouseUp Event constructors
120− - Added support for bracketed paste mode in Xterm-like terminals via
507+* Added support for bracketed paste mode in Xterm-like terminals via
121− the EvPaste event constructor
508+ the EvPaste event constructor
122− - Added derived Show instances for Event and Button (thanks Felix
509+* Added derived Show instances for Event and Button (thanks Felix
123− Hirn)
510+ Hirn)
124− - Now TERM values containing "screen" will automatically use the
511+* Now TERM values containing "screen" will automatically use the
125− XtermColor driver rather than just TerminfoBased
512+ XtermColor driver rather than just TerminfoBased
126
513
1275.5.0
5145.5.0
515+-----
516+
128− - Replaced lens dependency with microlens, microlens-mtl, microlens-th
517+* Replaced lens dependency with microlens, microlens-mtl, microlens-th
129− dependencies. Issue #90
518+ dependencies. Issue #90
130− - Thanks Jonathan Daugherty
519+ * Thanks Jonathan Daugherty
131− - Cabal corrections.
520+* Cabal corrections.
132− - Thanks Lennart Spitzner
521+ * Thanks Lennart Spitzner
133
522
1345.4.0
5235.4.0
524+-----
525+
135− - Changed eventChannel of Graphics.Vty.Input from Chan to TChan.
526+* Changed eventChannel of Graphics.Vty.Input from Chan to
136− This enables clients to query if there are no pending events. The
527+ TChan. This enables clients to query if there are no pending
137− Graphics.Vty interface nextEvent is unchanged. Clients that use
528+ events. The Graphics.Vty interface nextEvent is unchanged.
138− eventChannel directly will require updating.
529+ Clients that use eventChannel directly will require updating.
139− https://github.com/coreyoconnor/vty/issues/60
530+ https://github.com/coreyoconnor/vty/issues/60
531+
1405.3.1
5325.3.1
533+-----
534+
141− - 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
142− to possibly breaking this on reasonable GHC versions
536+ possibly breaking this on reasonable GHC versions
143
537
1445.3
5385.3
539+---
540+
145− - Upgraded QuickCheck dependency to 2.7
541+* Upgraded QuickCheck dependency to 2.7
146− - The standard IO Config (standardIOConfig) was overriding any
542+* The standard IO Config (standardIOConfig) was overriding any provided
147− provided application config. In addition, the inputFd and outputFd
543+ application config. In addition, the inputFd and outputFd could not be
148− could not be changed if mkVty was used. Fixed.
544+ changed if mkVty was used. Fixed.
149− - Correct handling of display attributes at end of line. The output
545+* Correct handling of display attributes at end of line. The output
150− 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
151− 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
152− 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
153− 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
154− IIRC Yi requires the old behavior to display the selection region
550+ requires the old behavior to display the selection region correctly.
155− correctly.
156− - shutdown of the input thread is now performed using killThread and
551+* shutdown of the input thread is now performed using killThread and
157− synchronization on an MVar. For correct handling of the terminal
552+ synchronization on an MVar. For correct handling of the terminal read
158− 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.
159− thread. This places a threadWaitRead, which will be interrupted by
554+ This places a threadWaitRead, which will be interrupted by the
160− the killThread, prior to the uninterruptable read. An alternative
555+ killThread, prior to the uninterruptable read. An alternative would be
161− would be to re-import the read foreign call as interruptable.
556+ to re-import the read foreign call as interruptable.
162
557
1635.2.11
5585.2.11
559+------
560+
164− - deepseq bounds increased for tests.
561+* deepseq bounds increased for tests.
165− - Clean up warnings when compiling on 7.10
562+* Clean up warnings when compiling on 7.10
166− - Thanks Eric Mertens
563+ * Thanks Eric Mertens
167− - Avoid discarding input bytes after multi-byte encoded codepoint
564+* Avoid discarding input bytes after multi-byte encoded codepoint
168− - Thanks Eric Mertens
565+ * Thanks Eric Mertens
169
566
1705.2.10
5675.2.10
568+------
569+
171− - "str" now returns EmptyImage for empty strings to match behavior of
570+* "str" now returns EmptyImage for empty strings to match behavior of
172− other string-like Image constructors (fixes #74)
571+ other string-like Image constructors (fixes #74)
173− - Thanks Jonathan Daugherty
572+ * Thanks Jonathan Daugherty
174
573
1755.2.9
5745.2.9
575+-----
576+
176− - dependency version bumps
577+* dependency version bumps
177− - https://github.com/coreyoconnor/vty/pull/71
578+ * https://github.com/coreyoconnor/vty/pull/71
178− - https://github.com/coreyoconnor/vty/pull/70
579+ * https://github.com/coreyoconnor/vty/pull/70
179− - Correct/Simplify the example code
580+* Correct/Simplify the example code
180− - Thanks glguy
581+ * Thanks glguy
181− - https://github.com/coreyoconnor/vty/pull/69
582+ * https://github.com/coreyoconnor/vty/pull/69
182
583
1835.2.8
5845.2.8
585+-----
586+
184− - blaze-builder, lens, utf8-string version constraint bump
587+* blaze-builder, lens, utf8-string version constraint bump
185− - Thanks glguy
588+ * Thanks glguy
186− - https://github.com/coreyoconnor/vty/pull/67
589+ * https://github.com/coreyoconnor/vty/pull/67
187− - Do not differentiate based on TERM_PROGRAM
590+* Do not differentiate based on TERM_PROGRAM
188− - https://github.com/coreyoconnor/vty/issues/68
591+ * https://github.com/coreyoconnor/vty/issues/68
189
592
1905.2.7
5935.2.7
594+-----
595+
191− - lens and deepseq constraint bump + misc
596+* lens and deepseq constraint bump + misc
192− - Thanks ethercrow
597+ * Thanks ethercrow
193− - https://github.com/coreyoconnor/vty/pull/66
598+ * https://github.com/coreyoconnor/vty/pull/66
194
599
1955.2.6
6005.2.6
601+-----
602+
196− - lens constraint bump
603+* lens constraint bump
197− - Thanks alexander-b!
604+ * Thanks alexander-b!
198− - https://github.com/coreyoconnor/vty/pull/64
605+ * https://github.com/coreyoconnor/vty/pull/64
199
606
2005.2.5
6075.2.5
608+-----
609+
201− - lens and random version constraint bump.
610+* lens and random version constraint bump.
202− - Thanks RyanGlScott!
611+ * Thanks RyanGlScott!
203− - https://github.com/coreyoconnor/vty/pull/62
612+ * https://github.com/coreyoconnor/vty/pull/62
204
613
2055.2.4
6145.2.4
615+-----
616+
206− - removed -fpic from cc-options. No longer required.
617+* removed -fpic from cc-options. No longer required.
207− - https://github.com/coreyoconnor/vty/issues/61
618+ * https://github.com/coreyoconnor/vty/issues/61
208− - https://ghc.haskell.org/trac/ghc/ticket/9657
619+ * https://ghc.haskell.org/trac/ghc/ticket/9657
209− - Thanks Fuuzetsu!
620+ * Thanks Fuuzetsu!
210
621
2115.2.3
6225.2.3
623+-----
624+
212− - evaluate/compile the input parsing table once instead of each
625+* evaluate/compile the input parsing table once instead of each
213− keystroke.
626+ keystroke.
214− - https://github.com/coreyoconnor/vty/pull/59
627+ * https://github.com/coreyoconnor/vty/pull/59
215− - Thanks ethercrow!
628+ * Thanks ethercrow!
216
629
2175.2.2
6305.2.2
631+-----
632+
218− - 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.
219− - https://github.com/coreyoconnor/vty/pull/57
634+ * https://github.com/coreyoconnor/vty/pull/57
220− - Thanks ethercrow!
635+ * Thanks ethercrow!
221
636
2225.2.1
6375.2.1
638+-----
639+
223− - Bump upper version bound for lens to 4.5. Thanks markus1189!
640+* Bump upper version bound for lens to 4.5. Thanks markus1189!
224
641
2255.2.0
6425.2.0
643+-----
644+
226− - Config structure now specifies file descriptor to use. The default
645+* Config structure now specifies file descriptor to use. The default
227− is stdInput and stdOutput file descriptors. Previously Vty used
646+ is stdInput and stdOutput file descriptors. Previously Vty used
228− stdInput for input and the follow code for output:
647+ stdInput for input and the follow code for output:
229− - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
648+ * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
230− NoBuffering)
649+ NoBuffering)
231− - the difference was required by Vty.Inline. Now, Vty.Inline uses
650+ * the difference was required by Vty.Inline. Now, Vty.Inline uses
232− the Config structure options to acheive the same effect.
651+ the Config structure options to acheive the same effect.
233− - removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
652+* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
234− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
653+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
235− - added: inputForConfig, outputForConfig
654+* added: inputForConfig, outputForConfig
236− - updates to vty-rogue from jtdaugherty. Thanks!
655+* updates to vty-rogue from jtdaugherty. Thanks!
237− - 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.
238− - 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
239
658
2405.1.4
6595.1.4
660+-----
661+
241− - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
662+* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
242
663
2435.1.1
6645.1.1
665+-----
666+
244− - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
667+* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
245− - jtdaugherty resolved a number of compiler warnings. Thanks!
668+* jtdaugherty resolved a number of compiler warnings. Thanks!
246
669
2475.1.0
6705.1.0
671+-----
672+
248− - vmin and vtime can be specified however the application requires.
673+* vmin and vtime can be specified however the application requires.
249− See Graphics.Vty.Config.
674+ See Graphics.Vty.Config.
250− - fixed the processing of input when vmin is set > 1.
675+* fixed the processing of input when vmin is set > 1.
251
676
2525.0.0
6775.0.0
678+-----
679+
253− - The naming convention now matches:
680+* The naming convention now matches:
254− - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
681+ * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
255− - all projects using vty for input must be compiled with -threaded.
682+* all projects using vty for input must be compiled with -threaded.
256− Please notify vty author if this is not acceptable.
683+ Please notify vty author if this is not acceptable.
257− - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
684+* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
258− vty with the default configuration.
685+ vty with the default configuration.
259− - input handling changes
686+* input handling changes
260− - KASCII is now KChar
687+ * KASCII is now KChar
261− - KPN5 is now KCenter
688+ * KPN5 is now KCenter
262− - tests exist.
689+ * tests exist.
263− - Applications can add to the input tables by setting inputMap of
690+ * Applications can add to the input tables by setting inputMap of
264− the Config. See Graphics.Vty.Config
691+ the Config. See Graphics.Vty.Config
265− - 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
266− applications. See Graphics.Vty.Config
693+ applications. See Graphics.Vty.Config
267− - terminal timing is now handled by selecting an appropriate VTIME.
694+ * terminal timing is now handled by selecting an appropriate VTIME.
268− Previously this was implemented within Vty itself. This reduced
695+ Previously this was implemented within Vty itself. This reduced
269− complexity in vty but provides a different meta key behavior and
696+ complexity in vty but provides a different meta key behavior and
270− implies a requirement on -threaded.
697+ implies a requirement on -threaded.
271− - 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
272− key is the singleEscPeriod of the Input Config structure.
699+ key is the singleEscPeriod of the Input Config structure.
273− - removed the typeclass based terminal and display context interface
700+* removed the typeclass based terminal and display context interface
274− in favor of a data structure of properties interface.
701+ in favor of a data structure of properties interface.
275− - renamed the Terminal interface to Output
702+* renamed the Terminal interface to Output
276− - The default picture for an image now uses the "clear" background.
703+* The default picture for an image now uses the "clear" background.
277− This background fills background spans with spaces or just ends the
704+ This background fills background spans with spaces or just ends the
278− line.
705+ line.
279− - Previously the background defaulted to the space character. This
706+ * Previously the background defaulted to the space character. This
280− 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
281− up with extra spaces at the end of the line.
708+ up with extra spaces at the end of the line.
282− - Layer support
709+* Layer support
283− - Each layer is an image.
710+ * Each layer is an image.
284− - The layers for a picture are a list of images.
711+ * The layers for a picture are a list of images.
285− - 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
286− top to bottom.
713+ top to bottom.
287− - The transparent areas for a layer are the backgroundFill areas.
714+ * The transparent areas for a layer are the backgroundFill areas.
288− backgroundFill is added to pad images when images of different
715+ backgroundFill is added to pad images when images of different
289− sizes are joined.
716+ sizes are joined.
290− - If the background is clear there is no background layer.
717+ * If the background is clear there is no background layer.
291− - 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
292− background layer.
719+ background layer.
293− - emptyPicture is a Picture with no layers and no cursor
720+ * emptyPicture is a Picture with no layers and no cursor
294− - 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
295− given Picture.
722+ given Picture.
296− - compatibility improvements:
723+* compatibility improvements:
297− - terminfo based terminals with no cursor support are silently
724+ * terminfo based terminals with no cursor support are silently
298− accepted. The cursor visibility changes in the Picture will have
725+ accepted. The cursor visibility changes in the Picture will have
299− no effect.
726+ no effect.
300− - alternate (setf/setb) color maps supported. Though colors beyond
727+ * alternate (setf/setb) color maps supported. Though colors beyond
301− the first 8 are just a guess.
728+ the first 8 are just a guess.
302− - added "rgbColor" for easy support of RGB specified colors.
729+ * added "rgbColor" for easy support of RGB specified colors.
303− - Both applications and users can add to the mapping used to
730+ * Both applications and users can add to the mapping used to
304− translate from input bytes to events.
731+ translate from input bytes to events.
305− - Additional information about input and output process can be
732+* Additional information about input and output process can be
306− appended to a debug log
733+ appended to a debug log
307− - Set environment variable VTY_DEBUG_LOG to path of debug log
734+ * Set environment variable VTY_DEBUG_LOG to path of debug log
308− - Or use "debugLog <path>" config directive
735+ * Or use "debugLog <path>" config directive
309− - Or set 'debugLog' property of the Config provided to mkVty.
736+ * Or set 'debugLog' property of the Config provided to mkVty.
310− - examples moved to vty-examples package. See test directory for cabal
737+* examples moved to vty-examples package. See test directory for cabal
311− file.
738+ file.
312− - vty-interactive-terminal-test
739+ * vty-interactive-terminal-test
313− - interactive test. Useful for building a bug report for vty's
740+ * interactive test. Useful for building a bug report for vty's
314− author.
741+ author.
315− - test/interactive_terminal_test.hs
742+ * test/interactive_terminal_test.hs
316− - vty-event-echo
743+ * vty-event-echo
317− - view a input event log for vty. Example of interacting with
744+ * view a input event log for vty. Example of interacting with
318− user.
745+ user.
319− - test/EventEcho.hs
746+ * test/EventEcho.hs
320− - vty-rogue
747+ * vty-rogue
321− - 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
322− build operations.
749+ build operations.
323− - test/Rogue.hs
750+ * test/Rogue.hs
324− - vty-benchmark
751+ * vty-benchmark
325− - benchmarks vty. A series of tests that push random pictures to
752+ * benchmarks vty. A series of tests that push random pictures to
326− the terminal. The random pictures are generated using
753+ the terminal. The random pictures are generated using
327− QuickCheck. The same generators used in the automated tests.
754+ QuickCheck. The same generators used in the automated tests.
328− - test/benchmark.hs
755+ * test/benchmark.hs
329
756
3304.7.0.0
7574.7.0.0
331− - API changes:
758+-------
332− - Added Graphics.Vty.Image.crop: Ensure an image is no larger
333− than the specified size.
334− - Added Graphics.Vty.Image.pad: Ensure an image is no smaller
335− than the specified size.
336− - Added Graphics.Vty.Image.translate: Offset an image.
337− - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
338
759
339−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.
340
767
3414.2.1.0
7684.2.1.0
769+-------
770+
342− - API changes:
771+API changes:
343− - Attr record accessor fore_color changed to attr_fore_color
772+* Attr record accessor fore_color changed to attr_fore_color
344− - Attr record accessor back_color changed to attr_back_color
773+* Attr record accessor back_color changed to attr_back_color
345− - Attr record accessor style changed to attr_style
774+* Attr record accessor style changed to attr_style
346− - Added an "inline" display attribute changing DSL:
775+* Added an "inline" display attribute changing DSL:
347− - put_attr_change applies a display attribute change
776+ * put_attr_change applies a display attribute change
348− immediately to a terminal
777+ immediately to a terminal
349− - For instance, can be used to change the display attrbiutes
778+ * For instance, can be used to change the display attrbiutes
350− of text output via putStrLn and putStr. EX:
779+ of text output via putStrLn and putStr. EX:
351− "put_attr_change $ back_color red" will set the background
780+ "put_attr_change $ back_color red" will set the background
352− color to red.
781+ color to red.
353− - Changes do not apply to a Picture output via output_picture.
782+ * Changes do not apply to a Picture output via output_picture.
354− - See Graphics.Vty.Inline
783+ * See Graphics.Vty.Inline
355− - Moved all IO actions into any monad an instance of MonadIO
784+* Moved all IO actions into any monad an instance of MonadIO
356
785
3574.0.0.1
7864.0.0.1
787+-------
788+
358− - binding for mk_wcswidth was incorrect. Most platforms just
789+* binding for mk_wcswidth was incorrect. Most platforms just
359− magically worked due to coincidence.
790+ magically worked due to coincidence.
360
791
3614.0.0
7924.0.0
793+-----
794+
362− - API changes:
795+API changes:
363− - "getSize" has been removed. Use "terminal vty >>= display_bounds"
796+* "getSize" has been removed. Use "terminal vty >>= display_bounds"
364− where "vty" is an instance of the Vty data structure.
797+ where "vty" is an instance of the Vty data structure.
365− - added a "terminal" field to the Vty data structure. Accesses the
798+* added a "terminal" field to the Vty data structure. Accesses the
366− TerminalHandle associated with the Vty instance.
799+ TerminalHandle associated with the Vty instance.
367− - Graphics.Vty.Types has undergone a number of changes. Summary:
800+* Graphics.Vty.Types has undergone a number of changes. Summary:
368− - Partitioned into Graphics.Vty.Attributes for display attributes.
801+ * Partitioned into Graphics.Vty.Attributes for display attributes.
369− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
802+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
370− for final picture construction.
803+ for final picture construction.
371− - Graphics.Vty.Attributes:
804+* Graphics.Vty.Attributes:
372− - "setFG" and "setBG" are now "with_fore_color" and
805+ * "setFG" and "setBG" are now "with_fore_color" and
373− "with_back_color"
806+ "with_back_color"
374− - All other "set.." equations similarly replaced.
807+ * All other "set.." equations similarly replaced.
375− - "attr" is now "def_attr", short for "default display attributes"
808+ * "attr" is now "def_attr", short for "default display attributes"
376− Also added a "current_attr" for "currently applied display
809+ Also added a "current_attr" for "currently applied display
377− attributes"
810+ attributes"
378− - Graphics.Vty.Image:
811+* Graphics.Vty.Image:
379− - "horzcat" is now "horiz_cat"
812+ * "horzcat" is now "horiz_cat"
380− - "vertcat" is now "vert_cat"
813+ * "vertcat" is now "vert_cat"
381− - "renderBS" is now "utf8_bytestring"
814+ * "renderBS" is now "utf8_bytestring"
382− - "renderChar" is now "char"
815+ * "renderChar" is now "char"
383− - "renderFill" is now "char_fill"
816+ * "renderFill" is now "char_fill"
384− - added a "utf8_string" and "string" (AKA "iso_10464_string") for
817+ * added a "utf8_string" and "string" (AKA "iso_10464_string") for
385− UTF-8 encoded Strings and ISO-10464 encoded Strings. String
818+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String
386− literals in GHC have an ISO-10464 runtime representation.
819+ literals in GHC have an ISO-10464 runtime representation.
387− - Graphics.Vty.Picture:
820+* Graphics.Vty.Picture:
388− - exports Graphics.Vty.Image
821+ * exports Graphics.Vty.Image
389− - "pic" is now "pic_for_image"
822+ * "pic" is now "pic_for_image"
390− - added API for setting background fill pattern.
823+ * added API for setting background fill pattern.
391− - Completely rewritten output backend.
824+* Completely rewritten output backend.
392− - Efficient, scanline style output span generator. Has not been
825+ * Efficient, scanline style output span generator. Has not been
393− fully optimized, but good enough.
826+ fully optimized, but good enough.
394− - The details required to display the desired picture on a
827+ * The details required to display the desired picture on a
395− terminal are well encapsulated.
828+ terminal are well encapsulated.
396− - Terminfo based display terminal implementation. With specialized
829+ * Terminfo based display terminal implementation. With specialized
397− derivitives for xterm, Terminal.app, and iTerm.app.
830+ derivitives for xterm, Terminal.app, and iTerm.app.
398− - Attempts to robustly handle even terminals that don't
831+ * Attempts to robustly handle even terminals that don't
399− support all display attributes.
832+ support all display attributes.
400− - I've tested the following terminals with success: iTerm.app,
833+ * I've tested the following terminals with success: iTerm.app,
401− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
834+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
402− konsole, screen, linux vty. Hopefully you will be as
835+ konsole, screen, linux vty. Hopefully you will be as
403− successfull.
836+ successfull.
404− - Improved unicode support. Double wide characters will display as
837+ * Improved unicode support. Double wide characters will display as
405− expected.
838+ expected.
406− - 256 color support. See Graphics.Vty.Attributes.Color240. The actual
839+* 256 color support. See Graphics.Vty.Attributes.Color240. The actual
407− output color is adjusted according to the number of colors the
840+ output color is adjusted according to the number of colors the
408− terminal supports.
841+ terminal supports.
409− - The Graphics.Vty.Image combinators no longer require matching
842+* The Graphics.Vty.Image combinators no longer require matching
410− dimensions to arguments. Unspecified areas are filled in with a
843+ dimensions to arguments. Unspecified areas are filled in with a
411− user-customizable background pattern. See Graphics.Vty.Picture.
844+ user-customizable background pattern. See Graphics.Vty.Picture.
412− - output images are always cropped to display size.
845+* output images are always cropped to display size.
413− - Significant code coverage by QuickCheck tests. An interactive test
846+* Significant code coverage by QuickCheck tests. An interactive test
414− for those final properties that couldn't be automatically verified.
847+ for those final properties that couldn't be automatically verified.
415
848
416Issues resolved:
849Issues resolved:
417− - "gnome terminal displays non-basic attributes as strikethrough"
850+* "gnome terminal displays non-basic attributes as strikethrough"
418− - http://trac.haskell.org/vty/ticket/14
851+ * http://trac.haskell.org/vty/ticket/14
419− - "Multi-byte characters are not displayed correctly on update"
852+* "Multi-byte characters are not displayed correctly on update"
420− - http://trac.haskell.org/vty/ticket/10
853+ * http://trac.haskell.org/vty/ticket/10
421− - "Redraw does not handle rendering a line that extends beyond screen
854+* "Redraw does not handle rendering a line that extends beyond screen
422− width characters"
855+ width characters"
423− - http://trac.haskell.org/vty/ticket/13
856+ * http://trac.haskell.org/vty/ticket/13
424− - "The <|> and <-> combinators should be more forgiving of mismatched
857+* "The <|> and <-> combinators should be more forgiving of mismatched
425− dimensions"
858+ dimensions"
426− - http://trac.haskell.org/vty/ticket/9
859+ * http://trac.haskell.org/vty/ticket/9
427− - "256-color support"
860+* "256-color support"
428− - 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+109−54
@@ -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,10 +186,10 @@ 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.
136
191
137−# Sources
192+# Further Reading
138
193
139Good sources of documentation for terminal programming are:
194Good sources of documentation for terminal programming are:
140
195
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+12−4
@@ -31,7 +31,8 @@ introText = vertCat $ map (string defAttr)
31 [ "this line is hidden by the top layer"
31 [ "this line is hidden by the top layer"
32 , "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."
33 , "Below there is a 240 color box."
33 , "Below there is a 240 color box."
34− , "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."
35 , "If the 240 color box is not visible then the terminal"
36 , "If the 240 color box is not visible then the terminal"
36 , "claims 240 colors are not supported."
37 , "claims 240 colors are not supported."
37 , "Try setting TERM to xterm-256color"
38 , "Try setting TERM to xterm-256color"
@@ -42,12 +43,19 @@ introText = vertCat $ map (string defAttr)
42 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
43 ]
44 ]
44
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+
45colorbox_240 :: Image
55colorbox_240 :: Image
46colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
47 where
57 where
48 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
49− splitColorImages [] = []
50− splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
51
59
52colorbox_16 :: Image
60colorbox_16 :: Image
53colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
61colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
@@ -70,7 +78,7 @@ updateDisplay = do
70 "Press ESC to exit. Events for keys below."
78 "Press ESC to exit. Events for keys below."
71 eventLog <- foldMap (string defAttr) <$> get
79 eventLog <- foldMap (string defAttr) <$> get
72 let pic = picForImage (info <-> eventLog)
80 let pic = picForImage (info <-> eventLog)
73− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
81+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
74 vty <- ask
82 vty <- ask
75 liftIO $ update vty pic
83 liftIO $ update vty pic
76
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+40−9
@@ -1,26 +1,47 @@
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.
@@ -30,4 +51,14 @@ safeWcwidth = max 0 . wcwidth
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+134−38
@@ -1,3 +1,6 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
1-- | Vty provides interfaces for both terminal input and terminal
4-- | Vty provides interfaces for both terminal input and terminal
2-- output.
5-- output.
3--
6--
@@ -10,6 +13,9 @@
10-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
13-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
11-- values in the "Graphics.Vty.Attributes" module.
14-- values in the "Graphics.Vty.Attributes" module.
12--
15--
16+-- Vty uses threads internally, so programs made with Vty need to be
17+-- compiled with the threaded runtime using the GHC @-threaded@ option.
18+--
13-- @
19-- @
14-- import "Graphics.Vty"
20-- import "Graphics.Vty"
15--
21--
@@ -28,6 +34,7 @@
28module Graphics.Vty
34module Graphics.Vty
29 ( Vty(..)
35 ( Vty(..)
30 , mkVty
36 , mkVty
37+ , setWindowTitle
31 , Mode(..)
38 , Mode(..)
32 , module Graphics.Vty.Config
39 , module Graphics.Vty.Config
33 , module Graphics.Vty.Input
40 , module Graphics.Vty.Input
@@ -41,23 +48,33 @@ where
41
48
42import Graphics.Vty.Config
49import Graphics.Vty.Config
43import Graphics.Vty.Input
50import Graphics.Vty.Input
51+import Graphics.Vty.Input.Events
44import Graphics.Vty.Output
52import Graphics.Vty.Output
45import Graphics.Vty.Output.Interface
53import Graphics.Vty.Output.Interface
46import Graphics.Vty.Picture
54import Graphics.Vty.Picture
47import Graphics.Vty.Image
55import Graphics.Vty.Image
48import Graphics.Vty.Attributes
56import Graphics.Vty.Attributes
57+import Graphics.Vty.UnicodeWidthTable.IO
58+import Graphics.Vty.UnicodeWidthTable.Install
49
59
60+import Data.Char (isPrint, showLitChar)
61+import qualified Data.ByteString.Char8 as BS8
62+
63+import qualified Control.Exception as E
64+import Control.Monad (when)
50import Control.Concurrent.STM
65import Control.Concurrent.STM
51
66
52import Data.IORef
67import Data.IORef
68+#if !(MIN_VERSION_base(4,11,0))
53−import Data.Monoid
69+import Data.Semigroup ((<>))
70+#endif
54
71
55-- | A Vty value represents a handle to the Vty library that the
72-- | A Vty value represents a handle to the Vty library that the
56-- application must create in order to use Vty.
73-- application must create in order to use Vty.
57--
74--
58-- The use of Vty typically follows this process:
75-- The use of Vty typically follows this process:
59--
76--
60−-- 1. Initialize vty
77+-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
61--
78--
62-- 2. Use 'update' to display a picture.
79-- 2. Use 'update' to display a picture.
63--
80--
@@ -65,31 +82,33 @@ import Data.Monoid
65--
82--
66-- 4. Depending on the event, go to 2 or 5.
83-- 4. Depending on the event, go to 2 or 5.
67--
84--
68−-- 5. Shutdown vty.
85+-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
86+-- this point the 'Vty' handle cannot be used again.
69--
87--
70-- Operations on Vty handles are not thread-safe.
88-- Operations on Vty handles are not thread-safe.
71−data Vty = Vty
89+data Vty =
90+ Vty { update :: Picture -> IO ()
72− { -- | Outputs the given 'Picture'.
91+ -- ^ Outputs the given 'Picture'.
73− update :: Picture -> IO ()
92+ , nextEvent :: IO Event
74− -- | Get one 'Event' object, blocking if none are available. This
93+ -- ^ Return the next 'Event' or block until one becomes
75− -- will refresh the terminal if the event is a 'EvResize'.
94+ -- available.
76− , nextEvent :: IO Event
95+ , nextEventNonblocking :: IO (Maybe Event)
77− -- | The input interface. See 'Input'.
96+ -- ^ Non-blocking version of 'nextEvent'.
78− , inputIface :: Input
97+ , inputIface :: Input
79− -- | The output interface. See 'Output'.
98+ -- ^ The input interface. See 'Input'.
80− , outputIface :: Output
99+ , outputIface :: Output
81− -- | Refresh the display. 'nextEvent' will refresh the display if
100+ -- ^ The output interface. See 'Output'.
82− -- a resize occurs, but this can be used to refresh the display
101+ , refresh :: IO ()
83− -- explicitly. If other programs output to the terminal and mess
102+ -- ^ Refresh the display. If other programs output to the
84− -- up the display then the application might want to force a
103+ -- terminal and mess up the display then the application might
85− -- refresh using this function.
104+ -- want to force a refresh using this function.
86− , refresh :: IO ()
105+ , shutdown :: IO ()
87− -- | Clean up after vty. A call to this function is necessary to
106+ -- ^ Clean up after vty. A call to this function is necessary to
88− -- cleanly restore the terminal state before application exit. The
107+ -- cleanly restore the terminal state before application exit.
89− -- above methods will throw an exception if executed after this is
108+ -- The above methods will throw an exception if executed after
90− -- executed.
109+ -- this is executed. Idempotent.
91− , shutdown :: IO ()
110+ , isShutdown :: IO Bool
92− }
111+ }
93
112
94-- | Create a Vty handle. At most one handle should be created at a time
113-- | Create a Vty handle. At most one handle should be created at a time
95-- for a given terminal device.
114-- for a given terminal device.
@@ -102,17 +121,63 @@ data Vty = Vty
102mkVty :: Config -> IO Vty
121mkVty :: Config -> IO Vty
103mkVty appConfig = do
122mkVty appConfig = do
104 config <- (<> appConfig) <$> userConfig
123 config <- (<> appConfig) <$> userConfig
105− input <- inputForConfig config
106− out <- outputForConfig config
107− intMkVty input out
108
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+
109−intMkVty :: Input -> Output -> IO Vty
167+internalMkVty :: Input -> Output -> IO Vty
110−intMkVty input out = do
168+internalMkVty input out = do
111 reserveDisplay out
169 reserveDisplay out
170+
171+ shutdownVar <- newTVarIO False
112 let shutdownIo = do
172 let shutdownIo = do
173+ alreadyShutdown <- atomically $ swapTVar shutdownVar True
174+ when (not alreadyShutdown) $ do
113− shutdownInput input
175+ shutdownInput input
114− releaseDisplay out
176+ releaseDisplay out
115− releaseTerminal out
177+ releaseTerminal out
178+
179+ let shutdownStatus = readTVarIO shutdownVar
180+
116 lastPicRef <- newIORef Nothing
181 lastPicRef <- newIORef Nothing
117 lastUpdateRef <- newIORef Nothing
182 lastUpdateRef <- newIORef Nothing
118
183
@@ -144,16 +209,47 @@ intMkVty input out = do
144 mPic <- readIORef lastPicRef
209 mPic <- readIORef lastPicRef
145 maybe (return ()) innerUpdate mPic
210 maybe (return ()) innerUpdate mPic
146
211
212+ let mkResize = uncurry EvResize <$> displayBounds out
213+
214+ translateInternalEvent ResumeAfterSignal = mkResize
215+ translateInternalEvent (InputEvent e) = return e
216+
217+ gkey = do
147− 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
148− case k of
222+ case mEv of
149− (EvResize _ _) -> displayBounds out
223+ Just e -> Just <$> translateInternalEvent e
150− >>= return . (\(w,h)-> EvResize w h)
151− _ -> return k
224+ Nothing -> return Nothing
152
225
153 return $ Vty { update = innerUpdate
226 return $ Vty { update = innerUpdate
154 , nextEvent = gkey
227 , nextEvent = gkey
228+ , nextEventNonblocking = gkey'
155 , inputIface = input
229 , inputIface = input
156 , outputIface = out
230 , outputIface = out
157 , refresh = innerRefresh
231 , refresh = innerRefresh
158 , shutdown = shutdownIo
232 , shutdown = shutdownIo
233+ , isShutdown = shutdownStatus
159 }
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+54−45
@@ -1,6 +1,6 @@
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--
@@ -10,14 +10,14 @@
10-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,
10-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,
11--
11--
12-- @
12-- @
13−-- defAttr `withForeColor` red
13+-- defAttr \`withForeColor\` red
14-- @
14-- @
15--
15--
16-- 'Image' constructors often require an 'Attr' to indicate the
16-- 'Image' constructors often require an 'Attr' to indicate the
17-- attributes used in the image, e.g.,
17-- attributes used in the image, e.g.,
18--
18--
19-- @
19-- @
20−-- string (defAttr `withForeColor` red) "this text will be red"
20+-- string (defAttr \`withForeColor\` red) "this text will be red"
21-- @
21-- @
22--
22--
23-- The appearance of 'Image's using 'defAttr' is determined by the The
23-- The appearance of 'Image's using 'defAttr' is determined by the The
@@ -27,7 +27,9 @@
27-- The value 'currentAttr' will keep the attributes of whatever was
27-- The value 'currentAttr' will keep the attributes of whatever was
28-- output previously.
28-- output previously.
29module Graphics.Vty.Attributes
29module Graphics.Vty.Attributes
30+ ( module Graphics.Vty.Attributes.Color
31+
30− ( Attr(..)
32+ , Attr(..)
31 , FixedAttr(..)
33 , FixedAttr(..)
32 , MaybeDefault(..)
34 , MaybeDefault(..)
33 , defAttr
35 , defAttr
@@ -37,6 +39,8 @@ module Graphics.Vty.Attributes
37 , Style
39 , Style
38 , withStyle
40 , withStyle
39 , standout
41 , standout
42+ , italic
43+ , strikethrough
40 , underline
44 , underline
41 , reverseVideo
45 , reverseVideo
42 , blink
46 , blink
@@ -50,17 +54,18 @@ module Graphics.Vty.Attributes
50 , withForeColor
54 , withForeColor
51 , withBackColor
55 , withBackColor
52
56
53− -- * Colors
57+ -- * Setting hyperlinks
54− , module Graphics.Vty.Attributes.Color
58+ , withURL
55− , module Graphics.Vty.Attributes.Color240
56 )
59 )
57where
60where
58
61
62+import Control.DeepSeq
59import Data.Bits
63import Data.Bits
64+import Data.Text (Text)
60import Data.Word
65import Data.Word
66+import GHC.Generics
61
67
62import Graphics.Vty.Attributes.Color
68import Graphics.Vty.Attributes.Color
63−import Graphics.Vty.Attributes.Color240
64
69
65-- | A display attribute defines the Color and Style of all the
70-- | A display attribute defines the Color and Style of all the
66-- characters rendered after the attribute is applied.
71-- characters rendered after the attribute is applied.
@@ -73,7 +78,8 @@ data Attr = Attr
73 { attrStyle :: !(MaybeDefault Style)
78 { attrStyle :: !(MaybeDefault Style)
74 , attrForeColor :: !(MaybeDefault Color)
79 , attrForeColor :: !(MaybeDefault Color)
75 , attrBackColor :: !(MaybeDefault Color)
80 , attrBackColor :: !(MaybeDefault Color)
81+ , attrURL :: !(MaybeDefault Text)
76− } deriving ( Eq, Show, Read )
82+ } deriving ( Eq, Show, Read, Generic, NFData )
77
83
78-- 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
79-- 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
@@ -94,25 +100,19 @@ data Attr = Attr
94-- __ - unused
100-- __ - unused
95--
101--
96-- Next is the style flags
102-- Next is the style flags
97−-- SURBDO__
103+-- SURBDOI_
98-- S - standout
104-- S - standout
99-- U - underline
105-- U - underline
100-- R - reverse video
106-- R - reverse video
101-- B - blink
107-- B - blink
102-- D - dim
108-- D - dim
103-- O - bold
109-- O - bold
110+-- I - italic
104−-- __ - unused
111+-- _ - unused
105--
112--
106-- Then the foreground color encoded into 8 bits.
113-- Then the foreground color encoded into 8 bits.
107-- Then the background color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
108
115
109−instance Monoid Attr where
110− mempty = Attr mempty mempty mempty
111− mappend attr0 attr1 =
112− Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
113− ( attrForeColor attr0 `mappend` attrForeColor attr1 )
114− ( attrBackColor attr0 `mappend` attrBackColor attr1 )
115−
116-- | Specifies the display attributes such that the final style and
116-- | Specifies the display attributes such that the final style and
117-- color values do not depend on the previously applied display
117-- color values do not depend on the previously applied display
118-- attribute. The display attributes can still depend on the terminal's
118-- attribute. The display attributes can still depend on the terminal's
@@ -121,38 +121,26 @@ data FixedAttr = FixedAttr
121 { fixedStyle :: !Style
121 { fixedStyle :: !Style
122 , fixedForeColor :: !(Maybe Color)
122 , fixedForeColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
124+ , fixedURL :: !(Maybe Text)
124 } deriving ( Eq, Show )
125 } deriving ( Eq, Show )
125
126
126-- | The style and color attributes can either be the terminal defaults.
127-- | The style and color attributes can either be the terminal defaults.
127-- 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
128-- value.
129-- value.
129−data MaybeDefault v where
130+data MaybeDefault v = Default | KeepCurrent | SetTo !v
130− Default :: MaybeDefault v
131+ deriving (Eq, Read, Show)
131− KeepCurrent :: MaybeDefault v
132+
132− SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
133−
134−deriving instance Eq v => Eq (MaybeDefault v)
135−deriving instance Eq v => Show (MaybeDefault v)
136−deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
137−
138−instance Eq v => Monoid ( MaybeDefault v ) where
133+instance (NFData v) => NFData (MaybeDefault v) where
139− mempty = KeepCurrent
134+ rnf Default = ()
140− mappend Default Default = Default
141− mappend Default KeepCurrent = Default
142− mappend Default ( SetTo v ) = SetTo v
143− mappend KeepCurrent Default = Default
144− mappend KeepCurrent KeepCurrent = KeepCurrent
135+ rnf KeepCurrent = ()
145− mappend KeepCurrent ( SetTo v ) = SetTo v
136+ rnf (SetTo v) = rnf v
146− mappend ( SetTo _v ) Default = Default
147− mappend ( SetTo v ) KeepCurrent = SetTo v
148− mappend ( SetTo _ ) ( SetTo v ) = SetTo v
149
137
150-- | 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
151-- 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
152-- if the style attribute should not be applied.
140-- if the style attribute should not be applied.
153type Style = Word8
141type Style = Word8
154
142
155−-- | The 6 possible style attributes:
143+-- | Valid style attributes include:
156--
144--
157-- * standout
145-- * standout
158--
146--
@@ -166,15 +154,21 @@ type Style = Word8
166--
154--
167-- * bold/bright
155-- * bold/bright
168--
156--
157+-- * italic
158+--
159+-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160+--
169-- (The invisible, protect, and altcharset display attributes some
161-- (The invisible, protect, and altcharset display attributes some
170-- terminals support are not supported via VTY.)
162-- terminals support are not supported via VTY.)
171−standout, underline, reverseVideo, blink, dim, bold :: Style
163+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
172standout = 0x01
164standout = 0x01
173underline = 0x02
165underline = 0x02
174−reverseVideo = 0x04
166+reverseVideo = 0x04
175blink = 0x08
167blink = 0x08
176dim = 0x10
168dim = 0x10
177bold = 0x20
169bold = 0x20
170+italic = 0x40
171+strikethrough = 0x80
178
172
179defaultStyleMask :: Style
173defaultStyleMask :: Style
180defaultStyleMask = 0x00
174defaultStyleMask = 0x00
@@ -200,13 +194,28 @@ withBackColor attr c = attr { attrBackColor = SetTo c }
200
194
201-- | Add the given style attribute
195-- | Add the given style attribute
202withStyle :: Attr -> Style -> Attr
196withStyle :: Attr -> Style -> Attr
197+withStyle attr 0 = attr
203withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
204
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+
205-- | Sets the style, background color and foreground color to the
214-- | Sets the style, background color and foreground color to the
206-- 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
207-- what the default background and foreground colors are.
216-- what the default background and foreground colors are.
208defAttr :: Attr
217defAttr :: Attr
209−defAttr = Attr Default Default Default
218+defAttr = Attr Default Default Default Default
210
219
211-- | Keeps the style, background color and foreground color that was
220-- | Keeps the style, background color and foreground color that was
212-- previously set. Used to override some part of the previous style.
221-- previously set. Used to override some part of the previous style.
@@ -216,4 +225,4 @@ defAttr = Attr Default Default Default
216-- 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
217-- with the foreground color set to brightMagenta.
226-- with the foreground color set to brightMagenta.
218currentAttr :: Attr
227currentAttr :: Attr
219−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
228+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs+96−5
@@ -1,5 +1,24 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE MultiWayIf #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+
1module Graphics.Vty.Attributes.Color
6module Graphics.Vty.Attributes.Color
2 ( 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`
3 , black
22 , black
4 , red
23 , red
5 , green
24 , green
@@ -8,6 +27,8 @@ module Graphics.Vty.Attributes.Color
8 , magenta
27 , magenta
9 , cyan
28 , cyan
10 , white
29 , white
30+
31+ -- | Bright/Vivid variants of the standard 8-color ANSI
11 , brightBlack
32 , brightBlack
12 , brightRed
33 , brightRed
13 , brightGreen
34 , brightGreen
@@ -16,10 +37,25 @@ module Graphics.Vty.Attributes.Color
16 , brightMagenta
37 , brightMagenta
17 , brightCyan
38 , brightCyan
18 , brightWhite
39 , brightWhite
40+ -- ** Creating Colors From RGB
41+ , linearColor
42+ , srgbColor
43+ , rgbColor
44+ , color240
45+ , module Graphics.Vty.Attributes.Color240
19 )
46 )
20where
47where
21
48
22import 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
23
59
24-- | Abstract data type representing a color.
60-- | Abstract data type representing a color.
25--
61--
@@ -59,7 +95,7 @@ import Data.Word
59-- reported then the color reproduction will be incorrect.
95-- reported then the color reproduction will be incorrect.
60--
96--
61-- If the terminal reports <= 16 colors then the 240 color palette
97-- If the terminal reports <= 16 colors then the 240 color palette
62−-- 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
63-- 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
64-- addressable via the 240 color palette.
100-- addressable via the 240 color palette.
65--
101--
@@ -73,10 +109,33 @@ import Data.Word
73-- terminfo but I don't know it.
109-- terminfo but I don't know it.
74--
110--
75-- Seriously, terminal color support is INSANE.
111-- Seriously, terminal color support is INSANE.
76−data Color = ISOColor !Word8 | Color240 !Word8
112+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8
77− 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
78
138
79−-- | Standard 8-color ANSI terminal color codes.
80black, red, green, yellow, blue, magenta, cyan, white :: Color
139black, red, green, yellow, blue, magenta, cyan, white :: Color
81black = ISOColor 0
140black = ISOColor 0
82red = ISOColor 1
141red = ISOColor 1
@@ -87,7 +146,6 @@ magenta= ISOColor 5
87cyan = ISOColor 6
146cyan = ISOColor 6
88white = ISOColor 7
147white = ISOColor 7
89
148
90−-- | Bright/Vivid variants of the standard 8-color ANSI
91brightBlack, brightRed, brightGreen, brightYellow :: Color
149brightBlack, brightRed, brightGreen, brightYellow :: Color
92brightBlue, brightMagenta, brightCyan, brightWhite :: Color
150brightBlue, brightMagenta, brightCyan, brightWhite :: Color
93brightBlack = ISOColor 8
151brightBlack = ISOColor 8
@@ -98,3 +156,36 @@ brightBlue = ISOColor 12
98brightMagenta= ISOColor 13
156brightMagenta= ISOColor 13
99brightCyan = ISOColor 14
157brightCyan = ISOColor 14
100brightWhite = ISOColor 15
158brightWhite = 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+285−248
@@ -1,261 +1,298 @@
1-- This header file was generated by ./256colres.pl
1-- This header file was generated by ./256colres.pl
2module Graphics.Vty.Attributes.Color240
2module Graphics.Vty.Attributes.Color240
3− ( rgbColor
3+ ( rgbColorToColor240
4+ , color240CodeToRGB
4 )
5 )
5where
6where
6
7
7−import Graphics.Vty.Attributes.Color
8+import Data.Word (Word8)
8−
9import Text.Printf
9import Text.Printf
10
10
11-- Note: rgbColor's mapping from RGB to 240 colors was generated from
11-- Note: rgbColor's mapping from RGB to 240 colors was generated from
12-- 256colres.pl which is forked from xterm 256colres.pl.
12-- 256colres.pl which is forked from xterm 256colres.pl.
13
13
14−-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.
14+-- | Create a value in the Color240 set from an RGB triple
15−rgbColor :: Integral i => i -> i -> i -> Color
15+rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
16−rgbColor r g b
16+rgbColorToColor240 r g b
17 | 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"
18− | r == 8 && g == 8 && b == 8 = Color240 216
18+ | r == 8 && g == 8 && b == 8 = 216
19− | r == 18 && g == 18 && b == 18 = Color240 217
19+ | r == 18 && g == 18 && b == 18 = 217
20− | r == 28 && g == 28 && b == 28 = Color240 218
20+ | r == 28 && g == 28 && b == 28 = 218
21− | r == 38 && g == 38 && b == 38 = Color240 219
21+ | r == 38 && g == 38 && b == 38 = 219
22− | r == 48 && g == 48 && b == 48 = Color240 220
22+ | r == 48 && g == 48 && b == 48 = 220
23− | r == 58 && g == 58 && b == 58 = Color240 221
23+ | r == 58 && g == 58 && b == 58 = 221
24− | r == 68 && g == 68 && b == 68 = Color240 222
24+ | r == 68 && g == 68 && b == 68 = 222
25− | r == 78 && g == 78 && b == 78 = Color240 223
25+ | r == 78 && g == 78 && b == 78 = 223
26− | r == 88 && g == 88 && b == 88 = Color240 224
26+ | r == 88 && g == 88 && b == 88 = 224
27− | r == 98 && g == 98 && b == 98 = Color240 225
27+ | r == 98 && g == 98 && b == 98 = 225
28− | r == 108 && g == 108 && b == 108 = Color240 226
28+ | r == 108 && g == 108 && b == 108 = 226
29− | r == 118 && g == 118 && b == 118 = Color240 227
29+ | r == 118 && g == 118 && b == 118 = 227
30− | r == 128 && g == 128 && b == 128 = Color240 228
30+ | r == 128 && g == 128 && b == 128 = 228
31− | r == 138 && g == 138 && b == 138 = Color240 229
31+ | r == 138 && g == 138 && b == 138 = 229
32− | r == 148 && g == 148 && b == 148 = Color240 230
32+ | r == 148 && g == 148 && b == 148 = 230
33− | r == 158 && g == 158 && b == 158 = Color240 231
33+ | r == 158 && g == 158 && b == 158 = 231
34− | r == 168 && g == 168 && b == 168 = Color240 232
34+ | r == 168 && g == 168 && b == 168 = 232
35− | r == 178 && g == 178 && b == 178 = Color240 233
35+ | r == 178 && g == 178 && b == 178 = 233
36− | r == 188 && g == 188 && b == 188 = Color240 234
36+ | r == 188 && g == 188 && b == 188 = 234
37− | r == 198 && g == 198 && b == 198 = Color240 235
37+ | r == 198 && g == 198 && b == 198 = 235
38− | r == 208 && g == 208 && b == 208 = Color240 236
38+ | r == 208 && g == 208 && b == 208 = 236
39− | r == 218 && g == 218 && b == 218 = Color240 237
39+ | r == 218 && g == 218 && b == 218 = 237
40− | r == 228 && g == 228 && b == 228 = Color240 238
40+ | r == 228 && g == 228 && b == 228 = 238
41− | r == 238 && g == 238 && b == 238 = Color240 239
41+ | r == 238 && g == 238 && b == 238 = 239
42− | r <= 0 && g <= 0 && b <= 0 = Color240 0
42+ | otherwise = 36 * go r + 6 * go g + go b
43− | 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."
44− | r <= 0 && g <= 0 && b <= 135 = Color240 2
45− | r <= 0 && g <= 0 && b <= 175 = Color240 3
46− | r <= 0 && g <= 0 && b <= 215 = Color240 4
47− | r <= 0 && g <= 0 && b <= 255 = Color240 5
48− | r <= 0 && g <= 95 && b <= 0 = Color240 6
49− | r <= 0 && g <= 95 && b <= 95 = Color240 7
50− | r <= 0 && g <= 95 && b <= 135 = Color240 8
51− | r <= 0 && g <= 95 && b <= 175 = Color240 9
52− | r <= 0 && g <= 95 && b <= 215 = Color240 10
53− | r <= 0 && g <= 95 && b <= 255 = Color240 11
54− | r <= 0 && g <= 135 && b <= 0 = Color240 12
55− | r <= 0 && g <= 135 && b <= 95 = Color240 13
56− | r <= 0 && g <= 135 && b <= 135 = Color240 14
57− | r <= 0 && g <= 135 && b <= 175 = Color240 15
58− | r <= 0 && g <= 135 && b <= 215 = Color240 16
59− | r <= 0 && g <= 135 && b <= 255 = Color240 17
60− | r <= 0 && g <= 175 && b <= 0 = Color240 18
61− | r <= 0 && g <= 175 && b <= 95 = Color240 19
62− | r <= 0 && g <= 175 && b <= 135 = Color240 20
63− | r <= 0 && g <= 175 && b <= 175 = Color240 21
64− | r <= 0 && g <= 175 && b <= 215 = Color240 22
65− | r <= 0 && g <= 175 && b <= 255 = Color240 23
66− | r <= 0 && g <= 215 && b <= 0 = Color240 24
67− | r <= 0 && g <= 215 && b <= 95 = Color240 25
68− | r <= 0 && g <= 215 && b <= 135 = Color240 26
69− | r <= 0 && g <= 215 && b <= 175 = Color240 27
70− | r <= 0 && g <= 215 && b <= 215 = Color240 28
71− | r <= 0 && g <= 215 && b <= 255 = Color240 29
72− | r <= 0 && g <= 255 && b <= 0 = Color240 30
73− | r <= 0 && g <= 255 && b <= 95 = Color240 31
74− | r <= 0 && g <= 255 && b <= 135 = Color240 32
75− | r <= 0 && g <= 255 && b <= 175 = Color240 33
76− | r <= 0 && g <= 255 && b <= 215 = Color240 34
77− | r <= 0 && g <= 255 && b <= 255 = Color240 35
78− | r <= 95 && g <= 0 && b <= 0 = Color240 36
79− | r <= 95 && g <= 0 && b <= 95 = Color240 37
80− | r <= 95 && g <= 0 && b <= 135 = Color240 38
81− | r <= 95 && g <= 0 && b <= 175 = Color240 39
82− | r <= 95 && g <= 0 && b <= 215 = Color240 40
83− | r <= 95 && g <= 0 && b <= 255 = Color240 41
84− | r <= 95 && g <= 95 && b <= 0 = Color240 42
85− | r <= 95 && g <= 95 && b <= 95 = Color240 43
86− | r <= 95 && g <= 95 && b <= 135 = Color240 44
87− | r <= 95 && g <= 95 && b <= 175 = Color240 45
88− | r <= 95 && g <= 95 && b <= 215 = Color240 46
89− | r <= 95 && g <= 95 && b <= 255 = Color240 47
90− | r <= 95 && g <= 135 && b <= 0 = Color240 48
91− | r <= 95 && g <= 135 && b <= 95 = Color240 49
92− | r <= 95 && g <= 135 && b <= 135 = Color240 50
93− | r <= 95 && g <= 135 && b <= 175 = Color240 51
94− | r <= 95 && g <= 135 && b <= 215 = Color240 52
95− | r <= 95 && g <= 135 && b <= 255 = Color240 53
96− | r <= 95 && g <= 175 && b <= 0 = Color240 54
97− | r <= 95 && g <= 175 && b <= 95 = Color240 55
98− | r <= 95 && g <= 175 && b <= 135 = Color240 56
99− | r <= 95 && g <= 175 && b <= 175 = Color240 57
100− | r <= 95 && g <= 175 && b <= 215 = Color240 58
101− | r <= 95 && g <= 175 && b <= 255 = Color240 59
102− | r <= 95 && g <= 215 && b <= 0 = Color240 60
103− | r <= 95 && g <= 215 && b <= 95 = Color240 61
104− | r <= 95 && g <= 215 && b <= 135 = Color240 62
105− | r <= 95 && g <= 215 && b <= 175 = Color240 63
106− | r <= 95 && g <= 215 && b <= 215 = Color240 64
107− | r <= 95 && g <= 215 && b <= 255 = Color240 65
108− | r <= 95 && g <= 255 && b <= 0 = Color240 66
109− | r <= 95 && g <= 255 && b <= 95 = Color240 67
110− | r <= 95 && g <= 255 && b <= 135 = Color240 68
111− | r <= 95 && g <= 255 && b <= 175 = Color240 69
112− | r <= 95 && g <= 255 && b <= 215 = Color240 70
113− | r <= 95 && g <= 255 && b <= 255 = Color240 71
114− | r <= 135 && g <= 0 && b <= 0 = Color240 72
115− | r <= 135 && g <= 0 && b <= 95 = Color240 73
116− | r <= 135 && g <= 0 && b <= 135 = Color240 74
117− | r <= 135 && g <= 0 && b <= 175 = Color240 75
118− | r <= 135 && g <= 0 && b <= 215 = Color240 76
119− | r <= 135 && g <= 0 && b <= 255 = Color240 77
120− | r <= 135 && g <= 95 && b <= 0 = Color240 78
121− | r <= 135 && g <= 95 && b <= 95 = Color240 79
122− | r <= 135 && g <= 95 && b <= 135 = Color240 80
123− | r <= 135 && g <= 95 && b <= 175 = Color240 81
124− | r <= 135 && g <= 95 && b <= 215 = Color240 82
125− | r <= 135 && g <= 95 && b <= 255 = Color240 83
126− | r <= 135 && g <= 135 && b <= 0 = Color240 84
127− | r <= 135 && g <= 135 && b <= 95 = Color240 85
128− | r <= 135 && g <= 135 && b <= 135 = Color240 86
129− | r <= 135 && g <= 135 && b <= 175 = Color240 87
130− | r <= 135 && g <= 135 && b <= 215 = Color240 88
131− | r <= 135 && g <= 135 && b <= 255 = Color240 89
132− | r <= 135 && g <= 175 && b <= 0 = Color240 90
133− | r <= 135 && g <= 175 && b <= 95 = Color240 91
134− | r <= 135 && g <= 175 && b <= 135 = Color240 92
135− | r <= 135 && g <= 175 && b <= 175 = Color240 93
136− | r <= 135 && g <= 175 && b <= 215 = Color240 94
137− | r <= 135 && g <= 175 && b <= 255 = Color240 95
138− | r <= 135 && g <= 215 && b <= 0 = Color240 96
139− | r <= 135 && g <= 215 && b <= 95 = Color240 97
140− | r <= 135 && g <= 215 && b <= 135 = Color240 98
141− | r <= 135 && g <= 215 && b <= 175 = Color240 99
142− | r <= 135 && g <= 215 && b <= 215 = Color240 100
143− | r <= 135 && g <= 215 && b <= 255 = Color240 101
144− | r <= 135 && g <= 255 && b <= 0 = Color240 102
145− | r <= 135 && g <= 255 && b <= 95 = Color240 103
146− | r <= 135 && g <= 255 && b <= 135 = Color240 104
147− | r <= 135 && g <= 255 && b <= 175 = Color240 105
148− | r <= 135 && g <= 255 && b <= 215 = Color240 106
149− | r <= 135 && g <= 255 && b <= 255 = Color240 107
150− | r <= 175 && g <= 0 && b <= 0 = Color240 108
151− | r <= 175 && g <= 0 && b <= 95 = Color240 109
152− | r <= 175 && g <= 0 && b <= 135 = Color240 110
153− | r <= 175 && g <= 0 && b <= 175 = Color240 111
154− | r <= 175 && g <= 0 && b <= 215 = Color240 112
155− | r <= 175 && g <= 0 && b <= 255 = Color240 113
156− | r <= 175 && g <= 95 && b <= 0 = Color240 114
157− | r <= 175 && g <= 95 && b <= 95 = Color240 115
158− | r <= 175 && g <= 95 && b <= 135 = Color240 116
159− | r <= 175 && g <= 95 && b <= 175 = Color240 117
160− | r <= 175 && g <= 95 && b <= 215 = Color240 118
161− | r <= 175 && g <= 95 && b <= 255 = Color240 119
162− | r <= 175 && g <= 135 && b <= 0 = Color240 120
163− | r <= 175 && g <= 135 && b <= 95 = Color240 121
164− | r <= 175 && g <= 135 && b <= 135 = Color240 122
165− | r <= 175 && g <= 135 && b <= 175 = Color240 123
166− | r <= 175 && g <= 135 && b <= 215 = Color240 124
167− | r <= 175 && g <= 135 && b <= 255 = Color240 125
168− | r <= 175 && g <= 175 && b <= 0 = Color240 126
169− | r <= 175 && g <= 175 && b <= 95 = Color240 127
170− | r <= 175 && g <= 175 && b <= 135 = Color240 128
171− | r <= 175 && g <= 175 && b <= 175 = Color240 129
172− | r <= 175 && g <= 175 && b <= 215 = Color240 130
173− | r <= 175 && g <= 175 && b <= 255 = Color240 131
174− | r <= 175 && g <= 215 && b <= 0 = Color240 132
175− | r <= 175 && g <= 215 && b <= 95 = Color240 133
176− | r <= 175 && g <= 215 && b <= 135 = Color240 134
177− | r <= 175 && g <= 215 && b <= 175 = Color240 135
178− | r <= 175 && g <= 215 && b <= 215 = Color240 136
179− | r <= 175 && g <= 215 && b <= 255 = Color240 137
180− | r <= 175 && g <= 255 && b <= 0 = Color240 138
181− | r <= 175 && g <= 255 && b <= 95 = Color240 139
182− | r <= 175 && g <= 255 && b <= 135 = Color240 140
183− | r <= 175 && g <= 255 && b <= 175 = Color240 141
184− | r <= 175 && g <= 255 && b <= 215 = Color240 142
185− | r <= 175 && g <= 255 && b <= 255 = Color240 143
186− | r <= 215 && g <= 0 && b <= 0 = Color240 144
187− | r <= 215 && g <= 0 && b <= 95 = Color240 145
188− | r <= 215 && g <= 0 && b <= 135 = Color240 146
189− | r <= 215 && g <= 0 && b <= 175 = Color240 147
190− | r <= 215 && g <= 0 && b <= 215 = Color240 148
191− | r <= 215 && g <= 0 && b <= 255 = Color240 149
192− | r <= 215 && g <= 95 && b <= 0 = Color240 150
193− | r <= 215 && g <= 95 && b <= 95 = Color240 151
194− | r <= 215 && g <= 95 && b <= 135 = Color240 152
195− | r <= 215 && g <= 95 && b <= 175 = Color240 153
196− | r <= 215 && g <= 95 && b <= 215 = Color240 154
197− | r <= 215 && g <= 95 && b <= 255 = Color240 155
198− | r <= 215 && g <= 135 && b <= 0 = Color240 156
199− | r <= 215 && g <= 135 && b <= 95 = Color240 157
200− | r <= 215 && g <= 135 && b <= 135 = Color240 158
201− | r <= 215 && g <= 135 && b <= 175 = Color240 159
202− | r <= 215 && g <= 135 && b <= 215 = Color240 160
203− | r <= 215 && g <= 135 && b <= 255 = Color240 161
204− | r <= 215 && g <= 175 && b <= 0 = Color240 162
205− | r <= 215 && g <= 175 && b <= 95 = Color240 163
206− | r <= 215 && g <= 175 && b <= 135 = Color240 164
207− | r <= 215 && g <= 175 && b <= 175 = Color240 165
208− | r <= 215 && g <= 175 && b <= 215 = Color240 166
209− | r <= 215 && g <= 175 && b <= 255 = Color240 167
210− | r <= 215 && g <= 215 && b <= 0 = Color240 168
211− | r <= 215 && g <= 215 && b <= 95 = Color240 169
212− | r <= 215 && g <= 215 && b <= 135 = Color240 170
213− | r <= 215 && g <= 215 && b <= 175 = Color240 171
214− | r <= 215 && g <= 215 && b <= 215 = Color240 172
215− | r <= 215 && g <= 215 && b <= 255 = Color240 173
216− | r <= 215 && g <= 255 && b <= 0 = Color240 174
217− | r <= 215 && g <= 255 && b <= 95 = Color240 175
218− | r <= 215 && g <= 255 && b <= 135 = Color240 176
219− | r <= 215 && g <= 255 && b <= 175 = Color240 177
220− | r <= 215 && g <= 255 && b <= 215 = Color240 178
221− | r <= 215 && g <= 255 && b <= 255 = Color240 179
222− | r <= 255 && g <= 0 && b <= 0 = Color240 180
223− | r <= 255 && g <= 0 && b <= 95 = Color240 181
224− | r <= 255 && g <= 0 && b <= 135 = Color240 182
225− | r <= 255 && g <= 0 && b <= 175 = Color240 183
226− | r <= 255 && g <= 0 && b <= 215 = Color240 184
227− | r <= 255 && g <= 0 && b <= 255 = Color240 185
228− | r <= 255 && g <= 95 && b <= 0 = Color240 186
229− | r <= 255 && g <= 95 && b <= 95 = Color240 187
230− | r <= 255 && g <= 95 && b <= 135 = Color240 188
231− | r <= 255 && g <= 95 && b <= 175 = Color240 189
232− | r <= 255 && g <= 95 && b <= 215 = Color240 190
233− | r <= 255 && g <= 95 && b <= 255 = Color240 191
234− | r <= 255 && g <= 135 && b <= 0 = Color240 192
235− | r <= 255 && g <= 135 && b <= 95 = Color240 193
236− | r <= 255 && g <= 135 && b <= 135 = Color240 194
237− | r <= 255 && g <= 135 && b <= 175 = Color240 195
238− | r <= 255 && g <= 135 && b <= 215 = Color240 196
239− | r <= 255 && g <= 135 && b <= 255 = Color240 197
240− | r <= 255 && g <= 175 && b <= 0 = Color240 198
241− | r <= 255 && g <= 175 && b <= 95 = Color240 199
242− | r <= 255 && g <= 175 && b <= 135 = Color240 200
243− | r <= 255 && g <= 175 && b <= 175 = Color240 201
244− | r <= 255 && g <= 175 && b <= 215 = Color240 202
245− | r <= 255 && g <= 175 && b <= 255 = Color240 203
246− | r <= 255 && g <= 215 && b <= 0 = Color240 204
247− | r <= 255 && g <= 215 && b <= 95 = Color240 205
248− | r <= 255 && g <= 215 && b <= 135 = Color240 206
249− | r <= 255 && g <= 215 && b <= 175 = Color240 207
250− | r <= 255 && g <= 215 && b <= 215 = Color240 208
251− | r <= 255 && g <= 215 && b <= 255 = Color240 209
252− | r <= 255 && g <= 255 && b <= 0 = Color240 210
253− | r <= 255 && g <= 255 && b <= 95 = Color240 211
254− | r <= 255 && g <= 255 && b <= 135 = Color240 212
255− | r <= 255 && g <= 255 && b <= 175 = Color240 213
256− | r <= 255 && g <= 255 && b <= 215 = Color240 214
257− | r <= 255 && g <= 255 && b <= 255 = Color240 215
258− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
259 (fromIntegral r :: Int)
44 (fromIntegral r :: Int)
260 (fromIntegral g :: Int)
45 (fromIntegral g :: Int)
261− (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
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+259−68
@@ -1,7 +1,9 @@
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 #-}
5-- | Vty supports a configuration file format and associated 'Config'
7-- | Vty supports a configuration file format and associated 'Config'
6-- data type. The 'Config' can be provided to 'mkVty' to customize the
8-- data type. The 'Config' can be provided to 'mkVty' to customize the
7-- application's use of Vty.
9-- application's use of Vty.
@@ -53,7 +55,33 @@
53-- 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
54-- table to the log in the above format. A workflow for using this is
56-- table to the log in the above format. A workflow for using this is
55-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
57-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
56−-- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.
58+-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.
59+--
60+-- = Unicode Character Width Maps
61+--
62+-- == @widthMap@
63+--
64+-- Format:
65+--
66+-- @
67+-- \"widthMap\" string string
68+-- @
69+--
70+-- E.g.,
71+--
72+-- @
73+-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"
74+-- @
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.
57module Graphics.Vty.Config
85module Graphics.Vty.Config
58 ( InputMap
86 ( InputMap
59 , Config(..)
87 , Config(..)
@@ -64,6 +92,17 @@ module Graphics.Vty.Config
64 , runParseConfig
92 , runParseConfig
65 , parseConfigFile
93 , parseConfigFile
66 , defaultConfig
94 , defaultConfig
95+ , getTtyEraseChar
96+ , currentTerminalName
97+
98+ , vtyConfigPath
99+ , widthTableFilename
100+ , vtyDataDirectory
101+ , terminalWidthTablePath
102+ , vtyConfigFileEnvName
103+
104+ , ConfigUpdateResult(..)
105+ , addConfigWidthMap
67 )
106 )
68where
107where
69
108
@@ -75,29 +114,40 @@ import Control.Exception (catch, IOException, Exception(..), throwIO)
75import Control.Monad (liftM, guard, void)
114import Control.Monad (liftM, guard, void)
76
115
77import qualified Data.ByteString as BS
116import qualified Data.ByteString as BS
117+#if !(MIN_VERSION_base(4,8,0))
78−import Data.Monoid
118+import Data.Monoid (Monoid(..))
119+#endif
120+#if !(MIN_VERSION_base(4,11,0))
121+import Data.Semigroup (Semigroup(..))
122+#endif
79import Data.Typeable (Typeable)
123import Data.Typeable (Typeable)
80
124
81import Graphics.Vty.Input.Events
125import Graphics.Vty.Input.Events
126+import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
82
127
83import GHC.Generics
128import GHC.Generics
84
129
85−import System.Directory (getAppUserDataDirectory)
130+import System.Directory ( getAppUserDataDirectory, doesFileExist
131+ , createDirectoryIfMissing
132+ )
86−import System.Posix.Env (getEnv)
133+import System.Environment (lookupEnv)
134+import System.FilePath ((</>), takeDirectory)
87import System.Posix.IO (stdInput, stdOutput)
135import System.Posix.IO (stdInput, stdOutput)
88import System.Posix.Types (Fd(..))
136import System.Posix.Types (Fd(..))
137+import Foreign.C.Types (CInt(..), CChar(..))
89
138
90import Text.Parsec hiding ((<|>))
139import Text.Parsec hiding ((<|>))
91import Text.Parsec.Token ( GenLanguageDef(..) )
140import Text.Parsec.Token ( GenLanguageDef(..) )
92import qualified Text.Parsec.Token as P
141import qualified Text.Parsec.Token as P
93
142
94-- | Type of errors that can be thrown when configuring VTY
143-- | Type of errors that can be thrown when configuring VTY
95−data VtyConfigurationError
144+data VtyConfigurationError =
145+ VtyMissingTermEnvVar
96− = VtyMissingTermEnvVar -- ^ TERM environment variable not set
146+ -- ^ TERM environment variable not set
97− deriving (Show, Eq, Typeable)
147+ deriving (Show, Eq, Typeable)
98
148
99instance Exception VtyConfigurationError where
149instance Exception VtyConfigurationError where
100− displayException VtyMissingTermEnvVar = "TERM environment variable not set"
150+ displayException VtyMissingTermEnvVar = "TERM environment variable not set"
101
151
102-- | Mappings from input bytes to event in the order specified. Later
152-- | Mappings from input bytes to event in the order specified. Later
103-- entries take precedence over earlier in the case multiple entries
153-- entries take precedence over earlier in the case multiple entries
@@ -105,85 +155,144 @@ instance Exception VtyConfigurationError where
105type InputMap = [(Maybe String, String, Event)]
155type InputMap = [(Maybe String, String, Event)]
106
156
107-- | A Vty configuration.
157-- | A Vty configuration.
108−data Config = Config
158+data Config =
109− {
110− -- | The default is 1 character.
111− vmin :: Maybe Int
159+ Config { vmin :: Maybe Int
160+ -- ^ The default is 1 character.
161+ , vtime :: Maybe Int
112− -- | The default is 100 milliseconds, 0.1 seconds.
162+ -- ^ The default is 100 milliseconds, 0.1 seconds.
113− , vtime :: Maybe Int
114− -- | The default is False.
115− , mouseMode :: Maybe Bool
163+ , mouseMode :: Maybe Bool
116− -- | The default is False.
164+ -- ^ The default is False.
117− , bracketedPasteMode :: Maybe Bool
165+ , bracketedPasteMode :: Maybe Bool
166+ -- ^ The default is False.
167+ , debugLog :: Maybe FilePath
118− -- | Debug information is appended to this file if not Nothing.
168+ -- ^ Debug information is appended to this file if not
119− , debugLog :: Maybe FilePath
169+ -- Nothing.
170+ , inputMap :: InputMap
120− -- | The (input byte, output event) pairs extend the internal input
171+ -- ^ The (input byte, output event) pairs extend the internal
121− -- table of VTY and the table from terminfo.
172+ -- input table of VTY and the table from terminfo.
122− --
173+ --
123− -- See "Graphics.Vty.Config" module documentation for documentation
174+ -- See "Graphics.Vty.Config" module documentation for
124− -- of the @map@ directive.
175+ -- documentation of the @map@ directive.
125− , inputMap :: InputMap
126− -- | The input file descriptor to use. The default is
127− -- 'System.Posix.IO.stdInput'
128− , inputFd :: Maybe Fd
176+ , inputFd :: Maybe Fd
129− -- | The output file descriptor to use. The default is
177+ -- ^ The input file descriptor to use. The default is
130− -- 'System.Posix.IO.stdOutput'
178+ -- 'System.Posix.IO.stdInput'
131− , outputFd :: Maybe Fd
179+ , outputFd :: Maybe Fd
180+ -- ^ The output file descriptor to use. The default is
181+ -- 'System.Posix.IO.stdOutput'
182+ , termName :: Maybe String
132− -- | The terminal name used to look up terminfo capabilities.
183+ -- ^ The terminal name used to look up terminfo capabilities.
133− -- The default is the value of the TERM environment variable.
184+ -- The default is the value of the TERM environment variable.
134− , 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+ }
135− } deriving (Show, Eq)
202+ deriving (Show, Eq)
136
203
137defaultConfig :: Config
204defaultConfig :: Config
138defaultConfig = mempty
205defaultConfig = mempty
139
206
140−instance Monoid Config where
207+instance Semigroup Config where
141− mempty = Config
208+ c0 <> c1 =
142− { vmin = Nothing
143− , vtime = Nothing
144− , mouseMode = Nothing
145− , bracketedPasteMode = Nothing
146− , debugLog = mempty
147− , inputMap = mempty
148− , inputFd = Nothing
149− , outputFd = Nothing
150− , termName = Nothing
151− }
152− mappend c0 c1 = Config
153 -- latter config takes priority for everything but inputMap
209 -- latter config takes priority for everything but inputMap
154− { vmin = vmin c1 <|> vmin c0
210+ Config { vmin = vmin c1 <|> vmin c0
155− , vtime = vtime c1 <|> vtime c0
211+ , vtime = vtime c1 <|> vtime c0
156− , mouseMode = mouseMode c1
212+ , mouseMode = mouseMode c1
157− , bracketedPasteMode = bracketedPasteMode c1
213+ , bracketedPasteMode = bracketedPasteMode c1
158− , debugLog = debugLog c1 <|> debugLog c0
214+ , debugLog = debugLog c1 <|> debugLog c0
159− , inputMap = inputMap c0 <> inputMap c1
215+ , inputMap = inputMap c0 <> inputMap c1
160− , inputFd = inputFd c1 <|> inputFd c0
216+ , inputFd = inputFd c1 <|> inputFd c0
161− , outputFd = outputFd c1 <|> outputFd c0
217+ , outputFd = outputFd c1 <|> outputFd c0
162− , termName = termName c1 <|> termName 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+ }
224+
225+instance Monoid Config where
226+ mempty =
227+ Config { vmin = Nothing
228+ , vtime = Nothing
229+ , mouseMode = Nothing
230+ , bracketedPasteMode = Nothing
231+ , debugLog = mempty
232+ , inputMap = mempty
233+ , inputFd = Nothing
234+ , outputFd = Nothing
235+ , termName = Nothing
236+ , termWidthMaps = []
237+ , allowCustomUnicodeWidthTables = Nothing
238+ , colorMode = Nothing
163− }
239+ }
164−
240+#if !(MIN_VERSION_base(4,11,0))
241+ mappend = (<>)
242+#endif
243+
244+vtyDataDirectory :: IO FilePath
245+vtyDataDirectory = getAppUserDataDirectory "vty"
246+
247+vtyConfigPath :: IO FilePath
248+vtyConfigPath = do
249+ dir <- vtyDataDirectory
250+ return $ dir </> "config"
251+
252+vtyConfigFileEnvName :: String
253+vtyConfigFileEnvName = "VTY_CONFIG_FILE"
254+
165−-- | Load a configuration from @'getAppUserDataDirectory'/config@ and
255+-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
166−-- @$VTY_CONFIG_FILE@.
167userConfig :: IO Config
256userConfig :: IO Config
168userConfig = do
257userConfig = do
169− configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
258+ configFile <- vtyConfigPath >>= parseConfigFile
170− overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
259+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
260+ lookupEnv vtyConfigFileEnvName
171 let base = configFile <> overrideConfig
261 let base = configFile <> overrideConfig
172 mappend base <$> overrideEnvConfig
262 mappend base <$> overrideEnvConfig
173
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+
174overrideEnvConfig :: IO Config
282overrideEnvConfig :: IO Config
175overrideEnvConfig = do
283overrideEnvConfig = do
176− d <- getEnv "VTY_DEBUG_LOG"
284+ d <- lookupEnv "VTY_DEBUG_LOG"
177 return $ defaultConfig { debugLog = d }
285 return $ defaultConfig { debugLog = d }
178
286
179-- | Configures VTY using defaults suitable for terminals. This function
287-- | Configures VTY using defaults suitable for terminals. This function
180-- can raise 'VtyConfigurationError'.
288-- can raise 'VtyConfigurationError'.
181standardIOConfig :: IO Config
289standardIOConfig :: IO Config
182standardIOConfig = do
290standardIOConfig = do
183− mb <- getEnv "TERM"
291+ mb <- lookupEnv termVariable
184 case mb of
292 case mb of
185 Nothing -> throwIO VtyMissingTermEnvVar
293 Nothing -> throwIO VtyMissingTermEnvVar
186− Just t ->
294+ Just t -> do
295+ mcolorMode <- detectColorMode t
187 return defaultConfig
296 return defaultConfig
188 { vmin = Just 1
297 { vmin = Just 1
189 , mouseMode = Just False
298 , mouseMode = Just False
@@ -192,6 +301,7 @@ standardIOConfig = do
192 , inputFd = Just stdInput
301 , inputFd = Just stdInput
193 , outputFd = Just stdOutput
302 , outputFd = Just stdOutput
194 , termName = Just t
303 , termName = Just t
304+ , colorMode = Just mcolorMode
195 }
305 }
196
306
197parseConfigFile :: FilePath -> IO Config
307parseConfigFile :: FilePath -> IO Config
@@ -243,13 +353,20 @@ debugLogDecl = do
243 path <- P.stringLiteral configLexer
353 path <- P.stringLiteral configLexer
244 return defaultConfig { debugLog = Just path }
354 return defaultConfig { debugLog = Just path }
245
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)] }
362+
246ignoreLine :: Parser ()
363ignoreLine :: Parser ()
247ignoreLine = void $ manyTill anyChar newline
364ignoreLine = void $ manyTill anyChar newline
248
365
249parseConfig :: Parser Config
366parseConfig :: Parser Config
250parseConfig = liftM mconcat $ many $ do
367parseConfig = liftM mconcat $ many $ do
251 P.whiteSpace configLexer
368 P.whiteSpace configLexer
252− let directives = [try mapDecl, try debugLogDecl]
369+ let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]
253 choice directives <|> (ignoreLine >> return defaultConfig)
370 choice directives <|> (ignoreLine >> return defaultConfig)
254
371
255class Parse a where parseValue :: Parser a
372class Parse a where parseValue :: Parser a
@@ -295,3 +412,77 @@ instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
295 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
412 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
296
413
297instance 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+33−16
@@ -1,5 +1,4 @@
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 #-}
5-- | A Vty program makes 'Picture's from 'Image's. This module provides
4-- | A Vty program makes 'Picture's from 'Image's. This module provides
@@ -46,8 +45,12 @@ module Graphics.Vty.Image
46 -- * Character width functions
45 -- * Character width functions
47 , safeWcwidth
46 , safeWcwidth
48 , safeWcswidth
47 , safeWcswidth
48+ , safeWctwidth
49+ , safeWctlwidth
49 , wcwidth
50 , wcwidth
50 , wcswidth
51 , wcswidth
52+ , wctwidth
53+ , wctlwidth
51 -- * Display Regions
54 -- * Display Regions
52 , DisplayText
55 , DisplayText
53 , DisplayRegion
56 , DisplayRegion
@@ -113,14 +116,18 @@ horizCat = foldr horizJoin EmptyImage
113vertCat :: [Image] -> Image
116vertCat :: [Image] -> Image
114vertCat = foldr vertJoin EmptyImage
117vertCat = foldr vertJoin EmptyImage
115
118
116−-- | Make an 'Image' from a lazy text 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.
117text :: Attr -> TL.Text -> Image
122text :: Attr -> TL.Text -> Image
118−text a txt = let displayWidth = safeWcswidth (TL.unpack txt)
123+text a txt = let displayWidth = safeWctlwidth txt
119 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
120
125
121−-- | Make an 'Image' from a 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.
122text' :: Attr -> T.Text -> Image
129text' :: Attr -> T.Text -> Image
123−text' a txt = let displayWidth = safeWcswidth (T.unpack txt)
130+text' a txt = let displayWidth = safeWctwidth txt
124 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
125
132
126-- | Make an image from a single character. This is a standard Haskell
133-- | Make an image from a single character. This is a standard Haskell
@@ -130,9 +137,11 @@ char a c =
130 let displayWidth = safeWcwidth c
137 let displayWidth = safeWcwidth c
131 in HorizText a (TL.singleton c) displayWidth 1
138 in HorizText a (TL.singleton c) displayWidth 1
132
139
133−-- | Make an image from a string of characters layed out on a single
140+-- | Make an image from a string of characters laid out on a single
134-- row with the same display attribute. The string is assumed to be a
141-- row with the same display attribute. The string is assumed to be a
135−-- sequence of 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.
136--
145--
137-- Note: depending on how the Haskell compiler represents string
146-- Note: depending on how the Haskell compiler represents string
138-- 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
@@ -166,11 +175,14 @@ utf8String a bytes = utf8Bytestring a (BL.pack bytes)
166utf8Bytestring :: Attr -> BL.ByteString -> Image
175utf8Bytestring :: Attr -> BL.ByteString -> Image
167utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
168
177
169−-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
178+-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
170utf8Bytestring' :: Attr -> B.ByteString -> Image
179utf8Bytestring' :: Attr -> B.ByteString -> Image
171utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
172
181
173-- | Make an image filling a region with the specified character.
182-- | Make an image filling a region with the specified character.
183+--
184+-- If either the width or height are less than or equal to 0, then
185+-- the result is the empty image.
174charFill :: Integral d
186charFill :: Integral d
175 => Attr
187 => Attr
176 -- ^ The attribute to use.
188 -- ^ The attribute to use.
@@ -181,14 +193,17 @@ charFill :: Integral d
181 -> d
193 -> d
182 -- ^ The region height.
194 -- ^ The region height.
183 -> Image
195 -> Image
184−charFill _a _c 0 _h = EmptyImage
196+charFill a c w h
185−charFill _a _c _w 0 = EmptyImage
197+ | w <= 0 || h <= 0 = EmptyImage
186−charFill a c w h =
198+ | otherwise = vertCat
199+ $ replicate (fromIntegral h)
187− vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth
200+ $ HorizText a txt displayWidth charWidth
188− where
201+ where
189− txt = TL.replicate (fromIntegral w) (TL.singleton c)
202+ txt = TL.replicate charWidth (TL.singleton c)
190− displayWidth = safeWcwidth c * (fromIntegral w)
203+ displayWidth = safeWcwidth c * charWidth
204+
205+ charWidth :: Num a => a
191− charWidth = fromIntegral w
206+ charWidth = fromIntegral w
192
207
193-- | The empty image. Useful for fold combinators. These occupy no space
208-- | The empty image. Useful for fold combinators. These occupy no space
194-- and do not affect display attributes.
209-- and do not affect display attributes.
@@ -242,6 +257,7 @@ translate x y i = translateX x (translateY y i)
242-- | Translates an image by padding or cropping its left side.
257-- | Translates an image by padding or cropping its left side.
243translateX :: Int -> Image -> Image
258translateX :: Int -> Image -> Image
244translateX x i
259translateX x i
260+ | x < 0 && (abs x > imageWidth i) = emptyImage
245 | 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)
246 | x == 0 = i
262 | x == 0 = i
247 | 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
@@ -249,6 +265,7 @@ translateX x i
249-- | Translates an image by padding or cropping its top.
265-- | Translates an image by padding or cropping its top.
250translateY :: Int -> Image -> Image
266translateY :: Int -> Image -> Image
251translateY y i
267translateY y i
268+ | y < 0 && (abs y > imageHeight i) = emptyImage
252 | 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)
253 | y == 0 = i
270 | y == 0 = i
254 | 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)
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+28−17
@@ -1,5 +1,3 @@
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.
@@ -48,22 +46,33 @@ 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 then 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.
@@ -71,16 +80,18 @@ applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
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,14 +104,14 @@ 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
src/Graphics/Vty/Input.hs+14−23
@@ -1,4 +1,4 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
2
2
3-- | This module provides the input layer for Vty, including methods
3-- | This module provides the input layer for Vty, including methods
4-- for initializing an 'Input' structure and reading 'Event's from the
4-- for initializing an 'Input' structure and reading 'Event's from the
@@ -77,7 +77,7 @@
77-- The input encoding determines how UTF-8 encoded characters are
77-- The input encoding determines how UTF-8 encoded characters are
78-- recognized.
78-- recognized.
79--
79--
80−-- * 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
81-- 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
82-- sequences. However, the escape key must be differentiated from
82-- sequences. However, the escape key must be differentiated from
83-- escaped control key sequences by the timing of the input bytes.
83-- escaped control key sequences by the timing of the input bytes.
@@ -95,7 +95,7 @@
95--
95--
96-- == Terminal Input is Broken
96-- == Terminal Input is Broken
97--
97--
98−-- Clearly terminal input has fundemental issues. There is no easy way
98+-- Clearly terminal input has fundamental issues. There is no easy way
99-- to reliably resolve these issues.
99-- to reliably resolve these issues.
100--
100--
101-- One resolution would be to ditch standard terminal interfaces
101-- One resolution would be to ditch standard terminal interfaces
@@ -132,7 +132,9 @@ import Lens.Micro
132import qualified System.Console.Terminfo as Terminfo
132import qualified System.Console.Terminfo as Terminfo
133import System.Posix.Signals.Exts
133import System.Posix.Signals.Exts
134
134
135+#if !MIN_VERSION_base(4,11,0)
135import Data.Monoid ((<>))
136import Data.Monoid ((<>))
137+#endif
136
138
137-- | Set up the terminal with file descriptor `inputFd` for input.
139-- | Set up the terminal with file descriptor `inputFd` for input.
138-- Returns an 'Input'.
140-- Returns an 'Input'.
@@ -141,22 +143,8 @@ import Data.Monoid ((<>))
141-- bytes comes from 'classifyMapForTerm' which is then overridden by
143-- bytes comes from 'classifyMapForTerm' which is then overridden by
142-- the the applicable entries from the configuration's 'inputMap'.
144-- the the applicable entries from the configuration's 'inputMap'.
143--
145--
144−-- The terminal device is configured with the attributes:
146+-- The terminal device's mode flags are configured by the
145−--
147+-- 'attributeControl' function.
146−-- * IXON disabled: disables software flow control on outgoing data.
147−-- This stops the process from being suspended if the output terminal
148−-- cannot keep up.
149−--
150−-- * Raw mode is used for input.
151−--
152−-- * ISIG disabled (enables keyboard combinations that result in
153−-- signals)
154−--
155−-- * ECHO disabled (input is not echoed to the output)
156−--
157−-- * ICANON disabled (canonical mode (line mode) input is not used)
158−--
159−-- * IEXTEN disabled (extended functions are disabled)
160inputForConfig :: Config -> IO Input
148inputForConfig :: Config -> IO Input
161inputForConfig config@Config{ termName = Just termName
149inputForConfig config@Config{ termName = Just termName
162 , inputFd = Just termFd
150 , inputFd = Just termFd
@@ -166,20 +154,23 @@ inputForConfig config@Config{ termName = Just termName
166 terminal <- Terminfo.setupTerm termName
154 terminal <- Terminfo.setupTerm termName
167 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]
168 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
169− (setAttrs,unsetAttrs) <- attributeControl termFd
157+ (setAttrs, unsetAttrs) <- attributeControl termFd
170 setAttrs
158 setAttrs
171 input <- initInput config activeInputMap
159 input <- initInput config activeInputMap
172 let pokeIO = Catch $ do
160 let pokeIO = Catch $ do
173− let e = error "vty internal failure: this value should not propagate to users"
174 setAttrs
161 setAttrs
175− atomically $ writeTChan (input^.eventChannel) (EvResize e e)
162+ atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
176 _ <- installHandler windowChange pokeIO Nothing
163 _ <- installHandler windowChange pokeIO Nothing
177 _ <- installHandler continueProcess pokeIO Nothing
164 _ <- installHandler continueProcess pokeIO Nothing
165+
166+ let restore = unsetAttrs
167+
178 return $ input
168 return $ input
179 { shutdownInput = do
169 { shutdownInput = do
180 shutdownInput input
170 shutdownInput input
181 _ <- installHandler windowChange Ignore Nothing
171 _ <- installHandler windowChange Ignore Nothing
182 _ <- installHandler continueProcess Ignore Nothing
172 _ <- installHandler continueProcess Ignore Nothing
183− unsetAttrs
173+ restore
174+ , restoreInputState = restoreInputState input >> restore
184 }
175 }
185inputForConfig 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+6−4
@@ -74,7 +74,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])
74ctrlChars :: ClassifyMap
74ctrlChars :: ClassifyMap
75ctrlChars =
75ctrlChars =
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
77− | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
77+ | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
79 , y /= 'h' -- CTRL-h should not hide BS
79 , y /= 'h' -- CTRL-h should not hide BS
80 ]
80 ]
@@ -86,10 +86,12 @@ ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
86-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
86-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
87specialSupportKeys :: ClassifyMap
87specialSupportKeys :: ClassifyMap
88specialSupportKeys =
88specialSupportKeys =
89+ [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90+ , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
89− [ -- special support for ESC
91+ -- special support for ESC
90− ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
92+ , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
91 -- Special support for backspace
93 -- Special support for backspace
92− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
94+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
93 -- Special support for Enter
95 -- Special support for Enter
94 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
95 -- explicit support for tab
97 -- explicit support for tab
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+15−14
@@ -1,5 +1,4 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
2−{-# LANGUAGE NamedFieldPuns #-}
3-- | This module provides functions for accessing the current terminal
2-- | This module provides functions for accessing the current terminal
4-- or a specific terminal device.
3-- or a specific terminal device.
5--
4--
@@ -38,10 +37,11 @@ import Graphics.Vty.Output.TerminfoBased as TerminfoBased
38
37
39import Blaze.ByteString.Builder (writeToByteString)
38import Blaze.ByteString.Builder (writeToByteString)
40
39
41−import Control.Monad.Trans
42−
43import Data.List (isPrefixOf)
40import Data.List (isPrefixOf)
41+
42+#if !MIN_VERSION_base(4,11,0)
44import Data.Monoid ((<>))
43import Data.Monoid ((<>))
44+#endif
45
45
46-- | Returns an `Output` for the terminal specified in `Config`.
46-- | Returns an `Output` for the terminal specified in `Config`.
47--
47--
@@ -58,11 +58,12 @@ import Data.Monoid ((<>))
58-- * If TERM contains "xterm" or "screen", use XTermColor.
58-- * If TERM contains "xterm" or "screen", use XTermColor.
59-- * otherwise use the TerminfoBased driver.
59-- * otherwise use the TerminfoBased driver.
60outputForConfig :: Config -> IO Output
60outputForConfig :: Config -> IO Output
61−outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do
61+outputForConfig Config{ outputFd = Just fd, termName = Just termName
62+ , colorMode = Just colorMode, .. } = do
62 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
63− then XTermColor.reserveTerminal termName fd
64+ then XTermColor.reserveTerminal termName fd colorMode
64 -- Not an xterm-like terminal. try for generic terminfo.
65 -- Not an xterm-like terminal. try for generic terminfo.
65− else TerminfoBased.reserveTerminal termName fd
66+ else TerminfoBased.reserveTerminal termName fd colorMode
66
67
67 case mouseMode of
68 case mouseMode of
68 Just s -> setMode t Mouse s
69 Just s -> setMode t Mouse s
@@ -77,30 +78,30 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
77
78
78-- | Sets the cursor position to the given output column and row.
79-- | Sets the cursor position to the given output column and row.
79--
80--
80−-- 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
81-- same coordinates. Characters can be a variable number of columns in
82-- same coordinates. Characters can be a variable number of columns in
82-- width.
83-- width.
83--
84--
84-- 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
85-- character coordinate is to specify the coordinate in the Picture
86-- character coordinate is to specify the coordinate in the Picture
86-- instance provided to 'outputPicture' or 'refresh'.
87-- instance provided to 'outputPicture' or 'refresh'.
87−setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()
88+setCursorPos :: Output -> Int -> Int -> IO ()
88setCursorPos t x y = do
89setCursorPos t x y = do
89 bounds <- displayBounds t
90 bounds <- displayBounds t
90 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
91 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
91 dc <- displayContext t bounds
92 dc <- displayContext t bounds
92− liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
93+ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
93
94
94-- | Hides the cursor.
95-- | Hides the cursor.
95−hideCursor :: MonadIO m => Output -> m ()
96+hideCursor :: Output -> IO ()
96hideCursor t = do
97hideCursor t = do
97 bounds <- displayBounds t
98 bounds <- displayBounds t
98 dc <- displayContext t bounds
99 dc <- displayContext t bounds
99− liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
100+ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
100
101
101-- | Shows the cursor.
102-- | Shows the cursor.
102−showCursor :: MonadIO m => Output -> m ()
103+showCursor :: Output -> IO ()
103showCursor t = do
104showCursor t = do
104 bounds <- displayBounds t
105 bounds <- displayBounds t
105 dc <- displayContext t bounds
106 dc <- displayContext t bounds
106− liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
107+ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+88−52
@@ -1,9 +1,9 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2−{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7-- | This module provides an abstract interface for performing terminal
7-- | This module provides an abstract interface for performing terminal
8-- output. The only user-facing part of this API is 'Output'.
8-- output. The only user-facing part of this API is 'Output'.
9module Graphics.Vty.Output.Interface
9module Graphics.Vty.Output.Interface
@@ -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
@@ -44,6 +42,15 @@ data Mode = Mouse
44 | BracketedPaste
42 | BracketedPaste
45 -- ^ Paste mode (whether the terminal is configured to provide
43 -- ^ Paste mode (whether the terminal is configured to provide
46 -- events on OS pastes)
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.
47 deriving (Eq, Read, Show)
54 deriving (Eq, Read, Show)
48
55
49-- | The Vty terminal output interface.
56-- | The Vty terminal output interface.
@@ -52,7 +59,7 @@ data Output = Output
52 terminalID :: String
59 terminalID :: String
53 -- | Release the terminal just prior to application exit and reset
60 -- | Release the terminal just prior to application exit and reset
54 -- it to its state prior to application startup.
61 -- it to its state prior to application startup.
55− , releaseTerminal :: forall m. MonadIO m => m ()
62+ , releaseTerminal :: IO ()
56 -- | Clear the display and initialize the terminal to some initial
63 -- | Clear the display and initialize the terminal to some initial
57 -- display state.
64 -- display state.
58 --
65 --
@@ -62,40 +69,57 @@ data Output = Output
62 -- - cursor at top left
69 -- - cursor at top left
63 -- - UTF-8 character encoding
70 -- - UTF-8 character encoding
64 -- - drawing characteristics are the default
71 -- - drawing characteristics are the default
65− , reserveDisplay :: forall m. MonadIO m => m ()
72+ , reserveDisplay :: IO ()
66 -- | Return the display to the state before `reserveDisplay` If no
73 -- | Return the display to the state before `reserveDisplay` If no
67 -- previous state then set the display state to the initial state.
74 -- previous state then set the display state to the initial state.
68− , releaseDisplay :: forall m. MonadIO m => m ()
75+ , releaseDisplay :: IO ()
76+ -- | Sets the current display bounds (width, height).
77+ , setDisplayBounds :: (Int, Int) -> IO ()
69 -- | Returns the current display bounds.
78 -- | Returns the current display bounds.
70− , displayBounds :: forall m. MonadIO m => m DisplayRegion
79+ , displayBounds :: IO DisplayRegion
71 -- | Output the bytestring to the terminal device.
80 -- | Output the bytestring to the terminal device.
72 , outputByteBuffer :: BS.ByteString -> IO ()
81 , outputByteBuffer :: BS.ByteString -> IO ()
73− -- | Specifies the maximum number of colors supported by the
74− -- context.
75− , contextColorCount :: Int
76 -- | Specifies whether 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
@@ -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 ()
@@ -154,24 +178,24 @@ writeUtf8Text = writeByteString
154-- 4. Serialized to the display.
178-- 4. Serialized to the display.
155--
179--
156-- 5. 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 $ affectedRegion ops) True
192 Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
168 Just previousOps -> if affectedRegion previousOps /= affectedRegion 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+8−4
@@ -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 matche the expected sequence. The
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+190−63
@@ -1,5 +1,6 @@
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
@@ -8,10 +9,13 @@
8-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
9module Graphics.Vty.Output.TerminfoBased
10module Graphics.Vty.Output.TerminfoBased
10 ( reserveTerminal
11 ( reserveTerminal
12+ , setWindowSize
11 )
13 )
12where
14where
13
15
14import Control.Monad (when)
16import Control.Monad (when)
17+import Data.Bits (shiftL, (.&.))
18+import qualified Data.ByteString as BS
15import Data.ByteString.Internal (toForeignPtr)
19import Data.ByteString.Internal (toForeignPtr)
16import Data.Terminfo.Parse
20import Data.Terminfo.Parse
17import Data.Terminfo.Eval
21import Data.Terminfo.Eval
@@ -21,15 +25,16 @@ import Graphics.Vty.Image (DisplayRegion)
21import Graphics.Vty.DisplayAttributes
25import Graphics.Vty.DisplayAttributes
22import Graphics.Vty.Output.Interface
26import Graphics.Vty.Output.Interface
23
27
24−import Blaze.ByteString.Builder (Write, writeToByteString)
28+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
25
29
26−import Control.Monad.Trans
27−
28−import Data.Bits ((.&.))
29import Data.IORef
30import Data.IORef
30import Data.Maybe (isJust, isNothing, fromJust)
31import Data.Maybe (isJust, isNothing, fromJust)
31import Data.Word
32import Data.Word
32
33
34+#if !MIN_VERSION_base(4,8,0)
35+import Data.Foldable (foldMap)
36+#endif
37+
33import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.C.Types ( CInt(..), CLong(..) )
34import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.ForeignPtr (withForeignPtr)
35import Foreign.Ptr (Ptr, plusPtr)
40import Foreign.Ptr (Ptr, plusPtr)
@@ -44,7 +49,6 @@ data TerminfoCaps = TerminfoCaps
44 , cup :: CapExpression
49 , cup :: CapExpression
45 , cnorm :: Maybe CapExpression
50 , cnorm :: Maybe CapExpression
46 , civis :: Maybe CapExpression
51 , civis :: Maybe CapExpression
47− , supportsNoColors :: Bool
48 , useAltColorMap :: Bool
52 , useAltColorMap :: Bool
49 , setForeColor :: CapExpression
53 , setForeColor :: CapExpression
50 , setBackColor :: CapExpression
54 , setBackColor :: CapExpression
@@ -59,6 +63,10 @@ data DisplayAttrCaps = DisplayAttrCaps
59 { setAttrStates :: Maybe CapExpression
63 { setAttrStates :: Maybe CapExpression
60 , enterStandout :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
61 , exitStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
66+ , enterItalic :: Maybe CapExpression
67+ , exitItalic :: Maybe CapExpression
68+ , enterStrikethrough :: Maybe CapExpression
69+ , exitStrikethrough :: Maybe CapExpression
62 , enterUnderline :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
63 , exitUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
64 , enterReverseVideo :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
@@ -95,62 +103,85 @@ sendCapToTerminal t cap capParams = do
95--
103--
96-- * Providing independent string capabilities for all display
104-- * Providing independent string capabilities for all display
97-- attributes.
105-- attributes.
98−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
106+reserveTerminal :: String -> Fd -> ColorMode -> IO Output
99−reserveTerminal termName outFd = liftIO $ do
107+reserveTerminal termName outFd colorMode = do
100 ti <- Terminfo.setupTerm termName
108 ti <- Terminfo.setupTerm termName
101 -- assumes set foreground always implies set background exists.
109 -- assumes set foreground always implies set background exists.
102 -- if set foreground is not set then all color changing style
110 -- if set foreground is not set then all color changing style
103 -- attributes are filtered.
111 -- attributes are filtered.
104 msetaf <- probeCap ti "setaf"
112 msetaf <- probeCap ti "setaf"
105 msetf <- probeCap ti "setf"
113 msetf <- probeCap ti "setf"
106− let (noColors, useAlt, setForeCap)
114+ let (useAlt, setForeCap)
107 = case msetaf of
115 = case msetaf of
108− Just setaf -> (False, False, setaf)
116+ Just setaf -> (False, setaf)
109 Nothing -> case msetf of
117 Nothing -> case msetf of
110− Just setf -> (False, True, setf)
118+ Just setf -> (True, setf)
111− Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
119+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
112 msetab <- probeCap ti "setab"
120 msetab <- probeCap ti "setab"
113 msetb <- probeCap ti "setb"
121 msetb <- probeCap ti "setb"
114− let set_back_cap
122+ let setBackCap
115 = case msetab of
123 = case msetab of
124+ Just setab -> setab
116 Nothing -> case msetb of
125 Nothing -> case msetb of
117 Just setb -> setb
126 Just setb -> setb
118 Nothing -> error $ "no back color support for terminal " ++ termName
127 Nothing -> error $ "no back color support for terminal " ++ termName
119− 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+
120 terminfoCaps <- pure TerminfoCaps
147 terminfoCaps <- pure TerminfoCaps
121 <*> probeCap ti "smcup"
148 <*> probeCap ti "smcup"
122 <*> probeCap ti "rmcup"
149 <*> probeCap ti "rmcup"
123 <*> requireCap ti "cup"
150 <*> requireCap ti "cup"
124 <*> probeCap ti "cnorm"
151 <*> probeCap ti "cnorm"
125 <*> probeCap ti "civis"
152 <*> probeCap ti "civis"
126− <*> pure noColors
127 <*> pure useAlt
153 <*> pure useAlt
128 <*> pure setForeCap
154 <*> pure setForeCap
129− <*> pure set_back_cap
155+ <*> pure setBackCap
130 <*> requireCap ti "sgr0"
156 <*> requireCap ti "sgr0"
131 <*> requireCap ti "clear"
157 <*> requireCap ti "clear"
132 <*> requireCap ti "el"
158 <*> requireCap ti "el"
133 <*> currentDisplayAttrCaps ti
159 <*> currentDisplayAttrCaps ti
134 <*> probeCap ti "bel"
160 <*> probeCap ti "bel"
135− newAssumedStateRef <- newIORef initialAssumedState
136 let t = Output
161 let t = Output
137 { terminalID = termName
162 { terminalID = termName
138− , releaseTerminal = liftIO $ do
163+ , releaseTerminal = do
139 sendCap setDefaultAttr []
164 sendCap setDefaultAttr []
140 maybeSendCap cnorm []
165 maybeSendCap cnorm []
141 , 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))
142− , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
171+ , ringTerminalBell = maybeSendCap ringBellAudio []
143− , reserveDisplay = liftIO $ do
172+ , reserveDisplay = do
144 -- If there is no support for smcup: Clear the screen
173 -- If there is no support for smcup: Clear the screen
145 -- and then move the mouse to the home position to
174 -- and then move the mouse to the home position to
146 -- approximate the behavior.
175 -- approximate the behavior.
147 maybeSendCap smcup []
176 maybeSendCap smcup []
148 sendCap clearScreen []
177 sendCap clearScreen []
149− , releaseDisplay = liftIO $ do
178+ , releaseDisplay = do
150 maybeSendCap rmcup []
179 maybeSendCap rmcup []
151 maybeSendCap cnorm []
180 maybeSendCap cnorm []
181+ , setDisplayBounds = \(w, h) ->
182+ setWindowSize outFd (w, h)
152 , displayBounds = do
183 , displayBounds = do
153− rawSize <- liftIO $ getWindowSize outFd
184+ rawSize <- getWindowSize outFd
154 case rawSize of
185 case rawSize of
155 (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
156 | otherwise -> return (w,h)
187 | otherwise -> return (w,h)
@@ -161,51 +192,48 @@ reserveTerminal termName outFd = liftIO $ do
161 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
162 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
163 ++ " Please report this bug to vty project."
194 ++ " Please report this bug to vty project."
164− , contextColorCount
165− = case supportsNoColors terminfoCaps of
166− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
167− Nothing -> 8
168− Just v -> toEnum v
169− True -> 1
170 , supportsCursorVisibility = isJust $ civis terminfoCaps
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
171− , supportsMode = const False
196+ , supportsMode = terminfoModeSupported
172− , setMode = const $ const $ return ()
197+ , setMode = terminfoSetMode
173− , getModeStatus = const $ return False
198+ , getModeStatus = terminfoModeStatus
174 , assumedStateRef = newAssumedStateRef
199 , assumedStateRef = newAssumedStateRef
200+ , outputColorMode = colorMode
175 -- I think fix would help assure tActual is the only
201 -- I think fix would help assure tActual is the only
176 -- reference. I was having issues tho.
202 -- reference. I was having issues tho.
177− , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
203+ , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
178 }
204 }
179 sendCap s = sendCapToTerminal t (s terminfoCaps)
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
180 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
181 return t
207 return t
182
208
183−requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
209+requireCap :: Terminfo.Terminal -> String -> IO CapExpression
184requireCap ti capName
210requireCap ti capName
185 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
186 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
187 Just capStr -> parseCap capStr
213 Just capStr -> parseCap capStr
188
214
189−probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
215+probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
190probeCap ti capName
216probeCap ti capName
191 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
192 Nothing -> return Nothing
218 Nothing -> return Nothing
193 Just capStr -> Just <$> parseCap capStr
219 Just capStr -> Just <$> parseCap capStr
194
220
195−parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
221+parseCap :: String -> IO CapExpression
196parseCap capStr = do
222parseCap capStr = do
197 case parseCapExpression capStr of
223 case parseCapExpression capStr of
198 Left e -> fail $ show e
224 Left e -> fail $ show e
199 Right cap -> return cap
225 Right cap -> return cap
200
226
201−currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
227+currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
202− => Terminfo.Terminal
203− -> m DisplayAttrCaps
204currentDisplayAttrCaps ti
228currentDisplayAttrCaps ti
205 = pure DisplayAttrCaps
229 = pure DisplayAttrCaps
206 <*> probeCap ti "sgr"
230 <*> probeCap ti "sgr"
207 <*> probeCap ti "smso"
231 <*> probeCap ti "smso"
208 <*> probeCap ti "rmso"
232 <*> probeCap ti "rmso"
233+ <*> probeCap ti "sitm"
234+ <*> probeCap ti "ritm"
235+ <*> probeCap ti "smxx"
236+ <*> probeCap ti "rmxx"
209 <*> probeCap ti "smul"
237 <*> probeCap ti "smul"
210 <*> probeCap ti "rmul"
238 <*> probeCap ti "rmul"
211 <*> probeCap ti "rev"
239 <*> probeCap ti "rev"
@@ -219,6 +247,13 @@ getWindowSize fd = do
219 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
220 return (fromIntegral b, fromIntegral a)
248 return (fromIntegral b, fromIntegral a)
221
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+
222terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
223terminfoDisplayContext tActual terminfoCaps r = return dc
258terminfoDisplayContext tActual terminfoCaps r = return dc
224 where dc = DisplayContext
259 where dc = DisplayContext
@@ -232,15 +267,35 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
232 Nothing -> error "this terminal does not support hide cursor"
267 Nothing -> error "this terminal does not support hide cursor"
233 Just c -> writeCapExpr c []
268 Just c -> writeCapExpr c []
234 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270+ , writeDefaultAttr = \urlsEnabled ->
235− , 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+ )
236 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
237 , inlineHack = return ()
278 , inlineHack = return ()
238 }
279 }
239
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+
240-- | 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.
241--
296--
242-- 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
243−-- 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
244-- colors to the default) this procedure is used:
299-- colors to the default) this procedure is used:
245--
300--
246-- 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.
@@ -273,30 +328,30 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
273--
328--
274-- Note that this optimizes for fewer state changes followed by fewer
329-- Note that this optimizes for fewer state changes followed by fewer
275-- bytes.
330-- bytes.
276−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
331+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
277−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
332+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
278− case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
333+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
279 -- The only way to reset either color, portably, to the default
334 -- The only way to reset either color, portably, to the default
280 -- 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
281 -- capability.
336 -- capability.
282− True -> do
337+ True -> do
283 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
284− (fixedStyle attr )
339+ (fixedStyle attr)
285 (styleToApplySeq $ fixedStyle attr) of
340 (styleToApplySeq $ fixedStyle attr) of
286 -- only way to reset a color to the defaults
341 -- only way to reset a color to the defaults
287− EnterExitSeq caps -> writeDefaultAttr dc
342+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
288 `mappend`
343 `mappend`
289 foldMap (\cap -> writeCapExpr cap []) caps
344 foldMap (\cap -> writeCapExpr cap []) caps
290 `mappend`
345 `mappend`
291 setColors
346 setColors
292 -- implicitly resets the colors to the defaults
347 -- implicitly resets the colors to the defaults
293 SetState state -> writeCapExpr (fromJust $ setAttrStates
348 SetState state -> writeCapExpr (fromJust $ setAttrStates
294− $ displayAttrCaps
349+ $ displayAttrCaps terminfoCaps
295− $ terminfoCaps
296 )
350 )
297 (sgrArgsForState state)
351 (sgrArgsForState state)
298− `mappend`
352+ `mappend` setItalics
353+ `mappend` setStrikethrough
299− setColors
354+ `mappend` setColors
300 -- Otherwise the display colors are not changing or changing
355 -- Otherwise the display colors are not changing or changing
301 -- between two non-default points.
356 -- between two non-default points.
302 False -> do
357 False -> do
@@ -314,45 +369,99 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
314 -- applied states.
369 -- applied states.
315 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
316 `mappend`
371 `mappend`
317− writeColorDiff setForeColor (foreColorDiff diffs)
372+ writeColorDiff Foreground (foreColorDiff diffs)
318 `mappend`
373 `mappend`
319− writeColorDiff setBackColor (backColorDiff diffs)
374+ writeColorDiff Background (backColorDiff diffs)
320 -- implicitly resets the colors to the defaults
375 -- implicitly resets the colors to the defaults
321 SetState state -> writeCapExpr (fromJust $ setAttrStates
376 SetState state -> writeCapExpr (fromJust $ setAttrStates
322 $ displayAttrCaps terminfoCaps
377 $ displayAttrCaps terminfoCaps
323 )
378 )
324 (sgrArgsForState state)
379 (sgrArgsForState state)
380+ `mappend` setItalics
381+ `mappend` setStrikethrough
325 `mappend` setColors
382 `mappend` setColors
326 where
383 where
384+ urlAttrs True = writeURLEscapes (urlDiff diffs)
385+ urlAttrs False = mempty
327 colorMap = case useAltColorMap terminfoCaps of
386 colorMap = case useAltColorMap terminfoCaps of
328 False -> ansiColorIndex
387 False -> ansiColorIndex
329 True -> altColorIndex
388 True -> altColorIndex
330 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
331 setColors =
404 setColors =
332 (case fixedForeColor attr of
405 (case fixedForeColor attr of
333− Just c -> writeCapExpr (setForeColor terminfoCaps)
406+ Just c -> writeColor Foreground c
334− [toEnum $ colorMap c]
335 Nothing -> mempty)
407 Nothing -> mempty)
336 `mappend`
408 `mappend`
337 (case fixedBackColor attr of
409 (case fixedBackColor attr of
338− Just c -> writeCapExpr (setBackColor terminfoCaps)
410+ Just c -> writeColor Background c
339− [toEnum $ colorMap c]
340 Nothing -> mempty)
411 Nothing -> mempty)
341− writeColorDiff _f NoColorChange
412+ writeColorDiff _side NoColorChange
342 = mempty
413 = mempty
343− writeColorDiff _f ColorToDefault
414+ writeColorDiff _side ColorToDefault
344 = error "ColorToDefault is not a possible case for applyColorDiffs"
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
345− 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 =
346− = 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"
347
452
348-- | 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
349-- 240 color set that might not be supported by the terminal.
454-- 240 color set that might not be supported by the terminal.
350--
455--
351−-- 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
352−-- computes the index into the full 256 color pallete.
457+-- computes the index into the full 256 color palette.
353ansiColorIndex :: Color -> Int
458ansiColorIndex :: Color -> Int
354ansiColorIndex (ISOColor v) = fromEnum v
459ansiColorIndex (ISOColor v) = fromEnum v
355ansiColorIndex (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+ ]
356
465
357-- | For terminals without setaf/setab
466-- | For terminals without setaf/setab
358--
467--
@@ -369,6 +478,10 @@ altColorIndex (ISOColor 6) = 3
369altColorIndex (ISOColor 7) = 7
478altColorIndex (ISOColor 7) = 7
370altColorIndex (ISOColor v) = fromEnum v
479altColorIndex (ISOColor v) = fromEnum v
371altColorIndex (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+ ]
372
485
373{- | 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
374 - according to these rules.
487 - according to these rules.
@@ -395,6 +508,8 @@ data DisplayAttrSeq
395data DisplayAttrState = DisplayAttrState
508data DisplayAttrState = DisplayAttrState
396 { applyStandout :: Bool
509 { applyStandout :: Bool
397 , applyUnderline :: Bool
510 , applyUnderline :: Bool
511+ , applyItalic :: Bool
512+ , applyStrikethrough :: Bool
398 , applyReverseVideo :: Bool
513 , applyReverseVideo :: Bool
399 , applyBlink :: Bool
514 , applyBlink :: Bool
400 , applyDim :: Bool
515 , applyDim :: Bool
@@ -431,6 +546,10 @@ reqDisplayCapSeqFor caps s diffs
431 -- set state cap then just use the set state cap.
546 -- set state cap then just use the set state cap.
432 ( True, True ) -> SetState $ stateForStyle s
547 ( True, True ) -> SetState $ stateForStyle s
433 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
434 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
435 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
436 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -443,6 +562,10 @@ reqDisplayCapSeqFor caps s diffs
443 noEnterExitCap RemoveDim = True
562 noEnterExitCap RemoveDim = True
444 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
445 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
446 enterExitCap ApplyStandout = fromJust $ enterStandout caps
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
447 enterExitCap RemoveStandout = fromJust $ exitStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
448 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -456,6 +579,8 @@ stateForStyle :: Style -> DisplayAttrState
456stateForStyle s = DisplayAttrState
579stateForStyle s = DisplayAttrState
457 { applyStandout = isStyleSet standout
580 { applyStandout = isStyleSet standout
458 , applyUnderline = isStyleSet underline
581 , applyUnderline = isStyleSet underline
582+ , applyItalic = isStyleSet italic
583+ , applyStrikethrough = isStyleSet strikethrough
459 , applyReverseVideo = isStyleSet reverseVideo
584 , applyReverseVideo = isStyleSet reverseVideo
460 , applyBlink = isStyleSet blink
585 , applyBlink = isStyleSet blink
461 , applyDim = isStyleSet dim
586 , applyDim = isStyleSet dim
@@ -467,10 +592,12 @@ styleToApplySeq :: Style -> [StyleStateChange]
467styleToApplySeq s = concat
592styleToApplySeq s = concat
468 [ applyIfRequired ApplyStandout standout
593 [ applyIfRequired ApplyStandout standout
469 , applyIfRequired ApplyUnderline underline
594 , applyIfRequired ApplyUnderline underline
595+ , applyIfRequired ApplyItalic italic
596+ , applyIfRequired ApplyStrikethrough strikethrough
470 , applyIfRequired ApplyReverseVideo reverseVideo
597 , applyIfRequired ApplyReverseVideo reverseVideo
471 , applyIfRequired ApplyBlink blink
598 , applyIfRequired ApplyBlink blink
472 , applyIfRequired ApplyDim dim
599 , applyIfRequired ApplyDim dim
473− , applyIfRequired ApplyBlink bold
600+ , applyIfRequired ApplyBold bold
474 ]
601 ]
475 where
602 where
476 applyIfRequired op flag
603 applyIfRequired op flag
src/Graphics/Vty/Output/XTermColor.hs+42−18
@@ -1,3 +1,4 @@
1+{-# Language CPP #-}
1-- Copyright 2009-2010 Corey O'Connor
2-- Copyright 2009-2010 Corey O'Connor
2-- | Xterm output driver. This uses the Terminfo driver with some
3-- | Xterm output driver. This uses the Terminfo driver with some
3-- extensions for Xterm.
4-- extensions for Xterm.
@@ -8,26 +9,42 @@ where
8
9
9import Graphics.Vty.Output.Interface
10import Graphics.Vty.Output.Interface
10import Graphics.Vty.Input.Mouse
11import Graphics.Vty.Input.Mouse
12+import Graphics.Vty.Input.Focus
13+import Graphics.Vty.Attributes.Color (ColorMode)
11import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
12
15
13import Blaze.ByteString.Builder (writeToByteString)
16import Blaze.ByteString.Builder (writeToByteString)
14import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
15
18
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+import Foreign.Ptr (castPtr)
22+
16import Control.Monad (void, when)
23import Control.Monad (void, when)
17import Control.Monad.Trans
24import Control.Monad.Trans
25+import Data.Char (toLower)
18import Data.IORef
26import Data.IORef
19
27
20−import System.Posix.IO (fdWrite)
28+import System.Posix.IO (fdWriteBuf)
21−import System.Posix.Types (Fd)
29+import System.Posix.Types (ByteCount, Fd)
22import System.Posix.Env (getEnv)
30import System.Posix.Env (getEnv)
23
31
24import Data.List (isInfixOf)
32import Data.List (isInfixOf)
25import Data.Maybe (catMaybes)
33import Data.Maybe (catMaybes)
34+
35+#if !MIN_VERSION_base(4,11,0)
26import Data.Monoid ((<>))
36import Data.Monoid ((<>))
37+#endif
38+
39+-- | Write a 'ByteString' to an 'Fd'.
40+fdWrite :: Fd -> ByteString -> IO ByteCount
41+fdWrite fd s =
42+ BS8.useAsCStringLen s $ \(buf,len) -> do
43+ fdWriteBuf fd (castPtr buf) (fromIntegral len)
27
44
28-- | Construct an Xterm output driver. Initialize the display to UTF-8.
45-- | Construct an Xterm output driver. Initialize the display to UTF-8.
29−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
46+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
30−reserveTerminal variant outFd = liftIO $ do
47+reserveTerminal variant outFd colorMode = liftIO $ do
31 let flushedPut = void . fdWrite outFd
48 let flushedPut = void . fdWrite outFd
32 -- If the terminal variant is xterm-color use xterm instead since,
49 -- If the terminal variant is xterm-color use xterm instead since,
33 -- more often than not, xterm-color is broken.
50 -- more often than not, xterm-color is broken.
@@ -35,15 +52,21 @@ reserveTerminal variant outFd = liftIO $ do
35
52
36 utf8a <- utf8Active
53 utf8a <- utf8Active
37 when (not utf8a) $ flushedPut setUtf8CharSet
54 when (not utf8a) $ flushedPut setUtf8CharSet
38− t <- TerminfoBased.reserveTerminal variant' outFd
55+ t <- TerminfoBased.reserveTerminal variant' outFd colorMode
39
56
40 mouseModeStatus <- newIORef False
57 mouseModeStatus <- newIORef False
58+ focusModeStatus <- newIORef False
41 pasteModeStatus <- newIORef False
59 pasteModeStatus <- newIORef False
42
60
43 let xtermSetMode t' m newStatus = do
61 let xtermSetMode t' m newStatus = do
44 curStatus <- getModeStatus t' m
62 curStatus <- getModeStatus t' m
45 when (newStatus /= curStatus) $
63 when (newStatus /= curStatus) $
46 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
47 Mouse -> liftIO $ do
70 Mouse -> liftIO $ do
48 case newStatus of
71 case newStatus of
49 True -> flushedPut requestMouseEvents
72 True -> flushedPut requestMouseEvents
@@ -54,9 +77,12 @@ reserveTerminal variant outFd = liftIO $ do
54 True -> flushedPut enableBracketedPastes
77 True -> flushedPut enableBracketedPastes
55 False -> flushedPut disableBracketedPastes
78 False -> flushedPut disableBracketedPastes
56 writeIORef pasteModeStatus newStatus
79 writeIORef pasteModeStatus newStatus
80+ Hyperlink -> setMode t Hyperlink newStatus
57
81
58 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
83+ xtermGetMode Focus = liftIO $ readIORef focusModeStatus
59 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85+ xtermGetMode Hyperlink = getModeStatus t Hyperlink
60
86
61 let t' = t
87 let t' = t
62 { terminalID = terminalID t ++ " (xterm-color)"
88 { terminalID = terminalID t ++ " (xterm-color)"
@@ -64,6 +90,7 @@ reserveTerminal variant outFd = liftIO $ do
64 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
90 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
65 setMode t' BracketedPaste False
91 setMode t' BracketedPaste False
66 setMode t' Mouse False
92 setMode t' Mouse False
93+ setMode t' Focus False
67 releaseTerminal t
94 releaseTerminal t
68 , mkDisplayContext = \tActual r -> do
95 , mkDisplayContext = \tActual r -> do
69 dc <- mkDisplayContext t tActual r
96 dc <- mkDisplayContext t tActual r
@@ -77,30 +104,27 @@ reserveTerminal variant outFd = liftIO $ do
77utf8Active :: IO Bool
104utf8Active :: IO Bool
78utf8Active = do
105utf8Active = do
79 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
80− results <- catMaybes <$> mapM getEnv vars
107+ results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars
81− let matches = filter ("UTF8" `isInfixOf`) results <>
108+ let matches = filter ("utf8" `isInfixOf`) results <>
82− filter ("UTF-8" `isInfixOf`) results
109+ filter ("utf-8" `isInfixOf`) results
83 return $ not $ null matches
110 return $ not $ null matches
84
111
85-- | Enable bracketed paste mode:
112-- | Enable bracketed paste mode:
86-- http://cirw.in/blog/bracketed-paste
113-- http://cirw.in/blog/bracketed-paste
87−enableBracketedPastes :: String
114+enableBracketedPastes :: ByteString
88−enableBracketedPastes = "\ESC[?2004h"
115+enableBracketedPastes = BS8.pack "\ESC[?2004h"
89
116
90-- | Disable bracketed paste mode:
117-- | Disable bracketed paste mode:
91−disableBracketedPastes :: String
118+disableBracketedPastes :: ByteString
92−disableBracketedPastes = "\ESC[?2004l"
119+disableBracketedPastes = BS8.pack "\ESC[?2004l"
93
120
94-- | These sequences set xterm based terminals to UTF-8 output.
121-- | These sequences set xterm based terminals to UTF-8 output.
95--
122--
96-- There is no known terminfo capability equivalent to this.
123-- There is no known terminfo capability equivalent to this.
97−setUtf8CharSet, setDefaultCharSet :: String
124+setUtf8CharSet, setDefaultCharSet :: ByteString
98−setUtf8CharSet = "\ESC%G"
125+setUtf8CharSet = BS8.pack "\ESC%G"
99−setDefaultCharSet = "\ESC%@"
126+setDefaultCharSet = BS8.pack "\ESC%@"
100
127
101−-- | I think xterm is broken: Reseting the background color as the first
102−-- bytes serialized on a new line does not effect the background color
103−-- xterm uses to clear the line. Which is used *after* the next newline.
104xtermInlineHack :: Output -> IO ()
128xtermInlineHack :: Output -> IO ()
105xtermInlineHack t = do
129xtermInlineHack t = do
106 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
src/Graphics/Vty/Picture.hs+11−2
@@ -1,4 +1,3 @@
1−{-# LANGUAGE BangPatterns #-}
2-- A 'Picture' is a background paired with a set of 'Image' layers. The
1-- A 'Picture' is a background paired with a set of 'Image' layers. The
3-- 'Picture' data structure is representative of the final terminal
2-- 'Picture' data structure is representative of the final terminal
4-- view.
3-- view.
@@ -31,7 +30,7 @@ data Picture = Picture
31 , picBackground :: Background
30 , picBackground :: Background
32 -- ^ The picture's background to be displayed in locations with no
31 -- ^ The picture's background to be displayed in locations with no
33 -- Image data.
32 -- Image data.
34− }
33+ } deriving Eq
35
34
36instance Show Picture where
35instance Show Picture where
37 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -80,11 +79,20 @@ picForLayers is = Picture
80data Cursor =
79data Cursor =
81 -- | Hide the cursor
80 -- | Hide the cursor
82 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
83 -- | Show the cursor at the given logical column accounting for
90 -- | Show the cursor at the given logical column accounting for
84 -- character width in the presence of multi-column characters.
91 -- character width in the presence of multi-column characters.
85 | Cursor !Int !Int
92 | Cursor !Int !Int
86 -- | Show the cursor at the given absolute terminal column and row
93 -- | Show the cursor at the given absolute terminal column and row
87 | AbsoluteCursor !Int !Int
94 | AbsoluteCursor !Int !Int
95+ deriving Eq
88
96
89instance NFData Cursor where
97instance NFData Cursor where
90 rnf c = c `seq` ()
98 rnf c = c `seq` ()
@@ -108,6 +116,7 @@ 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` ()
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+8−11
@@ -1,6 +1,4 @@
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. The attribute is applied to all following spans,
4-- character spans. The attribute is applied to all following spans,
@@ -52,7 +50,7 @@ dropOps :: Int -> SpanOps -> SpanOps
52dropOps w = snd . splitOpsAt w
50dropOps w = snd . splitOpsAt w
53
51
54splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
55−splitOpsAt inW inOps = splitOpsAt' inW inOps
53+splitOpsAt = splitOpsAt'
56 where
54 where
57 splitOpsAt' 0 ops = (Vector.empty, ops)
55 splitOpsAt' 0 ops = (Vector.empty, ops)
58 splitOpsAt' remainingColumns ops = case Vector.head ops of
56 splitOpsAt' remainingColumns ops = case Vector.head ops of
@@ -103,18 +101,18 @@ displayOpsColumns ops
103
101
104-- | The number of rows the DisplayOps are defined for.
102-- | The number of rows the DisplayOps are defined for.
105displayOpsRows :: DisplayOps -> Int
103displayOpsRows :: DisplayOps -> Int
106−displayOpsRows ops = Vector.length ops
104+displayOpsRows = Vector.length
107
105
108affectedRegion :: DisplayOps -> DisplayRegion
106affectedRegion :: DisplayOps -> DisplayRegion
109affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
107affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
110
108
111-- | The number of columns a SpanOps affects.
109-- | The number of columns a SpanOps affects.
112−spanOpsEffectedColumns :: SpanOps -> Int
110+spanOpsAffectedColumns :: SpanOps -> Int
113−spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
111+spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps
114 where
112 where
115− spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
113+ spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w
116− spanOpsEffectedColumns' t (Skip w) = t + w
114+ spanOpsAffectedColumns' t (Skip w) = t + w
117− spanOpsEffectedColumns' t (RowEnd w) = t + w
115+ spanOpsAffectedColumns' t (RowEnd w) = t + w
118
116
119-- | The width of a single SpanOp in columns.
117-- | The width of a single SpanOp in columns.
120spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
@@ -126,7 +124,6 @@ spanOpHasWidth (RowEnd ow) = Just (ow,ow)
126-- span op.
124-- span op.
127columnsToCharOffset :: Int -> SpanOp -> Int
125columnsToCharOffset :: Int -> SpanOp -> Int
128columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
126columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
129− let str = TL.unpack utf8Str
127+ wctlwidth (TL.take (fromIntegral cx) utf8Str)
130− in wcswidth (take cx str)
131columnsToCharOffset cx (Skip _) = cx
128columnsToCharOffset cx (Skip _) = cx
132columnsToCharOffset 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/Rogue.hs−1
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TemplateHaskell #-}
2module Main where
1module Main where
3
2
4import Graphics.Vty
3import Graphics.Vty
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/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−3
@@ -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
@@ -13,7 +14,6 @@ import Verify.Graphics.Vty.Output
13import Control.Monad
14import Control.Monad
14
15
15import qualified System.Console.Terminfo as Terminfo
16import qualified System.Console.Terminfo as Terminfo
16−import System.Posix.Env
17import System.Posix.IO
17import System.Posix.IO
18
18
19tests :: IO [Test]
19tests :: IO [Test]
@@ -35,7 +35,11 @@ smokeTestTermNonMac termName i = liftIOResult $ do
35smokeTestTerm :: String -> Image -> IO Result
35smokeTestTerm :: String -> Image -> IO Result
36smokeTestTerm termName i = do
36smokeTestTerm termName i = do
37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
38− t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName }
38+ t <- outputForConfig $ defaultConfig
39+ { outputFd = Just nullOut
40+ , termName = Just termName
41+ , colorMode = Just NoColor
42+ }
39 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
43 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
40 reserveDisplay t
44 reserveDisplay t
41 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+4−1
@@ -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
@@ -131,7 +132,9 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
131 readLoop 0 = return ()
132 readLoop 0 = return ()
132 readLoop n = do
133 readLoop n = do
133 e <- atomically $ readTChan $ input^.eventChannel
134 e <- atomically $ readTChan $ input^.eventChannel
135+ case e of
134− modifyIORef eventsRef ((:) e)
136+ InputEvent ev -> modifyIORef eventsRef ((:) ev)
137+ ResumeAfterSignal -> return ()
135 readLoop (n - 1)
138 readLoop (n - 1)
136 genEventsUsingIoActions maxDuration writeWaitClose readEvents
139 genEventsUsingIoActions maxDuration writeWaitClose readEvents
137 outEvents <- reverse <$> readIORef eventsRef
140 outEvents <- reverse <$> readIORef eventsRef
test/interactive_terminal_test.hs+1−1
@@ -364,7 +364,7 @@ Did the test output match the description?
364|]
364|]
365 defaultSuccessConfirmResults
365 defaultSuccessConfirmResults
366
366
367−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
368-- This avoids any issues with how the compiler represents string literals.
368-- This avoids any issues with how the compiler represents string literals.
369--
369--
370-- 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
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+94−84
@@ -1,5 +1,5 @@
1name: vty
1name: vty
2−version: 5.15
2+version: 5.35.1
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
@@ -24,13 +24,13 @@ description:
24 &#169; Corey O'Connor; BSD3 license.
24 &#169; Corey O'Connor; BSD3 license.
25 .
25 .
26 &#169; Jonathan Daugherty; BSD3 license.
26 &#169; Jonathan Daugherty; BSD3 license.
27−cabal-version: >= 1.18
27+cabal-version: 1.18
28build-type: Simple
28build-type: Simple
29extra-doc-files: README.md,
29extra-doc-files: README.md,
30 AUTHORS,
30 AUTHORS,
31 CHANGELOG.md,
31 CHANGELOG.md,
32 LICENSE
32 LICENSE
33−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
34
34
35source-repository head
35source-repository head
36 type: git
36 type: git
@@ -38,17 +38,16 @@ source-repository head
38
38
39library
39library
40 default-language: Haskell2010
40 default-language: Haskell2010
41− build-depends: base >= 4.6 && < 5,
41+ build-depends: base >= 4.8 && < 5,
42 blaze-builder >= 0.3.3.2 && < 0.5,
42 blaze-builder >= 0.3.3.2 && < 0.5,
43 bytestring,
43 bytestring,
44 containers,
44 containers,
45 deepseq >= 1.1 && < 1.5,
45 deepseq >= 1.1 && < 1.5,
46 directory,
46 directory,
47 filepath >= 1.0 && < 2.0,
47 filepath >= 1.0 && < 2.0,
48− microlens,
48+ microlens < 0.4.13,
49 microlens-mtl,
49 microlens-mtl,
50 microlens-th,
50 microlens-th,
51− -- required for nice installation with yi
52 hashable >= 1.2,
51 hashable >= 1.2,
53 mtl >= 1.1.1.0 && < 2.3,
52 mtl >= 1.1.1.0 && < 2.3,
54 parallel >= 2.2 && < 3.3,
53 parallel >= 2.2 && < 3.3,
@@ -59,10 +58,18 @@ library
59 text >= 0.11.3,
58 text >= 0.11.3,
60 unix,
59 unix,
61 utf8-string >= 0.3 && < 1.1,
60 utf8-string >= 0.3 && < 1.1,
62− 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
63
68
64 exposed-modules: Graphics.Vty
69 exposed-modules: Graphics.Vty
65 Graphics.Vty.Attributes
70 Graphics.Vty.Attributes
71+ Graphics.Vty.Attributes.Color
72+ Graphics.Vty.Attributes.Color240
66 Graphics.Vty.Config
73 Graphics.Vty.Config
67 Graphics.Vty.Error
74 Graphics.Vty.Error
68 Graphics.Vty.Image
75 Graphics.Vty.Image
@@ -73,7 +80,6 @@ library
73 Graphics.Vty.Picture
80 Graphics.Vty.Picture
74 Graphics.Vty.Output
81 Graphics.Vty.Output
75 Graphics.Text.Width
82 Graphics.Text.Width
76− -- the modules below are only meant to be used by the tests.
77 Codec.Binary.UTF8.Debug
83 Codec.Binary.UTF8.Debug
78 Data.Terminfo.Parse
84 Data.Terminfo.Parse
79 Data.Terminfo.Eval
85 Data.Terminfo.Eval
@@ -85,6 +91,7 @@ library
85 Graphics.Vty.Input.Classify.Parse
91 Graphics.Vty.Input.Classify.Parse
86 Graphics.Vty.Input.Loop
92 Graphics.Vty.Input.Loop
87 Graphics.Vty.Input.Mouse
93 Graphics.Vty.Input.Mouse
94+ Graphics.Vty.Input.Focus
88 Graphics.Vty.Input.Paste
95 Graphics.Vty.Input.Paste
89 Graphics.Vty.Input.Terminfo
96 Graphics.Vty.Input.Terminfo
90 Graphics.Vty.PictureToSpans
97 Graphics.Vty.PictureToSpans
@@ -93,39 +100,51 @@ library
93 Graphics.Vty.Output.Interface
100 Graphics.Vty.Output.Interface
94 Graphics.Vty.Output.XTermColor
101 Graphics.Vty.Output.XTermColor
95 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
96
107
97− other-modules: Graphics.Vty.Attributes.Color
108+ other-modules: Graphics.Vty.Debug.Image
98− Graphics.Vty.Attributes.Color240
99− Graphics.Vty.Debug.Image
100 Graphics.Vty.Input.Terminfo.ANSIVT
109 Graphics.Vty.Input.Terminfo.ANSIVT
101
110
102 c-sources: cbits/gwinsz.c
111 c-sources: cbits/gwinsz.c
103 cbits/set_term_timing.c
112 cbits/set_term_timing.c
113+ cbits/get_tty_erase.c
104 cbits/mk_wcwidth.c
114 cbits/mk_wcwidth.c
105
115
106 include-dirs: cbits
116 include-dirs: cbits
107
117
108 hs-source-dirs: src
118 hs-source-dirs: src
109
119
110− default-extensions: ScopedTypeVariables
111− ForeignFunctionInterface
112−
113 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
114
121
115 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
116
123
124+executable vty-build-width-table
125+ main-is: BuildWidthTable.hs
126+ hs-source-dirs: tools
127+
128+ default-language: Haskell2010
117− 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
118
138
119executable vty-mode-demo
139executable vty-mode-demo
120 main-is: ModeDemo.hs
140 main-is: ModeDemo.hs
121 hs-source-dirs: demos
141 hs-source-dirs: demos
122
142
123 default-language: Haskell2010
143 default-language: Haskell2010
124− default-extensions: ScopedTypeVariables
125 ghc-options: -threaded
144 ghc-options: -threaded
126
145
127 build-depends: vty,
146 build-depends: vty,
128− base >= 4.6 && < 5,
147+ base >= 4.8 && < 5,
129 containers,
148 containers,
130 microlens,
149 microlens,
131 microlens-mtl,
150 microlens-mtl,
@@ -136,39 +155,17 @@ executable vty-demo
136 hs-source-dirs: demos
155 hs-source-dirs: demos
137
156
138 default-language: Haskell2010
157 default-language: Haskell2010
139− default-extensions: ScopedTypeVariables
140 ghc-options: -threaded
158 ghc-options: -threaded
141
159
142 build-depends: vty,
160 build-depends: vty,
143− base >= 4.6 && < 5,
161+ base >= 4.8 && < 5,
144 containers,
162 containers,
145 microlens,
163 microlens,
146 microlens-mtl,
164 microlens-mtl,
147 mtl >= 1.1.1.0 && < 2.3
165 mtl >= 1.1.1.0 && < 2.3
148
166
149−test-suite verify-attribute-ops
150− default-language: Haskell2010
151− default-extensions: ScopedTypeVariables
152− type: detailed-0.9
153− hs-source-dirs: test
154− test-module: VerifyAttributeOps
155− build-depends: vty,
156− Cabal >= 1.20,
157− QuickCheck >= 2.7,
158− random >= 1.0 && < 1.2,
159− base >= 4.6 && < 5,
160− bytestring,
161− containers,
162− deepseq >= 1.1 && < 1.5,
163− mtl >= 1.1.1.0 && < 2.3,
164− text >= 0.11.3,
165− unix,
166− utf8-string >= 0.3 && < 1.1,
167− vector >= 0.7
168−
169test-suite verify-using-mock-terminal
167test-suite verify-using-mock-terminal
170 default-language: Haskell2010
168 default-language: Haskell2010
171− default-extensions: ScopedTypeVariables
172
169
173 type: detailed-0.9
170 type: detailed-0.9
174
171
@@ -187,8 +184,8 @@ test-suite verify-using-mock-terminal
187 build-depends: vty,
184 build-depends: vty,
188 Cabal >= 1.20,
185 Cabal >= 1.20,
189 QuickCheck >= 2.7,
186 QuickCheck >= 2.7,
190− random >= 1.0 && < 1.2,
187+ random >= 1.0 && < 1.3,
191− base >= 4.6 && < 5,
188+ base >= 4.8 && < 5,
192 bytestring,
189 bytestring,
193 containers,
190 containers,
194 deepseq >= 1.1 && < 1.5,
191 deepseq >= 1.1 && < 1.5,
@@ -201,7 +198,6 @@ test-suite verify-using-mock-terminal
201
198
202test-suite verify-terminal
199test-suite verify-terminal
203 default-language: Haskell2010
200 default-language: Haskell2010
204− default-extensions: ScopedTypeVariables
205
201
206 type: detailed-0.9
202 type: detailed-0.9
207
203
@@ -220,8 +216,8 @@ test-suite verify-terminal
220 build-depends: vty,
216 build-depends: vty,
221 Cabal >= 1.20,
217 Cabal >= 1.20,
222 QuickCheck >= 2.7,
218 QuickCheck >= 2.7,
223− random >= 1.0 && < 1.2,
219+ random >= 1.0 && < 1.3,
224− base >= 4.6 && < 5,
220+ base >= 4.8 && < 5,
225 bytestring,
221 bytestring,
226 containers,
222 containers,
227 deepseq >= 1.1 && < 1.5,
223 deepseq >= 1.1 && < 1.5,
@@ -234,7 +230,6 @@ test-suite verify-terminal
234
230
235test-suite verify-display-attributes
231test-suite verify-display-attributes
236 default-language: Haskell2010
232 default-language: Haskell2010
237− default-extensions: ScopedTypeVariables
238
233
239 type: detailed-0.9
234 type: detailed-0.9
240
235
@@ -253,8 +248,8 @@ test-suite verify-display-attributes
253 build-depends: vty,
248 build-depends: vty,
254 Cabal >= 1.20,
249 Cabal >= 1.20,
255 QuickCheck >= 2.7,
250 QuickCheck >= 2.7,
256− random >= 1.0 && < 1.2,
251+ random >= 1.0 && < 1.3,
257− base >= 4.6 && < 5,
252+ base >= 4.8 && < 5,
258 bytestring,
253 bytestring,
259 containers,
254 containers,
260 deepseq >= 1.1 && < 1.5,
255 deepseq >= 1.1 && < 1.5,
@@ -266,7 +261,6 @@ test-suite verify-display-attributes
266
261
267test-suite verify-empty-image-props
262test-suite verify-empty-image-props
268 default-language: Haskell2010
263 default-language: Haskell2010
269− default-extensions: ScopedTypeVariables
270
264
271 type: detailed-0.9
265 type: detailed-0.9
272
266
@@ -279,8 +273,8 @@ test-suite verify-empty-image-props
279 build-depends: vty,
273 build-depends: vty,
280 Cabal >= 1.20,
274 Cabal >= 1.20,
281 QuickCheck >= 2.7,
275 QuickCheck >= 2.7,
282− random >= 1.0 && < 1.2,
276+ random >= 1.0 && < 1.3,
283− base >= 4.6 && < 5,
277+ base >= 4.8 && < 5,
284 bytestring,
278 bytestring,
285 containers,
279 containers,
286 deepseq >= 1.1 && < 1.5,
280 deepseq >= 1.1 && < 1.5,
@@ -292,7 +286,6 @@ test-suite verify-empty-image-props
292
286
293test-suite verify-eval-terminfo-caps
287test-suite verify-eval-terminfo-caps
294 default-language: Haskell2010
288 default-language: Haskell2010
295− default-extensions: ScopedTypeVariables
296
289
297 type: detailed-0.9
290 type: detailed-0.9
298
291
@@ -306,8 +299,8 @@ test-suite verify-eval-terminfo-caps
306 build-depends: vty,
299 build-depends: vty,
307 Cabal >= 1.20,
300 Cabal >= 1.20,
308 QuickCheck >= 2.7,
301 QuickCheck >= 2.7,
309− random >= 1.0 && < 1.2,
302+ random >= 1.0 && < 1.3,
310− base >= 4.6 && < 5,
303+ base >= 4.8 && < 5,
311 blaze-builder >= 0.3.3.2 && < 0.5,
304 blaze-builder >= 0.3.3.2 && < 0.5,
312 bytestring,
305 bytestring,
313 containers,
306 containers,
@@ -321,7 +314,6 @@ test-suite verify-eval-terminfo-caps
321
314
322test-suite verify-image-ops
315test-suite verify-image-ops
323 default-language: Haskell2010
316 default-language: Haskell2010
324− default-extensions: ScopedTypeVariables
325
317
326 type: detailed-0.9
318 type: detailed-0.9
327
319
@@ -336,8 +328,8 @@ test-suite verify-image-ops
336 build-depends: vty,
328 build-depends: vty,
337 Cabal >= 1.20,
329 Cabal >= 1.20,
338 QuickCheck >= 2.7,
330 QuickCheck >= 2.7,
339− random >= 1.0 && < 1.2,
331+ random >= 1.0 && < 1.3,
340− base >= 4.6 && < 5,
332+ base >= 4.8 && < 5,
341 bytestring,
333 bytestring,
342 containers,
334 containers,
343 deepseq >= 1.1 && < 1.5,
335 deepseq >= 1.1 && < 1.5,
@@ -349,7 +341,6 @@ test-suite verify-image-ops
349
341
350test-suite verify-image-trans
342test-suite verify-image-trans
351 default-language: Haskell2010
343 default-language: Haskell2010
352− default-extensions: ScopedTypeVariables
353
344
354 type: detailed-0.9
345 type: detailed-0.9
355
346
@@ -364,8 +355,8 @@ test-suite verify-image-trans
364 build-depends: vty,
355 build-depends: vty,
365 Cabal >= 1.20,
356 Cabal >= 1.20,
366 QuickCheck >= 2.7,
357 QuickCheck >= 2.7,
367− random >= 1.0 && < 1.2,
358+ random >= 1.0 && < 1.3,
368− base >= 4.6 && < 5,
359+ base >= 4.8 && < 5,
369 bytestring,
360 bytestring,
370 containers,
361 containers,
371 deepseq >= 1.1 && < 1.5,
362 deepseq >= 1.1 && < 1.5,
@@ -377,7 +368,6 @@ test-suite verify-image-trans
377
368
378test-suite verify-inline
369test-suite verify-inline
379 default-language: Haskell2010
370 default-language: Haskell2010
380− default-extensions: ScopedTypeVariables
381
371
382 type: detailed-0.9
372 type: detailed-0.9
383
373
@@ -391,8 +381,8 @@ test-suite verify-inline
391 build-depends: vty,
381 build-depends: vty,
392 Cabal >= 1.20,
382 Cabal >= 1.20,
393 QuickCheck >= 2.7,
383 QuickCheck >= 2.7,
394− random >= 1.0 && < 1.2,
384+ random >= 1.0 && < 1.3,
395− base >= 4.6 && < 5,
385+ base >= 4.8 && < 5,
396 bytestring,
386 bytestring,
397 containers,
387 containers,
398 deepseq >= 1.1 && < 1.5,
388 deepseq >= 1.1 && < 1.5,
@@ -404,7 +394,6 @@ test-suite verify-inline
404
394
405test-suite verify-parse-terminfo-caps
395test-suite verify-parse-terminfo-caps
406 default-language: Haskell2010
396 default-language: Haskell2010
407− default-extensions: ScopedTypeVariables
408
397
409 type: detailed-0.9
398 type: detailed-0.9
410
399
@@ -419,8 +408,8 @@ test-suite verify-parse-terminfo-caps
419 build-depends: vty,
408 build-depends: vty,
420 Cabal >= 1.20,
409 Cabal >= 1.20,
421 QuickCheck >= 2.7,
410 QuickCheck >= 2.7,
422− random >= 1.0 && < 1.2,
411+ random >= 1.0 && < 1.3,
423− base >= 4.6 && < 5,
412+ base >= 4.8 && < 5,
424 bytestring,
413 bytestring,
425 containers,
414 containers,
426 deepseq >= 1.1 && < 1.5,
415 deepseq >= 1.1 && < 1.5,
@@ -433,7 +422,6 @@ test-suite verify-parse-terminfo-caps
433
422
434test-suite verify-simple-span-generation
423test-suite verify-simple-span-generation
435 default-language: Haskell2010
424 default-language: Haskell2010
436− default-extensions: ScopedTypeVariables
437
425
438 type: detailed-0.9
426 type: detailed-0.9
439
427
@@ -451,8 +439,8 @@ test-suite verify-simple-span-generation
451 build-depends: vty,
439 build-depends: vty,
452 Cabal >= 1.20,
440 Cabal >= 1.20,
453 QuickCheck >= 2.7,
441 QuickCheck >= 2.7,
454− random >= 1.0 && < 1.2,
442+ random >= 1.0 && < 1.3,
455− base >= 4.6 && < 5,
443+ base >= 4.8 && < 5,
456 bytestring,
444 bytestring,
457 containers,
445 containers,
458 deepseq >= 1.1 && < 1.5,
446 deepseq >= 1.1 && < 1.5,
@@ -465,7 +453,6 @@ test-suite verify-simple-span-generation
465
453
466test-suite verify-crop-span-generation
454test-suite verify-crop-span-generation
467 default-language: Haskell2010
455 default-language: Haskell2010
468− default-extensions: ScopedTypeVariables
469
456
470 type: detailed-0.9
457 type: detailed-0.9
471
458
@@ -483,8 +470,8 @@ test-suite verify-crop-span-generation
483 build-depends: vty,
470 build-depends: vty,
484 Cabal >= 1.20,
471 Cabal >= 1.20,
485 QuickCheck >= 2.7,
472 QuickCheck >= 2.7,
486− random >= 1.0 && < 1.2,
473+ random >= 1.0 && < 1.3,
487− base >= 4.6 && < 5,
474+ base >= 4.8 && < 5,
488 bytestring,
475 bytestring,
489 containers,
476 containers,
490 deepseq >= 1.1 && < 1.5,
477 deepseq >= 1.1 && < 1.5,
@@ -497,7 +484,6 @@ test-suite verify-crop-span-generation
497
484
498test-suite verify-layers-span-generation
485test-suite verify-layers-span-generation
499 default-language: Haskell2010
486 default-language: Haskell2010
500− default-extensions: ScopedTypeVariables
501
487
502 type: detailed-0.9
488 type: detailed-0.9
503
489
@@ -515,8 +501,33 @@ test-suite verify-layers-span-generation
515 build-depends: vty,
501 build-depends: vty,
516 Cabal >= 1.20,
502 Cabal >= 1.20,
517 QuickCheck >= 2.7,
503 QuickCheck >= 2.7,
518− 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,
519− base >= 4.6 && < 5,
530+ base >= 4.8 && < 5,
520 bytestring,
531 bytestring,
521 containers,
532 containers,
522 deepseq >= 1.1 && < 1.5,
533 deepseq >= 1.1 && < 1.5,
@@ -528,7 +539,6 @@ test-suite verify-layers-span-generation
528
539
529test-suite verify-utf8-width
540test-suite verify-utf8-width
530 default-language: Haskell2010
541 default-language: Haskell2010
531− default-extensions: ScopedTypeVariables
532
542
533 type: detailed-0.9
543 type: detailed-0.9
534
544
@@ -541,8 +551,8 @@ test-suite verify-utf8-width
541 build-depends: vty,
551 build-depends: vty,
542 Cabal >= 1.20,
552 Cabal >= 1.20,
543 QuickCheck >= 2.7,
553 QuickCheck >= 2.7,
544− random >= 1.0 && < 1.2,
554+ random >= 1.0 && < 1.3,
545− base >= 4.6 && < 5,
555+ base >= 4.8 && < 5,
546 bytestring,
556 bytestring,
547 containers,
557 containers,
548 deepseq >= 1.1 && < 1.5,
558 deepseq >= 1.1 && < 1.5,
@@ -554,7 +564,6 @@ test-suite verify-utf8-width
554
564
555test-suite verify-using-mock-input
565test-suite verify-using-mock-input
556 default-language: Haskell2010
566 default-language: Haskell2010
557− default-extensions: ScopedTypeVariables
558
567
559 type: exitcode-stdio-1.0
568 type: exitcode-stdio-1.0
560
569
@@ -562,6 +571,8 @@ test-suite verify-using-mock-input
562
571
563 main-is: VerifyUsingMockInput.hs
572 main-is: VerifyUsingMockInput.hs
564
573
574+ other-modules: Verify.Graphics.Vty.Output
575+
565 build-depends: vty,
576 build-depends: vty,
566 Cabal >= 1.20,
577 Cabal >= 1.20,
567 QuickCheck >= 2.7,
578 QuickCheck >= 2.7,
@@ -569,8 +580,8 @@ test-suite verify-using-mock-input
569 quickcheck-assertions >= 0.1.1,
580 quickcheck-assertions >= 0.1.1,
570 test-framework == 0.8.*,
581 test-framework == 0.8.*,
571 test-framework-smallcheck == 0.2.*,
582 test-framework-smallcheck == 0.2.*,
572− random >= 1.0 && < 1.2,
583+ random >= 1.0 && < 1.3,
573− base >= 4.6 && < 5,
584+ base >= 4.8 && < 5,
574 bytestring,
585 bytestring,
575 containers,
586 containers,
576 deepseq >= 1.1 && < 1.5,
587 deepseq >= 1.1 && < 1.5,
@@ -588,7 +599,6 @@ test-suite verify-using-mock-input
588
599
589test-suite verify-config
600test-suite verify-config
590 default-language: Haskell2010
601 default-language: Haskell2010
591− default-extensions: ScopedTypeVariables
592
602
593 type: exitcode-stdio-1.0
603 type: exitcode-stdio-1.0
594
604
@@ -605,8 +615,8 @@ test-suite verify-config
605 test-framework == 0.8.*,
615 test-framework == 0.8.*,
606 test-framework-smallcheck == 0.2.*,
616 test-framework-smallcheck == 0.2.*,
607 test-framework-hunit,
617 test-framework-hunit,
608− random >= 1.0 && < 1.2,
618+ random >= 1.0 && < 1.3,
609− base >= 4.6 && < 5,
619+ base >= 4.8 && < 5,
610 bytestring,
620 bytestring,
611 containers,
621 containers,
612 deepseq >= 1.1 && < 1.5,
622 deepseq >= 1.1 && < 1.5,