git.iko.soy/vty
on 1fcdf94 help sign in
4a29aec
swap
0 ahead, 360 behind
.gitignore−1
since splitsnapshots
unifiedsplit
@@ -6,7 +6,6 @@ Setup
6dist
6dist
7dist-newstyle
7dist-newstyle
8cabal.project.local
8cabal.project.local
9−.ghc.environment.*
10test/benchmark
9test/benchmark
11.hpc
10.hpc
12.cabal-sandbox
11.cabal-sandbox
.travis.yml+18−100
@@ -1,109 +1,27 @@
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−#
7−language: c
1+language: haskell
8−sudo: false
9
2
10−git:
3+notifications:
11− submodules: false # whether to recursively clone submodules
4+ email: false
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
28
5
29matrix:
6matrix:
30− include:
7+ allow_failures:
31− - compiler: "ghc-8.4.3"
8+ - env: CABALVER=head GHCVER=head
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]}}
43
9
44−before_install:
10+env:
45− - HC=${CC}
11+ - CABALVER=1.20 GHCVER=7.6.3
46− - HCPKG=${HC/ghc/ghc-pkg}
12+ - CABALVER=1.20 GHCVER=7.8.3
47− - unset CC
13+ - CABALVER=1.22 GHCVER=7.10.1
48− - ROOTDIR=$(pwd)
14+ - CABALVER=1.24 GHCVER=8.0.1
49− - mkdir -p $HOME/.local/bin
15+ - CABALVER=head GHCVER=head
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
53
16
54install:
17install:
55− - cabal --version
18+ - ./ci/travis_ci_install
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)
80
19
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.
83script:
20script:
84− # test that source-distributions can be generated
21+ - ./ci/travis_ci_script
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
96
22
97− # build & run tests, build benchmarks
23+before_install:
98− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
24+ - sudo add-apt-repository -y ppa:hvr/ghc
99− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
25+ - sudo apt-get update
100−
26+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
101− # haddock
27+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH
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+329−782
@@ -1,861 +1,408 @@
1−
2−5.35.1
3−------
4−
5−Bug fixes:
6− * Fixed a build issue with a test program.
7−
8−5.35
9−----
10−
11−New features:
12− * Add support for 24-bit color (thanks @u-quark). This change
13− updates Vty to look at the `COLORTERM` environment variable that is
14− conventionally used to advertise support for truecolor escape
15− sequences. The change also updates the Vty demo to demonstrate
16− 24-bit colors. This change also adds a new data type, `ColorMode`,
17− to represent the color mode in use, as well as an `Output` interface
18− field, `outputColorMode`, to track the active color mode and use it
19− to clamp emitted color escape sequences to the active color range.
20−
21−API changes:
22− * All types in `Graphics.Vty.Input.Events` now have strict constructor
23− fields.
24− * Internal events are now wrapped in a new `InternalEvent` type to
25− improve how signal handling is done. This change modifies the `Input`
26− type's event channel API to produce `InternalEvents`, not `Events`.
27− The new `InternalEvent` either wraps `Event` with the `InputEvent`
28− constructor (the previous behavior) or indicates that Vty resumed
29− after handling a signal using the `ResumeAfterSignal` constructor.
30− This change avoids the previous use of `EvResize` with lazy exception
31− arguments as a sentinel value for `ResumeAfterSignal`.
32−
33−Other enhancements:
34− * Bracketed paste parsing performance has been greatly improved thanks
35− to benchmarking and optimization work by @iphydf. As part of that
36− work, Vty now uses bytestrings rather than Strings internally when
37− parsing input to look for events.
38− * The `\b` value is now interpreted as `KBS` (thanks @vglfr)
39−
40−5.34
41−----
42−
43−API changes:
44− * Added an `NFData` instance for `Event` (thanks Mario Lang)
45− * Removed `Monoid` and `Semigroup` instances for `Attr` and
46− `MaybeDefault`. This change removed the instances because they were
47− misbehaved; merging `Attr` and `MaybeDefault` values with these
48− instances resulted in field value losses. For example, before this
49− change,
50−```
51−(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)
52−```
53− would result in just
54−```
55− (defAttr `withBackColor` green)
56−```
57− because the instances were designed to favor the right-hand
58− arguments' fields even if they had not been explicitly set
59− (a consequence of the `MaybeDefault` `Semigroup` instance).
60− While that behavior was sensible specifically in the context of
61− `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made
62− for surprising instance behavior. Since there is actually no good way
63− to handle this in a `Semigroup` instance for `Attr` -- some choices
64− have to be made about how to merge two attributes' foreground colors,
65− and that won't be much better than what we had -- the instance was
66− just removed.
67−
68−
69−5.33
70−----
71−
72−API changes:
73−* The `Cursor` type got a new `PositionOnly` constructor for cursor
74− placement without visibility.
75−
76−Package changes:
77−* Relaxed upper bound for `random`
78−* Updated `microlens` bounds to allow 0.4.12
79−
80−Other improvements:
81−* Various hlint-driven improvements (thanks Willem Van Onsem)
82−* The implementation of `color240` was improved (thanks (Willem Van
83− Onsem)
84−
85−5.32
86−----
87−
88−New features:
89− * Meta-PageUp and Meta-PageDown are now supported (#193)
90− * Added `supportsItalics` and `supportsStrikethrough` functions to
91− check for feature support in terminfo
92−
93−Bug fixes:
94− * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka
95− Nkurumeh)
96−
97−5.31
98−----
99−
100−New features and API changes:
101− * Added support for strikethrough mode. This change adds a new
102− `strikethrough` `Style` value and uses the `smxx` and `rmxx`
103− Terminfo capabilities to activate and deactivate strikethrough mode,
104− respectively. If the terminfo does not report those capabilities,
105− this style is ignored.
106− * `Output`: added the `setDisplayBounds` field to set the output
107− dimensions of the output handle; added an implementation of this for
108− the `TerminfoBased` backend.
109−
110−Other changes:
111− * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.
112−
113−5.30
114−----
115−
116−New features:
117− * Added `Graphics.Vty.setWindowTitle` to emit an escape
118− sequence to set the window title, provide the terminal emulator
119− accepts Xterm-style title sequences. For details, see:
120− https://tldp.org/HOWTO/Xterm-Title-3.html
121−
122−5.29
123−----
124−
125−API changes:
126− * The Input type got a new field, 'restoreInputState'. This field
127− allows the end user to have direct access to the logic needed to
128− restore the terminal's input state flags. Prior to having this field,
129− this state restoration logic could only be invoked as part of calling
130− 'shutdownInput', but since that function does other things (like
131− killing threads) it is not advisable to call it repeatedly (which is
132− necessary in the use case this change is intended to support). This
133− can be called directly to restore the input state flags as needed,
134− although this is not required if 'shutdown' (or 'shutdownInput') is
135− called.
136−
137−Other changes:
138− * attributeControl: explicitly enable the ICRNL terminal mode flag (see
139− #187 and c572ad).
140−
141−5.28.2
142−------
143−
144−Bug fixes:
145− * Added a package dependency on `semigroups` for the
146− `vty-build-width-table` tool on older GHCs (#185)
147−
148−5.28.1
149−------
150−
151−Bug fixes:
152− * `installUnicodeWidthTable`: use `throwIO`, not `throw`
153−
154−5.28
155−----
156−
157−This release improves Vty's support for multi-column Unicode characters
158−and provides greater compatibility with a wider array of terminal
159−emulators. The following sections summarize the relevant changes, but an
160−overview of the new functionality is motivated and detailed in the new
161−"Multi-Column Character Support" README section. For
162−historical context, please also consider reading over
163−[#175](https://github.com/jtdaugherty/vty/issues/175).
164−
165−API changes:
166− * New modules were added:
167− * `Graphics.Vty.UnicodeWidthTable.Types`
168− * `Graphics.Vty.UnicodeWidthTable.IO`
169− * `Graphics.Vty.UnicodeWidthTable.Query`
170− * `Graphics.Vty.UnicodeWidthTable.Install`
171− * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,
172− that controls whether `mkVty` will attempt to load a Unicode width
173− table if specified in the configuration.
174−
175−Configuration file changes:
176− * A new syntax was added to support specifying Unicode width tables on
177− a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the
178− documentation for `Graphics.Vty.Config` for details. Since prior
179− versions of this library will silently ignore any configuration file
180− lines they cannot parse, this change to user configuration files is
181− at least non-breaking for older versions of Vty.
182−
183−Other changes:
184− * The `mkVty` function now automatically attempts to load a custom
185− Unicode width table if one is specified in the configuration,
186− provided `allowCustomUnicodeWidthTables` is not set to `Just False`.
187− See the documentation for `Graphics.Vty.mkVty` for details.
188− * Vty now includes a command line tool, `vty-build-width-table`, that
189− queries the terminal emulator to construct a custom Unicode width
190− table and optionally update the Vty configuration file to use it.
191− Programs that want to use that tool's functionality may also do so
192− via the API exposed in the various modules listed above.
193−
194−5.27
195−----
196−
197−* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the
198− kernel for the current terminal's settings to obtain the character
199− assigned by the `stty erase` command. That can then be added to the
200− Vty configuration's input map to map to `KBS` (backspace) if desired.
201−
202−5.26
203−----
204−
205−* Resolved various import warnings (thanks @glguy)
206−* Removed the `MonadIO` constraint from the Output type's fields and
207− removed `MonadFail` uses (PR #177, thanks @glguy)
208−* Clarified documentation for ANSI colors (thanks Colby Jenn)
209−* `Graphics.Vty.Attributes` no longer re-exports
210− `Graphics.Vty.Attributes.Color`
211−* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks
212− Colby Jenn)
213−* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)
214−* Changed from using `System.Posix.Env.getEnv` to
215− `System.Environment.lookupEnv` (thanks Jonathan Osser)
216−* Added `Graphics.Vty.Image` functions for dealing with character width
217− computations on `Text` values instead of `Strings`:
218− * `safeWctwidth`
219− * `safeWctlwidth`
220− * `wctwidth`
221− * `wctlwidth`
222−
223−5.25.1
224−------
225−
226−* Avoided a conflict with a Microlens 0.4.10 operator and added an
227− upper bound on Microlens of 0.4.11.
228−
229−5.25
230−----
231−
232−* The Vty type got a new field, isShutdown, that returns whether the
233− Vty handle has had its 'shutdown' function called (thanks Ian
234− Jeffries)
235−* Vty's shutdown function is now thread-safe.
236−
237−5.24.1
238−------
239−
240−* The "shutdown" method of Vty handles is now idempotent (#159)
241−
242−5.24
243−----
244−
245−* Add Generic and NFData instances for some types
246−* Image: remove custom Show instance, add derived Show and Read
247− instances
248−* Updated Travis build settings (thanks Eric Mertens)
249−
250−5.23.1
251−------
252−
253−* Fixed a bug where italics did not combine properly with other display
254− modes (#155, thanks Eric Mertens)
255−
256−5.23
257−----
258−
259−* Added support for italicized output when terminfo supports it. This
260− takes the form of a new Style, "italic". Note that most terminfo
261− descriptors do not report capabilities for italics, so support for
262− this will be very spotty.
263−* Updateed text/string function documentation to indicate that escapes
264− are not permitted in their inputs.
265−
266−5.22
267−----
268−
269−* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function
270− (thanks Brent Carmer)
271−* Added nextEventNonblocking function (field) to Vty type (#87)
272−
273−5.21
274−----
275−
276−* Picture and Background now provide Eq instances (thanks Jaro Reinders)
277−* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)
278−* #142: note requirement of threaded RTS
279−
280−5.20
281−----
282−
283−API changes:
284−* Split up Monoid instances into Monoid and Semigroup for newer GHCs
285− (thanks Ryan Scott)
286−
287−5.19.1
288−------
289−
290−API changes:
291−* Cursor now provides an Eq instance (thanks Jaro Reinders)
292−
293−5.19
294−----
295−
296−API changes:
297−* URL hyperlinking (via 'withURL') is now optional and disabled by
298− default due to poor support on some common terminals. A new 'Mode'
299− constructor, 'Hyperlink', has been added to enable this feature. To
300− change the hyperlinking mode, use 'setMode' on the 'outputIface' of a
301− Vty handle.
302−
303−5.18.1
304−------
305−
306−Bug fixes:
307−* Reset the hyperlink state on line endings to avoid run-on hyperlinks
308−
309−5.18
310−----
311−
312−API changes:
313−* Added support for hyperlinking attributes (thanks Getty Ritter). This
314− change adds a new Attr field for containing the hyperlink to apply,
315− as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda
316−
317−5.17.1
318−------
319−
320−* withStyle now ignores zero arguments, leaving attribute styles
321− untouched if the input style is the null style
322−
323−5.17
324−----
325−
326−API changes:
327−* Add support for terminal focus events. This change adds a new mode
328− usable with setMode, Focus, that requests that the terminal send
329− events on focus lose/gain. This change also adds two new Event
330− constructors, EvLostFocus and EvGainedFocus.
331−* No longer enable UTF8 mouse event encoding. This encoding was not
332− working properly with Terminal.app, and using the other modes (SGR,
333− etc.) work.
334−* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
335− #131)
336−
337−5.16
338−----
339−
340−API changes:
341−* Added support for mouse wheel events while in mouse mode. The Button
342− type got two new constructors as a result: BScrollUp and BScrollDown.
343− Thanks to doublescale@tutanota.com for this contribution!
344−
345−Bug fixes:
346−* charFill now clamps negative arguments to zero (thanks Eric Mertens!)
347−
348−5.15.1
349−------
350−
351−Package changes:
352−* Documentation files are now marked accordingly (thanks Michal
353− Suchánek)
354−
355−Bug fixes:
356−* translateX/Y: fix negative translations
357−
358−5.15
359−----
360−
361−Package changes:
362−* Discontinued support for GHC versions prior to 7.10.1.
363−* Removed instructions and configuration for Stack builds since they
364− are no longer supported.
365−* Clarified README mention of (lack of) Windows support (contributors
366− wanted, though!)
367−* Removed dependency on data-default (see below).
368−
369−API changes:
370−* Moved color definitions from Attributes to Color module.
371−* In lieu of data-default (Default) instances for Attr and Config, use
372− 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
373−* Graphics.Vty.Output no longer re-exports
374− Graphics.Vty.Output.Interface.
375−* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
376− accessors to Graphics.Vty.Image.
377−* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
378−* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
379−
3805.14
15.14
381−----
382−
383−* addMaybeClippedJoin: instead of raising an exception when the join
2+ - addMaybeClippedJoin: instead of raising an exception when the join
384− is totally clipped, just reduce the clip amount and continue
3+ is totally clipped, just reduce the clip amount and continue
385−* addMaybeClipped: skip blit of joins when their primary dimension is
4+ - addMaybeClipped: skip blit of joins when their primary dimension is
386− zero
5+ zero
387−* 'string' and related text functions no longer treat an empty string
6+ - 'string' and related text functions no longer treat an empty string
388− as an empty image (thanks Chris Penner). This means that now it is
7+ as an empty image (thanks Chris Penner). This means that now it is
389− possible to use 'str ""' as a non-empty image with height 1.
8+ possible to use 'str ""' as a non-empty image with height 1.
390
9
3915.13
105.13
392−----
393−
394−* Reverted changes in 5.12 due to disagreements between terminal
11+ - Reverted changes in 5.12 due to disagreements between terminal
395− emulators and utf8proc; for more details, please see the ticket
12+ emulators and utf8proc; for more details, please see the ticket
396− discussion at
13+ discussion at
397− https://github.com/coreyoconnor/vty/issues/115
14+ https://github.com/coreyoconnor/vty/issues/115
398
15
3995.12
165.12
400−----
401−
402−* Replaced 'wcwidth' with a call to the utf8proc library's character
17+ - Replaced 'wcwidth' with a call to the utf8proc library's character
403− width function, which is much more up to date (by several Unicode
18+ width function, which is much more up to date (by several Unicode
404− versions) and returns the right width for a much larger set of
19+ versions) and returns the right width for a much larger set of
405− characters.
20+ characters.
406−* Added a bundled version of the utf8proc C library.
21+ - Added a bundled version of the utf8proc C library.
407
22
4085.11.3
235.11.3
409−------
410−
411−* Fix mouse event offsets in mouse-up events
24+ - Fix mouse event offsets in mouse-up events
412
25
4135.11.2
265.11.2
414−------
415−
416−* Mouse events were modified so that the upper-left corner of the window
27+ - Mouse events were modified so that the upper-left corner of the
417− is (0,0) rather than (1,1).
28+ window is (0,0) rather than (1,1).
418
29
4195.11.1
305.11.1
420−------
421−
422−* Add Generic instance for Image
31+ - Add Generic instance for Image
423−* nextEvent: stop trying to refresh on a resize event (fixes segfault
32+ - nextEvent: stop trying to refresh on a resize event (fixes segfault
424− on refresh with normal cursor positioning mode)
33+ on refresh with normal cursor positioning mode)
425−* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
34+ - Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
426−* Update maintainer
35+ - Update maintainer
427
36
4285.11
375.11
429−----
430−
431−* Vty now raises a VtyConfigurationError exception when the TERM
38+ - Vty now raises a VtyConfigurationError exception when the TERM
432− evironment variable is missing (thanks Eric Mertens)
39+ evironment variable is missing (thanks Eric Mertens)
433−* Graphics.Vty.Config got an explicit export list to avoid accidentally
40+ - Graphics.Vty.Config got an explicit export list to avoid accidentally
434− exporting internal types (thanks Eric Mertens)
41+ exporting internal types (thanks Eric Mertens)
435
42
4365.10
435.10
437−----
438−
439−* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
44+ - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
440− mode provides greater control over cursor positioning by bypassing
45+ mode provides greater control over cursor positioning by bypassing
441− the logical positioning provided by default. Rather than positioning
46+ the logical positioning provided by default. Rather than positioning
442− the cursor by looking at the widths of characters involved, this
47+ the cursor by looking at the widths of characters involved, this
443− constructor lets you provide a physical row and column instead. This
48+ constructor lets you provide a physical row and column instead. This
444− is useful in more sophisticated programs. (thanks Eric Mertens)
49+ is useful in more sophisticated programs. (thanks Eric Mertens)
445−* Added a new Generic-derived config parser (thanks Eric Mertens)
50+ - Added a new Generic-derived config parser (thanks Eric Mertens)
446−* Fixed the MShift case in the configuration file parser (thanks Eric
51+ - Fixed the MShift case in the configuration file parser (thanks Eric
447− Mertens)
52+ Mertens)
448−* Fixed wcwidth import and matched safeWcswidth to its documented
53+ - Fixed wcwidth import and matched safeWcswidth to its documented
449− behavior. Previously vty_mk_wcwidth was being imported with the
54+ behavior. Previously vty_mk_wcwidth was being imported with
450− wrong type causing the -1 return value to be mapped to the wrong Int
55+ the wrong type causing the -1 return value to be mapped to the
451− value. Additionally safeWcswidth was using the unsafe character width
56+ wrong Int value. Additionally safeWcswidth was using the unsafe
452− function and only ensuring that the final result was non-negative.
57+ character width function and only ensuring that the final result was
453− (thanks Eric Mertens)
58+ non-negative. (thanks Eric Mertens)
454
59
4555.9.1
605.9.1
456−-----
457−
458−* Vty now only emits UTF8 charset sequences in terminals without a
61+ - Vty now only emits UTF8 charset sequences in terminals without a
459− preexisting UTF8 declaration to avoid emitting garbage sequences
62+ preexisting UTF8 declaration to avoid emitting garbage sequences
460− (fixes #89)
63+ (fixes #89)
461
64
4625.9
655.9
463−---
464−
465−* Added new Output methods supportsBell and ringTerminalBell to find out
66+ - Added new Output methods supportsBell and ringTerminalBell to find
466− whether the output device has an audio bell and to ring it (see #102)
67+ out whether the output device has an audio bell and to ring it (see
68+ #102)
467
69
4685.8.1
705.8.1
469−-----
470−
471−* Fixed "refresh" to work as advertised (see #104)
71+ - Fixed "refresh" to work as advertised (see #104)
472
72
4735.8
735.8
474−---
475−
476−* API change: EvPaste input event now provides paste data as a raw
74+ - API change: EvPaste input event now provides paste data as a raw
477− ByteString rather than a String to allow the application to decode how
75+ ByteString rather than a String to allow the application to decode
478− best to decode it
76+ how best to decode it
479
77
4805.7.1
785.7.1
481−-----
482−
483−* ModeDemo: added an explicit Control.Applicative import for older GHCs
79+ - ModeDemo: added an explicit Control.Applicative import for older
80+ GHCs
484
81
4855.7
825.7
486−---
487−
488−* Mouse and paste modes are now off by default.
83+ - Mouse and paste modes are now off by default.
489−* The Config type got new fields: mouseMode and bracketedPasteMode.
84+ - The Config type got new fields: mouseMode and bracketedPasteMode.
490− These determine whether these modes are enabled initially (for
85+ These determine whether these modes are enabled initially (for
491− terminals that support them).
86+ terminals that support them).
492−* Added a Mode type for modal terminal features (mouse events,
87+ - Added a Mode type for modal terminal features (mouse events,
493− bracketed paste mode) that is used with new Output interface
88+ bracketed paste mode) that is used with new Output interface
494− functions:
89+ functions:
495− * supportsMode :: Mode -> Bool tells whether the device supports a
90+ * supportsMode :: Mode -> Bool tells whether the device supports a
496− mode
91+ mode
497− * setMode :: Mode -> Bool -> IO () turns a mode on or off
92+ * setMode :: Mode -> Bool -> IO () turns a mode on or off
498− * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
93+ * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
499− off
94+ off
500−* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
95+ - Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
501
96
5025.6
975.6
503−---
504−
505−* Added support for normal and extended mouse modes in Xterm-like
98+ - Added support for normal and extended mouse modes in Xterm-like
506− terminals via the MouseDown and MouseUp Event constructors
99+ terminals via the MouseDown and MouseUp Event constructors
507−* Added support for bracketed paste mode in Xterm-like terminals via
100+ - Added support for bracketed paste mode in Xterm-like terminals via
508− the EvPaste event constructor
101+ the EvPaste event constructor
509−* Added derived Show instances for Event and Button (thanks Felix
102+ - Added derived Show instances for Event and Button (thanks Felix
510− Hirn)
103+ Hirn)
511−* Now TERM values containing "screen" will automatically use the
104+ - Now TERM values containing "screen" will automatically use the
512− XtermColor driver rather than just TerminfoBased
105+ XtermColor driver rather than just TerminfoBased
513
106
5145.5.0
1075.5.0
515−-----
516−
517−* Replaced lens dependency with microlens, microlens-mtl, microlens-th
108+ - Replaced lens dependency with microlens, microlens-mtl, microlens-th
518− dependencies. Issue #90
109+ dependencies. Issue #90
519− * Thanks Jonathan Daugherty
110+ - Thanks Jonathan Daugherty
520−* Cabal corrections.
111+ - Cabal corrections.
521− * Thanks Lennart Spitzner
112+ - Thanks Lennart Spitzner
522
113
5235.4.0
1145.4.0
524−-----
525−
526−* Changed eventChannel of Graphics.Vty.Input from Chan to
115+ - Changed eventChannel of Graphics.Vty.Input from Chan to TChan.
527− TChan. This enables clients to query if there are no pending
116+ This enables clients to query if there are no pending events. The
528− events. The Graphics.Vty interface nextEvent is unchanged.
117+ Graphics.Vty interface nextEvent is unchanged. Clients that use
529− Clients that use eventChannel directly will require updating.
118+ eventChannel directly will require updating.
530− https://github.com/coreyoconnor/vty/issues/60
119+ https://github.com/coreyoconnor/vty/issues/60
531−
5325.3.1
1205.3.1
533−-----
534−
535−* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to
121+ - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due
536− possibly breaking this on reasonable GHC versions
122+ to possibly breaking this on reasonable GHC versions
537
123
5385.3
1245.3
539−---
540−
541−* Upgraded QuickCheck dependency to 2.7
125+ - Upgraded QuickCheck dependency to 2.7
542−* The standard IO Config (standardIOConfig) was overriding any provided
126+ - The standard IO Config (standardIOConfig) was overriding any
543− application config. In addition, the inputFd and outputFd could not be
127+ provided application config. In addition, the inputFd and outputFd
544− changed if mkVty was used. Fixed.
128+ could not be changed if mkVty was used. Fixed.
545−* Correct handling of display attributes at end of line. The output
129+ - Correct handling of display attributes at end of line. The output
546− attributes are set to default at the end of content for the line and
130+ attributes are set to default at the end of content for the line and
547− at the start of a new line. Previously the current attribute would
131+ at the start of a new line. Previously the current attribute would
548− extend to the next start of content. This was odd to reason about and
132+ extend to the next start of content. This was odd to reason about
549− was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi
133+ and was the cause of https://github.com/coreyoconnor/vty/issues/76
550− requires the old behavior to display the selection region correctly.
134+ IIRC Yi requires the old behavior to display the selection region
135+ correctly.
551−* shutdown of the input thread is now performed using killThread and
136+ - shutdown of the input thread is now performed using killThread and
552− synchronization on an MVar. For correct handling of the terminal read
137+ synchronization on an MVar. For correct handling of the terminal
553− vmin and vtime the read must be a blocking read on an OS thread.
138+ read vmin and vtime the read must be a blocking read on an OS
554− This places a threadWaitRead, which will be interrupted by the
139+ thread. This places a threadWaitRead, which will be interrupted by
555− killThread, prior to the uninterruptable read. An alternative would be
140+ the killThread, prior to the uninterruptable read. An alternative
556− to re-import the read foreign call as interruptable.
141+ would be to re-import the read foreign call as interruptable.
557
142
5585.2.11
1435.2.11
559−------
560−
561−* deepseq bounds increased for tests.
144+ - deepseq bounds increased for tests.
562−* Clean up warnings when compiling on 7.10
145+ - Clean up warnings when compiling on 7.10
563− * Thanks Eric Mertens
146+ - Thanks Eric Mertens
564−* Avoid discarding input bytes after multi-byte encoded codepoint
147+ - Avoid discarding input bytes after multi-byte encoded codepoint
565− * Thanks Eric Mertens
148+ - Thanks Eric Mertens
566
149
5675.2.10
1505.2.10
568−------
569−
570−* "str" now returns EmptyImage for empty strings to match behavior of
151+ - "str" now returns EmptyImage for empty strings to match behavior of
571− other string-like Image constructors (fixes #74)
152+ other string-like Image constructors (fixes #74)
572− * Thanks Jonathan Daugherty
153+ - Thanks Jonathan Daugherty
573
154
5745.2.9
1555.2.9
575−-----
576−
577−* dependency version bumps
156+ - dependency version bumps
578− * https://github.com/coreyoconnor/vty/pull/71
157+ - https://github.com/coreyoconnor/vty/pull/71
579− * https://github.com/coreyoconnor/vty/pull/70
158+ - https://github.com/coreyoconnor/vty/pull/70
580−* Correct/Simplify the example code
159+ - Correct/Simplify the example code
581− * Thanks glguy
160+ - Thanks glguy
582− * https://github.com/coreyoconnor/vty/pull/69
161+ - https://github.com/coreyoconnor/vty/pull/69
583
162
5845.2.8
1635.2.8
585−-----
586−
587−* blaze-builder, lens, utf8-string version constraint bump
164+ - blaze-builder, lens, utf8-string version constraint bump
588− * Thanks glguy
165+ - Thanks glguy
589− * https://github.com/coreyoconnor/vty/pull/67
166+ - https://github.com/coreyoconnor/vty/pull/67
590−* Do not differentiate based on TERM_PROGRAM
167+ - Do not differentiate based on TERM_PROGRAM
591− * https://github.com/coreyoconnor/vty/issues/68
168+ - https://github.com/coreyoconnor/vty/issues/68
592
169
5935.2.7
1705.2.7
594−-----
595−
596−* lens and deepseq constraint bump + misc
171+ - lens and deepseq constraint bump + misc
597− * Thanks ethercrow
172+ - Thanks ethercrow
598− * https://github.com/coreyoconnor/vty/pull/66
173+ - https://github.com/coreyoconnor/vty/pull/66
599
174
6005.2.6
1755.2.6
601−-----
602−
603−* lens constraint bump
176+ - lens constraint bump
604− * Thanks alexander-b!
177+ - Thanks alexander-b!
605− * https://github.com/coreyoconnor/vty/pull/64
178+ - https://github.com/coreyoconnor/vty/pull/64
606
179
6075.2.5
1805.2.5
608−-----
609−
610−* lens and random version constraint bump.
181+ - lens and random version constraint bump.
611− * Thanks RyanGlScott!
182+ - Thanks RyanGlScott!
612− * https://github.com/coreyoconnor/vty/pull/62
183+ - https://github.com/coreyoconnor/vty/pull/62
613
184
6145.2.4
1855.2.4
615−-----
616−
617−* removed -fpic from cc-options. No longer required.
186+ - removed -fpic from cc-options. No longer required.
618− * https://github.com/coreyoconnor/vty/issues/61
187+ - https://github.com/coreyoconnor/vty/issues/61
619− * https://ghc.haskell.org/trac/ghc/ticket/9657
188+ - https://ghc.haskell.org/trac/ghc/ticket/9657
620− * Thanks Fuuzetsu!
189+ - Thanks Fuuzetsu!
621
190
6225.2.3
1915.2.3
623−-----
624−
625−* evaluate/compile the input parsing table once instead of each
192+ - evaluate/compile the input parsing table once instead of each
626− keystroke.
193+ keystroke.
627− * https://github.com/coreyoconnor/vty/pull/59
194+ - https://github.com/coreyoconnor/vty/pull/59
628− * Thanks ethercrow!
195+ - Thanks ethercrow!
629
196
6305.2.2
1975.2.2
631−-----
632−
633−* When looking at input for an event, don't look too deep.
198+ - When looking at input for an event, don't look too deep.
634− * https://github.com/coreyoconnor/vty/pull/57
199+ - https://github.com/coreyoconnor/vty/pull/57
635− * Thanks ethercrow!
200+ - Thanks ethercrow!
636
201
6375.2.1
2025.2.1
638−-----
639−
640−* Bump upper version bound for lens to 4.5. Thanks markus1189!
203+ - Bump upper version bound for lens to 4.5. Thanks markus1189!
641
204
6425.2.0
2055.2.0
643−-----
644−
645−* Config structure now specifies file descriptor to use. The default
206+ - Config structure now specifies file descriptor to use. The default
646− is stdInput and stdOutput file descriptors. Previously Vty used
207+ is stdInput and stdOutput file descriptors. Previously Vty used
647− stdInput for input and the follow code for output:
208+ stdInput for input and the follow code for output:
648− * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
209+ - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
649− NoBuffering)
210+ NoBuffering)
650− * the difference was required by Vty.Inline. Now, Vty.Inline uses
211+ - the difference was required by Vty.Inline. Now, Vty.Inline uses
651− the Config structure options to acheive the same effect.
212+ the Config structure options to acheive the same effect.
652−* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
213+ - removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
653− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
214+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
654−* added: inputForConfig, outputForConfig
215+ - added: inputForConfig, outputForConfig
655−* updates to vty-rogue from jtdaugherty. Thanks!
216+ - updates to vty-rogue from jtdaugherty. Thanks!
656−* the oldest version of GHC tested to support vty is 7.6.2.
217+ - the oldest version of GHC tested to support vty is 7.6.2.
657−* the oldest version of GHC that vty compiles under is 7.4.2
218+ - the oldest version of GHC that vty compiles under is 7.4.2
658
219
6595.1.4
2205.1.4
660−-----
661−
662−* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
221+ - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
663
222
6645.1.1
2235.1.1
665−-----
666−
667−* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
224+ - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
668−* jtdaugherty resolved a number of compiler warnings. Thanks!
225+ - jtdaugherty resolved a number of compiler warnings. Thanks!
669
226
6705.1.0
2275.1.0
671−-----
672−
673−* vmin and vtime can be specified however the application requires.
228+ - vmin and vtime can be specified however the application requires.
674− See Graphics.Vty.Config.
229+ See Graphics.Vty.Config.
675−* fixed the processing of input when vmin is set > 1.
230+ - fixed the processing of input when vmin is set > 1.
676
231
6775.0.0
2325.0.0
678−-----
679−
680−* The naming convention now matches:
233+ - The naming convention now matches:
681− * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
234+ - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
682−* all projects using vty for input must be compiled with -threaded.
235+ - all projects using vty for input must be compiled with -threaded.
683− Please notify vty author if this is not acceptable.
236+ Please notify vty author if this is not acceptable.
684−* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
237+ - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
685− vty with the default configuration.
238+ vty with the default configuration.
686−* input handling changes
239+ - input handling changes
687− * KASCII is now KChar
240+ - KASCII is now KChar
688− * KPN5 is now KCenter
241+ - KPN5 is now KCenter
689− * tests exist.
242+ - tests exist.
690− * Applications can add to the input tables by setting inputMap of
243+ - Applications can add to the input tables by setting inputMap of
691− the Config. See Graphics.Vty.Config
244+ the Config. See Graphics.Vty.Config
692− * Users can define input table extensions that will apply to all vty
245+ - Users can define input table extensions that will apply to all vty
693− applications. See Graphics.Vty.Config
246+ applications. See Graphics.Vty.Config
694− * terminal timing is now handled by selecting an appropriate VTIME.
247+ - terminal timing is now handled by selecting an appropriate VTIME.
695− Previously this was implemented within Vty itself. This reduced
248+ Previously this was implemented within Vty itself. This reduced
696− complexity in vty but provides a different meta key behavior and
249+ complexity in vty but provides a different meta key behavior and
697− implies a requirement on -threaded.
250+ implies a requirement on -threaded.
698− * The time vty will wait to verify an ESC byte means a single ESC
251+ - The time vty will wait to verify an ESC byte means a single ESC
699− key is the singleEscPeriod of the Input Config structure.
252+ key is the singleEscPeriod of the Input Config structure.
700−* removed the typeclass based terminal and display context interface
253+ - removed the typeclass based terminal and display context interface
701− in favor of a data structure of properties interface.
254+ in favor of a data structure of properties interface.
702−* renamed the Terminal interface to Output
255+ - renamed the Terminal interface to Output
703−* The default picture for an image now uses the "clear" background.
256+ - The default picture for an image now uses the "clear" background.
704− This background fills background spans with spaces or just ends the
257+ This background fills background spans with spaces or just ends the
705− line.
258+ line.
706− * Previously the background defaulted to the space character. This
259+ - Previously the background defaulted to the space character. This
707− causes issues copying text from a text editor. The text would end
260+ causes issues copying text from a text editor. The text would end
708− up with extra spaces at the end of the line.
261+ up with extra spaces at the end of the line.
709−* Layer support
262+ - Layer support
710− * Each layer is an image.
263+ - Each layer is an image.
711− * The layers for a picture are a list of images.
264+ - The layers for a picture are a list of images.
712− * The first image is the top-most layer. The images are ordered from
265+ - The first image is the top-most layer. The images are ordered from
713− top to bottom.
266+ top to bottom.
714− * The transparent areas for a layer are the backgroundFill areas.
267+ - The transparent areas for a layer are the backgroundFill areas.
715− backgroundFill is added to pad images when images of different
268+ backgroundFill is added to pad images when images of different
716− sizes are joined.
269+ sizes are joined.
717− * If the background is clear there is no background layer.
270+ - If the background is clear there is no background layer.
718− * If there is a background character then the bottom layer is the
271+ - If there is a background character then the bottom layer is the
719− background layer.
272+ background layer.
720− * emptyPicture is a Picture with no layers and no cursor
273+ - emptyPicture is a Picture with no layers and no cursor
721− * addToTop and addToBottom add a layer to the top and bottom of the
274+ - addToTop and addToBottom add a layer to the top and bottom of the
722− given Picture.
275+ given Picture.
723−* compatibility improvements:
276+ - compatibility improvements:
724− * terminfo based terminals with no cursor support are silently
277+ - terminfo based terminals with no cursor support are silently
725− accepted. The cursor visibility changes in the Picture will have
278+ accepted. The cursor visibility changes in the Picture will have
726− no effect.
279+ no effect.
727− * alternate (setf/setb) color maps supported. Though colors beyond
280+ - alternate (setf/setb) color maps supported. Though colors beyond
728− the first 8 are just a guess.
281+ the first 8 are just a guess.
729− * added "rgbColor" for easy support of RGB specified colors.
282+ - added "rgbColor" for easy support of RGB specified colors.
730− * Both applications and users can add to the mapping used to
283+ - Both applications and users can add to the mapping used to
731− translate from input bytes to events.
284+ translate from input bytes to events.
732−* Additional information about input and output process can be
285+ - Additional information about input and output process can be
733− appended to a debug log
286+ appended to a debug log
734− * Set environment variable VTY_DEBUG_LOG to path of debug log
287+ - Set environment variable VTY_DEBUG_LOG to path of debug log
735− * Or use "debugLog <path>" config directive
288+ - Or use "debugLog <path>" config directive
736− * Or set 'debugLog' property of the Config provided to mkVty.
289+ - Or set 'debugLog' property of the Config provided to mkVty.
737−* examples moved to vty-examples package. See test directory for cabal
290+ - examples moved to vty-examples package. See test directory for cabal
738− file.
291+ file.
739− * vty-interactive-terminal-test
292+ - vty-interactive-terminal-test
740− * interactive test. Useful for building a bug report for vty's
293+ - interactive test. Useful for building a bug report for vty's
741− author.
294+ author.
742− * test/interactive_terminal_test.hs
295+ - test/interactive_terminal_test.hs
743− * vty-event-echo
296+ - vty-event-echo
744− * view a input event log for vty. Example of interacting with
297+ - view a input event log for vty. Example of interacting with
745− user.
298+ user.
746− * test/EventEcho.hs
299+ - test/EventEcho.hs
747− * vty-rogue
300+ - vty-rogue
748− * The start of a rogue-like game. Example of layers and image
301+ - The start of a rogue-like game. Example of layers and image
749− build operations.
302+ build operations.
750− * test/Rogue.hs
303+ - test/Rogue.hs
751− * vty-benchmark
304+ - vty-benchmark
752− * benchmarks vty. A series of tests that push random pictures to
305+ - benchmarks vty. A series of tests that push random pictures to
753− the terminal. The random pictures are generated using
306+ the terminal. The random pictures are generated using
754− QuickCheck. The same generators used in the automated tests.
307+ QuickCheck. The same generators used in the automated tests.
755− * test/benchmark.hs
308+ - test/benchmark.hs
756
309
7574.7.0.0
3104.7.0.0
758−-------
311+ - API changes:
312+ - Added Graphics.Vty.Image.crop: Ensure an image is no larger
313+ than the specified size.
314+ - Added Graphics.Vty.Image.pad: Ensure an image is no smaller
315+ than the specified size.
316+ - Added Graphics.Vty.Image.translate: Offset an image.
317+ - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
759
318
760−API changes:
319+4.3.0.0
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.
767
320
7684.2.1.0
3214.2.1.0
769−-------
770−
771−API changes:
322+ - API changes:
772−* Attr record accessor fore_color changed to attr_fore_color
323+ - Attr record accessor fore_color changed to attr_fore_color
773−* Attr record accessor back_color changed to attr_back_color
324+ - Attr record accessor back_color changed to attr_back_color
774−* Attr record accessor style changed to attr_style
325+ - Attr record accessor style changed to attr_style
775−* Added an "inline" display attribute changing DSL:
326+ - Added an "inline" display attribute changing DSL:
776− * put_attr_change applies a display attribute change
327+ - put_attr_change applies a display attribute change
777− immediately to a terminal
328+ immediately to a terminal
778− * For instance, can be used to change the display attrbiutes
329+ - For instance, can be used to change the display attrbiutes
779− of text output via putStrLn and putStr. EX:
330+ of text output via putStrLn and putStr. EX:
780− "put_attr_change $ back_color red" will set the background
331+ "put_attr_change $ back_color red" will set the background
781− color to red.
332+ color to red.
782− * Changes do not apply to a Picture output via output_picture.
333+ - Changes do not apply to a Picture output via output_picture.
783− * See Graphics.Vty.Inline
334+ - See Graphics.Vty.Inline
784−* Moved all IO actions into any monad an instance of MonadIO
335+ - Moved all IO actions into any monad an instance of MonadIO
785
336
7864.0.0.1
3374.0.0.1
787−-------
788−
789−* binding for mk_wcswidth was incorrect. Most platforms just
338+ - binding for mk_wcswidth was incorrect. Most platforms just
790− magically worked due to coincidence.
339+ magically worked due to coincidence.
791
340
7924.0.0
3414.0.0
793−-----
794−
795−API changes:
342+ - API changes:
796−* "getSize" has been removed. Use "terminal vty >>= display_bounds"
343+ - "getSize" has been removed. Use "terminal vty >>= display_bounds"
797− where "vty" is an instance of the Vty data structure.
344+ where "vty" is an instance of the Vty data structure.
798−* added a "terminal" field to the Vty data structure. Accesses the
345+ - added a "terminal" field to the Vty data structure. Accesses the
799− TerminalHandle associated with the Vty instance.
346+ TerminalHandle associated with the Vty instance.
800−* Graphics.Vty.Types has undergone a number of changes. Summary:
347+ - Graphics.Vty.Types has undergone a number of changes. Summary:
801− * Partitioned into Graphics.Vty.Attributes for display attributes.
348+ - Partitioned into Graphics.Vty.Attributes for display attributes.
802− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
349+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
803− for final picture construction.
350+ for final picture construction.
804−* Graphics.Vty.Attributes:
351+ - Graphics.Vty.Attributes:
805− * "setFG" and "setBG" are now "with_fore_color" and
352+ - "setFG" and "setBG" are now "with_fore_color" and
806− "with_back_color"
353+ "with_back_color"
807− * All other "set.." equations similarly replaced.
354+ - All other "set.." equations similarly replaced.
808− * "attr" is now "def_attr", short for "default display attributes"
355+ - "attr" is now "def_attr", short for "default display attributes"
809− Also added a "current_attr" for "currently applied display
356+ Also added a "current_attr" for "currently applied display
810− attributes"
357+ attributes"
811−* Graphics.Vty.Image:
358+ - Graphics.Vty.Image:
812− * "horzcat" is now "horiz_cat"
359+ - "horzcat" is now "horiz_cat"
813− * "vertcat" is now "vert_cat"
360+ - "vertcat" is now "vert_cat"
814− * "renderBS" is now "utf8_bytestring"
361+ - "renderBS" is now "utf8_bytestring"
815− * "renderChar" is now "char"
362+ - "renderChar" is now "char"
816− * "renderFill" is now "char_fill"
363+ - "renderFill" is now "char_fill"
817− * added a "utf8_string" and "string" (AKA "iso_10464_string") for
364+ - added a "utf8_string" and "string" (AKA "iso_10464_string") for
818− UTF-8 encoded Strings and ISO-10464 encoded Strings. String
365+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String
819− literals in GHC have an ISO-10464 runtime representation.
366+ literals in GHC have an ISO-10464 runtime representation.
820−* Graphics.Vty.Picture:
367+ - Graphics.Vty.Picture:
821− * exports Graphics.Vty.Image
368+ - exports Graphics.Vty.Image
822− * "pic" is now "pic_for_image"
369+ - "pic" is now "pic_for_image"
823− * added API for setting background fill pattern.
370+ - added API for setting background fill pattern.
824−* Completely rewritten output backend.
371+ - Completely rewritten output backend.
825− * Efficient, scanline style output span generator. Has not been
372+ - Efficient, scanline style output span generator. Has not been
826− fully optimized, but good enough.
373+ fully optimized, but good enough.
827− * The details required to display the desired picture on a
374+ - The details required to display the desired picture on a
828− terminal are well encapsulated.
375+ terminal are well encapsulated.
829− * Terminfo based display terminal implementation. With specialized
376+ - Terminfo based display terminal implementation. With specialized
830− derivitives for xterm, Terminal.app, and iTerm.app.
377+ derivitives for xterm, Terminal.app, and iTerm.app.
831− * Attempts to robustly handle even terminals that don't
378+ - Attempts to robustly handle even terminals that don't
832− support all display attributes.
379+ support all display attributes.
833− * I've tested the following terminals with success: iTerm.app,
380+ - I've tested the following terminals with success: iTerm.app,
834− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
381+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
835− konsole, screen, linux vty. Hopefully you will be as
382+ konsole, screen, linux vty. Hopefully you will be as
836− successfull.
383+ successfull.
837− * Improved unicode support. Double wide characters will display as
384+ - Improved unicode support. Double wide characters will display as
838− expected.
385+ expected.
839−* 256 color support. See Graphics.Vty.Attributes.Color240. The actual
386+ - 256 color support. See Graphics.Vty.Attributes.Color240. The actual
840− output color is adjusted according to the number of colors the
387+ output color is adjusted according to the number of colors the
841− terminal supports.
388+ terminal supports.
842−* The Graphics.Vty.Image combinators no longer require matching
389+ - The Graphics.Vty.Image combinators no longer require matching
843− dimensions to arguments. Unspecified areas are filled in with a
390+ dimensions to arguments. Unspecified areas are filled in with a
844− user-customizable background pattern. See Graphics.Vty.Picture.
391+ user-customizable background pattern. See Graphics.Vty.Picture.
845−* output images are always cropped to display size.
392+ - output images are always cropped to display size.
846−* Significant code coverage by QuickCheck tests. An interactive test
393+ - Significant code coverage by QuickCheck tests. An interactive test
847− for those final properties that couldn't be automatically verified.
394+ for those final properties that couldn't be automatically verified.
848
395
849Issues resolved:
396Issues resolved:
850−* "gnome terminal displays non-basic attributes as strikethrough"
397+ - "gnome terminal displays non-basic attributes as strikethrough"
851− * http://trac.haskell.org/vty/ticket/14
398+ - http://trac.haskell.org/vty/ticket/14
852−* "Multi-byte characters are not displayed correctly on update"
399+ - "Multi-byte characters are not displayed correctly on update"
853− * http://trac.haskell.org/vty/ticket/10
400+ - http://trac.haskell.org/vty/ticket/10
854−* "Redraw does not handle rendering a line that extends beyond screen
401+ - "Redraw does not handle rendering a line that extends beyond screen
855− width characters"
402+ width characters"
856− * http://trac.haskell.org/vty/ticket/13
403+ - http://trac.haskell.org/vty/ticket/13
857−* "The <|> and <-> combinators should be more forgiving of mismatched
404+ - "The <|> and <-> combinators should be more forgiving of mismatched
858− dimensions"
405+ dimensions"
859− * http://trac.haskell.org/vty/ticket/9
406+ - http://trac.haskell.org/vty/ticket/9
860−* "256-color support"
407+ - "256-color support"
861− * http://trac.haskell.org/vty/ticket/19
408+ - http://trac.haskell.org/vty/ticket/19
LICENSE−2
@@ -1,5 +1,3 @@
1−BSD 3-Clause License
2−
3Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
1Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
4
2
5All rights reserved.
3All rights reserved.
README.md+58−137
@@ -1,13 +1,12 @@
1[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty)
1[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty)
2
2
3`vty` is a terminal interface library. It provides a high-level
3`vty` is a terminal interface library. It provides a high-level
4−interface for doing terminal I/O. Vty is supported on GHC versions
4+interface for doing terminal I/O.
5−7.10.1 and up.
6
5
7Install via `git` with:
6Install via `git` with:
8
7
9```
8```
10−git clone git://github.com/jtdaugherty/vty.git
9+git clone git://github.com/coreyoconnor/vty.git
11```
10```
12
11
13Install via `cabal` with:
12Install via `cabal` with:
@@ -18,21 +17,24 @@ cabal install vty
18
17
19# Features
18# Features
20
19
21−* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,
20+* Supports a large number of terminals. vt100, ansi, hurd, linux,
22− `screen`, etc., or anything with a sufficient terminfo entry.
21+ screen, etc., or anything with a sufficient terminfo entry.
23
22
24−* Automatically handles window resizes.
23+* Automatic handling of window resizes.
25
24
26−* Supports Unicode output on terminals with UTF-8 support.
25+* Unicode output on terminals with UTF-8 support.
27
26
27+* Handles multi-column glyphs. (Requires user to properly configure
28+ terminal.)
29+
28−* Provides an efficient output algorithm. Output buffering and terminal
30+* Efficient output. Output buffering and terminal state changes are
29− state changes are minimized.
31+ minimized.
30
32
31* Minimizes repaint area, which virtually eliminates the flicker
33* Minimizes repaint area, which virtually eliminates the flicker
32 problems that plague ncurses programs.
34 problems that plague ncurses programs.
33
35
34−* Provides a pure, compositional interface for efficiently constructing
36+* A pure, compositional interface for efficiently constructing display
35− display images.
37+ images.
36
38
37* Automatically decodes keyboard keys into (key,[modifier]) tuples.
39* Automatically decodes keyboard keys into (key,[modifier]) tuples.
38
40
@@ -41,7 +43,7 @@ cabal install vty
41* Supports a keypress timeout after for lone ESC. The timeout is
43* Supports a keypress timeout after for lone ESC. The timeout is
42 customizable.
44 customizable.
43
45
44−* Provides extensible input and output interfaces.
46+* The interface is designed for easy extension.
45
47
46* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
48* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
47 with a type-safe interface and graceful fallback for terminals
49 with a type-safe interface and graceful fallback for terminals
@@ -51,151 +53,70 @@ cabal install vty
51
53
52* Provides a comprehensive test suite.
54* Provides a comprehensive test suite.
53
55
56+# Known Issues
57+
58+* Terminals have numerous quirks and bugs. Vty picks what works best for
59+ the author in ambiguous or buggy situations.
60+
61+* Signal handling of STOP, TERM and INT are nonexistent.
62+
63+* The character encoding of the terminal is assumed to be UTF-8 if
64+ unicode is used.
65+
66+* Terminfo is assumed to be correct unless there is an override
67+ configured. Some terminals will not have correct special key support
68+ (shifted F10 etc). See `Config` for customizing vty's behavior for a
69+ particular terminal.
70+
71+* Uses the `TIOCGWINSZ` ioctl to find the current window size, which
72+ appears to be limited to Linux and BSD.
73+
54* Supports "normal" and "extended" (SGR) mouse modes as described at
74* Supports "normal" and "extended" (SGR) mouse modes as described at
55 http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
75 http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
56
76
57* Supports bracketed paste mode as described at
77* Supports bracketed paste mode as described at
58 http://cirw.in/blog/bracketed-paste
78 http://cirw.in/blog/bracketed-paste
59
79
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−
71# Platform Support
80# Platform Support
72
81
73## Posix Terminals
82## Posix Terminals
74
83
75−For the most part, Vty uses `terminfo` to determine terminal protocol
84+Uses terminfo to determine terminal protocol. With some special rules to
76−with some special rules to handle some omissions from `terminfo`.
85+handle some omissions from terminfo.
77
86
78## Windows
87## Windows
79
88
80−Windows is not supported.
89+Unsupported (but contributions and testing here are very welcome!)
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
90
125−```
91+# Development Notes
126−widthMap "xterm" "/path/to/map.dat"
127−```
128
92
129−where the first argument is the value that `TERM` must have in order for
93+## Under NixOS
130−the table to be loaded, and the second argument is the path to the table
131−file itself as generated by the two alternatives listed above. If the
132−Vty configuration file contains multiple matching `widthMap` directives
133−for the current value of `TERM`, the last one listed in the file is
134−used.
135−
136−The tables declared in the configuration file are only ever
137−automatically loaded when applications set up Vty by calling
138−`Graphics.Vty.mkVty`.
139−
140−Before a custom table has been loaded, calls to the library's character
141−width functions (e.g. `wcwidth`) will use the default built-in table.
142−Once a custom table has been loaded, the functions will use the new
143−custom table. Only one custom table load can be performed in a Vty
144−program. Once a custom table has been loaded, it cannot be replaced or
145−removed.
146−
147−Without using a custom width table, users of Vty-based applications
148−are likely to eventually experience rendering problems with with wide
149−characters. We recommend that developers of Vty-based applications either:
150−
151−* Provide the `vty-build-width-table` tool and documentation for running
152− it and updating the Vty configuration, or
153−* Have the application invoke the Vty library's table-building
154− functionality and load the table at startup without using the Vty
155− configuration.
156−
157−The best option will depend on a number of factors: the user audience,
158−the amount of risk posed by wide character rendering, the terminal
159−emulators in use, etc.
160−
161−# Contributing
162−
163−If you decide to contribute, that's great! Here are some guidelines you
164−should consider to make submitting patches easier for all concerned:
165−
166− - If you want to take on big things, talk to me first; let's have a
167− design/vision discussion before you start coding. Create a GitHub
168− issue and we can use that as the place to hash things out.
169− - If you make changes, make them consistent with the syntactic
170− conventions already used in the codebase.
171− - Please provide Haddock documentation for any changes you make.
172
94
173−# Known Issues
95+### Using cabal
174
96
175−* Terminals have numerous quirks and bugs, so mileage may vary. Please
97+After installing `ncurses` to the user environment:
176− report issues as you encounter them and provide details on your
177− terminal emulator, operating system, etc.
178
98
179−* STOP, TERM and INT signals are not handled.
99+~~~
100+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib
101+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build
102+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test
103+~~~
180
104
181−* The character encoding of the terminal is assumed to be UTF-8 if
105+## Code Coverage
182− unicode is used.
183
106
184−* Terminfo is assumed to be correct unless there is an override
107+As of last testing, profiling causes issues with coverage when enabled.
185− configured. Some terminals will not have correct special key support
108+To evaluate coverage, configure as follows:
186− (shifted F10 etc). See `Config` for customizing vty's behavior for a
187− particular terminal.
188−
189−* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which
190− appears to be limited to Linux and BSD.
191
109
192−# Further Reading
110+~~~
111+rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \
112+ --disable-library-profiling \
113+ --disable-executable-profiling
114+~~~
193
115
194−Good sources of documentation for terminal programming are:
116+## Profiling
195
117
196−* https://github.com/b4winckler/vim/blob/master/src/term.c
118+~~~
197−* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
119+rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
198−* http://ulisse.elettra.trieste.it/services/doc/serial/config.html
120+ --enable-library-profiling \
199−* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html
121+ --enable-executable-profiling
200−* http://www.unixwiz.net/techtips/termios-vmin-vtime.html
122+~~~
201−* http://vt100.net/docs/vt100-ug/chapter3.html
cbits/get_tty_erase.cdeleted−18
@@ -1,18 +0,0 @@
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+5−14
@@ -1,18 +1,9 @@
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− }
18}
9}
cbits/gwinsz.h+1−2
@@ -1,2 +1 @@
1−unsigned long vty_c_get_window_size(int fd);
1+unsigned long vty_c_get_window_size(void);
2−unsigned long vty_c_set_window_size(int fd, unsigned long val);
cbits/mk_wcwidth.c+2−136
@@ -60,28 +60,6 @@
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;
85
63
86struct interval {
64struct interval {
87 int first;
65 int first;
@@ -141,7 +119,7 @@ static int vty_bisearch(HsChar ucs, const struct interval *table, int max) {
141 * in ISO 10646.
119 * in ISO 10646.
142 */
120 */
143
121
144−static HsInt builtin_wcwidth(HsChar ucs)
122+HsInt vty_mk_wcwidth(HsChar ucs)
145{
123{
146 /* sorted list of non-overlapping intervals of non-spacing characters */
124 /* sorted list of non-overlapping intervals of non-spacing characters */
147 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
125 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
@@ -204,7 +182,7 @@ static HsInt builtin_wcwidth(HsChar ucs)
204
182
205 /* binary search in table of non-spacing characters */
183 /* binary search in table of non-spacing characters */
206 if (vty_bisearch(ucs, combining,
184 if (vty_bisearch(ucs, combining,
207− sizeof(combining) / sizeof(struct interval) - 1))
185+ sizeof(combining) / sizeof(struct interval) - 1))
208 return 0;
186 return 0;
209
187
210 /* if we arrive here, ucs is not a combining or C0/C1 control character */
188 /* if we arrive here, ucs is not a combining or C0/C1 control character */
@@ -224,115 +202,3 @@ static HsInt builtin_wcwidth(HsChar ucs)
224 (ucs >= 0x20000 && ucs <= 0x2fffd) ||
202 (ucs >= 0x20000 && ucs <= 0x2fffd) ||
225 (ucs >= 0x30000 && ucs <= 0x3fffd)));
203 (ucs >= 0x30000 && ucs <= 0x3fffd)));
226}
204}
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+7−14
@@ -7,6 +7,7 @@ import Control.Applicative hiding ((<|>))
7import Control.Arrow
7import Control.Arrow
8import Control.Monad.RWS
8import Control.Monad.RWS
9
9
10+import Data.Default (def)
10import Data.Sequence (Seq, (<|) )
11import Data.Sequence (Seq, (<|) )
11import qualified Data.Sequence as Seq
12import qualified Data.Sequence as Seq
12import Data.Foldable
13import Data.Foldable
@@ -17,8 +18,8 @@ type App = RWST Vty () (Seq String) IO
17
18
18main = do
19main = do
19 vty <- if True -- change to false for emacs-like input processing
20 vty <- if True -- change to false for emacs-like input processing
20− then mkVty defaultConfig
21+ then mkVty def
21− else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )
22+ else mkVty (def { vmin = Just 2, vtime = Just 300 } )
22 _ <- execRWST (vtyInteract False) vty Seq.empty
23 _ <- execRWST (vtyInteract False) vty Seq.empty
23 shutdown vty
24 shutdown vty
24
25
@@ -31,8 +32,7 @@ introText = vertCat $ map (string defAttr)
31 [ "this line is hidden by the top layer"
32 [ "this line is hidden by the top layer"
32 , "The vty demo program will echo the events generated by the pressed keys."
33 , "The vty demo program will echo the events generated by the pressed keys."
33 , "Below there is a 240 color box."
34 , "Below there is a 240 color box."
34− , "Followed by a description of the 16 color palette."
35+ , "Followed by a description of the 16 color pallete."
35− , "Followed by tones of red using a 24-bit palette."
36 , "If the 240 color box is not visible then the terminal"
36 , "If the 240 color box is not visible then the terminal"
37 , "claims 240 colors are not supported."
37 , "claims 240 colors are not supported."
38 , "Try setting TERM to xterm-256color"
38 , "Try setting TERM to xterm-256color"
@@ -43,19 +43,12 @@ introText = vertCat $ map (string defAttr)
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
44 ]
44 ]
45
45
46−splitColorImages :: [Image] -> [[Image]]
47−splitColorImages [] = []
48−splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
49−
50−fullcolorbox :: Image
51−fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages
52− where
53− colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255]
54−
55colorbox_240 :: Image
46colorbox_240 :: Image
56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
47colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
57 where
48 where
58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
49 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
50+ splitColorImages [] = []
51+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
59
52
60colorbox_16 :: Image
53colorbox_16 :: Image
61colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
54colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
@@ -78,7 +71,7 @@ updateDisplay = do
78 "Press ESC to exit. Events for keys below."
71 "Press ESC to exit. Events for keys below."
79 eventLog <- foldMap (string defAttr) <$> get
72 eventLog <- foldMap (string defAttr) <$> get
80 let pic = picForImage (info <-> eventLog)
73 let pic = picForImage (info <-> eventLog)
81− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
74+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
82 vty <- ask
75 vty <- ask
83 liftIO $ update vty pic
76 liftIO $ update vty pic
84
77
demos/ModeDemo.hs−2
@@ -2,8 +2,6 @@ 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(..))
7
5
8import Graphics.Vty
6import Graphics.Vty
9
7
src/Codec/Binary/UTF8/Debug.hs+2−1
@@ -14,4 +14,5 @@ utf8FromIso :: [Int] -> [Word8]
14utf8FromIso = encode . map toEnum
14utf8FromIso = encode . map toEnum
15
15
16ppUtf8 :: [Int] -> IO ()
16ppUtf8 :: [Int] -> IO ()
17−ppUtf8 = print . map (`showHex` "") . utf8FromIso
17+ppUtf8 = print . map (\f -> f "") . 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 = rnf' . viewl
10+ rnf = \v -> rnf' (viewl v)
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+12−3
@@ -1,8 +1,13 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# OPTIONS_GHC -funbox-strict-fields #-}
4{-# OPTIONS_GHC -funbox-strict-fields #-}
4{-# OPTIONS_HADDOCK hide #-}
5{-# OPTIONS_HADDOCK hide #-}
5
6
7+#ifndef MIN_VERSION_base
8+#defined MIN_VERSION_base(x,y,z) 1
9+#endif
10+
6-- | Evaluates the paramaterized terminfo string capability with the
11-- | Evaluates the paramaterized terminfo string capability with the
7-- given parameters.
12-- given parameters.
8module Data.Terminfo.Eval
13module Data.Terminfo.Eval
@@ -23,6 +28,10 @@ import Data.List
23
28
24import qualified Data.Vector.Unboxed as Vector
29import qualified Data.Vector.Unboxed as Vector
25
30
31+#if !(MIN_VERSION_base(4,8,0))
32+import Data.Word
33+#endif
34+
26-- | capability evaluator state
35-- | capability evaluator state
27data EvalState = EvalState
36data EvalState = EvalState
28 { evalStack :: ![CapParam]
37 { evalStack :: ![CapParam]
@@ -42,7 +51,7 @@ pop = do
42
51
43readParam :: Word -> Eval CapParam
52readParam :: Word -> Eval CapParam
44readParam pn = do
53readParam pn = do
45− !params <- evalParams <$> get
54+ !params <- get >>= return . evalParams
46 return $! genericIndex params pn
55 return $! genericIndex params pn
47
56
48push :: CapParam -> Eval ()
57push :: CapParam -> Eval ()
@@ -64,11 +73,11 @@ writeCapExpr cap params =
64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
73 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
65
74
66writeCapOps :: CapOps -> Eval ()
75writeCapOps :: CapOps -> Eval ()
67−writeCapOps = mapM_ writeCapOp
76+writeCapOps ops = mapM_ writeCapOp ops
68
77
69writeCapOp :: CapOp -> Eval ()
78writeCapOp :: CapOp -> Eval ()
70writeCapOp (Bytes !offset !count) = do
79writeCapOp (Bytes !offset !count) = do
71− !cap <- evalExpression <$> get
80+ !cap <- get >>= return . evalExpression
72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
81 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
73 Vector.forM_ bytes $ tell.writeWord8
82 Vector.forM_ bytes $ tell.writeWord8
74writeCapOp DecOut = do
83writeCapOp DecOut = do
src/Data/Terminfo/Parse.hs+24−22
@@ -1,9 +1,13 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# OPTIONS_HADDOCK hide #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE NamedFieldPuns #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6−{-# OPTIONS_HADDOCK hide #-}
7+
8+#ifndef MIN_VERSION_base
9+#defined MIN_VERSION_base(x,y,z) 1
10+#endif
7
11
8module Data.Terminfo.Parse
12module Data.Terminfo.Parse
9 ( module Data.Terminfo.Parse
13 ( module Data.Terminfo.Parse
@@ -14,9 +18,6 @@ where
14import Control.Monad ( liftM )
18import Control.Monad ( liftM )
15import Control.DeepSeq
19import Control.DeepSeq
16
20
17−#if !(MIN_VERSION_base(4,11,0))
18−import Data.Semigroup (Semigroup(..))
19−#endif
20import Data.Word
21import Data.Word
21import qualified Data.Vector.Unboxed as Vector
22import qualified Data.Vector.Unboxed as Vector
22
23
@@ -24,6 +25,10 @@ import Numeric (showHex)
24
25
25import Text.Parsec
26import Text.Parsec
26
27
28+#if !(MIN_VERSION_base(4,8,0))
29+import Data.Monoid
30+#endif
31+
27data CapExpression = CapExpression
32data CapExpression = CapExpression
28 { capOps :: !CapOps
33 { capOps :: !CapOps
29 , capBytes :: !(Vector.Vector Word8)
34 , capBytes :: !(Vector.Vector Word8)
@@ -39,7 +44,7 @@ instance Show CapExpression where
39 ++ " <= " ++ show (sourceString c)
44 ++ " <= " ++ show (sourceString c)
40 where
45 where
41 hexDump :: [Word8] -> String
46 hexDump :: [Word8] -> String
42− hexDump = foldr showHex ""
47+ hexDump = foldr (\b s -> showHex b s) ""
43
48
44instance NFData CapExpression where
49instance NFData CapExpression where
45 rnf (CapExpression ops !_bytes !str !c !pOps)
50 rnf (CapExpression ops !_bytes !str !c !pOps)
@@ -99,12 +104,14 @@ parseCapExpression capString =
99 Left e -> Left e
104 Left e -> Left e
100 Right buildResults -> Right $ constructCapExpression capString buildResults
105 Right buildResults -> Right $ constructCapExpression capString buildResults
101
106
102−constructCapExpression :: String -> BuildResults -> CapExpression
107+constructCapExpression :: [Char] -> BuildResults -> CapExpression
103constructCapExpression capString buildResults =
108constructCapExpression capString buildResults =
104 let expr = CapExpression
109 let expr = CapExpression
105 { capOps = outCapOps buildResults
110 { capOps = outCapOps buildResults
106 -- The cap bytes are the lower 8 bits of the input
111 -- The cap bytes are the lower 8 bits of the input
107 -- string's characters.
112 -- string's characters.
113+ -- \todo Verify the input string actually contains an
114+ -- 8bit byte per character.
108 , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
115 , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
109 , sourceString = capString
116 , sourceString = capString
110 , paramCount = outParamCount buildResults
117 , paramCount = outParamCount buildResults
@@ -128,7 +135,7 @@ paramEscapeParser = do
128literalPercentParser :: CapParser BuildResults
135literalPercentParser :: CapParser BuildResults
129literalPercentParser = do
136literalPercentParser = do
130 _ <- char '%'
137 _ <- char '%'
131− startOffset <- nextOffset <$> getState
138+ startOffset <- getState >>= return . nextOffset
132 incOffset 1
139 incOffset 1
133 return $ BuildResults 0 [Bytes startOffset 1] []
140 return $ BuildResults 0 [Bytes startOffset 1] []
134
141
@@ -154,7 +161,7 @@ incrementOpParser = do
154pushOpParser :: CapParser BuildResults
161pushOpParser :: CapParser BuildResults
155pushOpParser = do
162pushOpParser = do
156 _ <- char 'p'
163 _ <- char 'p'
157− paramN <- read . pure <$> digit
164+ paramN <- digit >>= return . (\d -> read [d])
158 incOffset 2
165 incOffset 2
159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
166 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
160
167
@@ -299,7 +306,7 @@ compareOpParser
299bytesOpParser :: CapParser BuildResults
306bytesOpParser :: CapParser BuildResults
300bytesOpParser = do
307bytesOpParser = do
301 bytes <- many1 $ satisfy (/= '%')
308 bytes <- many1 $ satisfy (/= '%')
302− startOffset <- nextOffset <$> getState
309+ startOffset <- getState >>= return . nextOffset
303 let !c = length bytes
310 let !c = length bytes
304 !s <- getState
311 !s <- getState
305 let s' = s { nextOffset = startOffset + c }
312 let s' = s { nextOffset = startOffset + c }
@@ -333,16 +340,11 @@ data BuildResults = BuildResults
333 , outParamOps :: !ParamOps
340 , outParamOps :: !ParamOps
334 }
341 }
335
342
336−instance Semigroup BuildResults where
337− v0 <> v1
338− = BuildResults
339− { outParamCount = outParamCount v0 `max` outParamCount v1
340− , outCapOps = outCapOps v0 <> outCapOps v1
341− , outParamOps = outParamOps v0 <> outParamOps v1
342− }
343−
344instance Monoid BuildResults where
343instance Monoid BuildResults where
345 mempty = BuildResults 0 [] []
344 mempty = BuildResults 0 [] []
346−#if !(MIN_VERSION_base(4,11,0))
345+ v0 `mappend` v1
347− mappend = (<>)
346+ = BuildResults
348−#endif
347+ { outParamCount = (outParamCount v0) `max` (outParamCount v1)
348+ , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
349+ , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
350+ }
src/Graphics/Text/Width.hs+11−42
@@ -1,64 +1,33 @@
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@.
13module Graphics.Text.Width
4module Graphics.Text.Width
14 ( wcwidth
5 ( wcwidth
15 , wcswidth
6 , wcswidth
16− , wctwidth
17− , wctlwidth
18 , safeWcwidth
7 , safeWcwidth
19 , safeWcswidth
8 , safeWcswidth
20− , safeWctwidth
21− , safeWctlwidth
22 )
9 )
23where
10where
24
11
25−import Data.List (foldl')
26−import qualified Data.Text as T
27−import qualified Data.Text.Lazy as TL
28−
29foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
12foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
30
13
31wcswidth :: String -> Int
14wcswidth :: String -> Int
32−wcswidth = foldl' (\l c -> wcwidth c + l) 0
15+wcswidth = sum . map wcwidth
33−{-# INLINE [1] wcswidth #-}
34−
35−wctwidth :: T.Text -> Int
36−wctwidth = T.foldl' (\l c -> wcwidth c + l) 0
37−
38−wctlwidth :: TL.Text -> Int
39−wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0
40
16
41−{-# RULES
17+-- XXX: Characters with unknown widths occupy 1 column?
42−"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x
18+--
43−"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x
19+-- Not sure if this is actually correct. I presume there is a
44− #-}
20+-- replacement character that is output by the terminal instead of the
21+-- character and this replacement character is 1 column wide. If this is
22+-- not true for all terminals then a per-terminal replacement character
23+-- width needs to be implemented.
45
24
46-- | Returns the display width of a character. Assumes all characters
25-- | Returns the display width of a character. Assumes all characters
47−-- with unknown widths are 0 width.
26+-- with unknown widths are 0 width
48safeWcwidth :: Char -> Int
27safeWcwidth :: Char -> Int
49safeWcwidth = max 0 . wcwidth
28safeWcwidth = max 0 . wcwidth
50
29
51-- | Returns the display width of a string. Assumes all characters with
30-- | Returns the display width of a string. Assumes all characters with
52−-- unknown widths are 0 width.
31+-- unknown widths are 0 width
53safeWcswidth :: String -> Int
32safeWcswidth :: String -> Int
54−safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0
33+safeWcswidth = sum . map safeWcwidth
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+98−170
@@ -1,20 +1,21 @@
1−{-# LANGUAGE CPP #-}
1+-- | Vty supports input and output to terminal devices.
2−{-# LANGUAGE ScopedTypeVariables #-}
2+--
3−
3+-- - Input to the terminal is provided to the app as a sequence of
4−-- | Vty provides interfaces for both terminal input and terminal
4+-- 'Event's.
5−-- output.
5+--
6+-- - The output is defined by a 'Picture'. Which is one or more layers
7+-- of 'Image's.
8+--
9+-- - The module "Graphics.Vty.Image" provides a number of
10+-- constructor equations that will build correct 'Image' values.
11+-- See 'string', '<|>', and '<->' for starters.
6--
12--
7−-- - Input to the terminal is provided to the Vty application as a
13+-- - The constructors in "Graphics.Vty.Image.Internal" should not
8−-- sequence of 'Event's.
14+-- be used.
9--
15--
10−-- - Output is provided to Vty by the application in the form of a
11−-- 'Picture'. A 'Picture' is one or more layers of 'Image's.
12−-- 'Image' values can be built by the various constructors in
13−-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
14−-- values in the "Graphics.Vty.Attributes" module.
16+-- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
15--
17--
16−-- Vty uses threads internally, so programs made with Vty need to be
18+-- See the vty-examples package for a number of examples.
17−-- compiled with the threaded runtime using the GHC @-threaded@ option.
18--
19--
19-- @
20-- @
20-- import "Graphics.Vty"
21-- import "Graphics.Vty"
@@ -22,8 +23,10 @@
22-- main = do
23-- main = do
23-- cfg <- 'standardIOConfig'
24-- cfg <- 'standardIOConfig'
24-- vty <- 'mkVty' cfg
25-- vty <- 'mkVty' cfg
25−-- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\"
26+-- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green')
27+-- \"first line\"
26−-- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\"
28+-- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue')
29+-- \"second line\"
27-- img = line0 '<->' line1
30-- img = line0 '<->' line1
28-- pic = 'picForImage' img
31-- pic = 'picForImage' img
29-- 'update' vty pic
32-- 'update' vty pic
@@ -31,153 +34,109 @@
31-- 'shutdown' vty
34-- 'shutdown' vty
32-- 'print' (\"Last event was: \" '++' 'show' e)
35-- 'print' (\"Last event was: \" '++' 'show' e)
33-- @
36-- @
37+--
38+-- Good sources of documentation for terminal programming are:
39+--
40+-- - <https://github.com/b4winckler/vim/blob/master/src/term.c>
41+--
42+-- - <http://invisible-island.net/xterm/ctlseqs/ctlseqs.html>
43+--
44+-- - <http://ulisse.elettra.trieste.it/services/doc/serial/config.html>
45+--
46+-- - <http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html>
47+--
48+-- - <http://www.unixwiz.net/techtips/termios-vmin-vtime.html>
49+--
50+-- - <http://vt100.net/docs/vt100-ug/chapter3.html vt100 control sequences>
34module Graphics.Vty
51module Graphics.Vty
35 ( Vty(..)
52 ( Vty(..)
36 , mkVty
53 , mkVty
37− , setWindowTitle
38− , Mode(..)
39 , module Graphics.Vty.Config
54 , module Graphics.Vty.Config
40 , module Graphics.Vty.Input
55 , module Graphics.Vty.Input
41 , module Graphics.Vty.Output
56 , module Graphics.Vty.Output
42− , module Graphics.Vty.Output.Interface
43 , module Graphics.Vty.Picture
57 , module Graphics.Vty.Picture
44− , module Graphics.Vty.Image
58+ , DisplayRegion
45− , module Graphics.Vty.Attributes
59+ , Mode(..)
46 )
60 )
47where
61where
48
62
63+import Graphics.Vty.Prelude
64+
49import Graphics.Vty.Config
65import Graphics.Vty.Config
50import Graphics.Vty.Input
66import Graphics.Vty.Input
51−import Graphics.Vty.Input.Events
52import Graphics.Vty.Output
67import Graphics.Vty.Output
53import Graphics.Vty.Output.Interface
68import Graphics.Vty.Output.Interface
54import Graphics.Vty.Picture
69import Graphics.Vty.Picture
55−import Graphics.Vty.Image
56−import Graphics.Vty.Attributes
57−import Graphics.Vty.UnicodeWidthTable.IO
58−import Graphics.Vty.UnicodeWidthTable.Install
59
70
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)
65import Control.Concurrent.STM
71import Control.Concurrent.STM
66
72
67import Data.IORef
73import Data.IORef
68−#if !(MIN_VERSION_base(4,11,0))
69−import Data.Semigroup ((<>))
74+import Data.Monoid
70−#endif
71
75
72−-- | A Vty value represents a handle to the Vty library that the
76+-- | The main object. At most one should be created.
73−-- application must create in order to use Vty.
74--
77--
75-- The use of Vty typically follows this process:
78-- The use of Vty typically follows this process:
76--
79--
77−-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
80+-- 0. initialize vty
78−--
81+--
79−-- 2. Use 'update' to display a picture.
82+-- 1. use the update equation of Vty to display a picture
83+--
84+-- 2. repeat
80−--
85+--
81−-- 3. Use 'nextEvent' to get the next input event.
86+-- 3. shutdown vty.
82−--
87+--
83−-- 4. Depending on the event, go to 2 or 5.
88+-- An alternative to tracking the Vty instance is to use 'withVty' in
84−--
89+-- "Graphics.Vty.Inline.Unsafe".
85−-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
86−-- this point the 'Vty' handle cannot be used again.
87−--
90+--
88−-- Operations on Vty handles are not thread-safe.
91+-- This does not assure any thread safety. In theory, as long as an
92+-- update action is not executed when another update action is already
93+-- then it's safe to call this on multiple threads.
94+--
95+-- \todo Remove explicit `shutdown` requirement.
89−data Vty =
96+data Vty = Vty
97+ { -- | Outputs the given Picture. Equivalent to 'outputPicture'
98+ -- applied to a display context implicitly managed by Vty. The
99+ -- managed display context is reset on resize.
90− Vty { update :: Picture -> IO ()
100+ update :: Picture -> IO ()
91− -- ^ Outputs the given 'Picture'.
101+ -- | Get one Event object, blocking if necessary. This will
92− , nextEvent :: IO Event
102+ -- refresh the terminal if the event is a 'EvResize'.
93− -- ^ Return the next 'Event' or block until one becomes
103+ , nextEvent :: IO Event
94− -- available.
104+ -- | The input interface. See 'Input'
95− , nextEventNonblocking :: IO (Maybe Event)
96− -- ^ Non-blocking version of 'nextEvent'.
97− , inputIface :: Input
105+ , inputIface :: Input
98− -- ^ The input interface. See 'Input'.
106+ -- | The output interface. See 'Output'
99− , outputIface :: Output
107+ , outputIface :: Output
100− -- ^ The output interface. See 'Output'.
108+ -- | Refresh the display. 'nextEvent' will refresh the display if
101− , refresh :: IO ()
102− -- ^ Refresh the display. If other programs output to the
109+ -- a resize occurs. If other programs output to the terminal and
103− -- terminal and mess up the display then the application might
110+ -- mess up the display then the application might want to force a
104− -- want to force a refresh using this function.
111+ -- refresh.
105− , shutdown :: IO ()
112+ , refresh :: IO ()
106− -- ^ Clean up after vty. A call to this function is necessary to
113+ -- | Clean up after vty.
107− -- cleanly restore the terminal state before application exit.
108− -- The above methods will throw an exception if executed after
114+ -- The above methods will throw an exception if executed after
109− -- this is executed. Idempotent.
115+ -- this is executed.
110− , isShutdown :: IO Bool
116+ , shutdown :: IO ()
111− }
117+ }
112−
118+
113−-- | Create a Vty handle. At most one handle should be created at a time
119+-- | Set up the state object for using vty. At most one state object
114−-- for a given terminal device.
120+-- should be created at a time for a given terminal device.
115−--
121+--
116−-- The specified configuration is added to the the configuration
122+-- The specified config is added to the 'userConfig'. With the
117−-- loaded by 'userConfig' with the 'userConfig' configuration taking
118−-- precedence. See "Graphics.Vty.Config".
123+-- 'userConfig' taking precedence. See "Graphics.Vty.Config"
119−--
124+--
120−-- For most applications @mkVty defaultConfig@ is sufficient.
125+-- For most applications @mkVty def@ is sufficient.
121mkVty :: Config -> IO Vty
126mkVty :: Config -> IO Vty
122mkVty appConfig = do
127mkVty appConfig = do
123 config <- (<> appConfig) <$> userConfig
128 config <- (<> appConfig) <$> userConfig
129+ input <- inputForConfig config
130+ out <- outputForConfig config
131+ intMkVty input out
124
132
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−
167−internalMkVty :: Input -> Output -> IO Vty
133+intMkVty :: Input -> Output -> IO Vty
168−internalMkVty input out = do
134+intMkVty input out = do
169 reserveDisplay out
135 reserveDisplay out
170−
171− shutdownVar <- newTVarIO False
172 let shutdownIo = do
136 let shutdownIo = do
173− alreadyShutdown <- atomically $ swapTVar shutdownVar True
174− when (not alreadyShutdown) $ do
175− shutdownInput input
137+ shutdownInput input
176− releaseDisplay out
138+ releaseDisplay out
177− releaseTerminal out
139+ releaseTerminal out
178−
179− let shutdownStatus = readTVarIO shutdownVar
180−
181 lastPicRef <- newIORef Nothing
140 lastPicRef <- newIORef Nothing
182 lastUpdateRef <- newIORef Nothing
141 lastUpdateRef <- newIORef Nothing
183
142
@@ -209,47 +168,16 @@ internalMkVty input out = do
209 mPic <- readIORef lastPicRef
168 mPic <- readIORef lastPicRef
210 maybe (return ()) innerUpdate mPic
169 maybe (return ()) innerUpdate mPic
211
170
212− let mkResize = uncurry EvResize <$> displayBounds out
213−
214− translateInternalEvent ResumeAfterSignal = mkResize
215− translateInternalEvent (InputEvent e) = return e
216−
217− gkey = do
218− e <- atomically $ readTChan $ _eventChannel input
171+ let gkey = do k <- atomically $ readTChan $ _eventChannel input
219− translateInternalEvent e
220− gkey' = do
221− mEv <- atomically $ tryReadTChan $ _eventChannel input
222− case mEv of
172+ case k of
223− Just e -> Just <$> translateInternalEvent e
173+ (EvResize _ _) -> displayBounds out
174+ >>= return . (\(w,h)-> EvResize w h)
224− Nothing -> return Nothing
175+ _ -> return k
225
176
226 return $ Vty { update = innerUpdate
177 return $ Vty { update = innerUpdate
227 , nextEvent = gkey
178 , nextEvent = gkey
228− , nextEventNonblocking = gkey'
229 , inputIface = input
179 , inputIface = input
230 , outputIface = out
180 , outputIface = out
231 , refresh = innerRefresh
181 , refresh = innerRefresh
232 , shutdown = shutdownIo
182 , shutdown = shutdownIo
233− , isShutdown = shutdownStatus
234 }
183 }
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+92−84
@@ -1,71 +1,57 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE DeriveAnyClass #-}
4+{-# LANGUAGE RankNTypes #-}
5+
6+#ifndef MIN_VERSION_base
7+#defined MIN_VERSION_base(x,y,z) 1
8+#endif
4
9
5-- | Display attributes
10-- | Display attributes
6--
11--
7−-- Attributes have three components: a foreground color, a background
12+-- Typically the values 'defAttr' or 'currentAttr' are modified to form
8−-- color, and a style mask. The simplest attribute is the default
13+-- attributes:
9−-- attribute, or 'defAttr'. Attributes can be modified with
10−-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,
11--
14--
12-- @
15-- @
13−-- defAttr \`withForeColor\` red
16+-- defAttr `withForeColor` red
14-- @
17-- @
15--
18--
16−-- 'Image' constructors often require an 'Attr' to indicate the
19+-- Is the attribute that will set the foreground color to red and the
17−-- attributes used in the image, e.g.,
20+-- background color to the default.
21+--
22+-- This can then be used to build an image with a red foreground like
23+-- so:
18--
24--
19-- @
25-- @
20−-- string (defAttr \`withForeColor\` red) "this text will be red"
26+-- string (defAttr `withForeColor` red) "this text will be red"
21-- @
27-- @
22--
28--
23−-- The appearance of 'Image's using 'defAttr' is determined by the The
29+-- The default attributes set by 'defAttr' have a presentation
24−-- terminal, so this is not something VTY can control. The user is free
30+-- determined by the terminal. This is not something VTY can control.
25−-- to The define the color scheme of the terminal as they see fit.
31+-- The user is free to define the color scheme of the terminal as they
32+-- see fit. Up to the limits of the terminal anyways.
26--
33--
27-- The value 'currentAttr' will keep the attributes of whatever was
34-- The value 'currentAttr' will keep the attributes of whatever was
28-- output previously.
35-- output previously.
36+--
37+-- \todo This API is very verbose IMO. I'd like something more succinct.
29module Graphics.Vty.Attributes
38module Graphics.Vty.Attributes
30− ( module Graphics.Vty.Attributes.Color
39+ ( module Graphics.Vty.Attributes
31−
40+ , module Graphics.Vty.Attributes.Color
32− , Attr(..)
41+ , module Graphics.Vty.Attributes.Color240
33− , FixedAttr(..)
34− , MaybeDefault(..)
35− , defAttr
36− , currentAttr
37−
38− -- * Styles
39− , Style
40− , withStyle
41− , standout
42− , italic
43− , strikethrough
44− , underline
45− , reverseVideo
46− , blink
47− , dim
48− , bold
49− , defaultStyleMask
50− , styleMask
51− , hasStyle
52−
53− -- * Setting attribute colors
54− , withForeColor
55− , withBackColor
56−
57− -- * Setting hyperlinks
58− , withURL
59 )
42 )
60where
43where
61
44
62−import Control.DeepSeq
63import Data.Bits
45import Data.Bits
64−import Data.Text (Text)
46+import Data.Default
65import Data.Word
47import Data.Word
66−import GHC.Generics
67
48
68import Graphics.Vty.Attributes.Color
49import Graphics.Vty.Attributes.Color
50+import Graphics.Vty.Attributes.Color240
51+
52+#if !(MIN_VERSION_base(4,8,0))
53+import Data.Monoid
54+#endif
69
55
70-- | A display attribute defines the Color and Style of all the
56-- | A display attribute defines the Color and Style of all the
71-- characters rendered after the attribute is applied.
57-- characters rendered after the attribute is applied.
@@ -78,8 +64,7 @@ data Attr = Attr
78 { attrStyle :: !(MaybeDefault Style)
64 { attrStyle :: !(MaybeDefault Style)
79 , attrForeColor :: !(MaybeDefault Color)
65 , attrForeColor :: !(MaybeDefault Color)
80 , attrBackColor :: !(MaybeDefault Color)
66 , attrBackColor :: !(MaybeDefault Color)
81− , attrURL :: !(MaybeDefault Text)
82− } deriving ( Eq, Show, Read, Generic, NFData )
67+ } deriving ( Eq, Show, Read )
83
68
84-- This could be encoded into a single 32 bit word. The 32 bit word is
69-- This could be encoded into a single 32 bit word. The 32 bit word is
85-- first divided into 4 groups of 8 bits where: The first group codes
70-- first divided into 4 groups of 8 bits where: The first group codes
@@ -100,19 +85,25 @@ data Attr = Attr
100-- __ - unused
85-- __ - unused
101--
86--
102-- Next is the style flags
87-- Next is the style flags
103−-- SURBDOI_
88+-- SURBDO__
104-- S - standout
89-- S - standout
105-- U - underline
90-- U - underline
106-- R - reverse video
91-- R - reverse video
107-- B - blink
92-- B - blink
108-- D - dim
93-- D - dim
109-- O - bold
94-- O - bold
110−-- I - italic
111−-- _ - unused
95+-- __ - unused
112--
96--
113-- Then the foreground color encoded into 8 bits.
97-- Then the foreground color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
98-- Then the background color encoded into 8 bits.
115
99
100+instance Monoid Attr where
101+ mempty = Attr mempty mempty mempty
102+ mappend attr0 attr1 =
103+ Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
104+ ( attrForeColor attr0 `mappend` attrForeColor attr1 )
105+ ( attrBackColor attr0 `mappend` attrBackColor attr1 )
106+
116-- | Specifies the display attributes such that the final style and
107-- | Specifies the display attributes such that the final style and
117-- color values do not depend on the previously applied display
108-- color values do not depend on the previously applied display
118-- attribute. The display attributes can still depend on the terminal's
109-- attribute. The display attributes can still depend on the terminal's
@@ -121,26 +112,61 @@ data FixedAttr = FixedAttr
121 { fixedStyle :: !Style
112 { fixedStyle :: !Style
122 , fixedForeColor :: !(Maybe Color)
113 , fixedForeColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
114 , fixedBackColor :: !(Maybe Color)
124− , fixedURL :: !(Maybe Text)
125 } deriving ( Eq, Show )
115 } deriving ( Eq, Show )
126
116
127-- | The style and color attributes can either be the terminal defaults.
117-- | The style and color attributes can either be the terminal defaults.
128-- Or be equivalent to the previously applied style. Or be a specific
118-- Or be equivalent to the previously applied style. Or be a specific
129-- value.
119-- value.
130−data MaybeDefault v = Default | KeepCurrent | SetTo !v
120+data MaybeDefault v where
131− deriving (Eq, Read, Show)
121+ Default :: MaybeDefault v
132−
122+ KeepCurrent :: MaybeDefault v
123+ SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
124+
125+deriving instance Eq v => Eq (MaybeDefault v)
126+deriving instance Eq v => Show (MaybeDefault v)
127+deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
128+
133−instance (NFData v) => NFData (MaybeDefault v) where
129+instance Eq v => Monoid ( MaybeDefault v ) where
134− rnf Default = ()
130+ mempty = KeepCurrent
131+ mappend Default Default = Default
132+ mappend Default KeepCurrent = Default
133+ mappend Default ( SetTo v ) = SetTo v
134+ mappend KeepCurrent Default = Default
135− rnf KeepCurrent = ()
135+ mappend KeepCurrent KeepCurrent = KeepCurrent
136− rnf (SetTo v) = rnf v
136+ mappend KeepCurrent ( SetTo v ) = SetTo v
137+ mappend ( SetTo _v ) Default = Default
138+ mappend ( SetTo v ) KeepCurrent = SetTo v
139+ mappend ( SetTo _ ) ( SetTo v ) = SetTo v
140+
141+-- | Standard 8-color ANSI terminal color codes.
142+black, red, green, yellow, blue, magenta, cyan, white :: Color
143+black = ISOColor 0
144+red = ISOColor 1
145+green = ISOColor 2
146+yellow = ISOColor 3
147+blue = ISOColor 4
148+magenta= ISOColor 5
149+cyan = ISOColor 6
150+white = ISOColor 7
151+
152+-- | Bright/Vivid variants of the standard 8-color ANSI
153+brightBlack, brightRed, brightGreen, brightYellow :: Color
154+brightBlue, brightMagenta, brightCyan, brightWhite :: Color
155+brightBlack = ISOColor 8
156+brightRed = ISOColor 9
157+brightGreen = ISOColor 10
158+brightYellow = ISOColor 11
159+brightBlue = ISOColor 12
160+brightMagenta= ISOColor 13
161+brightCyan = ISOColor 14
162+brightWhite = ISOColor 15
137
163
138-- | Styles are represented as an 8 bit word. Each bit in the word is 1
164-- | Styles are represented as an 8 bit word. Each bit in the word is 1
139-- if the style attribute assigned to that bit should be applied and 0
165-- if the style attribute assigned to that bit should be applied and 0
140-- if the style attribute should not be applied.
166-- if the style attribute should not be applied.
141type Style = Word8
167type Style = Word8
142
168
143−-- | Valid style attributes include:
169+-- | The 6 possible style attributes:
144--
170--
145-- * standout
171-- * standout
146--
172--
@@ -154,21 +180,15 @@ type Style = Word8
154--
180--
155-- * bold/bright
181-- * bold/bright
156--
182--
157−-- * italic
158−--
159−-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160−--
161-- (The invisible, protect, and altcharset display attributes some
183-- (The invisible, protect, and altcharset display attributes some
162-- terminals support are not supported via VTY.)
184-- terminals support are not supported via VTY.)
163−standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
185+standout, underline, reverseVideo, blink, dim, bold :: Style
164standout = 0x01
186standout = 0x01
165underline = 0x02
187underline = 0x02
166−reverseVideo = 0x04
188+reverseVideo = 0x04
167blink = 0x08
189blink = 0x08
168dim = 0x10
190dim = 0x10
169bold = 0x20
191bold = 0x20
170−italic = 0x40
171−strikethrough = 0x80
172
192
173defaultStyleMask :: Style
193defaultStyleMask :: Style
174defaultStyleMask = 0x00
194defaultStyleMask = 0x00
@@ -194,28 +214,16 @@ withBackColor attr c = attr { attrBackColor = SetTo c }
194
214
195-- | Add the given style attribute
215-- | Add the given style attribute
196withStyle :: Attr -> Style -> Attr
216withStyle :: Attr -> Style -> Attr
197−withStyle attr 0 = attr
198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
217withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
199
218
200−-- | Add a hyperlinked URL using the proposed [escape sequences for
201−-- hyperlinked
202−-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
203−-- These escape sequences are comparatively new and aren't widely
204−-- supported in terminal emulators yet, but most terminal emulators
205−-- that don't know about these sequences will ignore these sequences,
206−-- and therefore this should fall back sensibly. In some cases they
207−-- won't and this will result in garbage, so this is why hyperlinking is
208−-- disabled by default, in which case this combinator has no observable
209−-- effect. To enable it, enable 'Hyperlink' mode on your Vty output
210−-- interface.
211−withURL :: Attr -> Text -> Attr
212−withURL attr url = attr { attrURL = SetTo url }
213−
214-- | Sets the style, background color and foreground color to the
219-- | Sets the style, background color and foreground color to the
215-- default values for the terminal. There is no easy way to determine
220-- default values for the terminal. There is no easy way to determine
216-- what the default background and foreground colors are.
221-- what the default background and foreground colors are.
217defAttr :: Attr
222defAttr :: Attr
218−defAttr = Attr Default Default Default Default
223+defAttr = Attr Default Default Default
224+
225+instance Default Attr where
226+ def = defAttr
219
227
220-- | Keeps the style, background color and foreground color that was
228-- | Keeps the style, background color and foreground color that was
221-- previously set. Used to override some part of the previous style.
229-- previously set. Used to override some part of the previous style.
@@ -225,4 +233,4 @@ defAttr = Attr Default Default Default Default
225-- Would be the currently applied style (be it underline, bold, etc) but
233-- Would be the currently applied style (be it underline, bold, etc) but
226-- with the foreground color set to brightMagenta.
234-- with the foreground color set to brightMagenta.
227currentAttr :: Attr
235currentAttr :: Attr
228−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
236+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs+4−137
@@ -1,61 +1,6 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3−{-# LANGUAGE MultiWayIf #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−
6−module Graphics.Vty.Attributes.Color
1+module Graphics.Vty.Attributes.Color where
7− ( Color(..)
8− , ColorMode(..)
9−
10− -- * Detecting Terminal Color Support
11− , detectColorMode
12−
13− -- ** Fixed Colors
14− -- | Standard 8-color ANSI terminal color codes.
15− --
16− -- Note that these map to colors in the terminal's custom palette. For
17− -- instance, `white` maps to whatever the terminal color theme uses for
18− -- white.
19− --
20− -- Use these functions if you want to make apps that fit the terminal theme.
21− -- If you want access to more/stronger colors use `rgbColor`
22− , black
23− , red
24− , green
25− , yellow
26− , blue
27− , magenta
28− , cyan
29− , white
30−
31− -- | Bright/Vivid variants of the standard 8-color ANSI
32− , brightBlack
33− , brightRed
34− , brightGreen
35− , brightYellow
36− , brightBlue
37− , brightMagenta
38− , brightCyan
39− , brightWhite
40− -- ** Creating Colors From RGB
41− , linearColor
42− , srgbColor
43− , rgbColor
44− , color240
45− , module Graphics.Vty.Attributes.Color240
46− )
47−where
48
2
49import Data.Word
3import 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
59
4
60-- | Abstract data type representing a color.
5-- | Abstract data type representing a color.
61--
6--
@@ -95,7 +40,7 @@ import Graphics.Vty.Attributes.Color240
95-- reported then the color reproduction will be incorrect.
40-- reported then the color reproduction will be incorrect.
96--
41--
97-- If the terminal reports <= 16 colors then the 240 color palette
42-- If the terminal reports <= 16 colors then the 240 color palette
98−-- points are only mapped to the 8 color palette. I'm not sure of
43+-- points are only mapped to the 8 color pallete. I'm not sure of
99-- the RGB points for the "bright" colors which is why they are not
44-- the RGB points for the "bright" colors which is why they are not
100-- addressable via the 240 color palette.
45-- addressable via the 240 color palette.
101--
46--
@@ -109,83 +54,5 @@ import Graphics.Vty.Attributes.Color240
109-- terminfo but I don't know it.
54-- terminfo but I don't know it.
110--
55--
111-- Seriously, terminal color support is INSANE.
56-- Seriously, terminal color support is INSANE.
112−data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8
57+data Color = ISOColor !Word8 | Color240 !Word8
113− deriving ( Eq, Show, Read, Generic, NFData )
58+ deriving ( Eq, Show, Read )
114−
115−data ColorMode
116− = NoColor
117− | ColorMode8
118− | ColorMode16
119− | ColorMode240 !Word8
120− | FullColor
121− deriving ( Eq, Show )
122−
123−detectColorMode :: String -> IO ColorMode
124−detectColorMode termName' = do
125− term <- catch (Just <$> Terminfo.setupTerm termName')
126− (\(_ :: Terminfo.SetupTermError) -> return Nothing)
127− let getCap cap = term >>= \t -> Terminfo.getCapability t cap
128− termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")
129− colorterm <- lookupEnv "COLORTERM"
130− return $ if
131− | termColors < 8 -> NoColor
132− | termColors < 16 -> ColorMode8
133− | termColors == 16 -> ColorMode16
134− | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)
135− | colorterm == Just "truecolor" -> FullColor
136− | colorterm == Just "24bit" -> FullColor
137− | otherwise -> ColorMode240 240
138−
139−black, red, green, yellow, blue, magenta, cyan, white :: Color
140−black = ISOColor 0
141−red = ISOColor 1
142−green = ISOColor 2
143−yellow = ISOColor 3
144−blue = ISOColor 4
145−magenta= ISOColor 5
146−cyan = ISOColor 6
147−white = ISOColor 7
148−
149−brightBlack, brightRed, brightGreen, brightYellow :: Color
150−brightBlue, brightMagenta, brightCyan, brightWhite :: Color
151−brightBlack = ISOColor 8
152−brightRed = ISOColor 9
153−brightGreen = ISOColor 10
154−brightYellow = ISOColor 11
155−brightBlue = ISOColor 12
156−brightMagenta= ISOColor 13
157−brightCyan = ISOColor 14
158−brightWhite = ISOColor 15
159−
160−linearColor :: Integral i => i -> i -> i -> Color
161−linearColor r g b = RGBColor r' g' b'
162− where
163− r' = fromIntegral (clamp r) :: Word8
164− g' = fromIntegral (clamp g) :: Word8
165− b' = fromIntegral (clamp b) :: Word8
166− clamp = min 255 . max 0
167−
168−srgbColor :: Integral i => i -> i -> i -> Color
169−srgbColor r g b =
170− -- srgb to rgb transformation as described at
171− -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation
172− --
173− -- TODO: it may be worth translating this to a lookup table, as with color240
174− let shrink n = fromIntegral n / 255 :: Double
175− -- called gamma^-1 in wiki
176− gamma u
177− | u <= 0.04045 = u/12.92
178− | otherwise = ((u + 0.055) / 1.055) ** 2.4
179− -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?
180− expand n = round (255 * n)
181− convert = expand . gamma . shrink
182− in RGBColor (convert r) (convert g) (convert b)
183−
184−color240 :: Integral i => i -> i -> i -> Color
185−color240 r g b = Color240 (rgbColorToColor240 r g b)
186−
187−-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.
188−-- This function is lossy in the sense that we only internally support 240 colors but the
189−-- #RRGGBB format supports 16^3 colors.
190−rgbColor :: Integral i => i -> i -> i -> Color
191−rgbColor = color240
src/Graphics/Vty/Attributes/Color240.hs+251−290
@@ -1,298 +1,259 @@
1-- This header file was generated by ./256colres.pl
1-- This header file was generated by ./256colres.pl
2−module Graphics.Vty.Attributes.Color240
2+module Graphics.Vty.Attributes.Color240 where
3− ( rgbColorToColor240
4− , color240CodeToRGB
5− )
6−where
7
3
8−import Data.Word (Word8)
4+import Graphics.Vty.Attributes.Color
9−import Text.Printf
10
5
11−-- Note: rgbColor's mapping from RGB to 240 colors was generated from
6+import Text.Printf
12−-- 256colres.pl which is forked from xterm 256colres.pl.
13
7
14−-- | Create a value in the Color240 set from an RGB triple
8+-- | RGB color to 240 color palette.
9+--
10+-- generated from 256colres.pl which is forked from xterm 256colres.pl
11+-- todo: all values get clamped high.
15−rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
12+rgbColor :: Integral i => i -> i -> i -> Color
16−rgbColorToColor240 r g b
13+rgbColor r g b
17 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
14 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
18− | r == 8 && g == 8 && b == 8 = 216
15+ | r == 8 && g == 8 && b == 8 = Color240 216
19− | r == 18 && g == 18 && b == 18 = 217
16+ | r == 18 && g == 18 && b == 18 = Color240 217
20− | r == 28 && g == 28 && b == 28 = 218
17+ | r == 28 && g == 28 && b == 28 = Color240 218
21− | r == 38 && g == 38 && b == 38 = 219
18+ | r == 38 && g == 38 && b == 38 = Color240 219
22− | r == 48 && g == 48 && b == 48 = 220
19+ | r == 48 && g == 48 && b == 48 = Color240 220
23− | r == 58 && g == 58 && b == 58 = 221
20+ | r == 58 && g == 58 && b == 58 = Color240 221
24− | r == 68 && g == 68 && b == 68 = 222
21+ | r == 68 && g == 68 && b == 68 = Color240 222
25− | r == 78 && g == 78 && b == 78 = 223
22+ | r == 78 && g == 78 && b == 78 = Color240 223
26− | r == 88 && g == 88 && b == 88 = 224
23+ | r == 88 && g == 88 && b == 88 = Color240 224
27− | r == 98 && g == 98 && b == 98 = 225
24+ | r == 98 && g == 98 && b == 98 = Color240 225
28− | r == 108 && g == 108 && b == 108 = 226
25+ | r == 108 && g == 108 && b == 108 = Color240 226
29− | r == 118 && g == 118 && b == 118 = 227
26+ | r == 118 && g == 118 && b == 118 = Color240 227
30− | r == 128 && g == 128 && b == 128 = 228
27+ | r == 128 && g == 128 && b == 128 = Color240 228
31− | r == 138 && g == 138 && b == 138 = 229
28+ | r == 138 && g == 138 && b == 138 = Color240 229
32− | r == 148 && g == 148 && b == 148 = 230
29+ | r == 148 && g == 148 && b == 148 = Color240 230
33− | r == 158 && g == 158 && b == 158 = 231
30+ | r == 158 && g == 158 && b == 158 = Color240 231
34− | r == 168 && g == 168 && b == 168 = 232
31+ | r == 168 && g == 168 && b == 168 = Color240 232
35− | r == 178 && g == 178 && b == 178 = 233
32+ | r == 178 && g == 178 && b == 178 = Color240 233
36− | r == 188 && g == 188 && b == 188 = 234
33+ | r == 188 && g == 188 && b == 188 = Color240 234
37− | r == 198 && g == 198 && b == 198 = 235
34+ | r == 198 && g == 198 && b == 198 = Color240 235
38− | r == 208 && g == 208 && b == 208 = 236
35+ | r == 208 && g == 208 && b == 208 = Color240 236
39− | r == 218 && g == 218 && b == 218 = 237
36+ | r == 218 && g == 218 && b == 218 = Color240 237
40− | r == 228 && g == 228 && b == 228 = 238
37+ | r == 228 && g == 228 && b == 228 = Color240 238
41− | r == 238 && g == 238 && b == 238 = 239
38+ | r == 238 && g == 238 && b == 238 = Color240 239
42− | otherwise = 36 * go r + 6 * go g + go b
39+ | r <= 0 && g <= 0 && b <= 0 = Color240 0
43− where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."
40+ | r <= 0 && g <= 0 && b <= 95 = Color240 1
41+ | r <= 0 && g <= 0 && b <= 135 = Color240 2
42+ | r <= 0 && g <= 0 && b <= 175 = Color240 3
43+ | r <= 0 && g <= 0 && b <= 215 = Color240 4
44+ | r <= 0 && g <= 0 && b <= 255 = Color240 5
45+ | r <= 0 && g <= 95 && b <= 0 = Color240 6
46+ | r <= 0 && g <= 95 && b <= 95 = Color240 7
47+ | r <= 0 && g <= 95 && b <= 135 = Color240 8
48+ | r <= 0 && g <= 95 && b <= 175 = Color240 9
49+ | r <= 0 && g <= 95 && b <= 215 = Color240 10
50+ | r <= 0 && g <= 95 && b <= 255 = Color240 11
51+ | r <= 0 && g <= 135 && b <= 0 = Color240 12
52+ | r <= 0 && g <= 135 && b <= 95 = Color240 13
53+ | r <= 0 && g <= 135 && b <= 135 = Color240 14
54+ | r <= 0 && g <= 135 && b <= 175 = Color240 15
55+ | r <= 0 && g <= 135 && b <= 215 = Color240 16
56+ | r <= 0 && g <= 135 && b <= 255 = Color240 17
57+ | r <= 0 && g <= 175 && b <= 0 = Color240 18
58+ | r <= 0 && g <= 175 && b <= 95 = Color240 19
59+ | r <= 0 && g <= 175 && b <= 135 = Color240 20
60+ | r <= 0 && g <= 175 && b <= 175 = Color240 21
61+ | r <= 0 && g <= 175 && b <= 215 = Color240 22
62+ | r <= 0 && g <= 175 && b <= 255 = Color240 23
63+ | r <= 0 && g <= 215 && b <= 0 = Color240 24
64+ | r <= 0 && g <= 215 && b <= 95 = Color240 25
65+ | r <= 0 && g <= 215 && b <= 135 = Color240 26
66+ | r <= 0 && g <= 215 && b <= 175 = Color240 27
67+ | r <= 0 && g <= 215 && b <= 215 = Color240 28
68+ | r <= 0 && g <= 215 && b <= 255 = Color240 29
69+ | r <= 0 && g <= 255 && b <= 0 = Color240 30
70+ | r <= 0 && g <= 255 && b <= 95 = Color240 31
71+ | r <= 0 && g <= 255 && b <= 135 = Color240 32
72+ | r <= 0 && g <= 255 && b <= 175 = Color240 33
73+ | r <= 0 && g <= 255 && b <= 215 = Color240 34
74+ | r <= 0 && g <= 255 && b <= 255 = Color240 35
75+ | r <= 95 && g <= 0 && b <= 0 = Color240 36
76+ | r <= 95 && g <= 0 && b <= 95 = Color240 37
77+ | r <= 95 && g <= 0 && b <= 135 = Color240 38
78+ | r <= 95 && g <= 0 && b <= 175 = Color240 39
79+ | r <= 95 && g <= 0 && b <= 215 = Color240 40
80+ | r <= 95 && g <= 0 && b <= 255 = Color240 41
81+ | r <= 95 && g <= 95 && b <= 0 = Color240 42
82+ | r <= 95 && g <= 95 && b <= 95 = Color240 43
83+ | r <= 95 && g <= 95 && b <= 135 = Color240 44
84+ | r <= 95 && g <= 95 && b <= 175 = Color240 45
85+ | r <= 95 && g <= 95 && b <= 215 = Color240 46
86+ | r <= 95 && g <= 95 && b <= 255 = Color240 47
87+ | r <= 95 && g <= 135 && b <= 0 = Color240 48
88+ | r <= 95 && g <= 135 && b <= 95 = Color240 49
89+ | r <= 95 && g <= 135 && b <= 135 = Color240 50
90+ | r <= 95 && g <= 135 && b <= 175 = Color240 51
91+ | r <= 95 && g <= 135 && b <= 215 = Color240 52
92+ | r <= 95 && g <= 135 && b <= 255 = Color240 53
93+ | r <= 95 && g <= 175 && b <= 0 = Color240 54
94+ | r <= 95 && g <= 175 && b <= 95 = Color240 55
95+ | r <= 95 && g <= 175 && b <= 135 = Color240 56
96+ | r <= 95 && g <= 175 && b <= 175 = Color240 57
97+ | r <= 95 && g <= 175 && b <= 215 = Color240 58
98+ | r <= 95 && g <= 175 && b <= 255 = Color240 59
99+ | r <= 95 && g <= 215 && b <= 0 = Color240 60
100+ | r <= 95 && g <= 215 && b <= 95 = Color240 61
101+ | r <= 95 && g <= 215 && b <= 135 = Color240 62
102+ | r <= 95 && g <= 215 && b <= 175 = Color240 63
103+ | r <= 95 && g <= 215 && b <= 215 = Color240 64
104+ | r <= 95 && g <= 215 && b <= 255 = Color240 65
105+ | r <= 95 && g <= 255 && b <= 0 = Color240 66
106+ | r <= 95 && g <= 255 && b <= 95 = Color240 67
107+ | r <= 95 && g <= 255 && b <= 135 = Color240 68
108+ | r <= 95 && g <= 255 && b <= 175 = Color240 69
109+ | r <= 95 && g <= 255 && b <= 215 = Color240 70
110+ | r <= 95 && g <= 255 && b <= 255 = Color240 71
111+ | r <= 135 && g <= 0 && b <= 0 = Color240 72
112+ | r <= 135 && g <= 0 && b <= 95 = Color240 73
113+ | r <= 135 && g <= 0 && b <= 135 = Color240 74
114+ | r <= 135 && g <= 0 && b <= 175 = Color240 75
115+ | r <= 135 && g <= 0 && b <= 215 = Color240 76
116+ | r <= 135 && g <= 0 && b <= 255 = Color240 77
117+ | r <= 135 && g <= 95 && b <= 0 = Color240 78
118+ | r <= 135 && g <= 95 && b <= 95 = Color240 79
119+ | r <= 135 && g <= 95 && b <= 135 = Color240 80
120+ | r <= 135 && g <= 95 && b <= 175 = Color240 81
121+ | r <= 135 && g <= 95 && b <= 215 = Color240 82
122+ | r <= 135 && g <= 95 && b <= 255 = Color240 83
123+ | r <= 135 && g <= 135 && b <= 0 = Color240 84
124+ | r <= 135 && g <= 135 && b <= 95 = Color240 85
125+ | r <= 135 && g <= 135 && b <= 135 = Color240 86
126+ | r <= 135 && g <= 135 && b <= 175 = Color240 87
127+ | r <= 135 && g <= 135 && b <= 215 = Color240 88
128+ | r <= 135 && g <= 135 && b <= 255 = Color240 89
129+ | r <= 135 && g <= 175 && b <= 0 = Color240 90
130+ | r <= 135 && g <= 175 && b <= 95 = Color240 91
131+ | r <= 135 && g <= 175 && b <= 135 = Color240 92
132+ | r <= 135 && g <= 175 && b <= 175 = Color240 93
133+ | r <= 135 && g <= 175 && b <= 215 = Color240 94
134+ | r <= 135 && g <= 175 && b <= 255 = Color240 95
135+ | r <= 135 && g <= 215 && b <= 0 = Color240 96
136+ | r <= 135 && g <= 215 && b <= 95 = Color240 97
137+ | r <= 135 && g <= 215 && b <= 135 = Color240 98
138+ | r <= 135 && g <= 215 && b <= 175 = Color240 99
139+ | r <= 135 && g <= 215 && b <= 215 = Color240 100
140+ | r <= 135 && g <= 215 && b <= 255 = Color240 101
141+ | r <= 135 && g <= 255 && b <= 0 = Color240 102
142+ | r <= 135 && g <= 255 && b <= 95 = Color240 103
143+ | r <= 135 && g <= 255 && b <= 135 = Color240 104
144+ | r <= 135 && g <= 255 && b <= 175 = Color240 105
145+ | r <= 135 && g <= 255 && b <= 215 = Color240 106
146+ | r <= 135 && g <= 255 && b <= 255 = Color240 107
147+ | r <= 175 && g <= 0 && b <= 0 = Color240 108
148+ | r <= 175 && g <= 0 && b <= 95 = Color240 109
149+ | r <= 175 && g <= 0 && b <= 135 = Color240 110
150+ | r <= 175 && g <= 0 && b <= 175 = Color240 111
151+ | r <= 175 && g <= 0 && b <= 215 = Color240 112
152+ | r <= 175 && g <= 0 && b <= 255 = Color240 113
153+ | r <= 175 && g <= 95 && b <= 0 = Color240 114
154+ | r <= 175 && g <= 95 && b <= 95 = Color240 115
155+ | r <= 175 && g <= 95 && b <= 135 = Color240 116
156+ | r <= 175 && g <= 95 && b <= 175 = Color240 117
157+ | r <= 175 && g <= 95 && b <= 215 = Color240 118
158+ | r <= 175 && g <= 95 && b <= 255 = Color240 119
159+ | r <= 175 && g <= 135 && b <= 0 = Color240 120
160+ | r <= 175 && g <= 135 && b <= 95 = Color240 121
161+ | r <= 175 && g <= 135 && b <= 135 = Color240 122
162+ | r <= 175 && g <= 135 && b <= 175 = Color240 123
163+ | r <= 175 && g <= 135 && b <= 215 = Color240 124
164+ | r <= 175 && g <= 135 && b <= 255 = Color240 125
165+ | r <= 175 && g <= 175 && b <= 0 = Color240 126
166+ | r <= 175 && g <= 175 && b <= 95 = Color240 127
167+ | r <= 175 && g <= 175 && b <= 135 = Color240 128
168+ | r <= 175 && g <= 175 && b <= 175 = Color240 129
169+ | r <= 175 && g <= 175 && b <= 215 = Color240 130
170+ | r <= 175 && g <= 175 && b <= 255 = Color240 131
171+ | r <= 175 && g <= 215 && b <= 0 = Color240 132
172+ | r <= 175 && g <= 215 && b <= 95 = Color240 133
173+ | r <= 175 && g <= 215 && b <= 135 = Color240 134
174+ | r <= 175 && g <= 215 && b <= 175 = Color240 135
175+ | r <= 175 && g <= 215 && b <= 215 = Color240 136
176+ | r <= 175 && g <= 215 && b <= 255 = Color240 137
177+ | r <= 175 && g <= 255 && b <= 0 = Color240 138
178+ | r <= 175 && g <= 255 && b <= 95 = Color240 139
179+ | r <= 175 && g <= 255 && b <= 135 = Color240 140
180+ | r <= 175 && g <= 255 && b <= 175 = Color240 141
181+ | r <= 175 && g <= 255 && b <= 215 = Color240 142
182+ | r <= 175 && g <= 255 && b <= 255 = Color240 143
183+ | r <= 215 && g <= 0 && b <= 0 = Color240 144
184+ | r <= 215 && g <= 0 && b <= 95 = Color240 145
185+ | r <= 215 && g <= 0 && b <= 135 = Color240 146
186+ | r <= 215 && g <= 0 && b <= 175 = Color240 147
187+ | r <= 215 && g <= 0 && b <= 215 = Color240 148
188+ | r <= 215 && g <= 0 && b <= 255 = Color240 149
189+ | r <= 215 && g <= 95 && b <= 0 = Color240 150
190+ | r <= 215 && g <= 95 && b <= 95 = Color240 151
191+ | r <= 215 && g <= 95 && b <= 135 = Color240 152
192+ | r <= 215 && g <= 95 && b <= 175 = Color240 153
193+ | r <= 215 && g <= 95 && b <= 215 = Color240 154
194+ | r <= 215 && g <= 95 && b <= 255 = Color240 155
195+ | r <= 215 && g <= 135 && b <= 0 = Color240 156
196+ | r <= 215 && g <= 135 && b <= 95 = Color240 157
197+ | r <= 215 && g <= 135 && b <= 135 = Color240 158
198+ | r <= 215 && g <= 135 && b <= 175 = Color240 159
199+ | r <= 215 && g <= 135 && b <= 215 = Color240 160
200+ | r <= 215 && g <= 135 && b <= 255 = Color240 161
201+ | r <= 215 && g <= 175 && b <= 0 = Color240 162
202+ | r <= 215 && g <= 175 && b <= 95 = Color240 163
203+ | r <= 215 && g <= 175 && b <= 135 = Color240 164
204+ | r <= 215 && g <= 175 && b <= 175 = Color240 165
205+ | r <= 215 && g <= 175 && b <= 215 = Color240 166
206+ | r <= 215 && g <= 175 && b <= 255 = Color240 167
207+ | r <= 215 && g <= 215 && b <= 0 = Color240 168
208+ | r <= 215 && g <= 215 && b <= 95 = Color240 169
209+ | r <= 215 && g <= 215 && b <= 135 = Color240 170
210+ | r <= 215 && g <= 215 && b <= 175 = Color240 171
211+ | r <= 215 && g <= 215 && b <= 215 = Color240 172
212+ | r <= 215 && g <= 215 && b <= 255 = Color240 173
213+ | r <= 215 && g <= 255 && b <= 0 = Color240 174
214+ | r <= 215 && g <= 255 && b <= 95 = Color240 175
215+ | r <= 215 && g <= 255 && b <= 135 = Color240 176
216+ | r <= 215 && g <= 255 && b <= 175 = Color240 177
217+ | r <= 215 && g <= 255 && b <= 215 = Color240 178
218+ | r <= 215 && g <= 255 && b <= 255 = Color240 179
219+ | r <= 255 && g <= 0 && b <= 0 = Color240 180
220+ | r <= 255 && g <= 0 && b <= 95 = Color240 181
221+ | r <= 255 && g <= 0 && b <= 135 = Color240 182
222+ | r <= 255 && g <= 0 && b <= 175 = Color240 183
223+ | r <= 255 && g <= 0 && b <= 215 = Color240 184
224+ | r <= 255 && g <= 0 && b <= 255 = Color240 185
225+ | r <= 255 && g <= 95 && b <= 0 = Color240 186
226+ | r <= 255 && g <= 95 && b <= 95 = Color240 187
227+ | r <= 255 && g <= 95 && b <= 135 = Color240 188
228+ | r <= 255 && g <= 95 && b <= 175 = Color240 189
229+ | r <= 255 && g <= 95 && b <= 215 = Color240 190
230+ | r <= 255 && g <= 95 && b <= 255 = Color240 191
231+ | r <= 255 && g <= 135 && b <= 0 = Color240 192
232+ | r <= 255 && g <= 135 && b <= 95 = Color240 193
233+ | r <= 255 && g <= 135 && b <= 135 = Color240 194
234+ | r <= 255 && g <= 135 && b <= 175 = Color240 195
235+ | r <= 255 && g <= 135 && b <= 215 = Color240 196
236+ | r <= 255 && g <= 135 && b <= 255 = Color240 197
237+ | r <= 255 && g <= 175 && b <= 0 = Color240 198
238+ | r <= 255 && g <= 175 && b <= 95 = Color240 199
239+ | r <= 255 && g <= 175 && b <= 135 = Color240 200
240+ | r <= 255 && g <= 175 && b <= 175 = Color240 201
241+ | r <= 255 && g <= 175 && b <= 215 = Color240 202
242+ | r <= 255 && g <= 175 && b <= 255 = Color240 203
243+ | r <= 255 && g <= 215 && b <= 0 = Color240 204
244+ | r <= 255 && g <= 215 && b <= 95 = Color240 205
245+ | r <= 255 && g <= 215 && b <= 135 = Color240 206
246+ | r <= 255 && g <= 215 && b <= 175 = Color240 207
247+ | r <= 255 && g <= 215 && b <= 215 = Color240 208
248+ | r <= 255 && g <= 215 && b <= 255 = Color240 209
249+ | r <= 255 && g <= 255 && b <= 0 = Color240 210
250+ | r <= 255 && g <= 255 && b <= 95 = Color240 211
251+ | r <= 255 && g <= 255 && b <= 135 = Color240 212
252+ | r <= 255 && g <= 255 && b <= 175 = Color240 213
253+ | r <= 255 && g <= 255 && b <= 215 = Color240 214
254+ | r <= 255 && g <= 255 && b <= 255 = Color240 215
255+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
44 (fromIntegral r :: Int)
256 (fromIntegral r :: Int)
45 (fromIntegral g :: Int)
257 (fromIntegral g :: Int)
46− (fromIntegral b :: Int)))
258+ (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
259
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+106−276
@@ -3,13 +3,23 @@
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
4{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE LambdaCase, MultiWayIf #-}
6+-- | A 'Config' can be provided to mkVty to customize the applications
7−-- | Vty supports a configuration file format and associated 'Config'
7+-- use of vty. A config file can be used to customize vty for a user's
8−-- data type. The 'Config' can be provided to 'mkVty' to customize the
8+-- system.
9+--
10+-- The 'Config' provided is mappend'd to 'Config's loaded from
11+-- @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@. The
12+-- @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the
9−-- application's use of Vty.
13+-- application provided 'Config'.
10--
14--
11-- Lines in config files that fail to parse are ignored. Later entries
15-- Lines in config files that fail to parse are ignored. Later entries
12−-- take precedence over earlier ones.
16+-- take precedence over earlier.
17+--
18+-- For all directives:
19+--
20+-- @
21+-- string := \"\\\"\" chars+ \"\\\"\"
22+-- @
13--
23--
14-- = Debug
24-- = Debug
15--
25--
@@ -39,7 +49,7 @@
39-- term := "_" | string
49-- term := "_" | string
40-- @
50-- @
41--
51--
42−-- E.g., if the contents are
52+-- EG: If the contents are
43--
53--
44-- @
54-- @
45-- map _ \"\\ESC[B\" KUp []
55-- map _ \"\\ESC[B\" KUp []
@@ -53,35 +63,11 @@
53-- result in the KLeft event when @TERM@ is @xterm@.
63-- result in the KLeft event when @TERM@ is @xterm@.
54--
64--
55-- If a debug log is requested then vty will output the current input
65-- If a debug log is requested then vty will output the current input
56−-- table to the log in the above format. A workflow for using this is
66+-- table to the log in the above format.
57−-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
58−-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.
59--
67--
60−-- = Unicode Character Width Maps
68+-- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings.
69+-- Add corrected mappings to .vty/config
61--
70--
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.
85module Graphics.Vty.Config
71module Graphics.Vty.Config
86 ( InputMap
72 ( InputMap
87 , Config(..)
73 , Config(..)
@@ -91,22 +77,14 @@ module Graphics.Vty.Config
91 , standardIOConfig
77 , standardIOConfig
92 , runParseConfig
78 , runParseConfig
93 , parseConfigFile
79 , parseConfigFile
94− , defaultConfig
95− , getTtyEraseChar
96− , currentTerminalName
97−
98− , vtyConfigPath
99− , widthTableFilename
100− , vtyDataDirectory
101− , terminalWidthTablePath
102− , vtyConfigFileEnvName
103−
104− , ConfigUpdateResult(..)
105− , addConfigWidthMap
106 )
80 )
107where
81where
108
82
83+#if __GLASGOW_HASKELL__ > 704
109import Prelude
84import Prelude
85+#else
86+import Prelude hiding (catch)
87+#endif
110
88
111import Control.Applicative hiding (many)
89import Control.Applicative hiding (many)
112
90
@@ -114,186 +92,118 @@ import Control.Exception (catch, IOException, Exception(..), throwIO)
114import Control.Monad (liftM, guard, void)
92import Control.Monad (liftM, guard, void)
115
93
116import qualified Data.ByteString as BS
94import qualified Data.ByteString as BS
117−#if !(MIN_VERSION_base(4,8,0))
118−import Data.Monoid (Monoid(..))
95+import Data.Default
119−#endif
120−#if !(MIN_VERSION_base(4,11,0))
121−import Data.Semigroup (Semigroup(..))
96+import Data.Monoid
122−#endif
123import Data.Typeable (Typeable)
97import Data.Typeable (Typeable)
124
98
125import Graphics.Vty.Input.Events
99import Graphics.Vty.Input.Events
126−import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
127
100
128import GHC.Generics
101import GHC.Generics
129
102
130−import System.Directory ( getAppUserDataDirectory, doesFileExist
103+import System.Directory (getAppUserDataDirectory)
131− , createDirectoryIfMissing
132− )
133−import System.Environment (lookupEnv)
104+import System.Posix.Env (getEnv)
134−import System.FilePath ((</>), takeDirectory)
135import System.Posix.IO (stdInput, stdOutput)
105import System.Posix.IO (stdInput, stdOutput)
136import System.Posix.Types (Fd(..))
106import System.Posix.Types (Fd(..))
137−import Foreign.C.Types (CInt(..), CChar(..))
138
107
139import Text.Parsec hiding ((<|>))
108import Text.Parsec hiding ((<|>))
140import Text.Parsec.Token ( GenLanguageDef(..) )
109import Text.Parsec.Token ( GenLanguageDef(..) )
141import qualified Text.Parsec.Token as P
110import qualified Text.Parsec.Token as P
142
111
143-- | Type of errors that can be thrown when configuring VTY
112-- | Type of errors that can be thrown when configuring VTY
144−data VtyConfigurationError =
113+data VtyConfigurationError
145− VtyMissingTermEnvVar
146− -- ^ TERM environment variable not set
114+ = VtyMissingTermEnvVar -- ^ TERM environment variable not set
147− deriving (Show, Eq, Typeable)
115+ deriving (Show, Eq, Typeable)
148
116
149instance Exception VtyConfigurationError where
117instance Exception VtyConfigurationError where
118+#if MIN_VERSION_base(4,8,0)
150− displayException VtyMissingTermEnvVar = "TERM environment variable not set"
119+ displayException VtyMissingTermEnvVar = "TERM environment variable not set"
120+#endif
151
121
152-- | Mappings from input bytes to event in the order specified. Later
122-- | Mappings from input bytes to event in the order specified. Later
153-- entries take precedence over earlier in the case multiple entries
123-- entries take precedence over earlier in the case multiple entries
154-- have the same byte string.
124-- have the same byte string.
155type InputMap = [(Maybe String, String, Event)]
125type InputMap = [(Maybe String, String, Event)]
156
126
157−-- | A Vty configuration.
158−data Config =
127+data Config = Config
128+ {
129+ -- | The default is 1 character.
159− Config { vmin :: Maybe Int
130+ vmin :: Maybe Int
160− -- ^ The default is 1 character.
161− , vtime :: Maybe Int
162− -- ^ The default is 100 milliseconds, 0.1 seconds.
131+ -- | The default is 100 milliseconds, 0.1 seconds.
163− , mouseMode :: Maybe Bool
132+ , vtime :: Maybe Int
164− -- ^ The default is False.
133+ -- | The default is False.
165− , bracketedPasteMode :: Maybe Bool
134+ , mouseMode :: Maybe Bool
166− -- ^ The default is False.
135+ -- | The default is False.
167− , debugLog :: Maybe FilePath
136+ , bracketedPasteMode :: Maybe Bool
168− -- ^ Debug information is appended to this file if not
137+ -- | Debug information is appended to this file if not Nothing.
169− -- Nothing.
138+ , debugLog :: Maybe FilePath
170− , inputMap :: InputMap
171− -- ^ The (input byte, output event) pairs extend the internal
139+ -- | The (input byte, output event) pairs extend the internal input
172− -- input table of VTY and the table from terminfo.
140+ -- table of VTY and the table from terminfo.
173− --
141+ --
174− -- See "Graphics.Vty.Config" module documentation for
142+ -- See "Graphics.Vty.Config" module documentation for documentation
175− -- documentation of the @map@ directive.
143+ -- of the @map@ directive.
176− , inputFd :: Maybe Fd
144+ , inputMap :: InputMap
177− -- ^ The input file descriptor to use. The default is
145+ -- | The input file descriptor to use. The default is
178− -- 'System.Posix.IO.stdInput'
146+ -- 'System.Posix.IO.stdInput'
179− , outputFd :: Maybe Fd
147+ , inputFd :: Maybe Fd
180− -- ^ The output file descriptor to use. The default is
148+ -- | The output file descriptor to use. The default is
181− -- 'System.Posix.IO.stdOutput'
149+ -- 'System.Posix.IO.stdOutput'
182− , termName :: Maybe String
150+ , outputFd :: Maybe Fd
183− -- ^ The terminal name used to look up terminfo capabilities.
151+ -- | The terminal name used to look up terminfo capabilities.
184− -- The default is the value of the TERM environment variable.
152+ -- The default is the value of the TERM environment variable.
185− , termWidthMaps :: [(String, FilePath)]
153+ , termName :: Maybe String
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− }
202− deriving (Show, Eq)
154+ } deriving (Show, Eq)
203−
155+
204−defaultConfig :: Config
205−defaultConfig = mempty
206−
207−instance Semigroup Config where
156+instance Default Config where
208− c0 <> c1 =
157+ def = mempty
209− -- latter config takes priority for everything but inputMap
210− Config { vmin = vmin c1 <|> vmin c0
211− , vtime = vtime c1 <|> vtime c0
212− , mouseMode = mouseMode c1
213− , bracketedPasteMode = bracketedPasteMode c1
214− , debugLog = debugLog c1 <|> debugLog c0
215− , inputMap = inputMap c0 <> inputMap c1
216− , inputFd = inputFd c1 <|> inputFd c0
217− , outputFd = outputFd c1 <|> outputFd c0
218− , termName = termName c1 <|> termName c0
219− , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0
220− , allowCustomUnicodeWidthTables =
221− allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0
222− , colorMode = colorMode c1 <|> colorMode c0
223− }
224
158
225instance Monoid Config where
159instance Monoid Config where
226− mempty =
160+ mempty = Config
227− Config { vmin = Nothing
161+ { vmin = Nothing
228− , vtime = Nothing
162+ , vtime = Nothing
229− , mouseMode = Nothing
163+ , mouseMode = Nothing
230− , bracketedPasteMode = Nothing
164+ , bracketedPasteMode = Nothing
231− , debugLog = mempty
165+ , debugLog = mempty
232− , inputMap = mempty
166+ , inputMap = mempty
233− , inputFd = Nothing
167+ , inputFd = Nothing
234− , outputFd = Nothing
168+ , outputFd = Nothing
235− , termName = Nothing
169+ , termName = Nothing
236− , termWidthMaps = []
237− , allowCustomUnicodeWidthTables = Nothing
238− , colorMode = Nothing
239− }
170+ }
240−#if !(MIN_VERSION_base(4,11,0))
241− mappend = (<>)
171+ mappend c0 c1 = Config
242−#endif
172+ -- latter config takes priority for everything but inputMap
243−
173+ { vmin = vmin c1 <|> vmin c0
244−vtyDataDirectory :: IO FilePath
174+ , vtime = vtime c1 <|> vtime c0
245−vtyDataDirectory = getAppUserDataDirectory "vty"
175+ , mouseMode = mouseMode c1
246−
176+ , bracketedPasteMode = bracketedPasteMode c1
247−vtyConfigPath :: IO FilePath
177+ , debugLog = debugLog c1 <|> debugLog c0
248−vtyConfigPath = do
178+ , inputMap = inputMap c0 <> inputMap c1
249− dir <- vtyDataDirectory
179+ , inputFd = inputFd c1 <|> inputFd c0
250− return $ dir </> "config"
180+ , outputFd = outputFd c1 <|> outputFd c0
251−
181+ , termName = termName c1 <|> termName c0
252−vtyConfigFileEnvName :: String
182+ }
253−vtyConfigFileEnvName = "VTY_CONFIG_FILE"
183+
254−
184+-- | Config from @'getAppUserDataDirectory'/config@ and
255−-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
185+-- @$VTY_CONFIG_FILE@
256userConfig :: IO Config
186userConfig :: IO Config
257userConfig = do
187userConfig = do
258− configFile <- vtyConfigPath >>= parseConfigFile
188+ configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
259− overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
189+ overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
260− lookupEnv vtyConfigFileEnvName
261 let base = configFile <> overrideConfig
190 let base = configFile <> overrideConfig
262 mappend base <$> overrideEnvConfig
191 mappend base <$> overrideEnvConfig
263
192
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−
282overrideEnvConfig :: IO Config
193overrideEnvConfig :: IO Config
283overrideEnvConfig = do
194overrideEnvConfig = do
284− d <- lookupEnv "VTY_DEBUG_LOG"
195+ d <- getEnv "VTY_DEBUG_LOG"
285− return $ defaultConfig { debugLog = d }
196+ return $ def { debugLog = d }
286
197
287−-- | Configures VTY using defaults suitable for terminals. This function
198+-- | Configures VTY using defaults suitable for terminals. This action
288-- can raise 'VtyConfigurationError'.
199-- can raise 'VtyConfigurationError'.
289standardIOConfig :: IO Config
200standardIOConfig :: IO Config
290standardIOConfig = do
201standardIOConfig = do
291− mb <- lookupEnv termVariable
202+ mb <- getEnv "TERM"
292 case mb of
203 case mb of
293 Nothing -> throwIO VtyMissingTermEnvVar
204 Nothing -> throwIO VtyMissingTermEnvVar
294− Just t -> do
205+ Just t ->
295− mcolorMode <- detectColorMode t
296− return defaultConfig
206+ return def
297 { vmin = Just 1
207 { vmin = Just 1
298 , mouseMode = Just False
208 , mouseMode = Just False
299 , bracketedPasteMode = Just False
209 , bracketedPasteMode = Just False
@@ -301,24 +211,25 @@ standardIOConfig = do
301 , inputFd = Just stdInput
211 , inputFd = Just stdInput
302 , outputFd = Just stdOutput
212 , outputFd = Just stdOutput
303 , termName = Just t
213 , termName = Just t
304− , colorMode = Just mcolorMode
305 }
214 }
306
215
307parseConfigFile :: FilePath -> IO Config
216parseConfigFile :: FilePath -> IO Config
308parseConfigFile path = do
217parseConfigFile path = do
309 catch (runParseConfig path <$> BS.readFile path)
218 catch (runParseConfig path <$> BS.readFile path)
310− (\(_ :: IOException) -> return defaultConfig)
219+ (\(_ :: IOException) -> return def)
311
220
312runParseConfig :: String -> BS.ByteString -> Config
221runParseConfig :: String -> BS.ByteString -> Config
313runParseConfig name cfgTxt =
222runParseConfig name cfgTxt =
314 case runParser parseConfig () name cfgTxt of
223 case runParser parseConfig () name cfgTxt of
315 Right cfg -> cfg
224 Right cfg -> cfg
316− Left{} -> defaultConfig
225+ Left{} -> def
317
226
318------------------------------------------------------------------------
227------------------------------------------------------------------------
319
228
320type Parser = Parsec BS.ByteString ()
229type Parser = Parsec BS.ByteString ()
321
230
231+-- I tried to use the haskellStyle here but that was specialized
232+-- (without requirement?) to the String stream type.
322configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
233configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
323configLanguage = LanguageDef
234configLanguage = LanguageDef
324 { commentStart = "{-"
235 { commentStart = "{-"
@@ -345,20 +256,13 @@ mapDecl = do
345 bytes <- P.stringLiteral configLexer
256 bytes <- P.stringLiteral configLexer
346 key <- parseValue
257 key <- parseValue
347 modifiers <- parseValue
258 modifiers <- parseValue
348− return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
259+ return def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
349
260
350debugLogDecl :: Parser Config
261debugLogDecl :: Parser Config
351debugLogDecl = do
262debugLogDecl = do
352 "debugLog" <- P.identifier configLexer
263 "debugLog" <- P.identifier configLexer
353 path <- P.stringLiteral configLexer
264 path <- P.stringLiteral configLexer
354− return defaultConfig { debugLog = Just path }
265+ return def { debugLog = Just path }
355−
356−widthMapDecl :: Parser Config
357−widthMapDecl = do
358− "widthMap" <- P.identifier configLexer
359− tName <- P.stringLiteral configLexer
360− path <- P.stringLiteral configLexer
361− return defaultConfig { termWidthMaps = [(tName, path)] }
362
266
363ignoreLine :: Parser ()
267ignoreLine :: Parser ()
364ignoreLine = void $ manyTill anyChar newline
268ignoreLine = void $ manyTill anyChar newline
@@ -366,8 +270,8 @@ ignoreLine = void $ manyTill anyChar newline
366parseConfig :: Parser Config
270parseConfig :: Parser Config
367parseConfig = liftM mconcat $ many $ do
271parseConfig = liftM mconcat $ many $ do
368 P.whiteSpace configLexer
272 P.whiteSpace configLexer
369− let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]
273+ let directives = [try mapDecl, try debugLogDecl]
370− choice directives <|> (ignoreLine >> return defaultConfig)
274+ choice directives <|> (ignoreLine >> return def)
371
275
372class Parse a where parseValue :: Parser a
276class Parse a where parseValue :: Parser a
373instance Parse Char where parseValue = P.charLiteral configLexer
277instance Parse Char where parseValue = P.charLiteral configLexer
@@ -412,77 +316,3 @@ instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
412 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
316 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
413
317
414instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"
318instance 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+8−7
@@ -5,23 +5,24 @@ module Graphics.Vty.Debug
5 )
5 )
6where
6where
7
7
8+import Graphics.Vty.Prelude
9+
8import Graphics.Vty.Attributes
10import Graphics.Vty.Attributes
9−import Graphics.Vty.Image (DisplayRegion)
10import Graphics.Vty.Debug.Image
11import Graphics.Vty.Debug.Image
11import Graphics.Vty.Span
12import Graphics.Vty.Span
12
13
13import qualified Data.Vector as Vector
14import qualified Data.Vector as Vector
14
15
15−rowOpsAffectedColumns :: DisplayOps -> [Int]
16+rowOpsEffectedColumns :: DisplayOps -> [Int]
16−rowOpsAffectedColumns ops
17+rowOpsEffectedColumns ops
17− = Vector.toList $ Vector.map spanOpsAffectedColumns ops
18+ = Vector.toList $ Vector.map spanOpsEffectedColumns ops
18
19
19allSpansHaveWidth :: DisplayOps -> Int -> Bool
20allSpansHaveWidth :: DisplayOps -> Int -> Bool
20allSpansHaveWidth ops expected
21allSpansHaveWidth ops expected
21− = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops
22+ = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops
22
23
23−spanOpsAffectedRows :: DisplayOps -> Int
24+spanOpsEffectedRows :: DisplayOps -> Int
24−spanOpsAffectedRows ops
25+spanOpsEffectedRows ops
25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
26 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
26
27
27type SpanConstructLog = [SpanConstructEvent]
28type SpanConstructLog = [SpanConstructEvent]
src/Graphics/Vty/DisplayAttributes.hs+16−46
@@ -1,18 +1,20 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2−{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3+{-# LANGUAGE BangPatterns #-}
4+
5+#ifndef MIN_VERSION_base
6+#defined MIN_VERSION_base(x,y,z) 1
7+#endif
4
8
5module Graphics.Vty.DisplayAttributes where
9module Graphics.Vty.DisplayAttributes where
6
10
7import Graphics.Vty.Attributes
11import Graphics.Vty.Attributes
8
12
9import Data.Bits ((.&.))
13import Data.Bits ((.&.))
10−import Data.ByteString (ByteString)
14+
11−#if !(MIN_VERSION_base(4,11,0))
15+#if !(MIN_VERSION_base(4,8,0))
12−import Data.Semigroup (Semigroup(..))
16+import Data.Monoid (Monoid(..), mconcat)
13#endif
17#endif
14−import Data.Text (Text)
15−import Data.Text.Encoding (encodeUtf8)
16
18
17-- | Given the previously applied display attributes as a FixedAttr and
19-- | Given the previously applied display attributes as a FixedAttr and
18-- the current display attributes as an Attr produces a FixedAttr that
20-- the current display attributes as an Attr produces a FixedAttr that
@@ -24,7 +26,6 @@ fixDisplayAttr fattr attr
24 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
26 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
25 (fixColor (fixedForeColor fattr) (attrForeColor attr))
27 (fixColor (fixedForeColor fattr) (attrForeColor attr))
26 (fixColor (fixedBackColor fattr) (attrBackColor attr))
28 (fixColor (fixedBackColor fattr) (attrBackColor attr))
27− (fixURL (fixedURL fattr) (attrURL attr))
28 where
29 where
29 fixStyle _s Default = defaultStyleMask
30 fixStyle _s Default = defaultStyleMask
30 fixStyle s KeepCurrent = s
31 fixStyle s KeepCurrent = s
@@ -32,9 +33,6 @@ fixDisplayAttr fattr attr
32 fixColor _c Default = Nothing
33 fixColor _c Default = Nothing
33 fixColor c KeepCurrent = c
34 fixColor c KeepCurrent = c
34 fixColor _c (SetTo c) = Just c
35 fixColor _c (SetTo c) = Just c
35− fixURL c KeepCurrent = c
36− fixURL _c (SetTo n) = Just n
37− fixURL _c Default = Nothing
38
36
39-- | difference between two display attributes. Used in the calculation
37-- | difference between two display attributes. Used in the calculation
40-- of the operations required to go from one display attribute to the
38-- of the operations required to go from one display attribute to the
@@ -47,41 +45,32 @@ data DisplayAttrDiff = DisplayAttrDiff
47 { styleDiffs :: [StyleStateChange]
45 { styleDiffs :: [StyleStateChange]
48 , foreColorDiff :: DisplayColorDiff
46 , foreColorDiff :: DisplayColorDiff
49 , backColorDiff :: DisplayColorDiff
47 , backColorDiff :: DisplayColorDiff
50− , urlDiff :: URLDiff
51 }
48 }
52 deriving (Show)
49 deriving (Show)
53
50
54−instance Semigroup DisplayAttrDiff where
51+instance Monoid DisplayAttrDiff where
52+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange
55− d0 <> d1 =
53+ mappend d0 d1 =
56 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
54 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
57 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
55 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
58 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
56 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
59− ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
60− in DisplayAttrDiff ds fcd bcd ud
57+ in DisplayAttrDiff ds fcd bcd
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
58
68-- | Used in the computation of a final style attribute change.
59-- | Used in the computation of a final style attribute change.
60+--
61+-- TODO(corey): not really a simplify but a monoid instance.
69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
62simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
70simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
63simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
71
64
72-- | Consider two display color attributes diffs. What display color
65-- | Consider two display color attributes diffs. What display color
73-- attribute diff are these equivalent to?
66-- attribute diff are these equivalent to?
67+--
68+-- TODO(corey): not really a simplify but a monoid instance.
74simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
69simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
75simplifyColorDiffs _cd ColorToDefault = ColorToDefault
70simplifyColorDiffs _cd ColorToDefault = ColorToDefault
76simplifyColorDiffs cd NoColorChange = cd
71simplifyColorDiffs cd NoColorChange = cd
77simplifyColorDiffs _cd (SetColor !c) = SetColor c
72simplifyColorDiffs _cd (SetColor !c) = SetColor c
78
73
79−-- | Consider two URL changes, which are mostly going to be the latter
80−-- unless the latter specifies no change.
81−simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
82−simplifyUrlDiffs ud NoLinkChange = ud
83−simplifyUrlDiffs _ ud = ud
84−
85-- | Difference between two display color attribute changes.
74-- | Difference between two display color attribute changes.
86data DisplayColorDiff
75data DisplayColorDiff
87 = ColorToDefault
76 = ColorToDefault
@@ -94,10 +83,6 @@ data DisplayColorDiff
94data StyleStateChange
83data StyleStateChange
95 = ApplyStandout
84 = ApplyStandout
96 | RemoveStandout
85 | RemoveStandout
97− | ApplyItalic
98− | RemoveItalic
99− | ApplyStrikethrough
100− | RemoveStrikethrough
101 | ApplyUnderline
86 | ApplyUnderline
102 | RemoveUnderline
87 | RemoveUnderline
103 | ApplyReverseVideo
88 | ApplyReverseVideo
@@ -110,13 +95,6 @@ data StyleStateChange
110 | RemoveBold
95 | RemoveBold
111 deriving (Show, Eq)
96 deriving (Show, Eq)
112
97
113−-- Setting and unsetting hyperlinks
114−data URLDiff
115− = LinkTo !ByteString
116− | NoLinkChange
117− | EndLink
118− deriving (Show, Eq)
119−
120-- | Determines the diff between two display&color attributes. This diff
98-- | Determines the diff between two display&color attributes. This diff
121-- determines the operations that actually get output to the terminal.
99-- determines the operations that actually get output to the terminal.
122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
100displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
@@ -124,14 +102,8 @@ displayAttrDiffs attr attr' = DisplayAttrDiff
124 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
102 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
125 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
103 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
126 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
104 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
127− , urlDiff = diffURL (fixedURL attr) (fixedURL attr')
128 }
105 }
129
106
130−diffURL :: Maybe Text -> Maybe Text -> URLDiff
131−diffURL Nothing Nothing = NoLinkChange
132−diffURL (Just _) Nothing = EndLink
133−diffURL _ (Just url) = LinkTo (encodeUtf8 url)
134−
135diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
107diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
136diffColor Nothing (Just c') = SetColor c'
108diffColor Nothing (Just c') = SetColor c'
137diffColor (Just c) (Just c')
109diffColor (Just c) (Just c')
@@ -145,8 +117,6 @@ diffStyles prev cur
145 = mconcat
117 = mconcat
146 [ styleDiff standout ApplyStandout RemoveStandout
118 [ styleDiff standout ApplyStandout RemoveStandout
147 , styleDiff underline ApplyUnderline RemoveUnderline
119 , styleDiff underline ApplyUnderline RemoveUnderline
148− , styleDiff italic ApplyItalic RemoveItalic
149− , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
120 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
151 , styleDiff blink ApplyBlink RemoveBlink
121 , styleDiff blink ApplyBlink RemoveBlink
152 , styleDiff dim ApplyDim RemoveDim
122 , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Image.hs+84−154
@@ -1,35 +1,33 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2+{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE DisambiguateRecordFields #-}
4{-# LANGUAGE DisambiguateRecordFields #-}
4−-- | A Vty program makes 'Picture's from 'Image's. This module provides
5−-- the core constructors for creating, combining, and modifying
6−-- 'Image's.
7module Graphics.Vty.Image
5module Graphics.Vty.Image
8− (
6+ ( DisplayText
9− -- * Images
10− Image
7+ , Image
11 , imageWidth
8 , imageWidth
12 , imageHeight
9 , imageHeight
13− -- * Image constructors
10+ , horizJoin
14− , emptyImage
11+ , (<|>)
12+ , vertJoin
13+ , (<->)
14+ , horizCat
15+ , vertCat
16+ , backgroundFill
17+ , text
18+ , text'
15 , char
19 , char
16 , string
20 , string
17 , iso10646String
21 , iso10646String
18 , utf8String
22 , utf8String
19− , text
20− , text'
21− , backgroundFill
22 , utf8Bytestring
23 , utf8Bytestring
23 , utf8Bytestring'
24 , utf8Bytestring'
24 , charFill
25 , charFill
25− -- * Combinators
26+ , emptyImage
26− , horizJoin
27+ , safeWcwidth
27− , (<|>)
28+ , safeWcswidth
28− , vertJoin
29+ , wcwidth
29− , (<->)
30+ , wcswidth
30− , horizCat
31− , vertCat
32− -- * Image modifications
33 , crop
31 , crop
34 , cropRight
32 , cropRight
35 , cropLeft
33 , cropLeft
@@ -42,20 +40,9 @@ module Graphics.Vty.Image
42 , translate
40 , translate
43 , translateX
41 , translateX
44 , translateY
42 , translateY
45− -- * Character width functions
43+ -- | The possible display attributes used in
46− , safeWcwidth
44+ -- constructing an `Image`.
47− , safeWcswidth
45+ , module Graphics.Vty.Attributes
48− , safeWctwidth
49− , safeWctlwidth
50− , wcwidth
51− , wcswidth
52− , wctwidth
53− , wctlwidth
54− -- * Display Regions
55− , DisplayText
56− , DisplayRegion
57− , regionWidth
58− , regionHeight
59 )
46 )
60where
47where
61
48
@@ -71,80 +58,60 @@ import qualified Data.Text.Lazy as TL
71import qualified Data.Text.Lazy.Encoding as TL
58import qualified Data.Text.Lazy.Encoding as TL
72import Data.Word
59import Data.Word
73
60
74−-- | A region of the display (first width, then height)
75−type DisplayRegion = (Int,Int)
76−
77−regionWidth :: DisplayRegion -> Int
78−regionWidth = fst
79−
80−regionHeight :: DisplayRegion -> Int
81−regionHeight = snd
82−
83infixr 5 <|>
61infixr 5 <|>
84infixr 4 <->
62infixr 4 <->
85
63
86−-- | An area of the picture's background (See 'Background').
64+-- | An area of the picture's bacground (See Background) of w columns
65+-- and h rows.
87−backgroundFill :: Int
66+backgroundFill :: Int -> Int -> Image
88− -- ^ Fill width in columns
89− -> Int
90− -- ^ Fill height in rows
91− -> Image
92backgroundFill w h
67backgroundFill w h
93 | w == 0 = EmptyImage
68 | w == 0 = EmptyImage
94 | h == 0 = EmptyImage
69 | h == 0 = EmptyImage
95 | otherwise = BGFill w h
70 | otherwise = BGFill w h
96
71
97−-- | Combines two images horizontally. This is an alias for 'horizJoin'.
72+-- | Combines two images horizontally. Alias for horizJoin
98--
73--
99-- infixr 5
74-- infixr 5
100(<|>) :: Image -> Image -> Image
75(<|>) :: Image -> Image -> Image
101(<|>) = horizJoin
76(<|>) = horizJoin
102
77
103−-- | Combines two images vertically. This is an alias for 'vertJoin'.
78+-- | Combines two images vertically. Alias for vertJoin
104--
79--
105-- infixr 4
80-- infixr 4
106(<->) :: Image -> Image -> Image
81(<->) :: Image -> Image -> Image
107(<->) = vertJoin
82(<->) = vertJoin
108
83
109−-- | Compose any number of images together horizontally, with the first
84+-- | Compose any number of images horizontally.
110−-- in the list being leftmost.
111horizCat :: [Image] -> Image
85horizCat :: [Image] -> Image
112horizCat = foldr horizJoin EmptyImage
86horizCat = foldr horizJoin EmptyImage
113
87
114−-- | Compose any number of images vertically, with the first in the list
88+-- | Compose any number of images vertically.
115−-- being topmost.
116vertCat :: [Image] -> Image
89vertCat :: [Image] -> Image
117vertCat = foldr vertJoin EmptyImage
90vertCat = foldr vertJoin EmptyImage
118
91
119−-- | Make an 'Image' from a lazy text value. The text value should be
92+-- | A Data.Text.Lazy value
120−-- sanitized of escape sequences (ASCII 27) and carriage returns;
121−-- otherwise layout and attribute problems may result.
122text :: Attr -> TL.Text -> Image
93text :: Attr -> TL.Text -> Image
123−text a txt = let displayWidth = safeWctlwidth txt
94+text a txt = let displayWidth = safeWcswidth (TL.unpack txt)
124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
95 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
125
96
126−-- | Make an 'Image' from a text value. The text value should be
97+-- | A Data.Text value
127−-- sanitized of escape sequences (ASCII 27) and carriage returns;
128−-- otherwise layout and attribute problems may result.
129text' :: Attr -> T.Text -> Image
98text' :: Attr -> T.Text -> Image
130−text' a txt = let displayWidth = safeWctwidth txt
99+text' a txt = let displayWidth = safeWcswidth (T.unpack txt)
131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
100 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
132
101
133−-- | Make an image from a single character. This is a standard Haskell
102+-- | An image of a single character. This is a standard Haskell 31-bit
134−-- 31-bit character assumed to be in the ISO-10646 encoding.
103+-- character assumed to be in the ISO-10646 encoding.
135char :: Attr -> Char -> Image
104char :: Attr -> Char -> Image
136char a c =
105char a c =
137 let displayWidth = safeWcwidth c
106 let displayWidth = safeWcwidth c
138 in HorizText a (TL.singleton c) displayWidth 1
107 in HorizText a (TL.singleton c) displayWidth 1
139
108
140−-- | Make an image from a string of characters laid out on a single
109+-- | A string of characters layed out on a single row with the same
141−-- row with the same display attribute. The string is assumed to be a
110+-- display attribute. The string is assumed to be a sequence of
142−-- sequence of ISO-10646 characters. The input string should be
111+-- ISO-10646 characters.
143−-- sanitized of escape sequences (ASCII 27) and carriage returns;
144−-- otherwise layout and attribute problems may result.
145--
112--
146-- Note: depending on how the Haskell compiler represents string
113-- Note: depending on how the Haskell compiler represents string
147−-- literals, a string literal in a UTF-8 encoded source file, for
114+-- literals a string literal in a UTF-8 encoded source file, for
148-- example, may be represented as a ISO-10646 string. That is, I think,
115-- example, may be represented as a ISO-10646 string. That is, I think,
149-- the case with GHC 6.10. This means, for the most part, you don't need
116-- the case with GHC 6.10. This means, for the most part, you don't need
150-- to worry about the encoding format when outputting string literals.
117-- to worry about the encoding format when outputting string literals.
@@ -154,11 +121,9 @@ iso10646String a str =
154 let displayWidth = safeWcswidth str
121 let displayWidth = safeWcswidth str
155 in HorizText a (TL.pack str) displayWidth (length str)
122 in HorizText a (TL.pack str) displayWidth (length str)
156
123
157−-- | Make an 'Image' from a 'String'.
158−--
159−-- This is an alias for iso10646String since the usual case is that a
124+-- | Alias for iso10646String. Since the usual case is that a literal
160−-- literal string like "foo" is represented internally as a list of ISO
125+-- string like "foo" is represented internally as a list of ISO 10646 31
161−-- 10646 31 bit characters.
126+-- bit characters.
162--
127--
163-- Note: Keep in mind that GHC will compile source encoded as UTF-8
128-- Note: Keep in mind that GHC will compile source encoded as UTF-8
164-- but the literal strings, while UTF-8 encoded in the source, will be
129-- but the literal strings, while UTF-8 encoded in the source, will be
@@ -166,68 +131,46 @@ iso10646String a str =
166string :: Attr -> String -> Image
131string :: Attr -> String -> Image
167string = iso10646String
132string = iso10646String
168
133
169−-- | Make an 'Image' from a string of characters layed out on a single
134+-- | A string of characters layed out on a single row. The input is
170−-- row. The input is assumed to be the bytes for UTF-8 encoded text.
135+-- assumed to be the bytes for UTF-8 encoded text.
171utf8String :: Attr -> [Word8] -> Image
136utf8String :: Attr -> [Word8] -> Image
172utf8String a bytes = utf8Bytestring a (BL.pack bytes)
137utf8String a bytes = utf8Bytestring a (BL.pack bytes)
173
138
174−-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
139+-- | Renders a UTF-8 encoded lazy bytestring.
175utf8Bytestring :: Attr -> BL.ByteString -> Image
140utf8Bytestring :: Attr -> BL.ByteString -> Image
176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
141utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
177
142
178−-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
143+-- | Renders a UTF-8 encoded strict bytestring.
179utf8Bytestring' :: Attr -> B.ByteString -> Image
144utf8Bytestring' :: Attr -> B.ByteString -> Image
180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
145utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
181
146
182−-- | Make an image filling a region with the specified character.
147+-- | Creates a fill of the specified character. The dimensions are in
183−--
148+-- number of characters wide and number of rows high.
184−-- If either the width or height are less than or equal to 0, then
185−-- the result is the empty image.
186−charFill :: Integral d
149+charFill :: Integral d => Attr -> Char -> d -> d -> Image
187− => Attr
188− -- ^ The attribute to use.
189− -> Char
190− -- ^ The character to use in filling the region.
191− -> d
192− -- ^ The region width.
193− -> d
194− -- ^ The region height.
195− -> Image
196−charFill a c w h
150+charFill _a _c 0 _h = EmptyImage
197− | w <= 0 || h <= 0 = EmptyImage
151+charFill _a _c _w 0 = EmptyImage
198− | otherwise = vertCat
152+charFill a c w h =
199− $ replicate (fromIntegral h)
200− $ HorizText a txt displayWidth charWidth
153+ vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth
201− where
154+ where
202− txt = TL.replicate charWidth (TL.singleton c)
155+ txt = TL.replicate (fromIntegral w) (TL.singleton c)
203− displayWidth = safeWcwidth c * charWidth
156+ displayWidth = safeWcwidth c * (fromIntegral w)
204−
205− charWidth :: Num a => a
206− charWidth = fromIntegral w
157+ charWidth = fromIntegral w
207
158
208-- | The empty image. Useful for fold combinators. These occupy no space
159-- | The empty image. Useful for fold combinators. These occupy no space
209−-- and do not affect display attributes.
160+-- nor define any display attributes.
210emptyImage :: Image
161emptyImage :: Image
211emptyImage = EmptyImage
162emptyImage = EmptyImage
212
163
213-- | Pad the given image. This adds background character fills to the
164-- | Pad the given image. This adds background character fills to the
214−-- left, top, right, bottom.
165+-- left, top, right, bottom. The pad values are how many display columns
215−pad :: Int
166+-- or rows to add.
216− -- ^ How much padding to add to the left side of the image.
167+pad :: Int -> Int -> Int -> Int -> Image -> Image
217− -> Int
218− -- ^ How much padding to add to the top of the image.
219− -> Int
220− -- ^ How much padding to add to the right side of the image.
221− -> Int
222− -- ^ How much padding to add to the bottom of the image.
223− -> Image
224− -- ^ The image to pad.
225− -> Image
226pad 0 0 0 0 i = i
168pad 0 0 0 0 i = i
227pad inL inT inR inB inImage
169pad inL inT inR inB inImage
228 | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
170 | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
229 | otherwise = go inL inT inR inB inImage
171 | otherwise = go inL inT inR inB inImage
230 where
172 where
173+ -- TODO: uh.
231 go 0 0 0 0 i = i
174 go 0 0 0 0 i = i
232 go 0 0 0 b i = VertJoin i (BGFill w b) w h
175 go 0 0 0 b i = VertJoin i (BGFill w b) w h
233 where w = imageWidth i
176 where w = imageWidth i
@@ -243,29 +186,24 @@ pad inL inT inR inB inImage
243 h = imageHeight i
186 h = imageHeight i
244
187
245-- | Translates an image by padding or cropping the left and top.
188-- | Translates an image by padding or cropping the left and top.
189+-- First param is amount to translate left. Second param is amount to
190+-- translate top.
246--
191--
247−-- If translation offsets are negative then the image is cropped.
192+-- This can have an unexpected effect: Translating an image to less than
193+-- (0,0) then to greater than (0,0) will crop the image.
248−translate :: Int
194+translate :: Int -> Int -> Image -> Image
249− -- ^ The horizontal translation offset (can be negative)
250− -> Int
251− -- ^ The vertical translation offset (can be negative)
252− -> Image
253− -- ^ The image to translate.
254− -> Image
255translate x y i = translateX x (translateY y i)
195translate x y i = translateX x (translateY y i)
256
196
257−-- | Translates an image by padding or cropping its left side.
197+-- | translates an image by padding or cropping the left
258translateX :: Int -> Image -> Image
198translateX :: Int -> Image -> Image
259translateX x i
199translateX x i
260− | x < 0 && (abs x > imageWidth i) = emptyImage
261 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)
200 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)
262 | x == 0 = i
201 | x == 0 = i
263 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h
202 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h
264
203
265−-- | Translates an image by padding or cropping its top.
204+-- | translates an image by padding or cropping the top
266translateY :: Int -> Image -> Image
205translateY :: Int -> Image -> Image
267translateY y i
206translateY y i
268− | y < 0 && (abs y > imageHeight i) = emptyImage
269 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)
207 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)
270 | y == 0 = i
208 | y == 0 = i
271 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)
209 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)
@@ -273,22 +211,16 @@ translateY y i
273-- | Ensure an image is no larger than the provided size. If the image
211-- | Ensure an image is no larger than the provided size. If the image
274-- is larger then crop the right or bottom.
212-- is larger then crop the right or bottom.
275--
213--
276−-- This is equivalent to a vertical crop from the bottom followed by
214+-- This is transformed to a vertical crop from the bottom followed by
277-- horizontal crop from the right.
215-- horizontal crop from the right.
278−crop :: Int
216+crop :: Int -> Int -> Image -> Image
279− -- ^ Cropping width
280− -> Int
281− -- ^ Cropping height
282− -> Image
283− -- ^ The image to crop
284− -> Image
285crop 0 _ _ = EmptyImage
217crop 0 _ _ = EmptyImage
286crop _ 0 _ = EmptyImage
218crop _ 0 _ = EmptyImage
287crop w h i = cropBottom h (cropRight w i)
219crop w h i = cropBottom h (cropRight w i)
288
220
289−-- | Crop an image's height. If the image's height is less than or equal
221+-- | crop the display height. If the image is less than or equal in
290−-- to the specified height then this operation has no effect. Otherwise
222+-- height then this operation has no effect. Otherwise the image is
291−-- the image is cropped from the bottom.
223+-- cropped from the bottom.
292cropBottom :: Int -> Image -> Image
224cropBottom :: Int -> Image -> Image
293cropBottom 0 _ = EmptyImage
225cropBottom 0 _ = EmptyImage
294cropBottom h inI
226cropBottom h inI
@@ -303,9 +235,8 @@ cropBottom h inI
303 | h >= imageHeight i = i
235 | h >= imageHeight i = i
304 | otherwise = CropBottom i (imageWidth i) h
236 | otherwise = CropBottom i (imageWidth i) h
305
237
306−-- | Crop an image's width. If the image's width is less than or equal
238+-- | ensure the image is no wider than the given width. If the image is
307−-- to the specified width then this operation has no effect. Otherwise
239+-- wider then crop the right side.
308−-- the image is cropped from the right.
309cropRight :: Int -> Image -> Image
240cropRight :: Int -> Image -> Image
310cropRight 0 _ = EmptyImage
241cropRight 0 _ = EmptyImage
311cropRight w inI
242cropRight w inI
@@ -320,9 +251,8 @@ cropRight w inI
320 | w >= imageWidth i = i
251 | w >= imageWidth i = i
321 | otherwise = CropRight i w (imageHeight i)
252 | otherwise = CropRight i w (imageHeight i)
322
253
323−-- | Crop an image's width. If the image's width is less than or equal
254+-- | ensure the image is no wider than the given width. If the image is
324−-- to the specified width then this operation has no effect. Otherwise
255+-- wider then crop the left side.
325−-- the image is cropped from the left.
326cropLeft :: Int -> Image -> Image
256cropLeft :: Int -> Image -> Image
327cropLeft 0 _ = EmptyImage
257cropLeft 0 _ = EmptyImage
328cropLeft w inI
258cropLeft w inI
@@ -339,9 +269,9 @@ cropLeft w inI
339 | imageWidth i <= w = i
269 | imageWidth i <= w = i
340 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
270 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
341
271
342−-- | Crop an image's height. If the image's height is less than or equal
272+-- | crop the display height. If the image is less than or equal in
343−-- to the specified height then this operation has no effect. Otherwise
273+-- height then this operation has no effect. Otherwise the image is
344−-- the image is cropped from the top.
274+-- cropped from the top.
345cropTop :: Int -> Image -> Image
275cropTop :: Int -> Image -> Image
346cropTop 0 _ = EmptyImage
276cropTop 0 _ = EmptyImage
347cropTop h inI
277cropTop h inI
@@ -358,14 +288,14 @@ cropTop h inI
358 | imageHeight i <= h = i
288 | imageHeight i <= h = i
359 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
289 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
360
290
361−-- | Generic resize. Pads and crops are added to ensure that the
291+-- | Generic resize. Pads and crops as required to assure the given
362−-- resulting image matches the specified dimensions. This is biased to
363−-- pad/crop the right and bottom.
292+-- display width and height. This is biased to pad/crop the right and
293+-- bottom.
364resize :: Int -> Int -> Image -> Image
294resize :: Int -> Int -> Image -> Image
365resize w h i = resizeHeight h (resizeWidth w i)
295resize w h i = resizeHeight h (resizeWidth w i)
366
296
367-- | Resize the width. Pads and crops as required to assure the given
297-- | Resize the width. Pads and crops as required to assure the given
368−-- display width. This is biased to pad/crop on the right.
298+-- display width. This is biased to pad/crop the right.
369resizeWidth :: Int -> Image -> Image
299resizeWidth :: Int -> Image -> Image
370resizeWidth w i = case w `compare` imageWidth i of
300resizeWidth w i = case w `compare` imageWidth i of
371 LT -> cropRight w i
301 LT -> cropRight w i
@@ -373,7 +303,7 @@ resizeWidth w i = case w `compare` imageWidth i of
373 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
303 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
374
304
375-- | Resize the height. Pads and crops as required to assure the given
305-- | Resize the height. Pads and crops as required to assure the given
376−-- display height. This is biased to pad/crop on the bottom.
306+-- display height. This is biased to pad/crop the bottom.
377resizeHeight :: Int -> Image -> Image
307resizeHeight :: Int -> Image -> Image
378resizeHeight h i = case h `compare` imageHeight i of
308resizeHeight h i = case h `compare` imageHeight i of
379 LT -> cropBottom h i
309 LT -> cropBottom h i
src/Graphics/Vty/Image/Internal.hs+55−16
@@ -3,6 +3,10 @@
3{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# OPTIONS_HADDOCK hide #-}
4{-# OPTIONS_HADDOCK hide #-}
5
5
6+#ifndef MIN_VERSION_base
7+#defined MIN_VERSION_base(x,y,z) 1
8+#endif
9+
6module Graphics.Vty.Image.Internal where
10module Graphics.Vty.Image.Internal where
7
11
8import Graphics.Vty.Attributes
12import Graphics.Vty.Attributes
@@ -12,14 +16,25 @@ import GHC.Generics
12
16
13import Control.DeepSeq
17import Control.DeepSeq
14
18
15−#if !(MIN_VERSION_base(4,11,0))
16−import Data.Semigroup (Semigroup(..))
17−#endif
18import qualified Data.Text.Lazy as TL
19import qualified Data.Text.Lazy as TL
19
20
21+#if !(MIN_VERSION_base(4,8,0))
22+import Data.Monoid
23+#endif
24+
20-- | A display text is a Data.Text.Lazy
25-- | A display text is a Data.Text.Lazy
26+--
27+-- TODO(corey): hm. there is an explicit equation for each type which
28+-- goes to a lazy text. Each application probably uses a single type.
29+-- Perhaps parameterize the entire vty interface by the input text type?
30+-- TODO: Try using a builder instead of a TL.Text instance directly.
31+-- That might improve performance for the usual case of appending a
32+-- bunch of characters with the same attribute together.
21type DisplayText = TL.Text
33type DisplayText = TL.Text
22
34
35+-- TODO: store a skip list in HorizText(?)
36+-- TODO: represent display strings containing chars that are not 1
37+-- column chars as a separate display string value?
23clipText :: DisplayText -> Int -> Int -> DisplayText
38clipText :: DisplayText -> Int -> Int -> DisplayText
24clipText txt leftSkip rightClip =
39clipText txt leftSkip rightClip =
25 -- CPS would clarify this I think
40 -- CPS would clarify this I think
@@ -142,11 +157,37 @@ data Image =
142 --
157 --
143 -- Any image of zero size equals the empty image.
158 -- Any image of zero size equals the empty image.
144 | EmptyImage
159 | EmptyImage
145− deriving (Eq, Generic, Show, Read)
160+ deriving (Eq, Generic)
161+
162+instance Show Image where
163+ show ( HorizText { attr, displayText, outputWidth, charWidth } )
164+ = "HorizText " ++ show displayText
165+ ++ "@(" ++ show attr ++ ","
166+ ++ show outputWidth ++ ","
167+ ++ show charWidth ++ ")"
168+ show ( BGFill { outputWidth, outputHeight } )
169+ = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"
170+ show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )
171+ = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
172+ show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )
173+ = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
174+ show ( CropRight { croppedImage, outputWidth, outputHeight } )
175+ = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
176+ ++ " (" ++ show croppedImage ++ ")"
177+ show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )
178+ = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
179+ ++ " (" ++ show croppedImage ++ ")"
180+ show ( CropBottom { croppedImage, outputWidth, outputHeight } )
181+ = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
182+ ++ " (" ++ show croppedImage ++ ")"
183+ show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )
184+ = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
185+ ++ " (" ++ show croppedImage ++ ")"
186+ show ( EmptyImage ) = "EmptyImage"
146
187
147-- | pretty print just the structure of an image.
188-- | pretty print just the structure of an image.
148ppImageStructure :: Image -> String
189ppImageStructure :: Image -> String
149−ppImageStructure = go 0
190+ppImageStructure inImg = go 0 inImg
150 where
191 where
151 go indent img = tab indent ++ pp indent img
192 go indent img = tab indent ++ pp indent img
152 tab indent = concat $ replicate indent " "
193 tab indent = concat $ replicate indent " "
@@ -210,16 +251,10 @@ imageHeight CropBottom { outputHeight = h } = h
210imageHeight CropTop { outputHeight = h } = h
251imageHeight CropTop { outputHeight = h } = h
211imageHeight EmptyImage = 0
252imageHeight EmptyImage = 0
212
253
213−-- | Append in the 'Semigroup' instance is equivalent to '<->'.
214−instance Semigroup Image where
215− (<>) = vertJoin
216−
217−-- | Append in the 'Monoid' instance is equivalent to '<->'.
254+-- | Append in the Monoid instance is equivalent to <->.
218instance Monoid Image where
255instance Monoid Image where
219 mempty = EmptyImage
256 mempty = EmptyImage
220−#if !(MIN_VERSION_base(4,11,0))
221− mappend = (<>)
257+ mappend = vertJoin
222−#endif
223
258
224-- | combines two images side by side
259-- | combines two images side by side
225--
260--
@@ -228,14 +263,16 @@ instance Monoid Image where
228--
263--
229-- The result image will have a width equal to the sum of the two images
264-- The result image will have a width equal to the sum of the two images
230-- width. And the height will equal the largest height of the two
265-- width. And the height will equal the largest height of the two
231−-- images. The area not defined in one image due to a height mismatch
266+-- images. The area not defined in one image due to a height missmatch
232-- will be filled with the background pattern.
267-- will be filled with the background pattern.
268+--
269+-- TODO: the bg fill is biased towards top to bottom languages(?)
233horizJoin :: Image -> Image -> Image
270horizJoin :: Image -> Image -> Image
234horizJoin EmptyImage i = i
271horizJoin EmptyImage i = i
235horizJoin i EmptyImage = i
272horizJoin i EmptyImage = i
236horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)
273horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)
237 | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)
274 | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)
238− -- assumes horiz text height is always 1
275+ -- TODO: assumes horiz text height is always 1
239 | otherwise = HorizJoin i0 i1 (w0 + w1) 1
276 | otherwise = HorizJoin i0 i1 (w0 + w1) 1
240horizJoin i0 i1
277horizJoin i0 i1
241 -- If the images are of the same height then no padding is required
278 -- If the images are of the same height then no padding is required
@@ -259,8 +296,10 @@ horizJoin _ _ = error "horizJoin applied to undefined values."
259--
296--
260-- The result image will have a height equal to the sum of the heights
297-- The result image will have a height equal to the sum of the heights
261-- of both images. The width will equal the largest width of the two
298-- of both images. The width will equal the largest width of the two
262−-- images. The area not defined in one image due to a width mismatch
299+-- images. The area not defined in one image due to a width missmatch
263-- will be filled with the background pattern.
300-- will be filled with the background pattern.
301+--
302+-- TODO: the bg fill is biased towards right to left languages(?)
264vertJoin :: Image -> Image -> Image
303vertJoin :: Image -> Image -> Image
265vertJoin EmptyImage i = i
304vertJoin EmptyImage i = i
266vertJoin i EmptyImage = i
305vertJoin i EmptyImage = i
src/Graphics/Vty/Inline.hs+43−42
@@ -1,12 +1,19 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE BangPatterns #-}
3+
4+#ifndef MIN_VERSION_base
5+#defined MIN_VERSION_base(x,y,z) 1
6+#endif
7+
1-- | The inline module provides a limited interface to changing the
8-- | The inline module provides a limited interface to changing the
2-- style of terminal output. The intention is for this interface to be
9-- style of terminal output. The intention is for this interface to be
3-- used inline with other output systems.
10-- used inline with other output systems.
4--
11--
5-- The changes specified by the InlineM monad are applied to the
12-- The changes specified by the InlineM monad are applied to the
6−-- terminal's display attributes. These display attributes affect the
13+-- terminals display attributes. These display attributes effect the
7-- display of all following text output to the terminal file descriptor.
14-- display of all following text output to the terminal file descriptor.
8--
15--
9−-- For example, in an IO monad the following code will print the text
16+-- For example, in an IO monad the following code with print the text
10-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
17-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
11-- background and underlined.
18-- background and underlined.
12--
19--
@@ -20,11 +27,11 @@
20-- putStrLn \"Not styled.\"
27-- putStrLn \"Not styled.\"
21-- @
28-- @
22--
29--
23−-- 'putAttrChange' emits the control codes to the terminal device
30+-- 'putAttrChange' outputs the control codes to the terminal device
24−-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when
31+-- 'Handle'. This is a duplicate of the 'stdout' handle when the
25−-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been
32+-- 'terminalHandle' was (first) acquired. If 'stdout' has since been
26−-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a
33+-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a
27−-- different 'Handle' than 'putAttrChange'.
34+-- different 'Handle' than 'putAttrChange'
28--
35--
29-- Copyright 2009-2010 Corey O'Connor
36-- Copyright 2009-2010 Corey O'Connor
30module Graphics.Vty.Inline
37module Graphics.Vty.Inline
@@ -36,6 +43,7 @@ where
36import Graphics.Vty
43import Graphics.Vty
37import Graphics.Vty.DisplayAttributes
44import Graphics.Vty.DisplayAttributes
38import Graphics.Vty.Inline.Unsafe
45import Graphics.Vty.Inline.Unsafe
46+import Graphics.Vty.Output.Interface
39
47
40import Blaze.ByteString.Builder (writeToByteString)
48import Blaze.ByteString.Builder (writeToByteString)
41
49
@@ -46,52 +54,44 @@ import Data.IORef
46
54
47import System.IO
55import System.IO
48
56
49−type InlineM v = State InlineState v
57+#if !(MIN_VERSION_base(4,8,0))
58+import Control.Applicative
59+import Data.Monoid ( mappend )
60+#endif
50
61
51−data InlineState =
62+type InlineM v = State Attr v
52− InlineState { inlineAttr :: Attr
53− , inlineUrlsEnabled :: Bool
54− }
55
63
56−-- | Set the background color to the provided 'Color'.
64+-- | Set the background color to the provided 'Color'
57backColor :: Color -> InlineM ()
65backColor :: Color -> InlineM ()
58−backColor c = modify $ \s ->
66+backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )
59− s { inlineAttr = inlineAttr s `withBackColor` c
60− }
61
67
62−-- | Set the foreground color to the provided 'Color'.
68+-- | Set the foreground color to the provided 'Color'
63foreColor :: Color -> InlineM ()
69foreColor :: Color -> InlineM ()
64−foreColor c = modify $ \s ->
70+foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )
65− s { inlineAttr = inlineAttr s `withForeColor` c
66− }
67
71
68−-- | Attempt to change the 'Style' of the following text..
72+-- | Attempt to change the 'Style' of the following text.
69--
73--
70−-- If the terminal does not support the style change then no error is
74+-- If the terminal does not support the style change no error is
71-- produced. The style can still be removed.
75-- produced. The style can still be removed.
72applyStyle :: Style -> InlineM ()
76applyStyle :: Style -> InlineM ()
73−applyStyle st = modify $ \s ->
77+applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
74− s { inlineAttr = inlineAttr s `withStyle` st
75− }
76
78
77-- | Attempt to remove the specified 'Style' from the display of the
79-- | Attempt to remove the specified 'Style' from the display of the
78-- following text.
80-- following text.
79--
81--
80−-- This will fail if 'applyStyle' for the given style has not been
82+-- This will fail if applyStyle for the given style has not been
81-- previously called.
83-- previously called.
82removeStyle :: Style -> InlineM ()
84removeStyle :: Style -> InlineM ()
83−removeStyle sMask = modify $ \s ->
85+removeStyle sMask = modify $ \attr ->
84− s { inlineAttr =
85− let style' = case attrStyle (inlineAttr s) of
86+ let style' = case attrStyle attr of
86− Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
87+ Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
87− KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
88+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
88− SetTo st -> st .&. complement sMask
89+ SetTo s -> s .&. complement sMask
89− in (inlineAttr s) { attrStyle = SetTo style' }
90+ in attr { attrStyle = SetTo style' }
90− }
91+
91−
92−-- | Reset the display attributes.
92+-- | Reset the display attributes
93defaultAll :: InlineM ()
93defaultAll :: InlineM ()
94−defaultAll = modify $ \s -> s { inlineAttr = defAttr }
94+defaultAll = put defAttr
95
95
96-- | Apply the provided display attribute changes to the given terminal
96-- | Apply the provided display attribute changes to the given terminal
97-- output device.
97-- output device.
@@ -104,19 +104,20 @@ putAttrChange out c = liftIO $ do
104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
105 fattr <- case mfattr of
105 fattr <- case mfattr of
106 Nothing -> do
106 Nothing -> do
107− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
107+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
108− return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
108+ return $ FixedAttr defaultStyleMask Nothing Nothing
109 Just v -> return v
109 Just v -> return v
110− let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
110+ let attr = execState c currentAttr
111 attr' = limitAttrForDisplay out attr
111 attr' = limitAttrForDisplay out attr
112 fattr' = fixDisplayAttr fattr attr'
112 fattr' = fixDisplayAttr fattr attr'
113 diffs = displayAttrDiffs fattr fattr'
113 diffs = displayAttrDiffs fattr fattr'
114− outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
114+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
116 inlineHack dc
116 inlineHack dc
117
117
118-- | Apply the provided display attributes changes to the terminal
118-- | Apply the provided display attributes changes to the terminal
119−-- output device.
119+-- output device that was current at the time this was first used.
120+-- Which, for most use cases, is the current terminal.
120--
121--
121-- This will flush the terminal output.
122-- This will flush the terminal output.
122putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
123putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
src/Graphics/Vty/Inline/Unsafe.hs+12−1
@@ -1,9 +1,16 @@
1+{-# LANGUAGE CPP #-}
1{-# OPTIONS_HADDOCK hide #-}
2{-# OPTIONS_HADDOCK hide #-}
2
3
4+#ifndef MIN_VERSION_base
5+#defined MIN_VERSION_base(x,y,z) 1
6+#endif
7+
3module Graphics.Vty.Inline.Unsafe where
8module Graphics.Vty.Inline.Unsafe where
4
9
5import Graphics.Vty
10import Graphics.Vty
6
11
12+import Data.Default
13+import Data.Monoid
7import Data.IORef
14import Data.IORef
8
15
9import GHC.IO.Handle (hDuplicate)
16import GHC.IO.Handle (hDuplicate)
@@ -14,6 +21,10 @@ import System.IO.Unsafe
14
21
15import System.Posix.IO (handleToFd)
22import System.Posix.IO (handleToFd)
16
23
24+#if !(MIN_VERSION_base(4,8,0))
25+import Control.Applicative
26+#endif
27+
17globalVty :: IORef (Maybe Vty)
28globalVty :: IORef (Maybe Vty)
18{-# NOINLINE globalVty #-}
29{-# NOINLINE globalVty #-}
19globalVty = unsafePerformIO $ newIORef Nothing
30globalVty = unsafePerformIO $ newIORef Nothing
@@ -28,7 +39,7 @@ mkDupeConfig = do
28 hSetBuffering stdin NoBuffering
39 hSetBuffering stdin NoBuffering
29 stdinDupe <- hDuplicate stdin >>= handleToFd
40 stdinDupe <- hDuplicate stdin >>= handleToFd
30 stdoutDupe <- hDuplicate stdout >>= handleToFd
41 stdoutDupe <- hDuplicate stdout >>= handleToFd
31− return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
42+ return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
32
43
33-- | This will create a Vty instance using 'mkVty' and execute an IO
44-- | This will create a Vty instance using 'mkVty' and execute an IO
34-- action provided that instance. The created Vty instance will be
45-- action provided that instance. The created Vty instance will be
src/Graphics/Vty/Input.hs+123−67
@@ -1,116 +1,147 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE RecordWildCards #-}
2
3
3−-- | This module provides the input layer for Vty, including methods
4+#ifndef MIN_VERSION_base
5+#defined MIN_VERSION_base(x,y,z) 1
6+#endif
7+
8+-- | The input layer for VTY. This provides methods for initializing an
4−-- for initializing an 'Input' structure and reading 'Event's from the
9+-- 'Input' structure which can then be used to read 'Event's from the
5-- terminal.
10-- terminal.
6--
11--
7−-- Note that due to the evolution of terminal emulators, some keys
12+-- The history of terminals has resulted in a broken input process. Some
8−-- and combinations will not reliably map to the expected events by
13+-- keys and combinations will not reliably map to the expected events
9−-- any terminal program. There is no 1:1 mapping from key events to
14+-- by any terminal program. Even those not using vty. There is no 1:1
10−-- bytes read from the terminal input device. In very limited cases the
15+-- mapping from key events to bytes read from the terminal input device.
11−-- terminal and vty's input process can be customized to resolve these
16+-- In very limited cases the terminal and vty's input process can be
17+-- customized to resolve these issues.
18+--
12−-- issues; see "Graphics.Vty.Config" for how to configure vty's input
19+-- See "Graphics.Vty.Config" for how to configure vty's input
13−-- processing.
20+-- processing. Customizing terminfo and the terminal is beyond the scope
21+-- of this documentation.
14--
22--
15-- = VTY's Implementation
23-- = VTY's Implementation
16--
24--
17-- There are two input modes:
25-- There are two input modes:
18--
26--
19−-- 1. 7-bit
27+-- 1. 7 bit
20--
28--
21−-- 2. 8-bit
29+-- 2. 8 bit
22--
30--
23−-- The 7-bit input mode is the default and the expected mode in most use
31+-- 7 bit input is the default and the expected in most use cases. This
24−-- cases. This is what Vty uses.
32+-- is what vty uses.
25--
33--
26−-- == 7-bit input encoding
34+-- == 7 bit input encoding
27--
35--
28-- Control key combinations are represented by masking the two high bits
36-- Control key combinations are represented by masking the two high bits
29−-- of the 7-bit input. Historically the control key actually grounded
37+-- of the 7bit input. Back in the day the control key actually grounded
30−-- the two high bit wires: 6 and 7. This is why control key combos
38+-- the two high bit wires: 6 and 7. This is why control key combos map
31−-- map to single character events: the input bytes are identical. The
39+-- to single character events: The input bytes are identical. The input
32−-- input byte is the bit encoding of the character with bits 6 and 7
40+-- byte is the bit encoding of the character with bits 6 and 7 masked.
33−-- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For
41+-- Bit 6 is set by shift. Bit 6 and 7 are masked by control. EG:
34−-- example,
35--
42--
36−-- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become
43+-- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become
37−-- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key.
44+-- `00001001`. Which is the ASCII and UTF-8 encoding of the tab key.
38--
45--
39-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
46-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
40−-- which is `0000011` and is the "End of Text" code.
47+-- which makes `0000011` and is the "End of Text" code.
41--
48--
42−-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this
49+-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This
43-- is the value 1 with bit 7 set and 6 unset.
50-- is the value 1 with bit 7 set and 6 unset.
44--
51--
45-- * Hypothesis: Bit 6 is unset by upper case letters because,
52-- * Hypothesis: Bit 6 is unset by upper case letters because,
46-- initially, there were only upper case letters used and a 5 bit
53-- initially, there were only upper case letters used and a 5 bit
47-- encoding.
54-- encoding.
48--
55--
49−-- == 8-bit encoding
56+-- == 8 bit encoding
50--
57--
51−-- The 8th bit was originally used for parity checking which is useless
58+-- The 8th bit was originally used for parity checking. Useless for
52−-- for terminal emulators. Some terminal emulators support an 8-bit
59+-- emulators. Some terminal emulators support a 8 bit input encoding.
53−-- input encoding. While this provides some advantages, the actual usage
60+-- While this provides some advantages the actual usage is low. Most
54−-- is low. Most systems use 7-bit mode but recognize 8-bit control
61+-- systems use 7bit mode but recognize 8bit control characters when
55−-- characters when escaped. This is what Vty does.
62+-- escaped. This is what vty does.
56--
63--
57-- == Escaped Control Keys
64-- == Escaped Control Keys
58--
65--
59−-- Using 7-bit input encoding, the @ESC@ byte can signal the start of
66+-- Using 7 bit input encoding the @ESC@ byte can signal the start of
60−-- an encoded control key. To differentiate a single @ESC@ event from a
67+-- an encoded control key. To differentiate a single @ESC@ eventfrom a
61−-- control key, the timing of the input is used.
68+-- control key the timing of the input is used.
62--
69--
63−-- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of
70+-- 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'.
64−-- 'VMIN' milliseconds.
65--
71--
66−-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte
72+-- 2. control keys that contain @ESC@ in their encoding: The @ESC byte;
67−-- is followed by more bytes read within 'VMIN' milliseconds. All bytes
73+-- followed by more bytes read within 'singleEscPeriod'. All bytes up
68−-- up until the next valid input block are passed to the classifier.
74+-- until the next valid input block are passed to the classifier.
69--
75--
70-- If the current runtime is the threaded runtime then the terminal's
76-- If the current runtime is the threaded runtime then the terminal's
71-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
77-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
72−-- the current runtime does not support 'forkOS' then there is currently
78+-- the current runtime does not support forkOS then there is currently
73-- no implementation.
79-- no implementation.
74--
80--
81+-- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop
82+-- which did tricky things with non-blocking reads and timers. The
83+-- implementation was not reliable. A reliable implementation is
84+-- possible, but there are no plans to implement this.
85+--
75-- == Unicode Input and Escaped Control Key Sequences
86-- == Unicode Input and Escaped Control Key Sequences
76--
87--
77-- The input encoding determines how UTF-8 encoded characters are
88-- The input encoding determines how UTF-8 encoded characters are
78−-- recognized.
89+-- recognize.
79--
90--
80−-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
91+-- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is
81-- a superset of ASCII. UTF-8 does not overlap escaped control key
92-- a superset of ASCII. UTF-8 does not overlap escaped control key
82-- sequences. However, the escape key must be differentiated from
93-- sequences. However, the escape key must be differentiated from
83-- escaped control key sequences by the timing of the input bytes.
94-- escaped control key sequences by the timing of the input bytes.
84--
95--
85−-- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not
96+-- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not
86-- require using the timing of input bytes to differentiate the escape
97-- require using the timing of input bytes to differentiate the escape
87−-- key. Many terminals do not support 8-bit mode.
98+-- key. Many terminals do not support 8 bit mode.
88--
99--
89-- == Terminfo
100-- == Terminfo
90--
101--
91-- The terminfo system is used to determine how some keys are encoded.
102-- The terminfo system is used to determine how some keys are encoded.
92−-- Terminfo is incomplete and in some cases terminfo is incorrect. Vty
103+-- Terminfo is incomplete. In some cases terminfo is incorrect. Vty
93-- assumes terminfo is correct but provides a mechanism to override
104-- assumes terminfo is correct but provides a mechanism to override
94−-- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'.
105+-- terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'.
95--
106--
96-- == Terminal Input is Broken
107-- == Terminal Input is Broken
97--
108--
98−-- Clearly terminal input has fundamental issues. There is no easy way
109+-- Clearly terminal input has fundemental issues. There is no easy way
99-- to reliably resolve these issues.
110-- to reliably resolve these issues.
100--
111--
101-- One resolution would be to ditch standard terminal interfaces
112-- One resolution would be to ditch standard terminal interfaces
102−-- entirely and just go directly to scancodes. This would be a
113+-- entirely and just go directly to scancodes. A reasonable option for
103−-- reasonable option for Vty if everybody used the linux kernel console
114+-- vty if everybody used the linux kernel console. I hear GUIs are
104−-- but for obvious reasons this is not possible.
115+-- popular these days. Sadly, GUI terminal emulators don't provide
105−--
116+-- access to scancodes AFAIK.
117+--
106−-- The "Graphics.Vty.Config" module supports customizing the
118+-- All is lost? Not really. "Graphics.Vty.Config" supports customizing
107−-- input-byte-to-event mapping and xterm supports customizing the
119+-- the input byte to event mapping and xterm supports customizing the
108−-- scancode-to-input-byte mapping. With a lot of work a user's system
120+-- scancode to input byte mapping. With a lot of work a user's system
109-- can be set up to encode all the key combos in an almost-sane manner.
121-- can be set up to encode all the key combos in an almost-sane manner.
110--
122--
123+-- There are other tricky work arounds that can be done. I have no
124+-- interest in implementing most of these. They are not really worth the
125+-- time.
126+--
127+-- == Terminal Output is Also Broken
128+--
129+-- This isn't the only odd aspect of terminals due to historical
130+-- aspects that no longer apply. EG: Some terminfo capabilities specify
131+-- millisecond delays. (Capabilities are how terminfo describes the
132+-- control sequence to output red, for instance) This is to account for
133+-- the slow speed of hardcopy teletype interfaces. Cause, uh, we totally
134+-- still use those.
135+--
136+-- The output encoding of colors and attributes are also rife with
137+-- issues.
138+--
111-- == See also
139-- == See also
112--
140--
113-- * http://www.leonerd.org.uk/hacks/fixterms/
141-- * http://www.leonerd.org.uk/hacks/fixterms/
142+--
143+-- In my experience this cannot resolve the issues without changes to
144+-- the terminal emulator and device.
114module Graphics.Vty.Input
145module Graphics.Vty.Input
115 ( Key(..)
146 ( Key(..)
116 , Modifier(..)
147 , Modifier(..)
@@ -132,19 +163,47 @@ import Lens.Micro
132import qualified System.Console.Terminfo as Terminfo
163import qualified System.Console.Terminfo as Terminfo
133import System.Posix.Signals.Exts
164import System.Posix.Signals.Exts
134
165
135−#if !MIN_VERSION_base(4,11,0)
166+#if !(MIN_VERSION_base(4,8,0))
167+import Data.Functor ((<$>))
168+import Data.Monoid
169+#else
136import Data.Monoid ((<>))
170import Data.Monoid ((<>))
137#endif
171#endif
138
172
139-- | Set up the terminal with file descriptor `inputFd` for input.
173-- | Set up the terminal with file descriptor `inputFd` for input.
140−-- Returns an 'Input'.
174+-- Returns a 'Input'.
141--
175--
142-- The table used to determine the 'Events' to produce for the input
176-- The table used to determine the 'Events' to produce for the input
143−-- bytes comes from 'classifyMapForTerm' which is then overridden by
177+-- bytes comes from 'classifyMapForTerm'. Which is then overridden by
144−-- the the applicable entries from the configuration's 'inputMap'.
178+-- the the applicable entries from 'inputMap'.
179+--
180+-- The terminal device is configured with the attributes:
181+--
182+-- * IXON disabled
183+-- - disables software flow control on outgoing data. This stops
184+-- the process from being suspended if the output terminal cannot
185+-- keep up. I presume this has little effect these days. I hope
186+-- this means that output will be buffered if the terminal cannot
187+-- keep up. In the old days the output might of been dropped?
188+--
189+-- "raw" mode is used for input.
190+--
191+-- * ISIG disabled
192+-- - enables keyboard combinations that result in signals. TODO:
193+-- should probably be a dynamic option.
194+--
195+-- * ECHO disabled
196+-- - input is not echod to the output. TODO: should be a
197+-- dynamic option.
198+--
199+-- * ICANON disabled
200+-- - canonical mode (line mode) input is not used. TODO: should
201+-- be a dynamic option.
202+--
203+-- * IEXTEN disabled
204+-- - extended functions are disabled. TODO: I don't know what
205+-- those are.
145--
206--
146−-- The terminal device's mode flags are configured by the
147−-- 'attributeControl' function.
148inputForConfig :: Config -> IO Input
207inputForConfig :: Config -> IO Input
149inputForConfig config@Config{ termName = Just termName
208inputForConfig config@Config{ termName = Just termName
150 , inputFd = Just termFd
209 , inputFd = Just termFd
@@ -154,23 +213,20 @@ inputForConfig config@Config{ termName = Just termName
154 terminal <- Terminfo.setupTerm termName
213 terminal <- Terminfo.setupTerm termName
155 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
214 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
215 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
157− (setAttrs, unsetAttrs) <- attributeControl termFd
216+ (setAttrs,unsetAttrs) <- attributeControl termFd
158 setAttrs
217 setAttrs
159 input <- initInput config activeInputMap
218 input <- initInput config activeInputMap
160 let pokeIO = Catch $ do
219 let pokeIO = Catch $ do
220+ let e = error "vty internal failure: this value should not propagate to users"
161 setAttrs
221 setAttrs
162− atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
222+ atomically $ writeTChan (input^.eventChannel) (EvResize e e)
163 _ <- installHandler windowChange pokeIO Nothing
223 _ <- installHandler windowChange pokeIO Nothing
164 _ <- installHandler continueProcess pokeIO Nothing
224 _ <- installHandler continueProcess pokeIO Nothing
165−
166− let restore = unsetAttrs
167−
168 return $ input
225 return $ input
169 { shutdownInput = do
226 { shutdownInput = do
170 shutdownInput input
227 shutdownInput input
171 _ <- installHandler windowChange Ignore Nothing
228 _ <- installHandler windowChange Ignore Nothing
172 _ <- installHandler continueProcess Ignore Nothing
229 _ <- installHandler continueProcess Ignore Nothing
173− restore
230+ unsetAttrs
174− , restoreInputState = restoreInputState input >> restore
175 }
231 }
176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
232inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Classify.hs+31−54
@@ -1,55 +1,41 @@
1{-# OPTIONS_HADDOCK hide #-}
1{-# OPTIONS_HADDOCK hide #-}
2−-- This makes a kind of trie. Has space efficiency issues with large
2+-- This makes a kind of tri. 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.
5+-- TODO: The ClassifyMap interface requires this code to always assure
6+-- later entries override earlier.
5module Graphics.Vty.Input.Classify
7module Graphics.Vty.Input.Classify
6 ( classify
8 ( classify
7 , KClass(..)
9 , KClass(..)
8− , ClassifierState(..)
9 )
10 )
10where
11where
11
12
12import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Mouse
14import Graphics.Vty.Input.Mouse
14−import Graphics.Vty.Input.Focus
15import Graphics.Vty.Input.Paste
15import Graphics.Vty.Input.Paste
16import Graphics.Vty.Input.Classify.Types
16import Graphics.Vty.Input.Classify.Types
17
17
18import Codec.Binary.UTF8.Generic (decode)
18import Codec.Binary.UTF8.Generic (decode)
19
19
20−import Control.Arrow (first)
20+import Data.List (inits)
21import qualified Data.Map as M( fromList, lookup )
21import qualified Data.Map as M( fromList, lookup )
22import Data.Maybe ( mapMaybe )
22import Data.Maybe ( mapMaybe )
23import qualified Data.Set as S( fromList, member )
23import qualified Data.Set as S( fromList, member )
24
24
25+import Data.Char
25import Data.Word
26import Data.Word
26
27
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−
42−compile :: ClassifyMap -> ByteString -> KClass
28+compile :: ClassifyMap -> [Char] -> KClass
43compile table = cl' where
29compile table = cl' where
44 -- take all prefixes and create a set of these
30 -- take all prefixes and create a set of these
45− prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
31+ prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
46 maxValidInputLength = maximum (map (length . fst) table)
32 maxValidInputLength = maximum (map (length . fst) table)
47− eventForInput = M.fromList $ map (first BS8.pack) table
33+ eventForInput = M.fromList table
48− cl' inputBlock | BS8.null inputBlock = Prefix
34+ cl' [] = Prefix
49 cl' inputBlock = case M.lookup inputBlock eventForInput of
35 cl' inputBlock = case M.lookup inputBlock eventForInput of
50 -- if the inputBlock is exactly what is expected for an
36 -- if the inputBlock is exactly what is expected for an
51 -- event then consume the whole block and return the event
37 -- event then consume the whole block and return the event
52− Just e -> Valid e BS8.empty
38+ Just e -> Valid e []
53 Nothing -> case S.member inputBlock prefixSet of
39 Nothing -> case S.member inputBlock prefixSet of
54 True -> Prefix
40 True -> Prefix
55 -- look up progressively smaller tails of the input
41 -- look up progressively smaller tails of the input
@@ -60,49 +46,40 @@ compile table = cl' where
60 -- H: There will always be one match. The prefixSet
46 -- H: There will always be one match. The prefixSet
61 -- contains, by definition, all prefixes of an event.
47 -- contains, by definition, all prefixes of an event.
62 False ->
48 False ->
63− let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
49+ let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
64 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
50 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
65− (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
51+ (s,e) : _ -> Valid e (drop (length s) inputBlock)
66 -- neither a prefix or a full event.
52 -- neither a prefix or a full event.
53+ -- TODO: debug log
67 [] -> Invalid
54 [] -> Invalid
68
55
69−classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
56+classify :: ClassifyMap -> [Char] -> KClass
70−classify table = process
57+classify table =
71− where
72− standardClassifier = compile table
58+ let standardClassifier = compile table
73−
74− process ClassifierStart s =
75− case BS.uncons s of
59+ in \s -> case s of
76− _ | bracketedPasteStarted s ->
60+ _ | 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 =
86 if bracketedPasteFinished s
61 if bracketedPasteFinished s
87− then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
62+ then parseBracketedPaste s
88− else Chunk
63+ else Prefix
89− process ClassifierInChunk{} _ = Invalid
64+ _ | isMouseEvent s -> classifyMouseEvent s
65+ c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
66+ _ -> standardClassifier s
90
67
91−classifyUtf8 :: Word8 -> ByteString -> KClass
68+classifyUtf8 :: Char -> [Char] -> KClass
92classifyUtf8 c cs =
69classifyUtf8 c cs =
93− let n = utf8Length c
70+ let n = utf8Length (ord c)
94− (codepoint,rest) = BS8.splitAt (n - 1) cs
71+ (codepoint,rest) = splitAt n (c:cs)
95
72
96 codepoint8 :: [Word8]
73 codepoint8 :: [Word8]
97− codepoint8 = c:BS.unpack codepoint
74+ codepoint8 = map (fromIntegral . ord) codepoint
98
75
99 in case decode codepoint8 of
76 in case decode codepoint8 of
100− _ | n < BS.length codepoint + 1 -> Prefix
77+ _ | n < length codepoint -> Prefix
101− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
78+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
102 -- something bad happened; just ignore and continue.
79 -- something bad happened; just ignore and continue.
103− Nothing -> Invalid
80+ Nothing -> Invalid
104
81
105−utf8Length :: Word8 -> Int
82+utf8Length :: (Num t, Ord a, Num a) => a -> t
106utf8Length c
83utf8Length c
107 | c < 0x80 = 1
84 | c < 0x80 = 1
108 | c < 0xE0 = 2
85 | c < 0xE0 = 2
src/Graphics/Vty/Input/Classify/Parse.hs+7−10
@@ -16,15 +16,12 @@ 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−
22−type Parser a = MaybeT (State ByteString) a
19+type Parser a = MaybeT (State String) a
23
20
24-- | Run a parser on a given input string. If the parser fails, return
21-- | Run a parser on a given input string. If the parser fails, return
25-- 'Invalid'. Otherwise return the valid event ('Valid') and the
22-- 'Invalid'. Otherwise return the valid event ('Valid') and the
26-- remaining unparsed characters.
23-- remaining unparsed characters.
27−runParser :: ByteString -> Parser Event -> KClass
24+runParser :: String -> Parser Event -> KClass
28runParser s parser =
25runParser s parser =
29 case runState (runMaybeT parser) s of
26 case runState (runMaybeT parser) s of
30 (Nothing, _) -> Invalid
27 (Nothing, _) -> Invalid
@@ -39,9 +36,9 @@ failParse = fail "invalid parse"
39-- return '123' and consume those characters.
36-- return '123' and consume those characters.
40readInt :: Parser Int
37readInt :: Parser Int
41readInt = do
38readInt = do
42− s <- BS8.unpack <$> get
39+ s <- get
43 case (reads :: ReadS Int) s of
40 case (reads :: ReadS Int) s of
44− [(i, rest)] -> put (BS8.pack rest) >> return i
41+ [(i, rest)] -> put rest >> return i
45 _ -> failParse
42 _ -> failParse
46
43
47-- | Read a character from the input stream. If one cannot be read (e.g.
44-- | Read a character from the input stream. If one cannot be read (e.g.
@@ -49,9 +46,9 @@ readInt = do
49readChar :: Parser Char
46readChar :: Parser Char
50readChar = do
47readChar = do
51 s <- get
48 s <- get
52− case BS8.uncons s of
49+ case s of
53− Just (c,rest) -> put rest >> return c
50+ c:rest -> put rest >> return c
54− Nothing -> failParse
51+ _ -> failParse
55
52
56-- | Read a character from the input stream and fail parsing if it is
53-- | Read a character from the input stream and fail parsing if it is
57-- not the specified character.
54-- not the specified character.
src/Graphics/Vty/Input/Classify/Types.hs+1−7
@@ -1,6 +1,5 @@
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 #-}
4module Graphics.Vty.Input.Classify.Types
3module Graphics.Vty.Input.Classify.Types
5 ( KClass(..)
4 ( KClass(..)
6 )
5 )
@@ -8,10 +7,8 @@ where
8
7
9import Graphics.Vty.Input.Events
8import Graphics.Vty.Input.Events
10
9
11−import Data.ByteString.Char8 (ByteString)
12−
13data KClass
10data KClass
14− = Valid Event ByteString
11+ = Valid Event [Char]
15 -- ^ A valid event was parsed. Any unused characters from the input
12 -- ^ A valid event was parsed. Any unused characters from the input
16 -- stream are also provided.
13 -- stream are also provided.
17 | Invalid
14 | Invalid
@@ -19,7 +16,4 @@ data KClass
19 | Prefix
16 | Prefix
20 -- ^ The input characters form the prefix of a valid event character
17 -- ^ The input characters form the prefix of a valid event character
21 -- sequence.
18 -- 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.
25 deriving(Show, Eq)
19 deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs+7−29
@@ -1,8 +1,6 @@
1{-# Language DeriveGeneric #-}
1{-# Language DeriveGeneric #-}
2−{-# Language StrictData #-}
3module Graphics.Vty.Input.Events where
2module Graphics.Vty.Input.Events where
4
3
5−import Control.DeepSeq
6import Data.ByteString
4import Data.ByteString
7import GHC.Generics
5import GHC.Generics
8
6
@@ -16,29 +14,23 @@ import GHC.Generics
16--
14--
17-- * Actually, support for most of these but KEsc, KChar, KBS, and
15-- * Actually, support for most of these but KEsc, KChar, KBS, and
18-- KEnter vary by terminal and keyboard.
16-- KEnter vary by terminal and keyboard.
19−data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter
17+data Key = KEsc | KChar Char | KBS | KEnter
20 | KLeft | KRight | KUp | KDown
18 | KLeft | KRight | KUp | KDown
21 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
19 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
22− | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns
20+ | KFun Int | KBackTab | KPrtScr | KPause | KIns
23 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
21 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
24 deriving (Eq,Show,Read,Ord,Generic)
22 deriving (Eq,Show,Read,Ord,Generic)
25
23
26−instance NFData Key
27−
28-- | Modifier keys. Key codes are interpreted such that users are more
24-- | Modifier keys. Key codes are interpreted such that users are more
29-- likely to have Meta than Alt; for instance on the PC Linux console,
25-- likely to have Meta than Alt; for instance on the PC Linux console,
30-- 'MMeta' will generally correspond to the physical Alt key.
26-- 'MMeta' will generally correspond to the physical Alt key.
31data Modifier = MShift | MCtrl | MMeta | MAlt
27data Modifier = MShift | MCtrl | MMeta | MAlt
32 deriving (Eq,Show,Read,Ord,Generic)
28 deriving (Eq,Show,Read,Ord,Generic)
33
29
34−instance NFData Modifier
35−
36-- | Mouse buttons.
30-- | Mouse buttons.
37−data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
31+data Button = BLeft | BMiddle | BRight
38 deriving (Eq,Show,Read,Ord,Generic)
32 deriving (Eq,Show,Read,Ord,Generic)
39
33
40−instance NFData Button
41−
42-- | Events.
34-- | Events.
43data Event
35data Event
44 = EvKey Key [Modifier]
36 = EvKey Key [Modifier]
@@ -52,8 +44,10 @@ data Event
52 -- without specifying which one; in that case, Nothing is provided.
44 -- without specifying which one; in that case, Nothing is provided.
53 -- Otherwise Just the button released is included in the event.
45 -- Otherwise Just the button released is included in the event.
54 | EvResize Int Int
46 | EvResize Int Int
55− -- The terminal window was resized and the size is provided in the
47+ -- ^ If read from 'eventChannel' this is the size at the time of the
56− -- integer fields (width, height).
48+ -- signal. If read from 'nextEvent' this is the size at the time the
49+ -- event was processed by Vty. Typically these are the same, but if
50+ -- somebody is resizing the terminal quickly they can be different.
57 | EvPaste ByteString
51 | EvPaste ByteString
58 -- ^ A paste event occurs when a bracketed paste input sequence is
52 -- ^ A paste event occurs when a bracketed paste input sequence is
59 -- received. For terminals that support bracketed paste mode, these
53 -- received. For terminals that support bracketed paste mode, these
@@ -62,22 +56,6 @@ data Event
62 -- input (which is probably bad, so beware!) Note that the data is
56 -- input (which is probably bad, so beware!) Note that the data is
63 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if
57 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if
64 -- that's what your application expects.
58 -- that's what your application expects.
65− | EvLostFocus
66− -- ^ The terminal running the application lost input focus.
67− | EvGainedFocus
68− -- ^ The terminal running the application gained input focus.
69 deriving (Eq,Show,Read,Ord,Generic)
59 deriving (Eq,Show,Read,Ord,Generic)
70
60
71−instance NFData Event
72−
73type ClassifyMap = [(String,Event)]
61type 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.hsdeleted−49
@@ -1,49 +0,0 @@
1−module Graphics.Vty.Input.Focus
2− ( requestFocusEvents
3− , disableFocusEvents
4− , isFocusEvent
5− , classifyFocusEvent
6− )
7−where
8−
9−import Graphics.Vty.Input.Events
10−import Graphics.Vty.Input.Classify.Types
11−import Graphics.Vty.Input.Classify.Parse
12−
13−import Control.Monad.State
14−
15−import qualified Data.ByteString.Char8 as BS8
16−import Data.ByteString.Char8 (ByteString)
17−
18−-- | These sequences set xterm-based terminals to send focus event
19−-- sequences.
20−requestFocusEvents :: ByteString
21−requestFocusEvents = BS8.pack "\ESC[?1004h"
22−
23−-- | These sequences disable focus events.
24−disableFocusEvents :: ByteString
25−disableFocusEvents = BS8.pack "\ESC[?1004l"
26−
27−-- | Does the specified string begin with a focus event?
28−isFocusEvent :: ByteString -> Bool
29−isFocusEvent s = BS8.isPrefixOf focusIn s ||
30− BS8.isPrefixOf focusOut s
31−
32−focusIn :: ByteString
33−focusIn = BS8.pack "\ESC[I"
34−
35−focusOut :: ByteString
36−focusOut = BS8.pack "\ESC[O"
37−
38−-- | Attempt to classify an input string as a focus event.
39−classifyFocusEvent :: ByteString -> KClass
40−classifyFocusEvent s = runParser s $ do
41− when (not $ isFocusEvent s) failParse
42−
43− expectChar '\ESC'
44− expectChar '['
45− ty <- readChar
46− case ty of
47− 'I' -> return EvGainedFocus
48− 'O' -> return EvLostFocus
49− _ -> failParse
src/Graphics/Vty/Input/Loop.hs+32−87
@@ -1,9 +1,8 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TemplateHaskell #-}
6{-# OPTIONS_HADDOCK hide #-}
2{-# OPTIONS_HADDOCK hide #-}
3+{-# LANGUAGE NoMonomorphismRestriction #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE CPP #-}
7-- | The input layer used to be a single function that correctly
6-- | The input layer used to be a single function that correctly
8-- accounted for the non-threaded runtime by emulating the terminal
7-- accounted for the non-threaded runtime by emulating the terminal
9-- VMIN adn VTIME handling. This has been removed and replace with a
8-- VMIN adn VTIME handling. This has been removed and replace with a
@@ -25,7 +24,8 @@ import Control.Applicative
25import Control.Concurrent
24import Control.Concurrent
26import Control.Concurrent.STM
25import Control.Concurrent.STM
27import Control.Exception (mask, try, SomeException)
26import Control.Exception (mask, try, SomeException)
27+import Data.Monoid
28−import Lens.Micro hiding ((<>~))
28+import Lens.Micro
29import Lens.Micro.Mtl
29import Lens.Micro.Mtl
30import Lens.Micro.TH
30import Lens.Micro.TH
31import Control.Monad (when, mzero, forM_)
31import Control.Monad (when, mzero, forM_)
@@ -34,15 +34,12 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)
34import Control.Monad.State.Class (MonadState, modify)
34import Control.Monad.State.Class (MonadState, modify)
35import Control.Monad.Trans.Reader (ReaderT(..))
35import Control.Monad.Trans.Reader (ReaderT(..))
36
36
37−import qualified Data.ByteString.Char8 as BS8
37+import Data.Char
38−import qualified Data.ByteString as BS
39−import Data.ByteString.Char8 (ByteString)
40import Data.IORef
38import Data.IORef
41import Data.Word (Word8)
39import Data.Word (Word8)
42
40
43−import Foreign (allocaArray)
41+import Foreign ( allocaArray, peekArray, Ptr )
44import Foreign.C.Types (CInt(..))
42import Foreign.C.Types (CInt(..))
45−import Foreign.Ptr (Ptr, castPtr)
46
43
47import System.IO
44import System.IO
48import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
45import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
@@ -55,15 +52,10 @@ data Input = Input
55 { -- | Channel of events direct from input processing. Unlike
52 { -- | Channel of events direct from input processing. Unlike
56 -- 'nextEvent' this will not refresh the display if the next event
53 -- 'nextEvent' this will not refresh the display if the next event
57 -- is an 'EvResize'.
54 -- is an 'EvResize'.
58− _eventChannel :: TChan InternalEvent
55+ _eventChannel :: TChan Event
59− -- | Shuts down the input processing. As part of shutting down the
56+ -- | Shuts down the input processing. This should return the
60− -- input, this should also restore the input state.
57+ -- terminal input state to before he input initialized.
61 , shutdownInput :: IO ()
58 , 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 ()
67 -- | Changes to this value are reflected after the next event.
59 -- | Changes to this value are reflected after the next event.
68 , _configRef :: IORef Config
60 , _configRef :: IORef Config
69 -- | input debug log
61 -- | input debug log
@@ -80,11 +72,10 @@ data InputBuffer = InputBuffer
80makeLenses ''InputBuffer
72makeLenses ''InputBuffer
81
73
82data InputState = InputState
74data InputState = InputState
83− { _unprocessedBytes :: ByteString
75+ { _unprocessedBytes :: String
84− , _classifierState :: ClassifierState
85 , _appliedConfig :: Config
76 , _appliedConfig :: Config
86 , _inputBuffer :: InputBuffer
77 , _inputBuffer :: InputBuffer
87− , _classifier :: ClassifierState -> ByteString -> KClass
78+ , _classifier :: String -> KClass
88 }
79 }
89
80
90makeLenses ''InputState
81makeLenses ''InputState
@@ -109,20 +100,21 @@ loopInputProcessor = do
109 dropInvalid
100 dropInvalid
110 loopInputProcessor
101 loopInputProcessor
111
102
112−addBytesToProcess :: ByteString -> InputM ()
103+addBytesToProcess :: String -> InputM ()
113addBytesToProcess block = unprocessedBytes <>= block
104addBytesToProcess block = unprocessedBytes <>= block
114
105
115emit :: Event -> InputM ()
106emit :: Event -> InputM ()
116emit event = do
107emit event = do
117 logMsg $ "parsed event: " ++ show event
108 logMsg $ "parsed event: " ++ show event
118− view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
109+ view eventChannel >>= liftIO . atomically . flip writeTChan event
119
110
120-- The timing requirements are assured by the VMIN and VTIME set for the
111-- The timing requirements are assured by the VMIN and VTIME set for the
121-- device.
112-- device.
122--
113--
123-- Precondition: Under the threaded runtime. Only current use is from a
114-- Precondition: Under the threaded runtime. Only current use is from a
124-- forkOS thread. That case satisfies precondition.
115-- forkOS thread. That case satisfies precondition.
116+-- TODO: When under the non-threaded runtime emulate VMIN and VTIME
125−readFromDevice :: InputM ByteString
117+readFromDevice :: InputM String
126readFromDevice = do
118readFromDevice = do
127 newConfig <- view configRef >>= liftIO . readIORef
119 newConfig <- view configRef >>= liftIO . readIORef
128 oldConfig <- use appliedConfig
120 oldConfig <- use appliedConfig
@@ -142,10 +134,9 @@ readFromDevice = do
142 threadWaitRead fd
134 threadWaitRead fd
143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
135 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
144 if bytesRead > 0
136 if bytesRead > 0
145− then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
137+ then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
146− else return BS.empty
138+ else return []
147− when (not $ BS.null stringRep) $
148− logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
139+ when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
149 return stringRep
140 return stringRep
150
141
151applyConfig :: Fd -> Config -> IO ()
142applyConfig :: Fd -> Config -> IO ()
@@ -156,86 +147,41 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat
156parseEvent :: InputM Event
147parseEvent :: InputM Event
157parseEvent = do
148parseEvent = do
158 c <- use classifier
149 c <- use classifier
159− s <- use classifierState
160 b <- use unprocessedBytes
150 b <- use unprocessedBytes
161− case c s b of
151+ case c b of
162 Valid e remaining -> do
152 Valid e remaining -> do
163 logMsg $ "valid parse: " ++ show e
153 logMsg $ "valid parse: " ++ show e
164 logMsg $ "remaining: " ++ show remaining
154 logMsg $ "remaining: " ++ show remaining
165− classifierState .= ClassifierStart
166 unprocessedBytes .= remaining
155 unprocessedBytes .= remaining
167 return e
156 return e
168− _ -> mzero
157+ _ -> mzero
169
158
170dropInvalid :: InputM ()
159dropInvalid :: InputM ()
171dropInvalid = do
160dropInvalid = do
172 c <- use classifier
161 c <- use classifier
173− s <- use classifierState
174 b <- use unprocessedBytes
162 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
182− Invalid -> do
163+ when (c b == Invalid) $ do
183− logMsg "dropping input bytes"
164+ logMsg "dropping input bytes"
184− classifierState .= ClassifierStart
185− unprocessedBytes .= BS8.empty
165+ unprocessedBytes .= []
186− _ -> return ()
187
166
188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
167runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
189runInputProcessorLoop classifyTable input = do
168runInputProcessorLoop classifyTable input = do
190 let bufferSize = 1024
169 let bufferSize = 1024
191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
170 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
192− s0 <- InputState BS8.empty ClassifierStart
193− <$> readIORef (_configRef input)
171+ s0 <- InputState [] <$> readIORef (_configRef input)
194− <*> pure (InputBuffer bufferPtr bufferSize)
172+ <*> pure (InputBuffer bufferPtr bufferSize)
195− <*> pure (classify classifyTable)
173+ <*> pure (classify classifyTable)
196 runReaderT (evalStateT loopInputProcessor s0) input
174 runReaderT (evalStateT loopInputProcessor s0) input
197
175
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)
223attributeControl :: Fd -> IO (IO (), IO ())
176attributeControl :: Fd -> IO (IO (), IO ())
224attributeControl fd = do
177attributeControl fd = do
225 original <- getTerminalAttributes fd
178 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
231− , KeyboardInterrupts -- ISIG
179+ let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
232− , EnableEcho -- ECHO
233− , ProcessInput -- ICANON
234− , ExtendedFunctions -- IEXTEN
180+ , EnableEcho, ProcessInput, ExtendedFunctions
235− ]
181+ ]
236 let setAttrs = setTerminalAttributes fd vtyMode Immediately
182 let setAttrs = setTerminalAttributes fd vtyMode Immediately
237 unsetAttrs = setTerminalAttributes fd original Immediately
183 unsetAttrs = setTerminalAttributes fd original Immediately
238− return (setAttrs, unsetAttrs)
184+ return (setAttrs,unsetAttrs)
239
185
240logInitialInputState :: Input -> ClassifyMap -> IO()
186logInitialInputState :: Input -> ClassifyMap -> IO()
241logInitialInputState input classifyTable = case _inputDebug input of
187logInitialInputState input classifyTable = case _inputDebug input of
@@ -243,7 +189,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
243 Just h -> do
189 Just h -> do
244 Config{ vmin = Just theVmin
190 Config{ vmin = Just theVmin
245 , vtime = Just theVtime
191 , vtime = Just theVtime
246− , termName = Just theTerm } <- readIORef $ _configRef input
192+ , termName = Just theTerm, .. } <- readIORef $ _configRef input
247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
193 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
248 forM_ classifyTable $ \i -> case i of
194 forM_ classifyTable $ \i -> case i of
249 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
195 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
@@ -259,7 +205,6 @@ initInput config classifyTable = do
259 applyConfig fd config
205 applyConfig fd config
260 stopSync <- newEmptyMVar
206 stopSync <- newEmptyMVar
261 input <- Input <$> atomically newTChan
207 input <- Input <$> atomically newTChan
262− <*> pure (return ())
263 <*> pure (return ())
208 <*> pure (return ())
264 <*> newIORef config
209 <*> newIORef config
265 <*> maybe (return Nothing)
210 <*> maybe (return Nothing)
src/Graphics/Vty/Input/Mouse.hs+18−28
@@ -15,12 +15,10 @@ 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)
18import Data.Maybe (catMaybes)
19import Data.Maybe (catMaybes)
19import Data.Bits ((.&.))
20import Data.Bits ((.&.))
20
21
21−import qualified Data.ByteString.Char8 as BS8
22−import Data.ByteString.Char8 (ByteString)
23−
24-- A mouse event in SGR extended mode is
22-- A mouse event in SGR extended mode is
25--
23--
26-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
24-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
@@ -34,28 +32,28 @@ import Data.ByteString.Char8 (ByteString)
34
32
35-- | These sequences set xterm-based terminals to send mouse event
33-- | These sequences set xterm-based terminals to send mouse event
36-- sequences.
34-- sequences.
37−requestMouseEvents :: ByteString
35+requestMouseEvents :: String
38−requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
36+requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h\ESC[?1005h"
39
37
40-- | These sequences disable mouse events.
38-- | These sequences disable mouse events.
41−disableMouseEvents :: ByteString
39+disableMouseEvents :: String
42−disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
40+disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l\ESC[?1005l"
43
41
44-- | Does the specified string begin with a mouse event?
42-- | Does the specified string begin with a mouse event?
45−isMouseEvent :: ByteString -> Bool
43+isMouseEvent :: String -> Bool
46isMouseEvent s = isSGREvent s || isNormalEvent s
44isMouseEvent s = isSGREvent s || isNormalEvent s
47
45
48−isSGREvent :: ByteString -> Bool
46+isSGREvent :: String -> Bool
49−isSGREvent = BS8.isPrefixOf sgrPrefix
47+isSGREvent = isPrefixOf sgrPrefix
50
48
51−sgrPrefix :: ByteString
49+sgrPrefix :: String
52−sgrPrefix = BS8.pack "\ESC[M"
50+sgrPrefix = "\ESC[M"
53
51
54−isNormalEvent :: ByteString -> Bool
52+isNormalEvent :: String -> Bool
55−isNormalEvent = BS8.isPrefixOf normalPrefix
53+isNormalEvent = isPrefixOf normalPrefix
56
54
57−normalPrefix :: ByteString
55+normalPrefix :: String
58−normalPrefix = BS8.pack "\ESC[<"
56+normalPrefix = "\ESC[<"
59
57
60-- Modifier bits:
58-- Modifier bits:
61shiftBit :: Int
59shiftBit :: Int
@@ -69,7 +67,7 @@ ctrlBit = 16
69
67
70-- These bits indicate the buttons involved:
68-- These bits indicate the buttons involved:
71buttonMask :: Int
69buttonMask :: Int
72−buttonMask = 67
70+buttonMask = 3
73
71
74leftButton :: Int
72leftButton :: Int
75leftButton = 0
73leftButton = 0
@@ -80,17 +78,11 @@ middleButton = 1
80rightButton :: Int
78rightButton :: Int
81rightButton = 2
79rightButton = 2
82
80
83−scrollUp :: Int
84−scrollUp = 64
85−
86−scrollDown :: Int
87−scrollDown = 65
88−
89hasBitSet :: Int -> Int -> Bool
81hasBitSet :: Int -> Int -> Bool
90hasBitSet val bit = val .&. bit > 0
82hasBitSet val bit = val .&. bit > 0
91
83
92−-- | Attempt to classify an input string as a mouse event.
84+-- | Attempt to lassify an input string as a mouse event.
93−classifyMouseEvent :: ByteString -> KClass
85+classifyMouseEvent :: String -> KClass
94classifyMouseEvent s = runParser s $ do
86classifyMouseEvent s = runParser s $ do
95 when (not $ isMouseEvent s) failParse
87 when (not $ isMouseEvent s) failParse
96
88
@@ -102,14 +94,12 @@ classifyMouseEvent s = runParser s $ do
102 'M' -> classifyNormalMouseEvent
94 'M' -> classifyNormalMouseEvent
103 _ -> failParse
95 _ -> failParse
104
96
105−-- Given a modifier/button value, determine which button was indicated
97+-- Given a modifer/button value, determine which button was indicated
106getSGRButton :: Int -> Parser Button
98getSGRButton :: Int -> Parser Button
107getSGRButton mods =
99getSGRButton mods =
108 let buttonMap = [ (leftButton, BLeft)
100 let buttonMap = [ (leftButton, BLeft)
109 , (middleButton, BMiddle)
101 , (middleButton, BMiddle)
110 , (rightButton, BRight)
102 , (rightButton, BRight)
111− , (scrollUp, BScrollUp)
112− , (scrollDown, BScrollDown)
113 ]
103 ]
114 in case lookup (mods .&. buttonMask) buttonMap of
104 in case lookup (mods .&. buttonMask) buttonMap of
115 Nothing -> failParse
105 Nothing -> failParse
src/Graphics/Vty/Input/Paste.hs+24−16
@@ -9,33 +9,41 @@ 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)
13
12
14import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Events
15import Graphics.Vty.Input.Classify.Types
14import Graphics.Vty.Input.Classify.Types
16
15
17−bracketedPasteStart :: ByteString
16+import Data.List (isPrefixOf, isInfixOf)
18−bracketedPasteStart = BS8.pack "\ESC[200~"
19
17
18+bracketedPasteStart :: String
19+bracketedPasteStart = "\ESC[200~"
20+
20−bracketedPasteEnd :: ByteString
21+bracketedPasteEnd :: String
21−bracketedPasteEnd = BS8.pack "\ESC[201~"
22+bracketedPasteEnd = "\ESC[201~"
22
23
23-- | Does the input start a bracketed paste?
24-- | Does the input start a bracketed paste?
24−bracketedPasteStarted :: ByteString -> Bool
25+bracketedPasteStarted :: String -> Bool
25−bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart
26+bracketedPasteStarted = isPrefixOf bracketedPasteStart
26
27
27-- | Does the input contain a complete bracketed paste?
28-- | Does the input contain a complete bracketed paste?
28−bracketedPasteFinished :: ByteString -> Bool
29+bracketedPasteFinished :: String -> Bool
29−bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd
30+bracketedPasteFinished = isInfixOf bracketedPasteEnd
30
31
31-- | Parse a bracketed paste. This should only be called on a string if
32-- | Parse a bracketed paste. This should only be called on a string if
32-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
33-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
33-- 'True'.
34-- 'True'.
34−parseBracketedPaste :: ByteString -> KClass
35+parseBracketedPaste :: String -> KClass
35parseBracketedPaste s =
36parseBracketedPaste 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
36− Valid (EvPaste p) (BS8.drop endLen rest')
41+ in Valid (EvPaste $ BS8.pack p) rest'
37− where
42+
38− startLen = BS8.length bracketedPasteStart
43+takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])
39− endLen = BS8.length bracketedPasteEnd
44+takeUntil [] _ = ([], [])
40− (_, rest ) = BS8.breakSubstring bracketedPasteStart s
45+takeUntil cs sub
41− (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest
46+ | length cs < length sub = (cs, [])
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+29−27
@@ -7,8 +7,8 @@ import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT
7import Control.Arrow
7import Control.Arrow
8import System.Console.Terminfo
8import System.Console.Terminfo
9
9
10−-- | Queries the terminal for all capability-based input sequences and
10+-- | Queries the terminal for all capability based input sequences then
11−-- then adds on a terminal-dependent input sequence mapping.
11+-- adds on a terminal dependent input sequence mapping.
12--
12--
13-- For reference see:
13-- For reference see:
14--
14--
@@ -20,29 +20,30 @@ import System.Console.Terminfo
20--
20--
21-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
21-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
22--
22--
23−-- Terminfo is incomplete. The vim source implies that terminfo is also
23+-- This is painful. Terminfo is incomplete. The vim source implies that
24−-- incorrect. Vty assumes that the internal terminfo table added to the
24+-- terminfo is also incorrect. Vty assumes that the an internal terminfo
25−-- system-provided terminfo table is correct.
25+-- table added to the system provided terminfo table is correct.
26--
26--
27−-- The procedure used here is:
27+-- 1. build terminfo table for all caps. Missing caps are not added.
28--
28--
29−-- 1. Build terminfo table for all caps. Missing caps are not added.
29+-- 2. add tables for visible chars, esc, del plus ctrl and meta
30--
30--
31−-- 2. Add tables for visible chars, esc, del, ctrl, and meta.
31+-- 3. add internally defined table for given terminal type.
32--
32--
33−-- 3. Add internally-defined table for given terminal type.
33+-- Precedence is currently implicit in the 'compile' algorithm. Which is
34+-- a bit odd.
34--
35--
35−-- Precedence is currently implicit in the 'compile' algorithm.
36+-- \todo terminfo meta is not supported.
37+-- \todo no 8bit
36classifyMapForTerm :: String -> Terminal -> ClassifyMap
38classifyMapForTerm :: String -> Terminal -> ClassifyMap
37classifyMapForTerm termName term =
39classifyMapForTerm termName term =
38 concat $ capsClassifyMap term keysFromCapsTable
40 concat $ capsClassifyMap term keysFromCapsTable
39 : universalTable
41 : universalTable
40 : termSpecificTables termName
42 : termSpecificTables termName
41
43
42−-- | The key table applicable to all terminals.
44+-- | key table applicable to all terminals.
43--
45--
44−-- Note that some of these entries are probably only applicable to
46+-- TODO: some probably only applicable to ANSI/VT100 terminals.
45−-- ANSI/VT100 terminals.
46universalTable :: ClassifyMap
47universalTable :: ClassifyMap
47universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
48universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
48
49
@@ -53,8 +54,7 @@ capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]
53-- | Tables specific to a given terminal that are not derivable from
54-- | Tables specific to a given terminal that are not derivable from
54-- terminfo.
55-- terminfo.
55--
56--
56−-- Note that this adds the ANSI/VT100/VT50 tables regardless of term
57+-- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier.
57−-- identifier.
58termSpecificTables :: String -> [ClassifyMap]
58termSpecificTables :: String -> [ClassifyMap]
59termSpecificTables _termName = ANSIVT.classifyTable
59termSpecificTables _termName = ANSIVT.classifyTable
60
60
@@ -62,19 +62,22 @@ termSpecificTables _termName = ANSIVT.classifyTable
62--
62--
63-- We limit to < 0xC1. The UTF8 sequence detector will catch all values
63-- We limit to < 0xC1. The UTF8 sequence detector will catch all values
64-- 0xC2 and above before this classify table is reached.
64-- 0xC2 and above before this classify table is reached.
65+--
66+-- TODO: resolve
67+-- 1. start at ' '. The earlier characters are all 'ctrlChar'
65visibleChars :: ClassifyMap
68visibleChars :: ClassifyMap
66visibleChars = [ ([x], EvKey (KChar x) [])
69visibleChars = [ ([x], EvKey (KChar x) [])
67 | x <- [' ' .. toEnum 0xC1]
70 | x <- [' ' .. toEnum 0xC1]
68 ]
71 ]
69
72
70−-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set
73+-- | Non visible characters in the ISO-8859-1 and UTF-8 common set
71-- translated to ctrl + char.
74-- translated to ctrl + char.
72--
75--
73−-- This treats CTRL-i the same as tab.
76+-- \todo resolve CTRL-i is the same as tab
74ctrlChars :: ClassifyMap
77ctrlChars :: ClassifyMap
75ctrlChars =
78ctrlChars =
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
79 [ ([toEnum x],EvKey (KChar y) [MCtrl])
77− | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
80+ | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
81 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
79 , y /= 'h' -- CTRL-h should not hide BS
82 , y /= 'h' -- CTRL-h should not hide BS
80 ]
83 ]
@@ -83,23 +86,22 @@ ctrlChars =
83ctrlMetaChars :: ClassifyMap
86ctrlMetaChars :: ClassifyMap
84ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
87ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
85
88
86−-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
89+-- | esc, meta esc, delete, meta delete, enter, meta enter
87specialSupportKeys :: ClassifyMap
90specialSupportKeys :: ClassifyMap
88specialSupportKeys =
91specialSupportKeys =
89− [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90− , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
91− -- special support for ESC
92+ [ -- special support for ESC
92− , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
93+ ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
93 -- Special support for backspace
94 -- Special support for backspace
94− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
95+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
95 -- Special support for Enter
96 -- Special support for Enter
96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
97 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
97 -- explicit support for tab
98 -- explicit support for tab
98 , ("\t", EvKey (KChar '\t') [])
99 , ("\t", EvKey (KChar '\t') [])
99 ]
100 ]
100
101
101−-- | A classification table directly generated from terminfo cap
102+-- | classify table directly generated from terminfo cap strings
102−-- strings. These are:
103+--
104+-- these are:
103--
105--
104-- * ka1 - keypad up-left
106-- * ka1 - keypad up-left
105--
107--
@@ -181,6 +183,6 @@ keysFromCapsTable =
181 , ("kcuu1", EvKey KUp [])
183 , ("kcuu1", EvKey KUp [])
182 ] ++ functionKeyCapsTable
184 ] ++ functionKeyCapsTable
183
185
184−-- | Cap names for function keys.
186+-- | cap names for function keys
185functionKeyCapsTable :: ClassifyMap
187functionKeyCapsTable :: ClassifyMap
186functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
188functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+6−1
@@ -10,6 +10,9 @@ module Graphics.Vty.Input.Terminfo.ANSIVT where
10import Graphics.Vty.Input.Events
10import Graphics.Vty.Input.Events
11
11
12-- | Encoding for navigation keys.
12-- | Encoding for navigation keys.
13+--
14+-- TODO: This is not the same as the input bytes pulled from teh caps
15+-- table.
13navKeys0 :: ClassifyMap
16navKeys0 :: ClassifyMap
14navKeys0 =
17navKeys0 =
15 [ k "G" KCenter
18 [ k "G" KCenter
@@ -59,11 +62,13 @@ navKeys3 =
59-- This encoding depends on the terminal.
62-- This encoding depends on the terminal.
60functionKeys1 :: ClassifyMap
63functionKeys1 :: ClassifyMap
61functionKeys1 =
64functionKeys1 =
62− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in
65+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
63 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
66 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
64
67
65-- | encoding for meta plus char
68-- | encoding for meta plus char
66--
69--
70+-- TODO: resolve -
71+--
67-- 1. removed 'ESC' from second list due to duplication with
72-- 1. removed 'ESC' from second list due to duplication with
68-- "special_support_keys".
73-- "special_support_keys".
69-- 2. removed '[' from second list due to conflict with 7-bit encoding
74-- 2. removed '[' from second list due to conflict with 7-bit encoding
src/Graphics/Vty/Output.hs+44−35
@@ -1,69 +1,78 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
1+{-# LANGUAGE RecordWildCards #-}
2−-- | This module provides functions for accessing the current terminal
2+{-# LANGUAGE NamedFieldPuns #-}
3+-- | Output interface.
4+--
3−-- or a specific terminal device.
5+-- Access to the current terminal or a specific terminal device.
4--
6--
5-- See also:
7-- See also:
6--
8--
7−-- 1. "Graphics.Vty.Output": This instantiates an abtract interface
9+-- 1. "Graphics.Vty.Output": This instantiates an abtract interface to
8−-- to the terminal based on the @TERM@ and @COLORTERM@ environment
10+-- the terminal interface based on the TERM and COLORTERM environment
9-- variables.
11-- variables.
10--
12--
11-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
13-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
12−-- terminal modules need to implement.
14+-- terminals need to implement.
13--
15--
14-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
16-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
15-- that uses terminfo for all control strings. No attempt is made to
17-- that uses terminfo for all control strings. No attempt is made to
16−-- change the character set to UTF-8 for these terminals.
18+-- change the character set to UTF-8 for these terminals. I don't know a
19+-- way to reliably determine if that is required or how to do so.
17--
20--
18-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
21-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
19-- interface suitable for xterm-like terminals. These are the terminals
22-- interface suitable for xterm-like terminals. These are the terminals
20−-- where @TERM@ begins with @xterm@. This does use terminfo for as many
23+-- where TERM == xterm. This does use terminfo for as many control codes
21−-- control codes as possible.
24+-- as possible.
22module Graphics.Vty.Output
25module Graphics.Vty.Output
23− ( outputForConfig
26+ ( module Graphics.Vty.Output
24− , setCursorPos
27+ , Output(..) -- \todo hide constructors
25− , hideCursor
28+ , AssumedState(..)
26− , showCursor
29+ , DisplayContext(..) -- \todo hide constructors
30+ , outputPicture
31+ , displayContext
27 )
32 )
28where
33where
29
34
30−import Control.Monad (when)
35+import Graphics.Vty.Prelude
31
36
32import Graphics.Vty.Config
37import Graphics.Vty.Config
33−import Graphics.Vty.Image (regionWidth, regionHeight)
38+
34import Graphics.Vty.Output.Interface
39import Graphics.Vty.Output.Interface
35import Graphics.Vty.Output.XTermColor as XTermColor
40import Graphics.Vty.Output.XTermColor as XTermColor
36import Graphics.Vty.Output.TerminfoBased as TerminfoBased
41import Graphics.Vty.Output.TerminfoBased as TerminfoBased
37
42
38import Blaze.ByteString.Builder (writeToByteString)
43import Blaze.ByteString.Builder (writeToByteString)
39
44
40−import Data.List (isPrefixOf)
45+import Control.Monad.Trans
41
46
42−#if !MIN_VERSION_base(4,11,0)
47+import Data.List (isPrefixOf)
43import Data.Monoid ((<>))
48import Data.Monoid ((<>))
44−#endif
45
49
46−-- | Returns an `Output` for the terminal specified in `Config`.
50+-- | Returns a `Output` for the terminal specified in `Config`
47--
51--
48-- The specific Output implementation used is hidden from the API user.
52-- The specific Output implementation used is hidden from the API user.
49-- All terminal implementations are assumed to perform more, or less,
53-- All terminal implementations are assumed to perform more, or less,
50-- the same. Currently, all implementations use terminfo for at least
54-- the same. Currently, all implementations use terminfo for at least
51-- some terminal specific information.
55-- some terminal specific information.
52--
56--
57+-- Specifics about it being based on terminfo are hidden from the API
53−-- If a terminal implementation is developed for a terminal without
58+-- user. If a terminal implementation is developed for a terminal
54−-- terminfo support then Vty should work as expected on that terminal.
59+-- without terminfo support then Vty should work as expected on that
60+-- terminal.
55--
61--
56-- Selection of a terminal is done as follows:
62-- Selection of a terminal is done as follows:
57--
63--
58-- * If TERM contains "xterm" or "screen", use XTermColor.
64-- * If TERM contains "xterm" or "screen", use XTermColor.
59-- * otherwise use the TerminfoBased driver.
65-- * otherwise use the TerminfoBased driver.
66+--
67+-- \todo add an implementation for windows that does not depend on
68+-- terminfo. Should be installable with only what is provided in the
69+-- haskell platform. Use ansi-terminal
60outputForConfig :: Config -> IO Output
70outputForConfig :: Config -> IO Output
61−outputForConfig Config{ outputFd = Just fd, termName = Just termName
71+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do
62− , colorMode = Just colorMode, .. } = do
63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
72 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
64− then XTermColor.reserveTerminal termName fd colorMode
73+ then XTermColor.reserveTerminal termName fd
65 -- Not an xterm-like terminal. try for generic terminfo.
74 -- Not an xterm-like terminal. try for generic terminfo.
66− else TerminfoBased.reserveTerminal termName fd colorMode
75+ else TerminfoBased.reserveTerminal termName fd
67
76
68 case mouseMode of
77 case mouseMode of
69 Just s -> setMode t Mouse s
78 Just s -> setMode t Mouse s
@@ -78,30 +87,30 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
78
87
79-- | Sets the cursor position to the given output column and row.
88-- | Sets the cursor position to the given output column and row.
80--
89--
81−-- This is not necessarily the same as the character position with the
90+-- This is not necessarially the same as the character position with the
82-- same coordinates. Characters can be a variable number of columns in
91-- same coordinates. Characters can be a variable number of columns in
83-- width.
92-- width.
84--
93--
85-- Currently, the only way to set the cursor position to a given
94-- Currently, the only way to set the cursor position to a given
86-- character coordinate is to specify the coordinate in the Picture
95-- character coordinate is to specify the coordinate in the Picture
87−-- instance provided to 'outputPicture' or 'refresh'.
96+-- instance provided to outputPicture or refresh.
88−setCursorPos :: Output -> Int -> Int -> IO ()
97+setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()
89setCursorPos t x y = do
98setCursorPos t x y = do
90 bounds <- displayBounds t
99 bounds <- displayBounds t
91 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
100 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
92 dc <- displayContext t bounds
101 dc <- displayContext t bounds
93− outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
102+ liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
94
103
95−-- | Hides the cursor.
104+-- | Hides the cursor
96−hideCursor :: Output -> IO ()
105+hideCursor :: MonadIO m => Output -> m ()
97hideCursor t = do
106hideCursor t = do
98 bounds <- displayBounds t
107 bounds <- displayBounds t
99 dc <- displayContext t bounds
108 dc <- displayContext t bounds
100− outputByteBuffer t $ writeToByteString $ writeHideCursor dc
109+ liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
101
110
102−-- | Shows the cursor.
111+-- | Shows the cursor
103−showCursor :: Output -> IO ()
112+showCursor :: MonadIO m => Output -> m ()
104showCursor t = do
113showCursor t = do
105 bounds <- displayBounds t
114 bounds <- displayBounds t
106 dc <- displayContext t bounds
115 dc <- displayContext t bounds
107− outputByteBuffer t $ writeToByteString $ writeShowCursor dc
116+ liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+115−148
@@ -1,25 +1,20 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2+-- General philosophy is: MonadIO is for equations exposed to clients.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
5{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−-- | This module provides an abstract interface for performing terminal
8−-- output. The only user-facing part of this API is 'Output'.
9−module Graphics.Vty.Output.Interface
10− ( Output(..)
11− , AssumedState(..)
12− , DisplayContext(..)
13− , Mode(..)
14− , displayContext
15− , outputPicture
16− , initialAssumedState
17− , limitAttrForDisplay
18− )
19−where
20
9
21−import Graphics.Vty.Attributes
10+#ifndef MIN_VERSION_base
22−import Graphics.Vty.Image (DisplayRegion, regionHeight)
11+#defined MIN_VERSION_base(x,y,z) 1
12+#endif
13+
14+module Graphics.Vty.Output.Interface where
15+
16+import Graphics.Vty.Prelude
17+
23import Graphics.Vty.Picture
18import Graphics.Vty.Picture
24import Graphics.Vty.PictureToSpans
19import Graphics.Vty.PictureToSpans
25import Graphics.Vty.Span
20import Graphics.Vty.Span
@@ -29,97 +24,77 @@ import Graphics.Vty.DisplayAttributes
29import Blaze.ByteString.Builder (Write, writeToByteString)
24import Blaze.ByteString.Builder (Write, writeToByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
25import Blaze.ByteString.Builder.ByteString (writeByteString)
31
26
27+import Control.Monad.Trans
28+
32import qualified Data.ByteString as BS
29import qualified Data.ByteString as BS
33import Data.IORef
30import Data.IORef
34import qualified Data.Text.Encoding as T
31import qualified Data.Text.Encoding as T
35import qualified Data.Text.Lazy as TL
32import qualified Data.Text.Lazy as TL
36import qualified Data.Vector as Vector
33import qualified Data.Vector as Vector
37
34
35+#if !(MIN_VERSION_base(4,8,0))
36+import Data.Monoid (mempty, mappend)
37+#endif
38+
38-- | Modal terminal features that can be enabled and disabled.
39-- | Modal terminal features that can be enabled and disabled.
39data Mode = Mouse
40data Mode = Mouse
40− -- ^ Mouse mode (whether the terminal is configured to provide
41− -- mouse input events)
42 | BracketedPaste
41 | BracketedPaste
43− -- ^ Paste mode (whether the terminal is configured to provide
44− -- events on OS pastes)
45− | Focus
46− -- ^ Focus-in/focus-out events (whether the terminal is
47− -- configured to provide events on focus change)
48− | Hyperlink
49− -- ^ Hyperlink mode via the 'withURL' attribute modifier (see
50− -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
51− -- Note that this may not work gracefully in all terminal
52− -- emulators so be sure to test this mode with the terminals
53− -- you intend to support. It is off by default.
54 deriving (Eq, Read, Show)
42 deriving (Eq, Read, Show)
55
43
56−-- | The Vty terminal output interface.
57data Output = Output
44data Output = Output
58 { -- | Text identifier for the output device. Used for debugging.
45 { -- | Text identifier for the output device. Used for debugging.
59 terminalID :: String
46 terminalID :: String
60− -- | Release the terminal just prior to application exit and reset
61− -- it to its state prior to application startup.
62− , releaseTerminal :: IO ()
47+ , releaseTerminal :: forall m. MonadIO m => m ()
63− -- | Clear the display and initialize the terminal to some initial
48+ -- | Clear the display and initialize the terminal to some initial
64− -- display state.
49+ -- display state.
65− --
50+ --
66− -- The expectation of a program is that the display starts in some
51+ -- The expectation of a program is that the display starts in some
67− -- The initial state. initial state would consist of fixed values:
52+ -- The initial state. initial state would consist of fixed values:
68− --
53+ --
69− -- - cursor at top left
54+ -- - cursor at top left
70− -- - UTF-8 character encoding
55+ -- - UTF-8 character encoding
71− -- - drawing characteristics are the default
56+ -- - drawing characteristics are the default
57+ --
58+ -- The abstract operation I think all these behaviors are instances
59+ -- of is reserving exclusive access to a display such that:
60+ --
61+ -- - The previous state cannot be determined
62+ -- - When exclusive access to a display is released the display
63+ -- returns to the previous state.
72− , reserveDisplay :: IO ()
64+ , reserveDisplay :: forall m. MonadIO m => m ()
73− -- | Return the display to the state before `reserveDisplay` If no
65+ -- | Return the display to the state before `reserveDisplay`
74− -- previous state then set the display state to the initial state.
66+ -- If no previous state then set the display state to the initial
67+ -- state.
75− , releaseDisplay :: IO ()
68+ , releaseDisplay :: forall m. MonadIO m => m ()
76− -- | Sets the current display bounds (width, height).
77− , setDisplayBounds :: (Int, Int) -> IO ()
78− -- | Returns the current display bounds.
69+ -- | Returns the current display bounds.
79− , displayBounds :: IO DisplayRegion
70+ , displayBounds :: forall m. MonadIO m => m DisplayRegion
80− -- | Output the bytestring to the terminal device.
71+ -- | Output the byte string to the terminal device.
81 , outputByteBuffer :: BS.ByteString -> IO ()
72 , outputByteBuffer :: BS.ByteString -> IO ()
73+ -- | Maximum number of colors supported by the context.
74+ , contextColorCount :: Int
82− -- | Specifies whether the cursor can be shown / hidden.
75+ -- | if the cursor can be shown / hidden
83 , supportsCursorVisibility :: Bool
76 , supportsCursorVisibility :: Bool
84− -- | Indicates support for terminal modes for this output device.
77+ -- | Indicates support for terminal modes for this output device
85 , supportsMode :: Mode -> Bool
78 , supportsMode :: Mode -> Bool
86− -- | Enables or disables a mode (does nothing if the mode is
79+ -- | Enables or disables a mode (does nothing if the mode is
87− -- unsupported).
80+ -- unsupported)
88− , setMode :: Mode -> Bool -> IO ()
81+ , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()
89− -- | Returns whether a mode is enabled.
82+ -- | Returns whether a mode is enabled
90− , getModeStatus :: Mode -> IO Bool
83+ , getModeStatus :: forall m. MonadIO m => Mode -> m Bool
91 , assumedStateRef :: IORef AssumedState
84 , assumedStateRef :: IORef AssumedState
92− -- | Acquire display access to the given region of the display.
85+ -- | Acquire display access to the given region of the display.
93− -- Currently all regions have the upper left corner of (0,0) and
86+ -- Currently all regions have the upper left corner of (0,0) and
94− -- the lower right corner at (max displayWidth providedWidth, max
87+ -- the lower right corner at (max displayWidth providedWidth, max
95− -- displayHeight providedHeight)
88+ -- displayHeight providedHeight)
96− , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
89+ , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
97− -- | Ring the terminal bell if supported.
90+ -- | Ring the terminal bell if supported.
98− , ringTerminalBell :: IO ()
91+ , ringTerminalBell :: forall m. MonadIO m => m ()
99− -- | Returns whether the terminal has an audio bell feature.
92+ -- | Returns whether the terminal has an audio bell feature.
100− , supportsBell :: IO Bool
93+ , supportsBell :: forall m. MonadIO m => m 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
119 }
94 }
120
95
121−displayContext :: Output -> DisplayRegion -> IO DisplayContext
96+displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
122−displayContext t = mkDisplayContext t t
97+displayContext t = liftIO . mkDisplayContext t t
123
98
124data AssumedState = AssumedState
99data AssumedState = AssumedState
125 { prevFattr :: Maybe FixedAttr
100 { prevFattr :: Maybe FixedAttr
@@ -133,16 +108,16 @@ data DisplayContext = DisplayContext
133 { contextDevice :: Output
108 { contextDevice :: Output
134 -- | Provide the bounds of the display context.
109 -- | Provide the bounds of the display context.
135 , contextRegion :: DisplayRegion
110 , contextRegion :: DisplayRegion
136− -- | Sets the output position to the specified row and column
111+ -- | sets the output position to the specified row and column.
137− -- where the number of bytes required for the control codes can be
112+ -- Where the number of bytes required for the control codes can be
138 -- specified seperate from the actual byte sequence.
113 -- specified seperate from the actual byte sequence.
139 , writeMoveCursor :: Int -> Int -> Write
114 , writeMoveCursor :: Int -> Int -> Write
140 , writeShowCursor :: Write
115 , writeShowCursor :: Write
141 , writeHideCursor :: Write
116 , writeHideCursor :: Write
142− -- Ensure that the specified output attributes will be applied to
117+ -- | Assure the specified output attributes will be applied to
143− -- all the following text until the next output attribute change
118+ -- all the following text until the next output attribute change.
144− -- where the number of bytes required for the control codes can be
119+ -- Where the number of bytes required for the control codes can be
145− -- specified seperately from the actual byte sequence. The required
120+ -- specified seperate from the actual byte sequence. The required
146 -- number of bytes must be at least the maximum number of bytes
121 -- number of bytes must be at least the maximum number of bytes
147 -- required by any attribute changes. The serialization equations
122 -- required by any attribute changes. The serialization equations
148 -- must provide the ptr to the next byte to be specified in the
123 -- must provide the ptr to the next byte to be specified in the
@@ -154,9 +129,9 @@ data DisplayContext = DisplayContext
154 -- to support this the currently applied display attributes are
129 -- to support this the currently applied display attributes are
155 -- required. In addition it may be possible to optimize the state
130 -- required. In addition it may be possible to optimize the state
156 -- changes based off the currently applied display attributes.
131 -- changes based off the currently applied display attributes.
157− , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
132+ , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
158− -- | Reset the display attributes to the default display attributes.
133+ -- | Reset the display attributes to the default display attributes
159− , writeDefaultAttr :: Bool -> Write
134+ , writeDefaultAttr :: Write
160 , writeRowEnd :: Write
135 , writeRowEnd :: Write
161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
136 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
162 , inlineHack :: IO ()
137 , inlineHack :: IO ()
@@ -169,33 +144,37 @@ writeUtf8Text = writeByteString
169
144
170-- | Displays the given `Picture`.
145-- | Displays the given `Picture`.
171--
146--
172−-- 1. The image is cropped to the display size.
147+-- 0. The image is cropped to the display size.
148+--
149+-- 1. Converted into a sequence of attribute changes and text spans.
173--
150--
174−-- 2. Converted into a sequence of attribute changes and text spans.
151+-- 2. The cursor is hidden.
175--
152--
176−-- 3. The cursor is hidden.
153+-- 3. Serialized to the display.
177--
154--
178−-- 4. Serialized to the display.
155+-- 4. The cursor is then shown and positioned or kept hidden.
179--
156--
180−-- 5. The cursor is then shown and positioned or kept hidden.
157+-- todo: specify possible IO exceptions.
158+-- abstract from IO monad to a MonadIO instance.
181−outputPicture :: DisplayContext -> Picture -> IO ()
159+outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
182−outputPicture dc pic = do
160+outputPicture dc pic = liftIO $ do
183− urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
184 as <- readIORef (assumedStateRef $ contextDevice dc)
161 as <- readIORef (assumedStateRef $ contextDevice dc)
185 let manipCursor = supportsCursorVisibility (contextDevice dc)
162 let manipCursor = supportsCursorVisibility (contextDevice dc)
186 r = contextRegion dc
163 r = contextRegion dc
187 ops = displayOpsForPic pic r
164 ops = displayOpsForPic pic r
188− initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
165+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing
189 -- Diff the previous output against the requested output.
166 -- Diff the previous output against the requested output.
190 -- Differences are currently on a per-row basis.
167 -- Differences are currently on a per-row basis.
168+ -- \todo handle resizes that crop the dominate directions better.
191 diffs :: [Bool] = case prevOutputOps as of
169 diffs :: [Bool] = case prevOutputOps as of
192− Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
170+ Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True
193− Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
171+ Just previousOps -> if effectedRegion previousOps /= effectedRegion ops
194 then replicate (displayOpsRows ops) True
172 then replicate (displayOpsRows ops) True
195− else Vector.toList $ Vector.zipWith (/=) previousOps ops
173+ else zipWith (/=) (Vector.toList previousOps)
174+ (Vector.toList ops)
196 -- build the Write corresponding to the output image
175 -- build the Write corresponding to the output image
197 out = (if manipCursor then writeHideCursor dc else mempty)
176 out = (if manipCursor then writeHideCursor dc else mempty)
198− `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
177+ `mappend` writeOutputOps dc initialAttr diffs ops
199 `mappend`
178 `mappend`
200 (let (w,h) = contextRegion dc
179 (let (w,h) = contextRegion dc
201 clampX = max 0 . min (w-1)
180 clampX = max 0 . min (w-1)
@@ -206,15 +185,9 @@ outputPicture dc pic = do
206 AbsoluteCursor x y ->
185 AbsoluteCursor x y ->
207 writeShowCursor dc `mappend`
186 writeShowCursor dc `mappend`
208 writeMoveCursor dc (clampX x) (clampY y)
187 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)
215 Cursor x y ->
188 Cursor x y ->
216 let m = cursorOutputMap ops $ picCursor pic
189 let m = cursorOutputMap ops $ picCursor pic
217− (ox, oy) = charToOutputPos m (clampX x, clampY y)
190+ (ox, oy) = charToOutputPos m (x,y)
218 in writeShowCursor dc `mappend`
191 in writeShowCursor dc `mappend`
219 writeMoveCursor dc (clampX ox) (clampY oy)
192 writeMoveCursor dc (clampX ox) (clampY oy)
220 )
193 )
@@ -224,15 +197,15 @@ outputPicture dc pic = do
224 let as' = as { prevOutputOps = Just ops }
197 let as' = as { prevOutputOps = Just ops }
225 writeIORef (assumedStateRef $ contextDevice dc) as'
198 writeIORef (assumedStateRef $ contextDevice dc) as'
226
199
227−writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
200+writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
228−writeOutputOps urlsEnabled dc initialAttr diffs ops =
201+writeOutputOps dc initialAttr diffs ops =
229 let (_, out, _) = Vector.foldl' writeOutputOps'
202 let (_, out, _) = Vector.foldl' writeOutputOps'
230 (0, mempty, diffs)
203 (0, mempty, diffs)
231 ops
204 ops
232 in out
205 in out
233 where
206 where
234 writeOutputOps' (y, out, True : diffs') spanOps
207 writeOutputOps' (y, out, True : diffs') spanOps
235− = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
208+ = let spanOut = writeSpanOps dc y initialAttr spanOps
236 out' = out `mappend` spanOut
209 out' = out `mappend` spanOut
237 in (y+1, out', diffs')
210 in (y+1, out', diffs')
238 writeOutputOps' (y, out, False : diffs') _spanOps
211 writeOutputOps' (y, out, False : diffs') _spanOps
@@ -240,27 +213,27 @@ writeOutputOps urlsEnabled dc initialAttr diffs ops =
240 writeOutputOps' (_y, _out, []) _spanOps
213 writeOutputOps' (_y, _out, []) _spanOps
241 = error "vty - output spans without a corresponding diff."
214 = error "vty - output spans without a corresponding diff."
242
215
243−writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
216+writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
244−writeSpanOps urlsEnabled dc y initialAttr spanOps =
217+writeSpanOps dc y initialAttr spanOps =
245 -- The first operation is to set the cursor to the start of the row
218 -- The first operation is to set the cursor to the start of the row
246− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
219+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
247 -- then the span ops are serialized in the order specified
220 -- then the span ops are serialized in the order specified
248− in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of
221+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
249 (opOut, fattr') -> (out `mappend` opOut, fattr')
222 (opOut, fattr') -> (out `mappend` opOut, fattr')
250 )
223 )
251 (start, initialAttr)
224 (start, initialAttr)
252 spanOps
225 spanOps
253
226
254−writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
227+writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
255−writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
228+writeSpanOp dc (TextSpan attr _ _ str) fattr =
256 let attr' = limitAttrForDisplay (contextDevice dc) attr
229 let attr' = limitAttrForDisplay (contextDevice dc) attr
257 fattr' = fixDisplayAttr fattr attr'
230 fattr' = fixDisplayAttr fattr attr'
258 diffs = displayAttrDiffs fattr fattr'
231 diffs = displayAttrDiffs fattr fattr'
259− out = writeSetAttr dc urlsEnabled fattr attr' diffs
232+ out = writeSetAttr dc fattr attr' diffs
260 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
233 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
261 in (out, fattr')
234 in (out, fattr')
262−writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
235+writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
263−writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
236+writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
264
237
265-- | The cursor position is given in X,Y character offsets. Due to
238-- | The cursor position is given in X,Y character offsets. Due to
266-- multi-column characters this needs to be translated to column, row
239-- multi-column characters this needs to be translated to column, row
@@ -309,23 +282,17 @@ limitAttrForDisplay t attr
309 where
282 where
310 clampColor Default = Default
283 clampColor Default = Default
311 clampColor KeepCurrent = KeepCurrent
284 clampColor KeepCurrent = KeepCurrent
312− clampColor (SetTo c) = clampColor' (outputColorMode t) c
285+ clampColor (SetTo c) = clampColor' c
313−
314− clampColor' NoColor _ = Default
286+ clampColor' (ISOColor v)
315−
287+ | contextColorCount t < 8 = Default
316− clampColor' ColorMode8 (ISOColor v)
317− | v >= 8 = SetTo $ ISOColor (v - 8)
288+ | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
318− | otherwise = SetTo $ ISOColor v
289+ | otherwise = SetTo $ ISOColor v
319− clampColor' ColorMode8 _ = Default
290+ clampColor' (Color240 v)
320−
291+ -- TODO: Choose closes ISO color?
321− clampColor' ColorMode16 c@(ISOColor _) = SetTo c
292+ | contextColorCount t < 8 = Default
322− clampColor' ColorMode16 _ = Default
293+ | contextColorCount t < 16 = Default
323−
294+ | contextColorCount t <= 256 = SetTo $ Color240 v
324− clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c
325− clampColor' (ColorMode240 colorCount) c@(Color240 n)
326− | n <= colorCount = SetTo c
327− | otherwise = Default
295+ | otherwise
328− clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
296+ = let p :: Double = fromIntegral v / 240.0
329− clampColor' colorMode (color240 r g b)
297+ v' = floor $ p * (fromIntegral $ contextColorCount t)
330−
298+ in SetTo $ Color240 v'
331− clampColor' FullColor c = SetTo c
src/Graphics/Vty/Output/Mock.hs+8−11
@@ -2,16 +2,16 @@
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4-- | This provides a mock terminal implementation that is nice for
4-- | This provides a mock terminal implementation that is nice for
5−-- testing. This transforms the output operations to visible characters
5+-- testing. This transforms the output operations to visible characters.
6−-- which is useful for testing.
6+-- Which is nice for some tests.
7module Graphics.Vty.Output.Mock
7module Graphics.Vty.Output.Mock
8 ( MockData
8 ( MockData
9 , mockTerminal
9 , mockTerminal
10 )
10 )
11where
11where
12
12
13−import Graphics.Vty.Image (DisplayRegion)
13+import Graphics.Vty.Prelude
14−import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
14+
15import Graphics.Vty.Output.Interface
15import Graphics.Vty.Output.Interface
16
16
17import Blaze.ByteString.Builder.Word (writeWord8)
17import Blaze.ByteString.Builder.Word (writeWord8)
@@ -31,7 +31,7 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString)
31-- without considering terminal specific issues.
31-- without considering terminal specific issues.
32--
32--
33-- The mock implementation is useful in manually determining if the
33-- The mock implementation is useful in manually determining if the
34−-- sequence of terminal operations matches the expected sequence. The
34+-- sequence of terminal operations matches the expected sequence. So
35-- requirement of the produced representation is simplicity in parsing
35-- requirement of the produced representation is simplicity in parsing
36-- the text representation and determining how the picture was mapped to
36-- the text representation and determining how the picture was mapped to
37-- terminal operations.
37-- terminal operations.
@@ -49,19 +49,16 @@ mockTerminal r = liftIO $ do
49 , releaseDisplay = return ()
49 , releaseDisplay = return ()
50 , ringTerminalBell = return ()
50 , ringTerminalBell = return ()
51 , supportsBell = return False
51 , supportsBell = return False
52− , supportsItalics = return False
53− , supportsStrikethrough = return False
54− , setDisplayBounds = const $ return ()
55 , displayBounds = return r
52 , displayBounds = return r
56 , outputByteBuffer = \bytes -> do
53 , outputByteBuffer = \bytes -> do
57 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
54 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
58 writeIORef outRef $ UTF8.fromRep bytes
55 writeIORef outRef $ UTF8.fromRep bytes
56+ , contextColorCount = 16
59 , supportsCursorVisibility = True
57 , supportsCursorVisibility = True
60 , supportsMode = const False
58 , supportsMode = const False
61 , setMode = const $ const $ return ()
59 , setMode = const $ const $ return ()
62 , getModeStatus = const $ return False
60 , getModeStatus = const $ return False
63 , assumedStateRef = newAssumedStateRef
61 , assumedStateRef = newAssumedStateRef
64− , outputColorMode = ColorMode16
65 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
62 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
66 { contextRegion = rActual
63 { contextRegion = rActual
67 , contextDevice = tActual
64 , contextDevice = tActual
@@ -76,10 +73,10 @@ mockTerminal r = liftIO $ do
76 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
73 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
77 -- An attr change is always visualized as the single
74 -- An attr change is always visualized as the single
78 -- character 'A'
75 -- character 'A'
79− , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
76+ , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
80 -- default attr is always visualized as the single
77 -- default attr is always visualized as the single
81 -- character 'D'
78 -- character 'D'
82− , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
79+ , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'
83 -- row end is always visualized as the single character
80 -- row end is always visualized as the single character
84 -- 'E'
81 -- 'E'
85 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
82 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
src/Graphics/Vty/Output/TerminfoBased.hs+99−208
@@ -1,40 +1,44 @@
1−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3+{-# LANGUAGE FlexibleInstances #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
5{-# CFILES gwinsz.c #-}
5{-# CFILES gwinsz.c #-}
6
6
7+#ifndef MIN_VERSION_base
8+#defined MIN_VERSION_base(x,y,z) 1
9+#endif
10+
7−-- | Terminfo-based terminal output driver.
11+-- | Terminfo based terminal handling.
12+--
13+-- The color handling assumes tektronix like. No HP support provided. If
14+-- the terminal is not one I have easy access to then color support is
15+-- entirely based of the docs. Probably with some assumptions mixed in.
8--
16--
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
17-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
10module Graphics.Vty.Output.TerminfoBased
18module Graphics.Vty.Output.TerminfoBased
11 ( reserveTerminal
19 ( reserveTerminal
12− , setWindowSize
13 )
20 )
14where
21where
15
22
16−import Control.Monad (when)
23+import Graphics.Vty.Prelude
17−import Data.Bits (shiftL, (.&.))
24+
18−import qualified Data.ByteString as BS
19import Data.ByteString.Internal (toForeignPtr)
25import Data.ByteString.Internal (toForeignPtr)
20import Data.Terminfo.Parse
26import Data.Terminfo.Parse
21import Data.Terminfo.Eval
27import Data.Terminfo.Eval
22
28
23import Graphics.Vty.Attributes
29import Graphics.Vty.Attributes
24−import Graphics.Vty.Image (DisplayRegion)
25import Graphics.Vty.DisplayAttributes
30import Graphics.Vty.DisplayAttributes
26import Graphics.Vty.Output.Interface
31import Graphics.Vty.Output.Interface
27
32
28−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
33+import Blaze.ByteString.Builder (Write, writeToByteString)
34+
35+import Control.Monad.Trans
29
36
37+import Data.Bits ((.&.))
30import Data.IORef
38import Data.IORef
31import Data.Maybe (isJust, isNothing, fromJust)
39import Data.Maybe (isJust, isNothing, fromJust)
32import Data.Word
40import Data.Word
33
41
34−#if !MIN_VERSION_base(4,8,0)
35−import Data.Foldable (foldMap)
36−#endif
37−
38import Foreign.C.Types ( CInt(..), CLong(..) )
42import Foreign.C.Types ( CInt(..), CLong(..) )
39import Foreign.ForeignPtr (withForeignPtr)
43import Foreign.ForeignPtr (withForeignPtr)
40import Foreign.Ptr (Ptr, plusPtr)
44import Foreign.Ptr (Ptr, plusPtr)
@@ -43,12 +47,18 @@ import qualified System.Console.Terminfo as Terminfo
43import System.Posix.IO (fdWriteBuf)
47import System.Posix.IO (fdWriteBuf)
44import System.Posix.Types (Fd(..))
48import System.Posix.Types (Fd(..))
45
49
50+#if !(MIN_VERSION_base(4,8,0))
51+import Data.Foldable (foldMap)
52+import Data.Monoid
53+#endif
54+
46data TerminfoCaps = TerminfoCaps
55data TerminfoCaps = TerminfoCaps
47 { smcup :: Maybe CapExpression
56 { smcup :: Maybe CapExpression
48 , rmcup :: Maybe CapExpression
57 , rmcup :: Maybe CapExpression
49 , cup :: CapExpression
58 , cup :: CapExpression
50 , cnorm :: Maybe CapExpression
59 , cnorm :: Maybe CapExpression
51 , civis :: Maybe CapExpression
60 , civis :: Maybe CapExpression
61+ , supportsNoColors :: Bool
52 , useAltColorMap :: Bool
62 , useAltColorMap :: Bool
53 , setForeColor :: CapExpression
63 , setForeColor :: CapExpression
54 , setBackColor :: CapExpression
64 , setBackColor :: CapExpression
@@ -63,10 +73,6 @@ data DisplayAttrCaps = DisplayAttrCaps
63 { setAttrStates :: Maybe CapExpression
73 { setAttrStates :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
74 , enterStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
75 , exitStandout :: Maybe CapExpression
66− , enterItalic :: Maybe CapExpression
67− , exitItalic :: Maybe CapExpression
68− , enterStrikethrough :: Maybe CapExpression
69− , exitStrikethrough :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
76 , enterUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
77 , exitUnderline :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
78 , enterReverseVideo :: Maybe CapExpression
@@ -93,95 +99,75 @@ sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
93sendCapToTerminal t cap capParams = do
99sendCapToTerminal t cap capParams = do
94 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
100 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
95
101
96−-- | Constructs an output driver that uses terminfo for all control
97−-- codes. While this should provide the most compatible terminal,
102+{- | Uses terminfo for all control codes. While this should provide the
98−-- terminfo does not support some features that would increase
103+ - most compatible terminal terminfo does not support some features that
99−-- efficiency and improve compatibility:
104+ - would increase efficiency and improve compatibility:
100−--
105+ -
101−-- * determining the character encoding supported by the terminal.
106+ - * determine the character encoding supported by the terminal. Should
102−-- Should this be taken from the LANG environment variable?
107+ - this be taken from the LANG environment variable?
103−--
108+ -
104−-- * Providing independent string capabilities for all display
109+ - * Provide independent string capabilities for all display attributes.
105−-- attributes.
110+ -
111+ - todo: Some display attributes like underline and bold have
112+ - independent string capabilities that should be used instead of the
113+ - generic "sgr" string capability.
114+ -}
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
115+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
107−reserveTerminal termName outFd colorMode = do
116+reserveTerminal termName outFd = liftIO $ do
108 ti <- Terminfo.setupTerm termName
117 ti <- Terminfo.setupTerm termName
109 -- assumes set foreground always implies set background exists.
118 -- assumes set foreground always implies set background exists.
110 -- if set foreground is not set then all color changing style
119 -- if set foreground is not set then all color changing style
111 -- attributes are filtered.
120 -- attributes are filtered.
112 msetaf <- probeCap ti "setaf"
121 msetaf <- probeCap ti "setaf"
113 msetf <- probeCap ti "setf"
122 msetf <- probeCap ti "setf"
114− let (useAlt, setForeCap)
123+ let (noColors, useAlt, setForeCap)
115 = case msetaf of
124 = case msetaf of
116− Just setaf -> (False, setaf)
125+ Just setaf -> (False, False, setaf)
117 Nothing -> case msetf of
126 Nothing -> case msetf of
118− Just setf -> (True, setf)
127+ Just setf -> (False, True, setf)
119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
128+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
120 msetab <- probeCap ti "setab"
129 msetab <- probeCap ti "setab"
121 msetb <- probeCap ti "setb"
130 msetb <- probeCap ti "setb"
122− let setBackCap
131+ let set_back_cap
123 = case msetab of
132 = case msetab of
124− Just setab -> setab
125 Nothing -> case msetb of
133 Nothing -> case msetb of
126 Just setb -> setb
134 Just setb -> setb
127 Nothing -> error $ "no back color support for terminal " ++ termName
135 Nothing -> error $ "no back color support for terminal " ++ termName
128−
136+ Just setab -> setab
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−
147 terminfoCaps <- pure TerminfoCaps
137 terminfoCaps <- pure TerminfoCaps
148 <*> probeCap ti "smcup"
138 <*> probeCap ti "smcup"
149 <*> probeCap ti "rmcup"
139 <*> probeCap ti "rmcup"
150 <*> requireCap ti "cup"
140 <*> requireCap ti "cup"
151 <*> probeCap ti "cnorm"
141 <*> probeCap ti "cnorm"
152 <*> probeCap ti "civis"
142 <*> probeCap ti "civis"
143+ <*> pure noColors
153 <*> pure useAlt
144 <*> pure useAlt
154 <*> pure setForeCap
145 <*> pure setForeCap
155− <*> pure setBackCap
146+ <*> pure set_back_cap
156 <*> requireCap ti "sgr0"
147 <*> requireCap ti "sgr0"
157 <*> requireCap ti "clear"
148 <*> requireCap ti "clear"
158 <*> requireCap ti "el"
149 <*> requireCap ti "el"
159 <*> currentDisplayAttrCaps ti
150 <*> currentDisplayAttrCaps ti
160 <*> probeCap ti "bel"
151 <*> probeCap ti "bel"
152+ newAssumedStateRef <- newIORef initialAssumedState
161 let t = Output
153 let t = Output
162 { terminalID = termName
154 { terminalID = termName
163− , releaseTerminal = do
155+ , releaseTerminal = liftIO $ do
164 sendCap setDefaultAttr []
156 sendCap setDefaultAttr []
165 maybeSendCap cnorm []
157 maybeSendCap cnorm []
166 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
158 , 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))
171− , ringTerminalBell = maybeSendCap ringBellAudio []
159+ , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
172− , reserveDisplay = do
160+ , reserveDisplay = liftIO $ do
173 -- If there is no support for smcup: Clear the screen
161 -- If there is no support for smcup: Clear the screen
174 -- and then move the mouse to the home position to
162 -- and then move the mouse to the home position to
175 -- approximate the behavior.
163 -- approximate the behavior.
176 maybeSendCap smcup []
164 maybeSendCap smcup []
177 sendCap clearScreen []
165 sendCap clearScreen []
178− , releaseDisplay = do
166+ , releaseDisplay = liftIO $ do
179 maybeSendCap rmcup []
167 maybeSendCap rmcup []
180 maybeSendCap cnorm []
168 maybeSendCap cnorm []
181− , setDisplayBounds = \(w, h) ->
182− setWindowSize outFd (w, h)
183 , displayBounds = do
169 , displayBounds = do
184− rawSize <- getWindowSize outFd
170+ rawSize <- liftIO $ getWindowSize outFd
185 case rawSize of
171 case rawSize of
186 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
172 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
187 | otherwise -> return (w,h)
173 | otherwise -> return (w,h)
@@ -192,48 +178,51 @@ reserveTerminal termName outFd colorMode = do
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
178 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
179 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
194 ++ " Please report this bug to vty project."
180 ++ " Please report this bug to vty project."
181+ , contextColorCount
182+ = case supportsNoColors terminfoCaps of
183+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
184+ Nothing -> 8
185+ Just v -> toEnum v
186+ True -> 1
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
187 , supportsCursorVisibility = isJust $ civis terminfoCaps
196− , supportsMode = terminfoModeSupported
188+ , supportsMode = const False
197− , setMode = terminfoSetMode
189+ , setMode = const $ const $ return ()
198− , getModeStatus = terminfoModeStatus
190+ , getModeStatus = const $ return False
199 , assumedStateRef = newAssumedStateRef
191 , assumedStateRef = newAssumedStateRef
200− , outputColorMode = colorMode
201 -- I think fix would help assure tActual is the only
192 -- I think fix would help assure tActual is the only
202 -- reference. I was having issues tho.
193 -- reference. I was having issues tho.
203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
194+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
204 }
195 }
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
196 sendCap s = sendCapToTerminal t (s terminfoCaps)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
197 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
207 return t
198 return t
208
199
209−requireCap :: Terminfo.Terminal -> String -> IO CapExpression
200+requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
210requireCap ti capName
201requireCap ti capName
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
202 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
203 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
213 Just capStr -> parseCap capStr
204 Just capStr -> parseCap capStr
214
205
215−probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
206+probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
216probeCap ti capName
207probeCap ti capName
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
208 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
218 Nothing -> return Nothing
209 Nothing -> return Nothing
219 Just capStr -> Just <$> parseCap capStr
210 Just capStr -> Just <$> parseCap capStr
220
211
221−parseCap :: String -> IO CapExpression
212+parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
222parseCap capStr = do
213parseCap capStr = do
223 case parseCapExpression capStr of
214 case parseCapExpression capStr of
224 Left e -> fail $ show e
215 Left e -> fail $ show e
225 Right cap -> return cap
216 Right cap -> return cap
226
217
227−currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
218+currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
219+ => Terminfo.Terminal
220+ -> m DisplayAttrCaps
228currentDisplayAttrCaps ti
221currentDisplayAttrCaps ti
229 = pure DisplayAttrCaps
222 = pure DisplayAttrCaps
230 <*> probeCap ti "sgr"
223 <*> probeCap ti "sgr"
231 <*> probeCap ti "smso"
224 <*> probeCap ti "smso"
232 <*> probeCap ti "rmso"
225 <*> probeCap ti "rmso"
233− <*> probeCap ti "sitm"
234− <*> probeCap ti "ritm"
235− <*> probeCap ti "smxx"
236− <*> probeCap ti "rmxx"
237 <*> probeCap ti "smul"
226 <*> probeCap ti "smul"
238 <*> probeCap ti "rmul"
227 <*> probeCap ti "rmul"
239 <*> probeCap ti "rev"
228 <*> probeCap ti "rev"
@@ -247,13 +236,6 @@ getWindowSize fd = do
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
236 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
248 return (fromIntegral b, fromIntegral a)
237 return (fromIntegral b, fromIntegral a)
249
238
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−
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
239terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
258terminfoDisplayContext tActual terminfoCaps r = return dc
240terminfoDisplayContext tActual terminfoCaps r = return dc
259 where dc = DisplayContext
241 where dc = DisplayContext
@@ -267,35 +249,15 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
267 Nothing -> error "this terminal does not support hide cursor"
249 Nothing -> error "this terminal does not support hide cursor"
268 Just c -> writeCapExpr c []
250 Just c -> writeCapExpr c []
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
251 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270− , writeDefaultAttr = \urlsEnabled ->
271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
252+ , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
272− (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
273− (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274− Just cap -> writeCapExpr cap []
275− Nothing -> mempty
276− )
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
253 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
278 , inlineHack = return ()
254 , inlineHack = return ()
279 }
255 }
280
256
281−-- | Write the escape sequences that are used in some terminals to
282−-- include embedded hyperlinks. As of yet, this information isn't
283−-- included in termcap or terminfo, so this writes them directly
284−-- instead of looking up the appropriate capabilities.
285−writeURLEscapes :: URLDiff -> Write
286−writeURLEscapes (LinkTo url) =
287− foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`
288− foldMap writeStorable (BS.unpack url) `mappend`
289− writeStorable (0x07 :: Word8)
290−writeURLEscapes EndLink =
291− foldMap writeStorable (BS.unpack "\x1b]8;;\a")
292−writeURLEscapes NoLinkChange =
293− mempty
294−
295-- | Portably setting the display attributes is a giant pain in the ass.
257-- | Portably setting the display attributes is a giant pain in the ass.
296--
258--
297-- If the terminal supports the sgr capability (which sets the on/off
259-- If the terminal supports the sgr capability (which sets the on/off
298−-- state of each style directly; and, for no good reason, resets the
260+-- state of each style directly ; and, for no good reason, resets the
299-- colors to the default) this procedure is used:
261-- colors to the default) this procedure is used:
300--
262--
301-- 0. set the style attributes. This resets the fore and back color.
263-- 0. set the style attributes. This resets the fore and back color.
@@ -322,36 +284,37 @@ writeURLEscapes NoLinkChange =
322--
284--
323-- This equation implements the above logic.
285-- This equation implements the above logic.
324--
286--
325−-- Note that this assumes the removal of color changes in the
287+-- \todo This assumes the removal of color changes in the display
326−-- display attributes is done as expected with noColors == True. See
288+-- attributes is done as expected with noColors == True. See
327−-- `limitAttrForDisplay`.
289+-- `limitAttrForDisplay`
328--
290--
329−-- Note that this optimizes for fewer state changes followed by fewer
291+-- \todo This assumes that fewer state changes, followed by fewer
330−-- bytes.
292+-- bytes, is what to optimize. I haven't measured this or even examined
293+-- terminal implementations. *shrug*
331−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
294+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
332−terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
295+terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
333− urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
296+ case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
334 -- The only way to reset either color, portably, to the default
297 -- The only way to reset either color, portably, to the default
335 -- is to use either the set state capability or the set default
298 -- is to use either the set state capability or the set default
336 -- capability.
299 -- capability.
337− True -> do
300+ True -> do
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
301 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
339− (fixedStyle attr)
302+ (fixedStyle attr )
340 (styleToApplySeq $ fixedStyle attr) of
303 (styleToApplySeq $ fixedStyle attr) of
341 -- only way to reset a color to the defaults
304 -- only way to reset a color to the defaults
342− EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
305+ EnterExitSeq caps -> writeDefaultAttr dc
343 `mappend`
306 `mappend`
344 foldMap (\cap -> writeCapExpr cap []) caps
307 foldMap (\cap -> writeCapExpr cap []) caps
345 `mappend`
308 `mappend`
346 setColors
309 setColors
347 -- implicitly resets the colors to the defaults
310 -- implicitly resets the colors to the defaults
348 SetState state -> writeCapExpr (fromJust $ setAttrStates
311 SetState state -> writeCapExpr (fromJust $ setAttrStates
349− $ displayAttrCaps terminfoCaps
312+ $ displayAttrCaps
313+ $ terminfoCaps
350 )
314 )
351 (sgrArgsForState state)
315 (sgrArgsForState state)
352− `mappend` setItalics
316+ `mappend`
353− `mappend` setStrikethrough
354− `mappend` setColors
317+ setColors
355 -- Otherwise the display colors are not changing or changing
318 -- Otherwise the display colors are not changing or changing
356 -- between two non-default points.
319 -- between two non-default points.
357 False -> do
320 False -> do
@@ -369,99 +332,45 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
369 -- applied states.
332 -- applied states.
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
333 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
371 `mappend`
334 `mappend`
372− writeColorDiff Foreground (foreColorDiff diffs)
335+ writeColorDiff setForeColor (foreColorDiff diffs)
373 `mappend`
336 `mappend`
374− writeColorDiff Background (backColorDiff diffs)
337+ writeColorDiff setBackColor (backColorDiff diffs)
375 -- implicitly resets the colors to the defaults
338 -- implicitly resets the colors to the defaults
376 SetState state -> writeCapExpr (fromJust $ setAttrStates
339 SetState state -> writeCapExpr (fromJust $ setAttrStates
377 $ displayAttrCaps terminfoCaps
340 $ displayAttrCaps terminfoCaps
378 )
341 )
379 (sgrArgsForState state)
342 (sgrArgsForState state)
380− `mappend` setItalics
381− `mappend` setStrikethrough
382 `mappend` setColors
343 `mappend` setColors
383 where
344 where
384− urlAttrs True = writeURLEscapes (urlDiff diffs)
385− urlAttrs False = mempty
386 colorMap = case useAltColorMap terminfoCaps of
345 colorMap = case useAltColorMap terminfoCaps of
387 False -> ansiColorIndex
346 False -> ansiColorIndex
388 True -> altColorIndex
347 True -> altColorIndex
389 attr = fixDisplayAttr prevAttr reqAttr
348 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
404 setColors =
349 setColors =
405 (case fixedForeColor attr of
350 (case fixedForeColor attr of
406− Just c -> writeColor Foreground c
351+ Just c -> writeCapExpr (setForeColor terminfoCaps)
352+ [toEnum $ colorMap c]
407 Nothing -> mempty)
353 Nothing -> mempty)
408 `mappend`
354 `mappend`
409 (case fixedBackColor attr of
355 (case fixedBackColor attr of
410− Just c -> writeColor Background c
356+ Just c -> writeCapExpr (setBackColor terminfoCaps)
357+ [toEnum $ colorMap c]
411 Nothing -> mempty)
358 Nothing -> mempty)
412− writeColorDiff _side NoColorChange
359+ writeColorDiff _f NoColorChange
413 = mempty
360 = mempty
414− writeColorDiff _side ColorToDefault
361+ writeColorDiff _f ColorToDefault
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
362 = error "ColorToDefault is not a possible case for applyColorDiffs"
416− writeColorDiff side (SetColor c)
363+ writeColorDiff f (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 =
426− writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]
364+ = writeCapExpr (f 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"
452
365
453-- | The color table used by a terminal is a 16 color set followed by a
366-- | The color table used by a terminal is a 16 color set followed by a
454-- 240 color set that might not be supported by the terminal.
367-- 240 color set that might not be supported by the terminal.
455--
368--
456−-- This takes a Color which clearly identifies which palette to use and
369+-- This takes a Color which clearly identifies which pallete to use and
457−-- computes the index into the full 256 color palette.
370+-- computes the index into the full 256 color pallete.
458ansiColorIndex :: Color -> Int
371ansiColorIndex :: Color -> Int
459ansiColorIndex (ISOColor v) = fromEnum v
372ansiColorIndex (ISOColor v) = fromEnum v
460ansiColorIndex (Color240 v) = 16 + fromEnum v
373ansiColorIndex (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− ]
465
374
466-- | For terminals without setaf/setab
375-- | For terminals without setaf/setab
467--
376--
@@ -478,10 +387,6 @@ altColorIndex (ISOColor 6) = 3
478altColorIndex (ISOColor 7) = 7
387altColorIndex (ISOColor 7) = 7
479altColorIndex (ISOColor v) = fromEnum v
388altColorIndex (ISOColor v) = fromEnum v
480altColorIndex (Color240 v) = 16 + fromEnum v
389altColorIndex (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− ]
485
390
486{- | The sequence of terminfo caps to apply a given style are determined
391{- | The sequence of terminfo caps to apply a given style are determined
487 - according to these rules.
392 - according to these rules.
@@ -508,8 +413,6 @@ data DisplayAttrSeq
508data DisplayAttrState = DisplayAttrState
413data DisplayAttrState = DisplayAttrState
509 { applyStandout :: Bool
414 { applyStandout :: Bool
510 , applyUnderline :: Bool
415 , applyUnderline :: Bool
511− , applyItalic :: Bool
512− , applyStrikethrough :: Bool
513 , applyReverseVideo :: Bool
416 , applyReverseVideo :: Bool
514 , applyBlink :: Bool
417 , applyBlink :: Bool
515 , applyDim :: Bool
418 , applyDim :: Bool
@@ -546,10 +449,6 @@ reqDisplayCapSeqFor caps s diffs
546 -- set state cap then just use the set state cap.
449 -- set state cap then just use the set state cap.
547 ( True, True ) -> SetState $ stateForStyle s
450 ( True, True ) -> SetState $ stateForStyle s
548 where
451 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
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
452 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
453 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
454 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -562,10 +461,6 @@ reqDisplayCapSeqFor caps s diffs
562 noEnterExitCap RemoveDim = True
461 noEnterExitCap RemoveDim = True
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
462 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
564 noEnterExitCap RemoveBold = True
463 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
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
464 enterExitCap ApplyStandout = fromJust $ enterStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
465 enterExitCap RemoveStandout = fromJust $ exitStandout caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
466 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -579,8 +474,6 @@ stateForStyle :: Style -> DisplayAttrState
579stateForStyle s = DisplayAttrState
474stateForStyle s = DisplayAttrState
580 { applyStandout = isStyleSet standout
475 { applyStandout = isStyleSet standout
581 , applyUnderline = isStyleSet underline
476 , applyUnderline = isStyleSet underline
582− , applyItalic = isStyleSet italic
583− , applyStrikethrough = isStyleSet strikethrough
584 , applyReverseVideo = isStyleSet reverseVideo
477 , applyReverseVideo = isStyleSet reverseVideo
585 , applyBlink = isStyleSet blink
478 , applyBlink = isStyleSet blink
586 , applyDim = isStyleSet dim
479 , applyDim = isStyleSet dim
@@ -592,12 +485,10 @@ styleToApplySeq :: Style -> [StyleStateChange]
592styleToApplySeq s = concat
485styleToApplySeq s = concat
593 [ applyIfRequired ApplyStandout standout
486 [ applyIfRequired ApplyStandout standout
594 , applyIfRequired ApplyUnderline underline
487 , applyIfRequired ApplyUnderline underline
595− , applyIfRequired ApplyItalic italic
596− , applyIfRequired ApplyStrikethrough strikethrough
597 , applyIfRequired ApplyReverseVideo reverseVideo
488 , applyIfRequired ApplyReverseVideo reverseVideo
598 , applyIfRequired ApplyBlink blink
489 , applyIfRequired ApplyBlink blink
599 , applyIfRequired ApplyDim dim
490 , applyIfRequired ApplyDim dim
600− , applyIfRequired ApplyBold bold
491+ , applyIfRequired ApplyBlink bold
601 ]
492 ]
602 where
493 where
603 applyIfRequired op flag
494 applyIfRequired op flag
src/Graphics/Vty/Output/XTermColor.hs+32−47
@@ -1,7 +1,10 @@
1−{-# Language CPP #-}
1+{-# LANGUAGE CPP #-}
2+
3+#ifndef MIN_VERSION_base
4+#defined MIN_VERSION_base(x,y,z) 1
5+#endif
6+
2-- Copyright 2009-2010 Corey O'Connor
7-- Copyright 2009-2010 Corey O'Connor
3−-- | Xterm output driver. This uses the Terminfo driver with some
4−-- extensions for Xterm.
5module Graphics.Vty.Output.XTermColor
8module Graphics.Vty.Output.XTermColor
6 ( reserveTerminal
9 ( reserveTerminal
7 )
10 )
@@ -9,42 +12,31 @@ where
9
12
10import Graphics.Vty.Output.Interface
13import Graphics.Vty.Output.Interface
11import Graphics.Vty.Input.Mouse
14import Graphics.Vty.Input.Mouse
12−import Graphics.Vty.Input.Focus
13−import Graphics.Vty.Attributes.Color (ColorMode)
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
15import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
15
16
16import Blaze.ByteString.Builder (writeToByteString)
17import Blaze.ByteString.Builder (writeToByteString)
17import Blaze.ByteString.Builder.Word (writeWord8)
18import Blaze.ByteString.Builder.Word (writeWord8)
18
19
19−import qualified Data.ByteString.Char8 as BS8
20−import Data.ByteString.Char8 (ByteString)
21−import Foreign.Ptr (castPtr)
22−
23import Control.Monad (void, when)
20import Control.Monad (void, when)
24import Control.Monad.Trans
21import Control.Monad.Trans
25−import Data.Char (toLower)
26import Data.IORef
22import Data.IORef
27
23
28−import System.Posix.IO (fdWriteBuf)
24+import System.Posix.IO (fdWrite)
29−import System.Posix.Types (ByteCount, Fd)
25+import System.Posix.Types (Fd)
30import System.Posix.Env (getEnv)
26import System.Posix.Env (getEnv)
31
27
28+#if !(MIN_VERSION_base(4,8,0))
29+import Control.Applicative
30+import Data.Foldable (foldMap)
31+#endif
32+
32import Data.List (isInfixOf)
33import Data.List (isInfixOf)
33import Data.Maybe (catMaybes)
34import Data.Maybe (catMaybes)
34−
35−#if !MIN_VERSION_base(4,11,0)
36import Data.Monoid ((<>))
35import 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)
44
36
45−-- | Construct an Xterm output driver. Initialize the display to UTF-8.
37+-- | Initialize the display to UTF-8.
46−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
38+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
47−reserveTerminal variant outFd colorMode = liftIO $ do
39+reserveTerminal variant outFd = liftIO $ do
48 let flushedPut = void . fdWrite outFd
40 let flushedPut = void . fdWrite outFd
49 -- If the terminal variant is xterm-color use xterm instead since,
41 -- If the terminal variant is xterm-color use xterm instead since,
50 -- more often than not, xterm-color is broken.
42 -- more often than not, xterm-color is broken.
@@ -52,21 +44,15 @@ reserveTerminal variant outFd colorMode = liftIO $ do
52
44
53 utf8a <- utf8Active
45 utf8a <- utf8Active
54 when (not utf8a) $ flushedPut setUtf8CharSet
46 when (not utf8a) $ flushedPut setUtf8CharSet
55− t <- TerminfoBased.reserveTerminal variant' outFd colorMode
47+ t <- TerminfoBased.reserveTerminal variant' outFd
56
48
57 mouseModeStatus <- newIORef False
49 mouseModeStatus <- newIORef False
58− focusModeStatus <- newIORef False
59 pasteModeStatus <- newIORef False
50 pasteModeStatus <- newIORef False
60
51
61 let xtermSetMode t' m newStatus = do
52 let xtermSetMode t' m newStatus = do
62 curStatus <- getModeStatus t' m
53 curStatus <- getModeStatus t' m
63 when (newStatus /= curStatus) $
54 when (newStatus /= curStatus) $
64 case m of
55 case m of
65− Focus -> liftIO $ do
66− case newStatus of
67− True -> flushedPut requestFocusEvents
68− False -> flushedPut disableFocusEvents
69− writeIORef focusModeStatus newStatus
70 Mouse -> liftIO $ do
56 Mouse -> liftIO $ do
71 case newStatus of
57 case newStatus of
72 True -> flushedPut requestMouseEvents
58 True -> flushedPut requestMouseEvents
@@ -77,12 +63,9 @@ reserveTerminal variant outFd colorMode = liftIO $ do
77 True -> flushedPut enableBracketedPastes
63 True -> flushedPut enableBracketedPastes
78 False -> flushedPut disableBracketedPastes
64 False -> flushedPut disableBracketedPastes
79 writeIORef pasteModeStatus newStatus
65 writeIORef pasteModeStatus newStatus
80− Hyperlink -> setMode t Hyperlink newStatus
81
66
82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
67 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
83− xtermGetMode Focus = liftIO $ readIORef focusModeStatus
84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
68 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85− xtermGetMode Hyperlink = getModeStatus t Hyperlink
86
69
87 let t' = t
70 let t' = t
88 { terminalID = terminalID t ++ " (xterm-color)"
71 { terminalID = terminalID t ++ " (xterm-color)"
@@ -90,7 +73,6 @@ reserveTerminal variant outFd colorMode = liftIO $ do
90 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
73 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
91 setMode t' BracketedPaste False
74 setMode t' BracketedPaste False
92 setMode t' Mouse False
75 setMode t' Mouse False
93− setMode t' Focus False
94 releaseTerminal t
76 releaseTerminal t
95 , mkDisplayContext = \tActual r -> do
77 , mkDisplayContext = \tActual r -> do
96 dc <- mkDisplayContext t tActual r
78 dc <- mkDisplayContext t tActual r
@@ -104,27 +86,30 @@ reserveTerminal variant outFd colorMode = liftIO $ do
104utf8Active :: IO Bool
86utf8Active :: IO Bool
105utf8Active = do
87utf8Active = do
106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
88 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
107− results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars
89+ results <- catMaybes <$> mapM getEnv vars
108− let matches = filter ("utf8" `isInfixOf`) results <>
90+ let matches = filter ("UTF8" `isInfixOf`) results <>
109− filter ("utf-8" `isInfixOf`) results
91+ filter ("UTF-8" `isInfixOf`) results
110 return $ not $ null matches
92 return $ not $ null matches
111
93
112-- | Enable bracketed paste mode:
94-- | Enable bracketed paste mode:
113-- http://cirw.in/blog/bracketed-paste
95-- http://cirw.in/blog/bracketed-paste
114−enableBracketedPastes :: ByteString
96+enableBracketedPastes :: String
115−enableBracketedPastes = BS8.pack "\ESC[?2004h"
97+enableBracketedPastes = "\ESC[?2004h"
116
98
117-- | Disable bracketed paste mode:
99-- | Disable bracketed paste mode:
118−disableBracketedPastes :: ByteString
100+disableBracketedPastes :: String
119−disableBracketedPastes = BS8.pack "\ESC[?2004l"
101+disableBracketedPastes = "\ESC[?2004l"
120
102
121-- | These sequences set xterm based terminals to UTF-8 output.
103-- | These sequences set xterm based terminals to UTF-8 output.
122--
104--
123−-- There is no known terminfo capability equivalent to this.
105+-- \todo I don't know of a terminfo cap that is equivalent to this.
124−setUtf8CharSet, setDefaultCharSet :: ByteString
106+setUtf8CharSet, setDefaultCharSet :: String
125−setUtf8CharSet = BS8.pack "\ESC%G"
107+setUtf8CharSet = "\ESC%G"
126−setDefaultCharSet = BS8.pack "\ESC%@"
108+setDefaultCharSet = "\ESC%@"
127−
109+
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.
128xtermInlineHack :: Output -> IO ()
113xtermInlineHack :: Output -> IO ()
129xtermInlineHack t = do
114xtermInlineHack t = do
130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
115 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
src/Graphics/Vty/Picture.hs+46−59
@@ -1,36 +1,28 @@
1−-- A 'Picture' is a background paired with a set of 'Image' layers. The
1+{-# LANGUAGE BangPatterns #-}
2−-- 'Picture' data structure is representative of the final terminal
2+-- | The 'Picture' data structure is representative of the final
3−-- view.
3+-- terminal view.
4+--
5+-- A 'Picture' is a background paired with a layer of 'Image's.
4module Graphics.Vty.Picture
6module Graphics.Vty.Picture
5− ( Picture(..)
7+ ( module Graphics.Vty.Picture
6− , Cursor(..)
8+ , module Graphics.Vty.Image
7− , Background(..)
8− , emptyPicture
9− , addToTop
10− , addToBottom
11− , picForImage
12− , picForLayers
13− , picImage
14 )
9 )
15where
10where
16
11
17import Graphics.Vty.Image
12import Graphics.Vty.Image
18−import Graphics.Vty.Attributes
19
13
20import Control.DeepSeq
14import Control.DeepSeq
21
15
22−-- | A Vty picture.
16+-- | The type of images to be displayed using 'update'.
23--
17--
24−-- These can be constructed directly or using `picForImage`.
18+-- Can be constructed directly or using `picForImage`. Which provides
19+-- an initial instance with reasonable defaults for picCursor and
20+-- picBackground.
25data Picture = Picture
21data Picture = Picture
26 { picCursor :: Cursor
22 { picCursor :: Cursor
27− -- ^ The picture's cursor.
28 , picLayers :: [Image]
23 , picLayers :: [Image]
29− -- ^ The picture's image layers (top-most first).
30 , picBackground :: Background
24 , picBackground :: Background
31− -- ^ The picture's background to be displayed in locations with no
25+ }
32− -- Image data.
33− } deriving Eq
34
26
35instance Show Picture where
27instance Show Picture where
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
28 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -38,21 +30,21 @@ instance Show Picture where
38instance NFData Picture where
30instance NFData Picture where
39 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
31 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
40
32
41−-- | A picture with no cursor, background or image layers.
33+-- | a picture with no cursor, background or image layers
42emptyPicture :: Picture
34emptyPicture :: Picture
43emptyPicture = Picture NoCursor [] ClearBackground
35emptyPicture = Picture NoCursor [] ClearBackground
44
36
45−-- | Add an 'Image' as the top-most layer of a 'Picture'.
37+-- | The given 'Image' is added as the top layer of the 'Picture'
46addToTop :: Picture -> Image -> Picture
38addToTop :: Picture -> Image -> Picture
47addToTop p i = p {picLayers = i : picLayers p}
39addToTop p i = p {picLayers = i : picLayers p}
48
40
49−-- | Add an 'Image' as the bottom-most layer of a 'Picture'.
41+-- | The given 'Image' is added as the bottom layer of the 'Picture'
50addToBottom :: Picture -> Image -> Picture
42addToBottom :: Picture -> Image -> Picture
51addToBottom p i = p {picLayers = picLayers p ++ [i]}
43addToBottom p i = p {picLayers = picLayers p ++ [i]}
52
44
53−-- | Create a picture from the given image. The picture will not have a
45+-- | Create a picture for display for the given image. The picture
54−-- displayed cursor and no background pattern (ClearBackground) will be
46+-- will not have a displayed cursor and no background pattern
55−-- used.
47+-- (ClearBackground) will be used.
56picForImage :: Image -> Picture
48picForImage :: Image -> Picture
57picForImage i = Picture
49picForImage i = Picture
58 { picCursor = NoCursor
50 { picCursor = NoCursor
@@ -60,10 +52,13 @@ picForImage i = Picture
60 , picBackground = ClearBackground
52 , picBackground = ClearBackground
61 }
53 }
62
54
63−-- | Create a picture with the given layers, top-most first.
55+-- | Create a picture for display with the given layers. Ordered top to
56+-- bottom.
64--
57--
65-- The picture will not have a displayed cursor and no background
58-- The picture will not have a displayed cursor and no background
66−-- pattern (ClearBackgroun) will be used.
59+-- apttern (ClearBackgroun) will be used.
60+--
61+-- The first 'Image' is the top layer.
67picForLayers :: [Image] -> Picture
62picForLayers :: [Image] -> Picture
68picForLayers is = Picture
63picForLayers is = Picture
69 { picCursor = NoCursor
64 { picCursor = NoCursor
@@ -71,40 +66,36 @@ picForLayers is = Picture
71 , picBackground = ClearBackground
66 , picBackground = ClearBackground
72 }
67 }
73
68
74−-- | A picture can be configured to hide the cursor or to show the
69+-- | A picture can be configured either to not show the cursor or show
75−-- cursor at the specified character position.
70+-- the cursor at the specified character position.
76--
71--
77−-- There is not a 1:1 map from character positions to a row and column
72+-- There is not a 1 to 1 map from character positions to a row and
78−-- on the screen due to characters that take more than 1 column.
73+-- column on the screen due to characters that take more than 1 column.
74+--
75+-- todo: The Cursor can be given a (character,row) offset outside of the
76+-- visible bounds of the output region. In this case the cursor will not
77+-- be shown.
79data Cursor =
78data Cursor =
80− -- | Hide the cursor
79+ -- | Hide the cursor
81− NoCursor
80+ 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
90− -- | Show the cursor at the given logical column accounting for
81+ -- | Show the cursor at the given logical column accounting for
91− -- character width in the presence of multi-column characters.
82+ -- char width and row
92 | Cursor !Int !Int
83 | Cursor !Int !Int
93− -- | Show the cursor at the given absolute terminal column and row
84+ -- | Show the cursor at the given absolute terminal column and row
94 | AbsoluteCursor !Int !Int
85 | AbsoluteCursor !Int !Int
95− deriving Eq
96
86
97instance NFData Cursor where
87instance NFData Cursor where
98 rnf c = c `seq` ()
88 rnf c = c `seq` ()
99
89
100−-- | A 'Picture' has a background pattern. The background is either:
90+-- | A 'Picture' has a background pattern. The background is either
101−--
102−-- * ClearBackground, which shows the layer below or is blank if the
91+-- ClearBackground. Which shows the layer below or is blank if the
103−-- bottom layer
104−-- * A character and a display attribute
92+-- bottom layer. Or the background pattern is a character and a display
93+-- attribute. If the display attribute used previously should be used
94+-- for a background fill then use `currentAttr` for the background
95+-- attribute.
105--
96--
106−-- If the display attribute used previously should be used for a
97+-- \todo The current attribute is always set to the default attributes
107−-- background fill then use `currentAttr` for the background attribute.
98+-- at the start of updating the screen to a picture.
108data Background
99data Background
109 = Background
100 = Background
110 { backgroundChar :: Char
101 { backgroundChar :: Char
@@ -116,16 +107,12 @@ data Background
116 --
107 --
117 -- * End of line if there are no remaining non-skip ops.
108 -- * End of line if there are no remaining non-skip ops.
118 | ClearBackground
109 | ClearBackground
119− deriving Eq
120
110
121instance NFData Background where
111instance NFData Background where
122 rnf (Background c a) = c `seq` a `seq` ()
112 rnf (Background c a) = c `seq` a `seq` ()
123 rnf ClearBackground = ()
113 rnf ClearBackground = ()
124
114
125−-- | Return the top-most 'Image' layer for a picture. This is unsafe for
126−-- 'Picture's without at least one layer.
127−--
128−-- This is provided for compatibility with applications that do not use
115+-- | Compatibility with applications that do not use more than a single
129−-- more than a single layer.
116+-- layer.
130picImage :: Picture -> Image
117picImage :: Picture -> Image
131picImage = head . picLayers
118picImage = head . picLayers
src/Graphics/Vty/PictureToSpans.hs+48−15
@@ -1,14 +1,20 @@
1-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
1-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE CPP #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE NamedFieldPuns #-}
5{-# LANGUAGE NamedFieldPuns #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TemplateHaskell #-}
7
8
9+#ifndef MIN_VERSION_base
10+#defined MIN_VERSION_base(x,y,z) 1
11+#endif
12+
8-- | Transforms an image into rows of operations.
13-- | Transforms an image into rows of operations.
9module Graphics.Vty.PictureToSpans where
14module Graphics.Vty.PictureToSpans where
10
15
11−import Graphics.Vty.Attributes (Attr, currentAttr)
16+import Graphics.Vty.Prelude
17+
12import Graphics.Vty.Image
18import Graphics.Vty.Image
13import Graphics.Vty.Image.Internal
19import Graphics.Vty.Image.Internal
14import Graphics.Vty.Picture
20import Graphics.Vty.Picture
@@ -19,7 +25,12 @@ import Lens.Micro.Mtl
19import Lens.Micro.TH
25import Lens.Micro.TH
20import Control.Monad.Reader
26import Control.Monad.Reader
21import Control.Monad.State.Strict hiding ( state )
27import Control.Monad.State.Strict hiding ( state )
28+
29+#if __GLASGOW_HASKELL__ < 708
30+import Control.Monad.ST.Strict hiding ( unsafeIOToST )
31+#else
22import Control.Monad.ST.Strict
32import Control.Monad.ST.Strict
33+#endif
23
34
24import qualified Data.Vector as Vector hiding ( take, replicate )
35import qualified Data.Vector as Vector hiding ( take, replicate )
25import Data.Vector.Mutable ( MVector(..))
36import Data.Vector.Mutable ( MVector(..))
@@ -27,6 +38,10 @@ import qualified Data.Vector.Mutable as MVector
27
38
28import qualified Data.Text.Lazy as TL
39import qualified Data.Text.Lazy as TL
29
40
41+#if !(MIN_VERSION_base(4,8,0))
42+import Data.Monoid (mappend)
43+#endif
44+
30type MRowOps s = MVector s SpanOps
45type MRowOps s = MVector s SpanOps
31
46
32type MSpanOps s = MVector s SpanOp
47type MSpanOps s = MVector s SpanOp
@@ -72,16 +87,19 @@ displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
72-- | Returns the DisplayOps for an image rendered to a window the size
87-- | Returns the DisplayOps for an image rendered to a window the size
73-- of the image.
88-- of the image.
74--
89--
75−-- largely used only for debugging.
90+-- largerly used only for debugging.
76displayOpsForImage :: Image -> DisplayOps
91displayOpsForImage :: Image -> DisplayOps
77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
92displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
78
93
79-- | Produces the span ops for each layer then combines them.
94-- | Produces the span ops for each layer then combines them.
95+--
96+-- TODO: a fold over a builder function. start with span ops that are a
97+-- bg fill of the entire region.
80combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
98combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
81combinedOpsForLayers pic r
99combinedOpsForLayers pic r
82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
100 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
83 | otherwise = do
101 | otherwise = do
84− layerOps <- mapM (`buildSpans` r) (picLayers pic)
102+ layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)
85 case layerOps of
103 case layerOps of
86 [] -> fail "empty picture"
104 [] -> fail "empty picture"
87 [ops] -> substituteSkips (picBackground pic) ops
105 [ops] -> substituteSkips (picBackground pic) ops
@@ -101,6 +119,7 @@ substituteSkips ClearBackground ops = do
101 -- but only by the insertion of a non skip. all this combines to
119 -- but only by the insertion of a non skip. all this combines to
102 -- mean we can check the last operation and remove it if it's a
120 -- mean we can check the last operation and remove it if it's a
103 -- skip
121 -- skip
122+ -- todo: or does it?
104 let rowOps' = case Vector.last rowOps of
123 let rowOps' = case Vector.last rowOps of
105 Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w
124 Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w
106 _ -> rowOps
125 _ -> rowOps
@@ -136,8 +155,8 @@ mergeUnder upper lower = do
136 return upper
155 return upper
137
156
138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
157mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
139−mergeRowUnder upperRowOps =
158+mergeRowUnder upperRowOps lowerRowOps =
140− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)
159+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps
141 where
160 where
142 -- H: it will never be the case that we are out of upper ops
161 -- H: it will never be the case that we are out of upper ops
143 -- before lower ops.
162 -- before lower ops.
@@ -179,12 +198,17 @@ swapSkipsForCharSpan w c a = Vector.map f
179-- picture to the terminal.
198-- picture to the terminal.
180--
199--
181-- Crops to the given display region.
200-- Crops to the given display region.
201+--
202+-- \todo I'm pretty sure there is an algorithm that does not require a
203+-- mutable buffer.
182buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
204buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
183buildSpans image outRegion = do
205buildSpans image outRegion = do
184 -- First we create a mutable vector for each rows output operations.
206 -- First we create a mutable vector for each rows output operations.
185 outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
207 outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
186− -- It's possible that building the span operations in display order
208+ -- \todo I think building the span operations in display order
187− -- would provide better performance.
209+ -- would provide better performance. However, I got stuck trying to
210+ -- implement an algorithm that did this. This will be considered as
211+ -- a possible future optimization.
188 --
212 --
189 -- A depth first traversal of the image is performed. ordered
213 -- A depth first traversal of the image is performed. ordered
190 -- according to the column range defined by the image from least
214 -- according to the column range defined by the image from least
@@ -232,10 +256,12 @@ isOutOfBounds i s
232-- This is a very touchy algorithm. Too touchy. For instance, the
256-- This is a very touchy algorithm. Too touchy. For instance, the
233-- CropRight and CropBottom implementations are odd. They pass the
257-- CropRight and CropBottom implementations are odd. They pass the
234-- current tests but something seems terribly wrong about all this.
258-- current tests but something seems terribly wrong about all this.
259+--
260+-- \todo prove this cannot be called in an out of bounds case.
235addMaybeClipped :: forall s . Image -> BlitM s ()
261addMaybeClipped :: forall s . Image -> BlitM s ()
236addMaybeClipped EmptyImage = return ()
262addMaybeClipped EmptyImage = return ()
237addMaybeClipped (HorizText a textStr ow _cw) = do
263addMaybeClipped (HorizText a textStr ow _cw) = do
238− -- This assumes that text spans are only 1 row high.
264+ -- TODO: assumption that text spans are only 1 row high.
239 s <- use skipRows
265 s <- use skipRows
240 when (s < 1) $ do
266 when (s < 1) $ do
241 leftClip <- use skipColumns
267 leftClip <- use skipColumns
@@ -298,11 +324,12 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
298 state <- get
324 state <- get
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
325 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
300 case state^.skip of
326 case state^.skip of
327+ s -- TODO: check if clipped in other dim. if not use addUnclipped
301− s | s > size -> put $ state & skip %~ subtract size
328+ | s > size -> put $ state & skip -~ size
302 | s == 0 -> if state^.remaining > i0Dim
329 | s == 0 -> if state^.remaining > i0Dim
303 then do
330 then do
304 addMaybeClipped i0
331 addMaybeClipped i0
305− put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim
332+ put $ state & offset +~ i0Dim & remaining -~ i0Dim
306 addMaybeClipped i1
333 addMaybeClipped i1
307 else addMaybeClipped i0
334 else addMaybeClipped i0
308 | s < i0Dim ->
335 | s < i0Dim ->
@@ -311,10 +338,10 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
311 then addMaybeClipped i0
338 then addMaybeClipped i0
312 else do
339 else do
313 addMaybeClipped i0
340 addMaybeClipped i0
314− put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0
341+ put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0
315 addMaybeClipped i1
342 addMaybeClipped i1
316 | s >= i0Dim -> do
343 | s >= i0Dim -> do
317− put $ state & skip %~ subtract i0Dim
344+ put $ state & skip -~ i0Dim
318 addMaybeClipped i1
345 addMaybeClipped i1
319 _ -> fail $ name ++ " has unhandled skip class"
346 _ -> fail $ name ++ " has unhandled skip class"
320
347
@@ -323,14 +350,14 @@ addUnclippedText a txt = do
323 let op = TextSpan a usedDisplayColumns
350 let op = TextSpan a usedDisplayColumns
324 (fromIntegral $ TL.length txt)
351 (fromIntegral $ TL.length txt)
325 txt
352 txt
326− usedDisplayColumns = wctlwidth txt
353+ usedDisplayColumns = wcswidth $ TL.unpack txt
327 use rowOffset >>= snocOp op
354 use rowOffset >>= snocOp op
328
355
329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
356addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
330addRowCompletion displayRegion row = do
357addRowCompletion displayRegion row = do
331 allRowOps <- view mrowOps
358 allRowOps <- view mrowOps
332 rowOps <- lift $ lift $ MVector.read allRowOps row
359 rowOps <- lift $ lift $ MVector.read allRowOps row
333− let endX = spanOpsAffectedColumns rowOps
360+ let endX = spanOpsEffectedColumns rowOps
334 when (endX < regionWidth displayRegion) $ do
361 when (endX < regionWidth displayRegion) $ do
335 let ow = regionWidth displayRegion - endX
362 let ow = regionWidth displayRegion - endX
336 snocOp (Skip ow) row
363 snocOp (Skip ow) row
@@ -343,6 +370,12 @@ snocOp !op !row = do
343 lift $ lift $ do
370 lift $ lift $ do
344 ops <- MVector.read theMrowOps row
371 ops <- MVector.read theMrowOps row
345 let ops' = Vector.snoc ops op
372 let ops' = Vector.snoc ops op
346− when (spanOpsAffectedColumns ops' > regionWidth theRegion)
373+ when (spanOpsEffectedColumns ops' > regionWidth theRegion)
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
374 $ fail $ "row " ++ show row ++ " now exceeds region width"
348 MVector.write theMrowOps row ops'
375 MVector.write theMrowOps row ops'
376+
377+(-~) :: Num a => ASetter s t a a -> a -> s -> t
378+l -~ n = over l (subtract n)
379+
380+(+~) :: Num a => ASetter s t a a -> a -> s -> t
381+l +~ n = over l (n +)
src/Graphics/Vty/Prelude.hsnew file+19
@@ -0,0 +1,19 @@
1+-- | Prelude for Vty modules. Not particularly useful outside of Vty.
2+module Graphics.Vty.Prelude
3+ ( module Graphics.Vty.Prelude
4+ , module Control.Applicative
5+ , module Control.Monad
6+ )
7+where
8+
9+import Control.Applicative hiding ((<|>))
10+import Control.Monad
11+
12+-- | Named alias for a Int pair
13+type DisplayRegion = (Int,Int)
14+
15+regionWidth :: DisplayRegion -> Int
16+regionWidth = fst
17+
18+regionHeight :: DisplayRegion -> Int
19+regionHeight = snd
src/Graphics/Vty/Span.hs+47−34
@@ -1,15 +1,22 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
3-- | A picture is translated into a sequences of state changes and
5-- | A picture is translated into a sequences of state changes and
6+-- character spans. State changes are currently limited to new attribute
4−-- character spans. The attribute is applied to all following spans,
7+-- values. The attribute is applied to all following spans. Including
5−-- including spans of the next row. The nth element of the sequence
8+-- spans of the next row. The nth element of the sequence represents the
6−-- represents the nth row (from top to bottom) of the picture to render.
9+-- nth row (from top to bottom) of the picture to render.
7--
10--
8-- A span op sequence will be defined for all rows and columns (and no
11-- A span op sequence will be defined for all rows and columns (and no
9−-- more) of the region provided with the picture to 'spansForPic'.
12+-- more) of the region provided with the picture to `spansForPic`.
13+--
14+-- todo: Partition attribute changes into multiple categories according
15+-- to the serialized representation of the various attributes.
10module Graphics.Vty.Span where
16module Graphics.Vty.Span where
11
17
12−import Graphics.Vty.Attributes (Attr)
18+import Graphics.Vty.Prelude
19+
13import Graphics.Vty.Image
20import Graphics.Vty.Image
14import Graphics.Vty.Image.Internal ( clipText )
21import Graphics.Vty.Image.Internal ( clipText )
15
22
@@ -17,40 +24,44 @@ import qualified Data.Text.Lazy as TL
17import Data.Vector (Vector)
24import Data.Vector (Vector)
18import qualified Data.Vector as Vector
25import qualified Data.Vector as Vector
19
26
20−-- | This represents an operation on the terminal: either an attribute
27+-- | This represents an operation on the terminal. Either an attribute
21-- change or the output of a text string.
28-- change or the output of a text string.
22data SpanOp =
29data SpanOp =
23− -- | A span of UTF-8 text occupies a specific number of screen space
30+ -- | a span of UTF-8 text occupies a specific number of screen space
24− -- columns. A single UTF character does not necessarily represent 1
31+ -- columns. A single UTF character does not necessarially represent
25− -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width
32+ -- 1 colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output
26− -- in columns] [number of characters] [data]
33+ -- width in columns] [number of characters] [data]
27 TextSpan
34 TextSpan
28 { textSpanAttr :: !Attr
35 { textSpanAttr :: !Attr
29 , textSpanOutputWidth :: !Int
36 , textSpanOutputWidth :: !Int
30 , textSpanCharWidth :: !Int
37 , textSpanCharWidth :: !Int
31 , textSpanText :: DisplayText
38 , textSpanText :: DisplayText
32 }
39 }
33− -- | Skips the given number of columns.
40+ -- | Skips the given number of columns
41+ -- A skip is transparent.... maybe? I am not sure how attribute
42+ -- changes interact.
43+ -- todo: separate from this type.
34 | Skip !Int
44 | Skip !Int
35− -- | Marks the end of a row. Specifies how many columns are
45+ -- | Marks the end of a row. specifies how many columns are
36 -- remaining. These columns will not be explicitly overwritten with
46 -- remaining. These columns will not be explicitly overwritten with
37 -- the span ops. The terminal is require to assure the remaining
47 -- the span ops. The terminal is require to assure the remaining
38 -- columns are clear.
48 -- columns are clear.
49+ -- todo: separate from this type.
39 | RowEnd !Int
50 | RowEnd !Int
40 deriving Eq
51 deriving Eq
41
52
42−-- | A vector of span operations executed in succession. This represents
53+-- | vector of span operations. executed in succession. This represents
43-- the operations required to render a row of the terminal. The
54-- the operations required to render a row of the terminal. The
44−-- operations in one row may affect subsequent rows. For example,
55+-- operations in one row may effect subsequent rows.
45−-- setting the foreground color in one row will affect all subsequent
56+-- EG: Setting the foreground color in one row will effect all
46−-- rows until the foreground color is changed.
57+-- subsequent rows until the foreground color is changed.
47type SpanOps = Vector SpanOp
58type SpanOps = Vector SpanOp
48
59
49dropOps :: Int -> SpanOps -> SpanOps
60dropOps :: Int -> SpanOps -> SpanOps
50dropOps w = snd . splitOpsAt w
61dropOps w = snd . splitOpsAt w
51
62
52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
63splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
53−splitOpsAt = splitOpsAt'
64+splitOpsAt inW inOps = splitOpsAt' inW inOps
54 where
65 where
55 splitOpsAt' 0 ops = (Vector.empty, ops)
66 splitOpsAt' 0 ops = (Vector.empty, ops)
56 splitOpsAt' remainingColumns ops = case Vector.head ops of
67 splitOpsAt' remainingColumns ops = case Vector.head ops of
@@ -82,7 +93,7 @@ splitOpsAt = splitOpsAt'
82 )
93 )
83 RowEnd _ -> error "cannot split ops containing a row end"
94 RowEnd _ -> error "cannot split ops containing a row end"
84
95
85−-- | A vector of span operation vectors for display, one per row of the
96+-- | vector of span operation vectors for display. One per row of the
86-- output region.
97-- output region.
87type DisplayOps = Vector SpanOps
98type DisplayOps = Vector SpanOps
88
99
@@ -91,39 +102,41 @@ instance Show SpanOp where
91 show (Skip ow) = "Skip(" ++ show ow ++ ")"
102 show (Skip ow) = "Skip(" ++ show ow ++ ")"
92 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
103 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
93
104
94−-- | The number of columns the DisplayOps are defined for.
105+-- | Number of columns the DisplayOps are defined for
95--
106--
96−-- All spans are verified to define same number of columns.
107+-- All spans are verified to define same number of columns. See:
108+-- VerifySpanOps
97displayOpsColumns :: DisplayOps -> Int
109displayOpsColumns :: DisplayOps -> Int
98displayOpsColumns ops
110displayOpsColumns ops
99 | Vector.length ops == 0 = 0
111 | Vector.length ops == 0 = 0
100 | otherwise = Vector.length $ Vector.head ops
112 | otherwise = Vector.length $ Vector.head ops
101
113
102−-- | The number of rows the DisplayOps are defined for.
114+-- | Number of rows the DisplayOps are defined for
103displayOpsRows :: DisplayOps -> Int
115displayOpsRows :: DisplayOps -> Int
104−displayOpsRows = Vector.length
116+displayOpsRows ops = Vector.length ops
105
117
106−affectedRegion :: DisplayOps -> DisplayRegion
118+effectedRegion :: DisplayOps -> DisplayRegion
107−affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
119+effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
108
120
109−-- | The number of columns a SpanOps affects.
121+-- | The number of columns a SpanOps effects.
110−spanOpsAffectedColumns :: SpanOps -> Int
122+spanOpsEffectedColumns :: SpanOps -> Int
111−spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps
123+spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
112 where
124 where
113− spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w
125+ spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
114− spanOpsAffectedColumns' t (Skip w) = t + w
126+ spanOpsEffectedColumns' t (Skip w) = t + w
115− spanOpsAffectedColumns' t (RowEnd w) = t + w
127+ spanOpsEffectedColumns' t (RowEnd w) = t + w
116
128
117−-- | The width of a single SpanOp in columns.
129+-- | The width of a single SpanOp in columns
118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
130spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
119spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
131spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
120spanOpHasWidth (Skip ow) = Just (ow,ow)
132spanOpHasWidth (Skip ow) = Just (ow,ow)
121spanOpHasWidth (RowEnd ow) = Just (ow,ow)
133spanOpHasWidth (RowEnd ow) = Just (ow,ow)
122
134
123−-- | The number of columns to the character at the given position in the
135+-- | returns the number of columns to the character at the given
124−-- span op.
136+-- position in the span op
125columnsToCharOffset :: Int -> SpanOp -> Int
137columnsToCharOffset :: Int -> SpanOp -> Int
126columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
138columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
127− wctlwidth (TL.take (fromIntegral cx) utf8Str)
139+ let str = TL.unpack utf8Str
140+ in wcswidth (take cx str)
128columnsToCharOffset cx (Skip _) = cx
141columnsToCharOffset cx (Skip _) = cx
129columnsToCharOffset cx (RowEnd _) = cx
142columnsToCharOffset cx (RowEnd _) = cx
src/Graphics/Vty/UnicodeWidthTable/IO.hsdeleted−105
@@ -1,105 +0,0 @@
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.hsdeleted−129
@@ -1,129 +0,0 @@
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.hsdeleted−79
@@ -1,79 +0,0 @@
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.hsdeleted−29
@@ -1,29 +0,0 @@
1−module Graphics.Vty.UnicodeWidthTable.Types
2− ( UnicodeWidthTable(..)
3− , WidthTableRange(..)
4− )
5−where
6−
7−import Data.Word (Word8, Word32)
8−
9−-- | A range of code points in a width table.
10−data WidthTableRange =
11− WidthTableRange { rangeStart :: Word32
12− -- ^ The range's starting code point.
13− , rangeSize :: Word32
14− -- ^ The number of code points in the contiguous
15− -- range, beginning with the starting code point
16− -- ('rangeStart').
17− , rangeColumns :: Word8
18− -- ^ The terminal width, in columns, of all of the
19− -- characters corresponding to the code points in
20− -- this range.
21− }
22− deriving (Eq, Show)
23−
24−-- | A run-length-encoded table of Unicode character widths.
25−data UnicodeWidthTable =
26− UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
27− -- ^ The ranges in the table.
28− }
29− deriving (Show)
test/BenchImageFuzz.hs+3−1
@@ -8,6 +8,8 @@ import Verify
8import Control.Applicative
8import Control.Applicative
9import Control.Monad
9import Control.Monad
10
10
11+import Data.Default (def)
12+
11import System.Random
13import System.Random
12
14
13rand :: Arbitrary a => IO a
15rand :: Arbitrary a => IO a
@@ -19,7 +21,7 @@ randomImage = rand
19randomPicture = picForImage <$> randomImage
21randomPicture = picForImage <$> randomImage
20
22
21bench0 = do
23bench0 = do
22− vty <- mkVty defaultConfig
24+ vty <- mkVty def
23 (w,h) <- displayBounds $ outputIface vty
25 (w,h) <- displayBounds $ outputIface vty
24 let pictures = replicateM 3000 randomPicture
26 let pictures = replicateM 3000 randomPicture
25 bench ps = do
27 bench ps = do
test/BenchNoDiffOpt.hs+2−1
@@ -9,6 +9,7 @@ import Control.Concurrent( threadDelay )
9import Control.Monad( liftM2 )
9import Control.Monad( liftM2 )
10
10
11import qualified Data.ByteString.Char8 as B
11import qualified Data.ByteString.Char8 as B
12+import Data.Default (def)
12import Data.List
13import Data.List
13
14
14import System.Environment( getArgs )
15import System.Environment( getArgs )
@@ -18,7 +19,7 @@ import System.Random
18bench0 = do
19bench0 = do
19 let fixedGen = mkStdGen 0
20 let fixedGen = mkStdGen 0
20 setStdGen fixedGen
21 setStdGen fixedGen
21− vty <- mkVty defaultConfig
22+ vty <- mkVty def
22 (w,h) <- displayBounds $ outputIface vty
23 (w,h) <- displayBounds $ outputIface vty
23 let images = return $ (image0, image1)
24 let images = return $ (image0, image1)
24 image0 = charFill defAttr 'X' w h
25 image0 = charFill defAttr 'X' w h
test/BenchRenderChar.hs+4−2
@@ -9,8 +9,10 @@ import Verify
9
9
10import Control.Monad ( forM_ )
10import Control.Monad ( forM_ )
11
11
12+import Data.Default (def)
13+
12bench0 = do
14bench0 = do
13− vty <- mkVty defaultConfig
15+ vty <- mkVty def
14 (w,h) <- displayBounds $ outputIface vty
16 (w,h) <- displayBounds $ outputIface vty
15 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
17 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
16 bench d = do
18 bench d = do
@@ -26,7 +28,7 @@ testImageUsingChar c w h
26 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
28 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
27
29
28bench1 = do
30bench1 = do
29− vty <- mkVty defaultConfig
31+ vty <- mkVty def
30 (w,h) <- displayBounds $ outputIface vty
32 (w,h) <- displayBounds $ outputIface vty
31 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
33 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
32 bench d = do
34 bench d = do
test/BenchVerticalScroll.hs+2−1
@@ -6,6 +6,7 @@ import Verify
6import Control.Concurrent( threadDelay )
6import Control.Concurrent( threadDelay )
7import Control.Monad( liftM2 )
7import Control.Monad( liftM2 )
8
8
9+import Data.Default (def)
9import Data.List
10import Data.List
10import Data.Word
11import Data.Word
11
12
@@ -16,7 +17,7 @@ import System.Random
16bench0 = do
17bench0 = do
17 let fixedGen = mkStdGen 0
18 let fixedGen = mkStdGen 0
18 setStdGen fixedGen
19 setStdGen fixedGen
19− return $ Bench (return ()) (\() -> mkVty defaultConfig >>= liftM2 (>>) run shutdown)
20+ return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)
20
21
21run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)
22run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)
22
23
test/EventEcho.hs+2−1
@@ -6,6 +6,7 @@ import Control.Applicative
6import Control.Arrow
6import Control.Arrow
7import Control.Monad.RWS
7import Control.Monad.RWS
8
8
9+import Data.Default (def)
9import Data.Sequence (Seq, (<|) )
10import Data.Sequence (Seq, (<|) )
10import qualified Data.Sequence as Seq
11import qualified Data.Sequence as Seq
11import Data.Foldable
12import Data.Foldable
@@ -15,7 +16,7 @@ eventBufferSize = 1000
15type App = RWST Vty () (Seq String) IO
16type App = RWST Vty () (Seq String) IO
16
17
17main = do
18main = do
18− vty <- mkVty defaultConfig
19+ vty <- mkVty def
19 _ <- execRWST (vtyInteract False) vty Seq.empty
20 _ <- execRWST (vtyInteract False) vty Seq.empty
20 shutdown vty
21 shutdown vty
21
22
test/MinimalExample.hs+3−1
@@ -2,8 +2,10 @@ module Main where
2
2
3import Graphics.Vty
3import Graphics.Vty
4
4
5+import Data.Default
6+
5main = do
7main = do
6− vty <- mkVty defaultConfig
8+ vty <- mkVty def
7 let line0 = string (def `withForeColor` green) "first line"
9 let line0 = string (def `withForeColor` green) "first line"
8 line1 = string (def `withBackColor` blue) "second line"
10 line1 = string (def `withBackColor` blue) "second line"
9 img = line0 <-> line1
11 img = line0 <-> line1
test/Rogue.hs+3−1
@@ -1,8 +1,10 @@
1+{-# LANGUAGE TemplateHaskell #-}
1module Main where
2module Main where
2
3
3import Graphics.Vty
4import Graphics.Vty
4
5
5import Data.Array
6import Data.Array
7+import Data.Default (def)
6
8
7import Control.Applicative
9import Control.Applicative
8import Control.Monad
10import Control.Monad
@@ -41,7 +43,7 @@ type Coord = (Int, Int)
41
43
42main :: IO ()
44main :: IO ()
43main = do
45main = do
44− vty <- mkVty defaultConfig
46+ vty <- mkVty def
45 level0 <- mkLevel 1
47 level0 <- mkLevel 1
46 let world0 = World (Player (levelStart level0)) level0
48 let world0 = World (Player (levelStart level0)) level0
47 (_finalWorld, ()) <- execRWST play vty world0
49 (_finalWorld, ()) <- execRWST play vty world0
test/Verify.hs+11
@@ -1,6 +1,7 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE CPP #-}
4{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE StandaloneDeriving #-}
@@ -85,5 +86,15 @@ instance Arbitrary DoubleColumnChar where
85liftIOResult :: Testable prop => IO prop -> Property
86liftIOResult :: Testable prop => IO prop -> Property
86liftIOResult = ioProperty
87liftIOResult = ioProperty
87
88
89+#if __GLASGOW_HASKELL__ <= 701
90+instance Random Word where
91+ random g =
92+ let (i :: Int, g') = random g
93+ in (toEnum i, g')
94+ randomR (l,h) g =
95+ let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g
96+ in (toEnum i, g')
97+#endif
98+
88data Bench where
99data Bench where
89 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
100 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
test/Verify/Graphics/Vty/Output.hs+1
@@ -4,6 +4,7 @@ import Control.Applicative ((<$>))
4
4
5import Graphics.Vty.Output.Mock
5import Graphics.Vty.Output.Mock
6
6
7+import qualified Data.ByteString as BS
7import Data.IORef
8import Data.IORef
8import qualified Data.String.UTF8 as UTF8
9import qualified Data.String.UTF8 as UTF8
9
10
test/Verify/Graphics/Vty/Prelude.hs+3
@@ -1,9 +1,12 @@
1module Verify.Graphics.Vty.Prelude
1module Verify.Graphics.Vty.Prelude
2 ( module Verify.Graphics.Vty.Prelude
2 ( module Verify.Graphics.Vty.Prelude
3+ , module Graphics.Vty.Prelude
3 , MockWindow(..)
4 , MockWindow(..)
4 )
5 )
5where
6where
6
7
8+import Graphics.Vty.Prelude
9+
7import Graphics.Vty.Debug
10import Graphics.Vty.Debug
8
11
9import Verify
12import Verify
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 -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)
23+ = let v = map (\s -> (spanOpsEffectedColumns 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.hsnew file+9
@@ -0,0 +1,9 @@
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.hsdeleted−269
@@ -1,269 +0,0 @@
1−module VerifyColor240 where
2−
3−import Data.Word(Word8)
4−import Verify
5−
6−import Graphics.Vty.Attributes.Color240(rgbColorToColor240)
7−
8−oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8
9−oldRgbColorToColor240 r g b
10− | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
11− | r == 8 && g == 8 && b == 8 = 216
12− | r == 18 && g == 18 && b == 18 = 217
13− | r == 28 && g == 28 && b == 28 = 218
14− | r == 38 && g == 38 && b == 38 = 219
15− | r == 48 && g == 48 && b == 48 = 220
16− | r == 58 && g == 58 && b == 58 = 221
17− | r == 68 && g == 68 && b == 68 = 222
18− | r == 78 && g == 78 && b == 78 = 223
19− | r == 88 && g == 88 && b == 88 = 224
20− | r == 98 && g == 98 && b == 98 = 225
21− | r == 108 && g == 108 && b == 108 = 226
22− | r == 118 && g == 118 && b == 118 = 227
23− | r == 128 && g == 128 && b == 128 = 228
24− | r == 138 && g == 138 && b == 138 = 229
25− | r == 148 && g == 148 && b == 148 = 230
26− | r == 158 && g == 158 && b == 158 = 231
27− | r == 168 && g == 168 && b == 168 = 232
28− | r == 178 && g == 178 && b == 178 = 233
29− | r == 188 && g == 188 && b == 188 = 234
30− | r == 198 && g == 198 && b == 198 = 235
31− | r == 208 && g == 208 && b == 208 = 236
32− | r == 218 && g == 218 && b == 218 = 237
33− | r == 228 && g == 228 && b == 228 = 238
34− | r == 238 && g == 238 && b == 238 = 239
35− | r <= 0 && g <= 0 && b <= 0 = 0
36− | r <= 0 && g <= 0 && b <= 95 = 1
37− | r <= 0 && g <= 0 && b <= 135 = 2
38− | r <= 0 && g <= 0 && b <= 175 = 3
39− | r <= 0 && g <= 0 && b <= 215 = 4
40− | r <= 0 && g <= 0 && b <= 255 = 5
41− | r <= 0 && g <= 95 && b <= 0 = 6
42− | r <= 0 && g <= 95 && b <= 95 = 7
43− | r <= 0 && g <= 95 && b <= 135 = 8
44− | r <= 0 && g <= 95 && b <= 175 = 9
45− | r <= 0 && g <= 95 && b <= 215 = 10
46− | r <= 0 && g <= 95 && b <= 255 = 11
47− | r <= 0 && g <= 135 && b <= 0 = 12
48− | r <= 0 && g <= 135 && b <= 95 = 13
49− | r <= 0 && g <= 135 && b <= 135 = 14
50− | r <= 0 && g <= 135 && b <= 175 = 15
51− | r <= 0 && g <= 135 && b <= 215 = 16
52− | r <= 0 && g <= 135 && b <= 255 = 17
53− | r <= 0 && g <= 175 && b <= 0 = 18
54− | r <= 0 && g <= 175 && b <= 95 = 19
55− | r <= 0 && g <= 175 && b <= 135 = 20
56− | r <= 0 && g <= 175 && b <= 175 = 21
57− | r <= 0 && g <= 175 && b <= 215 = 22
58− | r <= 0 && g <= 175 && b <= 255 = 23
59− | r <= 0 && g <= 215 && b <= 0 = 24
60− | r <= 0 && g <= 215 && b <= 95 = 25
61− | r <= 0 && g <= 215 && b <= 135 = 26
62− | r <= 0 && g <= 215 && b <= 175 = 27
63− | r <= 0 && g <= 215 && b <= 215 = 28
64− | r <= 0 && g <= 215 && b <= 255 = 29
65− | r <= 0 && g <= 255 && b <= 0 = 30
66− | r <= 0 && g <= 255 && b <= 95 = 31
67− | r <= 0 && g <= 255 && b <= 135 = 32
68− | r <= 0 && g <= 255 && b <= 175 = 33
69− | r <= 0 && g <= 255 && b <= 215 = 34
70− | r <= 0 && g <= 255 && b <= 255 = 35
71− | r <= 95 && g <= 0 && b <= 0 = 36
72− | r <= 95 && g <= 0 && b <= 95 = 37
73− | r <= 95 && g <= 0 && b <= 135 = 38
74− | r <= 95 && g <= 0 && b <= 175 = 39
75− | r <= 95 && g <= 0 && b <= 215 = 40
76− | r <= 95 && g <= 0 && b <= 255 = 41
77− | r <= 95 && g <= 95 && b <= 0 = 42
78− | r <= 95 && g <= 95 && b <= 95 = 43
79− | r <= 95 && g <= 95 && b <= 135 = 44
80− | r <= 95 && g <= 95 && b <= 175 = 45
81− | r <= 95 && g <= 95 && b <= 215 = 46
82− | r <= 95 && g <= 95 && b <= 255 = 47
83− | r <= 95 && g <= 135 && b <= 0 = 48
84− | r <= 95 && g <= 135 && b <= 95 = 49
85− | r <= 95 && g <= 135 && b <= 135 = 50
86− | r <= 95 && g <= 135 && b <= 175 = 51
87− | r <= 95 && g <= 135 && b <= 215 = 52
88− | r <= 95 && g <= 135 && b <= 255 = 53
89− | r <= 95 && g <= 175 && b <= 0 = 54
90− | r <= 95 && g <= 175 && b <= 95 = 55
91− | r <= 95 && g <= 175 && b <= 135 = 56
92− | r <= 95 && g <= 175 && b <= 175 = 57
93− | r <= 95 && g <= 175 && b <= 215 = 58
94− | r <= 95 && g <= 175 && b <= 255 = 59
95− | r <= 95 && g <= 215 && b <= 0 = 60
96− | r <= 95 && g <= 215 && b <= 95 = 61
97− | r <= 95 && g <= 215 && b <= 135 = 62
98− | r <= 95 && g <= 215 && b <= 175 = 63
99− | r <= 95 && g <= 215 && b <= 215 = 64
100− | r <= 95 && g <= 215 && b <= 255 = 65
101− | r <= 95 && g <= 255 && b <= 0 = 66
102− | r <= 95 && g <= 255 && b <= 95 = 67
103− | r <= 95 && g <= 255 && b <= 135 = 68
104− | r <= 95 && g <= 255 && b <= 175 = 69
105− | r <= 95 && g <= 255 && b <= 215 = 70
106− | r <= 95 && g <= 255 && b <= 255 = 71
107− | r <= 135 && g <= 0 && b <= 0 = 72
108− | r <= 135 && g <= 0 && b <= 95 = 73
109− | r <= 135 && g <= 0 && b <= 135 = 74
110− | r <= 135 && g <= 0 && b <= 175 = 75
111− | r <= 135 && g <= 0 && b <= 215 = 76
112− | r <= 135 && g <= 0 && b <= 255 = 77
113− | r <= 135 && g <= 95 && b <= 0 = 78
114− | r <= 135 && g <= 95 && b <= 95 = 79
115− | r <= 135 && g <= 95 && b <= 135 = 80
116− | r <= 135 && g <= 95 && b <= 175 = 81
117− | r <= 135 && g <= 95 && b <= 215 = 82
118− | r <= 135 && g <= 95 && b <= 255 = 83
119− | r <= 135 && g <= 135 && b <= 0 = 84
120− | r <= 135 && g <= 135 && b <= 95 = 85
121− | r <= 135 && g <= 135 && b <= 135 = 86
122− | r <= 135 && g <= 135 && b <= 175 = 87
123− | r <= 135 && g <= 135 && b <= 215 = 88
124− | r <= 135 && g <= 135 && b <= 255 = 89
125− | r <= 135 && g <= 175 && b <= 0 = 90
126− | r <= 135 && g <= 175 && b <= 95 = 91
127− | r <= 135 && g <= 175 && b <= 135 = 92
128− | r <= 135 && g <= 175 && b <= 175 = 93
129− | r <= 135 && g <= 175 && b <= 215 = 94
130− | r <= 135 && g <= 175 && b <= 255 = 95
131− | r <= 135 && g <= 215 && b <= 0 = 96
132− | r <= 135 && g <= 215 && b <= 95 = 97
133− | r <= 135 && g <= 215 && b <= 135 = 98
134− | r <= 135 && g <= 215 && b <= 175 = 99
135− | r <= 135 && g <= 215 && b <= 215 = 100
136− | r <= 135 && g <= 215 && b <= 255 = 101
137− | r <= 135 && g <= 255 && b <= 0 = 102
138− | r <= 135 && g <= 255 && b <= 95 = 103
139− | r <= 135 && g <= 255 && b <= 135 = 104
140− | r <= 135 && g <= 255 && b <= 175 = 105
141− | r <= 135 && g <= 255 && b <= 215 = 106
142− | r <= 135 && g <= 255 && b <= 255 = 107
143− | r <= 175 && g <= 0 && b <= 0 = 108
144− | r <= 175 && g <= 0 && b <= 95 = 109
145− | r <= 175 && g <= 0 && b <= 135 = 110
146− | r <= 175 && g <= 0 && b <= 175 = 111
147− | r <= 175 && g <= 0 && b <= 215 = 112
148− | r <= 175 && g <= 0 && b <= 255 = 113
149− | r <= 175 && g <= 95 && b <= 0 = 114
150− | r <= 175 && g <= 95 && b <= 95 = 115
151− | r <= 175 && g <= 95 && b <= 135 = 116
152− | r <= 175 && g <= 95 && b <= 175 = 117
153− | r <= 175 && g <= 95 && b <= 215 = 118
154− | r <= 175 && g <= 95 && b <= 255 = 119
155− | r <= 175 && g <= 135 && b <= 0 = 120
156− | r <= 175 && g <= 135 && b <= 95 = 121
157− | r <= 175 && g <= 135 && b <= 135 = 122
158− | r <= 175 && g <= 135 && b <= 175 = 123
159− | r <= 175 && g <= 135 && b <= 215 = 124
160− | r <= 175 && g <= 135 && b <= 255 = 125
161− | r <= 175 && g <= 175 && b <= 0 = 126
162− | r <= 175 && g <= 175 && b <= 95 = 127
163− | r <= 175 && g <= 175 && b <= 135 = 128
164− | r <= 175 && g <= 175 && b <= 175 = 129
165− | r <= 175 && g <= 175 && b <= 215 = 130
166− | r <= 175 && g <= 175 && b <= 255 = 131
167− | r <= 175 && g <= 215 && b <= 0 = 132
168− | r <= 175 && g <= 215 && b <= 95 = 133
169− | r <= 175 && g <= 215 && b <= 135 = 134
170− | r <= 175 && g <= 215 && b <= 175 = 135
171− | r <= 175 && g <= 215 && b <= 215 = 136
172− | r <= 175 && g <= 215 && b <= 255 = 137
173− | r <= 175 && g <= 255 && b <= 0 = 138
174− | r <= 175 && g <= 255 && b <= 95 = 139
175− | r <= 175 && g <= 255 && b <= 135 = 140
176− | r <= 175 && g <= 255 && b <= 175 = 141
177− | r <= 175 && g <= 255 && b <= 215 = 142
178− | r <= 175 && g <= 255 && b <= 255 = 143
179− | r <= 215 && g <= 0 && b <= 0 = 144
180− | r <= 215 && g <= 0 && b <= 95 = 145
181− | r <= 215 && g <= 0 && b <= 135 = 146
182− | r <= 215 && g <= 0 && b <= 175 = 147
183− | r <= 215 && g <= 0 && b <= 215 = 148
184− | r <= 215 && g <= 0 && b <= 255 = 149
185− | r <= 215 && g <= 95 && b <= 0 = 150
186− | r <= 215 && g <= 95 && b <= 95 = 151
187− | r <= 215 && g <= 95 && b <= 135 = 152
188− | r <= 215 && g <= 95 && b <= 175 = 153
189− | r <= 215 && g <= 95 && b <= 215 = 154
190− | r <= 215 && g <= 95 && b <= 255 = 155
191− | r <= 215 && g <= 135 && b <= 0 = 156
192− | r <= 215 && g <= 135 && b <= 95 = 157
193− | r <= 215 && g <= 135 && b <= 135 = 158
194− | r <= 215 && g <= 135 && b <= 175 = 159
195− | r <= 215 && g <= 135 && b <= 215 = 160
196− | r <= 215 && g <= 135 && b <= 255 = 161
197− | r <= 215 && g <= 175 && b <= 0 = 162
198− | r <= 215 && g <= 175 && b <= 95 = 163
199− | r <= 215 && g <= 175 && b <= 135 = 164
200− | r <= 215 && g <= 175 && b <= 175 = 165
201− | r <= 215 && g <= 175 && b <= 215 = 166
202− | r <= 215 && g <= 175 && b <= 255 = 167
203− | r <= 215 && g <= 215 && b <= 0 = 168
204− | r <= 215 && g <= 215 && b <= 95 = 169
205− | r <= 215 && g <= 215 && b <= 135 = 170
206− | r <= 215 && g <= 215 && b <= 175 = 171
207− | r <= 215 && g <= 215 && b <= 215 = 172
208− | r <= 215 && g <= 215 && b <= 255 = 173
209− | r <= 215 && g <= 255 && b <= 0 = 174
210− | r <= 215 && g <= 255 && b <= 95 = 175
211− | r <= 215 && g <= 255 && b <= 135 = 176
212− | r <= 215 && g <= 255 && b <= 175 = 177
213− | r <= 215 && g <= 255 && b <= 215 = 178
214− | r <= 215 && g <= 255 && b <= 255 = 179
215− | r <= 255 && g <= 0 && b <= 0 = 180
216− | r <= 255 && g <= 0 && b <= 95 = 181
217− | r <= 255 && g <= 0 && b <= 135 = 182
218− | r <= 255 && g <= 0 && b <= 175 = 183
219− | r <= 255 && g <= 0 && b <= 215 = 184
220− | r <= 255 && g <= 0 && b <= 255 = 185
221− | r <= 255 && g <= 95 && b <= 0 = 186
222− | r <= 255 && g <= 95 && b <= 95 = 187
223− | r <= 255 && g <= 95 && b <= 135 = 188
224− | r <= 255 && g <= 95 && b <= 175 = 189
225− | r <= 255 && g <= 95 && b <= 215 = 190
226− | r <= 255 && g <= 95 && b <= 255 = 191
227− | r <= 255 && g <= 135 && b <= 0 = 192
228− | r <= 255 && g <= 135 && b <= 95 = 193
229− | r <= 255 && g <= 135 && b <= 135 = 194
230− | r <= 255 && g <= 135 && b <= 175 = 195
231− | r <= 255 && g <= 135 && b <= 215 = 196
232− | r <= 255 && g <= 135 && b <= 255 = 197
233− | r <= 255 && g <= 175 && b <= 0 = 198
234− | r <= 255 && g <= 175 && b <= 95 = 199
235− | r <= 255 && g <= 175 && b <= 135 = 200
236− | r <= 255 && g <= 175 && b <= 175 = 201
237− | r <= 255 && g <= 175 && b <= 215 = 202
238− | r <= 255 && g <= 175 && b <= 255 = 203
239− | r <= 255 && g <= 215 && b <= 0 = 204
240− | r <= 255 && g <= 215 && b <= 95 = 205
241− | r <= 255 && g <= 215 && b <= 135 = 206
242− | r <= 255 && g <= 215 && b <= 175 = 207
243− | r <= 255 && g <= 215 && b <= 215 = 208
244− | r <= 255 && g <= 215 && b <= 255 = 209
245− | r <= 255 && g <= 255 && b <= 0 = 210
246− | r <= 255 && g <= 255 && b <= 95 = 211
247− | r <= 255 && g <= 255 && b <= 135 = 212
248− | r <= 255 && g <= 255 && b <= 175 = 213
249− | r <= 255 && g <= 255 && b <= 215 = 214
250− | r <= 255 && g <= 255 && b <= 255 = 215
251− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
252− (fromIntegral r :: Int)
253− (fromIntegral g :: Int)
254− (fromIntegral b :: Int))
255−
256−sameColor :: Int -> Int -> Int -> Bool
257−sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b
258−
259−genVal :: Gen Int
260−genVal = chooseInt (0, 255)
261−
262−sameColorCheck :: Property
263−sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g)))
264−
265−tests :: IO [Test]
266−tests = return
267− [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck
268− ]
269−
test/VerifyConfig.hs+3−1
@@ -4,6 +4,7 @@ module Main where
4import Graphics.Vty.Config
4import Graphics.Vty.Config
5import Graphics.Vty.Input.Events
5import Graphics.Vty.Input.Events
6
6
7+import Data.Default
7import Data.String.QQ
8import Data.String.QQ
8import qualified Data.ByteString.Char8 as B
9import qualified Data.ByteString.Char8 as B
9
10
@@ -23,7 +24,7 @@ debugLog "/tmp/vty-debug.txt"
23|]
24|]
24
25
25exampleConfigConfig :: Config
26exampleConfigConfig :: Config
26−exampleConfigConfig = defaultConfig
27+exampleConfigConfig = def
27 { debugLog = Just "/tmp/vty-debug.txt"
28 { debugLog = Just "/tmp/vty-debug.txt"
28 , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])
29 , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])
29 , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])
30 , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])
@@ -42,3 +43,4 @@ main :: IO ()
42main = defaultMain
43main = defaultMain
43 [ testCase "example config parses" $ exampleConfigParses
44 [ testCase "example config parses" $ exampleConfigParses
44 ]
45 ]
46+
test/VerifyEmptyImageProps.hs+1−2
@@ -1,10 +1,9 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyEmptyImageProps where
1module VerifyEmptyImageProps where
3
2
4import Verify
3import Verify
5
4
6-- should be exported by Graphics.Vty.Picture
5-- should be exported by Graphics.Vty.Picture
7−import Graphics.Vty.Image ( Image, emptyImage )
6+import Graphics.Vty.Picture ( Image, emptyImage )
8
7
9tests :: IO [Test]
8tests :: IO [Test]
10tests = do
9tests = do
test/VerifyEvalTerminfoCaps.hs−1
@@ -1,6 +1,5 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4module VerifyEvalTerminfoCaps where
3module VerifyEvalTerminfoCaps where
5
4
6import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
5import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
test/VerifyImageOps.hs+1−2
@@ -1,4 +1,3 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyImageOps where
1module VerifyImageOps where
3
2
4import Graphics.Vty.Attributes
3import Graphics.Vty.Attributes
@@ -137,7 +136,7 @@ cropBottomLimitsHeight :: Image -> Int -> Property
137cropBottomLimitsHeight i v = v >= 0 ==>
136cropBottomLimitsHeight i v = v >= 0 ==>
138 v >= imageHeight (cropBottom v i)
137 v >= imageHeight (cropBottom v i)
139
138
140−-- ridiculous tests just to satisfy my desire for nice code coverage :-P
139+-- rediculous tests just to satisfy my desire for nice code coverage :-P
141canShowImage :: Image -> Bool
140canShowImage :: Image -> Bool
142canShowImage i = length (show i) > 0
141canShowImage i = length (show i) > 0
143
142
test/VerifyLayersSpanGeneration.hs−1
@@ -4,7 +4,6 @@ module VerifyLayersSpanGeneration where
4
4
5import Verify.Graphics.Vty.Prelude
5import Verify.Graphics.Vty.Prelude
6
6
7−import Verify.Graphics.Vty.Attributes
8import Verify.Graphics.Vty.Image
7import Verify.Graphics.Vty.Image
9import Verify.Graphics.Vty.Picture
8import Verify.Graphics.Vty.Picture
10import Verify.Graphics.Vty.Span
9import Verify.Graphics.Vty.Span
test/VerifyOutput.hs+5−7
@@ -1,7 +1,6 @@
1−-- We setup the environment to invoke certain terminals of interest.
1+-- We setup the environment to envoke 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 #-}
5module VerifyOutput where
4module VerifyOutput where
6
5
7import Verify
6import Verify
@@ -13,7 +12,10 @@ import Verify.Graphics.Vty.Output
13
12
14import Control.Monad
13import Control.Monad
15
14
15+import Data.Default
16+
16import qualified System.Console.Terminfo as Terminfo
17import qualified System.Console.Terminfo as Terminfo
18+import System.Posix.Env
17import System.Posix.IO
19import System.Posix.IO
18
20
19tests :: IO [Test]
21tests :: IO [Test]
@@ -35,11 +37,7 @@ smokeTestTermNonMac termName i = liftIOResult $ do
35smokeTestTerm :: String -> Image -> IO Result
37smokeTestTerm :: String -> Image -> IO Result
36smokeTestTerm termName i = do
38smokeTestTerm termName i = do
37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
39 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
38− t <- outputForConfig $ defaultConfig
39− { outputFd = Just nullOut
40− , termName = Just termName
40+ t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName }
41− , colorMode = Just NoColor
42− }
43 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
41 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
44 reserveDisplay t
42 reserveDisplay t
45 dc <- displayContext t (100,100)
43 dc <- displayContext t (100,100)
test/VerifyParseTerminfoCaps.hs−1
@@ -1,5 +1,4 @@
1{-# LANGUAGE NamedFieldPuns #-}
1{-# LANGUAGE NamedFieldPuns #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3module VerifyParseTerminfoCaps where
2module VerifyParseTerminfoCaps where
4
3
5import Prelude hiding ( catch )
4import 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 ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
28+ in ( spanOpsEffectedRows 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 ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
40+ in ( spanOpsEffectedRows 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 spanOpsAffectedRows ops == 1
54+ in spanOpsEffectedRows 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 = spanOpsAffectedRows ops
77+ actualRowCount = spanOpsEffectedRows 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 = spanOpsAffectedRows ops
93+ actualRowCount = spanOpsEffectedRows 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 = spanOpsAffectedRows ops
110+ actualRowCount = spanOpsEffectedRows 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 ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w )
126+ in ( spanOpsEffectedRows 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 = spanOpsAffectedRows ops
132+ actualRowCount = spanOpsEffectedRows ops
133 in expectedRowCount == actualRowCount
133 in expectedRowCount == actualRowCount
134
134
135spanOpsActuallyFillColumns :: DefaultPic -> Bool
135spanOpsActuallyFillColumns :: DefaultPic -> Bool
test/VerifyUsingMockInput.hs+16−17
@@ -1,6 +1,5 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4-- Generate some input bytes and delays between blocks of input bytes.
3-- Generate some input bytes and delays between blocks of input bytes.
5-- Verify the events produced are as expected.
4-- Verify the events produced are as expected.
6module Main where
5module Main where
@@ -12,12 +11,14 @@ import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Loop
11import Graphics.Vty.Input.Loop
13import Graphics.Vty.Input.Terminfo
12import Graphics.Vty.Input.Terminfo
14
13
14+import Control.Applicative
15import Control.Concurrent
15import Control.Concurrent
16import Control.Concurrent.STM
16import Control.Concurrent.STM
17import Control.Exception
17import Control.Exception
18import Lens.Micro ((^.))
18import Lens.Micro ((^.))
19import Control.Monad
19import Control.Monad
20
20
21+import Data.Default
21import Data.IORef
22import Data.IORef
22import Data.List (intersperse, reverse, nubBy)
23import Data.List (intersperse, reverse, nubBy)
23
24
@@ -113,11 +114,11 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
113 (writeFd, readFd) <- openPseudoTerminal
114 (writeFd, readFd) <- openPseudoTerminal
114 (setTermAttr,_) <- attributeControl readFd
115 (setTermAttr,_) <- attributeControl readFd
115 setTermAttr
116 setTermAttr
116− let testConfig = defaultConfig { inputFd = Just readFd
117+ let testConfig = def { inputFd = Just readFd
117− , termName = Just "dummy"
118+ , termName = Just "dummy"
118− , vmin = Just 1
119+ , vmin = Just 1
119− , vtime = Just 100
120+ , vtime = Just 100
120− }
121+ }
121 input <- initInput testConfig table
122 input <- initInput testConfig table
122 eventsRef <- newIORef []
123 eventsRef <- newIORef []
123 let writeWaitClose = do
124 let writeWaitClose = do
@@ -132,9 +133,7 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
132 readLoop 0 = return ()
133 readLoop 0 = return ()
133 readLoop n = do
134 readLoop n = do
134 e <- atomically $ readTChan $ input^.eventChannel
135 e <- atomically $ readTChan $ input^.eventChannel
135− case e of
136− InputEvent ev -> modifyIORef eventsRef ((:) ev)
136+ modifyIORef eventsRef ((:) e)
137− ResumeAfterSignal -> return ()
138 readLoop (n - 1)
137 readLoop (n - 1)
139 genEventsUsingIoActions maxDuration writeWaitClose readEvents
138 genEventsUsingIoActions maxDuration writeWaitClose readEvents
140 outEvents <- reverse <$> readIORef eventsRef
139 outEvents <- reverse <$> readIORef eventsRef
@@ -167,8 +166,8 @@ verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
167
166
168verifyCapsSynInputToEvent :: Property IO
167verifyCapsSynInputToEvent :: Property IO
169verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
168verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
170− forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
169+ forEachOf terminalsOfInterest $ \termName -> monadic $ do
171− term <- setupTerm terminalName
170+ term <- setupTerm termName
172 let table = capsClassifyMap term keysFromCapsTable
171 let table = capsClassifyMap term keysFromCapsTable
173 inputSeq = gen table
172 inputSeq = gen table
174 events = map snd inputSeq
173 events = map snd inputSeq
@@ -187,9 +186,9 @@ verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
187
186
188verifyFullSynInputToEvent :: Property IO
187verifyFullSynInputToEvent :: Property IO
189verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
188verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
190− forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
189+ forEachOf terminalsOfInterest $ \termName -> monadic $ do
191− term <- setupTerm terminalName
190+ term <- setupTerm termName
192− let table = classifyMapForTerm terminalName term
191+ let table = classifyMapForTerm termName term
193 inputSeq = gen table
192 inputSeq = gen table
194 events = map snd inputSeq
193 events = map snd inputSeq
195 keydowns = map (Bytes . fst) inputSeq
194 keydowns = map (Bytes . fst) inputSeq
@@ -198,9 +197,9 @@ verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
198
197
199verifyFullSynInputToEvent_2x :: Property IO
198verifyFullSynInputToEvent_2x :: Property IO
200verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
199verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
201− forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
200+ forEachOf terminalsOfInterest $ \termName -> monadic $ do
202− term <- setupTerm terminalName
201+ term <- setupTerm termName
203− let table = classifyMapForTerm terminalName term
202+ let table = classifyMapForTerm termName term
204 inputSeq = gen table
203 inputSeq = gen table
205 events = concatMap ((\s -> [s,s]) . snd) inputSeq
204 events = concatMap ((\s -> [s,s]) . snd) inputSeq
206 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
205 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
test/VerifyUsingMockTerminal.hs−2
@@ -4,11 +4,9 @@ import Verify.Graphics.Vty.Prelude
4
4
5import Verify.Graphics.Vty.Picture
5import Verify.Graphics.Vty.Picture
6import Verify.Graphics.Vty.Image
6import Verify.Graphics.Vty.Image
7−import Verify.Graphics.Vty.Attributes
8import Verify.Graphics.Vty.Span
7import Verify.Graphics.Vty.Span
9import Verify.Graphics.Vty.Output
8import Verify.Graphics.Vty.Output
10import Graphics.Vty.Output
9import Graphics.Vty.Output
11−import Graphics.Vty.Output.Interface
12import Graphics.Vty.Output.Mock
10import Graphics.Vty.Output.Mock
13
11
14import Graphics.Vty.Debug
12import Graphics.Vty.Debug
test/VerifyUtf8Width.hs−1
@@ -5,7 +5,6 @@ import Verify
5import Graphics.Text.Width
5import Graphics.Text.Width
6import Graphics.Vty.Attributes
6import Graphics.Vty.Attributes
7import Graphics.Vty.Picture
7import Graphics.Vty.Picture
8−import Graphics.Vty.Image
9
8
10swIs1Column :: SingleColumnChar -> Bool
9swIs1Column :: SingleColumnChar -> Bool
11swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1
10swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1
test/interactive_terminal_test.hs+3−2
@@ -12,6 +12,7 @@ import Control.Concurrent (threadDelay)
12import Control.Exception
12import Control.Exception
13import Control.Monad
13import Control.Monad
14
14
15+import Data.Default (def)
15import Data.List ( lookup )
16import Data.List ( lookup )
16import Data.Maybe ( isJust, fromJust )
17import Data.Maybe ( isJust, fromJust )
17import Data.Monoid
18import Data.Monoid
@@ -364,7 +365,7 @@ Did the test output match the description?
364|]
365|]
365 defaultSuccessConfirmResults
366 defaultSuccessConfirmResults
366
367
367−-- Explicitly define the bytes that encode each example text.
368+-- Explicitely definethe bytes that encode each example text.
368-- This avoids any issues with how the compiler represents string literals.
369-- This avoids any issues with how the compiler represents string literals.
369--
370--
370-- This document is UTF-8 encoded so the UTF-8 string is still included for
371-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -937,7 +938,7 @@ cursorHideTest0 = Test
937 { testName = "Verify the cursor is hid and re-shown. issue #7"
938 { testName = "Verify the cursor is hid and re-shown. issue #7"
938 , testID = "cursorHideTest0"
939 , testID = "cursorHideTest0"
939 , testAction = do
940 , testAction = do
940− vty <- mkVty defaultConfig
941+ vty <- mkVty def
941 showCursor $ outputIface vty
942 showCursor $ outputIface vty
942 setCursorPos (outputIface vty) 5 5
943 setCursorPos (outputIface vty) 5 5
943 nextEvent vty
944 nextEvent vty
test/vty-examples.cabal+5−5
@@ -1,5 +1,5 @@
1name: vty-examples
1name: vty-examples
2−version: 5.7
2+version: 5.6
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
@@ -41,7 +41,7 @@ executable vty-interactive-terminal-test
41 default-extensions: ScopedTypeVariables
41 default-extensions: ScopedTypeVariables
42 ghc-options: -threaded
42 ghc-options: -threaded
43
43
44− build-depends: vty >= 5.15,
44+ build-depends: vty >= 5.2.11,
45 base >= 4 && < 5,
45 base >= 4 && < 5,
46 bytestring,
46 bytestring,
47 containers,
47 containers,
@@ -69,7 +69,7 @@ executable vty-event-echo
69 FlexibleContexts
69 FlexibleContexts
70 ghc-options: -threaded
70 ghc-options: -threaded
71
71
72− build-depends: vty >= 5.15,
72+ build-depends: vty >= 5.2.11,
73 base >= 4 && < 5,
73 base >= 4 && < 5,
74 array,
74 array,
75 bytestring,
75 bytestring,
@@ -89,7 +89,7 @@ executable vty-rogue
89 default-extensions: ScopedTypeVariables
89 default-extensions: ScopedTypeVariables
90 ghc-options: -threaded
90 ghc-options: -threaded
91
91
92− build-depends: vty >= 5.15,
92+ build-depends: vty >= 5.2.11,
93 base >= 4 && < 5,
93 base >= 4 && < 5,
94 array,
94 array,
95 bytestring,
95 bytestring,
@@ -110,7 +110,7 @@ executable vty-benchmark
110 default-extensions: ScopedTypeVariables
110 default-extensions: ScopedTypeVariables
111 ghc-options: -threaded
111 ghc-options: -threaded
112
112
113− build-depends: vty >= 5.15,
113+ build-depends: vty >= 5.2.11,
114 base >= 4 && < 5,
114 base >= 4 && < 5,
115 bytestring,
115 bytestring,
116 Cabal,
116 Cabal,
tools/BuildWidthTable.hsdeleted−144
@@ -1,144 +0,0 @@
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+98−100
@@ -1,5 +1,5 @@
1name: vty
1name: vty
2−version: 5.35.1
2+version: 5.14
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
@@ -12,25 +12,26 @@ description:
12 be easy to use, have no confusing corner cases, and good support for
12 be easy to use, have no confusing corner cases, and good support for
13 common terminal types.
13 common terminal types.
14 .
14 .
15− See the @vty-examples@ package as well as the program
15+ Included in the source distribution is a program
16− @test/interactive_terminal_test.hs@ included in the @vty@ package for
16+ test/interactive_terminal_test.hs that demonstrates the various
17− examples on how to use the library.
17+ features.
18 .
18 .
19− Import the "Graphics.Vty" convenience module to get access to the core
19+ Developers: See the "Graphics.Vty" module.
20− parts of the library.
20+ .
21+ Users: See the "Graphics.Vty.Config" module.
21 .
22 .
22 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
23 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
23 .
24 .
24 &#169; Corey O'Connor; BSD3 license.
25 &#169; Corey O'Connor; BSD3 license.
25 .
26 .
26 &#169; Jonathan Daugherty; BSD3 license.
27 &#169; Jonathan Daugherty; BSD3 license.
27−cabal-version: 1.18
28+cabal-version: >= 1.18
28build-type: Simple
29build-type: Simple
29−extra-doc-files: README.md,
30+data-files: README.md,
30 AUTHORS,
31 AUTHORS,
31 CHANGELOG.md,
32 CHANGELOG.md,
32 LICENSE
33 LICENSE
33−tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5
34+tested-with: GHC >= 7.6.2
34
35
35source-repository head
36source-repository head
36 type: git
37 type: git
@@ -38,16 +39,18 @@ source-repository head
38
39
39library
40library
40 default-language: Haskell2010
41 default-language: Haskell2010
41− build-depends: base >= 4.8 && < 5,
42+ build-depends: base >= 4.6 && < 5,
42 blaze-builder >= 0.3.3.2 && < 0.5,
43 blaze-builder >= 0.3.3.2 && < 0.5,
43 bytestring,
44 bytestring,
44 containers,
45 containers,
46+ data-default >= 0.5.3,
45 deepseq >= 1.1 && < 1.5,
47 deepseq >= 1.1 && < 1.5,
46 directory,
48 directory,
47 filepath >= 1.0 && < 2.0,
49 filepath >= 1.0 && < 2.0,
48− microlens < 0.4.13,
50+ microlens,
49 microlens-mtl,
51 microlens-mtl,
50 microlens-th,
52 microlens-th,
53+ -- required for nice installation with yi
51 hashable >= 1.2,
54 hashable >= 1.2,
52 mtl >= 1.1.1.0 && < 2.3,
55 mtl >= 1.1.1.0 && < 2.3,
53 parallel >= 2.2 && < 3.3,
56 parallel >= 2.2 && < 3.3,
@@ -58,18 +61,10 @@ library
58 text >= 0.11.3,
61 text >= 0.11.3,
59 unix,
62 unix,
60 utf8-string >= 0.3 && < 1.1,
63 utf8-string >= 0.3 && < 1.1,
61− vector >= 0.7,
64+ 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
68
65
69 exposed-modules: Graphics.Vty
66 exposed-modules: Graphics.Vty
70 Graphics.Vty.Attributes
67 Graphics.Vty.Attributes
71− Graphics.Vty.Attributes.Color
72− Graphics.Vty.Attributes.Color240
73 Graphics.Vty.Config
68 Graphics.Vty.Config
74 Graphics.Vty.Error
69 Graphics.Vty.Error
75 Graphics.Vty.Image
70 Graphics.Vty.Image
@@ -78,8 +73,10 @@ library
78 Graphics.Vty.Input
73 Graphics.Vty.Input
79 Graphics.Vty.Input.Events
74 Graphics.Vty.Input.Events
80 Graphics.Vty.Picture
75 Graphics.Vty.Picture
76+ Graphics.Vty.Prelude
81 Graphics.Vty.Output
77 Graphics.Vty.Output
82 Graphics.Text.Width
78 Graphics.Text.Width
79+ -- the modules below are only meant to be used by the tests.
83 Codec.Binary.UTF8.Debug
80 Codec.Binary.UTF8.Debug
84 Data.Terminfo.Parse
81 Data.Terminfo.Parse
85 Data.Terminfo.Eval
82 Data.Terminfo.Eval
@@ -91,7 +88,6 @@ library
91 Graphics.Vty.Input.Classify.Parse
88 Graphics.Vty.Input.Classify.Parse
92 Graphics.Vty.Input.Loop
89 Graphics.Vty.Input.Loop
93 Graphics.Vty.Input.Mouse
90 Graphics.Vty.Input.Mouse
94− Graphics.Vty.Input.Focus
95 Graphics.Vty.Input.Paste
91 Graphics.Vty.Input.Paste
96 Graphics.Vty.Input.Terminfo
92 Graphics.Vty.Input.Terminfo
97 Graphics.Vty.PictureToSpans
93 Graphics.Vty.PictureToSpans
@@ -100,52 +96,41 @@ library
100 Graphics.Vty.Output.Interface
96 Graphics.Vty.Output.Interface
101 Graphics.Vty.Output.XTermColor
97 Graphics.Vty.Output.XTermColor
102 Graphics.Vty.Output.TerminfoBased
98 Graphics.Vty.Output.TerminfoBased
103− Graphics.Vty.UnicodeWidthTable.Types
104− Graphics.Vty.UnicodeWidthTable.IO
105− Graphics.Vty.UnicodeWidthTable.Query
106− Graphics.Vty.UnicodeWidthTable.Install
107
99
108− other-modules: Graphics.Vty.Debug.Image
100+ other-modules: Graphics.Vty.Attributes.Color
101+ Graphics.Vty.Attributes.Color240
102+ Graphics.Vty.Debug.Image
109 Graphics.Vty.Input.Terminfo.ANSIVT
103 Graphics.Vty.Input.Terminfo.ANSIVT
110
104
111 c-sources: cbits/gwinsz.c
105 c-sources: cbits/gwinsz.c
112 cbits/set_term_timing.c
106 cbits/set_term_timing.c
113− cbits/get_tty_erase.c
114 cbits/mk_wcwidth.c
107 cbits/mk_wcwidth.c
115
108
116 include-dirs: cbits
109 include-dirs: cbits
117
110
118 hs-source-dirs: src
111 hs-source-dirs: src
119
112
113+ default-extensions: ScopedTypeVariables
114+ ForeignFunctionInterface
115+
120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
116 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
121
117
122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
118 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
123
119
124−executable vty-build-width-table
125− main-is: BuildWidthTable.hs
126− hs-source-dirs: tools
127−
128− default-language: Haskell2010
129− ghc-options: -threaded -Wall
120+ cc-options: -O2
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
138
121
139executable vty-mode-demo
122executable vty-mode-demo
140 main-is: ModeDemo.hs
123 main-is: ModeDemo.hs
141 hs-source-dirs: demos
124 hs-source-dirs: demos
142
125
143 default-language: Haskell2010
126 default-language: Haskell2010
127+ default-extensions: ScopedTypeVariables
144 ghc-options: -threaded
128 ghc-options: -threaded
145
129
146 build-depends: vty,
130 build-depends: vty,
147− base >= 4.8 && < 5,
131+ base >= 4.6 && < 5,
148 containers,
132 containers,
133+ data-default >= 0.5.3,
149 microlens,
134 microlens,
150 microlens-mtl,
135 microlens-mtl,
151 mtl >= 1.1.1.0 && < 2.3
136 mtl >= 1.1.1.0 && < 2.3
@@ -155,17 +140,40 @@ executable vty-demo
155 hs-source-dirs: demos
140 hs-source-dirs: demos
156
141
157 default-language: Haskell2010
142 default-language: Haskell2010
143+ default-extensions: ScopedTypeVariables
158 ghc-options: -threaded
144 ghc-options: -threaded
159
145
160 build-depends: vty,
146 build-depends: vty,
161− base >= 4.8 && < 5,
147+ base >= 4.6 && < 5,
162 containers,
148 containers,
149+ data-default >= 0.5.3,
163 microlens,
150 microlens,
164 microlens-mtl,
151 microlens-mtl,
165 mtl >= 1.1.1.0 && < 2.3
152 mtl >= 1.1.1.0 && < 2.3
166
153
154+test-suite verify-attribute-ops
155+ default-language: Haskell2010
156+ default-extensions: ScopedTypeVariables
157+ type: detailed-0.9
158+ hs-source-dirs: test
159+ test-module: VerifyAttributeOps
160+ build-depends: vty,
161+ Cabal >= 1.20,
162+ QuickCheck >= 2.7,
163+ random >= 1.0 && < 1.2,
164+ base >= 4.6 && < 5,
165+ bytestring,
166+ containers,
167+ deepseq >= 1.1 && < 1.5,
168+ mtl >= 1.1.1.0 && < 2.3,
169+ text >= 0.11.3,
170+ unix,
171+ utf8-string >= 0.3 && < 1.1,
172+ vector >= 0.7
173+
167test-suite verify-using-mock-terminal
174test-suite verify-using-mock-terminal
168 default-language: Haskell2010
175 default-language: Haskell2010
176+ default-extensions: ScopedTypeVariables
169
177
170 type: detailed-0.9
178 type: detailed-0.9
171
179
@@ -184,8 +192,8 @@ test-suite verify-using-mock-terminal
184 build-depends: vty,
192 build-depends: vty,
185 Cabal >= 1.20,
193 Cabal >= 1.20,
186 QuickCheck >= 2.7,
194 QuickCheck >= 2.7,
187− random >= 1.0 && < 1.3,
195+ random >= 1.0 && < 1.2,
188− base >= 4.8 && < 5,
196+ base >= 4.6 && < 5,
189 bytestring,
197 bytestring,
190 containers,
198 containers,
191 deepseq >= 1.1 && < 1.5,
199 deepseq >= 1.1 && < 1.5,
@@ -198,6 +206,7 @@ test-suite verify-using-mock-terminal
198
206
199test-suite verify-terminal
207test-suite verify-terminal
200 default-language: Haskell2010
208 default-language: Haskell2010
209+ default-extensions: ScopedTypeVariables
201
210
202 type: detailed-0.9
211 type: detailed-0.9
203
212
@@ -216,10 +225,11 @@ test-suite verify-terminal
216 build-depends: vty,
225 build-depends: vty,
217 Cabal >= 1.20,
226 Cabal >= 1.20,
218 QuickCheck >= 2.7,
227 QuickCheck >= 2.7,
219− random >= 1.0 && < 1.3,
228+ random >= 1.0 && < 1.2,
220− base >= 4.8 && < 5,
229+ base >= 4.6 && < 5,
221 bytestring,
230 bytestring,
222 containers,
231 containers,
232+ data-default >= 0.5.3,
223 deepseq >= 1.1 && < 1.5,
233 deepseq >= 1.1 && < 1.5,
224 mtl >= 1.1.1.0 && < 2.3,
234 mtl >= 1.1.1.0 && < 2.3,
225 terminfo >= 0.3 && < 0.5,
235 terminfo >= 0.3 && < 0.5,
@@ -230,6 +240,7 @@ test-suite verify-terminal
230
240
231test-suite verify-display-attributes
241test-suite verify-display-attributes
232 default-language: Haskell2010
242 default-language: Haskell2010
243+ default-extensions: ScopedTypeVariables
233
244
234 type: detailed-0.9
245 type: detailed-0.9
235
246
@@ -248,8 +259,8 @@ test-suite verify-display-attributes
248 build-depends: vty,
259 build-depends: vty,
249 Cabal >= 1.20,
260 Cabal >= 1.20,
250 QuickCheck >= 2.7,
261 QuickCheck >= 2.7,
251− random >= 1.0 && < 1.3,
262+ random >= 1.0 && < 1.2,
252− base >= 4.8 && < 5,
263+ base >= 4.6 && < 5,
253 bytestring,
264 bytestring,
254 containers,
265 containers,
255 deepseq >= 1.1 && < 1.5,
266 deepseq >= 1.1 && < 1.5,
@@ -261,6 +272,7 @@ test-suite verify-display-attributes
261
272
262test-suite verify-empty-image-props
273test-suite verify-empty-image-props
263 default-language: Haskell2010
274 default-language: Haskell2010
275+ default-extensions: ScopedTypeVariables
264
276
265 type: detailed-0.9
277 type: detailed-0.9
266
278
@@ -273,8 +285,8 @@ test-suite verify-empty-image-props
273 build-depends: vty,
285 build-depends: vty,
274 Cabal >= 1.20,
286 Cabal >= 1.20,
275 QuickCheck >= 2.7,
287 QuickCheck >= 2.7,
276− random >= 1.0 && < 1.3,
288+ random >= 1.0 && < 1.2,
277− base >= 4.8 && < 5,
289+ base >= 4.6 && < 5,
278 bytestring,
290 bytestring,
279 containers,
291 containers,
280 deepseq >= 1.1 && < 1.5,
292 deepseq >= 1.1 && < 1.5,
@@ -286,6 +298,7 @@ test-suite verify-empty-image-props
286
298
287test-suite verify-eval-terminfo-caps
299test-suite verify-eval-terminfo-caps
288 default-language: Haskell2010
300 default-language: Haskell2010
301+ default-extensions: ScopedTypeVariables
289
302
290 type: detailed-0.9
303 type: detailed-0.9
291
304
@@ -299,8 +312,8 @@ test-suite verify-eval-terminfo-caps
299 build-depends: vty,
312 build-depends: vty,
300 Cabal >= 1.20,
313 Cabal >= 1.20,
301 QuickCheck >= 2.7,
314 QuickCheck >= 2.7,
302− random >= 1.0 && < 1.3,
315+ random >= 1.0 && < 1.2,
303− base >= 4.8 && < 5,
316+ base >= 4.6 && < 5,
304 blaze-builder >= 0.3.3.2 && < 0.5,
317 blaze-builder >= 0.3.3.2 && < 0.5,
305 bytestring,
318 bytestring,
306 containers,
319 containers,
@@ -314,6 +327,7 @@ test-suite verify-eval-terminfo-caps
314
327
315test-suite verify-image-ops
328test-suite verify-image-ops
316 default-language: Haskell2010
329 default-language: Haskell2010
330+ default-extensions: ScopedTypeVariables
317
331
318 type: detailed-0.9
332 type: detailed-0.9
319
333
@@ -328,8 +342,8 @@ test-suite verify-image-ops
328 build-depends: vty,
342 build-depends: vty,
329 Cabal >= 1.20,
343 Cabal >= 1.20,
330 QuickCheck >= 2.7,
344 QuickCheck >= 2.7,
331− random >= 1.0 && < 1.3,
345+ random >= 1.0 && < 1.2,
332− base >= 4.8 && < 5,
346+ base >= 4.6 && < 5,
333 bytestring,
347 bytestring,
334 containers,
348 containers,
335 deepseq >= 1.1 && < 1.5,
349 deepseq >= 1.1 && < 1.5,
@@ -341,6 +355,7 @@ test-suite verify-image-ops
341
355
342test-suite verify-image-trans
356test-suite verify-image-trans
343 default-language: Haskell2010
357 default-language: Haskell2010
358+ default-extensions: ScopedTypeVariables
344
359
345 type: detailed-0.9
360 type: detailed-0.9
346
361
@@ -355,8 +370,8 @@ test-suite verify-image-trans
355 build-depends: vty,
370 build-depends: vty,
356 Cabal >= 1.20,
371 Cabal >= 1.20,
357 QuickCheck >= 2.7,
372 QuickCheck >= 2.7,
358− random >= 1.0 && < 1.3,
373+ random >= 1.0 && < 1.2,
359− base >= 4.8 && < 5,
374+ base >= 4.6 && < 5,
360 bytestring,
375 bytestring,
361 containers,
376 containers,
362 deepseq >= 1.1 && < 1.5,
377 deepseq >= 1.1 && < 1.5,
@@ -368,6 +383,7 @@ test-suite verify-image-trans
368
383
369test-suite verify-inline
384test-suite verify-inline
370 default-language: Haskell2010
385 default-language: Haskell2010
386+ default-extensions: ScopedTypeVariables
371
387
372 type: detailed-0.9
388 type: detailed-0.9
373
389
@@ -381,8 +397,8 @@ test-suite verify-inline
381 build-depends: vty,
397 build-depends: vty,
382 Cabal >= 1.20,
398 Cabal >= 1.20,
383 QuickCheck >= 2.7,
399 QuickCheck >= 2.7,
384− random >= 1.0 && < 1.3,
400+ random >= 1.0 && < 1.2,
385− base >= 4.8 && < 5,
401+ base >= 4.6 && < 5,
386 bytestring,
402 bytestring,
387 containers,
403 containers,
388 deepseq >= 1.1 && < 1.5,
404 deepseq >= 1.1 && < 1.5,
@@ -394,6 +410,7 @@ test-suite verify-inline
394
410
395test-suite verify-parse-terminfo-caps
411test-suite verify-parse-terminfo-caps
396 default-language: Haskell2010
412 default-language: Haskell2010
413+ default-extensions: ScopedTypeVariables
397
414
398 type: detailed-0.9
415 type: detailed-0.9
399
416
@@ -408,8 +425,8 @@ test-suite verify-parse-terminfo-caps
408 build-depends: vty,
425 build-depends: vty,
409 Cabal >= 1.20,
426 Cabal >= 1.20,
410 QuickCheck >= 2.7,
427 QuickCheck >= 2.7,
411− random >= 1.0 && < 1.3,
428+ random >= 1.0 && < 1.2,
412− base >= 4.8 && < 5,
429+ base >= 4.6 && < 5,
413 bytestring,
430 bytestring,
414 containers,
431 containers,
415 deepseq >= 1.1 && < 1.5,
432 deepseq >= 1.1 && < 1.5,
@@ -422,6 +439,7 @@ test-suite verify-parse-terminfo-caps
422
439
423test-suite verify-simple-span-generation
440test-suite verify-simple-span-generation
424 default-language: Haskell2010
441 default-language: Haskell2010
442+ default-extensions: ScopedTypeVariables
425
443
426 type: detailed-0.9
444 type: detailed-0.9
427
445
@@ -439,8 +457,8 @@ test-suite verify-simple-span-generation
439 build-depends: vty,
457 build-depends: vty,
440 Cabal >= 1.20,
458 Cabal >= 1.20,
441 QuickCheck >= 2.7,
459 QuickCheck >= 2.7,
442− random >= 1.0 && < 1.3,
460+ random >= 1.0 && < 1.2,
443− base >= 4.8 && < 5,
461+ base >= 4.6 && < 5,
444 bytestring,
462 bytestring,
445 containers,
463 containers,
446 deepseq >= 1.1 && < 1.5,
464 deepseq >= 1.1 && < 1.5,
@@ -453,6 +471,7 @@ test-suite verify-simple-span-generation
453
471
454test-suite verify-crop-span-generation
472test-suite verify-crop-span-generation
455 default-language: Haskell2010
473 default-language: Haskell2010
474+ default-extensions: ScopedTypeVariables
456
475
457 type: detailed-0.9
476 type: detailed-0.9
458
477
@@ -470,8 +489,8 @@ test-suite verify-crop-span-generation
470 build-depends: vty,
489 build-depends: vty,
471 Cabal >= 1.20,
490 Cabal >= 1.20,
472 QuickCheck >= 2.7,
491 QuickCheck >= 2.7,
473− random >= 1.0 && < 1.3,
492+ random >= 1.0 && < 1.2,
474− base >= 4.8 && < 5,
493+ base >= 4.6 && < 5,
475 bytestring,
494 bytestring,
476 containers,
495 containers,
477 deepseq >= 1.1 && < 1.5,
496 deepseq >= 1.1 && < 1.5,
@@ -484,6 +503,7 @@ test-suite verify-crop-span-generation
484
503
485test-suite verify-layers-span-generation
504test-suite verify-layers-span-generation
486 default-language: Haskell2010
505 default-language: Haskell2010
506+ default-extensions: ScopedTypeVariables
487
507
488 type: detailed-0.9
508 type: detailed-0.9
489
509
@@ -501,33 +521,8 @@ test-suite verify-layers-span-generation
501 build-depends: vty,
521 build-depends: vty,
502 Cabal >= 1.20,
522 Cabal >= 1.20,
503 QuickCheck >= 2.7,
523 QuickCheck >= 2.7,
504− random >= 1.0 && < 1.3,
524+ random >= 1.0 && < 1.2,
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,
530− base >= 4.8 && < 5,
525+ base >= 4.6 && < 5,
531 bytestring,
526 bytestring,
532 containers,
527 containers,
533 deepseq >= 1.1 && < 1.5,
528 deepseq >= 1.1 && < 1.5,
@@ -539,6 +534,7 @@ test-suite verify-color-mapping
539
534
540test-suite verify-utf8-width
535test-suite verify-utf8-width
541 default-language: Haskell2010
536 default-language: Haskell2010
537+ default-extensions: ScopedTypeVariables
542
538
543 type: detailed-0.9
539 type: detailed-0.9
544
540
@@ -551,8 +547,8 @@ test-suite verify-utf8-width
551 build-depends: vty,
547 build-depends: vty,
552 Cabal >= 1.20,
548 Cabal >= 1.20,
553 QuickCheck >= 2.7,
549 QuickCheck >= 2.7,
554− random >= 1.0 && < 1.3,
550+ random >= 1.0 && < 1.2,
555− base >= 4.8 && < 5,
551+ base >= 4.6 && < 5,
556 bytestring,
552 bytestring,
557 containers,
553 containers,
558 deepseq >= 1.1 && < 1.5,
554 deepseq >= 1.1 && < 1.5,
@@ -564,6 +560,7 @@ test-suite verify-utf8-width
564
560
565test-suite verify-using-mock-input
561test-suite verify-using-mock-input
566 default-language: Haskell2010
562 default-language: Haskell2010
563+ default-extensions: ScopedTypeVariables
567
564
568 type: exitcode-stdio-1.0
565 type: exitcode-stdio-1.0
569
566
@@ -571,17 +568,16 @@ test-suite verify-using-mock-input
571
568
572 main-is: VerifyUsingMockInput.hs
569 main-is: VerifyUsingMockInput.hs
573
570
574− other-modules: Verify.Graphics.Vty.Output
575−
576 build-depends: vty,
571 build-depends: vty,
577 Cabal >= 1.20,
572 Cabal >= 1.20,
573+ data-default >= 0.5.3,
578 QuickCheck >= 2.7,
574 QuickCheck >= 2.7,
579 smallcheck == 1.*,
575 smallcheck == 1.*,
580 quickcheck-assertions >= 0.1.1,
576 quickcheck-assertions >= 0.1.1,
581 test-framework == 0.8.*,
577 test-framework == 0.8.*,
582 test-framework-smallcheck == 0.2.*,
578 test-framework-smallcheck == 0.2.*,
583− random >= 1.0 && < 1.3,
579+ random >= 1.0 && < 1.2,
584− base >= 4.8 && < 5,
580+ base >= 4.6 && < 5,
585 bytestring,
581 bytestring,
586 containers,
582 containers,
587 deepseq >= 1.1 && < 1.5,
583 deepseq >= 1.1 && < 1.5,
@@ -599,6 +595,7 @@ test-suite verify-using-mock-input
599
595
600test-suite verify-config
596test-suite verify-config
601 default-language: Haskell2010
597 default-language: Haskell2010
598+ default-extensions: ScopedTypeVariables
602
599
603 type: exitcode-stdio-1.0
600 type: exitcode-stdio-1.0
604
601
@@ -608,6 +605,7 @@ test-suite verify-config
608
605
609 build-depends: vty,
606 build-depends: vty,
610 Cabal >= 1.20,
607 Cabal >= 1.20,
608+ data-default >= 0.5.3,
611 HUnit,
609 HUnit,
612 QuickCheck >= 2.7,
610 QuickCheck >= 2.7,
613 smallcheck == 1.*,
611 smallcheck == 1.*,
@@ -615,8 +613,8 @@ test-suite verify-config
615 test-framework == 0.8.*,
613 test-framework == 0.8.*,
616 test-framework-smallcheck == 0.2.*,
614 test-framework-smallcheck == 0.2.*,
617 test-framework-hunit,
615 test-framework-hunit,
618− random >= 1.0 && < 1.3,
616+ random >= 1.0 && < 1.2,
619− base >= 4.8 && < 5,
617+ base >= 4.6 && < 5,
620 bytestring,
618 bytestring,
621 containers,
619 containers,
622 deepseq >= 1.1 && < 1.5,
620 deepseq >= 1.1 && < 1.5,