git.iko.soy/vty
on 452ed52 help sign in
4a29aec
swap
0 ahead, 299 behind
.travis.yml+17−100
since splitsnapshots
unifiedsplit
@@ -1,109 +1,26 @@
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.22 GHCVER=7.10.1
46− - HCPKG=${HC/ghc/ghc-pkg}
12+ - CABALVER=1.24 GHCVER=8.0.1
47− - unset CC
13+ - CABALVER=1.24 GHCVER=8.0.2
48− - ROOTDIR=$(pwd)
14+ - CABALVER=head GHCVER=head
49− - mkdir -p $HOME/.local/bin
50− - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
51− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
52− - echo $HCNUMVER
53
15
54install:
16install:
55− - cabal --version
17+ - ./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
18
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:
19script:
84− # test that source-distributions can be generated
20+ - ./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
21
97− # build & run tests, build benchmarks
22+before_install:
98− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
23+ - 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
24+ - sudo apt-get update
100−
25+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
101− # haddock
26+ - 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+363−762
@@ -1,861 +1,462 @@
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−
3175.17.1
15.17.1
318−------
319−
320−* withStyle now ignores zero arguments, leaving attribute styles
2+ - withStyle now ignores zero arguments, leaving attribute styles
321− untouched if the input style is the null style
3+ untouched if the input style is the null style
322
4
3235.17
55.17
324−----
325−
326API changes:
6API changes:
327−* Add support for terminal focus events. This change adds a new mode
7+ - Add support for terminal focus events. This change adds a new mode
328− usable with setMode, Focus, that requests that the terminal send
8+ usable with setMode, Focus, that requests that the terminal send
329− events on focus lose/gain. This change also adds two new Event
9+ events on focus lose/gain. This change also adds two new Event
330− constructors, EvLostFocus and EvGainedFocus.
10+ constructors, EvLostFocus and EvGainedFocus.
331−* No longer enable UTF8 mouse event encoding. This encoding was not
11+ - No longer enable UTF8 mouse event encoding. This encoding was not
332− working properly with Terminal.app, and using the other modes (SGR,
12+ working properly with Terminal.app, and using the other modes (SGR,
333− etc.) work.
13+ etc.) work.
334−* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
14+ - Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
335− #131)
15+ #131)
336
16
3375.16
175.16
338−----
339−
340API changes:
18API changes:
341−* Added support for mouse wheel events while in mouse mode. The Button
19+ - Added support for mouse wheel events while in mouse mode. The Button
342− type got two new constructors as a result: BScrollUp and BScrollDown.
20+ type got two new constructors as a result: BScrollUp and BScrollDown.
343− Thanks to doublescale@tutanota.com for this contribution!
21+ Thanks to doublescale@tutanota.com for this contribution!
344
22
345Bug fixes:
23Bug fixes:
346−* charFill now clamps negative arguments to zero (thanks Eric Mertens!)
24+ - charFill now clamps negative arguments to zero (thanks Eric
25+ Mertens!)
347
26
3485.15.1
275.15.1
349−------
350−
351Package changes:
28Package changes:
352−* Documentation files are now marked accordingly (thanks Michal
29+ - Documentation files are now marked accordingly (thanks Michal
353− Suchánek)
30+ Suchánek)
354
31
355Bug fixes:
32Bug fixes:
356−* translateX/Y: fix negative translations
33+ - translateX/Y: fix negative translations
357
34
3585.15
355.15
359−----
360−
361Package changes:
36Package changes:
362−* Discontinued support for GHC versions prior to 7.10.1.
37+ - Discontinued support for GHC versions prior to 7.10.1.
363−* Removed instructions and configuration for Stack builds since they
38+ - Removed instructions and configuration for Stack builds since they
364− are no longer supported.
39+ are no longer supported.
365−* Clarified README mention of (lack of) Windows support (contributors
40+ - Clarified README mention of (lack of) Windows support (contributors
366− wanted, though!)
41+ wanted, though!)
367−* Removed dependency on data-default (see below).
42+ - Removed dependency on data-default (see below).
368
43
369API changes:
44API changes:
370−* Moved color definitions from Attributes to Color module.
45+ - Moved color definitions from Attributes to Color module.
371−* In lieu of data-default (Default) instances for Attr and Config, use
46+ - In lieu of data-default (Default) instances for Attr and Config, use
372− 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
47+ 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
373−* Graphics.Vty.Output no longer re-exports
48+ - Graphics.Vty.Output no longer re-exports
374− Graphics.Vty.Output.Interface.
49+ Graphics.Vty.Output.Interface.
375−* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
50+ - Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
376− accessors to Graphics.Vty.Image.
51+ accessors to Graphics.Vty.Image.
377−* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
52+ - Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
378−* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
53+ - Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
379
54
3805.14
555.14
381−----
382−
383−* addMaybeClippedJoin: instead of raising an exception when the join
56+ - addMaybeClippedJoin: instead of raising an exception when the join
384− is totally clipped, just reduce the clip amount and continue
57+ is totally clipped, just reduce the clip amount and continue
385−* addMaybeClipped: skip blit of joins when their primary dimension is
58+ - addMaybeClipped: skip blit of joins when their primary dimension is
386− zero
59+ zero
387−* 'string' and related text functions no longer treat an empty string
60+ - '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
61+ 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.
62+ possible to use 'str ""' as a non-empty image with height 1.
390
63
3915.13
645.13
392−----
393−
394−* Reverted changes in 5.12 due to disagreements between terminal
65+ - Reverted changes in 5.12 due to disagreements between terminal
395− emulators and utf8proc; for more details, please see the ticket
66+ emulators and utf8proc; for more details, please see the ticket
396− discussion at
67+ discussion at
397− https://github.com/coreyoconnor/vty/issues/115
68+ https://github.com/coreyoconnor/vty/issues/115
398
69
3995.12
705.12
400−----
401−
402−* Replaced 'wcwidth' with a call to the utf8proc library's character
71+ - Replaced 'wcwidth' with a call to the utf8proc library's character
403− width function, which is much more up to date (by several Unicode
72+ 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
73+ versions) and returns the right width for a much larger set of
405− characters.
74+ characters.
406−* Added a bundled version of the utf8proc C library.
75+ - Added a bundled version of the utf8proc C library.
407
76
4085.11.3
775.11.3
409−------
410−
411−* Fix mouse event offsets in mouse-up events
78+ - Fix mouse event offsets in mouse-up events
412
79
4135.11.2
805.11.2
414−------
415−
416−* Mouse events were modified so that the upper-left corner of the window
81+ - Mouse events were modified so that the upper-left corner of the
417− is (0,0) rather than (1,1).
82+ window is (0,0) rather than (1,1).
418
83
4195.11.1
845.11.1
420−------
421−
422−* Add Generic instance for Image
85+ - Add Generic instance for Image
423−* nextEvent: stop trying to refresh on a resize event (fixes segfault
86+ - nextEvent: stop trying to refresh on a resize event (fixes segfault
424− on refresh with normal cursor positioning mode)
87+ on refresh with normal cursor positioning mode)
425−* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
88+ - Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
426−* Update maintainer
89+ - Update maintainer
427
90
4285.11
915.11
429−----
430−
431−* Vty now raises a VtyConfigurationError exception when the TERM
92+ - Vty now raises a VtyConfigurationError exception when the TERM
432− evironment variable is missing (thanks Eric Mertens)
93+ evironment variable is missing (thanks Eric Mertens)
433−* Graphics.Vty.Config got an explicit export list to avoid accidentally
94+ - Graphics.Vty.Config got an explicit export list to avoid accidentally
434− exporting internal types (thanks Eric Mertens)
95+ exporting internal types (thanks Eric Mertens)
435
96
4365.10
975.10
437−----
438−
439−* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
98+ - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
440− mode provides greater control over cursor positioning by bypassing
99+ mode provides greater control over cursor positioning by bypassing
441− the logical positioning provided by default. Rather than positioning
100+ the logical positioning provided by default. Rather than positioning
442− the cursor by looking at the widths of characters involved, this
101+ the cursor by looking at the widths of characters involved, this
443− constructor lets you provide a physical row and column instead. This
102+ constructor lets you provide a physical row and column instead. This
444− is useful in more sophisticated programs. (thanks Eric Mertens)
103+ is useful in more sophisticated programs. (thanks Eric Mertens)
445−* Added a new Generic-derived config parser (thanks Eric Mertens)
104+ - Added a new Generic-derived config parser (thanks Eric Mertens)
446−* Fixed the MShift case in the configuration file parser (thanks Eric
105+ - Fixed the MShift case in the configuration file parser (thanks Eric
447− Mertens)
106+ Mertens)
448−* Fixed wcwidth import and matched safeWcswidth to its documented
107+ - Fixed wcwidth import and matched safeWcswidth to its documented
449− behavior. Previously vty_mk_wcwidth was being imported with the
108+ behavior. Previously vty_mk_wcwidth was being imported with
450− wrong type causing the -1 return value to be mapped to the wrong Int
109+ the wrong type causing the -1 return value to be mapped to the
451− value. Additionally safeWcswidth was using the unsafe character width
110+ wrong Int value. Additionally safeWcswidth was using the unsafe
452− function and only ensuring that the final result was non-negative.
111+ character width function and only ensuring that the final result was
453− (thanks Eric Mertens)
112+ non-negative. (thanks Eric Mertens)
454
113
4555.9.1
1145.9.1
456−-----
457−
458−* Vty now only emits UTF8 charset sequences in terminals without a
115+ - Vty now only emits UTF8 charset sequences in terminals without a
459− preexisting UTF8 declaration to avoid emitting garbage sequences
116+ preexisting UTF8 declaration to avoid emitting garbage sequences
460− (fixes #89)
117+ (fixes #89)
461
118
4625.9
1195.9
463−---
464−
465−* Added new Output methods supportsBell and ringTerminalBell to find out
120+ - Added new Output methods supportsBell and ringTerminalBell to find
466− whether the output device has an audio bell and to ring it (see #102)
121+ out whether the output device has an audio bell and to ring it (see
122+ #102)
467
123
4685.8.1
1245.8.1
469−-----
470−
471−* Fixed "refresh" to work as advertised (see #104)
125+ - Fixed "refresh" to work as advertised (see #104)
472
126
4735.8
1275.8
474−---
475−
476−* API change: EvPaste input event now provides paste data as a raw
128+ - 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
129+ ByteString rather than a String to allow the application to decode
478− best to decode it
130+ how best to decode it
479
131
4805.7.1
1325.7.1
481−-----
482−
483−* ModeDemo: added an explicit Control.Applicative import for older GHCs
133+ - ModeDemo: added an explicit Control.Applicative import for older
134+ GHCs
484
135
4855.7
1365.7
486−---
487−
488−* Mouse and paste modes are now off by default.
137+ - Mouse and paste modes are now off by default.
489−* The Config type got new fields: mouseMode and bracketedPasteMode.
138+ - The Config type got new fields: mouseMode and bracketedPasteMode.
490− These determine whether these modes are enabled initially (for
139+ These determine whether these modes are enabled initially (for
491− terminals that support them).
140+ terminals that support them).
492−* Added a Mode type for modal terminal features (mouse events,
141+ - Added a Mode type for modal terminal features (mouse events,
493− bracketed paste mode) that is used with new Output interface
142+ bracketed paste mode) that is used with new Output interface
494− functions:
143+ functions:
495− * supportsMode :: Mode -> Bool tells whether the device supports a
144+ * supportsMode :: Mode -> Bool tells whether the device supports a
496− mode
145+ mode
497− * setMode :: Mode -> Bool -> IO () turns a mode on or off
146+ * setMode :: Mode -> Bool -> IO () turns a mode on or off
498− * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
147+ * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
499− off
148+ off
500−* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
149+ - Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
501
150
5025.6
1515.6
503−---
504−
505−* Added support for normal and extended mouse modes in Xterm-like
152+ - Added support for normal and extended mouse modes in Xterm-like
506− terminals via the MouseDown and MouseUp Event constructors
153+ terminals via the MouseDown and MouseUp Event constructors
507−* Added support for bracketed paste mode in Xterm-like terminals via
154+ - Added support for bracketed paste mode in Xterm-like terminals via
508− the EvPaste event constructor
155+ the EvPaste event constructor
509−* Added derived Show instances for Event and Button (thanks Felix
156+ - Added derived Show instances for Event and Button (thanks Felix
510− Hirn)
157+ Hirn)
511−* Now TERM values containing "screen" will automatically use the
158+ - Now TERM values containing "screen" will automatically use the
512− XtermColor driver rather than just TerminfoBased
159+ XtermColor driver rather than just TerminfoBased
513
160
5145.5.0
1615.5.0
515−-----
516−
517−* Replaced lens dependency with microlens, microlens-mtl, microlens-th
162+ - Replaced lens dependency with microlens, microlens-mtl, microlens-th
518− dependencies. Issue #90
163+ dependencies. Issue #90
519− * Thanks Jonathan Daugherty
164+ - Thanks Jonathan Daugherty
520−* Cabal corrections.
165+ - Cabal corrections.
521− * Thanks Lennart Spitzner
166+ - Thanks Lennart Spitzner
522
167
5235.4.0
1685.4.0
524−-----
525−
526−* Changed eventChannel of Graphics.Vty.Input from Chan to
169+ - Changed eventChannel of Graphics.Vty.Input from Chan to TChan.
527− TChan. This enables clients to query if there are no pending
170+ This enables clients to query if there are no pending events. The
528− events. The Graphics.Vty interface nextEvent is unchanged.
171+ Graphics.Vty interface nextEvent is unchanged. Clients that use
529− Clients that use eventChannel directly will require updating.
172+ eventChannel directly will require updating.
530− https://github.com/coreyoconnor/vty/issues/60
173+ https://github.com/coreyoconnor/vty/issues/60
531−
5325.3.1
1745.3.1
533−-----
534−
535−* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to
175+ - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due
536− possibly breaking this on reasonable GHC versions
176+ to possibly breaking this on reasonable GHC versions
537
177
5385.3
1785.3
539−---
540−
541−* Upgraded QuickCheck dependency to 2.7
179+ - Upgraded QuickCheck dependency to 2.7
542−* The standard IO Config (standardIOConfig) was overriding any provided
180+ - The standard IO Config (standardIOConfig) was overriding any
543− application config. In addition, the inputFd and outputFd could not be
181+ provided application config. In addition, the inputFd and outputFd
544− changed if mkVty was used. Fixed.
182+ could not be changed if mkVty was used. Fixed.
545−* Correct handling of display attributes at end of line. The output
183+ - 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
184+ 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
185+ 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
186+ 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
187+ and was the cause of https://github.com/coreyoconnor/vty/issues/76
550− requires the old behavior to display the selection region correctly.
188+ IIRC Yi requires the old behavior to display the selection region
189+ correctly.
551−* shutdown of the input thread is now performed using killThread and
190+ - shutdown of the input thread is now performed using killThread and
552− synchronization on an MVar. For correct handling of the terminal read
191+ 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.
192+ 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
193+ thread. This places a threadWaitRead, which will be interrupted by
555− killThread, prior to the uninterruptable read. An alternative would be
194+ the killThread, prior to the uninterruptable read. An alternative
556− to re-import the read foreign call as interruptable.
195+ would be to re-import the read foreign call as interruptable.
557
196
5585.2.11
1975.2.11
559−------
560−
561−* deepseq bounds increased for tests.
198+ - deepseq bounds increased for tests.
562−* Clean up warnings when compiling on 7.10
199+ - Clean up warnings when compiling on 7.10
563− * Thanks Eric Mertens
200+ - Thanks Eric Mertens
564−* Avoid discarding input bytes after multi-byte encoded codepoint
201+ - Avoid discarding input bytes after multi-byte encoded codepoint
565− * Thanks Eric Mertens
202+ - Thanks Eric Mertens
566
203
5675.2.10
2045.2.10
568−------
569−
570−* "str" now returns EmptyImage for empty strings to match behavior of
205+ - "str" now returns EmptyImage for empty strings to match behavior of
571− other string-like Image constructors (fixes #74)
206+ other string-like Image constructors (fixes #74)
572− * Thanks Jonathan Daugherty
207+ - Thanks Jonathan Daugherty
573
208
5745.2.9
2095.2.9
575−-----
576−
577−* dependency version bumps
210+ - dependency version bumps
578− * https://github.com/coreyoconnor/vty/pull/71
211+ - https://github.com/coreyoconnor/vty/pull/71
579− * https://github.com/coreyoconnor/vty/pull/70
212+ - https://github.com/coreyoconnor/vty/pull/70
580−* Correct/Simplify the example code
213+ - Correct/Simplify the example code
581− * Thanks glguy
214+ - Thanks glguy
582− * https://github.com/coreyoconnor/vty/pull/69
215+ - https://github.com/coreyoconnor/vty/pull/69
583
216
5845.2.8
2175.2.8
585−-----
586−
587−* blaze-builder, lens, utf8-string version constraint bump
218+ - blaze-builder, lens, utf8-string version constraint bump
588− * Thanks glguy
219+ - Thanks glguy
589− * https://github.com/coreyoconnor/vty/pull/67
220+ - https://github.com/coreyoconnor/vty/pull/67
590−* Do not differentiate based on TERM_PROGRAM
221+ - Do not differentiate based on TERM_PROGRAM
591− * https://github.com/coreyoconnor/vty/issues/68
222+ - https://github.com/coreyoconnor/vty/issues/68
592
223
5935.2.7
2245.2.7
594−-----
595−
596−* lens and deepseq constraint bump + misc
225+ - lens and deepseq constraint bump + misc
597− * Thanks ethercrow
226+ - Thanks ethercrow
598− * https://github.com/coreyoconnor/vty/pull/66
227+ - https://github.com/coreyoconnor/vty/pull/66
599
228
6005.2.6
2295.2.6
601−-----
602−
603−* lens constraint bump
230+ - lens constraint bump
604− * Thanks alexander-b!
231+ - Thanks alexander-b!
605− * https://github.com/coreyoconnor/vty/pull/64
232+ - https://github.com/coreyoconnor/vty/pull/64
606
233
6075.2.5
2345.2.5
608−-----
609−
610−* lens and random version constraint bump.
235+ - lens and random version constraint bump.
611− * Thanks RyanGlScott!
236+ - Thanks RyanGlScott!
612− * https://github.com/coreyoconnor/vty/pull/62
237+ - https://github.com/coreyoconnor/vty/pull/62
613
238
6145.2.4
2395.2.4
615−-----
616−
617−* removed -fpic from cc-options. No longer required.
240+ - removed -fpic from cc-options. No longer required.
618− * https://github.com/coreyoconnor/vty/issues/61
241+ - https://github.com/coreyoconnor/vty/issues/61
619− * https://ghc.haskell.org/trac/ghc/ticket/9657
242+ - https://ghc.haskell.org/trac/ghc/ticket/9657
620− * Thanks Fuuzetsu!
243+ - Thanks Fuuzetsu!
621
244
6225.2.3
2455.2.3
623−-----
624−
625−* evaluate/compile the input parsing table once instead of each
246+ - evaluate/compile the input parsing table once instead of each
626− keystroke.
247+ keystroke.
627− * https://github.com/coreyoconnor/vty/pull/59
248+ - https://github.com/coreyoconnor/vty/pull/59
628− * Thanks ethercrow!
249+ - Thanks ethercrow!
629
250
6305.2.2
2515.2.2
631−-----
632−
633−* When looking at input for an event, don't look too deep.
252+ - When looking at input for an event, don't look too deep.
634− * https://github.com/coreyoconnor/vty/pull/57
253+ - https://github.com/coreyoconnor/vty/pull/57
635− * Thanks ethercrow!
254+ - Thanks ethercrow!
636
255
6375.2.1
2565.2.1
638−-----
639−
640−* Bump upper version bound for lens to 4.5. Thanks markus1189!
257+ - Bump upper version bound for lens to 4.5. Thanks markus1189!
641
258
6425.2.0
2595.2.0
643−-----
644−
645−* Config structure now specifies file descriptor to use. The default
260+ - Config structure now specifies file descriptor to use. The default
646− is stdInput and stdOutput file descriptors. Previously Vty used
261+ is stdInput and stdOutput file descriptors. Previously Vty used
647− stdInput for input and the follow code for output:
262+ stdInput for input and the follow code for output:
648− * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
263+ - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
649− NoBuffering)
264+ NoBuffering)
650− * the difference was required by Vty.Inline. Now, Vty.Inline uses
265+ - the difference was required by Vty.Inline. Now, Vty.Inline uses
651− the Config structure options to acheive the same effect.
266+ the Config structure options to acheive the same effect.
652−* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
267+ - removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
653− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
268+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
654−* added: inputForConfig, outputForConfig
269+ - added: inputForConfig, outputForConfig
655−* updates to vty-rogue from jtdaugherty. Thanks!
270+ - updates to vty-rogue from jtdaugherty. Thanks!
656−* the oldest version of GHC tested to support vty is 7.6.2.
271+ - 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
272+ - the oldest version of GHC that vty compiles under is 7.4.2
658
273
6595.1.4
2745.1.4
660−-----
661−
662−* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
275+ - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
663
276
6645.1.1
2775.1.1
665−-----
666−
667−* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
278+ - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
668−* jtdaugherty resolved a number of compiler warnings. Thanks!
279+ - jtdaugherty resolved a number of compiler warnings. Thanks!
669
280
6705.1.0
2815.1.0
671−-----
672−
673−* vmin and vtime can be specified however the application requires.
282+ - vmin and vtime can be specified however the application requires.
674− See Graphics.Vty.Config.
283+ See Graphics.Vty.Config.
675−* fixed the processing of input when vmin is set > 1.
284+ - fixed the processing of input when vmin is set > 1.
676
285
6775.0.0
2865.0.0
678−-----
679−
680−* The naming convention now matches:
287+ - The naming convention now matches:
681− * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
288+ - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
682−* all projects using vty for input must be compiled with -threaded.
289+ - all projects using vty for input must be compiled with -threaded.
683− Please notify vty author if this is not acceptable.
290+ Please notify vty author if this is not acceptable.
684−* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
291+ - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
685− vty with the default configuration.
292+ vty with the default configuration.
686−* input handling changes
293+ - input handling changes
687− * KASCII is now KChar
294+ - KASCII is now KChar
688− * KPN5 is now KCenter
295+ - KPN5 is now KCenter
689− * tests exist.
296+ - tests exist.
690− * Applications can add to the input tables by setting inputMap of
297+ - Applications can add to the input tables by setting inputMap of
691− the Config. See Graphics.Vty.Config
298+ the Config. See Graphics.Vty.Config
692− * Users can define input table extensions that will apply to all vty
299+ - Users can define input table extensions that will apply to all vty
693− applications. See Graphics.Vty.Config
300+ applications. See Graphics.Vty.Config
694− * terminal timing is now handled by selecting an appropriate VTIME.
301+ - terminal timing is now handled by selecting an appropriate VTIME.
695− Previously this was implemented within Vty itself. This reduced
302+ Previously this was implemented within Vty itself. This reduced
696− complexity in vty but provides a different meta key behavior and
303+ complexity in vty but provides a different meta key behavior and
697− implies a requirement on -threaded.
304+ implies a requirement on -threaded.
698− * The time vty will wait to verify an ESC byte means a single ESC
305+ - The time vty will wait to verify an ESC byte means a single ESC
699− key is the singleEscPeriod of the Input Config structure.
306+ key is the singleEscPeriod of the Input Config structure.
700−* removed the typeclass based terminal and display context interface
307+ - removed the typeclass based terminal and display context interface
701− in favor of a data structure of properties interface.
308+ in favor of a data structure of properties interface.
702−* renamed the Terminal interface to Output
309+ - renamed the Terminal interface to Output
703−* The default picture for an image now uses the "clear" background.
310+ - The default picture for an image now uses the "clear" background.
704− This background fills background spans with spaces or just ends the
311+ This background fills background spans with spaces or just ends the
705− line.
312+ line.
706− * Previously the background defaulted to the space character. This
313+ - Previously the background defaulted to the space character. This
707− causes issues copying text from a text editor. The text would end
314+ causes issues copying text from a text editor. The text would end
708− up with extra spaces at the end of the line.
315+ up with extra spaces at the end of the line.
709−* Layer support
316+ - Layer support
710− * Each layer is an image.
317+ - Each layer is an image.
711− * The layers for a picture are a list of images.
318+ - The layers for a picture are a list of images.
712− * The first image is the top-most layer. The images are ordered from
319+ - The first image is the top-most layer. The images are ordered from
713− top to bottom.
320+ top to bottom.
714− * The transparent areas for a layer are the backgroundFill areas.
321+ - The transparent areas for a layer are the backgroundFill areas.
715− backgroundFill is added to pad images when images of different
322+ backgroundFill is added to pad images when images of different
716− sizes are joined.
323+ sizes are joined.
717− * If the background is clear there is no background layer.
324+ - If the background is clear there is no background layer.
718− * If there is a background character then the bottom layer is the
325+ - If there is a background character then the bottom layer is the
719− background layer.
326+ background layer.
720− * emptyPicture is a Picture with no layers and no cursor
327+ - emptyPicture is a Picture with no layers and no cursor
721− * addToTop and addToBottom add a layer to the top and bottom of the
328+ - addToTop and addToBottom add a layer to the top and bottom of the
722− given Picture.
329+ given Picture.
723−* compatibility improvements:
330+ - compatibility improvements:
724− * terminfo based terminals with no cursor support are silently
331+ - terminfo based terminals with no cursor support are silently
725− accepted. The cursor visibility changes in the Picture will have
332+ accepted. The cursor visibility changes in the Picture will have
726− no effect.
333+ no effect.
727− * alternate (setf/setb) color maps supported. Though colors beyond
334+ - alternate (setf/setb) color maps supported. Though colors beyond
728− the first 8 are just a guess.
335+ the first 8 are just a guess.
729− * added "rgbColor" for easy support of RGB specified colors.
336+ - added "rgbColor" for easy support of RGB specified colors.
730− * Both applications and users can add to the mapping used to
337+ - Both applications and users can add to the mapping used to
731− translate from input bytes to events.
338+ translate from input bytes to events.
732−* Additional information about input and output process can be
339+ - Additional information about input and output process can be
733− appended to a debug log
340+ appended to a debug log
734− * Set environment variable VTY_DEBUG_LOG to path of debug log
341+ - Set environment variable VTY_DEBUG_LOG to path of debug log
735− * Or use "debugLog <path>" config directive
342+ - Or use "debugLog <path>" config directive
736− * Or set 'debugLog' property of the Config provided to mkVty.
343+ - Or set 'debugLog' property of the Config provided to mkVty.
737−* examples moved to vty-examples package. See test directory for cabal
344+ - examples moved to vty-examples package. See test directory for cabal
738− file.
345+ file.
739− * vty-interactive-terminal-test
346+ - vty-interactive-terminal-test
740− * interactive test. Useful for building a bug report for vty's
347+ - interactive test. Useful for building a bug report for vty's
741− author.
348+ author.
742− * test/interactive_terminal_test.hs
349+ - test/interactive_terminal_test.hs
743− * vty-event-echo
350+ - vty-event-echo
744− * view a input event log for vty. Example of interacting with
351+ - view a input event log for vty. Example of interacting with
745− user.
352+ user.
746− * test/EventEcho.hs
353+ - test/EventEcho.hs
747− * vty-rogue
354+ - vty-rogue
748− * The start of a rogue-like game. Example of layers and image
355+ - The start of a rogue-like game. Example of layers and image
749− build operations.
356+ build operations.
750− * test/Rogue.hs
357+ - test/Rogue.hs
751− * vty-benchmark
358+ - vty-benchmark
752− * benchmarks vty. A series of tests that push random pictures to
359+ - benchmarks vty. A series of tests that push random pictures to
753− the terminal. The random pictures are generated using
360+ the terminal. The random pictures are generated using
754− QuickCheck. The same generators used in the automated tests.
361+ QuickCheck. The same generators used in the automated tests.
755− * test/benchmark.hs
362+ - test/benchmark.hs
756
363
7574.7.0.0
3644.7.0.0
758−-------
365+ - API changes:
366+ - Added Graphics.Vty.Image.crop: Ensure an image is no larger
367+ than the specified size.
368+ - Added Graphics.Vty.Image.pad: Ensure an image is no smaller
369+ than the specified size.
370+ - Added Graphics.Vty.Image.translate: Offset an image.
371+ - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
759
372
760−API changes:
373+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
374
7684.2.1.0
3754.2.1.0
769−-------
770−
771−API changes:
376+ - API changes:
772−* Attr record accessor fore_color changed to attr_fore_color
377+ - Attr record accessor fore_color changed to attr_fore_color
773−* Attr record accessor back_color changed to attr_back_color
378+ - Attr record accessor back_color changed to attr_back_color
774−* Attr record accessor style changed to attr_style
379+ - Attr record accessor style changed to attr_style
775−* Added an "inline" display attribute changing DSL:
380+ - Added an "inline" display attribute changing DSL:
776− * put_attr_change applies a display attribute change
381+ - put_attr_change applies a display attribute change
777− immediately to a terminal
382+ immediately to a terminal
778− * For instance, can be used to change the display attrbiutes
383+ - For instance, can be used to change the display attrbiutes
779− of text output via putStrLn and putStr. EX:
384+ of text output via putStrLn and putStr. EX:
780− "put_attr_change $ back_color red" will set the background
385+ "put_attr_change $ back_color red" will set the background
781− color to red.
386+ color to red.
782− * Changes do not apply to a Picture output via output_picture.
387+ - Changes do not apply to a Picture output via output_picture.
783− * See Graphics.Vty.Inline
388+ - See Graphics.Vty.Inline
784−* Moved all IO actions into any monad an instance of MonadIO
389+ - Moved all IO actions into any monad an instance of MonadIO
785
390
7864.0.0.1
3914.0.0.1
787−-------
788−
789−* binding for mk_wcswidth was incorrect. Most platforms just
392+ - binding for mk_wcswidth was incorrect. Most platforms just
790− magically worked due to coincidence.
393+ magically worked due to coincidence.
791
394
7924.0.0
3954.0.0
793−-----
794−
795−API changes:
396+ - API changes:
796−* "getSize" has been removed. Use "terminal vty >>= display_bounds"
397+ - "getSize" has been removed. Use "terminal vty >>= display_bounds"
797− where "vty" is an instance of the Vty data structure.
398+ where "vty" is an instance of the Vty data structure.
798−* added a "terminal" field to the Vty data structure. Accesses the
399+ - added a "terminal" field to the Vty data structure. Accesses the
799− TerminalHandle associated with the Vty instance.
400+ TerminalHandle associated with the Vty instance.
800−* Graphics.Vty.Types has undergone a number of changes. Summary:
401+ - Graphics.Vty.Types has undergone a number of changes. Summary:
801− * Partitioned into Graphics.Vty.Attributes for display attributes.
402+ - Partitioned into Graphics.Vty.Attributes for display attributes.
802− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
403+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
803− for final picture construction.
404+ for final picture construction.
804−* Graphics.Vty.Attributes:
405+ - Graphics.Vty.Attributes:
805− * "setFG" and "setBG" are now "with_fore_color" and
406+ - "setFG" and "setBG" are now "with_fore_color" and
806− "with_back_color"
407+ "with_back_color"
807− * All other "set.." equations similarly replaced.
408+ - All other "set.." equations similarly replaced.
808− * "attr" is now "def_attr", short for "default display attributes"
409+ - "attr" is now "def_attr", short for "default display attributes"
809− Also added a "current_attr" for "currently applied display
410+ Also added a "current_attr" for "currently applied display
810− attributes"
411+ attributes"
811−* Graphics.Vty.Image:
412+ - Graphics.Vty.Image:
812− * "horzcat" is now "horiz_cat"
413+ - "horzcat" is now "horiz_cat"
813− * "vertcat" is now "vert_cat"
414+ - "vertcat" is now "vert_cat"
814− * "renderBS" is now "utf8_bytestring"
415+ - "renderBS" is now "utf8_bytestring"
815− * "renderChar" is now "char"
416+ - "renderChar" is now "char"
816− * "renderFill" is now "char_fill"
417+ - "renderFill" is now "char_fill"
817− * added a "utf8_string" and "string" (AKA "iso_10464_string") for
418+ - added a "utf8_string" and "string" (AKA "iso_10464_string") for
818− UTF-8 encoded Strings and ISO-10464 encoded Strings. String
419+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String
819− literals in GHC have an ISO-10464 runtime representation.
420+ literals in GHC have an ISO-10464 runtime representation.
820−* Graphics.Vty.Picture:
421+ - Graphics.Vty.Picture:
821− * exports Graphics.Vty.Image
422+ - exports Graphics.Vty.Image
822− * "pic" is now "pic_for_image"
423+ - "pic" is now "pic_for_image"
823− * added API for setting background fill pattern.
424+ - added API for setting background fill pattern.
824−* Completely rewritten output backend.
425+ - Completely rewritten output backend.
825− * Efficient, scanline style output span generator. Has not been
426+ - Efficient, scanline style output span generator. Has not been
826− fully optimized, but good enough.
427+ fully optimized, but good enough.
827− * The details required to display the desired picture on a
428+ - The details required to display the desired picture on a
828− terminal are well encapsulated.
429+ terminal are well encapsulated.
829− * Terminfo based display terminal implementation. With specialized
430+ - Terminfo based display terminal implementation. With specialized
830− derivitives for xterm, Terminal.app, and iTerm.app.
431+ derivitives for xterm, Terminal.app, and iTerm.app.
831− * Attempts to robustly handle even terminals that don't
432+ - Attempts to robustly handle even terminals that don't
832− support all display attributes.
433+ support all display attributes.
833− * I've tested the following terminals with success: iTerm.app,
434+ - I've tested the following terminals with success: iTerm.app,
834− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
435+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
835− konsole, screen, linux vty. Hopefully you will be as
436+ konsole, screen, linux vty. Hopefully you will be as
836− successfull.
437+ successfull.
837− * Improved unicode support. Double wide characters will display as
438+ - Improved unicode support. Double wide characters will display as
838− expected.
439+ expected.
839−* 256 color support. See Graphics.Vty.Attributes.Color240. The actual
440+ - 256 color support. See Graphics.Vty.Attributes.Color240. The actual
840− output color is adjusted according to the number of colors the
441+ output color is adjusted according to the number of colors the
841− terminal supports.
442+ terminal supports.
842−* The Graphics.Vty.Image combinators no longer require matching
443+ - The Graphics.Vty.Image combinators no longer require matching
843− dimensions to arguments. Unspecified areas are filled in with a
444+ dimensions to arguments. Unspecified areas are filled in with a
844− user-customizable background pattern. See Graphics.Vty.Picture.
445+ user-customizable background pattern. See Graphics.Vty.Picture.
845−* output images are always cropped to display size.
446+ - output images are always cropped to display size.
846−* Significant code coverage by QuickCheck tests. An interactive test
447+ - Significant code coverage by QuickCheck tests. An interactive test
847− for those final properties that couldn't be automatically verified.
448+ for those final properties that couldn't be automatically verified.
848
449
849Issues resolved:
450Issues resolved:
850−* "gnome terminal displays non-basic attributes as strikethrough"
451+ - "gnome terminal displays non-basic attributes as strikethrough"
851− * http://trac.haskell.org/vty/ticket/14
452+ - http://trac.haskell.org/vty/ticket/14
852−* "Multi-byte characters are not displayed correctly on update"
453+ - "Multi-byte characters are not displayed correctly on update"
853− * http://trac.haskell.org/vty/ticket/10
454+ - http://trac.haskell.org/vty/ticket/10
854−* "Redraw does not handle rendering a line that extends beyond screen
455+ - "Redraw does not handle rendering a line that extends beyond screen
855− width characters"
456+ width characters"
856− * http://trac.haskell.org/vty/ticket/13
457+ - http://trac.haskell.org/vty/ticket/13
857−* "The <|> and <-> combinators should be more forgiving of mismatched
458+ - "The <|> and <-> combinators should be more forgiving of mismatched
858− dimensions"
459+ dimensions"
859− * http://trac.haskell.org/vty/ticket/9
460+ - http://trac.haskell.org/vty/ticket/9
860−* "256-color support"
461+ - "256-color support"
861− * http://trac.haskell.org/vty/ticket/19
462+ - 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+54−109
@@ -7,7 +7,7 @@ interface for doing terminal I/O. Vty is supported on GHC versions
7Install via `git` with:
7Install via `git` with:
8
8
9```
9```
10−git clone git://github.com/jtdaugherty/vty.git
10+git clone git://github.com/coreyoconnor/vty.git
11```
11```
12
12
13Install via `cabal` with:
13Install via `cabal` with:
@@ -18,21 +18,24 @@ cabal install vty
18
18
19# Features
19# Features
20
20
21−* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,
21+* Supports a large number of terminals. vt100, ansi, hurd, linux,
22− `screen`, etc., or anything with a sufficient terminfo entry.
22+ screen, etc., or anything with a sufficient terminfo entry.
23
23
24−* Automatically handles window resizes.
24+* Automatic handling of window resizes.
25
25
26−* Supports Unicode output on terminals with UTF-8 support.
26+* Unicode output on terminals with UTF-8 support.
27
27
28+* Handles multi-column glyphs. (Requires user to properly configure
29+ terminal.)
30+
28−* Provides an efficient output algorithm. Output buffering and terminal
31+* Efficient output. Output buffering and terminal state changes are
29− state changes are minimized.
32+ minimized.
30
33
31* Minimizes repaint area, which virtually eliminates the flicker
34* Minimizes repaint area, which virtually eliminates the flicker
32 problems that plague ncurses programs.
35 problems that plague ncurses programs.
33
36
34−* Provides a pure, compositional interface for efficiently constructing
37+* A pure, compositional interface for efficiently constructing display
35− display images.
38+ images.
36
39
37* Automatically decodes keyboard keys into (key,[modifier]) tuples.
40* Automatically decodes keyboard keys into (key,[modifier]) tuples.
38
41
@@ -41,7 +44,7 @@ cabal install vty
41* Supports a keypress timeout after for lone ESC. The timeout is
44* Supports a keypress timeout after for lone ESC. The timeout is
42 customizable.
45 customizable.
43
46
44−* Provides extensible input and output interfaces.
47+* The interface is designed for easy extension.
45
48
46* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
49* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
47 with a type-safe interface and graceful fallback for terminals
50 with a type-safe interface and graceful fallback for terminals
@@ -57,106 +60,16 @@ cabal install vty
57* Supports bracketed paste mode as described at
60* Supports bracketed paste mode as described at
58 http://cirw.in/blog/bracketed-paste
61 http://cirw.in/blog/bracketed-paste
59
62
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
63# Platform Support
72
64
73## Posix Terminals
65## Posix Terminals
74
66
75−For the most part, Vty uses `terminfo` to determine terminal protocol
67+Uses terminfo to determine terminal protocol. With some special rules to
76−with some special rules to handle some omissions from `terminfo`.
68+handle some omissions from terminfo.
77
69
78## Windows
70## Windows
79
71
80−Windows is not supported.
72+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−
125−```
126−widthMap "xterm" "/path/to/map.dat"
127−```
128−
129−where the first argument is the value that `TERM` must have in order for
130−the table to be loaded, and the second argument is the path to the table
131−file itself as generated by the two alternatives listed above. If the
132−Vty configuration file contains multiple matching `widthMap` directives
133−for the current value of `TERM`, the last one listed in the file is
134−used.
135−
136−The tables declared in the configuration file are only ever
137−automatically loaded when applications set up Vty by calling
138−`Graphics.Vty.mkVty`.
139−
140−Before a custom table has been loaded, calls to the library's character
141−width functions (e.g. `wcwidth`) will use the default built-in table.
142−Once a custom table has been loaded, the functions will use the new
143−custom table. Only one custom table load can be performed in a Vty
144−program. Once a custom table has been loaded, it cannot be replaced or
145−removed.
146−
147−Without using a custom width table, users of Vty-based applications
148−are likely to eventually experience rendering problems with with wide
149−characters. We recommend that developers of Vty-based applications either:
150−
151−* Provide the `vty-build-width-table` tool and documentation for running
152− it and updating the Vty configuration, or
153−* Have the application invoke the Vty library's table-building
154− functionality and load the table at startup without using the Vty
155− configuration.
156−
157−The best option will depend on a number of factors: the user audience,
158−the amount of risk posed by wide character rendering, the terminal
159−emulators in use, etc.
160
73
161# Contributing
74# Contributing
162
75
@@ -170,13 +83,45 @@ should consider to make submitting patches easier for all concerned:
170 conventions already used in the codebase.
83 conventions already used in the codebase.
171 - Please provide Haddock documentation for any changes you make.
84 - Please provide Haddock documentation for any changes you make.
172
85
86+# Development Notes
87+
88+## Under NixOS
89+
90+### Using cabal
91+
92+After installing `ncurses` to the user environment:
93+
94+~~~
95+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib
96+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build
97+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test
98+~~~
99+
100+## Code Coverage
101+
102+As of last testing, profiling causes issues with coverage when enabled.
103+To evaluate coverage, configure as follows:
104+
105+~~~
106+rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \
107+ --disable-library-profiling \
108+ --disable-executable-profiling
109+~~~
110+
111+## Profiling
112+
113+~~~
114+rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
115+ --enable-library-profiling \
116+ --enable-executable-profiling
117+~~~
118+
173# Known Issues
119# Known Issues
174
120
175−* Terminals have numerous quirks and bugs, so mileage may vary. Please
121+* Terminals have numerous quirks and bugs. Vty picks what works best for
176− report issues as you encounter them and provide details on your
122+ the author in ambiguous or buggy situations.
177− terminal emulator, operating system, etc.
178
123
179−* STOP, TERM and INT signals are not handled.
124+* Signal handling of STOP, TERM and INT are nonexistent.
180
125
181* The character encoding of the terminal is assumed to be UTF-8 if
126* The character encoding of the terminal is assumed to be UTF-8 if
182 unicode is used.
127 unicode is used.
@@ -186,10 +131,10 @@ should consider to make submitting patches easier for all concerned:
186 (shifted F10 etc). See `Config` for customizing vty's behavior for a
131 (shifted F10 etc). See `Config` for customizing vty's behavior for a
187 particular terminal.
132 particular terminal.
188
133
189−* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which
134+* Uses the `TIOCGWINSZ` ioctl to find the current window size, which
190 appears to be limited to Linux and BSD.
135 appears to be limited to Linux and BSD.
191
136
192−# Further Reading
137+# Sources
193
138
194Good sources of documentation for terminal programming are:
139Good sources of documentation for terminal programming are:
195
140
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+4−12
@@ -31,8 +31,7 @@ introText = vertCat $ map (string defAttr)
31 [ "this line is hidden by the top layer"
31 [ "this line is hidden by the top layer"
32 , "The vty demo program will echo the events generated by the pressed keys."
32 , "The vty demo program will echo the events generated by the pressed keys."
33 , "Below there is a 240 color box."
33 , "Below there is a 240 color box."
34− , "Followed by a description of the 16 color palette."
34+ , "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"
35 , "If the 240 color box is not visible then the terminal"
37 , "claims 240 colors are not supported."
36 , "claims 240 colors are not supported."
38 , "Try setting TERM to xterm-256color"
37 , "Try setting TERM to xterm-256color"
@@ -43,19 +42,12 @@ introText = vertCat $ map (string defAttr)
43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
42 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
44 ]
43 ]
45
44
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
45colorbox_240 :: Image
56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
46colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
57 where
47 where
58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
48 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
49+ splitColorImages [] = []
50+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
59
51
60colorbox_16 :: Image
52colorbox_16 :: Image
61colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
53colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
@@ -78,7 +70,7 @@ updateDisplay = do
78 "Press ESC to exit. Events for keys below."
70 "Press ESC to exit. Events for keys below."
79 eventLog <- foldMap (string defAttr) <$> get
71 eventLog <- foldMap (string defAttr) <$> get
80 let pic = picForImage (info <-> eventLog)
72 let pic = picForImage (info <-> eventLog)
81− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
73+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
82 vty <- ask
74 vty <- ask
83 liftIO $ update vty pic
75 liftIO $ update vty pic
84
76
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+3−3
@@ -42,7 +42,7 @@ pop = do
42
42
43readParam :: Word -> Eval CapParam
43readParam :: Word -> Eval CapParam
44readParam pn = do
44readParam pn = do
45− !params <- evalParams <$> get
45+ !params <- get >>= return . evalParams
46 return $! genericIndex params pn
46 return $! genericIndex params pn
47
47
48push :: CapParam -> Eval ()
48push :: CapParam -> Eval ()
@@ -64,11 +64,11 @@ writeCapExpr cap params =
64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
65
65
66writeCapOps :: CapOps -> Eval ()
66writeCapOps :: CapOps -> Eval ()
67−writeCapOps = mapM_ writeCapOp
67+writeCapOps ops = mapM_ writeCapOp ops
68
68
69writeCapOp :: CapOp -> Eval ()
69writeCapOp :: CapOp -> Eval ()
70writeCapOp (Bytes !offset !count) = do
70writeCapOp (Bytes !offset !count) = do
71− !cap <- evalExpression <$> get
71+ !cap <- get >>= return . evalExpression
72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
73 Vector.forM_ bytes $ tell.writeWord8
73 Vector.forM_ bytes $ tell.writeWord8
74writeCapOp DecOut = do
74writeCapOp DecOut = do
src/Data/Terminfo/Parse.hs+13−22
@@ -1,9 +1,8 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE CPP #-}
2+{-# OPTIONS_HADDOCK hide #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE NamedFieldPuns #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6−{-# OPTIONS_HADDOCK hide #-}
7
6
8module Data.Terminfo.Parse
7module Data.Terminfo.Parse
9 ( module Data.Terminfo.Parse
8 ( module Data.Terminfo.Parse
@@ -14,9 +13,6 @@ where
14import Control.Monad ( liftM )
13import Control.Monad ( liftM )
15import Control.DeepSeq
14import Control.DeepSeq
16
15
17−#if !(MIN_VERSION_base(4,11,0))
18−import Data.Semigroup (Semigroup(..))
19−#endif
20import Data.Word
16import Data.Word
21import qualified Data.Vector.Unboxed as Vector
17import qualified Data.Vector.Unboxed as Vector
22
18
@@ -39,7 +35,7 @@ instance Show CapExpression where
39 ++ " <= " ++ show (sourceString c)
35 ++ " <= " ++ show (sourceString c)
40 where
36 where
41 hexDump :: [Word8] -> String
37 hexDump :: [Word8] -> String
42− hexDump = foldr showHex ""
38+ hexDump = foldr (\b s -> showHex b s) ""
43
39
44instance NFData CapExpression where
40instance NFData CapExpression where
45 rnf (CapExpression ops !_bytes !str !c !pOps)
41 rnf (CapExpression ops !_bytes !str !c !pOps)
@@ -99,7 +95,7 @@ parseCapExpression capString =
99 Left e -> Left e
95 Left e -> Left e
100 Right buildResults -> Right $ constructCapExpression capString buildResults
96 Right buildResults -> Right $ constructCapExpression capString buildResults
101
97
102−constructCapExpression :: String -> BuildResults -> CapExpression
98+constructCapExpression :: [Char] -> BuildResults -> CapExpression
103constructCapExpression capString buildResults =
99constructCapExpression capString buildResults =
104 let expr = CapExpression
100 let expr = CapExpression
105 { capOps = outCapOps buildResults
101 { capOps = outCapOps buildResults
@@ -128,7 +124,7 @@ paramEscapeParser = do
128literalPercentParser :: CapParser BuildResults
124literalPercentParser :: CapParser BuildResults
129literalPercentParser = do
125literalPercentParser = do
130 _ <- char '%'
126 _ <- char '%'
131− startOffset <- nextOffset <$> getState
127+ startOffset <- getState >>= return . nextOffset
132 incOffset 1
128 incOffset 1
133 return $ BuildResults 0 [Bytes startOffset 1] []
129 return $ BuildResults 0 [Bytes startOffset 1] []
134
130
@@ -154,7 +150,7 @@ incrementOpParser = do
154pushOpParser :: CapParser BuildResults
150pushOpParser :: CapParser BuildResults
155pushOpParser = do
151pushOpParser = do
156 _ <- char 'p'
152 _ <- char 'p'
157− paramN <- read . pure <$> digit
153+ paramN <- digit >>= return . (\d -> read [d])
158 incOffset 2
154 incOffset 2
159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
155 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
160
156
@@ -299,7 +295,7 @@ compareOpParser
299bytesOpParser :: CapParser BuildResults
295bytesOpParser :: CapParser BuildResults
300bytesOpParser = do
296bytesOpParser = do
301 bytes <- many1 $ satisfy (/= '%')
297 bytes <- many1 $ satisfy (/= '%')
302− startOffset <- nextOffset <$> getState
298+ startOffset <- getState >>= return . nextOffset
303 let !c = length bytes
299 let !c = length bytes
304 !s <- getState
300 !s <- getState
305 let s' = s { nextOffset = startOffset + c }
301 let s' = s { nextOffset = startOffset + c }
@@ -333,16 +329,11 @@ data BuildResults = BuildResults
333 , outParamOps :: !ParamOps
329 , outParamOps :: !ParamOps
334 }
330 }
335
331
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
332instance Monoid BuildResults where
345 mempty = BuildResults 0 [] []
333 mempty = BuildResults 0 [] []
346−#if !(MIN_VERSION_base(4,11,0))
334+ v0 `mappend` v1
347− mappend = (<>)
335+ = BuildResults
348−#endif
336+ { outParamCount = (outParamCount v0) `max` (outParamCount v1)
337+ , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
338+ , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
339+ }
src/Graphics/Text/Width.hs+9−40
@@ -1,47 +1,26 @@
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
16
38−wctlwidth :: TL.Text -> Int
17+-- XXX: Characters with unknown widths occupy 1 column?
39−wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0
18+--
40−
19+-- Not sure if this is actually correct. I presume there is a
41−{-# RULES
20+-- replacement character that is output by the terminal instead of the
42−"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x
21+-- character and this replacement character is 1 column wide. If this is
43−"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x
22+-- not true for all terminals then a per-terminal replacement character
44− #-}
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.
@@ -51,14 +30,4 @@ safeWcwidth = max 0 . wcwidth
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+38−134
@@ -1,6 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−
4-- | Vty provides interfaces for both terminal input and terminal
1-- | Vty provides interfaces for both terminal input and terminal
5-- output.
2-- output.
6--
3--
@@ -13,9 +10,6 @@
13-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
10-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
14-- values in the "Graphics.Vty.Attributes" module.
11-- values in the "Graphics.Vty.Attributes" module.
15--
12--
16−-- Vty uses threads internally, so programs made with Vty need to be
17−-- compiled with the threaded runtime using the GHC @-threaded@ option.
18−--
19-- @
13-- @
20-- import "Graphics.Vty"
14-- import "Graphics.Vty"
21--
15--
@@ -34,7 +28,6 @@
34module Graphics.Vty
28module Graphics.Vty
35 ( Vty(..)
29 ( Vty(..)
36 , mkVty
30 , mkVty
37− , setWindowTitle
38 , Mode(..)
31 , Mode(..)
39 , module Graphics.Vty.Config
32 , module Graphics.Vty.Config
40 , module Graphics.Vty.Input
33 , module Graphics.Vty.Input
@@ -48,33 +41,23 @@ where
48
41
49import Graphics.Vty.Config
42import Graphics.Vty.Config
50import Graphics.Vty.Input
43import Graphics.Vty.Input
51−import Graphics.Vty.Input.Events
52import Graphics.Vty.Output
44import Graphics.Vty.Output
53import Graphics.Vty.Output.Interface
45import Graphics.Vty.Output.Interface
54import Graphics.Vty.Picture
46import Graphics.Vty.Picture
55import Graphics.Vty.Image
47import Graphics.Vty.Image
56import Graphics.Vty.Attributes
48import Graphics.Vty.Attributes
57−import Graphics.Vty.UnicodeWidthTable.IO
58−import Graphics.Vty.UnicodeWidthTable.Install
59
49
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
50import Control.Concurrent.STM
66
51
67import Data.IORef
52import Data.IORef
68−#if !(MIN_VERSION_base(4,11,0))
69−import Data.Semigroup ((<>))
53+import Data.Monoid
70−#endif
71
54
72-- | A Vty value represents a handle to the Vty library that the
55-- | A Vty value represents a handle to the Vty library that the
73-- application must create in order to use Vty.
56-- application must create in order to use Vty.
74--
57--
75-- The use of Vty typically follows this process:
58-- The use of Vty typically follows this process:
76--
59--
77−-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
60+-- 1. Initialize vty
78--
61--
79-- 2. Use 'update' to display a picture.
62-- 2. Use 'update' to display a picture.
80--
63--
@@ -82,33 +65,31 @@ import Data.Semigroup ((<>))
82--
65--
83-- 4. Depending on the event, go to 2 or 5.
66-- 4. Depending on the event, go to 2 or 5.
84--
67--
85−-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
68+-- 5. Shutdown vty.
86−-- this point the 'Vty' handle cannot be used again.
87--
69--
88-- Operations on Vty handles are not thread-safe.
70-- Operations on Vty handles are not thread-safe.
89−data Vty =
71+data Vty = Vty
90− Vty { update :: Picture -> IO ()
91− -- ^ Outputs the given 'Picture'.
72+ { -- | Outputs the given 'Picture'.
92− , nextEvent :: IO Event
73+ update :: Picture -> IO ()
93− -- ^ Return the next 'Event' or block until one becomes
74+ -- | Get one 'Event' object, blocking if none are available. This
94− -- available.
75+ -- will refresh the terminal if the event is a 'EvResize'.
95− , nextEventNonblocking :: IO (Maybe Event)
76+ , nextEvent :: IO Event
96− -- ^ Non-blocking version of 'nextEvent'.
97− , inputIface :: Input
98− -- ^ The input interface. See 'Input'.
77+ -- | The input interface. See 'Input'.
78+ , inputIface :: Input
79+ -- | The output interface. See 'Output'.
99− , outputIface :: Output
80+ , outputIface :: Output
100− -- ^ The output interface. See 'Output'.
81+ -- | Refresh the display. 'nextEvent' will refresh the display if
101− , refresh :: IO ()
82+ -- a resize occurs, but this can be used to refresh the display
102− -- ^ Refresh the display. If other programs output to the
83+ -- explicitly. If other programs output to the terminal and mess
103− -- terminal and mess up the display then the application might
84+ -- up the display then the application might want to force a
104− -- want to force a refresh using this function.
85+ -- refresh using this function.
105− , shutdown :: IO ()
86+ , refresh :: IO ()
106− -- ^ Clean up after vty. A call to this function is necessary to
87+ -- | Clean up after vty. A call to this function is necessary to
107− -- cleanly restore the terminal state before application exit.
88+ -- cleanly restore the terminal state before application exit. The
108− -- The above methods will throw an exception if executed after
89+ -- above methods will throw an exception if executed after this is
109− -- this is executed. Idempotent.
90+ -- executed.
110− , isShutdown :: IO Bool
91+ , shutdown :: IO ()
111− }
92+ }
112
93
113-- | Create a Vty handle. At most one handle should be created at a time
94-- | Create a Vty handle. At most one handle should be created at a time
114-- for a given terminal device.
95-- for a given terminal device.
@@ -121,63 +102,17 @@ data Vty =
121mkVty :: Config -> IO Vty
102mkVty :: Config -> IO Vty
122mkVty appConfig = do
103mkVty appConfig = do
123 config <- (<> appConfig) <$> userConfig
104 config <- (<> appConfig) <$> userConfig
105+ input <- inputForConfig config
106+ out <- outputForConfig config
107+ intMkVty input out
124
108
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
109+intMkVty :: Input -> Output -> IO Vty
168−internalMkVty input out = do
110+intMkVty input out = do
169 reserveDisplay out
111 reserveDisplay out
170−
171− shutdownVar <- newTVarIO False
172 let shutdownIo = do
112 let shutdownIo = do
173− alreadyShutdown <- atomically $ swapTVar shutdownVar True
174− when (not alreadyShutdown) $ do
175− shutdownInput input
113+ shutdownInput input
176− releaseDisplay out
114+ releaseDisplay out
177− releaseTerminal out
115+ releaseTerminal out
178−
179− let shutdownStatus = readTVarIO shutdownVar
180−
181 lastPicRef <- newIORef Nothing
116 lastPicRef <- newIORef Nothing
182 lastUpdateRef <- newIORef Nothing
117 lastUpdateRef <- newIORef Nothing
183
118
@@ -209,47 +144,16 @@ internalMkVty input out = do
209 mPic <- readIORef lastPicRef
144 mPic <- readIORef lastPicRef
210 maybe (return ()) innerUpdate mPic
145 maybe (return ()) innerUpdate mPic
211
146
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
147+ let gkey = do k <- atomically $ readTChan $ _eventChannel input
219− translateInternalEvent e
220− gkey' = do
221− mEv <- atomically $ tryReadTChan $ _eventChannel input
222− case mEv of
148+ case k of
223− Just e -> Just <$> translateInternalEvent e
149+ (EvResize _ _) -> displayBounds out
150+ >>= return . (\(w,h)-> EvResize w h)
224− Nothing -> return Nothing
151+ _ -> return k
225
152
226 return $ Vty { update = innerUpdate
153 return $ Vty { update = innerUpdate
227 , nextEvent = gkey
154 , nextEvent = gkey
228− , nextEventNonblocking = gkey'
229 , inputIface = input
155 , inputIface = input
230 , outputIface = out
156 , outputIface = out
231 , refresh = innerRefresh
157 , refresh = innerRefresh
232 , shutdown = shutdownIo
158 , shutdown = shutdownIo
233− , isShutdown = shutdownStatus
234 }
159 }
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+43−51
@@ -1,6 +1,6 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE StandaloneDeriving #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE RankNTypes #-}
4
4
5-- | Display attributes
5-- | Display attributes
6--
6--
@@ -27,9 +27,7 @@
27-- The value 'currentAttr' will keep the attributes of whatever was
27-- The value 'currentAttr' will keep the attributes of whatever was
28-- output previously.
28-- output previously.
29module Graphics.Vty.Attributes
29module Graphics.Vty.Attributes
30− ( module Graphics.Vty.Attributes.Color
31−
32− , Attr(..)
30+ ( Attr(..)
33 , FixedAttr(..)
31 , FixedAttr(..)
34 , MaybeDefault(..)
32 , MaybeDefault(..)
35 , defAttr
33 , defAttr
@@ -39,8 +37,6 @@ module Graphics.Vty.Attributes
39 , Style
37 , Style
40 , withStyle
38 , withStyle
41 , standout
39 , standout
42− , italic
43− , strikethrough
44 , underline
40 , underline
45 , reverseVideo
41 , reverseVideo
46 , blink
42 , blink
@@ -54,18 +50,17 @@ module Graphics.Vty.Attributes
54 , withForeColor
50 , withForeColor
55 , withBackColor
51 , withBackColor
56
52
57− -- * Setting hyperlinks
53+ -- * Colors
58− , withURL
54+ , module Graphics.Vty.Attributes.Color
55+ , module Graphics.Vty.Attributes.Color240
59 )
56 )
60where
57where
61
58
62−import Control.DeepSeq
63import Data.Bits
59import Data.Bits
64−import Data.Text (Text)
65import Data.Word
60import Data.Word
66−import GHC.Generics
67
61
68import Graphics.Vty.Attributes.Color
62import Graphics.Vty.Attributes.Color
63+import Graphics.Vty.Attributes.Color240
69
64
70-- | A display attribute defines the Color and Style of all the
65-- | A display attribute defines the Color and Style of all the
71-- characters rendered after the attribute is applied.
66-- characters rendered after the attribute is applied.
@@ -78,8 +73,7 @@ data Attr = Attr
78 { attrStyle :: !(MaybeDefault Style)
73 { attrStyle :: !(MaybeDefault Style)
79 , attrForeColor :: !(MaybeDefault Color)
74 , attrForeColor :: !(MaybeDefault Color)
80 , attrBackColor :: !(MaybeDefault Color)
75 , attrBackColor :: !(MaybeDefault Color)
81− , attrURL :: !(MaybeDefault Text)
82− } deriving ( Eq, Show, Read, Generic, NFData )
76+ } deriving ( Eq, Show, Read )
83
77
84-- This could be encoded into a single 32 bit word. The 32 bit word is
78-- 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
79-- first divided into 4 groups of 8 bits where: The first group codes
@@ -100,19 +94,25 @@ data Attr = Attr
100-- __ - unused
94-- __ - unused
101--
95--
102-- Next is the style flags
96-- Next is the style flags
103−-- SURBDOI_
97+-- SURBDO__
104-- S - standout
98-- S - standout
105-- U - underline
99-- U - underline
106-- R - reverse video
100-- R - reverse video
107-- B - blink
101-- B - blink
108-- D - dim
102-- D - dim
109-- O - bold
103-- O - bold
110−-- I - italic
111−-- _ - unused
104+-- __ - unused
112--
105--
113-- Then the foreground color encoded into 8 bits.
106-- Then the foreground color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
107-- Then the background color encoded into 8 bits.
115
108
109+instance Monoid Attr where
110+ mempty = Attr mempty mempty mempty
111+ mappend attr0 attr1 =
112+ Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
113+ ( attrForeColor attr0 `mappend` attrForeColor attr1 )
114+ ( attrBackColor attr0 `mappend` attrBackColor attr1 )
115+
116-- | Specifies the display attributes such that the final style and
116-- | Specifies the display attributes such that the final style and
117-- color values do not depend on the previously applied display
117-- color values do not depend on the previously applied display
118-- attribute. The display attributes can still depend on the terminal's
118-- attribute. The display attributes can still depend on the terminal's
@@ -121,26 +121,38 @@ data FixedAttr = FixedAttr
121 { fixedStyle :: !Style
121 { fixedStyle :: !Style
122 , fixedForeColor :: !(Maybe Color)
122 , fixedForeColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
123 , fixedBackColor :: !(Maybe Color)
124− , fixedURL :: !(Maybe Text)
125 } deriving ( Eq, Show )
124 } deriving ( Eq, Show )
126
125
127-- | The style and color attributes can either be the terminal defaults.
126-- | The style and color attributes can either be the terminal defaults.
128-- Or be equivalent to the previously applied style. Or be a specific
127-- Or be equivalent to the previously applied style. Or be a specific
129-- value.
128-- value.
130−data MaybeDefault v = Default | KeepCurrent | SetTo !v
129+data MaybeDefault v where
131− deriving (Eq, Read, Show)
130+ Default :: MaybeDefault v
132−
131+ KeepCurrent :: MaybeDefault v
132+ SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
133+
134+deriving instance Eq v => Eq (MaybeDefault v)
135+deriving instance Eq v => Show (MaybeDefault v)
133−instance (NFData v) => NFData (MaybeDefault v) where
136+deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
134− rnf Default = ()
137+
138+instance Eq v => Monoid ( MaybeDefault v ) where
139+ mempty = KeepCurrent
140+ mappend Default Default = Default
141+ mappend Default KeepCurrent = Default
142+ mappend Default ( SetTo v ) = SetTo v
135− rnf KeepCurrent = ()
143+ mappend KeepCurrent Default = Default
136− rnf (SetTo v) = rnf v
144+ mappend KeepCurrent KeepCurrent = KeepCurrent
145+ mappend KeepCurrent ( SetTo v ) = SetTo v
146+ mappend ( SetTo _v ) Default = Default
147+ mappend ( SetTo v ) KeepCurrent = SetTo v
148+ mappend ( SetTo _ ) ( SetTo v ) = SetTo v
137
149
138-- | Styles are represented as an 8 bit word. Each bit in the word is 1
150-- | 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
151-- if the style attribute assigned to that bit should be applied and 0
140-- if the style attribute should not be applied.
152-- if the style attribute should not be applied.
141type Style = Word8
153type Style = Word8
142
154
143−-- | Valid style attributes include:
155+-- | The 6 possible style attributes:
144--
156--
145-- * standout
157-- * standout
146--
158--
@@ -154,21 +166,15 @@ type Style = Word8
154--
166--
155-- * bold/bright
167-- * bold/bright
156--
168--
157−-- * italic
158−--
159−-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160−--
161-- (The invisible, protect, and altcharset display attributes some
169-- (The invisible, protect, and altcharset display attributes some
162-- terminals support are not supported via VTY.)
170-- terminals support are not supported via VTY.)
163−standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
171+standout, underline, reverseVideo, blink, dim, bold :: Style
164standout = 0x01
172standout = 0x01
165underline = 0x02
173underline = 0x02
166−reverseVideo = 0x04
174+reverseVideo = 0x04
167blink = 0x08
175blink = 0x08
168dim = 0x10
176dim = 0x10
169bold = 0x20
177bold = 0x20
170−italic = 0x40
171−strikethrough = 0x80
172
178
173defaultStyleMask :: Style
179defaultStyleMask :: Style
174defaultStyleMask = 0x00
180defaultStyleMask = 0x00
@@ -197,25 +203,11 @@ withStyle :: Attr -> Style -> Attr
197withStyle attr 0 = attr
203withStyle attr 0 = attr
198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
204withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
199
205
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
206-- | Sets the style, background color and foreground color to the
215-- default values for the terminal. There is no easy way to determine
207-- default values for the terminal. There is no easy way to determine
216-- what the default background and foreground colors are.
208-- what the default background and foreground colors are.
217defAttr :: Attr
209defAttr :: Attr
218−defAttr = Attr Default Default Default Default
210+defAttr = Attr Default Default Default
219
211
220-- | Keeps the style, background color and foreground color that was
212-- | Keeps the style, background color and foreground color that was
221-- previously set. Used to override some part of the previous style.
213-- previously set. Used to override some part of the previous style.
@@ -225,4 +217,4 @@ defAttr = Attr Default Default Default Default
225-- Would be the currently applied style (be it underline, bold, etc) but
217-- Would be the currently applied style (be it underline, bold, etc) but
226-- with the foreground color set to brightMagenta.
218-- with the foreground color set to brightMagenta.
227currentAttr :: Attr
219currentAttr :: Attr
228−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
220+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs+5−96
@@ -1,24 +1,5 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3−{-# LANGUAGE MultiWayIf #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−
6module Graphics.Vty.Attributes.Color
1module Graphics.Vty.Attributes.Color
7 ( Color(..)
2 ( 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
3 , black
23 , red
4 , red
24 , green
5 , green
@@ -27,8 +8,6 @@ module Graphics.Vty.Attributes.Color
27 , magenta
8 , magenta
28 , cyan
9 , cyan
29 , white
10 , white
30−
31− -- | Bright/Vivid variants of the standard 8-color ANSI
32 , brightBlack
11 , brightBlack
33 , brightRed
12 , brightRed
34 , brightGreen
13 , brightGreen
@@ -37,25 +16,10 @@ module Graphics.Vty.Attributes.Color
37 , brightMagenta
16 , brightMagenta
38 , brightCyan
17 , brightCyan
39 , brightWhite
18 , brightWhite
40− -- ** Creating Colors From RGB
41− , linearColor
42− , srgbColor
43− , rgbColor
44− , color240
45− , module Graphics.Vty.Attributes.Color240
46 )
19 )
47where
20where
48
21
49import Data.Word
22import 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
23
60-- | Abstract data type representing a color.
24-- | Abstract data type representing a color.
61--
25--
@@ -95,7 +59,7 @@ import Graphics.Vty.Attributes.Color240
95-- reported then the color reproduction will be incorrect.
59-- reported then the color reproduction will be incorrect.
96--
60--
97-- If the terminal reports <= 16 colors then the 240 color palette
61-- 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
62+-- 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
63-- the RGB points for the "bright" colors which is why they are not
100-- addressable via the 240 color palette.
64-- addressable via the 240 color palette.
101--
65--
@@ -109,33 +73,10 @@ import Graphics.Vty.Attributes.Color240
109-- terminfo but I don't know it.
73-- terminfo but I don't know it.
110--
74--
111-- Seriously, terminal color support is INSANE.
75-- Seriously, terminal color support is INSANE.
112−data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8
76+data Color = ISOColor !Word8 | Color240 !Word8
113− deriving ( Eq, Show, Read, Generic, NFData )
77+ 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
78
79+-- | Standard 8-color ANSI terminal color codes.
139black, red, green, yellow, blue, magenta, cyan, white :: Color
80black, red, green, yellow, blue, magenta, cyan, white :: Color
140black = ISOColor 0
81black = ISOColor 0
141red = ISOColor 1
82red = ISOColor 1
@@ -146,6 +87,7 @@ magenta= ISOColor 5
146cyan = ISOColor 6
87cyan = ISOColor 6
147white = ISOColor 7
88white = ISOColor 7
148
89
90+-- | Bright/Vivid variants of the standard 8-color ANSI
149brightBlack, brightRed, brightGreen, brightYellow :: Color
91brightBlack, brightRed, brightGreen, brightYellow :: Color
150brightBlue, brightMagenta, brightCyan, brightWhite :: Color
92brightBlue, brightMagenta, brightCyan, brightWhite :: Color
151brightBlack = ISOColor 8
93brightBlack = ISOColor 8
@@ -156,36 +98,3 @@ brightBlue = ISOColor 12
156brightMagenta= ISOColor 13
98brightMagenta= ISOColor 13
157brightCyan = ISOColor 14
99brightCyan = ISOColor 14
158brightWhite = ISOColor 15
100brightWhite = 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+248−285
@@ -1,298 +1,261 @@
1-- This header file was generated by ./256colres.pl
1-- This header file was generated by ./256colres.pl
2module Graphics.Vty.Attributes.Color240
2module Graphics.Vty.Attributes.Color240
3− ( rgbColorToColor240
3+ ( rgbColor
4− , color240CodeToRGB
5 )
4 )
6where
5where
7
6
8−import Data.Word (Word8)
7+import Graphics.Vty.Attributes.Color
8+
9import Text.Printf
9import Text.Printf
10
10
11-- Note: rgbColor's mapping from RGB to 240 colors was generated from
11-- Note: rgbColor's mapping from RGB to 240 colors was generated from
12-- 256colres.pl which is forked from xterm 256colres.pl.
12-- 256colres.pl which is forked from xterm 256colres.pl.
13
13
14−-- | Create a value in the Color240 set from an RGB triple
14+-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.
15−rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
15+rgbColor :: Integral i => i -> i -> i -> Color
16−rgbColorToColor240 r g b
16+rgbColor r g b
17 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
17 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
18− | r == 8 && g == 8 && b == 8 = 216
18+ | r == 8 && g == 8 && b == 8 = Color240 216
19− | r == 18 && g == 18 && b == 18 = 217
19+ | r == 18 && g == 18 && b == 18 = Color240 217
20− | r == 28 && g == 28 && b == 28 = 218
20+ | r == 28 && g == 28 && b == 28 = Color240 218
21− | r == 38 && g == 38 && b == 38 = 219
21+ | r == 38 && g == 38 && b == 38 = Color240 219
22− | r == 48 && g == 48 && b == 48 = 220
22+ | r == 48 && g == 48 && b == 48 = Color240 220
23− | r == 58 && g == 58 && b == 58 = 221
23+ | r == 58 && g == 58 && b == 58 = Color240 221
24− | r == 68 && g == 68 && b == 68 = 222
24+ | r == 68 && g == 68 && b == 68 = Color240 222
25− | r == 78 && g == 78 && b == 78 = 223
25+ | r == 78 && g == 78 && b == 78 = Color240 223
26− | r == 88 && g == 88 && b == 88 = 224
26+ | r == 88 && g == 88 && b == 88 = Color240 224
27− | r == 98 && g == 98 && b == 98 = 225
27+ | r == 98 && g == 98 && b == 98 = Color240 225
28− | r == 108 && g == 108 && b == 108 = 226
28+ | r == 108 && g == 108 && b == 108 = Color240 226
29− | r == 118 && g == 118 && b == 118 = 227
29+ | r == 118 && g == 118 && b == 118 = Color240 227
30− | r == 128 && g == 128 && b == 128 = 228
30+ | r == 128 && g == 128 && b == 128 = Color240 228
31− | r == 138 && g == 138 && b == 138 = 229
31+ | r == 138 && g == 138 && b == 138 = Color240 229
32− | r == 148 && g == 148 && b == 148 = 230
32+ | r == 148 && g == 148 && b == 148 = Color240 230
33− | r == 158 && g == 158 && b == 158 = 231
33+ | r == 158 && g == 158 && b == 158 = Color240 231
34− | r == 168 && g == 168 && b == 168 = 232
34+ | r == 168 && g == 168 && b == 168 = Color240 232
35− | r == 178 && g == 178 && b == 178 = 233
35+ | r == 178 && g == 178 && b == 178 = Color240 233
36− | r == 188 && g == 188 && b == 188 = 234
36+ | r == 188 && g == 188 && b == 188 = Color240 234
37− | r == 198 && g == 198 && b == 198 = 235
37+ | r == 198 && g == 198 && b == 198 = Color240 235
38− | r == 208 && g == 208 && b == 208 = 236
38+ | r == 208 && g == 208 && b == 208 = Color240 236
39− | r == 218 && g == 218 && b == 218 = 237
39+ | r == 218 && g == 218 && b == 218 = Color240 237
40− | r == 228 && g == 228 && b == 228 = 238
40+ | r == 228 && g == 228 && b == 228 = Color240 238
41− | r == 238 && g == 238 && b == 238 = 239
41+ | r == 238 && g == 238 && b == 238 = Color240 239
42− | otherwise = 36 * go r + 6 * go g + go b
42+ | 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."
43+ | r <= 0 && g <= 0 && b <= 95 = Color240 1
44+ | r <= 0 && g <= 0 && b <= 135 = Color240 2
45+ | r <= 0 && g <= 0 && b <= 175 = Color240 3
46+ | r <= 0 && g <= 0 && b <= 215 = Color240 4
47+ | r <= 0 && g <= 0 && b <= 255 = Color240 5
48+ | r <= 0 && g <= 95 && b <= 0 = Color240 6
49+ | r <= 0 && g <= 95 && b <= 95 = Color240 7
50+ | r <= 0 && g <= 95 && b <= 135 = Color240 8
51+ | r <= 0 && g <= 95 && b <= 175 = Color240 9
52+ | r <= 0 && g <= 95 && b <= 215 = Color240 10
53+ | r <= 0 && g <= 95 && b <= 255 = Color240 11
54+ | r <= 0 && g <= 135 && b <= 0 = Color240 12
55+ | r <= 0 && g <= 135 && b <= 95 = Color240 13
56+ | r <= 0 && g <= 135 && b <= 135 = Color240 14
57+ | r <= 0 && g <= 135 && b <= 175 = Color240 15
58+ | r <= 0 && g <= 135 && b <= 215 = Color240 16
59+ | r <= 0 && g <= 135 && b <= 255 = Color240 17
60+ | r <= 0 && g <= 175 && b <= 0 = Color240 18
61+ | r <= 0 && g <= 175 && b <= 95 = Color240 19
62+ | r <= 0 && g <= 175 && b <= 135 = Color240 20
63+ | r <= 0 && g <= 175 && b <= 175 = Color240 21
64+ | r <= 0 && g <= 175 && b <= 215 = Color240 22
65+ | r <= 0 && g <= 175 && b <= 255 = Color240 23
66+ | r <= 0 && g <= 215 && b <= 0 = Color240 24
67+ | r <= 0 && g <= 215 && b <= 95 = Color240 25
68+ | r <= 0 && g <= 215 && b <= 135 = Color240 26
69+ | r <= 0 && g <= 215 && b <= 175 = Color240 27
70+ | r <= 0 && g <= 215 && b <= 215 = Color240 28
71+ | r <= 0 && g <= 215 && b <= 255 = Color240 29
72+ | r <= 0 && g <= 255 && b <= 0 = Color240 30
73+ | r <= 0 && g <= 255 && b <= 95 = Color240 31
74+ | r <= 0 && g <= 255 && b <= 135 = Color240 32
75+ | r <= 0 && g <= 255 && b <= 175 = Color240 33
76+ | r <= 0 && g <= 255 && b <= 215 = Color240 34
77+ | r <= 0 && g <= 255 && b <= 255 = Color240 35
78+ | r <= 95 && g <= 0 && b <= 0 = Color240 36
79+ | r <= 95 && g <= 0 && b <= 95 = Color240 37
80+ | r <= 95 && g <= 0 && b <= 135 = Color240 38
81+ | r <= 95 && g <= 0 && b <= 175 = Color240 39
82+ | r <= 95 && g <= 0 && b <= 215 = Color240 40
83+ | r <= 95 && g <= 0 && b <= 255 = Color240 41
84+ | r <= 95 && g <= 95 && b <= 0 = Color240 42
85+ | r <= 95 && g <= 95 && b <= 95 = Color240 43
86+ | r <= 95 && g <= 95 && b <= 135 = Color240 44
87+ | r <= 95 && g <= 95 && b <= 175 = Color240 45
88+ | r <= 95 && g <= 95 && b <= 215 = Color240 46
89+ | r <= 95 && g <= 95 && b <= 255 = Color240 47
90+ | r <= 95 && g <= 135 && b <= 0 = Color240 48
91+ | r <= 95 && g <= 135 && b <= 95 = Color240 49
92+ | r <= 95 && g <= 135 && b <= 135 = Color240 50
93+ | r <= 95 && g <= 135 && b <= 175 = Color240 51
94+ | r <= 95 && g <= 135 && b <= 215 = Color240 52
95+ | r <= 95 && g <= 135 && b <= 255 = Color240 53
96+ | r <= 95 && g <= 175 && b <= 0 = Color240 54
97+ | r <= 95 && g <= 175 && b <= 95 = Color240 55
98+ | r <= 95 && g <= 175 && b <= 135 = Color240 56
99+ | r <= 95 && g <= 175 && b <= 175 = Color240 57
100+ | r <= 95 && g <= 175 && b <= 215 = Color240 58
101+ | r <= 95 && g <= 175 && b <= 255 = Color240 59
102+ | r <= 95 && g <= 215 && b <= 0 = Color240 60
103+ | r <= 95 && g <= 215 && b <= 95 = Color240 61
104+ | r <= 95 && g <= 215 && b <= 135 = Color240 62
105+ | r <= 95 && g <= 215 && b <= 175 = Color240 63
106+ | r <= 95 && g <= 215 && b <= 215 = Color240 64
107+ | r <= 95 && g <= 215 && b <= 255 = Color240 65
108+ | r <= 95 && g <= 255 && b <= 0 = Color240 66
109+ | r <= 95 && g <= 255 && b <= 95 = Color240 67
110+ | r <= 95 && g <= 255 && b <= 135 = Color240 68
111+ | r <= 95 && g <= 255 && b <= 175 = Color240 69
112+ | r <= 95 && g <= 255 && b <= 215 = Color240 70
113+ | r <= 95 && g <= 255 && b <= 255 = Color240 71
114+ | r <= 135 && g <= 0 && b <= 0 = Color240 72
115+ | r <= 135 && g <= 0 && b <= 95 = Color240 73
116+ | r <= 135 && g <= 0 && b <= 135 = Color240 74
117+ | r <= 135 && g <= 0 && b <= 175 = Color240 75
118+ | r <= 135 && g <= 0 && b <= 215 = Color240 76
119+ | r <= 135 && g <= 0 && b <= 255 = Color240 77
120+ | r <= 135 && g <= 95 && b <= 0 = Color240 78
121+ | r <= 135 && g <= 95 && b <= 95 = Color240 79
122+ | r <= 135 && g <= 95 && b <= 135 = Color240 80
123+ | r <= 135 && g <= 95 && b <= 175 = Color240 81
124+ | r <= 135 && g <= 95 && b <= 215 = Color240 82
125+ | r <= 135 && g <= 95 && b <= 255 = Color240 83
126+ | r <= 135 && g <= 135 && b <= 0 = Color240 84
127+ | r <= 135 && g <= 135 && b <= 95 = Color240 85
128+ | r <= 135 && g <= 135 && b <= 135 = Color240 86
129+ | r <= 135 && g <= 135 && b <= 175 = Color240 87
130+ | r <= 135 && g <= 135 && b <= 215 = Color240 88
131+ | r <= 135 && g <= 135 && b <= 255 = Color240 89
132+ | r <= 135 && g <= 175 && b <= 0 = Color240 90
133+ | r <= 135 && g <= 175 && b <= 95 = Color240 91
134+ | r <= 135 && g <= 175 && b <= 135 = Color240 92
135+ | r <= 135 && g <= 175 && b <= 175 = Color240 93
136+ | r <= 135 && g <= 175 && b <= 215 = Color240 94
137+ | r <= 135 && g <= 175 && b <= 255 = Color240 95
138+ | r <= 135 && g <= 215 && b <= 0 = Color240 96
139+ | r <= 135 && g <= 215 && b <= 95 = Color240 97
140+ | r <= 135 && g <= 215 && b <= 135 = Color240 98
141+ | r <= 135 && g <= 215 && b <= 175 = Color240 99
142+ | r <= 135 && g <= 215 && b <= 215 = Color240 100
143+ | r <= 135 && g <= 215 && b <= 255 = Color240 101
144+ | r <= 135 && g <= 255 && b <= 0 = Color240 102
145+ | r <= 135 && g <= 255 && b <= 95 = Color240 103
146+ | r <= 135 && g <= 255 && b <= 135 = Color240 104
147+ | r <= 135 && g <= 255 && b <= 175 = Color240 105
148+ | r <= 135 && g <= 255 && b <= 215 = Color240 106
149+ | r <= 135 && g <= 255 && b <= 255 = Color240 107
150+ | r <= 175 && g <= 0 && b <= 0 = Color240 108
151+ | r <= 175 && g <= 0 && b <= 95 = Color240 109
152+ | r <= 175 && g <= 0 && b <= 135 = Color240 110
153+ | r <= 175 && g <= 0 && b <= 175 = Color240 111
154+ | r <= 175 && g <= 0 && b <= 215 = Color240 112
155+ | r <= 175 && g <= 0 && b <= 255 = Color240 113
156+ | r <= 175 && g <= 95 && b <= 0 = Color240 114
157+ | r <= 175 && g <= 95 && b <= 95 = Color240 115
158+ | r <= 175 && g <= 95 && b <= 135 = Color240 116
159+ | r <= 175 && g <= 95 && b <= 175 = Color240 117
160+ | r <= 175 && g <= 95 && b <= 215 = Color240 118
161+ | r <= 175 && g <= 95 && b <= 255 = Color240 119
162+ | r <= 175 && g <= 135 && b <= 0 = Color240 120
163+ | r <= 175 && g <= 135 && b <= 95 = Color240 121
164+ | r <= 175 && g <= 135 && b <= 135 = Color240 122
165+ | r <= 175 && g <= 135 && b <= 175 = Color240 123
166+ | r <= 175 && g <= 135 && b <= 215 = Color240 124
167+ | r <= 175 && g <= 135 && b <= 255 = Color240 125
168+ | r <= 175 && g <= 175 && b <= 0 = Color240 126
169+ | r <= 175 && g <= 175 && b <= 95 = Color240 127
170+ | r <= 175 && g <= 175 && b <= 135 = Color240 128
171+ | r <= 175 && g <= 175 && b <= 175 = Color240 129
172+ | r <= 175 && g <= 175 && b <= 215 = Color240 130
173+ | r <= 175 && g <= 175 && b <= 255 = Color240 131
174+ | r <= 175 && g <= 215 && b <= 0 = Color240 132
175+ | r <= 175 && g <= 215 && b <= 95 = Color240 133
176+ | r <= 175 && g <= 215 && b <= 135 = Color240 134
177+ | r <= 175 && g <= 215 && b <= 175 = Color240 135
178+ | r <= 175 && g <= 215 && b <= 215 = Color240 136
179+ | r <= 175 && g <= 215 && b <= 255 = Color240 137
180+ | r <= 175 && g <= 255 && b <= 0 = Color240 138
181+ | r <= 175 && g <= 255 && b <= 95 = Color240 139
182+ | r <= 175 && g <= 255 && b <= 135 = Color240 140
183+ | r <= 175 && g <= 255 && b <= 175 = Color240 141
184+ | r <= 175 && g <= 255 && b <= 215 = Color240 142
185+ | r <= 175 && g <= 255 && b <= 255 = Color240 143
186+ | r <= 215 && g <= 0 && b <= 0 = Color240 144
187+ | r <= 215 && g <= 0 && b <= 95 = Color240 145
188+ | r <= 215 && g <= 0 && b <= 135 = Color240 146
189+ | r <= 215 && g <= 0 && b <= 175 = Color240 147
190+ | r <= 215 && g <= 0 && b <= 215 = Color240 148
191+ | r <= 215 && g <= 0 && b <= 255 = Color240 149
192+ | r <= 215 && g <= 95 && b <= 0 = Color240 150
193+ | r <= 215 && g <= 95 && b <= 95 = Color240 151
194+ | r <= 215 && g <= 95 && b <= 135 = Color240 152
195+ | r <= 215 && g <= 95 && b <= 175 = Color240 153
196+ | r <= 215 && g <= 95 && b <= 215 = Color240 154
197+ | r <= 215 && g <= 95 && b <= 255 = Color240 155
198+ | r <= 215 && g <= 135 && b <= 0 = Color240 156
199+ | r <= 215 && g <= 135 && b <= 95 = Color240 157
200+ | r <= 215 && g <= 135 && b <= 135 = Color240 158
201+ | r <= 215 && g <= 135 && b <= 175 = Color240 159
202+ | r <= 215 && g <= 135 && b <= 215 = Color240 160
203+ | r <= 215 && g <= 135 && b <= 255 = Color240 161
204+ | r <= 215 && g <= 175 && b <= 0 = Color240 162
205+ | r <= 215 && g <= 175 && b <= 95 = Color240 163
206+ | r <= 215 && g <= 175 && b <= 135 = Color240 164
207+ | r <= 215 && g <= 175 && b <= 175 = Color240 165
208+ | r <= 215 && g <= 175 && b <= 215 = Color240 166
209+ | r <= 215 && g <= 175 && b <= 255 = Color240 167
210+ | r <= 215 && g <= 215 && b <= 0 = Color240 168
211+ | r <= 215 && g <= 215 && b <= 95 = Color240 169
212+ | r <= 215 && g <= 215 && b <= 135 = Color240 170
213+ | r <= 215 && g <= 215 && b <= 175 = Color240 171
214+ | r <= 215 && g <= 215 && b <= 215 = Color240 172
215+ | r <= 215 && g <= 215 && b <= 255 = Color240 173
216+ | r <= 215 && g <= 255 && b <= 0 = Color240 174
217+ | r <= 215 && g <= 255 && b <= 95 = Color240 175
218+ | r <= 215 && g <= 255 && b <= 135 = Color240 176
219+ | r <= 215 && g <= 255 && b <= 175 = Color240 177
220+ | r <= 215 && g <= 255 && b <= 215 = Color240 178
221+ | r <= 215 && g <= 255 && b <= 255 = Color240 179
222+ | r <= 255 && g <= 0 && b <= 0 = Color240 180
223+ | r <= 255 && g <= 0 && b <= 95 = Color240 181
224+ | r <= 255 && g <= 0 && b <= 135 = Color240 182
225+ | r <= 255 && g <= 0 && b <= 175 = Color240 183
226+ | r <= 255 && g <= 0 && b <= 215 = Color240 184
227+ | r <= 255 && g <= 0 && b <= 255 = Color240 185
228+ | r <= 255 && g <= 95 && b <= 0 = Color240 186
229+ | r <= 255 && g <= 95 && b <= 95 = Color240 187
230+ | r <= 255 && g <= 95 && b <= 135 = Color240 188
231+ | r <= 255 && g <= 95 && b <= 175 = Color240 189
232+ | r <= 255 && g <= 95 && b <= 215 = Color240 190
233+ | r <= 255 && g <= 95 && b <= 255 = Color240 191
234+ | r <= 255 && g <= 135 && b <= 0 = Color240 192
235+ | r <= 255 && g <= 135 && b <= 95 = Color240 193
236+ | r <= 255 && g <= 135 && b <= 135 = Color240 194
237+ | r <= 255 && g <= 135 && b <= 175 = Color240 195
238+ | r <= 255 && g <= 135 && b <= 215 = Color240 196
239+ | r <= 255 && g <= 135 && b <= 255 = Color240 197
240+ | r <= 255 && g <= 175 && b <= 0 = Color240 198
241+ | r <= 255 && g <= 175 && b <= 95 = Color240 199
242+ | r <= 255 && g <= 175 && b <= 135 = Color240 200
243+ | r <= 255 && g <= 175 && b <= 175 = Color240 201
244+ | r <= 255 && g <= 175 && b <= 215 = Color240 202
245+ | r <= 255 && g <= 175 && b <= 255 = Color240 203
246+ | r <= 255 && g <= 215 && b <= 0 = Color240 204
247+ | r <= 255 && g <= 215 && b <= 95 = Color240 205
248+ | r <= 255 && g <= 215 && b <= 135 = Color240 206
249+ | r <= 255 && g <= 215 && b <= 175 = Color240 207
250+ | r <= 255 && g <= 215 && b <= 215 = Color240 208
251+ | r <= 255 && g <= 215 && b <= 255 = Color240 209
252+ | r <= 255 && g <= 255 && b <= 0 = Color240 210
253+ | r <= 255 && g <= 255 && b <= 95 = Color240 211
254+ | r <= 255 && g <= 255 && b <= 135 = Color240 212
255+ | r <= 255 && g <= 255 && b <= 175 = Color240 213
256+ | r <= 255 && g <= 255 && b <= 215 = Color240 214
257+ | r <= 255 && g <= 255 && b <= 255 = Color240 215
258+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
44 (fromIntegral r :: Int)
259 (fromIntegral r :: Int)
45 (fromIntegral g :: Int)
260 (fromIntegral g :: Int)
46− (fromIntegral b :: Int)))
261+ (fromIntegral b :: Int))
47−
48−simpleColor_ :: Integral i => Word8 -> i -> Word8
49−simpleColor_ e c
50− | c <= 0 = 0
51− | c <= 95 = 1
52− | c <= 255 = fromIntegral ((c-16) `div` 40)
53− | otherwise = e
54−
55−-- | Create a RGB triple from a value in the Color240 set.
56−color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)
57−color240CodeToRGB n = case n of
58− 0 -> Just (0, 0, 0)
59− 1 -> Just (0, 0, 95)
60− 2 -> Just (0, 0, 135)
61− 3 -> Just (0, 0, 175)
62− 4 -> Just (0, 0, 215)
63− 5 -> Just (0, 0, 255)
64− 6 -> Just (0, 95, 0)
65− 7 -> Just (0, 95, 95)
66− 8 -> Just (0, 95, 135)
67− 9 -> Just (0, 95, 175)
68− 10 -> Just (0, 95, 215)
69− 11 -> Just (0, 95, 255)
70− 12 -> Just (0, 135, 0)
71− 13 -> Just (0, 135, 95)
72− 14 -> Just (0, 135, 135)
73− 15 -> Just (0, 135, 175)
74− 16 -> Just (0, 135, 215)
75− 17 -> Just (0, 135, 255)
76− 18 -> Just (0, 175, 0)
77− 19 -> Just (0, 175, 95)
78− 20 -> Just (0, 175, 135)
79− 21 -> Just (0, 175, 175)
80− 22 -> Just (0, 175, 215)
81− 23 -> Just (0, 175, 255)
82− 24 -> Just (0, 215, 0)
83− 25 -> Just (0, 215, 95)
84− 26 -> Just (0, 215, 135)
85− 27 -> Just (0, 215, 175)
86− 28 -> Just (0, 215, 215)
87− 29 -> Just (0, 215, 255)
88− 30 -> Just (0, 255, 0)
89− 31 -> Just (0, 255, 95)
90− 32 -> Just (0, 255, 135)
91− 33 -> Just (0, 255, 175)
92− 34 -> Just (0, 255, 215)
93− 35 -> Just (0, 255, 255)
94− 36 -> Just (95, 0, 0)
95− 37 -> Just (95, 0, 95)
96− 38 -> Just (95, 0, 135)
97− 39 -> Just (95, 0, 175)
98− 40 -> Just (95, 0, 215)
99− 41 -> Just (95, 0, 255)
100− 42 -> Just (95, 95, 0)
101− 43 -> Just (95, 95, 95)
102− 44 -> Just (95, 95, 135)
103− 45 -> Just (95, 95, 175)
104− 46 -> Just (95, 95, 215)
105− 47 -> Just (95, 95, 255)
106− 48 -> Just (95, 135, 0)
107− 49 -> Just (95, 135, 95)
108− 50 -> Just (95, 135, 135)
109− 51 -> Just (95, 135, 175)
110− 52 -> Just (95, 135, 215)
111− 53 -> Just (95, 135, 255)
112− 54 -> Just (95, 175, 0)
113− 55 -> Just (95, 175, 95)
114− 56 -> Just (95, 175, 135)
115− 57 -> Just (95, 175, 175)
116− 58 -> Just (95, 175, 215)
117− 59 -> Just (95, 175, 255)
118− 60 -> Just (95, 215, 0)
119− 61 -> Just (95, 215, 95)
120− 62 -> Just (95, 215, 135)
121− 63 -> Just (95, 215, 175)
122− 64 -> Just (95, 215, 215)
123− 65 -> Just (95, 215, 255)
124− 66 -> Just (95, 255, 0)
125− 67 -> Just (95, 255, 95)
126− 68 -> Just (95, 255, 135)
127− 69 -> Just (95, 255, 175)
128− 70 -> Just (95, 255, 215)
129− 71 -> Just (95, 255, 255)
130− 72 -> Just (135, 0, 0)
131− 73 -> Just (135, 0, 95)
132− 74 -> Just (135, 0, 135)
133− 75 -> Just (135, 0, 175)
134− 76 -> Just (135, 0, 215)
135− 77 -> Just (135, 0, 255)
136− 78 -> Just (135, 95, 0)
137− 79 -> Just (135, 95, 95)
138− 80 -> Just (135, 95, 135)
139− 81 -> Just (135, 95, 175)
140− 82 -> Just (135, 95, 215)
141− 83 -> Just (135, 95, 255)
142− 84 -> Just (135, 135, 0)
143− 85 -> Just (135, 135, 95)
144− 86 -> Just (135, 135, 135)
145− 87 -> Just (135, 135, 175)
146− 88 -> Just (135, 135, 215)
147− 89 -> Just (135, 135, 255)
148− 90 -> Just (135, 175, 0)
149− 91 -> Just (135, 175, 95)
150− 92 -> Just (135, 175, 135)
151− 93 -> Just (135, 175, 175)
152− 94 -> Just (135, 175, 215)
153− 95 -> Just (135, 175, 255)
154− 96 -> Just (135, 215, 0)
155− 97 -> Just (135, 215, 95)
156− 98 -> Just (135, 215, 135)
157− 99 -> Just (135, 215, 175)
158− 100 -> Just (135, 215, 215)
159− 101 -> Just (135, 215, 255)
160− 102 -> Just (135, 255, 0)
161− 103 -> Just (135, 255, 95)
162− 104 -> Just (135, 255, 135)
163− 105 -> Just (135, 255, 175)
164− 106 -> Just (135, 255, 215)
165− 107 -> Just (135, 255, 255)
166− 108 -> Just (175, 0, 0)
167− 109 -> Just (175, 0, 95)
168− 110 -> Just (175, 0, 135)
169− 111 -> Just (175, 0, 175)
170− 112 -> Just (175, 0, 215)
171− 113 -> Just (175, 0, 255)
172− 114 -> Just (175, 95, 0)
173− 115 -> Just (175, 95, 95)
174− 116 -> Just (175, 95, 135)
175− 117 -> Just (175, 95, 175)
176− 118 -> Just (175, 95, 215)
177− 119 -> Just (175, 95, 255)
178− 120 -> Just (175, 135, 0)
179− 121 -> Just (175, 135, 95)
180− 122 -> Just (175, 135, 135)
181− 123 -> Just (175, 135, 175)
182− 124 -> Just (175, 135, 215)
183− 125 -> Just (175, 135, 255)
184− 126 -> Just (175, 175, 0)
185− 127 -> Just (175, 175, 95)
186− 128 -> Just (175, 175, 135)
187− 129 -> Just (175, 175, 175)
188− 130 -> Just (175, 175, 215)
189− 131 -> Just (175, 175, 255)
190− 132 -> Just (175, 215, 0)
191− 133 -> Just (175, 215, 95)
192− 134 -> Just (175, 215, 135)
193− 135 -> Just (175, 215, 175)
194− 136 -> Just (175, 215, 215)
195− 137 -> Just (175, 215, 255)
196− 138 -> Just (175, 255, 0)
197− 139 -> Just (175, 255, 95)
198− 140 -> Just (175, 255, 135)
199− 141 -> Just (175, 255, 175)
200− 142 -> Just (175, 255, 215)
201− 143 -> Just (175, 255, 255)
202− 144 -> Just (215, 0, 0)
203− 145 -> Just (215, 0, 95)
204− 146 -> Just (215, 0, 135)
205− 147 -> Just (215, 0, 175)
206− 148 -> Just (215, 0, 215)
207− 149 -> Just (215, 0, 255)
208− 150 -> Just (215, 95, 0)
209− 151 -> Just (215, 95, 95)
210− 152 -> Just (215, 95, 135)
211− 153 -> Just (215, 95, 175)
212− 154 -> Just (215, 95, 215)
213− 155 -> Just (215, 95, 255)
214− 156 -> Just (215, 135, 0)
215− 157 -> Just (215, 135, 95)
216− 158 -> Just (215, 135, 135)
217− 159 -> Just (215, 135, 175)
218− 160 -> Just (215, 135, 215)
219− 161 -> Just (215, 135, 255)
220− 162 -> Just (215, 175, 0)
221− 163 -> Just (215, 175, 95)
222− 164 -> Just (215, 175, 135)
223− 165 -> Just (215, 175, 175)
224− 166 -> Just (215, 175, 215)
225− 167 -> Just (215, 175, 255)
226− 168 -> Just (215, 215, 0)
227− 169 -> Just (215, 215, 95)
228− 170 -> Just (215, 215, 135)
229− 171 -> Just (215, 215, 175)
230− 172 -> Just (215, 215, 215)
231− 173 -> Just (215, 215, 255)
232− 174 -> Just (215, 255, 0)
233− 175 -> Just (215, 255, 95)
234− 176 -> Just (215, 255, 135)
235− 177 -> Just (215, 255, 175)
236− 178 -> Just (215, 255, 215)
237− 179 -> Just (215, 255, 255)
238− 180 -> Just (255, 0, 0)
239− 181 -> Just (255, 0, 95)
240− 182 -> Just (255, 0, 135)
241− 183 -> Just (255, 0, 175)
242− 184 -> Just (255, 0, 215)
243− 185 -> Just (255, 0, 255)
244− 186 -> Just (255, 95, 0)
245− 187 -> Just (255, 95, 95)
246− 188 -> Just (255, 95, 135)
247− 189 -> Just (255, 95, 175)
248− 190 -> Just (255, 95, 215)
249− 191 -> Just (255, 95, 255)
250− 192 -> Just (255, 135, 0)
251− 193 -> Just (255, 135, 95)
252− 194 -> Just (255, 135, 135)
253− 195 -> Just (255, 135, 175)
254− 196 -> Just (255, 135, 215)
255− 197 -> Just (255, 135, 255)
256− 198 -> Just (255, 175, 0)
257− 199 -> Just (255, 175, 95)
258− 200 -> Just (255, 175, 135)
259− 201 -> Just (255, 175, 175)
260− 202 -> Just (255, 175, 215)
261− 203 -> Just (255, 175, 255)
262− 204 -> Just (255, 215, 0)
263− 205 -> Just (255, 215, 95)
264− 206 -> Just (255, 215, 135)
265− 207 -> Just (255, 215, 175)
266− 208 -> Just (255, 215, 215)
267− 209 -> Just (255, 215, 255)
268− 210 -> Just (255, 255, 0)
269− 211 -> Just (255, 255, 95)
270− 212 -> Just (255, 255, 135)
271− 213 -> Just (255, 255, 175)
272− 214 -> Just (255, 255, 215)
273− 215 -> Just (255, 255, 255)
274− 216 -> Just (8, 8, 8)
275− 217 -> Just (18, 18, 18)
276− 218 -> Just (28, 28, 28)
277− 219 -> Just (38, 38, 38)
278− 220 -> Just (48, 48, 48)
279− 221 -> Just (58, 58, 58)
280− 222 -> Just (68, 68, 68)
281− 223 -> Just (78, 78, 78)
282− 224 -> Just (88, 88, 88)
283− 225 -> Just (98, 98, 98)
284− 226 -> Just (108, 108, 108)
285− 227 -> Just (118, 118, 118)
286− 228 -> Just (128, 128, 128)
287− 229 -> Just (138, 138, 138)
288− 230 -> Just (148, 148, 148)
289− 231 -> Just (158, 158, 158)
290− 232 -> Just (168, 168, 168)
291− 233 -> Just (178, 178, 178)
292− 234 -> Just (188, 188, 188)
293− 235 -> Just (198, 198, 198)
294− 236 -> Just (208, 208, 208)
295− 237 -> Just (218, 218, 218)
296− 238 -> Just (228, 228, 228)
297− 239 -> Just (238, 238, 238)
298− _ -> Nothing
src/Graphics/Vty/Config.hs+68−259
@@ -1,9 +1,7 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
2{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
4{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE LambdaCase, MultiWayIf #-}
7-- | Vty supports a configuration file format and associated 'Config'
5-- | Vty supports a configuration file format and associated 'Config'
8-- data type. The 'Config' can be provided to 'mkVty' to customize the
6-- data type. The 'Config' can be provided to 'mkVty' to customize the
9-- application's use of Vty.
7-- application's use of Vty.
@@ -55,33 +53,7 @@
55-- If a debug log is requested then vty will output the current input
53-- 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
54-- table to the log in the above format. A workflow for using this is
57-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
55-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
58−-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.
56+-- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.
59−--
60−-- = Unicode Character Width Maps
61−--
62−-- == @widthMap@
63−--
64−-- Format:
65−--
66−-- @
67−-- \"widthMap\" string string
68−-- @
69−--
70−-- E.g.,
71−--
72−-- @
73−-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"
74−-- @
75−--
76−-- This directive specifies the path to a Unicode character width
77−-- map (the second argument) that should be loaded and used when
78−-- the value of TERM matches the first argument. Unicode character
79−-- width maps can be produced either by running the provided binary
80−-- @vty-build-width-table@ or by calling the library routine
81−-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The
82−-- 'Graphics.Vty.mkVty' function will use these configuration settings
83−-- to attempt to load and install the specified width map. See the
84−-- documentation for 'Graphics.Vty.mkVty' for details.
85module Graphics.Vty.Config
57module Graphics.Vty.Config
86 ( InputMap
58 ( InputMap
87 , Config(..)
59 , Config(..)
@@ -92,17 +64,6 @@ module Graphics.Vty.Config
92 , runParseConfig
64 , runParseConfig
93 , parseConfigFile
65 , parseConfigFile
94 , defaultConfig
66 , defaultConfig
95− , getTtyEraseChar
96− , currentTerminalName
97−
98− , vtyConfigPath
99− , widthTableFilename
100− , vtyDataDirectory
101− , terminalWidthTablePath
102− , vtyConfigFileEnvName
103−
104− , ConfigUpdateResult(..)
105− , addConfigWidthMap
106 )
67 )
107where
68where
108
69
@@ -114,40 +75,29 @@ import Control.Exception (catch, IOException, Exception(..), throwIO)
114import Control.Monad (liftM, guard, void)
75import Control.Monad (liftM, guard, void)
115
76
116import qualified Data.ByteString as BS
77import qualified Data.ByteString as BS
117−#if !(MIN_VERSION_base(4,8,0))
118−import Data.Monoid (Monoid(..))
78+import Data.Monoid
119−#endif
120−#if !(MIN_VERSION_base(4,11,0))
121−import Data.Semigroup (Semigroup(..))
122−#endif
123import Data.Typeable (Typeable)
79import Data.Typeable (Typeable)
124
80
125import Graphics.Vty.Input.Events
81import Graphics.Vty.Input.Events
126−import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
127
82
128import GHC.Generics
83import GHC.Generics
129
84
130−import System.Directory ( getAppUserDataDirectory, doesFileExist
85+import System.Directory (getAppUserDataDirectory)
131− , createDirectoryIfMissing
132− )
133−import System.Environment (lookupEnv)
86+import System.Posix.Env (getEnv)
134−import System.FilePath ((</>), takeDirectory)
135import System.Posix.IO (stdInput, stdOutput)
87import System.Posix.IO (stdInput, stdOutput)
136import System.Posix.Types (Fd(..))
88import System.Posix.Types (Fd(..))
137−import Foreign.C.Types (CInt(..), CChar(..))
138
89
139import Text.Parsec hiding ((<|>))
90import Text.Parsec hiding ((<|>))
140import Text.Parsec.Token ( GenLanguageDef(..) )
91import Text.Parsec.Token ( GenLanguageDef(..) )
141import qualified Text.Parsec.Token as P
92import qualified Text.Parsec.Token as P
142
93
143-- | Type of errors that can be thrown when configuring VTY
94-- | Type of errors that can be thrown when configuring VTY
144−data VtyConfigurationError =
95+data VtyConfigurationError
145− VtyMissingTermEnvVar
146− -- ^ TERM environment variable not set
96+ = VtyMissingTermEnvVar -- ^ TERM environment variable not set
147− deriving (Show, Eq, Typeable)
97+ deriving (Show, Eq, Typeable)
148
98
149instance Exception VtyConfigurationError where
99instance Exception VtyConfigurationError where
150− displayException VtyMissingTermEnvVar = "TERM environment variable not set"
100+ displayException VtyMissingTermEnvVar = "TERM environment variable not set"
151
101
152-- | Mappings from input bytes to event in the order specified. Later
102-- | Mappings from input bytes to event in the order specified. Later
153-- entries take precedence over earlier in the case multiple entries
103-- entries take precedence over earlier in the case multiple entries
@@ -155,144 +105,85 @@ instance Exception VtyConfigurationError where
155type InputMap = [(Maybe String, String, Event)]
105type InputMap = [(Maybe String, String, Event)]
156
106
157-- | A Vty configuration.
107-- | A Vty configuration.
158−data Config =
108+data Config = Config
109+ {
110+ -- | The default is 1 character.
159− Config { vmin :: Maybe Int
111+ vmin :: Maybe Int
160− -- ^ The default is 1 character.
161− , vtime :: Maybe Int
162− -- ^ The default is 100 milliseconds, 0.1 seconds.
112+ -- | The default is 100 milliseconds, 0.1 seconds.
113+ , vtime :: Maybe Int
114+ -- | The default is False.
163− , mouseMode :: Maybe Bool
115+ , mouseMode :: Maybe Bool
164− -- ^ The default is False.
116+ -- | The default is False.
165− , bracketedPasteMode :: Maybe Bool
117+ , bracketedPasteMode :: Maybe Bool
166− -- ^ The default is False.
167− , debugLog :: Maybe FilePath
168− -- ^ Debug information is appended to this file if not
118+ -- | Debug information is appended to this file if not Nothing.
169− -- Nothing.
119+ , debugLog :: Maybe FilePath
170− , inputMap :: InputMap
171− -- ^ The (input byte, output event) pairs extend the internal
120+ -- | The (input byte, output event) pairs extend the internal input
172− -- input table of VTY and the table from terminfo.
121+ -- table of VTY and the table from terminfo.
173− --
122+ --
174− -- See "Graphics.Vty.Config" module documentation for
123+ -- See "Graphics.Vty.Config" module documentation for documentation
175− -- documentation of the @map@ directive.
124+ -- of the @map@ directive.
176− , inputFd :: Maybe Fd
125+ , inputMap :: InputMap
177− -- ^ The input file descriptor to use. The default is
126+ -- | The input file descriptor to use. The default is
178− -- 'System.Posix.IO.stdInput'
127+ -- 'System.Posix.IO.stdInput'
179− , outputFd :: Maybe Fd
128+ , inputFd :: Maybe Fd
180− -- ^ The output file descriptor to use. The default is
129+ -- | The output file descriptor to use. The default is
181− -- 'System.Posix.IO.stdOutput'
130+ -- 'System.Posix.IO.stdOutput'
182− , termName :: Maybe String
131+ , outputFd :: Maybe Fd
183− -- ^ The terminal name used to look up terminfo capabilities.
132+ -- | The terminal name used to look up terminfo capabilities.
184− -- The default is the value of the TERM environment variable.
133+ -- The default is the value of the TERM environment variable.
185− , termWidthMaps :: [(String, FilePath)]
134+ , 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)
135+ } deriving (Show, Eq)
203
136
204defaultConfig :: Config
137defaultConfig :: Config
205defaultConfig = mempty
138defaultConfig = mempty
206
139
207−instance Semigroup Config where
208− c0 <> c1 =
209− -- latter config takes priority for everything but inputMap
210− Config { vmin = vmin c1 <|> vmin c0
211− , vtime = vtime c1 <|> vtime c0
212− , mouseMode = mouseMode c1
213− , bracketedPasteMode = bracketedPasteMode c1
214− , debugLog = debugLog c1 <|> debugLog c0
215− , inputMap = inputMap c0 <> inputMap c1
216− , inputFd = inputFd c1 <|> inputFd c0
217− , outputFd = outputFd c1 <|> outputFd c0
218− , termName = termName c1 <|> termName c0
219− , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0
220− , allowCustomUnicodeWidthTables =
221− allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0
222− , colorMode = colorMode c1 <|> colorMode c0
223− }
224−
225instance Monoid Config where
140instance Monoid Config where
226− mempty =
141+ mempty = Config
227− Config { vmin = Nothing
142+ { vmin = Nothing
228− , vtime = Nothing
143+ , vtime = Nothing
229− , mouseMode = Nothing
144+ , mouseMode = Nothing
230− , bracketedPasteMode = Nothing
145+ , bracketedPasteMode = Nothing
231− , debugLog = mempty
146+ , debugLog = mempty
232− , inputMap = mempty
147+ , inputMap = mempty
233− , inputFd = Nothing
148+ , inputFd = Nothing
234− , outputFd = Nothing
149+ , outputFd = Nothing
235− , termName = Nothing
150+ , termName = Nothing
236− , termWidthMaps = []
237− , allowCustomUnicodeWidthTables = Nothing
238− , colorMode = Nothing
239− }
151+ }
240−#if !(MIN_VERSION_base(4,11,0))
241− mappend = (<>)
152+ mappend c0 c1 = Config
242−#endif
153+ -- latter config takes priority for everything but inputMap
243−
154+ { vmin = vmin c1 <|> vmin c0
244−vtyDataDirectory :: IO FilePath
155+ , vtime = vtime c1 <|> vtime c0
245−vtyDataDirectory = getAppUserDataDirectory "vty"
156+ , mouseMode = mouseMode c1
246−
157+ , bracketedPasteMode = bracketedPasteMode c1
247−vtyConfigPath :: IO FilePath
158+ , debugLog = debugLog c1 <|> debugLog c0
248−vtyConfigPath = do
159+ , inputMap = inputMap c0 <> inputMap c1
249− dir <- vtyDataDirectory
160+ , inputFd = inputFd c1 <|> inputFd c0
250− return $ dir </> "config"
161+ , outputFd = outputFd c1 <|> outputFd c0
251−
162+ , termName = termName c1 <|> termName c0
252−vtyConfigFileEnvName :: String
163+ }
253−vtyConfigFileEnvName = "VTY_CONFIG_FILE"
164+
254−
255−-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
165+-- | Load a configuration from @'getAppUserDataDirectory'/config@ and
166+-- @$VTY_CONFIG_FILE@.
256userConfig :: IO Config
167userConfig :: IO Config
257userConfig = do
168userConfig = do
258− configFile <- vtyConfigPath >>= parseConfigFile
169+ configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
259− overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
170+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
260− lookupEnv vtyConfigFileEnvName
261 let base = configFile <> overrideConfig
171 let base = configFile <> overrideConfig
262 mappend base <$> overrideEnvConfig
172 mappend base <$> overrideEnvConfig
263
173
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
174overrideEnvConfig :: IO Config
283overrideEnvConfig = do
175overrideEnvConfig = do
284− d <- lookupEnv "VTY_DEBUG_LOG"
176+ d <- getEnv "VTY_DEBUG_LOG"
285 return $ defaultConfig { debugLog = d }
177 return $ defaultConfig { debugLog = d }
286
178
287-- | Configures VTY using defaults suitable for terminals. This function
179-- | Configures VTY using defaults suitable for terminals. This function
288-- can raise 'VtyConfigurationError'.
180-- can raise 'VtyConfigurationError'.
289standardIOConfig :: IO Config
181standardIOConfig :: IO Config
290standardIOConfig = do
182standardIOConfig = do
291− mb <- lookupEnv termVariable
183+ mb <- getEnv "TERM"
292 case mb of
184 case mb of
293 Nothing -> throwIO VtyMissingTermEnvVar
185 Nothing -> throwIO VtyMissingTermEnvVar
294− Just t -> do
186+ Just t ->
295− mcolorMode <- detectColorMode t
296 return defaultConfig
187 return defaultConfig
297 { vmin = Just 1
188 { vmin = Just 1
298 , mouseMode = Just False
189 , mouseMode = Just False
@@ -301,7 +192,6 @@ standardIOConfig = do
301 , inputFd = Just stdInput
192 , inputFd = Just stdInput
302 , outputFd = Just stdOutput
193 , outputFd = Just stdOutput
303 , termName = Just t
194 , termName = Just t
304− , colorMode = Just mcolorMode
305 }
195 }
306
196
307parseConfigFile :: FilePath -> IO Config
197parseConfigFile :: FilePath -> IO Config
@@ -353,20 +243,13 @@ debugLogDecl = do
353 path <- P.stringLiteral configLexer
243 path <- P.stringLiteral configLexer
354 return defaultConfig { debugLog = Just path }
244 return defaultConfig { debugLog = Just path }
355
245
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−
363ignoreLine :: Parser ()
246ignoreLine :: Parser ()
364ignoreLine = void $ manyTill anyChar newline
247ignoreLine = void $ manyTill anyChar newline
365
248
366parseConfig :: Parser Config
249parseConfig :: Parser Config
367parseConfig = liftM mconcat $ many $ do
250parseConfig = liftM mconcat $ many $ do
368 P.whiteSpace configLexer
251 P.whiteSpace configLexer
369− let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]
252+ let directives = [try mapDecl, try debugLogDecl]
370 choice directives <|> (ignoreLine >> return defaultConfig)
253 choice directives <|> (ignoreLine >> return defaultConfig)
371
254
372class Parse a where parseValue :: Parser a
255class Parse a where parseValue :: Parser a
@@ -412,77 +295,3 @@ instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
412 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
295 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
413
296
414instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"
297instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"
415−
416−foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar
417−
418−-- | Get the "erase" character for the terminal attached to the
419−-- specified file descriptor. This is the character configured by 'stty
420−-- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'.
421−-- Otherwise it will return the character that has been configured to
422−-- indicate the canonical mode ERASE behavior. That character can then
423−-- be added to the table of strings that we interpret to mean Backspace.
424−--
425−-- For more details, see:
426−--
427−-- * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html
428−-- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty
429−-- * https://github.com/matterhorn-chat/matterhorn/issues/565
430−getTtyEraseChar :: Fd -> IO (Maybe Char)
431−getTtyEraseChar fd = do
432− c <- cGetTtyErase fd
433− if c /= 0
434− then return $ Just $ toEnum $ fromEnum c
435− else return Nothing
436−
437−data ConfigUpdateResult =
438− ConfigurationCreated
439− | ConfigurationModified
440− | ConfigurationConflict String
441− | ConfigurationRedundant
442− deriving (Eq, Show)
443−
444−-- | Add a @widthMap@ directive to the Vty configuration file at the
445−-- specified path.
446−--
447−-- If the configuration path refers to a configuration that already
448−-- contains the directive for the specified map and terminal type, the
449−-- configuration file will not be modified. If the file does not contain
450−-- the directive, it will be appended to the file.
451−--
452−-- If the configuration path does not exist, a new configuration file
453−-- will be created and any directories in the path will also be created.
454−--
455−-- This returns @True@ if the configuration was created or modified and
456−-- @False@ otherwise. This does not handle exceptions raised by file or
457−-- directory permissions issues.
458−addConfigWidthMap :: FilePath
459− -- ^ The configuration file path of the configuration
460− -- to modify or create.
461− -> String
462− -- ^ The @TERM@ value for the @widthMap@ directive.
463− -> FilePath
464− -- ^ The width table file path for the directive.
465− -> IO ConfigUpdateResult
466−addConfigWidthMap configPath term tablePath = do
467− configEx <- doesFileExist configPath
468− if configEx
469− then updateConfig
470− else createConfig >> return ConfigurationCreated
471−
472− where
473− directive = "widthMap " <> show term <> " " <> show tablePath <> "\n"
474−
475− createConfig = do
476− let dir = takeDirectory configPath
477− createDirectoryIfMissing True dir
478− writeFile configPath directive
479−
480− updateConfig = do
481− config <- parseConfigFile configPath
482− if (term, tablePath) `elem` termWidthMaps config
483− then return ConfigurationRedundant
484− else case lookup term (termWidthMaps config) of
485− Just other -> return $ ConfigurationConflict other
486− Nothing -> do
487− appendFile configPath directive
488− return ConfigurationModified
src/Graphics/Vty/Debug.hs+6−6
@@ -12,16 +12,16 @@ import Graphics.Vty.Span
12
12
13import qualified Data.Vector as Vector
13import qualified Data.Vector as Vector
14
14
15−rowOpsAffectedColumns :: DisplayOps -> [Int]
15+rowOpsEffectedColumns :: DisplayOps -> [Int]
16−rowOpsAffectedColumns ops
16+rowOpsEffectedColumns ops
17− = Vector.toList $ Vector.map spanOpsAffectedColumns ops
17+ = Vector.toList $ Vector.map spanOpsEffectedColumns ops
18
18
19allSpansHaveWidth :: DisplayOps -> Int -> Bool
19allSpansHaveWidth :: DisplayOps -> Int -> Bool
20allSpansHaveWidth ops expected
20allSpansHaveWidth ops expected
21− = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops
21+ = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops
22
22
23−spanOpsAffectedRows :: DisplayOps -> Int
23+spanOpsEffectedRows :: DisplayOps -> Int
24−spanOpsAffectedRows ops
24+spanOpsEffectedRows ops
25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
26
26
27type SpanConstructLog = [SpanConstructEvent]
27type SpanConstructLog = [SpanConstructEvent]
src/Graphics/Vty/DisplayAttributes.hs+4−47
@@ -1,18 +1,11 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE CPP #-}
4
3
5module Graphics.Vty.DisplayAttributes where
4module Graphics.Vty.DisplayAttributes where
6
5
7import Graphics.Vty.Attributes
6import Graphics.Vty.Attributes
8
7
9import Data.Bits ((.&.))
8import Data.Bits ((.&.))
10−import Data.ByteString (ByteString)
11−#if !(MIN_VERSION_base(4,11,0))
12−import Data.Semigroup (Semigroup(..))
13−#endif
14−import Data.Text (Text)
15−import Data.Text.Encoding (encodeUtf8)
16
9
17-- | Given the previously applied display attributes as a FixedAttr and
10-- | Given the previously applied display attributes as a FixedAttr and
18-- the current display attributes as an Attr produces a FixedAttr that
11-- the current display attributes as an Attr produces a FixedAttr that
@@ -24,7 +17,6 @@ fixDisplayAttr fattr attr
24 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
17 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
25 (fixColor (fixedForeColor fattr) (attrForeColor attr))
18 (fixColor (fixedForeColor fattr) (attrForeColor attr))
26 (fixColor (fixedBackColor fattr) (attrBackColor attr))
19 (fixColor (fixedBackColor fattr) (attrBackColor attr))
27− (fixURL (fixedURL fattr) (attrURL attr))
28 where
20 where
29 fixStyle _s Default = defaultStyleMask
21 fixStyle _s Default = defaultStyleMask
30 fixStyle s KeepCurrent = s
22 fixStyle s KeepCurrent = s
@@ -32,9 +24,6 @@ fixDisplayAttr fattr attr
32 fixColor _c Default = Nothing
24 fixColor _c Default = Nothing
33 fixColor c KeepCurrent = c
25 fixColor c KeepCurrent = c
34 fixColor _c (SetTo c) = Just c
26 fixColor _c (SetTo c) = Just c
35− fixURL c KeepCurrent = c
36− fixURL _c (SetTo n) = Just n
37− fixURL _c Default = Nothing
38
27
39-- | difference between two display attributes. Used in the calculation
28-- | difference between two display attributes. Used in the calculation
40-- of the operations required to go from one display attribute to the
29-- of the operations required to go from one display attribute to the
@@ -47,23 +36,16 @@ data DisplayAttrDiff = DisplayAttrDiff
47 { styleDiffs :: [StyleStateChange]
36 { styleDiffs :: [StyleStateChange]
48 , foreColorDiff :: DisplayColorDiff
37 , foreColorDiff :: DisplayColorDiff
49 , backColorDiff :: DisplayColorDiff
38 , backColorDiff :: DisplayColorDiff
50− , urlDiff :: URLDiff
51 }
39 }
52 deriving (Show)
40 deriving (Show)
53
41
54−instance Semigroup DisplayAttrDiff where
42+instance Monoid DisplayAttrDiff where
43+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange
55− d0 <> d1 =
44+ mappend d0 d1 =
56 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
45 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
57 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
46 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
58 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
47 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
59− ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
60− in DisplayAttrDiff ds fcd bcd ud
48+ 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
49
68-- | Used in the computation of a final style attribute change.
50-- | Used in the computation of a final style attribute change.
69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
51simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
@@ -76,12 +58,6 @@ simplifyColorDiffs _cd ColorToDefault = ColorToDefault
76simplifyColorDiffs cd NoColorChange = cd
58simplifyColorDiffs cd NoColorChange = cd
77simplifyColorDiffs _cd (SetColor !c) = SetColor c
59simplifyColorDiffs _cd (SetColor !c) = SetColor c
78
60
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.
61-- | Difference between two display color attribute changes.
86data DisplayColorDiff
62data DisplayColorDiff
87 = ColorToDefault
63 = ColorToDefault
@@ -94,10 +70,6 @@ data DisplayColorDiff
94data StyleStateChange
70data StyleStateChange
95 = ApplyStandout
71 = ApplyStandout
96 | RemoveStandout
72 | RemoveStandout
97− | ApplyItalic
98− | RemoveItalic
99− | ApplyStrikethrough
100− | RemoveStrikethrough
101 | ApplyUnderline
73 | ApplyUnderline
102 | RemoveUnderline
74 | RemoveUnderline
103 | ApplyReverseVideo
75 | ApplyReverseVideo
@@ -110,13 +82,6 @@ data StyleStateChange
110 | RemoveBold
82 | RemoveBold
111 deriving (Show, Eq)
83 deriving (Show, Eq)
112
84
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
85-- | Determines the diff between two display&color attributes. This diff
121-- determines the operations that actually get output to the terminal.
86-- determines the operations that actually get output to the terminal.
122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
87displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
@@ -124,14 +89,8 @@ displayAttrDiffs attr attr' = DisplayAttrDiff
124 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
89 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
125 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
90 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
126 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
91 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
127− , urlDiff = diffURL (fixedURL attr) (fixedURL attr')
128 }
92 }
129
93
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
94diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
136diffColor Nothing (Just c') = SetColor c'
95diffColor Nothing (Just c') = SetColor c'
137diffColor (Just c) (Just c')
96diffColor (Just c) (Just c')
@@ -145,8 +104,6 @@ diffStyles prev cur
145 = mconcat
104 = mconcat
146 [ styleDiff standout ApplyStandout RemoveStandout
105 [ styleDiff standout ApplyStandout RemoveStandout
147 , styleDiff underline ApplyUnderline RemoveUnderline
106 , styleDiff underline ApplyUnderline RemoveUnderline
148− , styleDiff italic ApplyItalic RemoveItalic
149− , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
107 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
151 , styleDiff blink ApplyBlink RemoveBlink
108 , styleDiff blink ApplyBlink RemoveBlink
152 , styleDiff dim ApplyDim RemoveDim
109 , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Image.hs+8−17
@@ -1,4 +1,5 @@
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-- | A Vty program makes 'Picture's from 'Image's. This module provides
@@ -45,12 +46,8 @@ module Graphics.Vty.Image
45 -- * Character width functions
46 -- * Character width functions
46 , safeWcwidth
47 , safeWcwidth
47 , safeWcswidth
48 , safeWcswidth
48− , safeWctwidth
49− , safeWctlwidth
50 , wcwidth
49 , wcwidth
51 , wcswidth
50 , wcswidth
52− , wctwidth
53− , wctlwidth
54 -- * Display Regions
51 -- * Display Regions
55 , DisplayText
52 , DisplayText
56 , DisplayRegion
53 , DisplayRegion
@@ -116,18 +113,14 @@ horizCat = foldr horizJoin EmptyImage
116vertCat :: [Image] -> Image
113vertCat :: [Image] -> Image
117vertCat = foldr vertJoin EmptyImage
114vertCat = foldr vertJoin EmptyImage
118
115
119−-- | Make an 'Image' from a lazy text value. The text value should be
116+-- | Make an 'Image' from a lazy text value.
120−-- sanitized of escape sequences (ASCII 27) and carriage returns;
121−-- otherwise layout and attribute problems may result.
122text :: Attr -> TL.Text -> Image
117text :: Attr -> TL.Text -> Image
123−text a txt = let displayWidth = safeWctlwidth txt
118+text a txt = let displayWidth = safeWcswidth (TL.unpack txt)
124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
119 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
125
120
126−-- | Make an 'Image' from a text value. The text value should be
121+-- | Make an 'Image' from a 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
122text' :: Attr -> T.Text -> Image
130−text' a txt = let displayWidth = safeWctwidth txt
123+text' a txt = let displayWidth = safeWcswidth (T.unpack txt)
131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
124 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
132
125
133-- | Make an image from a single character. This is a standard Haskell
126-- | Make an image from a single character. This is a standard Haskell
@@ -137,11 +130,9 @@ char a c =
137 let displayWidth = safeWcwidth c
130 let displayWidth = safeWcwidth c
138 in HorizText a (TL.singleton c) displayWidth 1
131 in HorizText a (TL.singleton c) displayWidth 1
139
132
140−-- | Make an image from a string of characters laid out on a single
133+-- | Make an image from a string of characters layed out on a single
141-- row with the same display attribute. The string is assumed to be a
134-- row with the same display attribute. The string is assumed to be a
142−-- sequence of ISO-10646 characters. The input string should be
135+-- sequence of ISO-10646 characters.
143−-- sanitized of escape sequences (ASCII 27) and carriage returns;
144−-- otherwise layout and attribute problems may result.
145--
136--
146-- Note: depending on how the Haskell compiler represents string
137-- Note: depending on how the Haskell compiler represents string
147-- literals, a string literal in a UTF-8 encoded source file, for
138-- literals, a string literal in a UTF-8 encoded source file, for
@@ -175,7 +166,7 @@ utf8String a bytes = utf8Bytestring a (BL.pack bytes)
175utf8Bytestring :: Attr -> BL.ByteString -> Image
166utf8Bytestring :: Attr -> BL.ByteString -> Image
176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
167utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
177
168
178−-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
169+-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
179utf8Bytestring' :: Attr -> B.ByteString -> Image
170utf8Bytestring' :: Attr -> B.ByteString -> Image
180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
171utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
181
172
src/Graphics/Vty/Image/Internal.hs+32−16
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE NamedFieldPuns #-}
1{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
4{-# OPTIONS_HADDOCK hide #-}
3{-# OPTIONS_HADDOCK hide #-}
@@ -12,9 +11,6 @@ import GHC.Generics
12
11
13import Control.DeepSeq
12import Control.DeepSeq
14
13
15−#if !(MIN_VERSION_base(4,11,0))
16−import Data.Semigroup (Semigroup(..))
17−#endif
18import qualified Data.Text.Lazy as TL
14import qualified Data.Text.Lazy as TL
19
15
20-- | A display text is a Data.Text.Lazy
16-- | A display text is a Data.Text.Lazy
@@ -142,11 +138,37 @@ data Image =
142 --
138 --
143 -- Any image of zero size equals the empty image.
139 -- Any image of zero size equals the empty image.
144 | EmptyImage
140 | EmptyImage
145− deriving (Eq, Generic, Show, Read)
141+ deriving (Eq, Generic)
142+
143+instance Show Image where
144+ show ( HorizText { attr, displayText, outputWidth, charWidth } )
145+ = "HorizText " ++ show displayText
146+ ++ "@(" ++ show attr ++ ","
147+ ++ show outputWidth ++ ","
148+ ++ show charWidth ++ ")"
149+ show ( BGFill { outputWidth, outputHeight } )
150+ = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"
151+ show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )
152+ = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
153+ show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )
154+ = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
155+ show ( CropRight { croppedImage, outputWidth, outputHeight } )
156+ = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
157+ ++ " (" ++ show croppedImage ++ ")"
158+ show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )
159+ = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
160+ ++ " (" ++ show croppedImage ++ ")"
161+ show ( CropBottom { croppedImage, outputWidth, outputHeight } )
162+ = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
163+ ++ " (" ++ show croppedImage ++ ")"
164+ show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )
165+ = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
166+ ++ " (" ++ show croppedImage ++ ")"
167+ show ( EmptyImage ) = "EmptyImage"
146
168
147-- | pretty print just the structure of an image.
169-- | pretty print just the structure of an image.
148ppImageStructure :: Image -> String
170ppImageStructure :: Image -> String
149−ppImageStructure = go 0
171+ppImageStructure inImg = go 0 inImg
150 where
172 where
151 go indent img = tab indent ++ pp indent img
173 go indent img = tab indent ++ pp indent img
152 tab indent = concat $ replicate indent " "
174 tab indent = concat $ replicate indent " "
@@ -210,16 +232,10 @@ imageHeight CropBottom { outputHeight = h } = h
210imageHeight CropTop { outputHeight = h } = h
232imageHeight CropTop { outputHeight = h } = h
211imageHeight EmptyImage = 0
233imageHeight EmptyImage = 0
212
234
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 '<->'.
235+-- | Append in the Monoid instance is equivalent to <->.
218instance Monoid Image where
236instance Monoid Image where
219 mempty = EmptyImage
237 mempty = EmptyImage
220−#if !(MIN_VERSION_base(4,11,0))
221− mappend = (<>)
238+ mappend = vertJoin
222−#endif
223
239
224-- | combines two images side by side
240-- | combines two images side by side
225--
241--
@@ -228,7 +244,7 @@ instance Monoid Image where
228--
244--
229-- The result image will have a width equal to the sum of the two images
245-- 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
246-- 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
247+-- images. The area not defined in one image due to a height missmatch
232-- will be filled with the background pattern.
248-- will be filled with the background pattern.
233horizJoin :: Image -> Image -> Image
249horizJoin :: Image -> Image -> Image
234horizJoin EmptyImage i = i
250horizJoin EmptyImage i = i
@@ -259,7 +275,7 @@ horizJoin _ _ = error "horizJoin applied to undefined values."
259--
275--
260-- The result image will have a height equal to the sum of the heights
276-- 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
277-- 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
278+-- images. The area not defined in one image due to a width missmatch
263-- will be filled with the background pattern.
279-- will be filled with the background pattern.
264vertJoin :: Image -> Image -> Image
280vertJoin :: Image -> Image -> Image
265vertJoin EmptyImage i = i
281vertJoin EmptyImage i = i
src/Graphics/Vty/Inline.hs+17−28
@@ -1,3 +1,5 @@
1+{-# LANGUAGE BangPatterns #-}
2+
1-- | The inline module provides a limited interface to changing the
3-- | The inline module provides a limited interface to changing the
2-- style of terminal output. The intention is for this interface to be
4-- style of terminal output. The intention is for this interface to be
3-- used inline with other output systems.
5-- used inline with other output systems.
@@ -46,33 +48,22 @@ import Data.IORef
46
48
47import System.IO
49import System.IO
48
50
49−type InlineM v = State InlineState v
51+type InlineM v = State Attr v
50−
51−data InlineState =
52− InlineState { inlineAttr :: Attr
53− , inlineUrlsEnabled :: Bool
54− }
55
52
56-- | Set the background color to the provided 'Color'.
53-- | Set the background color to the provided 'Color'.
57backColor :: Color -> InlineM ()
54backColor :: Color -> InlineM ()
58−backColor c = modify $ \s ->
55+backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )
59− s { inlineAttr = inlineAttr s `withBackColor` c
60− }
61
56
62-- | Set the foreground color to the provided 'Color'.
57-- | Set the foreground color to the provided 'Color'.
63foreColor :: Color -> InlineM ()
58foreColor :: Color -> InlineM ()
64−foreColor c = modify $ \s ->
59+foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )
65− s { inlineAttr = inlineAttr s `withForeColor` c
66− }
67
60
68-- | Attempt to change the 'Style' of the following text..
61-- | Attempt to change the 'Style' of the following text..
69--
62--
70-- If the terminal does not support the style change then no error is
63-- If the terminal does not support the style change then no error is
71-- produced. The style can still be removed.
64-- produced. The style can still be removed.
72applyStyle :: Style -> InlineM ()
65applyStyle :: Style -> InlineM ()
73−applyStyle st = modify $ \s ->
66+applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
74− s { inlineAttr = inlineAttr s `withStyle` st
75− }
76
67
77-- | Attempt to remove the specified 'Style' from the display of the
68-- | Attempt to remove the specified 'Style' from the display of the
78-- following text.
69-- following text.
@@ -80,18 +71,16 @@ applyStyle st = modify $ \s ->
80-- This will fail if 'applyStyle' for the given style has not been
71-- This will fail if 'applyStyle' for the given style has not been
81-- previously called.
72-- previously called.
82removeStyle :: Style -> InlineM ()
73removeStyle :: Style -> InlineM ()
83−removeStyle sMask = modify $ \s ->
74+removeStyle sMask = modify $ \attr ->
84− s { inlineAttr =
85− let style' = case attrStyle (inlineAttr s) of
75+ let style' = case attrStyle attr of
86− Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
76+ Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
87− KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
77+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
88− SetTo st -> st .&. complement sMask
78+ SetTo s -> s .&. complement sMask
89− in (inlineAttr s) { attrStyle = SetTo style' }
79+ in attr { attrStyle = SetTo style' }
90− }
91
80
92-- | Reset the display attributes.
81-- | Reset the display attributes.
93defaultAll :: InlineM ()
82defaultAll :: InlineM ()
94−defaultAll = modify $ \s -> s { inlineAttr = defAttr }
83+defaultAll = put defAttr
95
84
96-- | Apply the provided display attribute changes to the given terminal
85-- | Apply the provided display attribute changes to the given terminal
97-- output device.
86-- output device.
@@ -104,14 +93,14 @@ putAttrChange out c = liftIO $ do
104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
93 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
105 fattr <- case mfattr of
94 fattr <- case mfattr of
106 Nothing -> do
95 Nothing -> do
107− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
96+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
108− return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
97+ return $ FixedAttr defaultStyleMask Nothing Nothing
109 Just v -> return v
98 Just v -> return v
110− let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
99+ let attr = execState c currentAttr
111 attr' = limitAttrForDisplay out attr
100 attr' = limitAttrForDisplay out attr
112 fattr' = fixDisplayAttr fattr attr'
101 fattr' = fixDisplayAttr fattr attr'
113 diffs = displayAttrDiffs fattr fattr'
102 diffs = displayAttrDiffs fattr fattr'
114− outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
103+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
104 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
116 inlineHack dc
105 inlineHack dc
117
106
src/Graphics/Vty/Input.hs+23−14
@@ -1,4 +1,4 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
1+{-# LANGUAGE RecordWildCards #-}
2
2
3-- | This module provides the input layer for Vty, including methods
3-- | This module provides the input layer for Vty, including methods
4-- for initializing an 'Input' structure and reading 'Event's from the
4-- for initializing an 'Input' structure and reading 'Event's from the
@@ -77,7 +77,7 @@
77-- The input encoding determines how UTF-8 encoded characters are
77-- The input encoding determines how UTF-8 encoded characters are
78-- recognized.
78-- recognized.
79--
79--
80−-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
80+-- * 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
81-- a superset of ASCII. UTF-8 does not overlap escaped control key
82-- sequences. However, the escape key must be differentiated from
82-- sequences. However, the escape key must be differentiated from
83-- escaped control key sequences by the timing of the input bytes.
83-- escaped control key sequences by the timing of the input bytes.
@@ -95,7 +95,7 @@
95--
95--
96-- == Terminal Input is Broken
96-- == Terminal Input is Broken
97--
97--
98−-- Clearly terminal input has fundamental issues. There is no easy way
98+-- Clearly terminal input has fundemental issues. There is no easy way
99-- to reliably resolve these issues.
99-- to reliably resolve these issues.
100--
100--
101-- One resolution would be to ditch standard terminal interfaces
101-- One resolution would be to ditch standard terminal interfaces
@@ -132,9 +132,7 @@ import Lens.Micro
132import qualified System.Console.Terminfo as Terminfo
132import qualified System.Console.Terminfo as Terminfo
133import System.Posix.Signals.Exts
133import System.Posix.Signals.Exts
134
134
135−#if !MIN_VERSION_base(4,11,0)
136import Data.Monoid ((<>))
135import Data.Monoid ((<>))
137−#endif
138
136
139-- | Set up the terminal with file descriptor `inputFd` for input.
137-- | Set up the terminal with file descriptor `inputFd` for input.
140-- Returns an 'Input'.
138-- Returns an 'Input'.
@@ -143,8 +141,22 @@ import Data.Monoid ((<>))
143-- bytes comes from 'classifyMapForTerm' which is then overridden by
141-- bytes comes from 'classifyMapForTerm' which is then overridden by
144-- the the applicable entries from the configuration's 'inputMap'.
142-- the the applicable entries from the configuration's 'inputMap'.
145--
143--
146−-- The terminal device's mode flags are configured by the
144+-- The terminal device is configured with the attributes:
147−-- 'attributeControl' function.
145+--
146+-- * IXON disabled: disables software flow control on outgoing data.
147+-- This stops the process from being suspended if the output terminal
148+-- cannot keep up.
149+--
150+-- * Raw mode is used for input.
151+--
152+-- * ISIG disabled (enables keyboard combinations that result in
153+-- signals)
154+--
155+-- * ECHO disabled (input is not echoed to the output)
156+--
157+-- * ICANON disabled (canonical mode (line mode) input is not used)
158+--
159+-- * IEXTEN disabled (extended functions are disabled)
148inputForConfig :: Config -> IO Input
160inputForConfig :: Config -> IO Input
149inputForConfig config@Config{ termName = Just termName
161inputForConfig config@Config{ termName = Just termName
150 , inputFd = Just termFd
162 , inputFd = Just termFd
@@ -154,23 +166,20 @@ inputForConfig config@Config{ termName = Just termName
154 terminal <- Terminfo.setupTerm termName
166 terminal <- Terminfo.setupTerm termName
155 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
167 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
168 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
157− (setAttrs, unsetAttrs) <- attributeControl termFd
169+ (setAttrs,unsetAttrs) <- attributeControl termFd
158 setAttrs
170 setAttrs
159 input <- initInput config activeInputMap
171 input <- initInput config activeInputMap
160 let pokeIO = Catch $ do
172 let pokeIO = Catch $ do
173+ let e = error "vty internal failure: this value should not propagate to users"
161 setAttrs
174 setAttrs
162− atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
175+ atomically $ writeTChan (input^.eventChannel) (EvResize e e)
163 _ <- installHandler windowChange pokeIO Nothing
176 _ <- installHandler windowChange pokeIO Nothing
164 _ <- installHandler continueProcess pokeIO Nothing
177 _ <- installHandler continueProcess pokeIO Nothing
165−
166− let restore = unsetAttrs
167−
168 return $ input
178 return $ input
169 { shutdownInput = do
179 { shutdownInput = do
170 shutdownInput input
180 shutdownInput input
171 _ <- installHandler windowChange Ignore Nothing
181 _ <- installHandler windowChange Ignore Nothing
172 _ <- installHandler continueProcess Ignore Nothing
182 _ <- installHandler continueProcess Ignore Nothing
173− restore
183+ unsetAttrs
174− , restoreInputState = restoreInputState input >> restore
175 }
184 }
176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
185inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Classify.hs+29−53
@@ -1,11 +1,10 @@
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.
5module Graphics.Vty.Input.Classify
5module Graphics.Vty.Input.Classify
6 ( classify
6 ( classify
7 , KClass(..)
7 , KClass(..)
8− , ClassifierState(..)
9 )
8 )
10where
9where
11
10
@@ -17,39 +16,25 @@ import Graphics.Vty.Input.Classify.Types
17
16
18import Codec.Binary.UTF8.Generic (decode)
17import Codec.Binary.UTF8.Generic (decode)
19
18
20−import Control.Arrow (first)
19+import Data.List (inits)
21import qualified Data.Map as M( fromList, lookup )
20import qualified Data.Map as M( fromList, lookup )
22import Data.Maybe ( mapMaybe )
21import Data.Maybe ( mapMaybe )
23import qualified Data.Set as S( fromList, member )
22import qualified Data.Set as S( fromList, member )
24
23
24+import Data.Char
25import Data.Word
25import Data.Word
26
26
27−import qualified Data.ByteString as BS
28−import qualified Data.ByteString.Char8 as BS8
29−import Data.ByteString.Char8 (ByteString)
30−
31−-- | Whether the classifier is currently processing a chunked format.
32−-- Currently, only bracketed pastes use this.
33−data ClassifierState
34− = ClassifierStart
35− -- ^ Not processing a chunked format.
36− | ClassifierInChunk ByteString [ByteString]
37− -- ^ Currently processing a chunked format. The initial chunk is in the
38− -- first argument and a reversed remainder of the chunks is collected in
39− -- the second argument. At the end of the processing, the chunks are
40− -- reversed and concatenated with the final chunk.
41−
42−compile :: ClassifyMap -> ByteString -> KClass
27+compile :: ClassifyMap -> [Char] -> KClass
43compile table = cl' where
28compile table = cl' where
44 -- take all prefixes and create a set of these
29 -- take all prefixes and create a set of these
45− prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
30+ prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
46 maxValidInputLength = maximum (map (length . fst) table)
31 maxValidInputLength = maximum (map (length . fst) table)
47− eventForInput = M.fromList $ map (first BS8.pack) table
32+ eventForInput = M.fromList table
48− cl' inputBlock | BS8.null inputBlock = Prefix
33+ cl' [] = Prefix
49 cl' inputBlock = case M.lookup inputBlock eventForInput of
34 cl' inputBlock = case M.lookup inputBlock eventForInput of
50 -- if the inputBlock is exactly what is expected for an
35 -- if the inputBlock is exactly what is expected for an
51 -- event then consume the whole block and return the event
36 -- event then consume the whole block and return the event
52− Just e -> Valid e BS8.empty
37+ Just e -> Valid e []
53 Nothing -> case S.member inputBlock prefixSet of
38 Nothing -> case S.member inputBlock prefixSet of
54 True -> Prefix
39 True -> Prefix
55 -- look up progressively smaller tails of the input
40 -- look up progressively smaller tails of the input
@@ -60,49 +45,40 @@ compile table = cl' where
60 -- H: There will always be one match. The prefixSet
45 -- H: There will always be one match. The prefixSet
61 -- contains, by definition, all prefixes of an event.
46 -- contains, by definition, all prefixes of an event.
62 False ->
47 False ->
63− let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
48+ let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
64 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
49 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
65− (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
50+ (s,e) : _ -> Valid e (drop (length s) inputBlock)
66 -- neither a prefix or a full event.
51 -- neither a prefix or a full event.
67 [] -> Invalid
52 [] -> Invalid
68
53
69−classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
54+classify :: ClassifyMap -> [Char] -> KClass
70−classify table = process
55+classify table =
71− where
72− standardClassifier = compile table
56+ let standardClassifier = compile table
73−
74− process ClassifierStart s =
75− case BS.uncons s of
57+ in \s -> case s of
76− _ | bracketedPasteStarted s ->
58+ _ | 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
59 if bracketedPasteFinished s
87− then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
60+ then parseBracketedPaste s
88− else Chunk
61+ else Prefix
89− process ClassifierInChunk{} _ = Invalid
62+ _ | isMouseEvent s -> classifyMouseEvent s
63+ _ | isFocusEvent s -> classifyFocusEvent s
64+ c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
65+ _ -> standardClassifier s
90
66
91−classifyUtf8 :: Word8 -> ByteString -> KClass
67+classifyUtf8 :: Char -> [Char] -> KClass
92classifyUtf8 c cs =
68classifyUtf8 c cs =
93− let n = utf8Length c
69+ let n = utf8Length (ord c)
94− (codepoint,rest) = BS8.splitAt (n - 1) cs
70+ (codepoint,rest) = splitAt n (c:cs)
95
71
96 codepoint8 :: [Word8]
72 codepoint8 :: [Word8]
97− codepoint8 = c:BS.unpack codepoint
73+ codepoint8 = map (fromIntegral . ord) codepoint
98
74
99 in case decode codepoint8 of
75 in case decode codepoint8 of
100− _ | n < BS.length codepoint + 1 -> Prefix
76+ _ | n < length codepoint -> Prefix
101− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
77+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
102 -- something bad happened; just ignore and continue.
78 -- something bad happened; just ignore and continue.
103− Nothing -> Invalid
79+ Nothing -> Invalid
104
80
105−utf8Length :: Word8 -> Int
81+utf8Length :: (Num t, Ord a, Num a) => a -> t
106utf8Length c
82utf8Length c
107 | c < 0x80 = 1
83 | c < 0x80 = 1
108 | c < 0xE0 = 2
84 | 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+6−24
@@ -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.
37data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
31data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
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
@@ -68,16 +62,4 @@ data Event
68 -- ^ The terminal running the application gained input focus.
62 -- ^ The terminal running the application gained input focus.
69 deriving (Eq,Show,Read,Ord,Generic)
63 deriving (Eq,Show,Read,Ord,Generic)
70
64
71−instance NFData Event
72−
73type ClassifyMap = [(String,Event)]
65type ClassifyMap = [(String,Event)]
74−
75−-- | The type of internal events that drive the internal Vty event
76−-- dispatching to the application.
77−data InternalEvent =
78− ResumeAfterSignal
79− -- ^ Vty resumed operation after the process was interrupted with a
80− -- signal. In practice this translates into a screen redraw in the
81− -- input event loop.
82− | InputEvent Event
83− -- ^ An input event was received.
src/Graphics/Vty/Input/Focus.hs+13−15
@@ -11,32 +11,30 @@ import Graphics.Vty.Input.Classify.Types
11import Graphics.Vty.Input.Classify.Parse
11import Graphics.Vty.Input.Classify.Parse
12
12
13import Control.Monad.State
13import Control.Monad.State
14−
14+import Data.List (isPrefixOf)
15−import qualified Data.ByteString.Char8 as BS8
16−import Data.ByteString.Char8 (ByteString)
17
15
18-- | These sequences set xterm-based terminals to send focus event
16-- | These sequences set xterm-based terminals to send focus event
19-- sequences.
17-- sequences.
20−requestFocusEvents :: ByteString
18+requestFocusEvents :: String
21−requestFocusEvents = BS8.pack "\ESC[?1004h"
19+requestFocusEvents = "\ESC[?1004h"
22
20
23-- | These sequences disable focus events.
21-- | These sequences disable focus events.
24−disableFocusEvents :: ByteString
22+disableFocusEvents :: String
25−disableFocusEvents = BS8.pack "\ESC[?1004l"
23+disableFocusEvents = "\ESC[?1004l"
26
24
27-- | Does the specified string begin with a focus event?
25-- | Does the specified string begin with a focus event?
28−isFocusEvent :: ByteString -> Bool
26+isFocusEvent :: String -> Bool
29−isFocusEvent s = BS8.isPrefixOf focusIn s ||
27+isFocusEvent s = isPrefixOf focusIn s ||
30− BS8.isPrefixOf focusOut s
28+ isPrefixOf focusOut s
31
29
32−focusIn :: ByteString
30+focusIn :: String
33−focusIn = BS8.pack "\ESC[I"
31+focusIn = "\ESC[I"
34
32
35−focusOut :: ByteString
33+focusOut :: String
36−focusOut = BS8.pack "\ESC[O"
34+focusOut = "\ESC[O"
37
35
38-- | Attempt to classify an input string as a focus event.
36-- | Attempt to classify an input string as a focus event.
39−classifyFocusEvent :: ByteString -> KClass
37+classifyFocusEvent :: String -> KClass
40classifyFocusEvent s = runParser s $ do
38classifyFocusEvent s = runParser s $ do
41 when (not $ isFocusEvent s) failParse
39 when (not $ isFocusEvent s) failParse
42
40
src/Graphics/Vty/Input/Loop.hs+30−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,7 @@ 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)
28−import Lens.Micro hiding ((<>~))
27+import Lens.Micro
29import Lens.Micro.Mtl
28import Lens.Micro.Mtl
30import Lens.Micro.TH
29import Lens.Micro.TH
31import Control.Monad (when, mzero, forM_)
30import Control.Monad (when, mzero, forM_)
@@ -34,15 +33,12 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)
34import Control.Monad.State.Class (MonadState, modify)
33import Control.Monad.State.Class (MonadState, modify)
35import Control.Monad.Trans.Reader (ReaderT(..))
34import Control.Monad.Trans.Reader (ReaderT(..))
36
35
37−import qualified Data.ByteString.Char8 as BS8
36+import Data.Char
38−import qualified Data.ByteString as BS
39−import Data.ByteString.Char8 (ByteString)
40import Data.IORef
37import Data.IORef
41import Data.Word (Word8)
38import Data.Word (Word8)
42
39
43−import Foreign (allocaArray)
40+import Foreign ( allocaArray, peekArray, Ptr )
44import Foreign.C.Types (CInt(..))
41import Foreign.C.Types (CInt(..))
45−import Foreign.Ptr (Ptr, castPtr)
46
42
47import System.IO
43import System.IO
48import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
44import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
@@ -55,15 +51,10 @@ data Input = Input
55 { -- | Channel of events direct from input processing. Unlike
51 { -- | Channel of events direct from input processing. Unlike
56 -- 'nextEvent' this will not refresh the display if the next event
52 -- 'nextEvent' this will not refresh the display if the next event
57 -- is an 'EvResize'.
53 -- is an 'EvResize'.
58− _eventChannel :: TChan InternalEvent
54+ _eventChannel :: TChan Event
59− -- | Shuts down the input processing. As part of shutting down the
55+ -- | Shuts down the input processing. This should return the
60− -- input, this should also restore the input state.
56+ -- terminal input state to before he input initialized.
61 , shutdownInput :: IO ()
57 , 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.
58 -- | Changes to this value are reflected after the next event.
68 , _configRef :: IORef Config
59 , _configRef :: IORef Config
69 -- | input debug log
60 -- | input debug log
@@ -80,11 +71,10 @@ data InputBuffer = InputBuffer
80makeLenses ''InputBuffer
71makeLenses ''InputBuffer
81
72
82data InputState = InputState
73data InputState = InputState
83− { _unprocessedBytes :: ByteString
74+ { _unprocessedBytes :: String
84− , _classifierState :: ClassifierState
85 , _appliedConfig :: Config
75 , _appliedConfig :: Config
86 , _inputBuffer :: InputBuffer
76 , _inputBuffer :: InputBuffer
87− , _classifier :: ClassifierState -> ByteString -> KClass
77+ , _classifier :: String -> KClass
88 }
78 }
89
79
90makeLenses ''InputState
80makeLenses ''InputState
@@ -109,20 +99,20 @@ loopInputProcessor = do
109 dropInvalid
99 dropInvalid
110 loopInputProcessor
100 loopInputProcessor
111
101
112−addBytesToProcess :: ByteString -> InputM ()
102+addBytesToProcess :: String -> InputM ()
113addBytesToProcess block = unprocessedBytes <>= block
103addBytesToProcess block = unprocessedBytes <>= block
114
104
115emit :: Event -> InputM ()
105emit :: Event -> InputM ()
116emit event = do
106emit event = do
117 logMsg $ "parsed event: " ++ show event
107 logMsg $ "parsed event: " ++ show event
118− view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
108+ view eventChannel >>= liftIO . atomically . flip writeTChan event
119
109
120-- The timing requirements are assured by the VMIN and VTIME set for the
110-- The timing requirements are assured by the VMIN and VTIME set for the
121-- device.
111-- device.
122--
112--
123-- Precondition: Under the threaded runtime. Only current use is from a
113-- Precondition: Under the threaded runtime. Only current use is from a
124-- forkOS thread. That case satisfies precondition.
114-- forkOS thread. That case satisfies precondition.
125−readFromDevice :: InputM ByteString
115+readFromDevice :: InputM String
126readFromDevice = do
116readFromDevice = do
127 newConfig <- view configRef >>= liftIO . readIORef
117 newConfig <- view configRef >>= liftIO . readIORef
128 oldConfig <- use appliedConfig
118 oldConfig <- use appliedConfig
@@ -142,10 +132,9 @@ readFromDevice = do
142 threadWaitRead fd
132 threadWaitRead fd
143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
133 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
144 if bytesRead > 0
134 if bytesRead > 0
145− then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
135+ then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
146− else return BS.empty
136+ else return []
147− when (not $ BS.null stringRep) $
148− logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
137+ when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
149 return stringRep
138 return stringRep
150
139
151applyConfig :: Fd -> Config -> IO ()
140applyConfig :: Fd -> Config -> IO ()
@@ -156,86 +145,41 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat
156parseEvent :: InputM Event
145parseEvent :: InputM Event
157parseEvent = do
146parseEvent = do
158 c <- use classifier
147 c <- use classifier
159− s <- use classifierState
160 b <- use unprocessedBytes
148 b <- use unprocessedBytes
161− case c s b of
149+ case c b of
162 Valid e remaining -> do
150 Valid e remaining -> do
163 logMsg $ "valid parse: " ++ show e
151 logMsg $ "valid parse: " ++ show e
164 logMsg $ "remaining: " ++ show remaining
152 logMsg $ "remaining: " ++ show remaining
165− classifierState .= ClassifierStart
166 unprocessedBytes .= remaining
153 unprocessedBytes .= remaining
167 return e
154 return e
168− _ -> mzero
155+ _ -> mzero
169
156
170dropInvalid :: InputM ()
157dropInvalid :: InputM ()
171dropInvalid = do
158dropInvalid = do
172 c <- use classifier
159 c <- use classifier
173− s <- use classifierState
174 b <- use unprocessedBytes
160 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
161+ when (c b == Invalid) $ do
183− logMsg "dropping input bytes"
162+ logMsg "dropping input bytes"
184− classifierState .= ClassifierStart
185− unprocessedBytes .= BS8.empty
163+ unprocessedBytes .= []
186− _ -> return ()
187
164
188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
165runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
189runInputProcessorLoop classifyTable input = do
166runInputProcessorLoop classifyTable input = do
190 let bufferSize = 1024
167 let bufferSize = 1024
191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
168 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
192− s0 <- InputState BS8.empty ClassifierStart
193− <$> readIORef (_configRef input)
169+ s0 <- InputState [] <$> readIORef (_configRef input)
194− <*> pure (InputBuffer bufferPtr bufferSize)
170+ <*> pure (InputBuffer bufferPtr bufferSize)
195− <*> pure (classify classifyTable)
171+ <*> pure (classify classifyTable)
196 runReaderT (evalStateT loopInputProcessor s0) input
172 runReaderT (evalStateT loopInputProcessor s0) input
197
173
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 ())
174attributeControl :: Fd -> IO (IO (), IO ())
224attributeControl fd = do
175attributeControl fd = do
225 original <- getTerminalAttributes fd
176 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
177+ let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
232− , EnableEcho -- ECHO
233− , ProcessInput -- ICANON
234− , ExtendedFunctions -- IEXTEN
178+ , EnableEcho, ProcessInput, ExtendedFunctions
235− ]
179+ ]
236 let setAttrs = setTerminalAttributes fd vtyMode Immediately
180 let setAttrs = setTerminalAttributes fd vtyMode Immediately
237 unsetAttrs = setTerminalAttributes fd original Immediately
181 unsetAttrs = setTerminalAttributes fd original Immediately
238− return (setAttrs, unsetAttrs)
182+ return (setAttrs,unsetAttrs)
239
183
240logInitialInputState :: Input -> ClassifyMap -> IO()
184logInitialInputState :: Input -> ClassifyMap -> IO()
241logInitialInputState input classifyTable = case _inputDebug input of
185logInitialInputState input classifyTable = case _inputDebug input of
@@ -243,7 +187,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
243 Just h -> do
187 Just h -> do
244 Config{ vmin = Just theVmin
188 Config{ vmin = Just theVmin
245 , vtime = Just theVtime
189 , vtime = Just theVtime
246− , termName = Just theTerm } <- readIORef $ _configRef input
190+ , termName = Just theTerm, .. } <- readIORef $ _configRef input
247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
191 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
248 forM_ classifyTable $ \i -> case i of
192 forM_ classifyTable $ \i -> case i of
249 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
193 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
@@ -259,7 +203,6 @@ initInput config classifyTable = do
259 applyConfig fd config
203 applyConfig fd config
260 stopSync <- newEmptyMVar
204 stopSync <- newEmptyMVar
261 input <- Input <$> atomically newTChan
205 input <- Input <$> atomically newTChan
262− <*> pure (return ())
263 <*> pure (return ())
206 <*> pure (return ())
264 <*> newIORef config
207 <*> newIORef config
265 <*> maybe (return Nothing)
208 <*> maybe (return Nothing)
src/Graphics/Vty/Input/Mouse.hs+17−19
@@ -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"
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"
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
@@ -89,8 +87,8 @@ scrollDown = 65
89hasBitSet :: Int -> Int -> Bool
87hasBitSet :: Int -> Int -> Bool
90hasBitSet val bit = val .&. bit > 0
88hasBitSet val bit = val .&. bit > 0
91
89
92−-- | Attempt to classify an input string as a mouse event.
90+-- | Attempt to lassify an input string as a mouse event.
93−classifyMouseEvent :: ByteString -> KClass
91+classifyMouseEvent :: String -> KClass
94classifyMouseEvent s = runParser s $ do
92classifyMouseEvent s = runParser s $ do
95 when (not $ isMouseEvent s) failParse
93 when (not $ isMouseEvent s) failParse
96
94
@@ -102,7 +100,7 @@ classifyMouseEvent s = runParser s $ do
102 'M' -> classifyNormalMouseEvent
100 'M' -> classifyNormalMouseEvent
103 _ -> failParse
101 _ -> failParse
104
102
105−-- Given a modifier/button value, determine which button was indicated
103+-- Given a modifer/button value, determine which button was indicated
106getSGRButton :: Int -> Parser Button
104getSGRButton :: Int -> Parser Button
107getSGRButton mods =
105getSGRButton mods =
108 let buttonMap = [ (leftButton, BLeft)
106 let buttonMap = [ (leftButton, BLeft)
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+4−6
@@ -74,7 +74,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])
74ctrlChars :: ClassifyMap
74ctrlChars :: ClassifyMap
75ctrlChars =
75ctrlChars =
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
77− | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
77+ | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
79 , y /= 'h' -- CTRL-h should not hide BS
79 , y /= 'h' -- CTRL-h should not hide BS
80 ]
80 ]
@@ -86,12 +86,10 @@ ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
86-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
86-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
87specialSupportKeys :: ClassifyMap
87specialSupportKeys :: ClassifyMap
88specialSupportKeys =
88specialSupportKeys =
89− [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90− , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
91− -- special support for ESC
89+ [ -- special support for ESC
92− , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
90+ ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
93 -- Special support for backspace
91 -- Special support for backspace
94− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
92+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
95 -- Special support for Enter
93 -- Special support for Enter
96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
94 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
97 -- explicit support for tab
95 -- explicit support for tab
src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+1−1
@@ -59,7 +59,7 @@ navKeys3 =
59-- This encoding depends on the terminal.
59-- This encoding depends on the terminal.
60functionKeys1 :: ClassifyMap
60functionKeys1 :: ClassifyMap
61functionKeys1 =
61functionKeys1 =
62− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in
62+ 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] ]
63 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
64
64
65-- | encoding for meta plus char
65-- | encoding for meta plus char
src/Graphics/Vty/Output.hs+14−15
@@ -1,4 +1,5 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE NamedFieldPuns #-}
2-- | This module provides functions for accessing the current terminal
3-- | This module provides functions for accessing the current terminal
3-- or a specific terminal device.
4-- or a specific terminal device.
4--
5--
@@ -37,11 +38,10 @@ import Graphics.Vty.Output.TerminfoBased as TerminfoBased
37
38
38import Blaze.ByteString.Builder (writeToByteString)
39import Blaze.ByteString.Builder (writeToByteString)
39
40
40−import Data.List (isPrefixOf)
41+import Control.Monad.Trans
41
42
42−#if !MIN_VERSION_base(4,11,0)
43+import Data.List (isPrefixOf)
43import Data.Monoid ((<>))
44import Data.Monoid ((<>))
44−#endif
45
45
46-- | Returns an `Output` for the terminal specified in `Config`.
46-- | Returns an `Output` for the terminal specified in `Config`.
47--
47--
@@ -58,12 +58,11 @@ import Data.Monoid ((<>))
58-- * If TERM contains "xterm" or "screen", use XTermColor.
58-- * If TERM contains "xterm" or "screen", use XTermColor.
59-- * otherwise use the TerminfoBased driver.
59-- * otherwise use the TerminfoBased driver.
60outputForConfig :: Config -> IO Output
60outputForConfig :: Config -> IO Output
61−outputForConfig Config{ outputFd = Just fd, termName = Just termName
61+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do
62− , colorMode = Just colorMode, .. } = do
63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
62 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
64− then XTermColor.reserveTerminal termName fd colorMode
63+ then XTermColor.reserveTerminal termName fd
65 -- Not an xterm-like terminal. try for generic terminfo.
64 -- Not an xterm-like terminal. try for generic terminfo.
66− else TerminfoBased.reserveTerminal termName fd colorMode
65+ else TerminfoBased.reserveTerminal termName fd
67
66
68 case mouseMode of
67 case mouseMode of
69 Just s -> setMode t Mouse s
68 Just s -> setMode t Mouse s
@@ -78,30 +77,30 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
78
77
79-- | Sets the cursor position to the given output column and row.
78-- | Sets the cursor position to the given output column and row.
80--
79--
81−-- This is not necessarily the same as the character position with the
80+-- This is not necessarially the same as the character position with the
82-- same coordinates. Characters can be a variable number of columns in
81-- same coordinates. Characters can be a variable number of columns in
83-- width.
82-- width.
84--
83--
85-- Currently, the only way to set the cursor position to a given
84-- Currently, the only way to set the cursor position to a given
86-- character coordinate is to specify the coordinate in the Picture
85-- character coordinate is to specify the coordinate in the Picture
87-- instance provided to 'outputPicture' or 'refresh'.
86-- instance provided to 'outputPicture' or 'refresh'.
88−setCursorPos :: Output -> Int -> Int -> IO ()
87+setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()
89setCursorPos t x y = do
88setCursorPos t x y = do
90 bounds <- displayBounds t
89 bounds <- displayBounds t
91 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
90 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
92 dc <- displayContext t bounds
91 dc <- displayContext t bounds
93− outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
92+ liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
94
93
95-- | Hides the cursor.
94-- | Hides the cursor.
96−hideCursor :: Output -> IO ()
95+hideCursor :: MonadIO m => Output -> m ()
97hideCursor t = do
96hideCursor t = do
98 bounds <- displayBounds t
97 bounds <- displayBounds t
99 dc <- displayContext t bounds
98 dc <- displayContext t bounds
100− outputByteBuffer t $ writeToByteString $ writeHideCursor dc
99+ liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
101
100
102-- | Shows the cursor.
101-- | Shows the cursor.
103−showCursor :: Output -> IO ()
102+showCursor :: MonadIO m => Output -> m ()
104showCursor t = do
103showCursor t = do
105 bounds <- displayBounds t
104 bounds <- displayBounds t
106 dc <- displayContext t bounds
105 dc <- displayContext t bounds
107− outputByteBuffer t $ writeToByteString $ writeShowCursor dc
106+ liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+52−85
@@ -1,9 +1,9 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2+{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7-- | This module provides an abstract interface for performing terminal
7-- | This module provides an abstract interface for performing terminal
8-- output. The only user-facing part of this API is 'Output'.
8-- output. The only user-facing part of this API is 'Output'.
9module Graphics.Vty.Output.Interface
9module Graphics.Vty.Output.Interface
@@ -29,6 +29,8 @@ import Graphics.Vty.DisplayAttributes
29import Blaze.ByteString.Builder (Write, writeToByteString)
29import Blaze.ByteString.Builder (Write, writeToByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
31
31
32+import Control.Monad.Trans
33+
32import qualified Data.ByteString as BS
34import qualified Data.ByteString as BS
33import Data.IORef
35import Data.IORef
34import qualified Data.Text.Encoding as T
36import qualified Data.Text.Encoding as T
@@ -45,12 +47,6 @@ data Mode = Mouse
45 | Focus
47 | Focus
46 -- ^ Focus-in/focus-out events (whether the terminal is
48 -- ^ Focus-in/focus-out events (whether the terminal is
47 -- configured to provide events on focus change)
49 -- 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)
50 deriving (Eq, Read, Show)
55
51
56-- | The Vty terminal output interface.
52-- | The Vty terminal output interface.
@@ -59,7 +55,7 @@ data Output = Output
59 terminalID :: String
55 terminalID :: String
60 -- | Release the terminal just prior to application exit and reset
56 -- | Release the terminal just prior to application exit and reset
61 -- it to its state prior to application startup.
57 -- it to its state prior to application startup.
62− , releaseTerminal :: IO ()
58+ , releaseTerminal :: forall m. MonadIO m => m ()
63 -- | Clear the display and initialize the terminal to some initial
59 -- | Clear the display and initialize the terminal to some initial
64 -- display state.
60 -- display state.
65 --
61 --
@@ -69,57 +65,40 @@ data Output = Output
69 -- - cursor at top left
65 -- - cursor at top left
70 -- - UTF-8 character encoding
66 -- - UTF-8 character encoding
71 -- - drawing characteristics are the default
67 -- - drawing characteristics are the default
72− , reserveDisplay :: IO ()
68+ , reserveDisplay :: forall m. MonadIO m => m ()
73 -- | Return the display to the state before `reserveDisplay` If no
69 -- | Return the display to the state before `reserveDisplay` If no
74 -- previous state then set the display state to the initial state.
70 -- previous state then set the display state to the initial state.
75− , releaseDisplay :: IO ()
71+ , 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.
72 -- | Returns the current display bounds.
79− , displayBounds :: IO DisplayRegion
73+ , displayBounds :: forall m. MonadIO m => m DisplayRegion
80 -- | Output the bytestring to the terminal device.
74 -- | Output the bytestring to the terminal device.
81 , outputByteBuffer :: BS.ByteString -> IO ()
75 , outputByteBuffer :: BS.ByteString -> IO ()
76+ -- | Specifies the maximum number of colors supported by the
77+ -- context.
78+ , contextColorCount :: Int
82 -- | Specifies whether the cursor can be shown / hidden.
79 -- | Specifies whether the cursor can be shown / hidden.
83 , supportsCursorVisibility :: Bool
80 , supportsCursorVisibility :: Bool
84 -- | Indicates support for terminal modes for this output device.
81 -- | Indicates support for terminal modes for this output device.
85 , supportsMode :: Mode -> Bool
82 , supportsMode :: Mode -> Bool
86 -- | Enables or disables a mode (does nothing if the mode is
83 -- | Enables or disables a mode (does nothing if the mode is
87 -- unsupported).
84 -- unsupported).
88− , setMode :: Mode -> Bool -> IO ()
85+ , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()
89 -- | Returns whether a mode is enabled.
86 -- | Returns whether a mode is enabled.
90− , getModeStatus :: Mode -> IO Bool
87+ , getModeStatus :: forall m. MonadIO m => Mode -> m Bool
91 , assumedStateRef :: IORef AssumedState
88 , assumedStateRef :: IORef AssumedState
92 -- | Acquire display access to the given region of the display.
89 -- | Acquire display access to the given region of the display.
93 -- Currently all regions have the upper left corner of (0,0) and
90 -- Currently all regions have the upper left corner of (0,0) and
94 -- the lower right corner at (max displayWidth providedWidth, max
91 -- the lower right corner at (max displayWidth providedWidth, max
95 -- displayHeight providedHeight)
92 -- displayHeight providedHeight)
96− , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
93+ , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
97 -- | Ring the terminal bell if supported.
94 -- | Ring the terminal bell if supported.
98− , ringTerminalBell :: IO ()
95+ , ringTerminalBell :: forall m. MonadIO m => m ()
99 -- | Returns whether the terminal has an audio bell feature.
96 -- | Returns whether the terminal has an audio bell feature.
100− , supportsBell :: IO Bool
97+ , 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 }
98 }
120
99
121−displayContext :: Output -> DisplayRegion -> IO DisplayContext
100+displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
122−displayContext t = mkDisplayContext t t
101+displayContext t = liftIO . mkDisplayContext t t
123
102
124data AssumedState = AssumedState
103data AssumedState = AssumedState
125 { prevFattr :: Maybe FixedAttr
104 { prevFattr :: Maybe FixedAttr
@@ -154,9 +133,9 @@ data DisplayContext = DisplayContext
154 -- to support this the currently applied display attributes are
133 -- to support this the currently applied display attributes are
155 -- required. In addition it may be possible to optimize the state
134 -- required. In addition it may be possible to optimize the state
156 -- changes based off the currently applied display attributes.
135 -- changes based off the currently applied display attributes.
157− , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
136+ , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
158 -- | Reset the display attributes to the default display attributes.
137 -- | Reset the display attributes to the default display attributes.
159− , writeDefaultAttr :: Bool -> Write
138+ , writeDefaultAttr :: Write
160 , writeRowEnd :: Write
139 , writeRowEnd :: Write
161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
140 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
162 , inlineHack :: IO ()
141 , inlineHack :: IO ()
@@ -178,24 +157,24 @@ writeUtf8Text = writeByteString
178-- 4. Serialized to the display.
157-- 4. Serialized to the display.
179--
158--
180-- 5. The cursor is then shown and positioned or kept hidden.
159-- 5. The cursor is then shown and positioned or kept hidden.
181−outputPicture :: DisplayContext -> Picture -> IO ()
160+outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
182−outputPicture dc pic = do
161+outputPicture dc pic = liftIO $ do
183− urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
184 as <- readIORef (assumedStateRef $ contextDevice dc)
162 as <- readIORef (assumedStateRef $ contextDevice dc)
185 let manipCursor = supportsCursorVisibility (contextDevice dc)
163 let manipCursor = supportsCursorVisibility (contextDevice dc)
186 r = contextRegion dc
164 r = contextRegion dc
187 ops = displayOpsForPic pic r
165 ops = displayOpsForPic pic r
188− initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
166+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing
189 -- Diff the previous output against the requested output.
167 -- Diff the previous output against the requested output.
190 -- Differences are currently on a per-row basis.
168 -- Differences are currently on a per-row basis.
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 $ affectedRegion ops) True
193 Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
171 Just previousOps -> if affectedRegion previousOps /= affectedRegion 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+ -- Should we choose closest 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+4−8
@@ -11,7 +11,6 @@ module Graphics.Vty.Output.Mock
11where
11where
12
12
13import Graphics.Vty.Image (DisplayRegion)
13import Graphics.Vty.Image (DisplayRegion)
14−import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
15import Graphics.Vty.Output.Interface
14import Graphics.Vty.Output.Interface
16
15
17import Blaze.ByteString.Builder.Word (writeWord8)
16import Blaze.ByteString.Builder.Word (writeWord8)
@@ -31,7 +30,7 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString)
31-- without considering terminal specific issues.
30-- without considering terminal specific issues.
32--
31--
33-- The mock implementation is useful in manually determining if the
32-- The mock implementation is useful in manually determining if the
34−-- sequence of terminal operations matches the expected sequence. The
33+-- sequence of terminal operations matche the expected sequence. The
35-- requirement of the produced representation is simplicity in parsing
34-- requirement of the produced representation is simplicity in parsing
36-- the text representation and determining how the picture was mapped to
35-- the text representation and determining how the picture was mapped to
37-- terminal operations.
36-- terminal operations.
@@ -49,19 +48,16 @@ mockTerminal r = liftIO $ do
49 , releaseDisplay = return ()
48 , releaseDisplay = return ()
50 , ringTerminalBell = return ()
49 , ringTerminalBell = return ()
51 , supportsBell = return False
50 , supportsBell = return False
52− , supportsItalics = return False
53− , supportsStrikethrough = return False
54− , setDisplayBounds = const $ return ()
55 , displayBounds = return r
51 , displayBounds = return r
56 , outputByteBuffer = \bytes -> do
52 , outputByteBuffer = \bytes -> do
57 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
53 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
58 writeIORef outRef $ UTF8.fromRep bytes
54 writeIORef outRef $ UTF8.fromRep bytes
55+ , contextColorCount = 16
59 , supportsCursorVisibility = True
56 , supportsCursorVisibility = True
60 , supportsMode = const False
57 , supportsMode = const False
61 , setMode = const $ const $ return ()
58 , setMode = const $ const $ return ()
62 , getModeStatus = const $ return False
59 , getModeStatus = const $ return False
63 , assumedStateRef = newAssumedStateRef
60 , assumedStateRef = newAssumedStateRef
64− , outputColorMode = ColorMode16
65 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
61 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
66 { contextRegion = rActual
62 { contextRegion = rActual
67 , contextDevice = tActual
63 , contextDevice = tActual
@@ -76,10 +72,10 @@ mockTerminal r = liftIO $ do
76 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
72 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
77 -- An attr change is always visualized as the single
73 -- An attr change is always visualized as the single
78 -- character 'A'
74 -- character 'A'
79− , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
75+ , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
80 -- default attr is always visualized as the single
76 -- default attr is always visualized as the single
81 -- character 'D'
77 -- character 'D'
82− , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
78+ , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'
83 -- row end is always visualized as the single character
79 -- row end is always visualized as the single character
84 -- 'E'
80 -- 'E'
85 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
81 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
src/Graphics/Vty/Output/TerminfoBased.hs+63−190
@@ -1,6 +1,5 @@
1+{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE CPP #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
3{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
5{-# CFILES gwinsz.c #-}
4{-# CFILES gwinsz.c #-}
6
5
@@ -9,13 +8,10 @@
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
8-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
10module Graphics.Vty.Output.TerminfoBased
9module Graphics.Vty.Output.TerminfoBased
11 ( reserveTerminal
10 ( reserveTerminal
12− , setWindowSize
13 )
11 )
14where
12where
15
13
16import Control.Monad (when)
14import Control.Monad (when)
17−import Data.Bits (shiftL, (.&.))
18−import qualified Data.ByteString as BS
19import Data.ByteString.Internal (toForeignPtr)
15import Data.ByteString.Internal (toForeignPtr)
20import Data.Terminfo.Parse
16import Data.Terminfo.Parse
21import Data.Terminfo.Eval
17import Data.Terminfo.Eval
@@ -25,16 +21,15 @@ import Graphics.Vty.Image (DisplayRegion)
25import Graphics.Vty.DisplayAttributes
21import Graphics.Vty.DisplayAttributes
26import Graphics.Vty.Output.Interface
22import Graphics.Vty.Output.Interface
27
23
28−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
24+import Blaze.ByteString.Builder (Write, writeToByteString)
29
25
26+import Control.Monad.Trans
27+
28+import Data.Bits ((.&.))
30import Data.IORef
29import Data.IORef
31import Data.Maybe (isJust, isNothing, fromJust)
30import Data.Maybe (isJust, isNothing, fromJust)
32import Data.Word
31import Data.Word
33
32
34−#if !MIN_VERSION_base(4,8,0)
35−import Data.Foldable (foldMap)
36−#endif
37−
38import Foreign.C.Types ( CInt(..), CLong(..) )
33import Foreign.C.Types ( CInt(..), CLong(..) )
39import Foreign.ForeignPtr (withForeignPtr)
34import Foreign.ForeignPtr (withForeignPtr)
40import Foreign.Ptr (Ptr, plusPtr)
35import Foreign.Ptr (Ptr, plusPtr)
@@ -49,6 +44,7 @@ data TerminfoCaps = TerminfoCaps
49 , cup :: CapExpression
44 , cup :: CapExpression
50 , cnorm :: Maybe CapExpression
45 , cnorm :: Maybe CapExpression
51 , civis :: Maybe CapExpression
46 , civis :: Maybe CapExpression
47+ , supportsNoColors :: Bool
52 , useAltColorMap :: Bool
48 , useAltColorMap :: Bool
53 , setForeColor :: CapExpression
49 , setForeColor :: CapExpression
54 , setBackColor :: CapExpression
50 , setBackColor :: CapExpression
@@ -63,10 +59,6 @@ data DisplayAttrCaps = DisplayAttrCaps
63 { setAttrStates :: Maybe CapExpression
59 { setAttrStates :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
60 , enterStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
61 , exitStandout :: Maybe CapExpression
66− , enterItalic :: Maybe CapExpression
67− , exitItalic :: Maybe CapExpression
68− , enterStrikethrough :: Maybe CapExpression
69− , exitStrikethrough :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
62 , enterUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
63 , exitUnderline :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
64 , enterReverseVideo :: Maybe CapExpression
@@ -103,85 +95,62 @@ sendCapToTerminal t cap capParams = do
103--
95--
104-- * Providing independent string capabilities for all display
96-- * Providing independent string capabilities for all display
105-- attributes.
97-- attributes.
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
98+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
107−reserveTerminal termName outFd colorMode = do
99+reserveTerminal termName outFd = liftIO $ do
108 ti <- Terminfo.setupTerm termName
100 ti <- Terminfo.setupTerm termName
109 -- assumes set foreground always implies set background exists.
101 -- assumes set foreground always implies set background exists.
110 -- if set foreground is not set then all color changing style
102 -- if set foreground is not set then all color changing style
111 -- attributes are filtered.
103 -- attributes are filtered.
112 msetaf <- probeCap ti "setaf"
104 msetaf <- probeCap ti "setaf"
113 msetf <- probeCap ti "setf"
105 msetf <- probeCap ti "setf"
114− let (useAlt, setForeCap)
106+ let (noColors, useAlt, setForeCap)
115 = case msetaf of
107 = case msetaf of
116− Just setaf -> (False, setaf)
108+ Just setaf -> (False, False, setaf)
117 Nothing -> case msetf of
109 Nothing -> case msetf of
118− Just setf -> (True, setf)
110+ Just setf -> (False, True, setf)
119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
111+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
120 msetab <- probeCap ti "setab"
112 msetab <- probeCap ti "setab"
121 msetb <- probeCap ti "setb"
113 msetb <- probeCap ti "setb"
122− let setBackCap
114+ let set_back_cap
123 = case msetab of
115 = case msetab of
124− Just setab -> setab
125 Nothing -> case msetb of
116 Nothing -> case msetb of
126 Just setb -> setb
117 Just setb -> setb
127 Nothing -> error $ "no back color support for terminal " ++ termName
118 Nothing -> error $ "no back color support for terminal " ++ termName
128−
119+ 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
120 terminfoCaps <- pure TerminfoCaps
148 <*> probeCap ti "smcup"
121 <*> probeCap ti "smcup"
149 <*> probeCap ti "rmcup"
122 <*> probeCap ti "rmcup"
150 <*> requireCap ti "cup"
123 <*> requireCap ti "cup"
151 <*> probeCap ti "cnorm"
124 <*> probeCap ti "cnorm"
152 <*> probeCap ti "civis"
125 <*> probeCap ti "civis"
126+ <*> pure noColors
153 <*> pure useAlt
127 <*> pure useAlt
154 <*> pure setForeCap
128 <*> pure setForeCap
155− <*> pure setBackCap
129+ <*> pure set_back_cap
156 <*> requireCap ti "sgr0"
130 <*> requireCap ti "sgr0"
157 <*> requireCap ti "clear"
131 <*> requireCap ti "clear"
158 <*> requireCap ti "el"
132 <*> requireCap ti "el"
159 <*> currentDisplayAttrCaps ti
133 <*> currentDisplayAttrCaps ti
160 <*> probeCap ti "bel"
134 <*> probeCap ti "bel"
135+ newAssumedStateRef <- newIORef initialAssumedState
161 let t = Output
136 let t = Output
162 { terminalID = termName
137 { terminalID = termName
163− , releaseTerminal = do
138+ , releaseTerminal = liftIO $ do
164 sendCap setDefaultAttr []
139 sendCap setDefaultAttr []
165 maybeSendCap cnorm []
140 maybeSendCap cnorm []
166 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
141 , 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 []
142+ , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
172− , reserveDisplay = do
143+ , reserveDisplay = liftIO $ do
173 -- If there is no support for smcup: Clear the screen
144 -- If there is no support for smcup: Clear the screen
174 -- and then move the mouse to the home position to
145 -- and then move the mouse to the home position to
175 -- approximate the behavior.
146 -- approximate the behavior.
176 maybeSendCap smcup []
147 maybeSendCap smcup []
177 sendCap clearScreen []
148 sendCap clearScreen []
178− , releaseDisplay = do
149+ , releaseDisplay = liftIO $ do
179 maybeSendCap rmcup []
150 maybeSendCap rmcup []
180 maybeSendCap cnorm []
151 maybeSendCap cnorm []
181− , setDisplayBounds = \(w, h) ->
182− setWindowSize outFd (w, h)
183 , displayBounds = do
152 , displayBounds = do
184− rawSize <- getWindowSize outFd
153+ rawSize <- liftIO $ getWindowSize outFd
185 case rawSize of
154 case rawSize of
186 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
155 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
187 | otherwise -> return (w,h)
156 | otherwise -> return (w,h)
@@ -192,48 +161,51 @@ reserveTerminal termName outFd colorMode = do
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
161 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
162 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
194 ++ " Please report this bug to vty project."
163 ++ " Please report this bug to vty project."
164+ , contextColorCount
165+ = case supportsNoColors terminfoCaps of
166+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
167+ Nothing -> 8
168+ Just v -> toEnum v
169+ True -> 1
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
170 , supportsCursorVisibility = isJust $ civis terminfoCaps
196− , supportsMode = terminfoModeSupported
171+ , supportsMode = const False
197− , setMode = terminfoSetMode
172+ , setMode = const $ const $ return ()
198− , getModeStatus = terminfoModeStatus
173+ , getModeStatus = const $ return False
199 , assumedStateRef = newAssumedStateRef
174 , assumedStateRef = newAssumedStateRef
200− , outputColorMode = colorMode
201 -- I think fix would help assure tActual is the only
175 -- I think fix would help assure tActual is the only
202 -- reference. I was having issues tho.
176 -- reference. I was having issues tho.
203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
177+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
204 }
178 }
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
179 sendCap s = sendCapToTerminal t (s terminfoCaps)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
180 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
207 return t
181 return t
208
182
209−requireCap :: Terminfo.Terminal -> String -> IO CapExpression
183+requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
210requireCap ti capName
184requireCap ti capName
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
185 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
186 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
213 Just capStr -> parseCap capStr
187 Just capStr -> parseCap capStr
214
188
215−probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
189+probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
216probeCap ti capName
190probeCap ti capName
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
191 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
218 Nothing -> return Nothing
192 Nothing -> return Nothing
219 Just capStr -> Just <$> parseCap capStr
193 Just capStr -> Just <$> parseCap capStr
220
194
221−parseCap :: String -> IO CapExpression
195+parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
222parseCap capStr = do
196parseCap capStr = do
223 case parseCapExpression capStr of
197 case parseCapExpression capStr of
224 Left e -> fail $ show e
198 Left e -> fail $ show e
225 Right cap -> return cap
199 Right cap -> return cap
226
200
227−currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
201+currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
202+ => Terminfo.Terminal
203+ -> m DisplayAttrCaps
228currentDisplayAttrCaps ti
204currentDisplayAttrCaps ti
229 = pure DisplayAttrCaps
205 = pure DisplayAttrCaps
230 <*> probeCap ti "sgr"
206 <*> probeCap ti "sgr"
231 <*> probeCap ti "smso"
207 <*> probeCap ti "smso"
232 <*> probeCap ti "rmso"
208 <*> probeCap ti "rmso"
233− <*> probeCap ti "sitm"
234− <*> probeCap ti "ritm"
235− <*> probeCap ti "smxx"
236− <*> probeCap ti "rmxx"
237 <*> probeCap ti "smul"
209 <*> probeCap ti "smul"
238 <*> probeCap ti "rmul"
210 <*> probeCap ti "rmul"
239 <*> probeCap ti "rev"
211 <*> probeCap ti "rev"
@@ -247,13 +219,6 @@ getWindowSize fd = do
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
219 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
248 return (fromIntegral b, fromIntegral a)
220 return (fromIntegral b, fromIntegral a)
249
221
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
222terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
258terminfoDisplayContext tActual terminfoCaps r = return dc
223terminfoDisplayContext tActual terminfoCaps r = return dc
259 where dc = DisplayContext
224 where dc = DisplayContext
@@ -267,35 +232,15 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
267 Nothing -> error "this terminal does not support hide cursor"
232 Nothing -> error "this terminal does not support hide cursor"
268 Just c -> writeCapExpr c []
233 Just c -> writeCapExpr c []
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
234 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270− , writeDefaultAttr = \urlsEnabled ->
271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
235+ , 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) []
236 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
278 , inlineHack = return ()
237 , inlineHack = return ()
279 }
238 }
280
239
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.
240-- | Portably setting the display attributes is a giant pain in the ass.
296--
241--
297-- If the terminal supports the sgr capability (which sets the on/off
242-- 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
243+-- state of each style directly ; and, for no good reason, resets the
299-- colors to the default) this procedure is used:
244-- colors to the default) this procedure is used:
300--
245--
301-- 0. set the style attributes. This resets the fore and back color.
246-- 0. set the style attributes. This resets the fore and back color.
@@ -328,30 +273,30 @@ writeURLEscapes NoLinkChange =
328--
273--
329-- Note that this optimizes for fewer state changes followed by fewer
274-- Note that this optimizes for fewer state changes followed by fewer
330-- bytes.
275-- bytes.
331−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
276+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
332−terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
277+terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
333− urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
278+ case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
334 -- The only way to reset either color, portably, to the default
279 -- The only way to reset either color, portably, to the default
335 -- is to use either the set state capability or the set default
280 -- is to use either the set state capability or the set default
336 -- capability.
281 -- capability.
337− True -> do
282+ True -> do
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
283 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
339− (fixedStyle attr)
284+ (fixedStyle attr )
340 (styleToApplySeq $ fixedStyle attr) of
285 (styleToApplySeq $ fixedStyle attr) of
341 -- only way to reset a color to the defaults
286 -- only way to reset a color to the defaults
342− EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
287+ EnterExitSeq caps -> writeDefaultAttr dc
343 `mappend`
288 `mappend`
344 foldMap (\cap -> writeCapExpr cap []) caps
289 foldMap (\cap -> writeCapExpr cap []) caps
345 `mappend`
290 `mappend`
346 setColors
291 setColors
347 -- implicitly resets the colors to the defaults
292 -- implicitly resets the colors to the defaults
348 SetState state -> writeCapExpr (fromJust $ setAttrStates
293 SetState state -> writeCapExpr (fromJust $ setAttrStates
349− $ displayAttrCaps terminfoCaps
294+ $ displayAttrCaps
295+ $ terminfoCaps
350 )
296 )
351 (sgrArgsForState state)
297 (sgrArgsForState state)
352− `mappend` setItalics
298+ `mappend`
353− `mappend` setStrikethrough
354− `mappend` setColors
299+ setColors
355 -- Otherwise the display colors are not changing or changing
300 -- Otherwise the display colors are not changing or changing
356 -- between two non-default points.
301 -- between two non-default points.
357 False -> do
302 False -> do
@@ -369,99 +314,45 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
369 -- applied states.
314 -- applied states.
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
315 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
371 `mappend`
316 `mappend`
372− writeColorDiff Foreground (foreColorDiff diffs)
317+ writeColorDiff setForeColor (foreColorDiff diffs)
373 `mappend`
318 `mappend`
374− writeColorDiff Background (backColorDiff diffs)
319+ writeColorDiff setBackColor (backColorDiff diffs)
375 -- implicitly resets the colors to the defaults
320 -- implicitly resets the colors to the defaults
376 SetState state -> writeCapExpr (fromJust $ setAttrStates
321 SetState state -> writeCapExpr (fromJust $ setAttrStates
377 $ displayAttrCaps terminfoCaps
322 $ displayAttrCaps terminfoCaps
378 )
323 )
379 (sgrArgsForState state)
324 (sgrArgsForState state)
380− `mappend` setItalics
381− `mappend` setStrikethrough
382 `mappend` setColors
325 `mappend` setColors
383 where
326 where
384− urlAttrs True = writeURLEscapes (urlDiff diffs)
385− urlAttrs False = mempty
386 colorMap = case useAltColorMap terminfoCaps of
327 colorMap = case useAltColorMap terminfoCaps of
387 False -> ansiColorIndex
328 False -> ansiColorIndex
388 True -> altColorIndex
329 True -> altColorIndex
389 attr = fixDisplayAttr prevAttr reqAttr
330 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 =
331 setColors =
405 (case fixedForeColor attr of
332 (case fixedForeColor attr of
406− Just c -> writeColor Foreground c
333+ Just c -> writeCapExpr (setForeColor terminfoCaps)
334+ [toEnum $ colorMap c]
407 Nothing -> mempty)
335 Nothing -> mempty)
408 `mappend`
336 `mappend`
409 (case fixedBackColor attr of
337 (case fixedBackColor attr of
410− Just c -> writeColor Background c
338+ Just c -> writeCapExpr (setBackColor terminfoCaps)
339+ [toEnum $ colorMap c]
411 Nothing -> mempty)
340 Nothing -> mempty)
412− writeColorDiff _side NoColorChange
341+ writeColorDiff _f NoColorChange
413 = mempty
342 = mempty
414− writeColorDiff _side ColorToDefault
343+ writeColorDiff _f ColorToDefault
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
344 = error "ColorToDefault is not a possible case for applyColorDiffs"
416− writeColorDiff side (SetColor c)
345+ 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]
346+ = 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
347
453-- | The color table used by a terminal is a 16 color set followed by a
348-- | 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.
349-- 240 color set that might not be supported by the terminal.
455--
350--
456−-- This takes a Color which clearly identifies which palette to use and
351+-- This takes a Color which clearly identifies which pallete to use and
457−-- computes the index into the full 256 color palette.
352+-- computes the index into the full 256 color pallete.
458ansiColorIndex :: Color -> Int
353ansiColorIndex :: Color -> Int
459ansiColorIndex (ISOColor v) = fromEnum v
354ansiColorIndex (ISOColor v) = fromEnum v
460ansiColorIndex (Color240 v) = 16 + fromEnum v
355ansiColorIndex (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
356
466-- | For terminals without setaf/setab
357-- | For terminals without setaf/setab
467--
358--
@@ -478,10 +369,6 @@ altColorIndex (ISOColor 6) = 3
478altColorIndex (ISOColor 7) = 7
369altColorIndex (ISOColor 7) = 7
479altColorIndex (ISOColor v) = fromEnum v
370altColorIndex (ISOColor v) = fromEnum v
480altColorIndex (Color240 v) = 16 + fromEnum v
371altColorIndex (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
372
486{- | The sequence of terminfo caps to apply a given style are determined
373{- | The sequence of terminfo caps to apply a given style are determined
487 - according to these rules.
374 - according to these rules.
@@ -508,8 +395,6 @@ data DisplayAttrSeq
508data DisplayAttrState = DisplayAttrState
395data DisplayAttrState = DisplayAttrState
509 { applyStandout :: Bool
396 { applyStandout :: Bool
510 , applyUnderline :: Bool
397 , applyUnderline :: Bool
511− , applyItalic :: Bool
512− , applyStrikethrough :: Bool
513 , applyReverseVideo :: Bool
398 , applyReverseVideo :: Bool
514 , applyBlink :: Bool
399 , applyBlink :: Bool
515 , applyDim :: Bool
400 , applyDim :: Bool
@@ -546,10 +431,6 @@ reqDisplayCapSeqFor caps s diffs
546 -- set state cap then just use the set state cap.
431 -- set state cap then just use the set state cap.
547 ( True, True ) -> SetState $ stateForStyle s
432 ( True, True ) -> SetState $ stateForStyle s
548 where
433 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
434 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
435 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
436 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -562,10 +443,6 @@ reqDisplayCapSeqFor caps s diffs
562 noEnterExitCap RemoveDim = True
443 noEnterExitCap RemoveDim = True
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
444 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
564 noEnterExitCap RemoveBold = True
445 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
446 enterExitCap ApplyStandout = fromJust $ enterStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
447 enterExitCap RemoveStandout = fromJust $ exitStandout caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
448 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -579,8 +456,6 @@ stateForStyle :: Style -> DisplayAttrState
579stateForStyle s = DisplayAttrState
456stateForStyle s = DisplayAttrState
580 { applyStandout = isStyleSet standout
457 { applyStandout = isStyleSet standout
581 , applyUnderline = isStyleSet underline
458 , applyUnderline = isStyleSet underline
582− , applyItalic = isStyleSet italic
583− , applyStrikethrough = isStyleSet strikethrough
584 , applyReverseVideo = isStyleSet reverseVideo
459 , applyReverseVideo = isStyleSet reverseVideo
585 , applyBlink = isStyleSet blink
460 , applyBlink = isStyleSet blink
586 , applyDim = isStyleSet dim
461 , applyDim = isStyleSet dim
@@ -592,12 +467,10 @@ styleToApplySeq :: Style -> [StyleStateChange]
592styleToApplySeq s = concat
467styleToApplySeq s = concat
593 [ applyIfRequired ApplyStandout standout
468 [ applyIfRequired ApplyStandout standout
594 , applyIfRequired ApplyUnderline underline
469 , applyIfRequired ApplyUnderline underline
595− , applyIfRequired ApplyItalic italic
596− , applyIfRequired ApplyStrikethrough strikethrough
597 , applyIfRequired ApplyReverseVideo reverseVideo
470 , applyIfRequired ApplyReverseVideo reverseVideo
598 , applyIfRequired ApplyBlink blink
471 , applyIfRequired ApplyBlink blink
599 , applyIfRequired ApplyDim dim
472 , applyIfRequired ApplyDim dim
600− , applyIfRequired ApplyBold bold
473+ , applyIfRequired ApplyBlink bold
601 ]
474 ]
602 where
475 where
603 applyIfRequired op flag
476 applyIfRequired op flag
src/Graphics/Vty/Output/XTermColor.hs+18−33
@@ -1,4 +1,3 @@
1−{-# Language CPP #-}
2-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
3-- | Xterm output driver. This uses the Terminfo driver with some
2-- | Xterm output driver. This uses the Terminfo driver with some
4-- extensions for Xterm.
3-- extensions for Xterm.
@@ -10,41 +9,26 @@ where
10import Graphics.Vty.Output.Interface
9import Graphics.Vty.Output.Interface
11import Graphics.Vty.Input.Mouse
10import Graphics.Vty.Input.Mouse
12import Graphics.Vty.Input.Focus
11import Graphics.Vty.Input.Focus
13−import Graphics.Vty.Attributes.Color (ColorMode)
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
12import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
15
13
16import Blaze.ByteString.Builder (writeToByteString)
14import Blaze.ByteString.Builder (writeToByteString)
17import Blaze.ByteString.Builder.Word (writeWord8)
15import Blaze.ByteString.Builder.Word (writeWord8)
18
16
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)
17import Control.Monad (void, when)
24import Control.Monad.Trans
18import Control.Monad.Trans
25−import Data.Char (toLower)
26import Data.IORef
19import Data.IORef
27
20
28−import System.Posix.IO (fdWriteBuf)
21+import System.Posix.IO (fdWrite)
29−import System.Posix.Types (ByteCount, Fd)
22+import System.Posix.Types (Fd)
30import System.Posix.Env (getEnv)
23import System.Posix.Env (getEnv)
31
24
32import Data.List (isInfixOf)
25import Data.List (isInfixOf)
33import Data.Maybe (catMaybes)
26import Data.Maybe (catMaybes)
34−
35−#if !MIN_VERSION_base(4,11,0)
36import Data.Monoid ((<>))
27import 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
28
45-- | Construct an Xterm output driver. Initialize the display to UTF-8.
29-- | Construct an Xterm output driver. Initialize the display to UTF-8.
46−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
30+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
47−reserveTerminal variant outFd colorMode = liftIO $ do
31+reserveTerminal variant outFd = liftIO $ do
48 let flushedPut = void . fdWrite outFd
32 let flushedPut = void . fdWrite outFd
49 -- If the terminal variant is xterm-color use xterm instead since,
33 -- If the terminal variant is xterm-color use xterm instead since,
50 -- more often than not, xterm-color is broken.
34 -- more often than not, xterm-color is broken.
@@ -52,7 +36,7 @@ reserveTerminal variant outFd colorMode = liftIO $ do
52
36
53 utf8a <- utf8Active
37 utf8a <- utf8Active
54 when (not utf8a) $ flushedPut setUtf8CharSet
38 when (not utf8a) $ flushedPut setUtf8CharSet
55− t <- TerminfoBased.reserveTerminal variant' outFd colorMode
39+ t <- TerminfoBased.reserveTerminal variant' outFd
56
40
57 mouseModeStatus <- newIORef False
41 mouseModeStatus <- newIORef False
58 focusModeStatus <- newIORef False
42 focusModeStatus <- newIORef False
@@ -77,12 +61,10 @@ reserveTerminal variant outFd colorMode = liftIO $ do
77 True -> flushedPut enableBracketedPastes
61 True -> flushedPut enableBracketedPastes
78 False -> flushedPut disableBracketedPastes
62 False -> flushedPut disableBracketedPastes
79 writeIORef pasteModeStatus newStatus
63 writeIORef pasteModeStatus newStatus
80− Hyperlink -> setMode t Hyperlink newStatus
81
64
82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
65 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
83 xtermGetMode Focus = liftIO $ readIORef focusModeStatus
66 xtermGetMode Focus = liftIO $ readIORef focusModeStatus
84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
67 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85− xtermGetMode Hyperlink = getModeStatus t Hyperlink
86
68
87 let t' = t
69 let t' = t
88 { terminalID = terminalID t ++ " (xterm-color)"
70 { terminalID = terminalID t ++ " (xterm-color)"
@@ -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-- There is no known terminfo capability 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+2−11
@@ -1,3 +1,4 @@
1+{-# LANGUAGE BangPatterns #-}
1-- A 'Picture' is a background paired with a set of 'Image' layers. The
2-- A 'Picture' is a background paired with a set of 'Image' layers. The
2-- 'Picture' data structure is representative of the final terminal
3-- 'Picture' data structure is representative of the final terminal
3-- view.
4-- view.
@@ -30,7 +31,7 @@ data Picture = Picture
30 , picBackground :: Background
31 , picBackground :: Background
31 -- ^ The picture's background to be displayed in locations with no
32 -- ^ The picture's background to be displayed in locations with no
32 -- Image data.
33 -- Image data.
33− } deriving Eq
34+ }
34
35
35instance Show Picture where
36instance Show Picture where
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
37 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -79,20 +80,11 @@ picForLayers is = Picture
79data Cursor =
80data Cursor =
80 -- | Hide the cursor
81 -- | Hide the cursor
81 NoCursor
82 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
83 -- | Show the cursor at the given logical column accounting for
91 -- character width in the presence of multi-column characters.
84 -- character width in the presence of multi-column characters.
92 | Cursor !Int !Int
85 | Cursor !Int !Int
93 -- | Show the cursor at the given absolute terminal column and row
86 -- | Show the cursor at the given absolute terminal column and row
94 | AbsoluteCursor !Int !Int
87 | AbsoluteCursor !Int !Int
95− deriving Eq
96
88
97instance NFData Cursor where
89instance NFData Cursor where
98 rnf c = c `seq` ()
90 rnf c = c `seq` ()
@@ -116,7 +108,6 @@ data Background
116 --
108 --
117 -- * End of line if there are no remaining non-skip ops.
109 -- * End of line if there are no remaining non-skip ops.
118 | ClearBackground
110 | ClearBackground
119− deriving Eq
120
111
121instance NFData Background where
112instance NFData Background where
122 rnf (Background c a) = c `seq` a `seq` ()
113 rnf (Background c a) = c `seq` a `seq` ()
src/Graphics/Vty/PictureToSpans.hs+17−11
@@ -72,7 +72,7 @@ displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
72-- | Returns the DisplayOps for an image rendered to a window the size
72-- | Returns the DisplayOps for an image rendered to a window the size
73-- of the image.
73-- of the image.
74--
74--
75−-- largely used only for debugging.
75+-- largerly used only for debugging.
76displayOpsForImage :: Image -> DisplayOps
76displayOpsForImage :: Image -> DisplayOps
77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
78
78
@@ -81,7 +81,7 @@ combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
81combinedOpsForLayers pic r
81combinedOpsForLayers pic r
82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
83 | otherwise = do
83 | otherwise = do
84− layerOps <- mapM (`buildSpans` r) (picLayers pic)
84+ layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)
85 case layerOps of
85 case layerOps of
86 [] -> fail "empty picture"
86 [] -> fail "empty picture"
87 [ops] -> substituteSkips (picBackground pic) ops
87 [ops] -> substituteSkips (picBackground pic) ops
@@ -136,8 +136,8 @@ mergeUnder upper lower = do
136 return upper
136 return upper
137
137
138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
139−mergeRowUnder upperRowOps =
139+mergeRowUnder upperRowOps lowerRowOps =
140− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)
140+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps
141 where
141 where
142 -- H: it will never be the case that we are out of upper ops
142 -- H: it will never be the case that we are out of upper ops
143 -- before lower ops.
143 -- before lower ops.
@@ -298,11 +298,11 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
298 state <- get
298 state <- get
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
300 case state^.skip of
300 case state^.skip of
301− s | s > size -> put $ state & skip %~ subtract size
301+ s | s > size -> put $ state & skip -~ size
302 | s == 0 -> if state^.remaining > i0Dim
302 | s == 0 -> if state^.remaining > i0Dim
303 then do
303 then do
304 addMaybeClipped i0
304 addMaybeClipped i0
305− put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim
305+ put $ state & offset +~ i0Dim & remaining -~ i0Dim
306 addMaybeClipped i1
306 addMaybeClipped i1
307 else addMaybeClipped i0
307 else addMaybeClipped i0
308 | s < i0Dim ->
308 | s < i0Dim ->
@@ -311,10 +311,10 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
311 then addMaybeClipped i0
311 then addMaybeClipped i0
312 else do
312 else do
313 addMaybeClipped i0
313 addMaybeClipped i0
314− put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0
314+ put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0
315 addMaybeClipped i1
315 addMaybeClipped i1
316 | s >= i0Dim -> do
316 | s >= i0Dim -> do
317− put $ state & skip %~ subtract i0Dim
317+ put $ state & skip -~ i0Dim
318 addMaybeClipped i1
318 addMaybeClipped i1
319 _ -> fail $ name ++ " has unhandled skip class"
319 _ -> fail $ name ++ " has unhandled skip class"
320
320
@@ -323,14 +323,14 @@ addUnclippedText a txt = do
323 let op = TextSpan a usedDisplayColumns
323 let op = TextSpan a usedDisplayColumns
324 (fromIntegral $ TL.length txt)
324 (fromIntegral $ TL.length txt)
325 txt
325 txt
326− usedDisplayColumns = wctlwidth txt
326+ usedDisplayColumns = wcswidth $ TL.unpack txt
327 use rowOffset >>= snocOp op
327 use rowOffset >>= snocOp op
328
328
329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
330addRowCompletion displayRegion row = do
330addRowCompletion displayRegion row = do
331 allRowOps <- view mrowOps
331 allRowOps <- view mrowOps
332 rowOps <- lift $ lift $ MVector.read allRowOps row
332 rowOps <- lift $ lift $ MVector.read allRowOps row
333− let endX = spanOpsAffectedColumns rowOps
333+ let endX = spanOpsEffectedColumns rowOps
334 when (endX < regionWidth displayRegion) $ do
334 when (endX < regionWidth displayRegion) $ do
335 let ow = regionWidth displayRegion - endX
335 let ow = regionWidth displayRegion - endX
336 snocOp (Skip ow) row
336 snocOp (Skip ow) row
@@ -343,6 +343,12 @@ snocOp !op !row = do
343 lift $ lift $ do
343 lift $ lift $ do
344 ops <- MVector.read theMrowOps row
344 ops <- MVector.read theMrowOps row
345 let ops' = Vector.snoc ops op
345 let ops' = Vector.snoc ops op
346− when (spanOpsAffectedColumns ops' > regionWidth theRegion)
346+ when (spanOpsEffectedColumns ops' > regionWidth theRegion)
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
348 MVector.write theMrowOps row ops'
348 MVector.write theMrowOps row ops'
349+
350+(-~) :: Num a => ASetter s t a a -> a -> s -> t
351+l -~ n = over l (subtract n)
352+
353+(+~) :: Num a => ASetter s t a a -> a -> s -> t
354+l +~ n = over l (n +)
src/Graphics/Vty/Span.hs+11−8
@@ -1,4 +1,6 @@
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
4-- character spans. The attribute is applied to all following spans,
6-- character spans. The attribute is applied to all following spans,
@@ -50,7 +52,7 @@ dropOps :: Int -> SpanOps -> SpanOps
50dropOps w = snd . splitOpsAt w
52dropOps w = snd . splitOpsAt w
51
53
52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
54splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
53−splitOpsAt = splitOpsAt'
55+splitOpsAt inW inOps = splitOpsAt' inW inOps
54 where
56 where
55 splitOpsAt' 0 ops = (Vector.empty, ops)
57 splitOpsAt' 0 ops = (Vector.empty, ops)
56 splitOpsAt' remainingColumns ops = case Vector.head ops of
58 splitOpsAt' remainingColumns ops = case Vector.head ops of
@@ -101,18 +103,18 @@ displayOpsColumns ops
101
103
102-- | The number of rows the DisplayOps are defined for.
104-- | The number of rows the DisplayOps are defined for.
103displayOpsRows :: DisplayOps -> Int
105displayOpsRows :: DisplayOps -> Int
104−displayOpsRows = Vector.length
106+displayOpsRows ops = Vector.length ops
105
107
106affectedRegion :: DisplayOps -> DisplayRegion
108affectedRegion :: DisplayOps -> DisplayRegion
107affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
109affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
108
110
109-- | The number of columns a SpanOps affects.
111-- | The number of columns a SpanOps affects.
110−spanOpsAffectedColumns :: SpanOps -> Int
112+spanOpsEffectedColumns :: SpanOps -> Int
111−spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps
113+spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
112 where
114 where
113− spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w
115+ spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
114− spanOpsAffectedColumns' t (Skip w) = t + w
116+ spanOpsEffectedColumns' t (Skip w) = t + w
115− spanOpsAffectedColumns' t (RowEnd w) = t + w
117+ spanOpsEffectedColumns' t (RowEnd w) = t + w
116
118
117-- | The width of a single SpanOp in columns.
119-- | The width of a single SpanOp in columns.
118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
120spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
@@ -124,6 +126,7 @@ spanOpHasWidth (RowEnd ow) = Just (ow,ow)
124-- span op.
126-- span op.
125columnsToCharOffset :: Int -> SpanOp -> Int
127columnsToCharOffset :: Int -> SpanOp -> Int
126columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
128columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
127− wctlwidth (TL.take (fromIntegral cx) utf8Str)
129+ let str = TL.unpack utf8Str
130+ in wcswidth (take cx str)
128columnsToCharOffset cx (Skip _) = cx
131columnsToCharOffset cx (Skip _) = cx
129columnsToCharOffset cx (RowEnd _) = cx
132columnsToCharOffset 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/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/VerifyEmptyImageProps.hs−1
@@ -1,4 +1,3 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyEmptyImageProps where
1module VerifyEmptyImageProps where
3
2
4import Verify
3import Verify
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/VerifyOutput.hs+3−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
@@ -14,6 +13,7 @@ import Verify.Graphics.Vty.Output
14import Control.Monad
13import Control.Monad
15
14
16import qualified System.Console.Terminfo as Terminfo
15import qualified System.Console.Terminfo as Terminfo
16+import System.Posix.Env
17import System.Posix.IO
17import System.Posix.IO
18
18
19tests :: IO [Test]
19tests :: IO [Test]
@@ -35,11 +35,7 @@ smokeTestTermNonMac termName i = liftIOResult $ do
35smokeTestTerm :: String -> Image -> IO Result
35smokeTestTerm :: String -> Image -> IO Result
36smokeTestTerm termName i = do
36smokeTestTerm termName i = do
37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
38− t <- outputForConfig $ defaultConfig
38+ t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName }
39− { outputFd = Just nullOut
40− , termName = Just termName
41− , colorMode = Just NoColor
42− }
43 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
39 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
44 reserveDisplay t
40 reserveDisplay t
45 dc <- displayContext t (100,100)
41 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+1−4
@@ -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
@@ -132,9 +131,7 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
132 readLoop 0 = return ()
131 readLoop 0 = return ()
133 readLoop n = do
132 readLoop n = do
134 e <- atomically $ readTChan $ input^.eventChannel
133 e <- atomically $ readTChan $ input^.eventChannel
135− case e of
136− InputEvent ev -> modifyIORef eventsRef ((:) ev)
134+ modifyIORef eventsRef ((:) e)
137− ResumeAfterSignal -> return ()
138 readLoop (n - 1)
135 readLoop (n - 1)
139 genEventsUsingIoActions maxDuration writeWaitClose readEvents
136 genEventsUsingIoActions maxDuration writeWaitClose readEvents
140 outEvents <- reverse <$> readIORef eventsRef
137 outEvents <- reverse <$> readIORef eventsRef
test/interactive_terminal_test.hs+1−1
@@ -364,7 +364,7 @@ Did the test output match the description?
364|]
364|]
365 defaultSuccessConfirmResults
365 defaultSuccessConfirmResults
366
366
367−-- Explicitly define the bytes that encode each example text.
367+-- Explicitely definethe bytes that encode each example text.
368-- This avoids any issues with how the compiler represents string literals.
368-- This avoids any issues with how the compiler represents string literals.
369--
369--
370-- This document is UTF-8 encoded so the UTF-8 string is still included for
370-- This document is UTF-8 encoded so the UTF-8 string is still included for
tools/BuildWidthTable.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+66−75
@@ -1,5 +1,5 @@
1name: vty
1name: vty
2−version: 5.35.1
2+version: 5.17.1
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
@@ -24,13 +24,13 @@ description:
24 &#169; Corey O'Connor; BSD3 license.
24 &#169; Corey O'Connor; BSD3 license.
25 .
25 .
26 &#169; Jonathan Daugherty; BSD3 license.
26 &#169; Jonathan Daugherty; BSD3 license.
27−cabal-version: 1.18
27+cabal-version: >= 1.18
28build-type: Simple
28build-type: Simple
29extra-doc-files: README.md,
29extra-doc-files: README.md,
30 AUTHORS,
30 AUTHORS,
31 CHANGELOG.md,
31 CHANGELOG.md,
32 LICENSE
32 LICENSE
33−tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5
33+tested-with: GHC >= 7.6.2
34
34
35source-repository head
35source-repository head
36 type: git
36 type: git
@@ -45,9 +45,10 @@ library
45 deepseq >= 1.1 && < 1.5,
45 deepseq >= 1.1 && < 1.5,
46 directory,
46 directory,
47 filepath >= 1.0 && < 2.0,
47 filepath >= 1.0 && < 2.0,
48− microlens < 0.4.13,
48+ microlens,
49 microlens-mtl,
49 microlens-mtl,
50 microlens-th,
50 microlens-th,
51+ -- required for nice installation with yi
51 hashable >= 1.2,
52 hashable >= 1.2,
52 mtl >= 1.1.1.0 && < 2.3,
53 mtl >= 1.1.1.0 && < 2.3,
53 parallel >= 2.2 && < 3.3,
54 parallel >= 2.2 && < 3.3,
@@ -58,18 +59,10 @@ library
58 text >= 0.11.3,
59 text >= 0.11.3,
59 unix,
60 unix,
60 utf8-string >= 0.3 && < 1.1,
61 utf8-string >= 0.3 && < 1.1,
61− vector >= 0.7,
62+ 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
63
69 exposed-modules: Graphics.Vty
64 exposed-modules: Graphics.Vty
70 Graphics.Vty.Attributes
65 Graphics.Vty.Attributes
71− Graphics.Vty.Attributes.Color
72− Graphics.Vty.Attributes.Color240
73 Graphics.Vty.Config
66 Graphics.Vty.Config
74 Graphics.Vty.Error
67 Graphics.Vty.Error
75 Graphics.Vty.Image
68 Graphics.Vty.Image
@@ -80,6 +73,7 @@ library
80 Graphics.Vty.Picture
73 Graphics.Vty.Picture
81 Graphics.Vty.Output
74 Graphics.Vty.Output
82 Graphics.Text.Width
75 Graphics.Text.Width
76+ -- the modules below are only meant to be used by the tests.
83 Codec.Binary.UTF8.Debug
77 Codec.Binary.UTF8.Debug
84 Data.Terminfo.Parse
78 Data.Terminfo.Parse
85 Data.Terminfo.Eval
79 Data.Terminfo.Eval
@@ -100,47 +94,35 @@ library
100 Graphics.Vty.Output.Interface
94 Graphics.Vty.Output.Interface
101 Graphics.Vty.Output.XTermColor
95 Graphics.Vty.Output.XTermColor
102 Graphics.Vty.Output.TerminfoBased
96 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
97
108− other-modules: Graphics.Vty.Debug.Image
98+ other-modules: Graphics.Vty.Attributes.Color
99+ Graphics.Vty.Attributes.Color240
100+ Graphics.Vty.Debug.Image
109 Graphics.Vty.Input.Terminfo.ANSIVT
101 Graphics.Vty.Input.Terminfo.ANSIVT
110
102
111 c-sources: cbits/gwinsz.c
103 c-sources: cbits/gwinsz.c
112 cbits/set_term_timing.c
104 cbits/set_term_timing.c
113− cbits/get_tty_erase.c
114 cbits/mk_wcwidth.c
105 cbits/mk_wcwidth.c
115
106
116 include-dirs: cbits
107 include-dirs: cbits
117
108
118 hs-source-dirs: src
109 hs-source-dirs: src
119
110
111+ default-extensions: ScopedTypeVariables
112+ ForeignFunctionInterface
113+
120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
114 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
121
115
122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
116 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
123
117
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
118+ 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
119
139executable vty-mode-demo
120executable vty-mode-demo
140 main-is: ModeDemo.hs
121 main-is: ModeDemo.hs
141 hs-source-dirs: demos
122 hs-source-dirs: demos
142
123
143 default-language: Haskell2010
124 default-language: Haskell2010
125+ default-extensions: ScopedTypeVariables
144 ghc-options: -threaded
126 ghc-options: -threaded
145
127
146 build-depends: vty,
128 build-depends: vty,
@@ -155,6 +137,7 @@ executable vty-demo
155 hs-source-dirs: demos
137 hs-source-dirs: demos
156
138
157 default-language: Haskell2010
139 default-language: Haskell2010
140+ default-extensions: ScopedTypeVariables
158 ghc-options: -threaded
141 ghc-options: -threaded
159
142
160 build-depends: vty,
143 build-depends: vty,
@@ -164,8 +147,29 @@ executable vty-demo
164 microlens-mtl,
147 microlens-mtl,
165 mtl >= 1.1.1.0 && < 2.3
148 mtl >= 1.1.1.0 && < 2.3
166
149
150+test-suite verify-attribute-ops
151+ default-language: Haskell2010
152+ default-extensions: ScopedTypeVariables
153+ type: detailed-0.9
154+ hs-source-dirs: test
155+ test-module: VerifyAttributeOps
156+ build-depends: vty,
157+ Cabal >= 1.20,
158+ QuickCheck >= 2.7,
159+ random >= 1.0 && < 1.2,
160+ base >= 4.8 && < 5,
161+ bytestring,
162+ containers,
163+ deepseq >= 1.1 && < 1.5,
164+ mtl >= 1.1.1.0 && < 2.3,
165+ text >= 0.11.3,
166+ unix,
167+ utf8-string >= 0.3 && < 1.1,
168+ vector >= 0.7
169+
167test-suite verify-using-mock-terminal
170test-suite verify-using-mock-terminal
168 default-language: Haskell2010
171 default-language: Haskell2010
172+ default-extensions: ScopedTypeVariables
169
173
170 type: detailed-0.9
174 type: detailed-0.9
171
175
@@ -184,7 +188,7 @@ test-suite verify-using-mock-terminal
184 build-depends: vty,
188 build-depends: vty,
185 Cabal >= 1.20,
189 Cabal >= 1.20,
186 QuickCheck >= 2.7,
190 QuickCheck >= 2.7,
187− random >= 1.0 && < 1.3,
191+ random >= 1.0 && < 1.2,
188 base >= 4.8 && < 5,
192 base >= 4.8 && < 5,
189 bytestring,
193 bytestring,
190 containers,
194 containers,
@@ -198,6 +202,7 @@ test-suite verify-using-mock-terminal
198
202
199test-suite verify-terminal
203test-suite verify-terminal
200 default-language: Haskell2010
204 default-language: Haskell2010
205+ default-extensions: ScopedTypeVariables
201
206
202 type: detailed-0.9
207 type: detailed-0.9
203
208
@@ -216,7 +221,7 @@ test-suite verify-terminal
216 build-depends: vty,
221 build-depends: vty,
217 Cabal >= 1.20,
222 Cabal >= 1.20,
218 QuickCheck >= 2.7,
223 QuickCheck >= 2.7,
219− random >= 1.0 && < 1.3,
224+ random >= 1.0 && < 1.2,
220 base >= 4.8 && < 5,
225 base >= 4.8 && < 5,
221 bytestring,
226 bytestring,
222 containers,
227 containers,
@@ -230,6 +235,7 @@ test-suite verify-terminal
230
235
231test-suite verify-display-attributes
236test-suite verify-display-attributes
232 default-language: Haskell2010
237 default-language: Haskell2010
238+ default-extensions: ScopedTypeVariables
233
239
234 type: detailed-0.9
240 type: detailed-0.9
235
241
@@ -248,7 +254,7 @@ test-suite verify-display-attributes
248 build-depends: vty,
254 build-depends: vty,
249 Cabal >= 1.20,
255 Cabal >= 1.20,
250 QuickCheck >= 2.7,
256 QuickCheck >= 2.7,
251− random >= 1.0 && < 1.3,
257+ random >= 1.0 && < 1.2,
252 base >= 4.8 && < 5,
258 base >= 4.8 && < 5,
253 bytestring,
259 bytestring,
254 containers,
260 containers,
@@ -261,6 +267,7 @@ test-suite verify-display-attributes
261
267
262test-suite verify-empty-image-props
268test-suite verify-empty-image-props
263 default-language: Haskell2010
269 default-language: Haskell2010
270+ default-extensions: ScopedTypeVariables
264
271
265 type: detailed-0.9
272 type: detailed-0.9
266
273
@@ -273,7 +280,7 @@ test-suite verify-empty-image-props
273 build-depends: vty,
280 build-depends: vty,
274 Cabal >= 1.20,
281 Cabal >= 1.20,
275 QuickCheck >= 2.7,
282 QuickCheck >= 2.7,
276− random >= 1.0 && < 1.3,
283+ random >= 1.0 && < 1.2,
277 base >= 4.8 && < 5,
284 base >= 4.8 && < 5,
278 bytestring,
285 bytestring,
279 containers,
286 containers,
@@ -286,6 +293,7 @@ test-suite verify-empty-image-props
286
293
287test-suite verify-eval-terminfo-caps
294test-suite verify-eval-terminfo-caps
288 default-language: Haskell2010
295 default-language: Haskell2010
296+ default-extensions: ScopedTypeVariables
289
297
290 type: detailed-0.9
298 type: detailed-0.9
291
299
@@ -299,7 +307,7 @@ test-suite verify-eval-terminfo-caps
299 build-depends: vty,
307 build-depends: vty,
300 Cabal >= 1.20,
308 Cabal >= 1.20,
301 QuickCheck >= 2.7,
309 QuickCheck >= 2.7,
302− random >= 1.0 && < 1.3,
310+ random >= 1.0 && < 1.2,
303 base >= 4.8 && < 5,
311 base >= 4.8 && < 5,
304 blaze-builder >= 0.3.3.2 && < 0.5,
312 blaze-builder >= 0.3.3.2 && < 0.5,
305 bytestring,
313 bytestring,
@@ -314,6 +322,7 @@ test-suite verify-eval-terminfo-caps
314
322
315test-suite verify-image-ops
323test-suite verify-image-ops
316 default-language: Haskell2010
324 default-language: Haskell2010
325+ default-extensions: ScopedTypeVariables
317
326
318 type: detailed-0.9
327 type: detailed-0.9
319
328
@@ -328,7 +337,7 @@ test-suite verify-image-ops
328 build-depends: vty,
337 build-depends: vty,
329 Cabal >= 1.20,
338 Cabal >= 1.20,
330 QuickCheck >= 2.7,
339 QuickCheck >= 2.7,
331− random >= 1.0 && < 1.3,
340+ random >= 1.0 && < 1.2,
332 base >= 4.8 && < 5,
341 base >= 4.8 && < 5,
333 bytestring,
342 bytestring,
334 containers,
343 containers,
@@ -341,6 +350,7 @@ test-suite verify-image-ops
341
350
342test-suite verify-image-trans
351test-suite verify-image-trans
343 default-language: Haskell2010
352 default-language: Haskell2010
353+ default-extensions: ScopedTypeVariables
344
354
345 type: detailed-0.9
355 type: detailed-0.9
346
356
@@ -355,7 +365,7 @@ test-suite verify-image-trans
355 build-depends: vty,
365 build-depends: vty,
356 Cabal >= 1.20,
366 Cabal >= 1.20,
357 QuickCheck >= 2.7,
367 QuickCheck >= 2.7,
358− random >= 1.0 && < 1.3,
368+ random >= 1.0 && < 1.2,
359 base >= 4.8 && < 5,
369 base >= 4.8 && < 5,
360 bytestring,
370 bytestring,
361 containers,
371 containers,
@@ -368,6 +378,7 @@ test-suite verify-image-trans
368
378
369test-suite verify-inline
379test-suite verify-inline
370 default-language: Haskell2010
380 default-language: Haskell2010
381+ default-extensions: ScopedTypeVariables
371
382
372 type: detailed-0.9
383 type: detailed-0.9
373
384
@@ -381,7 +392,7 @@ test-suite verify-inline
381 build-depends: vty,
392 build-depends: vty,
382 Cabal >= 1.20,
393 Cabal >= 1.20,
383 QuickCheck >= 2.7,
394 QuickCheck >= 2.7,
384− random >= 1.0 && < 1.3,
395+ random >= 1.0 && < 1.2,
385 base >= 4.8 && < 5,
396 base >= 4.8 && < 5,
386 bytestring,
397 bytestring,
387 containers,
398 containers,
@@ -394,6 +405,7 @@ test-suite verify-inline
394
405
395test-suite verify-parse-terminfo-caps
406test-suite verify-parse-terminfo-caps
396 default-language: Haskell2010
407 default-language: Haskell2010
408+ default-extensions: ScopedTypeVariables
397
409
398 type: detailed-0.9
410 type: detailed-0.9
399
411
@@ -408,7 +420,7 @@ test-suite verify-parse-terminfo-caps
408 build-depends: vty,
420 build-depends: vty,
409 Cabal >= 1.20,
421 Cabal >= 1.20,
410 QuickCheck >= 2.7,
422 QuickCheck >= 2.7,
411− random >= 1.0 && < 1.3,
423+ random >= 1.0 && < 1.2,
412 base >= 4.8 && < 5,
424 base >= 4.8 && < 5,
413 bytestring,
425 bytestring,
414 containers,
426 containers,
@@ -422,6 +434,7 @@ test-suite verify-parse-terminfo-caps
422
434
423test-suite verify-simple-span-generation
435test-suite verify-simple-span-generation
424 default-language: Haskell2010
436 default-language: Haskell2010
437+ default-extensions: ScopedTypeVariables
425
438
426 type: detailed-0.9
439 type: detailed-0.9
427
440
@@ -439,7 +452,7 @@ test-suite verify-simple-span-generation
439 build-depends: vty,
452 build-depends: vty,
440 Cabal >= 1.20,
453 Cabal >= 1.20,
441 QuickCheck >= 2.7,
454 QuickCheck >= 2.7,
442− random >= 1.0 && < 1.3,
455+ random >= 1.0 && < 1.2,
443 base >= 4.8 && < 5,
456 base >= 4.8 && < 5,
444 bytestring,
457 bytestring,
445 containers,
458 containers,
@@ -453,6 +466,7 @@ test-suite verify-simple-span-generation
453
466
454test-suite verify-crop-span-generation
467test-suite verify-crop-span-generation
455 default-language: Haskell2010
468 default-language: Haskell2010
469+ default-extensions: ScopedTypeVariables
456
470
457 type: detailed-0.9
471 type: detailed-0.9
458
472
@@ -470,7 +484,7 @@ test-suite verify-crop-span-generation
470 build-depends: vty,
484 build-depends: vty,
471 Cabal >= 1.20,
485 Cabal >= 1.20,
472 QuickCheck >= 2.7,
486 QuickCheck >= 2.7,
473− random >= 1.0 && < 1.3,
487+ random >= 1.0 && < 1.2,
474 base >= 4.8 && < 5,
488 base >= 4.8 && < 5,
475 bytestring,
489 bytestring,
476 containers,
490 containers,
@@ -484,6 +498,7 @@ test-suite verify-crop-span-generation
484
498
485test-suite verify-layers-span-generation
499test-suite verify-layers-span-generation
486 default-language: Haskell2010
500 default-language: Haskell2010
501+ default-extensions: ScopedTypeVariables
487
502
488 type: detailed-0.9
503 type: detailed-0.9
489
504
@@ -501,32 +516,7 @@ test-suite verify-layers-span-generation
501 build-depends: vty,
516 build-depends: vty,
502 Cabal >= 1.20,
517 Cabal >= 1.20,
503 QuickCheck >= 2.7,
518 QuickCheck >= 2.7,
504− random >= 1.0 && < 1.3,
519+ 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,
520 base >= 4.8 && < 5,
531 bytestring,
521 bytestring,
532 containers,
522 containers,
@@ -539,6 +529,7 @@ test-suite verify-color-mapping
539
529
540test-suite verify-utf8-width
530test-suite verify-utf8-width
541 default-language: Haskell2010
531 default-language: Haskell2010
532+ default-extensions: ScopedTypeVariables
542
533
543 type: detailed-0.9
534 type: detailed-0.9
544
535
@@ -551,7 +542,7 @@ test-suite verify-utf8-width
551 build-depends: vty,
542 build-depends: vty,
552 Cabal >= 1.20,
543 Cabal >= 1.20,
553 QuickCheck >= 2.7,
544 QuickCheck >= 2.7,
554− random >= 1.0 && < 1.3,
545+ random >= 1.0 && < 1.2,
555 base >= 4.8 && < 5,
546 base >= 4.8 && < 5,
556 bytestring,
547 bytestring,
557 containers,
548 containers,
@@ -564,6 +555,7 @@ test-suite verify-utf8-width
564
555
565test-suite verify-using-mock-input
556test-suite verify-using-mock-input
566 default-language: Haskell2010
557 default-language: Haskell2010
558+ default-extensions: ScopedTypeVariables
567
559
568 type: exitcode-stdio-1.0
560 type: exitcode-stdio-1.0
569
561
@@ -571,8 +563,6 @@ test-suite verify-using-mock-input
571
563
572 main-is: VerifyUsingMockInput.hs
564 main-is: VerifyUsingMockInput.hs
573
565
574− other-modules: Verify.Graphics.Vty.Output
575−
576 build-depends: vty,
566 build-depends: vty,
577 Cabal >= 1.20,
567 Cabal >= 1.20,
578 QuickCheck >= 2.7,
568 QuickCheck >= 2.7,
@@ -580,7 +570,7 @@ test-suite verify-using-mock-input
580 quickcheck-assertions >= 0.1.1,
570 quickcheck-assertions >= 0.1.1,
581 test-framework == 0.8.*,
571 test-framework == 0.8.*,
582 test-framework-smallcheck == 0.2.*,
572 test-framework-smallcheck == 0.2.*,
583− random >= 1.0 && < 1.3,
573+ random >= 1.0 && < 1.2,
584 base >= 4.8 && < 5,
574 base >= 4.8 && < 5,
585 bytestring,
575 bytestring,
586 containers,
576 containers,
@@ -599,6 +589,7 @@ test-suite verify-using-mock-input
599
589
600test-suite verify-config
590test-suite verify-config
601 default-language: Haskell2010
591 default-language: Haskell2010
592+ default-extensions: ScopedTypeVariables
602
593
603 type: exitcode-stdio-1.0
594 type: exitcode-stdio-1.0
604
595
@@ -615,7 +606,7 @@ test-suite verify-config
615 test-framework == 0.8.*,
606 test-framework == 0.8.*,
616 test-framework-smallcheck == 0.2.*,
607 test-framework-smallcheck == 0.2.*,
617 test-framework-hunit,
608 test-framework-hunit,
618− random >= 1.0 && < 1.3,
609+ random >= 1.0 && < 1.2,
619 base >= 4.8 && < 5,
610 base >= 4.8 && < 5,
620 bytestring,
611 bytestring,
621 containers,
612 containers,