on master help sign in
.travis.yml+100−17
since splitsnapshots
unifiedsplit
@@ -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+759−366
@@ -1,468 +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+
15.18
3095.18
310+----
311+
2API changes:
312API changes:
3− - Added support for hyperlinking attributes (thanks Getty Ritter). This
313+* Added support for hyperlinking attributes (thanks Getty Ritter). This
4− change adds a new Attr field for containing the hyperlink to apply,
314+ change adds a new Attr field for containing the hyperlink to apply,
5− as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda
315+ as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda
6
316
75.17.1
3175.17.1
318+------
319+
8− - withStyle now ignores zero arguments, leaving attribute styles
320+* withStyle now ignores zero arguments, leaving attribute styles
9− untouched if the input style is the null style
321+ untouched if the input style is the null style
10
322
115.17
3235.17
324+----
325+
12API changes:
326API changes:
13− - Add support for terminal focus events. This change adds a new mode
327+* Add support for terminal focus events. This change adds a new mode
14− usable with setMode, Focus, that requests that the terminal send
328+ usable with setMode, Focus, that requests that the terminal send
15− events on focus lose/gain. This change also adds two new Event
329+ events on focus lose/gain. This change also adds two new Event
16− constructors, EvLostFocus and EvGainedFocus.
330+ constructors, EvLostFocus and EvGainedFocus.
17− - No longer enable UTF8 mouse event encoding. This encoding was not
331+* No longer enable UTF8 mouse event encoding. This encoding was not
18− working properly with Terminal.app, and using the other modes (SGR,
332+ working properly with Terminal.app, and using the other modes (SGR,
19− etc.) work.
333+ etc.) work.
20− - Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
334+* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
21− #131)
335+ #131)
22
336
235.16
3375.16
338+----
339+
24API changes:
340API changes:
25− - Added support for mouse wheel events while in mouse mode. The Button
341+* Added support for mouse wheel events while in mouse mode. The Button
26− type got two new constructors as a result: BScrollUp and BScrollDown.
342+ type got two new constructors as a result: BScrollUp and BScrollDown.
27− Thanks to doublescale@tutanota.com for this contribution!
343+ Thanks to doublescale@tutanota.com for this contribution!
28
344
29Bug fixes:
345Bug fixes:
30− - charFill now clamps negative arguments to zero (thanks Eric
346+* charFill now clamps negative arguments to zero (thanks Eric Mertens!)
31− Mertens!)
32
347
335.15.1
3485.15.1
349+------
350+
34Package changes:
351Package changes:
35− - Documentation files are now marked accordingly (thanks Michal
352+* Documentation files are now marked accordingly (thanks Michal
36− Suchánek)
353+ Suchánek)
37
354
38Bug fixes:
355Bug fixes:
39− - translateX/Y: fix negative translations
356+* translateX/Y: fix negative translations
40
357
415.15
3585.15
359+----
360+
42Package changes:
361Package changes:
43− - Discontinued support for GHC versions prior to 7.10.1.
362+* Discontinued support for GHC versions prior to 7.10.1.
44− - Removed instructions and configuration for Stack builds since they
363+* Removed instructions and configuration for Stack builds since they
45− are no longer supported.
364+ are no longer supported.
46− - Clarified README mention of (lack of) Windows support (contributors
365+* Clarified README mention of (lack of) Windows support (contributors
47− wanted, though!)
366+ wanted, though!)
48− - Removed dependency on data-default (see below).
367+* Removed dependency on data-default (see below).
49
368
50API changes:
369API changes:
51− - Moved color definitions from Attributes to Color module.
370+* Moved color definitions from Attributes to Color module.
52− - 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
53− 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
372+ 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
54− - Graphics.Vty.Output no longer re-exports
373+* Graphics.Vty.Output no longer re-exports
55− Graphics.Vty.Output.Interface.
374+ Graphics.Vty.Output.Interface.
56− - Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
375+* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
57− accessors to Graphics.Vty.Image.
376+ accessors to Graphics.Vty.Image.
58− - Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
377+* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
59− - Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
378+* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
60
379
615.14
3805.14
381+----
382+
62− - addMaybeClippedJoin: instead of raising an exception when the join
383+* addMaybeClippedJoin: instead of raising an exception when the join
63− is totally clipped, just reduce the clip amount and continue
384+ is totally clipped, just reduce the clip amount and continue
64− - addMaybeClipped: skip blit of joins when their primary dimension is
385+* addMaybeClipped: skip blit of joins when their primary dimension is
65− zero
386+ zero
66− - 'string' and related text functions no longer treat an empty string
387+* 'string' and related text functions no longer treat an empty string
67− 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
68− 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.
69
390
705.13
3915.13
392+----
393+
71− - Reverted changes in 5.12 due to disagreements between terminal
394+* Reverted changes in 5.12 due to disagreements between terminal
72− emulators and utf8proc; for more details, please see the ticket
395+ emulators and utf8proc; for more details, please see the ticket
73− discussion at
396+ discussion at
74− https://github.com/coreyoconnor/vty/issues/115
397+ https://github.com/coreyoconnor/vty/issues/115
75
398
765.12
3995.12
400+----
401+
77− - Replaced 'wcwidth' with a call to the utf8proc library's character
402+* Replaced 'wcwidth' with a call to the utf8proc library's character
78− 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
79− 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
80− characters.
405+ characters.
81− - Added a bundled version of the utf8proc C library.
406+* Added a bundled version of the utf8proc C library.
82
407
835.11.3
4085.11.3
409+------
410+
84− - Fix mouse event offsets in mouse-up events
411+* Fix mouse event offsets in mouse-up events
85
412
865.11.2
4135.11.2
414+------
415+
87− - 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
88− window is (0,0) rather than (1,1).
417+ is (0,0) rather than (1,1).
89
418
905.11.1
4195.11.1
420+------
421+
91− - Add Generic instance for Image
422+* Add Generic instance for Image
92− - nextEvent: stop trying to refresh on a resize event (fixes segfault
423+* nextEvent: stop trying to refresh on a resize event (fixes segfault
93− on refresh with normal cursor positioning mode)
424+ on refresh with normal cursor positioning mode)
94− - Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
425+* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
95− - Update maintainer
426+* Update maintainer
96
427
975.11
4285.11
429+----
430+
98− - Vty now raises a VtyConfigurationError exception when the TERM
431+* Vty now raises a VtyConfigurationError exception when the TERM
99− evironment variable is missing (thanks Eric Mertens)
432+ evironment variable is missing (thanks Eric Mertens)
100− - Graphics.Vty.Config got an explicit export list to avoid accidentally
433+* Graphics.Vty.Config got an explicit export list to avoid accidentally
101− exporting internal types (thanks Eric Mertens)
434+ exporting internal types (thanks Eric Mertens)
102
435
1035.10
4365.10
437+----
438+
104− - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
439+* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
105− mode provides greater control over cursor positioning by bypassing
440+ mode provides greater control over cursor positioning by bypassing
106− the logical positioning provided by default. Rather than positioning
441+ the logical positioning provided by default. Rather than positioning
107− the cursor by looking at the widths of characters involved, this
442+ the cursor by looking at the widths of characters involved, this
108− constructor lets you provide a physical row and column instead. This
443+ constructor lets you provide a physical row and column instead. This
109− is useful in more sophisticated programs. (thanks Eric Mertens)
444+ is useful in more sophisticated programs. (thanks Eric Mertens)
110− - Added a new Generic-derived config parser (thanks Eric Mertens)
445+* Added a new Generic-derived config parser (thanks Eric Mertens)
111− - Fixed the MShift case in the configuration file parser (thanks Eric
446+* Fixed the MShift case in the configuration file parser (thanks Eric
112− Mertens)
447+ Mertens)
113− - Fixed wcwidth import and matched safeWcswidth to its documented
448+* Fixed wcwidth import and matched safeWcswidth to its documented
114− behavior. Previously vty_mk_wcwidth was being imported with
449+ behavior. Previously vty_mk_wcwidth was being imported with the
115− 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
116− wrong Int value. Additionally safeWcswidth was using the unsafe
451+ value. Additionally safeWcswidth was using the unsafe character width
117− character width function and only ensuring that the final result was
452+ function and only ensuring that the final result was non-negative.
118− non-negative. (thanks Eric Mertens)
453+ (thanks Eric Mertens)
119
454
1205.9.1
4555.9.1
456+-----
457+
121− - Vty now only emits UTF8 charset sequences in terminals without a
458+* Vty now only emits UTF8 charset sequences in terminals without a
122− preexisting UTF8 declaration to avoid emitting garbage sequences
459+ preexisting UTF8 declaration to avoid emitting garbage sequences
123− (fixes #89)
460+ (fixes #89)
124
461
1255.9
4625.9
463+---
464+
126− - Added new Output methods supportsBell and ringTerminalBell to find
465+* Added new Output methods supportsBell and ringTerminalBell to find out
127− 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)
128− #102)
129
467
1305.8.1
4685.8.1
469+-----
470+
131− - Fixed "refresh" to work as advertised (see #104)
471+* Fixed "refresh" to work as advertised (see #104)
132
472
1335.8
4735.8
474+---
475+
134− - 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
135− ByteString rather than a String to allow the application to decode
477+ ByteString rather than a String to allow the application to decode how
136− how best to decode it
478+ best to decode it
137
479
1385.7.1
4805.7.1
481+-----
482+
139− - ModeDemo: added an explicit Control.Applicative import for older
483+* ModeDemo: added an explicit Control.Applicative import for older GHCs
140− GHCs
141
484
1425.7
4855.7
486+---
487+
143− - Mouse and paste modes are now off by default.
488+* Mouse and paste modes are now off by default.
144− - The Config type got new fields: mouseMode and bracketedPasteMode.
489+* The Config type got new fields: mouseMode and bracketedPasteMode.
145− These determine whether these modes are enabled initially (for
490+ These determine whether these modes are enabled initially (for
146− terminals that support them).
491+ terminals that support them).
147− - Added a Mode type for modal terminal features (mouse events,
492+* Added a Mode type for modal terminal features (mouse events,
148− bracketed paste mode) that is used with new Output interface
493+ bracketed paste mode) that is used with new Output interface
149− functions:
494+ functions:
150− * supportsMode :: Mode -> Bool tells whether the device supports a
495+ * supportsMode :: Mode -> Bool tells whether the device supports a
151− mode
496+ mode
152− * setMode :: Mode -> Bool -> IO () turns a mode on or off
497+ * setMode :: Mode -> Bool -> IO () turns a mode on or off
153− * 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
154− off
499+ off
155− - 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
156
501
1575.6
5025.6
503+---
504+
158− - Added support for normal and extended mouse modes in Xterm-like
505+* Added support for normal and extended mouse modes in Xterm-like
159− terminals via the MouseDown and MouseUp Event constructors
506+ terminals via the MouseDown and MouseUp Event constructors
160− - Added support for bracketed paste mode in Xterm-like terminals via
507+* Added support for bracketed paste mode in Xterm-like terminals via
161− the EvPaste event constructor
508+ the EvPaste event constructor
162− - Added derived Show instances for Event and Button (thanks Felix
509+* Added derived Show instances for Event and Button (thanks Felix
163− Hirn)
510+ Hirn)
164− - Now TERM values containing "screen" will automatically use the
511+* Now TERM values containing "screen" will automatically use the
165− XtermColor driver rather than just TerminfoBased
512+ XtermColor driver rather than just TerminfoBased
166
513
1675.5.0
5145.5.0
515+-----
516+
168− - Replaced lens dependency with microlens, microlens-mtl, microlens-th
517+* Replaced lens dependency with microlens, microlens-mtl, microlens-th
169− dependencies. Issue #90
518+ dependencies. Issue #90
170− - Thanks Jonathan Daugherty
519+ * Thanks Jonathan Daugherty
171− - Cabal corrections.
520+* Cabal corrections.
172− - Thanks Lennart Spitzner
521+ * Thanks Lennart Spitzner
173
522
1745.4.0
5235.4.0
524+-----
525+
175− - Changed eventChannel of Graphics.Vty.Input from Chan to TChan.
526+* Changed eventChannel of Graphics.Vty.Input from Chan to
176− This enables clients to query if there are no pending events. The
527+ TChan. This enables clients to query if there are no pending
177− Graphics.Vty interface nextEvent is unchanged. Clients that use
528+ events. The Graphics.Vty interface nextEvent is unchanged.
178− eventChannel directly will require updating.
529+ Clients that use eventChannel directly will require updating.
179− https://github.com/coreyoconnor/vty/issues/60
530+ https://github.com/coreyoconnor/vty/issues/60
531+
1805.3.1
5325.3.1
533+-----
534+
181− - 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
182− to possibly breaking this on reasonable GHC versions
536+ possibly breaking this on reasonable GHC versions
183
537
1845.3
5385.3
539+---
540+
185− - Upgraded QuickCheck dependency to 2.7
541+* Upgraded QuickCheck dependency to 2.7
186− - The standard IO Config (standardIOConfig) was overriding any
542+* The standard IO Config (standardIOConfig) was overriding any provided
187− provided application config. In addition, the inputFd and outputFd
543+ application config. In addition, the inputFd and outputFd could not be
188− could not be changed if mkVty was used. Fixed.
544+ changed if mkVty was used. Fixed.
189− - Correct handling of display attributes at end of line. The output
545+* Correct handling of display attributes at end of line. The output
190− 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
191− 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
192− 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
193− 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
194− IIRC Yi requires the old behavior to display the selection region
550+ requires the old behavior to display the selection region correctly.
195− correctly.
196− - shutdown of the input thread is now performed using killThread and
551+* shutdown of the input thread is now performed using killThread and
197− synchronization on an MVar. For correct handling of the terminal
552+ synchronization on an MVar. For correct handling of the terminal read
198− 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.
199− thread. This places a threadWaitRead, which will be interrupted by
554+ This places a threadWaitRead, which will be interrupted by the
200− the killThread, prior to the uninterruptable read. An alternative
555+ killThread, prior to the uninterruptable read. An alternative would be
201− would be to re-import the read foreign call as interruptable.
556+ to re-import the read foreign call as interruptable.
202
557
2035.2.11
5585.2.11
559+------
560+
204− - deepseq bounds increased for tests.
561+* deepseq bounds increased for tests.
205− - Clean up warnings when compiling on 7.10
562+* Clean up warnings when compiling on 7.10
206− - Thanks Eric Mertens
563+ * Thanks Eric Mertens
207− - Avoid discarding input bytes after multi-byte encoded codepoint
564+* Avoid discarding input bytes after multi-byte encoded codepoint
208− - Thanks Eric Mertens
565+ * Thanks Eric Mertens
209
566
2105.2.10
5675.2.10
568+------
569+
211− - "str" now returns EmptyImage for empty strings to match behavior of
570+* "str" now returns EmptyImage for empty strings to match behavior of
212− other string-like Image constructors (fixes #74)
571+ other string-like Image constructors (fixes #74)
213− - Thanks Jonathan Daugherty
572+ * Thanks Jonathan Daugherty
214
573
2155.2.9
5745.2.9
575+-----
576+
216− - dependency version bumps
577+* dependency version bumps
217− - https://github.com/coreyoconnor/vty/pull/71
578+ * https://github.com/coreyoconnor/vty/pull/71
218− - https://github.com/coreyoconnor/vty/pull/70
579+ * https://github.com/coreyoconnor/vty/pull/70
219− - Correct/Simplify the example code
580+* Correct/Simplify the example code
220− - Thanks glguy
581+ * Thanks glguy
221− - https://github.com/coreyoconnor/vty/pull/69
582+ * https://github.com/coreyoconnor/vty/pull/69
222
583
2235.2.8
5845.2.8
585+-----
586+
224− - blaze-builder, lens, utf8-string version constraint bump
587+* blaze-builder, lens, utf8-string version constraint bump
225− - Thanks glguy
588+ * Thanks glguy
226− - https://github.com/coreyoconnor/vty/pull/67
589+ * https://github.com/coreyoconnor/vty/pull/67
227− - Do not differentiate based on TERM_PROGRAM
590+* Do not differentiate based on TERM_PROGRAM
228− - https://github.com/coreyoconnor/vty/issues/68
591+ * https://github.com/coreyoconnor/vty/issues/68
229
592
2305.2.7
5935.2.7
594+-----
595+
231− - lens and deepseq constraint bump + misc
596+* lens and deepseq constraint bump + misc
232− - Thanks ethercrow
597+ * Thanks ethercrow
233− - https://github.com/coreyoconnor/vty/pull/66
598+ * https://github.com/coreyoconnor/vty/pull/66
234
599
2355.2.6
6005.2.6
601+-----
602+
236− - lens constraint bump
603+* lens constraint bump
237− - Thanks alexander-b!
604+ * Thanks alexander-b!
238− - https://github.com/coreyoconnor/vty/pull/64
605+ * https://github.com/coreyoconnor/vty/pull/64
239
606
2405.2.5
6075.2.5
608+-----
609+
241− - lens and random version constraint bump.
610+* lens and random version constraint bump.
242− - Thanks RyanGlScott!
611+ * Thanks RyanGlScott!
243− - https://github.com/coreyoconnor/vty/pull/62
612+ * https://github.com/coreyoconnor/vty/pull/62
244
613
2455.2.4
6145.2.4
615+-----
616+
246− - removed -fpic from cc-options. No longer required.
617+* removed -fpic from cc-options. No longer required.
247− - https://github.com/coreyoconnor/vty/issues/61
618+ * https://github.com/coreyoconnor/vty/issues/61
248− - https://ghc.haskell.org/trac/ghc/ticket/9657
619+ * https://ghc.haskell.org/trac/ghc/ticket/9657
249− - Thanks Fuuzetsu!
620+ * Thanks Fuuzetsu!
250
621
2515.2.3
6225.2.3
623+-----
624+
252− - evaluate/compile the input parsing table once instead of each
625+* evaluate/compile the input parsing table once instead of each
253− keystroke.
626+ keystroke.
254− - https://github.com/coreyoconnor/vty/pull/59
627+ * https://github.com/coreyoconnor/vty/pull/59
255− - Thanks ethercrow!
628+ * Thanks ethercrow!
256
629
2575.2.2
6305.2.2
631+-----
632+
258− - 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.
259− - https://github.com/coreyoconnor/vty/pull/57
634+ * https://github.com/coreyoconnor/vty/pull/57
260− - Thanks ethercrow!
635+ * Thanks ethercrow!
261
636
2625.2.1
6375.2.1
638+-----
639+
263− - Bump upper version bound for lens to 4.5. Thanks markus1189!
640+* Bump upper version bound for lens to 4.5. Thanks markus1189!
264
641
2655.2.0
6425.2.0
643+-----
644+
266− - Config structure now specifies file descriptor to use. The default
645+* Config structure now specifies file descriptor to use. The default
267− is stdInput and stdOutput file descriptors. Previously Vty used
646+ is stdInput and stdOutput file descriptors. Previously Vty used
268− stdInput for input and the follow code for output:
647+ stdInput for input and the follow code for output:
269− - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
648+ * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
270− NoBuffering)
649+ NoBuffering)
271− - the difference was required by Vty.Inline. Now, Vty.Inline uses
650+ * the difference was required by Vty.Inline. Now, Vty.Inline uses
272− the Config structure options to acheive the same effect.
651+ the Config structure options to acheive the same effect.
273− - removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
652+* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
274− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
653+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
275− - added: inputForConfig, outputForConfig
654+* added: inputForConfig, outputForConfig
276− - updates to vty-rogue from jtdaugherty. Thanks!
655+* updates to vty-rogue from jtdaugherty. Thanks!
277− - 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.
278− - 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
279
658
2805.1.4
6595.1.4
660+-----
661+
281− - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
662+* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
282
663
2835.1.1
6645.1.1
665+-----
666+
284− - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
667+* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
285− - jtdaugherty resolved a number of compiler warnings. Thanks!
668+* jtdaugherty resolved a number of compiler warnings. Thanks!
286
669
2875.1.0
6705.1.0
671+-----
672+
288− - vmin and vtime can be specified however the application requires.
673+* vmin and vtime can be specified however the application requires.
289− See Graphics.Vty.Config.
674+ See Graphics.Vty.Config.
290− - fixed the processing of input when vmin is set > 1.
675+* fixed the processing of input when vmin is set > 1.
291
676
2925.0.0
6775.0.0
678+-----
679+
293− - The naming convention now matches:
680+* The naming convention now matches:
294− - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
681+ * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
295− - all projects using vty for input must be compiled with -threaded.
682+* all projects using vty for input must be compiled with -threaded.
296− Please notify vty author if this is not acceptable.
683+ Please notify vty author if this is not acceptable.
297− - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
684+* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
298− vty with the default configuration.
685+ vty with the default configuration.
299− - input handling changes
686+* input handling changes
300− - KASCII is now KChar
687+ * KASCII is now KChar
301− - KPN5 is now KCenter
688+ * KPN5 is now KCenter
302− - tests exist.
689+ * tests exist.
303− - Applications can add to the input tables by setting inputMap of
690+ * Applications can add to the input tables by setting inputMap of
304− the Config. See Graphics.Vty.Config
691+ the Config. See Graphics.Vty.Config
305− - 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
306− applications. See Graphics.Vty.Config
693+ applications. See Graphics.Vty.Config
307− - terminal timing is now handled by selecting an appropriate VTIME.
694+ * terminal timing is now handled by selecting an appropriate VTIME.
308− Previously this was implemented within Vty itself. This reduced
695+ Previously this was implemented within Vty itself. This reduced
309− complexity in vty but provides a different meta key behavior and
696+ complexity in vty but provides a different meta key behavior and
310− implies a requirement on -threaded.
697+ implies a requirement on -threaded.
311− - 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
312− key is the singleEscPeriod of the Input Config structure.
699+ key is the singleEscPeriod of the Input Config structure.
313− - removed the typeclass based terminal and display context interface
700+* removed the typeclass based terminal and display context interface
314− in favor of a data structure of properties interface.
701+ in favor of a data structure of properties interface.
315− - renamed the Terminal interface to Output
702+* renamed the Terminal interface to Output
316− - The default picture for an image now uses the "clear" background.
703+* The default picture for an image now uses the "clear" background.
317− This background fills background spans with spaces or just ends the
704+ This background fills background spans with spaces or just ends the
318− line.
705+ line.
319− - Previously the background defaulted to the space character. This
706+ * Previously the background defaulted to the space character. This
320− 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
321− up with extra spaces at the end of the line.
708+ up with extra spaces at the end of the line.
322− - Layer support
709+* Layer support
323− - Each layer is an image.
710+ * Each layer is an image.
324− - The layers for a picture are a list of images.
711+ * The layers for a picture are a list of images.
325− - 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
326− top to bottom.
713+ top to bottom.
327− - The transparent areas for a layer are the backgroundFill areas.
714+ * The transparent areas for a layer are the backgroundFill areas.
328− backgroundFill is added to pad images when images of different
715+ backgroundFill is added to pad images when images of different
329− sizes are joined.
716+ sizes are joined.
330− - If the background is clear there is no background layer.
717+ * If the background is clear there is no background layer.
331− - 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
332− background layer.
719+ background layer.
333− - emptyPicture is a Picture with no layers and no cursor
720+ * emptyPicture is a Picture with no layers and no cursor
334− - 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
335− given Picture.
722+ given Picture.
336− - compatibility improvements:
723+* compatibility improvements:
337− - terminfo based terminals with no cursor support are silently
724+ * terminfo based terminals with no cursor support are silently
338− accepted. The cursor visibility changes in the Picture will have
725+ accepted. The cursor visibility changes in the Picture will have
339− no effect.
726+ no effect.
340− - alternate (setf/setb) color maps supported. Though colors beyond
727+ * alternate (setf/setb) color maps supported. Though colors beyond
341− the first 8 are just a guess.
728+ the first 8 are just a guess.
342− - added "rgbColor" for easy support of RGB specified colors.
729+ * added "rgbColor" for easy support of RGB specified colors.
343− - Both applications and users can add to the mapping used to
730+ * Both applications and users can add to the mapping used to
344− translate from input bytes to events.
731+ translate from input bytes to events.
345− - Additional information about input and output process can be
732+* Additional information about input and output process can be
346− appended to a debug log
733+ appended to a debug log
347− - Set environment variable VTY_DEBUG_LOG to path of debug log
734+ * Set environment variable VTY_DEBUG_LOG to path of debug log
348− - Or use "debugLog <path>" config directive
735+ * Or use "debugLog <path>" config directive
349− - Or set 'debugLog' property of the Config provided to mkVty.
736+ * Or set 'debugLog' property of the Config provided to mkVty.
350− - examples moved to vty-examples package. See test directory for cabal
737+* examples moved to vty-examples package. See test directory for cabal
351− file.
738+ file.
352− - vty-interactive-terminal-test
739+ * vty-interactive-terminal-test
353− - interactive test. Useful for building a bug report for vty's
740+ * interactive test. Useful for building a bug report for vty's
354− author.
741+ author.
355− - test/interactive_terminal_test.hs
742+ * test/interactive_terminal_test.hs
356− - vty-event-echo
743+ * vty-event-echo
357− - view a input event log for vty. Example of interacting with
744+ * view a input event log for vty. Example of interacting with
358− user.
745+ user.
359− - test/EventEcho.hs
746+ * test/EventEcho.hs
360− - vty-rogue
747+ * vty-rogue
361− - 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
362− build operations.
749+ build operations.
363− - test/Rogue.hs
750+ * test/Rogue.hs
364− - vty-benchmark
751+ * vty-benchmark
365− - benchmarks vty. A series of tests that push random pictures to
752+ * benchmarks vty. A series of tests that push random pictures to
366− the terminal. The random pictures are generated using
753+ the terminal. The random pictures are generated using
367− QuickCheck. The same generators used in the automated tests.
754+ QuickCheck. The same generators used in the automated tests.
368− - test/benchmark.hs
755+ * test/benchmark.hs
369
756
3704.7.0.0
7574.7.0.0
371− - API changes:
758+-------
372− - Added Graphics.Vty.Image.crop: Ensure an image is no larger
373− than the specified size.
374− - Added Graphics.Vty.Image.pad: Ensure an image is no smaller
375− than the specified size.
376− - Added Graphics.Vty.Image.translate: Offset an image.
377− - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
378
759
379−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.
380
767
3814.2.1.0
7684.2.1.0
769+-------
770+
382− - API changes:
771+API changes:
383− - Attr record accessor fore_color changed to attr_fore_color
772+* Attr record accessor fore_color changed to attr_fore_color
384− - Attr record accessor back_color changed to attr_back_color
773+* Attr record accessor back_color changed to attr_back_color
385− - Attr record accessor style changed to attr_style
774+* Attr record accessor style changed to attr_style
386− - Added an "inline" display attribute changing DSL:
775+* Added an "inline" display attribute changing DSL:
387− - put_attr_change applies a display attribute change
776+ * put_attr_change applies a display attribute change
388− immediately to a terminal
777+ immediately to a terminal
389− - For instance, can be used to change the display attrbiutes
778+ * For instance, can be used to change the display attrbiutes
390− of text output via putStrLn and putStr. EX:
779+ of text output via putStrLn and putStr. EX:
391− "put_attr_change $ back_color red" will set the background
780+ "put_attr_change $ back_color red" will set the background
392− color to red.
781+ color to red.
393− - Changes do not apply to a Picture output via output_picture.
782+ * Changes do not apply to a Picture output via output_picture.
394− - See Graphics.Vty.Inline
783+ * See Graphics.Vty.Inline
395− - Moved all IO actions into any monad an instance of MonadIO
784+* Moved all IO actions into any monad an instance of MonadIO
396
785
3974.0.0.1
7864.0.0.1
787+-------
788+
398− - binding for mk_wcswidth was incorrect. Most platforms just
789+* binding for mk_wcswidth was incorrect. Most platforms just
399− magically worked due to coincidence.
790+ magically worked due to coincidence.
400
791
4014.0.0
7924.0.0
793+-----
794+
402− - API changes:
795+API changes:
403− - "getSize" has been removed. Use "terminal vty >>= display_bounds"
796+* "getSize" has been removed. Use "terminal vty >>= display_bounds"
404− where "vty" is an instance of the Vty data structure.
797+ where "vty" is an instance of the Vty data structure.
405− - added a "terminal" field to the Vty data structure. Accesses the
798+* added a "terminal" field to the Vty data structure. Accesses the
406− TerminalHandle associated with the Vty instance.
799+ TerminalHandle associated with the Vty instance.
407− - Graphics.Vty.Types has undergone a number of changes. Summary:
800+* Graphics.Vty.Types has undergone a number of changes. Summary:
408− - Partitioned into Graphics.Vty.Attributes for display attributes.
801+ * Partitioned into Graphics.Vty.Attributes for display attributes.
409− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
802+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
410− for final picture construction.
803+ for final picture construction.
411− - Graphics.Vty.Attributes:
804+* Graphics.Vty.Attributes:
412− - "setFG" and "setBG" are now "with_fore_color" and
805+ * "setFG" and "setBG" are now "with_fore_color" and
413− "with_back_color"
806+ "with_back_color"
414− - All other "set.." equations similarly replaced.
807+ * All other "set.." equations similarly replaced.
415− - "attr" is now "def_attr", short for "default display attributes"
808+ * "attr" is now "def_attr", short for "default display attributes"
416− Also added a "current_attr" for "currently applied display
809+ Also added a "current_attr" for "currently applied display
417− attributes"
810+ attributes"
418− - Graphics.Vty.Image:
811+* Graphics.Vty.Image:
419− - "horzcat" is now "horiz_cat"
812+ * "horzcat" is now "horiz_cat"
420− - "vertcat" is now "vert_cat"
813+ * "vertcat" is now "vert_cat"
421− - "renderBS" is now "utf8_bytestring"
814+ * "renderBS" is now "utf8_bytestring"
422− - "renderChar" is now "char"
815+ * "renderChar" is now "char"
423− - "renderFill" is now "char_fill"
816+ * "renderFill" is now "char_fill"
424− - added a "utf8_string" and "string" (AKA "iso_10464_string") for
817+ * added a "utf8_string" and "string" (AKA "iso_10464_string") for
425− UTF-8 encoded Strings and ISO-10464 encoded Strings. String
818+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String
426− literals in GHC have an ISO-10464 runtime representation.
819+ literals in GHC have an ISO-10464 runtime representation.
427− - Graphics.Vty.Picture:
820+* Graphics.Vty.Picture:
428− - exports Graphics.Vty.Image
821+ * exports Graphics.Vty.Image
429− - "pic" is now "pic_for_image"
822+ * "pic" is now "pic_for_image"
430− - added API for setting background fill pattern.
823+ * added API for setting background fill pattern.
431− - Completely rewritten output backend.
824+* Completely rewritten output backend.
432− - Efficient, scanline style output span generator. Has not been
825+ * Efficient, scanline style output span generator. Has not been
433− fully optimized, but good enough.
826+ fully optimized, but good enough.
434− - The details required to display the desired picture on a
827+ * The details required to display the desired picture on a
435− terminal are well encapsulated.
828+ terminal are well encapsulated.
436− - Terminfo based display terminal implementation. With specialized
829+ * Terminfo based display terminal implementation. With specialized
437− derivitives for xterm, Terminal.app, and iTerm.app.
830+ derivitives for xterm, Terminal.app, and iTerm.app.
438− - Attempts to robustly handle even terminals that don't
831+ * Attempts to robustly handle even terminals that don't
439− support all display attributes.
832+ support all display attributes.
440− - I've tested the following terminals with success: iTerm.app,
833+ * I've tested the following terminals with success: iTerm.app,
441− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
834+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
442− konsole, screen, linux vty. Hopefully you will be as
835+ konsole, screen, linux vty. Hopefully you will be as
443− successfull.
836+ successfull.
444− - Improved unicode support. Double wide characters will display as
837+ * Improved unicode support. Double wide characters will display as
445− expected.
838+ expected.
446− - 256 color support. See Graphics.Vty.Attributes.Color240. The actual
839+* 256 color support. See Graphics.Vty.Attributes.Color240. The actual
447− output color is adjusted according to the number of colors the
840+ output color is adjusted according to the number of colors the
448− terminal supports.
841+ terminal supports.
449− - The Graphics.Vty.Image combinators no longer require matching
842+* The Graphics.Vty.Image combinators no longer require matching
450− dimensions to arguments. Unspecified areas are filled in with a
843+ dimensions to arguments. Unspecified areas are filled in with a
451− user-customizable background pattern. See Graphics.Vty.Picture.
844+ user-customizable background pattern. See Graphics.Vty.Picture.
452− - output images are always cropped to display size.
845+* output images are always cropped to display size.
453− - Significant code coverage by QuickCheck tests. An interactive test
846+* Significant code coverage by QuickCheck tests. An interactive test
454− for those final properties that couldn't be automatically verified.
847+ for those final properties that couldn't be automatically verified.
455
848
456Issues resolved:
849Issues resolved:
457− - "gnome terminal displays non-basic attributes as strikethrough"
850+* "gnome terminal displays non-basic attributes as strikethrough"
458− - http://trac.haskell.org/vty/ticket/14
851+ * http://trac.haskell.org/vty/ticket/14
459− - "Multi-byte characters are not displayed correctly on update"
852+* "Multi-byte characters are not displayed correctly on update"
460− - http://trac.haskell.org/vty/ticket/10
853+ * http://trac.haskell.org/vty/ticket/10
461− - "Redraw does not handle rendering a line that extends beyond screen
854+* "Redraw does not handle rendering a line that extends beyond screen
462− width characters"
855+ width characters"
463− - http://trac.haskell.org/vty/ticket/13
856+ * http://trac.haskell.org/vty/ticket/13
464− - "The <|> and <-> combinators should be more forgiving of mismatched
857+* "The <|> and <-> combinators should be more forgiving of mismatched
465− dimensions"
858+ dimensions"
466− - http://trac.haskell.org/vty/ticket/9
859+ * http://trac.haskell.org/vty/ticket/9
467− - "256-color support"
860+* "256-color support"
468− - 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+36−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--
@@ -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
@@ -52,19 +56,16 @@ module Graphics.Vty.Attributes
52
56
53 -- * Setting hyperlinks
57 -- * Setting hyperlinks
54 , withURL
58 , withURL
55−
56− -- * Colors
57− , module Graphics.Vty.Attributes.Color
58− , module Graphics.Vty.Attributes.Color240
59 )
59 )
60where
60where
61
61
62+import Control.DeepSeq
62import Data.Bits
63import Data.Bits
63import Data.Text (Text)
64import Data.Text (Text)
64import Data.Word
65import Data.Word
66+import GHC.Generics
65
67
66import Graphics.Vty.Attributes.Color
68import Graphics.Vty.Attributes.Color
67−import Graphics.Vty.Attributes.Color240
68
69
69-- | A display attribute defines the Color and Style of all the
70-- | A display attribute defines the Color and Style of all the
70-- characters rendered after the attribute is applied.
71-- characters rendered after the attribute is applied.
@@ -78,7 +79,7 @@ data Attr = Attr
78 , attrForeColor :: !(MaybeDefault Color)
79 , attrForeColor :: !(MaybeDefault Color)
79 , attrBackColor :: !(MaybeDefault Color)
80 , attrBackColor :: !(MaybeDefault Color)
80 , attrURL :: !(MaybeDefault Text)
81 , attrURL :: !(MaybeDefault Text)
81− } deriving ( Eq, Show, Read )
82+ } deriving ( Eq, Show, Read, Generic, NFData )
82
83
83-- 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
84-- 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
@@ -99,26 +100,19 @@ data Attr = Attr
99-- __ - unused
100-- __ - unused
100--
101--
101-- Next is the style flags
102-- Next is the style flags
102−-- SURBDO__
103+-- SURBDOI_
103-- S - standout
104-- S - standout
104-- U - underline
105-- U - underline
105-- R - reverse video
106-- R - reverse video
106-- B - blink
107-- B - blink
107-- D - dim
108-- D - dim
108-- O - bold
109-- O - bold
110+-- I - italic
109−-- __ - unused
111+-- _ - unused
110--
112--
111-- Then the foreground color encoded into 8 bits.
113-- Then the foreground color encoded into 8 bits.
112-- Then the background color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
113
115
114−instance Monoid Attr where
115− mempty = Attr mempty mempty mempty mempty
116− mappend attr0 attr1 =
117− Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
118− ( attrForeColor attr0 `mappend` attrForeColor attr1 )
119− ( attrBackColor attr0 `mappend` attrBackColor attr1 )
120− ( attrURL attr0 `mappend` attrURL attr1 )
121−
122-- | Specifies the display attributes such that the final style and
116-- | Specifies the display attributes such that the final style and
123-- color values do not depend on the previously applied display
117-- color values do not depend on the previously applied display
124-- attribute. The display attributes can still depend on the terminal's
118-- attribute. The display attributes can still depend on the terminal's
@@ -133,33 +127,20 @@ data FixedAttr = FixedAttr
133-- | The style and color attributes can either be the terminal defaults.
127-- | The style and color attributes can either be the terminal defaults.
134-- 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
135-- value.
129-- value.
136−data MaybeDefault v where
130+data MaybeDefault v = Default | KeepCurrent | SetTo !v
137− Default :: MaybeDefault v
131+ deriving (Eq, Read, Show)
138− KeepCurrent :: MaybeDefault v
132+
139− SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
140−
141−deriving instance Eq v => Eq (MaybeDefault v)
142−deriving instance Eq v => Show (MaybeDefault v)
143−deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
144−
145−instance Eq v => Monoid ( MaybeDefault v ) where
133+instance (NFData v) => NFData (MaybeDefault v) where
146− mempty = KeepCurrent
134+ rnf Default = ()
147− mappend Default Default = Default
148− mappend Default KeepCurrent = Default
149− mappend Default ( SetTo v ) = SetTo v
150− mappend KeepCurrent Default = Default
151− mappend KeepCurrent KeepCurrent = KeepCurrent
135+ rnf KeepCurrent = ()
152− mappend KeepCurrent ( SetTo v ) = SetTo v
136+ rnf (SetTo v) = rnf v
153− mappend ( SetTo _v ) Default = Default
154− mappend ( SetTo v ) KeepCurrent = SetTo v
155− mappend ( SetTo _ ) ( SetTo v ) = SetTo v
156
137
157-- | 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
158-- 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
159-- if the style attribute should not be applied.
140-- if the style attribute should not be applied.
160type Style = Word8
141type Style = Word8
161
142
162−-- | The 6 possible style attributes:
143+-- | Valid style attributes include:
163--
144--
164-- * standout
145-- * standout
165--
146--
@@ -173,15 +154,21 @@ type Style = Word8
173--
154--
174-- * bold/bright
155-- * bold/bright
175--
156--
157+-- * italic
158+--
159+-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160+--
176-- (The invisible, protect, and altcharset display attributes some
161-- (The invisible, protect, and altcharset display attributes some
177-- terminals support are not supported via VTY.)
162-- terminals support are not supported via VTY.)
178−standout, underline, reverseVideo, blink, dim, bold :: Style
163+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
179standout = 0x01
164standout = 0x01
180underline = 0x02
165underline = 0x02
181−reverseVideo = 0x04
166+reverseVideo = 0x04
182blink = 0x08
167blink = 0x08
183dim = 0x10
168dim = 0x10
184bold = 0x20
169bold = 0x20
170+italic = 0x40
171+strikethrough = 0x80
185
172
186defaultStyleMask :: Style
173defaultStyleMask :: Style
187defaultStyleMask = 0x00
174defaultStyleMask = 0x00
@@ -215,8 +202,12 @@ withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFl
215-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
202-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
216-- These escape sequences are comparatively new and aren't widely
203-- These escape sequences are comparatively new and aren't widely
217-- supported in terminal emulators yet, but most terminal emulators
204-- supported in terminal emulators yet, but most terminal emulators
218−-- that don't know about these sequences will ignore these
205+-- that don't know about these sequences will ignore these sequences,
219−-- sequences, and therefore this should fall back sensibly.
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.
220withURL :: Attr -> Text -> Attr
211withURL :: Attr -> Text -> Attr
221withURL attr url = attr { attrURL = SetTo url }
212withURL attr url = attr { attrURL = SetTo url }
222
213
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+18−3
@@ -1,5 +1,6 @@
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
@@ -7,6 +8,9 @@ import Graphics.Vty.Attributes
7
8
8import Data.Bits ((.&.))
9import Data.Bits ((.&.))
9import Data.ByteString (ByteString)
10import Data.ByteString (ByteString)
11+#if !(MIN_VERSION_base(4,11,0))
12+import Data.Semigroup (Semigroup(..))
13+#endif
10import Data.Text (Text)
14import Data.Text (Text)
11import Data.Text.Encoding (encodeUtf8)
15import Data.Text.Encoding (encodeUtf8)
12
16
@@ -47,15 +51,20 @@ data DisplayAttrDiff = DisplayAttrDiff
47 }
51 }
48 deriving (Show)
52 deriving (Show)
49
53
50−instance Monoid DisplayAttrDiff where
54+instance Semigroup DisplayAttrDiff where
51− mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
52− mappend d0 d1 =
55+ d0 <> d1 =
53 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
56 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
54 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
57 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
55 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
58 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
56 ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
59 ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
57 in DisplayAttrDiff ds fcd bcd ud
60 in DisplayAttrDiff ds fcd bcd ud
58
61
62+instance Monoid DisplayAttrDiff where
63+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
64+#if !(MIN_VERSION_base(4,11,0))
65+ mappend = (<>)
66+#endif
67+
59-- | Used in the computation of a final style attribute change.
68-- | Used in the computation of a final style attribute change.
60simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
61simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
70simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
@@ -85,6 +94,10 @@ data DisplayColorDiff
85data StyleStateChange
94data StyleStateChange
86 = ApplyStandout
95 = ApplyStandout
87 | RemoveStandout
96 | RemoveStandout
97+ | ApplyItalic
98+ | RemoveItalic
99+ | ApplyStrikethrough
100+ | RemoveStrikethrough
88 | ApplyUnderline
101 | ApplyUnderline
89 | RemoveUnderline
102 | RemoveUnderline
90 | ApplyReverseVideo
103 | ApplyReverseVideo
@@ -132,6 +145,8 @@ diffStyles prev cur
132 = mconcat
145 = mconcat
133 [ styleDiff standout ApplyStandout RemoveStandout
146 [ styleDiff standout ApplyStandout RemoveStandout
134 , styleDiff underline ApplyUnderline RemoveUnderline
147 , styleDiff underline ApplyUnderline RemoveUnderline
148+ , styleDiff italic ApplyItalic RemoveItalic
149+ , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
135 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
136 , styleDiff blink ApplyBlink RemoveBlink
151 , styleDiff blink ApplyBlink RemoveBlink
137 , styleDiff dim ApplyDim RemoveDim
152 , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Image.hs+17−8
@@ -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,7 +175,7 @@ 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
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+27−16
@@ -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 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+53−29
@@ -1,10 +1,11 @@
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
@@ -16,25 +17,39 @@ import Graphics.Vty.Input.Classify.Types
16
17
17import Codec.Binary.UTF8.Generic (decode)
18import Codec.Binary.UTF8.Generic (decode)
18
19
19−import Data.List (inits)
20+import Control.Arrow (first)
20import qualified Data.Map as M( fromList, lookup )
21import qualified Data.Map as M( fromList, lookup )
21import Data.Maybe ( mapMaybe )
22import Data.Maybe ( mapMaybe )
22import qualified Data.Set as S( fromList, member )
23import qualified Data.Set as S( fromList, member )
23
24
24−import Data.Char
25import Data.Word
25import Data.Word
26
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+
27−compile :: ClassifyMap -> [Char] -> KClass
42+compile :: ClassifyMap -> ByteString -> KClass
28compile table = cl' where
43compile table = cl' where
29 -- take all prefixes and create a set of these
44 -- take all prefixes and create a set of these
30− prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
45+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
31 maxValidInputLength = maximum (map (length . fst) table)
46 maxValidInputLength = maximum (map (length . fst) table)
32− eventForInput = M.fromList table
47+ eventForInput = M.fromList $ map (first BS8.pack) table
33− cl' [] = Prefix
48+ cl' inputBlock | BS8.null inputBlock = Prefix
34 cl' inputBlock = case M.lookup inputBlock eventForInput of
49 cl' inputBlock = case M.lookup inputBlock eventForInput of
35 -- if the inputBlock is exactly what is expected for an
50 -- if the inputBlock is exactly what is expected for an
36 -- event then consume the whole block and return the event
51 -- event then consume the whole block and return the event
37− Just e -> Valid e []
52+ Just e -> Valid e BS8.empty
38 Nothing -> case S.member inputBlock prefixSet of
53 Nothing -> case S.member inputBlock prefixSet of
39 True -> Prefix
54 True -> Prefix
40 -- look up progressively smaller tails of the input
55 -- look up progressively smaller tails of the input
@@ -45,40 +60,49 @@ compile table = cl' where
45 -- H: There will always be one match. The prefixSet
60 -- H: There will always be one match. The prefixSet
46 -- contains, by definition, all prefixes of an event.
61 -- contains, by definition, all prefixes of an event.
47 False ->
62 False ->
48− let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
63+ let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
49 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
50− (s,e) : _ -> Valid e (drop (length s) inputBlock)
65+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
51 -- neither a prefix or a full event.
66 -- neither a prefix or a full event.
52 [] -> Invalid
67 [] -> Invalid
53
68
54−classify :: ClassifyMap -> [Char] -> KClass
69+classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
55−classify table =
70+classify table = process
71+ where
56− let standardClassifier = compile table
72+ standardClassifier = compile table
73+
74+ process ClassifierStart s =
57− in \s -> case s of
75+ case BS.uncons s of
58− _ | 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 =
59 if bracketedPasteFinished s
86 if bracketedPasteFinished s
60− then parseBracketedPaste s
87+ then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
61− else Prefix
88+ else Chunk
62− _ | isMouseEvent s -> classifyMouseEvent s
89+ process ClassifierInChunk{} _ = Invalid
63− _ | isFocusEvent s -> classifyFocusEvent s
64− c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
65− _ -> standardClassifier s
66
90
67−classifyUtf8 :: Char -> [Char] -> KClass
91+classifyUtf8 :: Word8 -> ByteString -> KClass
68classifyUtf8 c cs =
92classifyUtf8 c cs =
69− let n = utf8Length (ord c)
93+ let n = utf8Length c
70− (codepoint,rest) = splitAt n (c:cs)
94+ (codepoint,rest) = BS8.splitAt (n - 1) cs
71
95
72 codepoint8 :: [Word8]
96 codepoint8 :: [Word8]
73− codepoint8 = map (fromIntegral . ord) codepoint
97+ codepoint8 = c:BS.unpack codepoint
74
98
75 in case decode codepoint8 of
99 in case decode codepoint8 of
76− _ | n < length codepoint -> Prefix
100+ _ | n < BS.length codepoint + 1 -> Prefix
77− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
101+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
78 -- something bad happened; just ignore and continue.
102 -- something bad happened; just ignore and continue.
79− Nothing -> Invalid
103+ Nothing -> Invalid
80
104
81−utf8Length :: (Num t, Ord a, Num a) => a -> t
105+utf8Length :: Word8 -> Int
82utf8Length c
106utf8Length c
83 | c < 0x80 = 1
107 | c < 0x80 = 1
84 | c < 0xE0 = 2
108 | c < 0xE0 = 2
src/Graphics/Vty/Input/Classify/Parse.hs+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+24−6
@@ -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.
31data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
37data 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
@@ -62,4 +68,16 @@ data Event
62 -- ^ The terminal running the application gained input focus.
68 -- ^ The terminal running the application gained input focus.
63 deriving (Eq,Show,Read,Ord,Generic)
69 deriving (Eq,Show,Read,Ord,Generic)
64
70
71+instance NFData Event
72+
65type 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.hs+15−13
@@ -11,30 +11,32 @@ import Graphics.Vty.Input.Classify.Types
11import Graphics.Vty.Input.Classify.Parse
11import Graphics.Vty.Input.Classify.Parse
12
12
13import Control.Monad.State
13import Control.Monad.State
14−import Data.List (isPrefixOf)
14+
15+import qualified Data.ByteString.Char8 as BS8
16+import Data.ByteString.Char8 (ByteString)
15
17
16-- | These sequences set xterm-based terminals to send focus event
18-- | These sequences set xterm-based terminals to send focus event
17-- sequences.
19-- sequences.
18−requestFocusEvents :: String
20+requestFocusEvents :: ByteString
19−requestFocusEvents = "\ESC[?1004h"
21+requestFocusEvents = BS8.pack "\ESC[?1004h"
20
22
21-- | These sequences disable focus events.
23-- | These sequences disable focus events.
22−disableFocusEvents :: String
24+disableFocusEvents :: ByteString
23−disableFocusEvents = "\ESC[?1004l"
25+disableFocusEvents = BS8.pack "\ESC[?1004l"
24
26
25-- | Does the specified string begin with a focus event?
27-- | Does the specified string begin with a focus event?
26−isFocusEvent :: String -> Bool
28+isFocusEvent :: ByteString -> Bool
27−isFocusEvent s = isPrefixOf focusIn s ||
29+isFocusEvent s = BS8.isPrefixOf focusIn s ||
28− isPrefixOf focusOut s
30+ BS8.isPrefixOf focusOut s
29
31
30−focusIn :: String
32+focusIn :: ByteString
31−focusIn = "\ESC[I"
33+focusIn = BS8.pack "\ESC[I"
32
34
33−focusOut :: String
35+focusOut :: ByteString
34−focusOut = "\ESC[O"
36+focusOut = BS8.pack "\ESC[O"
35
37
36-- | Attempt to classify an input string as a focus event.
38-- | Attempt to classify an input string as a focus event.
37−classifyFocusEvent :: String -> KClass
39+classifyFocusEvent :: ByteString -> KClass
38classifyFocusEvent s = runParser s $ do
40classifyFocusEvent s = runParser s $ do
39 when (not $ isFocusEvent s) failParse
41 when (not $ isFocusEvent s) failParse
40
42
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+19−17
@@ -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"
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"
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
@@ -87,8 +89,8 @@ scrollDown = 65
87hasBitSet :: Int -> Int -> Bool
89hasBitSet :: Int -> Int -> Bool
88hasBitSet val bit = val .&. bit > 0
90hasBitSet val bit = val .&. bit > 0
89
91
90−-- | Attempt to lassify an input string as a mouse event.
92+-- | Attempt to classify an input string as a mouse event.
91−classifyMouseEvent :: String -> KClass
93+classifyMouseEvent :: ByteString -> KClass
92classifyMouseEvent s = runParser s $ do
94classifyMouseEvent s = runParser s $ do
93 when (not $ isMouseEvent s) failParse
95 when (not $ isMouseEvent s) failParse
94
96
@@ -100,7 +102,7 @@ classifyMouseEvent s = runParser s $ do
100 'M' -> classifyNormalMouseEvent
102 'M' -> classifyNormalMouseEvent
101 _ -> failParse
103 _ -> failParse
102
104
103−-- Given a modifer/button value, determine which button was indicated
105+-- Given a modifier/button value, determine which button was indicated
104getSGRButton :: Int -> Parser Button
106getSGRButton :: Int -> Parser Button
105getSGRButton mods =
107getSGRButton mods =
106 let buttonMap = [ (leftButton, BLeft)
108 let buttonMap = [ (leftButton, BLeft)
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+84−51
@@ -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
@@ -47,6 +45,12 @@ data Mode = Mouse
47 | Focus
45 | Focus
48 -- ^ Focus-in/focus-out events (whether the terminal is
46 -- ^ Focus-in/focus-out events (whether the terminal is
49 -- configured to provide events on focus change)
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.
50 deriving (Eq, Read, Show)
54 deriving (Eq, Read, Show)
51
55
52-- | The Vty terminal output interface.
56-- | The Vty terminal output interface.
@@ -55,7 +59,7 @@ data Output = Output
55 terminalID :: String
59 terminalID :: String
56 -- | Release the terminal just prior to application exit and reset
60 -- | Release the terminal just prior to application exit and reset
57 -- it to its state prior to application startup.
61 -- it to its state prior to application startup.
58− , releaseTerminal :: forall m. MonadIO m => m ()
62+ , releaseTerminal :: IO ()
59 -- | Clear the display and initialize the terminal to some initial
63 -- | Clear the display and initialize the terminal to some initial
60 -- display state.
64 -- display state.
61 --
65 --
@@ -65,40 +69,57 @@ data Output = Output
65 -- - cursor at top left
69 -- - cursor at top left
66 -- - UTF-8 character encoding
70 -- - UTF-8 character encoding
67 -- - drawing characteristics are the default
71 -- - drawing characteristics are the default
68− , reserveDisplay :: forall m. MonadIO m => m ()
72+ , reserveDisplay :: IO ()
69 -- | Return the display to the state before `reserveDisplay` If no
73 -- | Return the display to the state before `reserveDisplay` If no
70 -- previous state then set the display state to the initial state.
74 -- previous state then set the display state to the initial state.
71− , releaseDisplay :: forall m. MonadIO m => m ()
75+ , releaseDisplay :: IO ()
76+ -- | Sets the current display bounds (width, height).
77+ , setDisplayBounds :: (Int, Int) -> IO ()
72 -- | Returns the current display bounds.
78 -- | Returns the current display bounds.
73− , displayBounds :: forall m. MonadIO m => m DisplayRegion
79+ , displayBounds :: IO DisplayRegion
74 -- | Output the bytestring to the terminal device.
80 -- | Output the bytestring to the terminal device.
75 , outputByteBuffer :: BS.ByteString -> IO ()
81 , outputByteBuffer :: BS.ByteString -> IO ()
76− -- | Specifies the maximum number of colors supported by the
77− -- context.
78− , contextColorCount :: Int
79 -- | Specifies whether the cursor can be shown / hidden.
82 -- | Specifies whether the cursor can be shown / hidden.
80 , supportsCursorVisibility :: Bool
83 , supportsCursorVisibility :: Bool
81 -- | Indicates support for terminal modes for this output device.
84 -- | Indicates support for terminal modes for this output device.
82 , supportsMode :: Mode -> Bool
85 , supportsMode :: Mode -> Bool
83 -- | Enables or disables a mode (does nothing if the mode is
86 -- | Enables or disables a mode (does nothing if the mode is
84 -- unsupported).
87 -- unsupported).
85− , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()
88+ , setMode :: Mode -> Bool -> IO ()
86 -- | Returns whether a mode is enabled.
89 -- | Returns whether a mode is enabled.
87− , getModeStatus :: forall m. MonadIO m => Mode -> m Bool
90+ , getModeStatus :: Mode -> IO Bool
88 , assumedStateRef :: IORef AssumedState
91 , assumedStateRef :: IORef AssumedState
89 -- | Acquire display access to the given region of the display.
92 -- | Acquire display access to the given region of the display.
90 -- 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
91 -- the lower right corner at (max displayWidth providedWidth, max
94 -- the lower right corner at (max displayWidth providedWidth, max
92 -- displayHeight providedHeight)
95 -- displayHeight providedHeight)
93− , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
96+ , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
94 -- | Ring the terminal bell if supported.
97 -- | Ring the terminal bell if supported.
95− , ringTerminalBell :: forall m. MonadIO m => m ()
98+ , ringTerminalBell :: IO ()
96 -- | Returns whether the terminal has an audio bell feature.
99 -- | Returns whether the terminal has an audio bell feature.
97− , 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
98 }
119 }
99
120
100−displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
121+displayContext :: Output -> DisplayRegion -> IO DisplayContext
101−displayContext t = liftIO . mkDisplayContext t t
122+displayContext t = mkDisplayContext t t
102
123
103data AssumedState = AssumedState
124data AssumedState = AssumedState
104 { prevFattr :: Maybe FixedAttr
125 { prevFattr :: Maybe FixedAttr
@@ -133,9 +154,9 @@ data DisplayContext = DisplayContext
133 -- to support this the currently applied display attributes are
154 -- to support this the currently applied display attributes are
134 -- required. In addition it may be possible to optimize the state
155 -- required. In addition it may be possible to optimize the state
135 -- changes based off the currently applied display attributes.
156 -- changes based off the currently applied display attributes.
136− , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
157+ , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
137 -- | Reset the display attributes to the default display attributes.
158 -- | Reset the display attributes to the default display attributes.
138− , writeDefaultAttr :: Write
159+ , writeDefaultAttr :: Bool -> Write
139 , writeRowEnd :: Write
160 , writeRowEnd :: Write
140 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
141 , inlineHack :: IO ()
162 , inlineHack :: IO ()
@@ -157,8 +178,9 @@ writeUtf8Text = writeByteString
157-- 4. Serialized to the display.
178-- 4. Serialized to the display.
158--
179--
159-- 5. The cursor is then shown and positioned or kept hidden.
180-- 5. The cursor is then shown and positioned or kept hidden.
160−outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
181+outputPicture :: DisplayContext -> Picture -> IO ()
161−outputPicture dc pic = liftIO $ do
182+outputPicture dc pic = do
183+ urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
162 as <- readIORef (assumedStateRef $ contextDevice dc)
184 as <- readIORef (assumedStateRef $ contextDevice dc)
163 let manipCursor = supportsCursorVisibility (contextDevice dc)
185 let manipCursor = supportsCursorVisibility (contextDevice dc)
164 r = contextRegion dc
186 r = contextRegion dc
@@ -170,11 +192,10 @@ outputPicture dc pic = liftIO $ do
170 Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
192 Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
171 Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
193 Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
172 then replicate (displayOpsRows ops) True
194 then replicate (displayOpsRows ops) True
173− else zipWith (/=) (Vector.toList previousOps)
195+ else Vector.toList $ Vector.zipWith (/=) previousOps ops
174− (Vector.toList ops)
175 -- build the Write corresponding to the output image
196 -- build the Write corresponding to the output image
176 out = (if manipCursor then writeHideCursor dc else mempty)
197 out = (if manipCursor then writeHideCursor dc else mempty)
177− `mappend` writeOutputOps dc initialAttr diffs ops
198+ `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
178 `mappend`
199 `mappend`
179 (let (w,h) = contextRegion dc
200 (let (w,h) = contextRegion dc
180 clampX = max 0 . min (w-1)
201 clampX = max 0 . min (w-1)
@@ -185,9 +206,15 @@ outputPicture dc pic = liftIO $ do
185 AbsoluteCursor x y ->
206 AbsoluteCursor x y ->
186 writeShowCursor dc `mappend`
207 writeShowCursor dc `mappend`
187 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)
188 Cursor x y ->
215 Cursor x y ->
189 let m = cursorOutputMap ops $ picCursor pic
216 let m = cursorOutputMap ops $ picCursor pic
190− (ox, oy) = charToOutputPos m (x,y)
217+ (ox, oy) = charToOutputPos m (clampX x, clampY y)
191 in writeShowCursor dc `mappend`
218 in writeShowCursor dc `mappend`
192 writeMoveCursor dc (clampX ox) (clampY oy)
219 writeMoveCursor dc (clampX ox) (clampY oy)
193 )
220 )
@@ -197,15 +224,15 @@ outputPicture dc pic = liftIO $ do
197 let as' = as { prevOutputOps = Just ops }
224 let as' = as { prevOutputOps = Just ops }
198 writeIORef (assumedStateRef $ contextDevice dc) as'
225 writeIORef (assumedStateRef $ contextDevice dc) as'
199
226
200−writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
227+writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
201−writeOutputOps dc initialAttr diffs ops =
228+writeOutputOps urlsEnabled dc initialAttr diffs ops =
202 let (_, out, _) = Vector.foldl' writeOutputOps'
229 let (_, out, _) = Vector.foldl' writeOutputOps'
203 (0, mempty, diffs)
230 (0, mempty, diffs)
204 ops
231 ops
205 in out
232 in out
206 where
233 where
207 writeOutputOps' (y, out, True : diffs') spanOps
234 writeOutputOps' (y, out, True : diffs') spanOps
208− = let spanOut = writeSpanOps dc y initialAttr spanOps
235+ = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
209 out' = out `mappend` spanOut
236 out' = out `mappend` spanOut
210 in (y+1, out', diffs')
237 in (y+1, out', diffs')
211 writeOutputOps' (y, out, False : diffs') _spanOps
238 writeOutputOps' (y, out, False : diffs') _spanOps
@@ -213,27 +240,27 @@ writeOutputOps dc initialAttr diffs ops =
213 writeOutputOps' (_y, _out, []) _spanOps
240 writeOutputOps' (_y, _out, []) _spanOps
214 = error "vty - output spans without a corresponding diff."
241 = error "vty - output spans without a corresponding diff."
215
242
216−writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
243+writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
217−writeSpanOps dc y initialAttr spanOps =
244+writeSpanOps urlsEnabled dc y initialAttr spanOps =
218 -- 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
219− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
246+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
220 -- then the span ops are serialized in the order specified
247 -- then the span ops are serialized in the order specified
221− 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
222 (opOut, fattr') -> (out `mappend` opOut, fattr')
249 (opOut, fattr') -> (out `mappend` opOut, fattr')
223 )
250 )
224 (start, initialAttr)
251 (start, initialAttr)
225 spanOps
252 spanOps
226
253
227−writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
254+writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
228−writeSpanOp dc (TextSpan attr _ _ str) fattr =
255+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
229 let attr' = limitAttrForDisplay (contextDevice dc) attr
256 let attr' = limitAttrForDisplay (contextDevice dc) attr
230 fattr' = fixDisplayAttr fattr attr'
257 fattr' = fixDisplayAttr fattr attr'
231 diffs = displayAttrDiffs fattr fattr'
258 diffs = displayAttrDiffs fattr fattr'
232− out = writeSetAttr dc fattr attr' diffs
259+ out = writeSetAttr dc urlsEnabled fattr attr' diffs
233 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
260 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
234 in (out, fattr')
261 in (out, fattr')
235−writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
262+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
236−writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
263+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
237
264
238-- | 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
239-- multi-column characters this needs to be translated to column, row
266-- multi-column characters this needs to be translated to column, row
@@ -282,17 +309,23 @@ limitAttrForDisplay t attr
282 where
309 where
283 clampColor Default = Default
310 clampColor Default = Default
284 clampColor KeepCurrent = KeepCurrent
311 clampColor KeepCurrent = KeepCurrent
285− clampColor (SetTo c) = clampColor' c
312+ clampColor (SetTo c) = clampColor' (outputColorMode t) c
313+
286− clampColor' (ISOColor v)
314+ clampColor' NoColor _ = Default
287− | contextColorCount t < 8 = Default
315+
316+ clampColor' ColorMode8 (ISOColor v)
288− | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
317+ | v >= 8 = SetTo $ ISOColor (v - 8)
289− | otherwise = SetTo $ ISOColor v
318+ | otherwise = SetTo $ ISOColor v
290− clampColor' (Color240 v)
319+ clampColor' ColorMode8 _ = Default
291− -- Should we choose closest ISO color?
320+
292− | contextColorCount t < 8 = Default
321+ clampColor' ColorMode16 c@(ISOColor _) = SetTo c
293− | contextColorCount t < 16 = Default
322+ clampColor' ColorMode16 _ = Default
294− | 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
295− | otherwise
327+ | otherwise = Default
296− = let p :: Double = fromIntegral v / 240.0
328+ clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
297− v' = floor $ p * (fromIntegral $ contextColorCount t)
329+ clampColor' colorMode (color240 r g b)
298− 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+174−65
@@ -1,6 +1,6 @@
1−{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
5{-# CFILES gwinsz.c #-}
5{-# CFILES gwinsz.c #-}
6
6
@@ -9,10 +9,12 @@
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
10module Graphics.Vty.Output.TerminfoBased
10module Graphics.Vty.Output.TerminfoBased
11 ( reserveTerminal
11 ( reserveTerminal
12+ , setWindowSize
12 )
13 )
13where
14where
14
15
15import Control.Monad (when)
16import Control.Monad (when)
17+import Data.Bits (shiftL, (.&.))
16import qualified Data.ByteString as BS
18import qualified Data.ByteString as BS
17import Data.ByteString.Internal (toForeignPtr)
19import Data.ByteString.Internal (toForeignPtr)
18import Data.Terminfo.Parse
20import Data.Terminfo.Parse
@@ -23,16 +25,16 @@ import Graphics.Vty.Image (DisplayRegion)
23import Graphics.Vty.DisplayAttributes
25import Graphics.Vty.DisplayAttributes
24import Graphics.Vty.Output.Interface
26import Graphics.Vty.Output.Interface
25
27
26−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)
28+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
27
29
28−import Control.Monad.Trans
29−
30−import Data.Bits ((.&.))
31−import Data.Foldable (foldMap)
32import Data.IORef
30import Data.IORef
33import Data.Maybe (isJust, isNothing, fromJust)
31import Data.Maybe (isJust, isNothing, fromJust)
34import Data.Word
32import Data.Word
35
33
34+#if !MIN_VERSION_base(4,8,0)
35+import Data.Foldable (foldMap)
36+#endif
37+
36import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.C.Types ( CInt(..), CLong(..) )
37import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.ForeignPtr (withForeignPtr)
38import Foreign.Ptr (Ptr, plusPtr)
40import Foreign.Ptr (Ptr, plusPtr)
@@ -47,7 +49,6 @@ data TerminfoCaps = TerminfoCaps
47 , cup :: CapExpression
49 , cup :: CapExpression
48 , cnorm :: Maybe CapExpression
50 , cnorm :: Maybe CapExpression
49 , civis :: Maybe CapExpression
51 , civis :: Maybe CapExpression
50− , supportsNoColors :: Bool
51 , useAltColorMap :: Bool
52 , useAltColorMap :: Bool
52 , setForeColor :: CapExpression
53 , setForeColor :: CapExpression
53 , setBackColor :: CapExpression
54 , setBackColor :: CapExpression
@@ -62,6 +63,10 @@ data DisplayAttrCaps = DisplayAttrCaps
62 { setAttrStates :: Maybe CapExpression
63 { setAttrStates :: Maybe CapExpression
63 , enterStandout :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
64 , exitStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
66+ , enterItalic :: Maybe CapExpression
67+ , exitItalic :: Maybe CapExpression
68+ , enterStrikethrough :: Maybe CapExpression
69+ , exitStrikethrough :: Maybe CapExpression
65 , enterUnderline :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
66 , exitUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
67 , enterReverseVideo :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
@@ -98,62 +103,85 @@ sendCapToTerminal t cap capParams = do
98--
103--
99-- * Providing independent string capabilities for all display
104-- * Providing independent string capabilities for all display
100-- attributes.
105-- attributes.
101−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
106+reserveTerminal :: String -> Fd -> ColorMode -> IO Output
102−reserveTerminal termName outFd = liftIO $ do
107+reserveTerminal termName outFd colorMode = do
103 ti <- Terminfo.setupTerm termName
108 ti <- Terminfo.setupTerm termName
104 -- assumes set foreground always implies set background exists.
109 -- assumes set foreground always implies set background exists.
105 -- if set foreground is not set then all color changing style
110 -- if set foreground is not set then all color changing style
106 -- attributes are filtered.
111 -- attributes are filtered.
107 msetaf <- probeCap ti "setaf"
112 msetaf <- probeCap ti "setaf"
108 msetf <- probeCap ti "setf"
113 msetf <- probeCap ti "setf"
109− let (noColors, useAlt, setForeCap)
114+ let (useAlt, setForeCap)
110 = case msetaf of
115 = case msetaf of
111− Just setaf -> (False, False, setaf)
116+ Just setaf -> (False, setaf)
112 Nothing -> case msetf of
117 Nothing -> case msetf of
113− Just setf -> (False, True, setf)
118+ Just setf -> (True, setf)
114− Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
119+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
115 msetab <- probeCap ti "setab"
120 msetab <- probeCap ti "setab"
116 msetb <- probeCap ti "setb"
121 msetb <- probeCap ti "setb"
117− let set_back_cap
122+ let setBackCap
118 = case msetab of
123 = case msetab of
124+ Just setab -> setab
119 Nothing -> case msetb of
125 Nothing -> case msetb of
120 Just setb -> setb
126 Just setb -> setb
121 Nothing -> error $ "no back color support for terminal " ++ termName
127 Nothing -> error $ "no back color support for terminal " ++ termName
122− 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+
123 terminfoCaps <- pure TerminfoCaps
147 terminfoCaps <- pure TerminfoCaps
124 <*> probeCap ti "smcup"
148 <*> probeCap ti "smcup"
125 <*> probeCap ti "rmcup"
149 <*> probeCap ti "rmcup"
126 <*> requireCap ti "cup"
150 <*> requireCap ti "cup"
127 <*> probeCap ti "cnorm"
151 <*> probeCap ti "cnorm"
128 <*> probeCap ti "civis"
152 <*> probeCap ti "civis"
129− <*> pure noColors
130 <*> pure useAlt
153 <*> pure useAlt
131 <*> pure setForeCap
154 <*> pure setForeCap
132− <*> pure set_back_cap
155+ <*> pure setBackCap
133 <*> requireCap ti "sgr0"
156 <*> requireCap ti "sgr0"
134 <*> requireCap ti "clear"
157 <*> requireCap ti "clear"
135 <*> requireCap ti "el"
158 <*> requireCap ti "el"
136 <*> currentDisplayAttrCaps ti
159 <*> currentDisplayAttrCaps ti
137 <*> probeCap ti "bel"
160 <*> probeCap ti "bel"
138− newAssumedStateRef <- newIORef initialAssumedState
139 let t = Output
161 let t = Output
140 { terminalID = termName
162 { terminalID = termName
141− , releaseTerminal = liftIO $ do
163+ , releaseTerminal = do
142 sendCap setDefaultAttr []
164 sendCap setDefaultAttr []
143 maybeSendCap cnorm []
165 maybeSendCap cnorm []
144 , 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))
145− , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
171+ , ringTerminalBell = maybeSendCap ringBellAudio []
146− , reserveDisplay = liftIO $ do
172+ , reserveDisplay = do
147 -- If there is no support for smcup: Clear the screen
173 -- If there is no support for smcup: Clear the screen
148 -- and then move the mouse to the home position to
174 -- and then move the mouse to the home position to
149 -- approximate the behavior.
175 -- approximate the behavior.
150 maybeSendCap smcup []
176 maybeSendCap smcup []
151 sendCap clearScreen []
177 sendCap clearScreen []
152− , releaseDisplay = liftIO $ do
178+ , releaseDisplay = do
153 maybeSendCap rmcup []
179 maybeSendCap rmcup []
154 maybeSendCap cnorm []
180 maybeSendCap cnorm []
181+ , setDisplayBounds = \(w, h) ->
182+ setWindowSize outFd (w, h)
155 , displayBounds = do
183 , displayBounds = do
156− rawSize <- liftIO $ getWindowSize outFd
184+ rawSize <- getWindowSize outFd
157 case rawSize of
185 case rawSize of
158 (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
159 | otherwise -> return (w,h)
187 | otherwise -> return (w,h)
@@ -164,51 +192,48 @@ reserveTerminal termName outFd = liftIO $ do
164 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
165 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
166 ++ " Please report this bug to vty project."
194 ++ " Please report this bug to vty project."
167− , contextColorCount
168− = case supportsNoColors terminfoCaps of
169− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
170− Nothing -> 8
171− Just v -> toEnum v
172− True -> 1
173 , supportsCursorVisibility = isJust $ civis terminfoCaps
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
174− , supportsMode = const False
196+ , supportsMode = terminfoModeSupported
175− , setMode = const $ const $ return ()
197+ , setMode = terminfoSetMode
176− , getModeStatus = const $ return False
198+ , getModeStatus = terminfoModeStatus
177 , assumedStateRef = newAssumedStateRef
199 , assumedStateRef = newAssumedStateRef
200+ , outputColorMode = colorMode
178 -- I think fix would help assure tActual is the only
201 -- I think fix would help assure tActual is the only
179 -- reference. I was having issues tho.
202 -- reference. I was having issues tho.
180− , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
203+ , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
181 }
204 }
182 sendCap s = sendCapToTerminal t (s terminfoCaps)
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
183 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
184 return t
207 return t
185
208
186−requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
209+requireCap :: Terminfo.Terminal -> String -> IO CapExpression
187requireCap ti capName
210requireCap ti capName
188 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
189 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
190 Just capStr -> parseCap capStr
213 Just capStr -> parseCap capStr
191
214
192−probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
215+probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
193probeCap ti capName
216probeCap ti capName
194 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
195 Nothing -> return Nothing
218 Nothing -> return Nothing
196 Just capStr -> Just <$> parseCap capStr
219 Just capStr -> Just <$> parseCap capStr
197
220
198−parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
221+parseCap :: String -> IO CapExpression
199parseCap capStr = do
222parseCap capStr = do
200 case parseCapExpression capStr of
223 case parseCapExpression capStr of
201 Left e -> fail $ show e
224 Left e -> fail $ show e
202 Right cap -> return cap
225 Right cap -> return cap
203
226
204−currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
227+currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
205− => Terminfo.Terminal
206− -> m DisplayAttrCaps
207currentDisplayAttrCaps ti
228currentDisplayAttrCaps ti
208 = pure DisplayAttrCaps
229 = pure DisplayAttrCaps
209 <*> probeCap ti "sgr"
230 <*> probeCap ti "sgr"
210 <*> probeCap ti "smso"
231 <*> probeCap ti "smso"
211 <*> probeCap ti "rmso"
232 <*> probeCap ti "rmso"
233+ <*> probeCap ti "sitm"
234+ <*> probeCap ti "ritm"
235+ <*> probeCap ti "smxx"
236+ <*> probeCap ti "rmxx"
212 <*> probeCap ti "smul"
237 <*> probeCap ti "smul"
213 <*> probeCap ti "rmul"
238 <*> probeCap ti "rmul"
214 <*> probeCap ti "rev"
239 <*> probeCap ti "rev"
@@ -222,6 +247,13 @@ getWindowSize fd = do
222 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
223 return (fromIntegral b, fromIntegral a)
248 return (fromIntegral b, fromIntegral a)
224
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+
225terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
226terminfoDisplayContext tActual terminfoCaps r = return dc
258terminfoDisplayContext tActual terminfoCaps r = return dc
227 where dc = DisplayContext
259 where dc = DisplayContext
@@ -235,7 +267,13 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
235 Nothing -> error "this terminal does not support hide cursor"
267 Nothing -> error "this terminal does not support hide cursor"
236 Just c -> writeCapExpr c []
268 Just c -> writeCapExpr c []
237 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270+ , writeDefaultAttr = \urlsEnabled ->
238− , 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+ )
239 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
240 , inlineHack = return ()
278 , inlineHack = return ()
241 }
279 }
@@ -257,7 +295,7 @@ writeURLEscapes NoLinkChange =
257-- | 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.
258--
296--
259-- 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
260−-- 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
261-- colors to the default) this procedure is used:
299-- colors to the default) this procedure is used:
262--
300--
263-- 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.
@@ -290,30 +328,30 @@ writeURLEscapes NoLinkChange =
290--
328--
291-- Note that this optimizes for fewer state changes followed by fewer
329-- Note that this optimizes for fewer state changes followed by fewer
292-- bytes.
330-- bytes.
293−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
331+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
294−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
332+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
295− urlAttrs `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
333+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
296 -- The only way to reset either color, portably, to the default
334 -- The only way to reset either color, portably, to the default
297 -- 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
298 -- capability.
336 -- capability.
299− True -> do
337+ True -> do
300 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
301− (fixedStyle attr )
339+ (fixedStyle attr)
302 (styleToApplySeq $ fixedStyle attr) of
340 (styleToApplySeq $ fixedStyle attr) of
303 -- only way to reset a color to the defaults
341 -- only way to reset a color to the defaults
304− EnterExitSeq caps -> writeDefaultAttr dc
342+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
305 `mappend`
343 `mappend`
306 foldMap (\cap -> writeCapExpr cap []) caps
344 foldMap (\cap -> writeCapExpr cap []) caps
307 `mappend`
345 `mappend`
308 setColors
346 setColors
309 -- implicitly resets the colors to the defaults
347 -- implicitly resets the colors to the defaults
310 SetState state -> writeCapExpr (fromJust $ setAttrStates
348 SetState state -> writeCapExpr (fromJust $ setAttrStates
311− $ displayAttrCaps
349+ $ displayAttrCaps terminfoCaps
312− $ terminfoCaps
313 )
350 )
314 (sgrArgsForState state)
351 (sgrArgsForState state)
315− `mappend`
352+ `mappend` setItalics
353+ `mappend` setStrikethrough
316− setColors
354+ `mappend` setColors
317 -- Otherwise the display colors are not changing or changing
355 -- Otherwise the display colors are not changing or changing
318 -- between two non-default points.
356 -- between two non-default points.
319 False -> do
357 False -> do
@@ -331,46 +369,99 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
331 -- applied states.
369 -- applied states.
332 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
333 `mappend`
371 `mappend`
334− writeColorDiff setForeColor (foreColorDiff diffs)
372+ writeColorDiff Foreground (foreColorDiff diffs)
335 `mappend`
373 `mappend`
336− writeColorDiff setBackColor (backColorDiff diffs)
374+ writeColorDiff Background (backColorDiff diffs)
337 -- implicitly resets the colors to the defaults
375 -- implicitly resets the colors to the defaults
338 SetState state -> writeCapExpr (fromJust $ setAttrStates
376 SetState state -> writeCapExpr (fromJust $ setAttrStates
339 $ displayAttrCaps terminfoCaps
377 $ displayAttrCaps terminfoCaps
340 )
378 )
341 (sgrArgsForState state)
379 (sgrArgsForState state)
380+ `mappend` setItalics
381+ `mappend` setStrikethrough
342 `mappend` setColors
382 `mappend` setColors
343 where
383 where
344− urlAttrs = writeURLEscapes (urlDiff diffs)
384+ urlAttrs True = writeURLEscapes (urlDiff diffs)
385+ urlAttrs False = mempty
345 colorMap = case useAltColorMap terminfoCaps of
386 colorMap = case useAltColorMap terminfoCaps of
346 False -> ansiColorIndex
387 False -> ansiColorIndex
347 True -> altColorIndex
388 True -> altColorIndex
348 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
349 setColors =
404 setColors =
350 (case fixedForeColor attr of
405 (case fixedForeColor attr of
351− Just c -> writeCapExpr (setForeColor terminfoCaps)
406+ Just c -> writeColor Foreground c
352− [toEnum $ colorMap c]
353 Nothing -> mempty)
407 Nothing -> mempty)
354 `mappend`
408 `mappend`
355 (case fixedBackColor attr of
409 (case fixedBackColor attr of
356− Just c -> writeCapExpr (setBackColor terminfoCaps)
410+ Just c -> writeColor Background c
357− [toEnum $ colorMap c]
358 Nothing -> mempty)
411 Nothing -> mempty)
359− writeColorDiff _f NoColorChange
412+ writeColorDiff _side NoColorChange
360 = mempty
413 = mempty
361− writeColorDiff _f ColorToDefault
414+ writeColorDiff _side ColorToDefault
362 = error "ColorToDefault is not a possible case for applyColorDiffs"
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
363− 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 =
364− = 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"
365
452
366-- | 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
367-- 240 color set that might not be supported by the terminal.
454-- 240 color set that might not be supported by the terminal.
368--
455--
369−-- 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
370−-- computes the index into the full 256 color pallete.
457+-- computes the index into the full 256 color palette.
371ansiColorIndex :: Color -> Int
458ansiColorIndex :: Color -> Int
372ansiColorIndex (ISOColor v) = fromEnum v
459ansiColorIndex (ISOColor v) = fromEnum v
373ansiColorIndex (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+ ]
374
465
375-- | For terminals without setaf/setab
466-- | For terminals without setaf/setab
376--
467--
@@ -387,6 +478,10 @@ altColorIndex (ISOColor 6) = 3
387altColorIndex (ISOColor 7) = 7
478altColorIndex (ISOColor 7) = 7
388altColorIndex (ISOColor v) = fromEnum v
479altColorIndex (ISOColor v) = fromEnum v
389altColorIndex (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+ ]
390
485
391{- | 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
392 - according to these rules.
487 - according to these rules.
@@ -413,6 +508,8 @@ data DisplayAttrSeq
413data DisplayAttrState = DisplayAttrState
508data DisplayAttrState = DisplayAttrState
414 { applyStandout :: Bool
509 { applyStandout :: Bool
415 , applyUnderline :: Bool
510 , applyUnderline :: Bool
511+ , applyItalic :: Bool
512+ , applyStrikethrough :: Bool
416 , applyReverseVideo :: Bool
513 , applyReverseVideo :: Bool
417 , applyBlink :: Bool
514 , applyBlink :: Bool
418 , applyDim :: Bool
515 , applyDim :: Bool
@@ -449,6 +546,10 @@ reqDisplayCapSeqFor caps s diffs
449 -- set state cap then just use the set state cap.
546 -- set state cap then just use the set state cap.
450 ( True, True ) -> SetState $ stateForStyle s
547 ( True, True ) -> SetState $ stateForStyle s
451 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
452 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
453 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
454 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -461,6 +562,10 @@ reqDisplayCapSeqFor caps s diffs
461 noEnterExitCap RemoveDim = True
562 noEnterExitCap RemoveDim = True
462 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
463 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
464 enterExitCap ApplyStandout = fromJust $ enterStandout caps
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
465 enterExitCap RemoveStandout = fromJust $ exitStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
466 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -474,6 +579,8 @@ stateForStyle :: Style -> DisplayAttrState
474stateForStyle s = DisplayAttrState
579stateForStyle s = DisplayAttrState
475 { applyStandout = isStyleSet standout
580 { applyStandout = isStyleSet standout
476 , applyUnderline = isStyleSet underline
581 , applyUnderline = isStyleSet underline
582+ , applyItalic = isStyleSet italic
583+ , applyStrikethrough = isStyleSet strikethrough
477 , applyReverseVideo = isStyleSet reverseVideo
584 , applyReverseVideo = isStyleSet reverseVideo
478 , applyBlink = isStyleSet blink
585 , applyBlink = isStyleSet blink
479 , applyDim = isStyleSet dim
586 , applyDim = isStyleSet dim
@@ -485,10 +592,12 @@ styleToApplySeq :: Style -> [StyleStateChange]
485styleToApplySeq s = concat
592styleToApplySeq s = concat
486 [ applyIfRequired ApplyStandout standout
593 [ applyIfRequired ApplyStandout standout
487 , applyIfRequired ApplyUnderline underline
594 , applyIfRequired ApplyUnderline underline
595+ , applyIfRequired ApplyItalic italic
596+ , applyIfRequired ApplyStrikethrough strikethrough
488 , applyIfRequired ApplyReverseVideo reverseVideo
597 , applyIfRequired ApplyReverseVideo reverseVideo
489 , applyIfRequired ApplyBlink blink
598 , applyIfRequired ApplyBlink blink
490 , applyIfRequired ApplyDim dim
599 , applyIfRequired ApplyDim dim
491− , applyIfRequired ApplyBlink bold
600+ , applyIfRequired ApplyBold bold
492 ]
601 ]
493 where
602 where
494 applyIfRequired op flag
603 applyIfRequired op flag
src/Graphics/Vty/Output/XTermColor.hs+33−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.
@@ -9,26 +10,41 @@ where
9import Graphics.Vty.Output.Interface
10import Graphics.Vty.Output.Interface
10import Graphics.Vty.Input.Mouse
11import Graphics.Vty.Input.Mouse
11import Graphics.Vty.Input.Focus
12import Graphics.Vty.Input.Focus
13+import Graphics.Vty.Attributes.Color (ColorMode)
12import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
13
15
14import Blaze.ByteString.Builder (writeToByteString)
16import Blaze.ByteString.Builder (writeToByteString)
15import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
16
18
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+import Foreign.Ptr (castPtr)
22+
17import Control.Monad (void, when)
23import Control.Monad (void, when)
18import Control.Monad.Trans
24import Control.Monad.Trans
25+import Data.Char (toLower)
19import Data.IORef
26import Data.IORef
20
27
21−import System.Posix.IO (fdWrite)
28+import System.Posix.IO (fdWriteBuf)
22−import System.Posix.Types (Fd)
29+import System.Posix.Types (ByteCount, Fd)
23import System.Posix.Env (getEnv)
30import System.Posix.Env (getEnv)
24
31
25import Data.List (isInfixOf)
32import Data.List (isInfixOf)
26import Data.Maybe (catMaybes)
33import Data.Maybe (catMaybes)
34+
35+#if !MIN_VERSION_base(4,11,0)
27import 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)
28
44
29-- | Construct an Xterm output driver. Initialize the display to UTF-8.
45-- | Construct an Xterm output driver. Initialize the display to UTF-8.
30−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
46+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
31−reserveTerminal variant outFd = liftIO $ do
47+reserveTerminal variant outFd colorMode = liftIO $ do
32 let flushedPut = void . fdWrite outFd
48 let flushedPut = void . fdWrite outFd
33 -- If the terminal variant is xterm-color use xterm instead since,
49 -- If the terminal variant is xterm-color use xterm instead since,
34 -- more often than not, xterm-color is broken.
50 -- more often than not, xterm-color is broken.
@@ -36,7 +52,7 @@ reserveTerminal variant outFd = liftIO $ do
36
52
37 utf8a <- utf8Active
53 utf8a <- utf8Active
38 when (not utf8a) $ flushedPut setUtf8CharSet
54 when (not utf8a) $ flushedPut setUtf8CharSet
39− t <- TerminfoBased.reserveTerminal variant' outFd
55+ t <- TerminfoBased.reserveTerminal variant' outFd colorMode
40
56
41 mouseModeStatus <- newIORef False
57 mouseModeStatus <- newIORef False
42 focusModeStatus <- newIORef False
58 focusModeStatus <- newIORef False
@@ -61,10 +77,12 @@ reserveTerminal variant outFd = liftIO $ do
61 True -> flushedPut enableBracketedPastes
77 True -> flushedPut enableBracketedPastes
62 False -> flushedPut disableBracketedPastes
78 False -> flushedPut disableBracketedPastes
63 writeIORef pasteModeStatus newStatus
79 writeIORef pasteModeStatus newStatus
80+ Hyperlink -> setMode t Hyperlink newStatus
64
81
65 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
66 xtermGetMode Focus = liftIO $ readIORef focusModeStatus
83 xtermGetMode Focus = liftIO $ readIORef focusModeStatus
67 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85+ xtermGetMode Hyperlink = getModeStatus t Hyperlink
68
86
69 let t' = t
87 let t' = t
70 { terminalID = terminalID t ++ " (xterm-color)"
88 { terminalID = terminalID t ++ " (xterm-color)"
@@ -86,30 +104,27 @@ reserveTerminal variant outFd = liftIO $ do
86utf8Active :: IO Bool
104utf8Active :: IO Bool
87utf8Active = do
105utf8Active = do
88 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
89− results <- catMaybes <$> mapM getEnv vars
107+ results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars
90− let matches = filter ("UTF8" `isInfixOf`) results <>
108+ let matches = filter ("utf8" `isInfixOf`) results <>
91− filter ("UTF-8" `isInfixOf`) results
109+ filter ("utf-8" `isInfixOf`) results
92 return $ not $ null matches
110 return $ not $ null matches
93
111
94-- | Enable bracketed paste mode:
112-- | Enable bracketed paste mode:
95-- http://cirw.in/blog/bracketed-paste
113-- http://cirw.in/blog/bracketed-paste
96−enableBracketedPastes :: String
114+enableBracketedPastes :: ByteString
97−enableBracketedPastes = "\ESC[?2004h"
115+enableBracketedPastes = BS8.pack "\ESC[?2004h"
98
116
99-- | Disable bracketed paste mode:
117-- | Disable bracketed paste mode:
100−disableBracketedPastes :: String
118+disableBracketedPastes :: ByteString
101−disableBracketedPastes = "\ESC[?2004l"
119+disableBracketedPastes = BS8.pack "\ESC[?2004l"
102
120
103-- | These sequences set xterm based terminals to UTF-8 output.
121-- | These sequences set xterm based terminals to UTF-8 output.
104--
122--
105-- There is no known terminfo capability equivalent to this.
123-- There is no known terminfo capability equivalent to this.
106−setUtf8CharSet, setDefaultCharSet :: String
124+setUtf8CharSet, setDefaultCharSet :: ByteString
107−setUtf8CharSet = "\ESC%G"
125+setUtf8CharSet = BS8.pack "\ESC%G"
108−setDefaultCharSet = "\ESC%@"
126+setDefaultCharSet = BS8.pack "\ESC%@"
109
127
110−-- | I think xterm is broken: Reseting the background color as the first
111−-- bytes serialized on a new line does not effect the background color
112−-- xterm uses to clear the line. Which is used *after* the next newline.
113xtermInlineHack :: Output -> IO ()
128xtermInlineHack :: Output -> IO ()
114xtermInlineHack t = do
129xtermInlineHack t = do
115 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/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+75−66
@@ -1,5 +1,5 @@
1name: vty
1name: vty
2−version: 5.18
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
@@ -45,10 +45,9 @@ library
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
@@ -94,35 +100,47 @@ library
94 Graphics.Vty.Output.Interface
100 Graphics.Vty.Output.Interface
95 Graphics.Vty.Output.XTermColor
101 Graphics.Vty.Output.XTermColor
96 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
97
107
98− other-modules: Graphics.Vty.Attributes.Color
108+ other-modules: Graphics.Vty.Debug.Image
99− Graphics.Vty.Attributes.Color240
100− Graphics.Vty.Debug.Image
101 Graphics.Vty.Input.Terminfo.ANSIVT
109 Graphics.Vty.Input.Terminfo.ANSIVT
102
110
103 c-sources: cbits/gwinsz.c
111 c-sources: cbits/gwinsz.c
104 cbits/set_term_timing.c
112 cbits/set_term_timing.c
113+ cbits/get_tty_erase.c
105 cbits/mk_wcwidth.c
114 cbits/mk_wcwidth.c
106
115
107 include-dirs: cbits
116 include-dirs: cbits
108
117
109 hs-source-dirs: src
118 hs-source-dirs: src
110
119
111− default-extensions: ScopedTypeVariables
112− ForeignFunctionInterface
113−
114 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
115
121
116 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
117
123
124+executable vty-build-width-table
125+ main-is: BuildWidthTable.hs
126+ hs-source-dirs: tools
127+
128+ default-language: Haskell2010
118− 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
119
138
120executable vty-mode-demo
139executable vty-mode-demo
121 main-is: ModeDemo.hs
140 main-is: ModeDemo.hs
122 hs-source-dirs: demos
141 hs-source-dirs: demos
123
142
124 default-language: Haskell2010
143 default-language: Haskell2010
125− default-extensions: ScopedTypeVariables
126 ghc-options: -threaded
144 ghc-options: -threaded
127
145
128 build-depends: vty,
146 build-depends: vty,
@@ -137,7 +155,6 @@ executable vty-demo
137 hs-source-dirs: demos
155 hs-source-dirs: demos
138
156
139 default-language: Haskell2010
157 default-language: Haskell2010
140− default-extensions: ScopedTypeVariables
141 ghc-options: -threaded
158 ghc-options: -threaded
142
159
143 build-depends: vty,
160 build-depends: vty,
@@ -147,29 +164,8 @@ executable vty-demo
147 microlens-mtl,
164 microlens-mtl,
148 mtl >= 1.1.1.0 && < 2.3
165 mtl >= 1.1.1.0 && < 2.3
149
166
150−test-suite verify-attribute-ops
151− default-language: Haskell2010
152− default-extensions: ScopedTypeVariables
153− type: detailed-0.9
154− hs-source-dirs: test
155− test-module: VerifyAttributeOps
156− build-depends: vty,
157− Cabal >= 1.20,
158− QuickCheck >= 2.7,
159− random >= 1.0 && < 1.2,
160− base >= 4.8 && < 5,
161− bytestring,
162− containers,
163− deepseq >= 1.1 && < 1.5,
164− mtl >= 1.1.1.0 && < 2.3,
165− text >= 0.11.3,
166− unix,
167− utf8-string >= 0.3 && < 1.1,
168− vector >= 0.7
169−
170test-suite verify-using-mock-terminal
167test-suite verify-using-mock-terminal
171 default-language: Haskell2010
168 default-language: Haskell2010
172− default-extensions: ScopedTypeVariables
173
169
174 type: detailed-0.9
170 type: detailed-0.9
175
171
@@ -188,7 +184,7 @@ test-suite verify-using-mock-terminal
188 build-depends: vty,
184 build-depends: vty,
189 Cabal >= 1.20,
185 Cabal >= 1.20,
190 QuickCheck >= 2.7,
186 QuickCheck >= 2.7,
191− random >= 1.0 && < 1.2,
187+ random >= 1.0 && < 1.3,
192 base >= 4.8 && < 5,
188 base >= 4.8 && < 5,
193 bytestring,
189 bytestring,
194 containers,
190 containers,
@@ -202,7 +198,6 @@ test-suite verify-using-mock-terminal
202
198
203test-suite verify-terminal
199test-suite verify-terminal
204 default-language: Haskell2010
200 default-language: Haskell2010
205− default-extensions: ScopedTypeVariables
206
201
207 type: detailed-0.9
202 type: detailed-0.9
208
203
@@ -221,7 +216,7 @@ test-suite verify-terminal
221 build-depends: vty,
216 build-depends: vty,
222 Cabal >= 1.20,
217 Cabal >= 1.20,
223 QuickCheck >= 2.7,
218 QuickCheck >= 2.7,
224− random >= 1.0 && < 1.2,
219+ random >= 1.0 && < 1.3,
225 base >= 4.8 && < 5,
220 base >= 4.8 && < 5,
226 bytestring,
221 bytestring,
227 containers,
222 containers,
@@ -235,7 +230,6 @@ test-suite verify-terminal
235
230
236test-suite verify-display-attributes
231test-suite verify-display-attributes
237 default-language: Haskell2010
232 default-language: Haskell2010
238− default-extensions: ScopedTypeVariables
239
233
240 type: detailed-0.9
234 type: detailed-0.9
241
235
@@ -254,7 +248,7 @@ test-suite verify-display-attributes
254 build-depends: vty,
248 build-depends: vty,
255 Cabal >= 1.20,
249 Cabal >= 1.20,
256 QuickCheck >= 2.7,
250 QuickCheck >= 2.7,
257− random >= 1.0 && < 1.2,
251+ random >= 1.0 && < 1.3,
258 base >= 4.8 && < 5,
252 base >= 4.8 && < 5,
259 bytestring,
253 bytestring,
260 containers,
254 containers,
@@ -267,7 +261,6 @@ test-suite verify-display-attributes
267
261
268test-suite verify-empty-image-props
262test-suite verify-empty-image-props
269 default-language: Haskell2010
263 default-language: Haskell2010
270− default-extensions: ScopedTypeVariables
271
264
272 type: detailed-0.9
265 type: detailed-0.9
273
266
@@ -280,7 +273,7 @@ test-suite verify-empty-image-props
280 build-depends: vty,
273 build-depends: vty,
281 Cabal >= 1.20,
274 Cabal >= 1.20,
282 QuickCheck >= 2.7,
275 QuickCheck >= 2.7,
283− random >= 1.0 && < 1.2,
276+ random >= 1.0 && < 1.3,
284 base >= 4.8 && < 5,
277 base >= 4.8 && < 5,
285 bytestring,
278 bytestring,
286 containers,
279 containers,
@@ -293,7 +286,6 @@ test-suite verify-empty-image-props
293
286
294test-suite verify-eval-terminfo-caps
287test-suite verify-eval-terminfo-caps
295 default-language: Haskell2010
288 default-language: Haskell2010
296− default-extensions: ScopedTypeVariables
297
289
298 type: detailed-0.9
290 type: detailed-0.9
299
291
@@ -307,7 +299,7 @@ test-suite verify-eval-terminfo-caps
307 build-depends: vty,
299 build-depends: vty,
308 Cabal >= 1.20,
300 Cabal >= 1.20,
309 QuickCheck >= 2.7,
301 QuickCheck >= 2.7,
310− random >= 1.0 && < 1.2,
302+ random >= 1.0 && < 1.3,
311 base >= 4.8 && < 5,
303 base >= 4.8 && < 5,
312 blaze-builder >= 0.3.3.2 && < 0.5,
304 blaze-builder >= 0.3.3.2 && < 0.5,
313 bytestring,
305 bytestring,
@@ -322,7 +314,6 @@ test-suite verify-eval-terminfo-caps
322
314
323test-suite verify-image-ops
315test-suite verify-image-ops
324 default-language: Haskell2010
316 default-language: Haskell2010
325− default-extensions: ScopedTypeVariables
326
317
327 type: detailed-0.9
318 type: detailed-0.9
328
319
@@ -337,7 +328,7 @@ test-suite verify-image-ops
337 build-depends: vty,
328 build-depends: vty,
338 Cabal >= 1.20,
329 Cabal >= 1.20,
339 QuickCheck >= 2.7,
330 QuickCheck >= 2.7,
340− random >= 1.0 && < 1.2,
331+ random >= 1.0 && < 1.3,
341 base >= 4.8 && < 5,
332 base >= 4.8 && < 5,
342 bytestring,
333 bytestring,
343 containers,
334 containers,
@@ -350,7 +341,6 @@ test-suite verify-image-ops
350
341
351test-suite verify-image-trans
342test-suite verify-image-trans
352 default-language: Haskell2010
343 default-language: Haskell2010
353− default-extensions: ScopedTypeVariables
354
344
355 type: detailed-0.9
345 type: detailed-0.9
356
346
@@ -365,7 +355,7 @@ test-suite verify-image-trans
365 build-depends: vty,
355 build-depends: vty,
366 Cabal >= 1.20,
356 Cabal >= 1.20,
367 QuickCheck >= 2.7,
357 QuickCheck >= 2.7,
368− random >= 1.0 && < 1.2,
358+ random >= 1.0 && < 1.3,
369 base >= 4.8 && < 5,
359 base >= 4.8 && < 5,
370 bytestring,
360 bytestring,
371 containers,
361 containers,
@@ -378,7 +368,6 @@ test-suite verify-image-trans
378
368
379test-suite verify-inline
369test-suite verify-inline
380 default-language: Haskell2010
370 default-language: Haskell2010
381− default-extensions: ScopedTypeVariables
382
371
383 type: detailed-0.9
372 type: detailed-0.9
384
373
@@ -392,7 +381,7 @@ test-suite verify-inline
392 build-depends: vty,
381 build-depends: vty,
393 Cabal >= 1.20,
382 Cabal >= 1.20,
394 QuickCheck >= 2.7,
383 QuickCheck >= 2.7,
395− random >= 1.0 && < 1.2,
384+ random >= 1.0 && < 1.3,
396 base >= 4.8 && < 5,
385 base >= 4.8 && < 5,
397 bytestring,
386 bytestring,
398 containers,
387 containers,
@@ -405,7 +394,6 @@ test-suite verify-inline
405
394
406test-suite verify-parse-terminfo-caps
395test-suite verify-parse-terminfo-caps
407 default-language: Haskell2010
396 default-language: Haskell2010
408− default-extensions: ScopedTypeVariables
409
397
410 type: detailed-0.9
398 type: detailed-0.9
411
399
@@ -420,7 +408,7 @@ test-suite verify-parse-terminfo-caps
420 build-depends: vty,
408 build-depends: vty,
421 Cabal >= 1.20,
409 Cabal >= 1.20,
422 QuickCheck >= 2.7,
410 QuickCheck >= 2.7,
423− random >= 1.0 && < 1.2,
411+ random >= 1.0 && < 1.3,
424 base >= 4.8 && < 5,
412 base >= 4.8 && < 5,
425 bytestring,
413 bytestring,
426 containers,
414 containers,
@@ -434,7 +422,6 @@ test-suite verify-parse-terminfo-caps
434
422
435test-suite verify-simple-span-generation
423test-suite verify-simple-span-generation
436 default-language: Haskell2010
424 default-language: Haskell2010
437− default-extensions: ScopedTypeVariables
438
425
439 type: detailed-0.9
426 type: detailed-0.9
440
427
@@ -452,7 +439,7 @@ test-suite verify-simple-span-generation
452 build-depends: vty,
439 build-depends: vty,
453 Cabal >= 1.20,
440 Cabal >= 1.20,
454 QuickCheck >= 2.7,
441 QuickCheck >= 2.7,
455− random >= 1.0 && < 1.2,
442+ random >= 1.0 && < 1.3,
456 base >= 4.8 && < 5,
443 base >= 4.8 && < 5,
457 bytestring,
444 bytestring,
458 containers,
445 containers,
@@ -466,7 +453,6 @@ test-suite verify-simple-span-generation
466
453
467test-suite verify-crop-span-generation
454test-suite verify-crop-span-generation
468 default-language: Haskell2010
455 default-language: Haskell2010
469− default-extensions: ScopedTypeVariables
470
456
471 type: detailed-0.9
457 type: detailed-0.9
472
458
@@ -484,7 +470,7 @@ test-suite verify-crop-span-generation
484 build-depends: vty,
470 build-depends: vty,
485 Cabal >= 1.20,
471 Cabal >= 1.20,
486 QuickCheck >= 2.7,
472 QuickCheck >= 2.7,
487− random >= 1.0 && < 1.2,
473+ random >= 1.0 && < 1.3,
488 base >= 4.8 && < 5,
474 base >= 4.8 && < 5,
489 bytestring,
475 bytestring,
490 containers,
476 containers,
@@ -498,7 +484,6 @@ test-suite verify-crop-span-generation
498
484
499test-suite verify-layers-span-generation
485test-suite verify-layers-span-generation
500 default-language: Haskell2010
486 default-language: Haskell2010
501− default-extensions: ScopedTypeVariables
502
487
503 type: detailed-0.9
488 type: detailed-0.9
504
489
@@ -516,7 +501,32 @@ test-suite verify-layers-span-generation
516 build-depends: vty,
501 build-depends: vty,
517 Cabal >= 1.20,
502 Cabal >= 1.20,
518 QuickCheck >= 2.7,
503 QuickCheck >= 2.7,
519− 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,
520 base >= 4.8 && < 5,
530 base >= 4.8 && < 5,
521 bytestring,
531 bytestring,
522 containers,
532 containers,
@@ -529,7 +539,6 @@ test-suite verify-layers-span-generation
529
539
530test-suite verify-utf8-width
540test-suite verify-utf8-width
531 default-language: Haskell2010
541 default-language: Haskell2010
532− default-extensions: ScopedTypeVariables
533
542
534 type: detailed-0.9
543 type: detailed-0.9
535
544
@@ -542,7 +551,7 @@ test-suite verify-utf8-width
542 build-depends: vty,
551 build-depends: vty,
543 Cabal >= 1.20,
552 Cabal >= 1.20,
544 QuickCheck >= 2.7,
553 QuickCheck >= 2.7,
545− random >= 1.0 && < 1.2,
554+ random >= 1.0 && < 1.3,
546 base >= 4.8 && < 5,
555 base >= 4.8 && < 5,
547 bytestring,
556 bytestring,
548 containers,
557 containers,
@@ -555,7 +564,6 @@ test-suite verify-utf8-width
555
564
556test-suite verify-using-mock-input
565test-suite verify-using-mock-input
557 default-language: Haskell2010
566 default-language: Haskell2010
558− default-extensions: ScopedTypeVariables
559
567
560 type: exitcode-stdio-1.0
568 type: exitcode-stdio-1.0
561
569
@@ -563,6 +571,8 @@ test-suite verify-using-mock-input
563
571
564 main-is: VerifyUsingMockInput.hs
572 main-is: VerifyUsingMockInput.hs
565
573
574+ other-modules: Verify.Graphics.Vty.Output
575+
566 build-depends: vty,
576 build-depends: vty,
567 Cabal >= 1.20,
577 Cabal >= 1.20,
568 QuickCheck >= 2.7,
578 QuickCheck >= 2.7,
@@ -570,7 +580,7 @@ test-suite verify-using-mock-input
570 quickcheck-assertions >= 0.1.1,
580 quickcheck-assertions >= 0.1.1,
571 test-framework == 0.8.*,
581 test-framework == 0.8.*,
572 test-framework-smallcheck == 0.2.*,
582 test-framework-smallcheck == 0.2.*,
573− random >= 1.0 && < 1.2,
583+ random >= 1.0 && < 1.3,
574 base >= 4.8 && < 5,
584 base >= 4.8 && < 5,
575 bytestring,
585 bytestring,
576 containers,
586 containers,
@@ -589,7 +599,6 @@ test-suite verify-using-mock-input
589
599
590test-suite verify-config
600test-suite verify-config
591 default-language: Haskell2010
601 default-language: Haskell2010
592− default-extensions: ScopedTypeVariables
593
602
594 type: exitcode-stdio-1.0
603 type: exitcode-stdio-1.0
595
604
@@ -606,7 +615,7 @@ test-suite verify-config
606 test-framework == 0.8.*,
615 test-framework == 0.8.*,
607 test-framework-smallcheck == 0.2.*,
616 test-framework-smallcheck == 0.2.*,
608 test-framework-hunit,
617 test-framework-hunit,
609− random >= 1.0 && < 1.2,
618+ random >= 1.0 && < 1.3,
610 base >= 4.8 && < 5,
619 base >= 4.8 && < 5,
611 bytestring,
620 bytestring,
612 containers,
621 containers,