on 5b4818c help sign in
.gitignore−7
since splitsnapshots
unifiedsplit
@@ -4,12 +4,5 @@
4*.prof
4*.prof
5Setup
5Setup
6dist
6dist
7−dist-newstyle
8−cabal.project.local
9−.ghc.environment.*
10test/benchmark
7test/benchmark
11.hpc
8.hpc
12−.cabal-sandbox
13−cabal.sandbox.config
14−test/cabal.sandbox.config
15−.stack-work
.travis.yml+16−104
@@ -1,109 +1,21 @@
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: 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−
44−before_install:
45− - HC=${CC}
46− - HCPKG=${HC/ghc/ghc-pkg}
47− - unset CC
48− - ROOTDIR=$(pwd)
49− - mkdir -p $HOME/.local/bin
50− - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
51− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
52− - echo $HCNUMVER
53
9
54−install:
10+env:
55− - cabal --version
11+ - GHCVER=6.12.3
56− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
12+ - GHCVER=7.2.2
57− - BENCH=${BENCH---enable-benchmarks}
13+ - GHCVER=7.4.2
58− - TEST=${TEST---enable-tests}
14+ - GHCVER=7.6.3
59− - HADDOCK=${HADDOCK-true}
15+ - GHCVER=head
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
16
81−# Here starts the actual work to be performed for the package under test;
17+before_install:
82−# any command which exits with a non-zero exit code causes the build to fail.
18+ - sudo add-apt-repository -y ppa:hvr/ghc
83−script:
19+ - sudo apt-get update
84− # test that source-distributions can be generated
20+ - sudo apt-get install cabal-install-1.18 ghc-$GHCVER
85− - (cd "." && cabal sdist)
21+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH
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−
97− # build & run tests, build benchmarks
98− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
99− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
100−
101− # haddock
102− - rm -rf ./dist-newstyle
103− - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
104−
105− # Build without installed constraints for packages in global-db
106− - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi
107−
108−# REGENDATA ["vty.cabal"]
109−# EOF
AUTHORS+1−6
@@ -1,6 +1,4 @@
1−The following people should be thanked for contributing to the vty
1+The following people should be thanked for contributing to the vty library:
2−library:
3−
4 * Andrea Vezzosi
2 * Andrea Vezzosi
5 * Corey O'Connor
3 * Corey O'Connor
6 * Emily Backes
4 * Emily Backes
@@ -17,6 +15,3 @@ library:
17 * Mikolaj Konarski
15 * Mikolaj Konarski
18 * Eyal Lotem
16 * Eyal Lotem
19 * Yoshikuni Jujo
17 * Yoshikuni Jujo
20− * Dmitry Ivanov
21−
22−Plus others.. Check the git log and CHANGELOG.md for a full list.
CHANGELOGnew file+143
@@ -0,0 +1,143 @@
1+5.0.0
2+ * all projects using vty must be compiled with -threaded. This can be resolved without API
3+ changes, but I don't know if this matters.
4+ * mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default
5+ configuration.
6+ * input handling changes
7+ * KASCII is now KChar
8+ * KPN5 is now KCenter
9+ * tests exist.
10+ * terminal timing is now handled by selecting an appropriate VTIME. Previously this was
11+ implemented within Vty itself. This reduced complexity in vty but potentially affects
12+ meta key handling.
13+ * The time vty will wait to verify an ESC byte means a single ESC key is the
14+ singleEscPeriod of the Input Config structure.
15+ * The input config can be changed dynamically.
16+ * removed the typeclass based terminal and display context interface in favor of a data
17+ structure of properties interface.
18+ * renamed the Terminal interface to Output
19+ * The default picture for an image now uses the "clear" background. This background fills
20+ background spans with spaces or just ends the line.
21+ * Previously the background defaulted to the space character. This causes issues copying
22+ text from a text editor. The text would end up with many extra spaces at the end of the
23+ line.
24+ * Layer support
25+ * Each layer is an image.
26+ * The layers for a picture are a list of images.
27+ * The first image is the top-most layer.
28+ * The final rendering is as if the bottom layer (last image) was rendered, then the next
29+ (second to last image) etc.
30+ * The transparent areas for a layer are the background image components.
31+ * If the background is clear there is no background layer.
32+ * If there is a background character then the bottom layer is the background layer.
33+ * empty_picture is a Picture with no layers and no cursor
34+ * add_to_top and add_to_bottom add a layer to the top and bottom of the given Picture.
35+ * compatibility improvements:
36+ * terminfo based terminals with no cursor support are silently accepted. The cursor
37+ visibility changes in the Picture will have no effect.
38+ * alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a
39+ guess.
40+ * added "rgb_color" for easy support of RGB specified colors.
41+ * examples moved to vty-examples package. See test directory for cabal file.
42+ * vty-interactive-terminal-test
43+ * interactive test. Useful for building a bug report for vty's author.
44+ * test/interactive_terminal_test.hs
45+ * vty-event-echo
46+ * view a input event log for vty. Example of interacting with user.
47+ * test/EventEcho.hs
48+ * vty-rouge
49+ * A bad rouge-like game. Go from the entrance to exit. Example of layers
50+ and image build operations.
51+ * test/Rouge.hs
52+ * vty-benchmark
53+ * benchmarks vty. A series of tests that push random pictures to the terminal. The
54+ random pictures are generated using QuickCheck. The same generators used in the
55+ automated tests.
56+ * test/benchmark.hs
57+
58+4.7.0.0
59+ * API changes:
60+ * Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size.
61+ * Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size.
62+ * Added Graphics.Vty.Image.translate: Offset an image.
63+ * Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
64+
65+4.3.0.0
66+
67+4.2.1.0
68+ * API changes:
69+ * Attr record accessor fore_color changed to attr_fore_color
70+ * Attr record accessor back_color changed to attr_back_color
71+ * Attr record accessor style changed to attr_style
72+ * Added an "inline" display attribute changing DSL:
73+ * put_attr_change applies a display attribute change immediately to a terminal
74+ * For instance, can be used to change the display attrbiutes of text output via putStrLn
75+ and putStr. EX: "put_attr_change $ back_color red" will set the
76+ background color to red.
77+ * Changes do not apply to a Picture output via output_picture.
78+ * See Graphics.Vty.Inline
79+ * Moved all IO actions into any monad an instance of MonadIO
80+
81+4.0.0.1
82+ * binding for mk_wcswidth was incorrect. Most platforms just magically worked due to
83+ coincidence.
84+
85+4.0.0
86+ * API changes:
87+ * "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an
88+ instance of the Vty data structure.
89+ * added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated
90+ with the Vty instance.
91+ * Graphics.Vty.Types has undergone a number of changes. Summary:
92+ * Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for
93+ image combinators. Graphics.Vty.Picture for final picture construction.
94+ * Graphics.Vty.Attributes:
95+ * "setFG" and "setBG" are now "with_fore_color" and "with_back_color"
96+ * All other "set.." equations similarly replaced.
97+ * "attr" is now "def_attr", short for "default display attributes" Also added a
98+ "current_attr" for "currently applied display attributes"
99+ * Graphics.Vty.Image:
100+ * "horzcat" is now "horiz_cat"
101+ * "vertcat" is now "vert_cat"
102+ * "renderBS" is now "utf8_bytestring"
103+ * "renderChar" is now "char"
104+ * "renderFill" is now "char_fill"
105+ * added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings
106+ and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime
107+ representation.
108+ * Graphics.Vty.Picture:
109+ * exports Graphics.Vty.Image
110+ * "pic" is now "pic_for_image"
111+ * added API for setting background fill pattern.
112+ * Completely rewritten output backend.
113+ * Efficient, scanline style output span generator. Has not been fully optimized, but good
114+ enough.
115+ * The details required to display the desired picture on a terminal are well encapsulated.
116+ * Terminfo based display terminal implementation. With specialized derivitives for xterm,
117+ Terminal.app, and iTerm.app.
118+ * Attempts to robustly handle even terminals that don't support all display attributes.
119+ * I've tested the following terminals with success: iTerm.app, Terminal.app, xterm,
120+ rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be
121+ as successfull.
122+ * Improved unicode support. Double wide characters will display as expected.
123+ * 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted
124+ according to the number of colors the terminal supports.
125+ * The Graphics.Vty.Image combinators no longer require matching dimensions to arguments.
126+ Unspecified areas are filled in with a user-customizable background pattern. See
127+ Graphics.Vty.Picture.
128+ * output images are always cropped to display size.
129+ * Significant code coverage by QuickCheck tests. An interactive test for those final properties
130+ that couldn't be automatically verified.
131+
132+ issues resolved:
133+ * "gnome terminal displays non-basic attributes as strikethrough"
134+ * http://trac.haskell.org/vty/ticket/14
135+ * "Multi-byte characters are not displayed correctly on update"
136+ * http://trac.haskell.org/vty/ticket/10
137+ * "Redraw does not handle rendering a line that extends beyond screen width characters"
138+ * http://trac.haskell.org/vty/ticket/13
139+ * "The <|> and <-> combinators should be more forgiving of mismatched dimensions"
140+ * http://trac.haskell.org/vty/ticket/9
141+ * "256-color support"
142+ * http://trac.haskell.org/vty/ticket/19
143+
CHANGELOG.mddeleted−861
@@ -1,861 +0,0 @@
1−
2−5.35.1
3−------
4−
5−Bug fixes:
6− * Fixed a build issue with a test program.
7−
8−5.35
9−----
10−
11−New features:
12− * Add support for 24-bit color (thanks @u-quark). This change
13− updates Vty to look at the `COLORTERM` environment variable that is
14− conventionally used to advertise support for truecolor escape
15− sequences. The change also updates the Vty demo to demonstrate
16− 24-bit colors. This change also adds a new data type, `ColorMode`,
17− to represent the color mode in use, as well as an `Output` interface
18− field, `outputColorMode`, to track the active color mode and use it
19− to clamp emitted color escape sequences to the active color range.
20−
21−API changes:
22− * All types in `Graphics.Vty.Input.Events` now have strict constructor
23− fields.
24− * Internal events are now wrapped in a new `InternalEvent` type to
25− improve how signal handling is done. This change modifies the `Input`
26− type's event channel API to produce `InternalEvents`, not `Events`.
27− The new `InternalEvent` either wraps `Event` with the `InputEvent`
28− constructor (the previous behavior) or indicates that Vty resumed
29− after handling a signal using the `ResumeAfterSignal` constructor.
30− This change avoids the previous use of `EvResize` with lazy exception
31− arguments as a sentinel value for `ResumeAfterSignal`.
32−
33−Other enhancements:
34− * Bracketed paste parsing performance has been greatly improved thanks
35− to benchmarking and optimization work by @iphydf. As part of that
36− work, Vty now uses bytestrings rather than Strings internally when
37− parsing input to look for events.
38− * The `\b` value is now interpreted as `KBS` (thanks @vglfr)
39−
40−5.34
41−----
42−
43−API changes:
44− * Added an `NFData` instance for `Event` (thanks Mario Lang)
45− * Removed `Monoid` and `Semigroup` instances for `Attr` and
46− `MaybeDefault`. This change removed the instances because they were
47− misbehaved; merging `Attr` and `MaybeDefault` values with these
48− instances resulted in field value losses. For example, before this
49− change,
50−```
51−(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)
52−```
53− would result in just
54−```
55− (defAttr `withBackColor` green)
56−```
57− because the instances were designed to favor the right-hand
58− arguments' fields even if they had not been explicitly set
59− (a consequence of the `MaybeDefault` `Semigroup` instance).
60− While that behavior was sensible specifically in the context of
61− `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made
62− for surprising instance behavior. Since there is actually no good way
63− to handle this in a `Semigroup` instance for `Attr` -- some choices
64− have to be made about how to merge two attributes' foreground colors,
65− and that won't be much better than what we had -- the instance was
66− just removed.
67−
68−
69−5.33
70−----
71−
72−API changes:
73−* The `Cursor` type got a new `PositionOnly` constructor for cursor
74− placement without visibility.
75−
76−Package changes:
77−* Relaxed upper bound for `random`
78−* Updated `microlens` bounds to allow 0.4.12
79−
80−Other improvements:
81−* Various hlint-driven improvements (thanks Willem Van Onsem)
82−* The implementation of `color240` was improved (thanks (Willem Van
83− Onsem)
84−
85−5.32
86−----
87−
88−New features:
89− * Meta-PageUp and Meta-PageDown are now supported (#193)
90− * Added `supportsItalics` and `supportsStrikethrough` functions to
91− check for feature support in terminfo
92−
93−Bug fixes:
94− * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka
95− Nkurumeh)
96−
97−5.31
98−----
99−
100−New features and API changes:
101− * Added support for strikethrough mode. This change adds a new
102− `strikethrough` `Style` value and uses the `smxx` and `rmxx`
103− Terminfo capabilities to activate and deactivate strikethrough mode,
104− respectively. If the terminfo does not report those capabilities,
105− this style is ignored.
106− * `Output`: added the `setDisplayBounds` field to set the output
107− dimensions of the output handle; added an implementation of this for
108− the `TerminfoBased` backend.
109−
110−Other changes:
111− * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.
112−
113−5.30
114−----
115−
116−New features:
117− * Added `Graphics.Vty.setWindowTitle` to emit an escape
118− sequence to set the window title, provide the terminal emulator
119− accepts Xterm-style title sequences. For details, see:
120− https://tldp.org/HOWTO/Xterm-Title-3.html
121−
122−5.29
123−----
124−
125−API changes:
126− * The Input type got a new field, 'restoreInputState'. This field
127− allows the end user to have direct access to the logic needed to
128− restore the terminal's input state flags. Prior to having this field,
129− this state restoration logic could only be invoked as part of calling
130− 'shutdownInput', but since that function does other things (like
131− killing threads) it is not advisable to call it repeatedly (which is
132− necessary in the use case this change is intended to support). This
133− can be called directly to restore the input state flags as needed,
134− although this is not required if 'shutdown' (or 'shutdownInput') is
135− called.
136−
137−Other changes:
138− * attributeControl: explicitly enable the ICRNL terminal mode flag (see
139− #187 and c572ad).
140−
141−5.28.2
142−------
143−
144−Bug fixes:
145− * Added a package dependency on `semigroups` for the
146− `vty-build-width-table` tool on older GHCs (#185)
147−
148−5.28.1
149−------
150−
151−Bug fixes:
152− * `installUnicodeWidthTable`: use `throwIO`, not `throw`
153−
154−5.28
155−----
156−
157−This release improves Vty's support for multi-column Unicode characters
158−and provides greater compatibility with a wider array of terminal
159−emulators. The following sections summarize the relevant changes, but an
160−overview of the new functionality is motivated and detailed in the new
161−"Multi-Column Character Support" README section. For
162−historical context, please also consider reading over
163−[#175](https://github.com/jtdaugherty/vty/issues/175).
164−
165−API changes:
166− * New modules were added:
167− * `Graphics.Vty.UnicodeWidthTable.Types`
168− * `Graphics.Vty.UnicodeWidthTable.IO`
169− * `Graphics.Vty.UnicodeWidthTable.Query`
170− * `Graphics.Vty.UnicodeWidthTable.Install`
171− * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,
172− that controls whether `mkVty` will attempt to load a Unicode width
173− table if specified in the configuration.
174−
175−Configuration file changes:
176− * A new syntax was added to support specifying Unicode width tables on
177− a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the
178− documentation for `Graphics.Vty.Config` for details. Since prior
179− versions of this library will silently ignore any configuration file
180− lines they cannot parse, this change to user configuration files is
181− at least non-breaking for older versions of Vty.
182−
183−Other changes:
184− * The `mkVty` function now automatically attempts to load a custom
185− Unicode width table if one is specified in the configuration,
186− provided `allowCustomUnicodeWidthTables` is not set to `Just False`.
187− See the documentation for `Graphics.Vty.mkVty` for details.
188− * Vty now includes a command line tool, `vty-build-width-table`, that
189− queries the terminal emulator to construct a custom Unicode width
190− table and optionally update the Vty configuration file to use it.
191− Programs that want to use that tool's functionality may also do so
192− via the API exposed in the various modules listed above.
193−
194−5.27
195−----
196−
197−* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the
198− kernel for the current terminal's settings to obtain the character
199− assigned by the `stty erase` command. That can then be added to the
200− Vty configuration's input map to map to `KBS` (backspace) if desired.
201−
202−5.26
203−----
204−
205−* Resolved various import warnings (thanks @glguy)
206−* Removed the `MonadIO` constraint from the Output type's fields and
207− removed `MonadFail` uses (PR #177, thanks @glguy)
208−* Clarified documentation for ANSI colors (thanks Colby Jenn)
209−* `Graphics.Vty.Attributes` no longer re-exports
210− `Graphics.Vty.Attributes.Color`
211−* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks
212− Colby Jenn)
213−* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)
214−* Changed from using `System.Posix.Env.getEnv` to
215− `System.Environment.lookupEnv` (thanks Jonathan Osser)
216−* Added `Graphics.Vty.Image` functions for dealing with character width
217− computations on `Text` values instead of `Strings`:
218− * `safeWctwidth`
219− * `safeWctlwidth`
220− * `wctwidth`
221− * `wctlwidth`
222−
223−5.25.1
224−------
225−
226−* Avoided a conflict with a Microlens 0.4.10 operator and added an
227− upper bound on Microlens of 0.4.11.
228−
229−5.25
230−----
231−
232−* The Vty type got a new field, isShutdown, that returns whether the
233− Vty handle has had its 'shutdown' function called (thanks Ian
234− Jeffries)
235−* Vty's shutdown function is now thread-safe.
236−
237−5.24.1
238−------
239−
240−* The "shutdown" method of Vty handles is now idempotent (#159)
241−
242−5.24
243−----
244−
245−* Add Generic and NFData instances for some types
246−* Image: remove custom Show instance, add derived Show and Read
247− instances
248−* Updated Travis build settings (thanks Eric Mertens)
249−
250−5.23.1
251−------
252−
253−* Fixed a bug where italics did not combine properly with other display
254− modes (#155, thanks Eric Mertens)
255−
256−5.23
257−----
258−
259−* Added support for italicized output when terminfo supports it. This
260− takes the form of a new Style, "italic". Note that most terminfo
261− descriptors do not report capabilities for italics, so support for
262− this will be very spotty.
263−* Updateed text/string function documentation to indicate that escapes
264− are not permitted in their inputs.
265−
266−5.22
267−----
268−
269−* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function
270− (thanks Brent Carmer)
271−* Added nextEventNonblocking function (field) to Vty type (#87)
272−
273−5.21
274−----
275−
276−* Picture and Background now provide Eq instances (thanks Jaro Reinders)
277−* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)
278−* #142: note requirement of threaded RTS
279−
280−5.20
281−----
282−
283−API changes:
284−* Split up Monoid instances into Monoid and Semigroup for newer GHCs
285− (thanks Ryan Scott)
286−
287−5.19.1
288−------
289−
290−API changes:
291−* Cursor now provides an Eq instance (thanks Jaro Reinders)
292−
293−5.19
294−----
295−
296−API changes:
297−* URL hyperlinking (via 'withURL') is now optional and disabled by
298− default due to poor support on some common terminals. A new 'Mode'
299− constructor, 'Hyperlink', has been added to enable this feature. To
300− change the hyperlinking mode, use 'setMode' on the 'outputIface' of a
301− Vty handle.
302−
303−5.18.1
304−------
305−
306−Bug fixes:
307−* Reset the hyperlink state on line endings to avoid run-on hyperlinks
308−
309−5.18
310−----
311−
312−API changes:
313−* Added support for hyperlinking attributes (thanks Getty Ritter). This
314− change adds a new Attr field for containing the hyperlink to apply,
315− as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda
316−
317−5.17.1
318−------
319−
320−* withStyle now ignores zero arguments, leaving attribute styles
321− untouched if the input style is the null style
322−
323−5.17
324−----
325−
326−API changes:
327−* Add support for terminal focus events. This change adds a new mode
328− usable with setMode, Focus, that requests that the terminal send
329− events on focus lose/gain. This change also adds two new Event
330− constructors, EvLostFocus and EvGainedFocus.
331−* No longer enable UTF8 mouse event encoding. This encoding was not
332− working properly with Terminal.app, and using the other modes (SGR,
333− etc.) work.
334−* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
335− #131)
336−
337−5.16
338−----
339−
340−API changes:
341−* Added support for mouse wheel events while in mouse mode. The Button
342− type got two new constructors as a result: BScrollUp and BScrollDown.
343− Thanks to doublescale@tutanota.com for this contribution!
344−
345−Bug fixes:
346−* charFill now clamps negative arguments to zero (thanks Eric Mertens!)
347−
348−5.15.1
349−------
350−
351−Package changes:
352−* Documentation files are now marked accordingly (thanks Michal
353− Suchánek)
354−
355−Bug fixes:
356−* translateX/Y: fix negative translations
357−
358−5.15
359−----
360−
361−Package changes:
362−* Discontinued support for GHC versions prior to 7.10.1.
363−* Removed instructions and configuration for Stack builds since they
364− are no longer supported.
365−* Clarified README mention of (lack of) Windows support (contributors
366− wanted, though!)
367−* Removed dependency on data-default (see below).
368−
369−API changes:
370−* Moved color definitions from Attributes to Color module.
371−* In lieu of data-default (Default) instances for Attr and Config, use
372− 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.
373−* Graphics.Vty.Output no longer re-exports
374− Graphics.Vty.Output.Interface.
375−* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its
376− accessors to Graphics.Vty.Image.
377−* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.
378−* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.
379−
380−5.14
381−----
382−
383−* addMaybeClippedJoin: instead of raising an exception when the join
384− is totally clipped, just reduce the clip amount and continue
385−* addMaybeClipped: skip blit of joins when their primary dimension is
386− zero
387−* '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
389− possible to use 'str ""' as a non-empty image with height 1.
390−
391−5.13
392−----
393−
394−* Reverted changes in 5.12 due to disagreements between terminal
395− emulators and utf8proc; for more details, please see the ticket
396− discussion at
397− https://github.com/coreyoconnor/vty/issues/115
398−
399−5.12
400−----
401−
402−* Replaced 'wcwidth' with a call to the utf8proc library's character
403− 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
405− characters.
406−* Added a bundled version of the utf8proc C library.
407−
408−5.11.3
409−------
410−
411−* Fix mouse event offsets in mouse-up events
412−
413−5.11.2
414−------
415−
416−* Mouse events were modified so that the upper-left corner of the window
417− is (0,0) rather than (1,1).
418−
419−5.11.1
420−------
421−
422−* Add Generic instance for Image
423−* nextEvent: stop trying to refresh on a resize event (fixes segfault
424− on refresh with normal cursor positioning mode)
425−* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)
426−* Update maintainer
427−
428−5.11
429−----
430−
431−* Vty now raises a VtyConfigurationError exception when the TERM
432− evironment variable is missing (thanks Eric Mertens)
433−* Graphics.Vty.Config got an explicit export list to avoid accidentally
434− exporting internal types (thanks Eric Mertens)
435−
436−5.10
437−----
438−
439−* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This
440− mode provides greater control over cursor positioning by bypassing
441− the logical positioning provided by default. Rather than positioning
442− the cursor by looking at the widths of characters involved, this
443− constructor lets you provide a physical row and column instead. This
444− is useful in more sophisticated programs. (thanks Eric Mertens)
445−* Added a new Generic-derived config parser (thanks Eric Mertens)
446−* Fixed the MShift case in the configuration file parser (thanks Eric
447− Mertens)
448−* Fixed wcwidth import and matched safeWcswidth to its documented
449− behavior. Previously vty_mk_wcwidth was being imported with the
450− wrong type causing the -1 return value to be mapped to the wrong Int
451− value. Additionally safeWcswidth was using the unsafe character width
452− function and only ensuring that the final result was non-negative.
453− (thanks Eric Mertens)
454−
455−5.9.1
456−-----
457−
458−* Vty now only emits UTF8 charset sequences in terminals without a
459− preexisting UTF8 declaration to avoid emitting garbage sequences
460− (fixes #89)
461−
462−5.9
463−---
464−
465−* Added new Output methods supportsBell and ringTerminalBell to find out
466− whether the output device has an audio bell and to ring it (see #102)
467−
468−5.8.1
469−-----
470−
471−* Fixed "refresh" to work as advertised (see #104)
472−
473−5.8
474−---
475−
476−* 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
478− best to decode it
479−
480−5.7.1
481−-----
482−
483−* ModeDemo: added an explicit Control.Applicative import for older GHCs
484−
485−5.7
486−---
487−
488−* Mouse and paste modes are now off by default.
489−* The Config type got new fields: mouseMode and bracketedPasteMode.
490− These determine whether these modes are enabled initially (for
491− terminals that support them).
492−* Added a Mode type for modal terminal features (mouse events,
493− bracketed paste mode) that is used with new Output interface
494− functions:
495− * supportsMode :: Mode -> Bool tells whether the device supports a
496− mode
497− * setMode :: Mode -> Bool -> IO () turns a mode on or off
498− * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or
499− off
500−* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes
501−
502−5.6
503−---
504−
505−* Added support for normal and extended mouse modes in Xterm-like
506− terminals via the MouseDown and MouseUp Event constructors
507−* Added support for bracketed paste mode in Xterm-like terminals via
508− the EvPaste event constructor
509−* Added derived Show instances for Event and Button (thanks Felix
510− Hirn)
511−* Now TERM values containing "screen" will automatically use the
512− XtermColor driver rather than just TerminfoBased
513−
514−5.5.0
515−-----
516−
517−* Replaced lens dependency with microlens, microlens-mtl, microlens-th
518− dependencies. Issue #90
519− * Thanks Jonathan Daugherty
520−* Cabal corrections.
521− * Thanks Lennart Spitzner
522−
523−5.4.0
524−-----
525−
526−* Changed eventChannel of Graphics.Vty.Input from Chan to
527− TChan. This enables clients to query if there are no pending
528− events. The Graphics.Vty interface nextEvent is unchanged.
529− Clients that use eventChannel directly will require updating.
530− https://github.com/coreyoconnor/vty/issues/60
531−
532−5.3.1
533−-----
534−
535−* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to
536− possibly breaking this on reasonable GHC versions
537−
538−5.3
539−---
540−
541−* Upgraded QuickCheck dependency to 2.7
542−* The standard IO Config (standardIOConfig) was overriding any provided
543− application config. In addition, the inputFd and outputFd could not be
544− changed if mkVty was used. Fixed.
545−* 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
547− 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
549− was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi
550− requires the old behavior to display the selection region correctly.
551−* shutdown of the input thread is now performed using killThread and
552− synchronization on an MVar. For correct handling of the terminal read
553− vmin and vtime the read must be a blocking read on an OS thread.
554− This places a threadWaitRead, which will be interrupted by the
555− killThread, prior to the uninterruptable read. An alternative would be
556− to re-import the read foreign call as interruptable.
557−
558−5.2.11
559−------
560−
561−* deepseq bounds increased for tests.
562−* Clean up warnings when compiling on 7.10
563− * Thanks Eric Mertens
564−* Avoid discarding input bytes after multi-byte encoded codepoint
565− * Thanks Eric Mertens
566−
567−5.2.10
568−------
569−
570−* "str" now returns EmptyImage for empty strings to match behavior of
571− other string-like Image constructors (fixes #74)
572− * Thanks Jonathan Daugherty
573−
574−5.2.9
575−-----
576−
577−* dependency version bumps
578− * https://github.com/coreyoconnor/vty/pull/71
579− * https://github.com/coreyoconnor/vty/pull/70
580−* Correct/Simplify the example code
581− * Thanks glguy
582− * https://github.com/coreyoconnor/vty/pull/69
583−
584−5.2.8
585−-----
586−
587−* blaze-builder, lens, utf8-string version constraint bump
588− * Thanks glguy
589− * https://github.com/coreyoconnor/vty/pull/67
590−* Do not differentiate based on TERM_PROGRAM
591− * https://github.com/coreyoconnor/vty/issues/68
592−
593−5.2.7
594−-----
595−
596−* lens and deepseq constraint bump + misc
597− * Thanks ethercrow
598− * https://github.com/coreyoconnor/vty/pull/66
599−
600−5.2.6
601−-----
602−
603−* lens constraint bump
604− * Thanks alexander-b!
605− * https://github.com/coreyoconnor/vty/pull/64
606−
607−5.2.5
608−-----
609−
610−* lens and random version constraint bump.
611− * Thanks RyanGlScott!
612− * https://github.com/coreyoconnor/vty/pull/62
613−
614−5.2.4
615−-----
616−
617−* removed -fpic from cc-options. No longer required.
618− * https://github.com/coreyoconnor/vty/issues/61
619− * https://ghc.haskell.org/trac/ghc/ticket/9657
620− * Thanks Fuuzetsu!
621−
622−5.2.3
623−-----
624−
625−* evaluate/compile the input parsing table once instead of each
626− keystroke.
627− * https://github.com/coreyoconnor/vty/pull/59
628− * Thanks ethercrow!
629−
630−5.2.2
631−-----
632−
633−* When looking at input for an event, don't look too deep.
634− * https://github.com/coreyoconnor/vty/pull/57
635− * Thanks ethercrow!
636−
637−5.2.1
638−-----
639−
640−* Bump upper version bound for lens to 4.5. Thanks markus1189!
641−
642−5.2.0
643−-----
644−
645−* Config structure now specifies file descriptor to use. The default
646− is stdInput and stdOutput file descriptors. Previously Vty used
647− stdInput for input and the follow code for output:
648− * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`
649− NoBuffering)
650− * the difference was required by Vty.Inline. Now, Vty.Inline uses
651− the Config structure options to acheive the same effect.
652−* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,
653− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO
654−* added: inputForConfig, outputForConfig
655−* updates to vty-rogue from jtdaugherty. Thanks!
656−* 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
658−
659−5.1.4
660−-----
661−
662−* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
663−
664−5.1.1
665−-----
666−
667−* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
668−* jtdaugherty resolved a number of compiler warnings. Thanks!
669−
670−5.1.0
671−-----
672−
673−* vmin and vtime can be specified however the application requires.
674− See Graphics.Vty.Config.
675−* fixed the processing of input when vmin is set > 1.
676−
677−5.0.0
678−-----
679−
680−* The naming convention now matches:
681− * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
682−* all projects using vty for input must be compiled with -threaded.
683− Please notify vty author if this is not acceptable.
684−* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized
685− vty with the default configuration.
686−* input handling changes
687− * KASCII is now KChar
688− * KPN5 is now KCenter
689− * tests exist.
690− * Applications can add to the input tables by setting inputMap of
691− the Config. See Graphics.Vty.Config
692− * Users can define input table extensions that will apply to all vty
693− applications. See Graphics.Vty.Config
694− * terminal timing is now handled by selecting an appropriate VTIME.
695− Previously this was implemented within Vty itself. This reduced
696− complexity in vty but provides a different meta key behavior and
697− implies a requirement on -threaded.
698− * The time vty will wait to verify an ESC byte means a single ESC
699− key is the singleEscPeriod of the Input Config structure.
700−* removed the typeclass based terminal and display context interface
701− in favor of a data structure of properties interface.
702−* renamed the Terminal interface to Output
703−* The default picture for an image now uses the "clear" background.
704− This background fills background spans with spaces or just ends the
705− line.
706− * Previously the background defaulted to the space character. This
707− causes issues copying text from a text editor. The text would end
708− up with extra spaces at the end of the line.
709−* Layer support
710− * Each layer is an image.
711− * The layers for a picture are a list of images.
712− * The first image is the top-most layer. The images are ordered from
713− top to bottom.
714− * The transparent areas for a layer are the backgroundFill areas.
715− backgroundFill is added to pad images when images of different
716− sizes are joined.
717− * If the background is clear there is no background layer.
718− * If there is a background character then the bottom layer is the
719− background layer.
720− * emptyPicture is a Picture with no layers and no cursor
721− * addToTop and addToBottom add a layer to the top and bottom of the
722− given Picture.
723−* compatibility improvements:
724− * terminfo based terminals with no cursor support are silently
725− accepted. The cursor visibility changes in the Picture will have
726− no effect.
727− * alternate (setf/setb) color maps supported. Though colors beyond
728− the first 8 are just a guess.
729− * added "rgbColor" for easy support of RGB specified colors.
730− * Both applications and users can add to the mapping used to
731− translate from input bytes to events.
732−* Additional information about input and output process can be
733− appended to a debug log
734− * Set environment variable VTY_DEBUG_LOG to path of debug log
735− * Or use "debugLog <path>" config directive
736− * Or set 'debugLog' property of the Config provided to mkVty.
737−* examples moved to vty-examples package. See test directory for cabal
738− file.
739− * vty-interactive-terminal-test
740− * interactive test. Useful for building a bug report for vty's
741− author.
742− * test/interactive_terminal_test.hs
743− * vty-event-echo
744− * view a input event log for vty. Example of interacting with
745− user.
746− * test/EventEcho.hs
747− * vty-rogue
748− * The start of a rogue-like game. Example of layers and image
749− build operations.
750− * test/Rogue.hs
751− * vty-benchmark
752− * benchmarks vty. A series of tests that push random pictures to
753− the terminal. The random pictures are generated using
754− QuickCheck. The same generators used in the automated tests.
755− * test/benchmark.hs
756−
757−4.7.0.0
758−-------
759−
760−API changes:
761−* Added Graphics.Vty.Image.crop: Ensure an image is no larger
762− than the specified size.
763−* Added Graphics.Vty.Image.pad: Ensure an image is no smaller
764− than the specified size.
765−* Added Graphics.Vty.Image.translate: Offset an image.
766−* Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
767−
768−4.2.1.0
769−-------
770−
771−API changes:
772−* Attr record accessor fore_color changed to attr_fore_color
773−* Attr record accessor back_color changed to attr_back_color
774−* Attr record accessor style changed to attr_style
775−* Added an "inline" display attribute changing DSL:
776− * put_attr_change applies a display attribute change
777− immediately to a terminal
778− * For instance, can be used to change the display attrbiutes
779− of text output via putStrLn and putStr. EX:
780− "put_attr_change $ back_color red" will set the background
781− color to red.
782− * Changes do not apply to a Picture output via output_picture.
783− * See Graphics.Vty.Inline
784−* Moved all IO actions into any monad an instance of MonadIO
785−
786−4.0.0.1
787−-------
788−
789−* binding for mk_wcswidth was incorrect. Most platforms just
790− magically worked due to coincidence.
791−
792−4.0.0
793−-----
794−
795−API changes:
796−* "getSize" has been removed. Use "terminal vty >>= display_bounds"
797− where "vty" is an instance of the Vty data structure.
798−* added a "terminal" field to the Vty data structure. Accesses the
799− TerminalHandle associated with the Vty instance.
800−* Graphics.Vty.Types has undergone a number of changes. Summary:
801− * Partitioned into Graphics.Vty.Attributes for display attributes.
802− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture
803− for final picture construction.
804−* Graphics.Vty.Attributes:
805− * "setFG" and "setBG" are now "with_fore_color" and
806− "with_back_color"
807− * All other "set.." equations similarly replaced.
808− * "attr" is now "def_attr", short for "default display attributes"
809− Also added a "current_attr" for "currently applied display
810− attributes"
811−* Graphics.Vty.Image:
812− * "horzcat" is now "horiz_cat"
813− * "vertcat" is now "vert_cat"
814− * "renderBS" is now "utf8_bytestring"
815− * "renderChar" is now "char"
816− * "renderFill" is now "char_fill"
817− * added a "utf8_string" and "string" (AKA "iso_10464_string") for
818− UTF-8 encoded Strings and ISO-10464 encoded Strings. String
819− literals in GHC have an ISO-10464 runtime representation.
820−* Graphics.Vty.Picture:
821− * exports Graphics.Vty.Image
822− * "pic" is now "pic_for_image"
823− * added API for setting background fill pattern.
824−* Completely rewritten output backend.
825− * Efficient, scanline style output span generator. Has not been
826− fully optimized, but good enough.
827− * The details required to display the desired picture on a
828− terminal are well encapsulated.
829− * Terminfo based display terminal implementation. With specialized
830− derivitives for xterm, Terminal.app, and iTerm.app.
831− * Attempts to robustly handle even terminals that don't
832− support all display attributes.
833− * I've tested the following terminals with success: iTerm.app,
834− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,
835− konsole, screen, linux vty. Hopefully you will be as
836− successfull.
837− * Improved unicode support. Double wide characters will display as
838− expected.
839−* 256 color support. See Graphics.Vty.Attributes.Color240. The actual
840− output color is adjusted according to the number of colors the
841− terminal supports.
842−* The Graphics.Vty.Image combinators no longer require matching
843− dimensions to arguments. Unspecified areas are filled in with a
844− user-customizable background pattern. See Graphics.Vty.Picture.
845−* output images are always cropped to display size.
846−* Significant code coverage by QuickCheck tests. An interactive test
847− for those final properties that couldn't be automatically verified.
848−
849−Issues resolved:
850−* "gnome terminal displays non-basic attributes as strikethrough"
851− * http://trac.haskell.org/vty/ticket/14
852−* "Multi-byte characters are not displayed correctly on update"
853− * http://trac.haskell.org/vty/ticket/10
854−* "Redraw does not handle rendering a line that extends beyond screen
855− width characters"
856− * http://trac.haskell.org/vty/ticket/13
857−* "The <|> and <-> combinators should be more forgiving of mismatched
858− dimensions"
859− * http://trac.haskell.org/vty/ticket/9
860−* "256-color support"
861− * http://trac.haskell.org/vty/ticket/19
docs/DESIGN → DESIGNrenamed

The content is the same.

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+42−164
@@ -1,201 +1,79 @@
1−[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty)
1+vty is a terminal interface library.
2
2
3−`vty` is a terminal interface library. It provides a high-level
3+Project is hosted on github.com: https://github.com/coreyoconnor/vty
4−interface for doing terminal I/O. Vty is supported on GHC versions
5−7.10.1 and up.
6
4
7−Install via `git` with:
8−
9−```
10−git clone git://github.com/jtdaugherty/vty.git
5+git clone git://github.com/coreyoconnor/vty.git
11−```
12−
13−Install via `cabal` with:
14−
15−```
16−cabal install vty
17−```
18
6
19# Features
7# Features
20
8
21−* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,
9+* Automatic handling of window resizes.
22− `screen`, etc., or anything with a sufficient terminfo entry.
23
10
24−* Automatically handles window resizes.
11+* Supports Unicode characters on output, automatically setting and
12+ resetting UTF-8 mode for xterm. Other terminals are assumed to support
25
13
26−* Supports Unicode output on terminals with UTF-8 support.
14+* Efficient output.
27
15
28−* Provides an efficient output algorithm. Output buffering and terminal
16+* Minimizes repaint area, thus virtually eliminating the flicker
29− state changes are minimized.
17+ problem that plagues ncurses programs.
30
18
31−* Minimizes repaint area, which virtually eliminates the flicker
32− problems that plague ncurses programs.
33−
34−* Provides a pure, compositional interface for efficiently constructing
19+* A pure, compositional interface for efficiently constructing display
35− display images.
20+ images.
36
21
37* Automatically decodes keyboard keys into (key,[modifier]) tuples.
22* Automatically decodes keyboard keys into (key,[modifier]) tuples.
38
23
39* Automatically supports refresh on Ctrl-L.
24* Automatically supports refresh on Ctrl-L.
40
25
41−* Supports a keypress timeout after for lone ESC. The timeout is
26+* Automatically supports timeout after 50ms for lone ESC (a barely
42− customizable.
27+ noticable delay)
43
28
44−* Provides extensible input and output interfaces.
29+* Interface is designed for relatively easy compatible extension.
45
30
46−* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
31+* Supports all ANSI SGR-modes (defined in console_codes(4)) with
47− with a type-safe interface and graceful fallback for terminals
32+ a type-safe interface.
48− with limited or nonexistent support for such modes.
49
33
50−* Properly handles cleanup (but not due to signals).
34+* Properly handles cleanup, but not due to signals.
51
35
52−* Provides a comprehensive test suite.
36+# Known Issues
53
37
54−* Supports "normal" and "extended" (SGR) mouse modes as described at
38+* Signal handling of STOP, TERM and INT are non existent.
55− http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
56
39
57−* Supports bracketed paste mode as described at
40+* The character encoding of the terminal is assumed to be UTF-8.
58− http://cirw.in/blog/bracketed-paste
59
41
60−* Supports multi-column Unicode characters such as emoji characters. In
42+* Terminfo is assumed to be correct unless the terminal (as declared by TERM) starts with xterm or
61− cases where Vty and your terminal emulator disagree on character
43+ ansi. This means that some terminals will not have correct special key support (shifted F10 etc)
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
44
66−# Development Notes
45+* Uses the TIOCGWINSZ ioctl to find the current window size, which
67−
46+ appears to be limited to Linux and *BSD.
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
47
71# Platform Support
48# Platform Support
72
49
73## Posix Terminals
50## Posix Terminals
74
51
75−For the most part, Vty uses `terminfo` to determine terminal protocol
52+Uses terminfo to determine terminal protocol. Some special rules for Mac terminal applications. The
76−with some special rules to handle some omissions from `terminfo`.
53+special rules might be invalid on newer Mac OS.
77
54
78## Windows
55## Windows
79
56
80−Windows is not supported.
57+None!
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−
161−# Contributing
162−
163−If you decide to contribute, that's great! Here are some guidelines you
164−should consider to make submitting patches easier for all concerned:
165−
166− - If you want to take on big things, talk to me first; let's have a
167− design/vision discussion before you start coding. Create a GitHub
168− issue and we can use that as the place to hash things out.
169− - If you make changes, make them consistent with the syntactic
170− conventions already used in the codebase.
171− - Please provide Haddock documentation for any changes you make.
172−
173−# Known Issues
174
58
175−* Terminals have numerous quirks and bugs, so mileage may vary. Please
59+# Development Notes
176− report issues as you encounter them and provide details on your
177− terminal emulator, operating system, etc.
178−
179−* STOP, TERM and INT signals are not handled.
180
60
181−* The character encoding of the terminal is assumed to be UTF-8 if
61+## Coverage
182− unicode is used.
183
62
184−* Terminfo is assumed to be correct unless there is an override
63+Profiling appears to cause issues with coverage when enabled. To evaluate coverage configure as
185− configured. Some terminals will not have correct special key support
64+follows:
186− (shifted F10 etc). See `Config` for customizing vty's behavior for a
187− particular terminal.
188
65
189−* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which
66+~~~
190− appears to be limited to Linux and BSD.
67+rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \
68+ --disable-library-profiling \
69+ --disable-executable-profiling
70+~~~
191
71
192−# Further Reading
72+## Profiling
193
73
194−Good sources of documentation for terminal programming are:
195
74
196−* https://github.com/b4winckler/vim/blob/master/src/term.c
75+~~~
197−* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
76+rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
198−* http://ulisse.elettra.trieste.it/services/doc/serial/config.html
77+ --enable-library-profiling \
199−* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html
78+ --enable-executable-profiling
200−* http://www.unixwiz.net/techtips/termios-vmin-vtime.html
79+~~~
201−* http://vt100.net/docs/vt100-ug/chapter3.html
TODOnew file+15
@@ -0,0 +1,15 @@
1+- Improve input handling
2+ - base off of haskeline input system. The haskeline input system appears to be excellent and
3+ satisfy all of Vty's input requirements. The current haskeline distribution does not appear to
4+ export the required modules. Either:
5+ 0. Add the required exports to the haskeline distribution.
6+ - fine for development but complicates the UI for production clients. Though, exposing
7+ the modules would only complicate the appearance of haskeline's interface.
8+ 1. Partition the backend of haskeline into a separate package usable by both vty and
9+ haskeline.
10+- use compact-string for character encoding handling
11+- Custom cursor appearance handling?
12+ - specific color?
13+ - reverse video?
14+ - auto?
15+
build_examplesnew file+2
@@ -0,0 +1,2 @@
1+#!/bin/bash
2+(cd test && cabal build)
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+6−15
@@ -1,18 +1,9 @@
1#include <sys/ioctl.h>
1#include <sys/ioctl.h>
2
2
3−unsigned long vty_c_get_window_size(int fd) {
3+unsigned long vty_c_get_window_size(void) {
4− struct winsize w;
4+ struct winsize w;
5− if (ioctl (fd, TIOCGWINSZ, &w) >= 0)
5+ if (ioctl (0, 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+97−126
@@ -59,29 +59,7 @@
59 * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c
59 * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c
60 */
60 */
61
61
62−#include <HsFFI.h>
62+#include <wchar.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;
@@ -89,7 +67,7 @@ struct interval {
89};
67};
90
68
91/* auxiliary function for binary search in interval table */
69/* auxiliary function for binary search in interval table */
92−static int vty_bisearch(HsChar ucs, const struct interval *table, int max) {
70+static int vty_bisearch(wchar_t ucs, const struct interval *table, int max) {
93 int min = 0;
71 int min = 0;
94 int mid;
72 int mid;
95
73
@@ -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+int vty_mk_wcwidth(wchar_t 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 */
@@ -225,114 +203,107 @@ static HsInt builtin_wcwidth(HsChar ucs)
225 (ucs >= 0x30000 && ucs <= 0x3fffd)));
203 (ucs >= 0x30000 && ucs <= 0x3fffd)));
226}
204}
227
205
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
206
247−// Initialize a custom character width table.
207+int vty_mk_wcswidth(const wchar_t *pwcs, size_t n)
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{
208{
260− if (custom_table == NULL) {
209+ int w, width = 0;
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
210
275−// Set the specified character range in the custom width table to the
211+ for (;n-- > 0; pwcs++)
276−// specified width.
212+ if ((w = vty_mk_wcwidth(*pwcs)) < 0)
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;
213+ return -1;
294− } else {
214+ else
295− memset(custom_table + start, width, size);
215+ width += w;
296− return 0;
297− }
298−}
299
216
300−// Mark the allocated custom character width table as ready for use.
217+ return width;
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}
218}
317
219
318−// Returns whether a custom character width table has been marked ready.
220+
319−int vty_custom_table_ready()
221+/*
222+ * The following functions are the same as mk_wcwidth() and
223+ * mk_wcswidth(), except that spacing characters in the East Asian
224+ * Ambiguous (A) category as defined in Unicode Technical Report #11
225+ * have a column width of 2. This variant might be useful for users of
226+ * CJK legacy encodings who want to migrate to UCS without changing
227+ * the traditional terminal character-width behaviour. It is not
228+ * otherwise recommended for general use.
229+ */
230+int vty_mk_wcwidth_cjk(wchar_t ucs)
320{
231{
321− return custom_table_ready;
232+ /* sorted list of non-overlapping intervals of East Asian Ambiguous
233+ * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */
234+ static const struct interval ambiguous[] = {
235+ { 0x00A1, 0x00A1 }, { 0x00A4, 0x00A4 }, { 0x00A7, 0x00A8 },
236+ { 0x00AA, 0x00AA }, { 0x00AE, 0x00AE }, { 0x00B0, 0x00B4 },
237+ { 0x00B6, 0x00BA }, { 0x00BC, 0x00BF }, { 0x00C6, 0x00C6 },
238+ { 0x00D0, 0x00D0 }, { 0x00D7, 0x00D8 }, { 0x00DE, 0x00E1 },
239+ { 0x00E6, 0x00E6 }, { 0x00E8, 0x00EA }, { 0x00EC, 0x00ED },
240+ { 0x00F0, 0x00F0 }, { 0x00F2, 0x00F3 }, { 0x00F7, 0x00FA },
241+ { 0x00FC, 0x00FC }, { 0x00FE, 0x00FE }, { 0x0101, 0x0101 },
242+ { 0x0111, 0x0111 }, { 0x0113, 0x0113 }, { 0x011B, 0x011B },
243+ { 0x0126, 0x0127 }, { 0x012B, 0x012B }, { 0x0131, 0x0133 },
244+ { 0x0138, 0x0138 }, { 0x013F, 0x0142 }, { 0x0144, 0x0144 },
245+ { 0x0148, 0x014B }, { 0x014D, 0x014D }, { 0x0152, 0x0153 },
246+ { 0x0166, 0x0167 }, { 0x016B, 0x016B }, { 0x01CE, 0x01CE },
247+ { 0x01D0, 0x01D0 }, { 0x01D2, 0x01D2 }, { 0x01D4, 0x01D4 },
248+ { 0x01D6, 0x01D6 }, { 0x01D8, 0x01D8 }, { 0x01DA, 0x01DA },
249+ { 0x01DC, 0x01DC }, { 0x0251, 0x0251 }, { 0x0261, 0x0261 },
250+ { 0x02C4, 0x02C4 }, { 0x02C7, 0x02C7 }, { 0x02C9, 0x02CB },
251+ { 0x02CD, 0x02CD }, { 0x02D0, 0x02D0 }, { 0x02D8, 0x02DB },
252+ { 0x02DD, 0x02DD }, { 0x02DF, 0x02DF }, { 0x0391, 0x03A1 },
253+ { 0x03A3, 0x03A9 }, { 0x03B1, 0x03C1 }, { 0x03C3, 0x03C9 },
254+ { 0x0401, 0x0401 }, { 0x0410, 0x044F }, { 0x0451, 0x0451 },
255+ { 0x2010, 0x2010 }, { 0x2013, 0x2016 }, { 0x2018, 0x2019 },
256+ { 0x201C, 0x201D }, { 0x2020, 0x2022 }, { 0x2024, 0x2027 },
257+ { 0x2030, 0x2030 }, { 0x2032, 0x2033 }, { 0x2035, 0x2035 },
258+ { 0x203B, 0x203B }, { 0x203E, 0x203E }, { 0x2074, 0x2074 },
259+ { 0x207F, 0x207F }, { 0x2081, 0x2084 }, { 0x20AC, 0x20AC },
260+ { 0x2103, 0x2103 }, { 0x2105, 0x2105 }, { 0x2109, 0x2109 },
261+ { 0x2113, 0x2113 }, { 0x2116, 0x2116 }, { 0x2121, 0x2122 },
262+ { 0x2126, 0x2126 }, { 0x212B, 0x212B }, { 0x2153, 0x2154 },
263+ { 0x215B, 0x215E }, { 0x2160, 0x216B }, { 0x2170, 0x2179 },
264+ { 0x2190, 0x2199 }, { 0x21B8, 0x21B9 }, { 0x21D2, 0x21D2 },
265+ { 0x21D4, 0x21D4 }, { 0x21E7, 0x21E7 }, { 0x2200, 0x2200 },
266+ { 0x2202, 0x2203 }, { 0x2207, 0x2208 }, { 0x220B, 0x220B },
267+ { 0x220F, 0x220F }, { 0x2211, 0x2211 }, { 0x2215, 0x2215 },
268+ { 0x221A, 0x221A }, { 0x221D, 0x2220 }, { 0x2223, 0x2223 },
269+ { 0x2225, 0x2225 }, { 0x2227, 0x222C }, { 0x222E, 0x222E },
270+ { 0x2234, 0x2237 }, { 0x223C, 0x223D }, { 0x2248, 0x2248 },
271+ { 0x224C, 0x224C }, { 0x2252, 0x2252 }, { 0x2260, 0x2261 },
272+ { 0x2264, 0x2267 }, { 0x226A, 0x226B }, { 0x226E, 0x226F },
273+ { 0x2282, 0x2283 }, { 0x2286, 0x2287 }, { 0x2295, 0x2295 },
274+ { 0x2299, 0x2299 }, { 0x22A5, 0x22A5 }, { 0x22BF, 0x22BF },
275+ { 0x2312, 0x2312 }, { 0x2460, 0x24E9 }, { 0x24EB, 0x254B },
276+ { 0x2550, 0x2573 }, { 0x2580, 0x258F }, { 0x2592, 0x2595 },
277+ { 0x25A0, 0x25A1 }, { 0x25A3, 0x25A9 }, { 0x25B2, 0x25B3 },
278+ { 0x25B6, 0x25B7 }, { 0x25BC, 0x25BD }, { 0x25C0, 0x25C1 },
279+ { 0x25C6, 0x25C8 }, { 0x25CB, 0x25CB }, { 0x25CE, 0x25D1 },
280+ { 0x25E2, 0x25E5 }, { 0x25EF, 0x25EF }, { 0x2605, 0x2606 },
281+ { 0x2609, 0x2609 }, { 0x260E, 0x260F }, { 0x2614, 0x2615 },
282+ { 0x261C, 0x261C }, { 0x261E, 0x261E }, { 0x2640, 0x2640 },
283+ { 0x2642, 0x2642 }, { 0x2660, 0x2661 }, { 0x2663, 0x2665 },
284+ { 0x2667, 0x266A }, { 0x266C, 0x266D }, { 0x266F, 0x266F },
285+ { 0x273D, 0x273D }, { 0x2776, 0x277F }, { 0xE000, 0xF8FF },
286+ { 0xFFFD, 0xFFFD }, { 0xF0000, 0xFFFFD }, { 0x100000, 0x10FFFD }
287+ };
288+
289+ /* binary search in table of non-spacing characters */
290+ if (vty_bisearch(ucs, ambiguous,
291+ sizeof(ambiguous) / sizeof(struct interval) - 1))
292+ return 2;
293+
294+ return vty_mk_wcwidth(ucs);
322}
295}
323
296
324−// Deallocate the custom width table.
297+
325−//
298+int vty_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n)
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{
299{
333− if ((custom_table != NULL) && (!custom_table_ready)) {
300+ int w, width = 0;
334− free(custom_table);
301+
335− custom_table = NULL;
302+ for (;n-- > 0; pwcs++)
336− custom_table_size = 0;
303+ if ((w = vty_mk_wcwidth_cjk(*pwcs)) < 0)
337− }
304+ return -1;
305+ else
306+ width += w;
307+
308+ return width;
338}
309}
ci/build-and-testdeleted−44
@@ -1,44 +0,0 @@
1−#!/usr/bin/env bash
2−set -ex
3−
4−source /etc/profile
5−
6−GHCVER=`ghc --version | cut -d' ' -f8`
7−
8−function init-sandbox() {
9− cabal sandbox init
10−}
11−
12−function build() {
13− if [[ "${GHCVER}" > "7.4.2" ]] ; then
14− cabal install --enable-tests --only-dependencies --force-reinstalls
15− else
16− echo "Skipping tests on ${GHCVER}"
17− cabal install --only-dependencies --force-reinstalls
18− fi
19−}
20−
21−function rebuild() {
22− rm -rf dist
23− build
24−}
25−
26−function rebuild-including-deps() {
27− rm -rf .cabal-sandbox
28− rm -rf cabal.sandbox.config
29− init-sandbox
30− build
31−}
32−
33−set -ex
34−
35−cd vty
36−if [[ ! -f cabal.sandbox.config ]] ; then
37− init-sandbox
38−fi
39−
40−build || rebuild || rebuild-including-deps
41−
42−if [[ "${GHCVER}" > "7.4.2" ]] ; then
43− cabal test
44−fi
ci/travis_ci_build_and_testnew file+9
@@ -0,0 +1,9 @@
1+#!/bin/bash
2+set -ex
3+if [[ "${GHCVER}" > "7.4.2" ]] ; then
4+ cabal configure --enable-tests && cabal build
5+ cabal test
6+else
7+ cabal configure && cabal build
8+ echo "Skipping tests on ${GHCVER}"
9+fi
ci/travis_ci_installdeleted−12
@@ -1,12 +0,0 @@
1−#!/bin/bash
2−set -ex
3−cabal --version
4−
5−GHC_IS_OLD=$(python -c "from distutils.version import StrictVersion as SV; print '$GHCVER' != 'head' and SV('$GHCVER') < SV('7.2.3')")
6−
7−if [[ "False" == "$GHC_IS_OLD" ]] ; then
8− /opt/cabal/${CABALVER}/bin/cabal install --only-dependencies --enable-tests
9−else
10− /opt/cabal/${CABALVER}/bin/cabal install --only-dependencies
11− echo "Skipping test dependency install on ${GHCVER}"
12−fi
ci/travis_ci_scriptdeleted−11
@@ -1,11 +0,0 @@
1−#!/bin/bash
2−set -ex
3−
4−GHC_IS_OLD=$(python -c "from distutils.version import StrictVersion as SV; print '$GHCVER' != 'head' and SV('$GHCVER') < SV('7.2.3')")
5−
6−if [[ "False" == "$GHC_IS_OLD" ]] ; then
7− /opt/cabal/${CABALVER}/bin/cabal configure --enable-tests && /opt/cabal/${CABALVER}/bin/cabal build && /opt/cabal/${CABALVER}/bin/cabal test
8−else
9− echo "Skipping tests on ${GHCVER}"
10− /opt/cabal/${CABALVER}/bin/cabal configure && /opt/cabal/${CABALVER}/bin/cabal build
11−fi
demos/Demo.hsdeleted−90
@@ -1,90 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−module Main where
3−
4−import Graphics.Vty
5−
6−import Control.Applicative hiding ((<|>))
7−import Control.Arrow
8−import Control.Monad.RWS
9−
10−import Data.Sequence (Seq, (<|) )
11−import qualified Data.Sequence as Seq
12−import Data.Foldable
13−
14−eventBufferSize = 1000
15−
16−type App = RWST Vty () (Seq String) IO
17−
18−main = do
19− vty <- if True -- change to false for emacs-like input processing
20− then mkVty defaultConfig
21− else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )
22− _ <- execRWST (vtyInteract False) vty Seq.empty
23− shutdown vty
24−
25−vtyInteract :: Bool -> App ()
26−vtyInteract shouldExit = do
27− updateDisplay
28− unless shouldExit $ handleNextEvent >>= vtyInteract
29−
30−introText = vertCat $ map (string defAttr)
31− [ "this line is hidden by the top layer"
32− , "The vty demo program will echo the events generated by the pressed keys."
33− , "Below there is a 240 color box."
34− , "Followed by a description of the 16 color palette."
35− , "Followed by tones of red using a 24-bit palette."
36− , "If the 240 color box is not visible then the terminal"
37− , "claims 240 colors are not supported."
38− , "Try setting TERM to xterm-256color"
39− , "This text is on a lower layer than the event list."
40− , "Which means it'll be hidden soon."
41− , "Bye!"
42− , "Great Faith in the ¯\\_(ツ)_/¯"
43− , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
44− ]
45−
46−splitColorImages :: [Image] -> [[Image]]
47−splitColorImages [] = []
48−splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
49−
50−fullcolorbox :: Image
51−fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages
52− where
53− colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255]
54−
55−colorbox_240 :: Image
56−colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
57− where
58− colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
59−
60−colorbox_16 :: Image
61−colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
62− where
63− column0 = vertCat $ map lineWithColor normal
64− column1 = vertCat $ map lineWithColor bright
65− border = vertCat $ replicate (length normal) $ string defAttr " | "
66− column2 = vertCat $ map (string defAttr . snd) normal
67− lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName
68− normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
69− [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
70− bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue
71− , brightMagenta, brightCyan, brightWhite ]
72− [ "bright black", "bright red", "bright green", "bright yellow"
73− , "bright blue", "bright magenta", "bright cyan", "bright white" ]
74−
75−updateDisplay :: App ()
76−updateDisplay = do
77− let info = string (defAttr `withForeColor` black `withBackColor` green)
78− "Press ESC to exit. Events for keys below."
79− eventLog <- foldMap (string defAttr) <$> get
80− let pic = picForImage (info <-> eventLog)
81− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
82− vty <- ask
83− liftIO $ update vty pic
84−
85−handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent
86− where
87− handleEvent e = do
88− modify $ (<|) (show e) >>> Seq.take eventBufferSize
89− return $ e == EvKey KEsc []
90−
demos/ModeDemo.hsdeleted−55
@@ -1,55 +0,0 @@
1−module Main where
2−
3−import Control.Applicative
4−import Data.Monoid
5−import Foreign.C.Types (CInt(..), CChar(..))
6−import System.Posix.Types (Fd(..))
7−
8−import Graphics.Vty
9−
10−mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image
11−mkUI (m, ms, p, ps) e =
12− vertCat [ string defAttr $ "Mouse mode supported: " <> show m
13− , string defAttr $ "Mouse mode status: " <> show ms
14− , string defAttr " "
15− , string defAttr $ "Paste mode supported: " <> show p
16− , string defAttr $ "Paste mode status: " <> show ps
17− , string defAttr " "
18− , string defAttr $ "Last event: " <> show e
19− , string defAttr " "
20− , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit."
21− ]
22−
23−main :: IO ()
24−main = do
25− cfg <- standardIOConfig
26− vty <- mkVty cfg
27−
28− let renderUI lastE = do
29− let output = outputIface vty
30− info <- (,,,) <$> (pure $ supportsMode output Mouse)
31− <*> getModeStatus output Mouse
32− <*> (pure $ supportsMode output BracketedPaste)
33− <*> getModeStatus output BracketedPaste
34− return $ picForImage $ mkUI info lastE
35−
36− let go lastE = do
37− pic <- renderUI lastE
38− update vty pic
39− e <- nextEvent vty
40− case e of
41− EvKey (KChar 'q') [] -> return ()
42− EvKey (KChar 'm') [] -> do
43− let output = outputIface vty
44− enabled <- getModeStatus output Mouse
45− setMode output Mouse (not enabled)
46− go (Just e)
47− EvKey (KChar 'p') [] -> do
48− let output = outputIface vty
49− enabled <- getModeStatus output BracketedPaste
50− setMode output BracketedPaste (not enabled)
51− go (Just e)
52− _ -> go (Just e)
53−
54− go Nothing
55− shutdown vty
install_examplesnew file+4
@@ -0,0 +1,4 @@
1+#!/bin/bash
2+set -ex
3+cabal install
4+(cd test && cabal install)
scripts/256colres.pl+3−3
@@ -59,9 +59,9 @@ import Text.Printf
59--
59--
60-- generated from 256colres.pl which is forked from xterm 256colres.pl
60-- generated from 256colres.pl which is forked from xterm 256colres.pl
61-- todo: all values get clamped high.
61-- todo: all values get clamped high.
62−rgbColor :: Integral i => i -> i -> i -> Color
62+rgb_color :: Integral i => i -> i -> i -> Color
63−rgbColor r g b
63+rgb_color r g b
64− | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
64+ | r < 0 && g < 0 && b < 0 = error "rgb_color with negative color component intensity"
65EOF
65EOF
66
66
67my $grey_line=" | r == %d && g == %d && b == %d = Color240 %d\n";
67my $grey_line=" | r == %d && g == %d && b == %d = Color240 %d\n";
src/Codec/Binary/UTF8/Debug.hs+10−8
@@ -1,6 +1,7 @@
1−{-# OPTIONS_HADDOCK hide #-}
1+{-# LANGUAGE NoMonomorphismRestriction #-}
2-- Copyright 2009 Corey O'Connor
2-- Copyright 2009 Corey O'Connor
3−module Codec.Binary.UTF8.Debug where
3+module Codec.Binary.UTF8.Debug
4+ where
4
5
5import Codec.Binary.UTF8.String ( encode )
6import Codec.Binary.UTF8.String ( encode )
6
7
@@ -8,10 +9,11 @@ import Data.Word
8
9
9import Numeric
10import Numeric
10
11
11−-- | Converts an array of ISO-10646 characters (Char type) to an array
12+-- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the
12−-- of Word8 bytes that is the corresponding UTF8 byte sequence
13+-- corresponding UTF8 byte sequence
13−utf8FromIso :: [Int] -> [Word8]
14+utf8_from_iso :: [Int] -> [Word8]
14−utf8FromIso = encode . map toEnum
15+utf8_from_iso = encode . map toEnum
16+
17+pp_utf8 :: [Int] -> IO ()
18+pp_utf8 = print . map (\f -> f "") . map showHex . utf8_from_iso
15
19
16−ppUtf8 :: [Int] -> IO ()
17−ppUtf8 = print . map (`showHex` "") . utf8FromIso
src/Data/Sequence/Extra.hs+2−3
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2-- Copyright 2009 Corey O'Connor
1-- Copyright 2009 Corey O'Connor
3module Data.Sequence.Extra where
2module Data.Sequence.Extra where
4
3
@@ -7,7 +6,7 @@ import Data.Sequence
7import Control.Parallel.Strategies
6import Control.Parallel.Strategies
8
7
9instance NFData a => NFData (Seq a) where
8instance NFData a => NFData (Seq a) where
10− rnf = rnf' . viewl
9+ rnf = \v -> rnf' (viewl v)
11− where
10+ where
12 rnf' EmptyL = ()
11 rnf' EmptyL = ()
13 rnf' (a :< r) = rnf a >| rnf' (viewl r)
12 rnf' (a :< r) = rnf a >| rnf' (viewl r)
src/Data/Terminfo/Eval.hs+86−86
@@ -1,14 +1,12 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# OPTIONS_GHC -funbox-strict-fields #-}
3{-# OPTIONS_GHC -funbox-strict-fields #-}
4−{-# OPTIONS_HADDOCK hide #-}
5−
6−-- | Evaluates the paramaterized terminfo string capability with the
4+{- Evaluates the paramaterized terminfo string capability with the given parameters.
7−-- given parameters.
5+ -
6+ - todo: This can be greatly simplified.
7+ -}
8−module Data.Terminfo.Eval
8+module Data.Terminfo.Eval (write_cap_expr)
9− ( writeCapExpr
10− )
11−where
9+ where
12
10
13import Blaze.ByteString.Builder.Word
11import Blaze.ByteString.Builder.Word
14import Blaze.ByteString.Builder
12import Blaze.ByteString.Builder
@@ -19,15 +17,16 @@ import Control.Monad.State.Strict
19import Control.Monad.Writer
17import Control.Monad.Writer
20
18
21import Data.Bits ((.|.), (.&.), xor)
19import Data.Bits ((.|.), (.&.), xor)
22−import Data.List
20+import Data.List
21+import Data.Word
23
22
24import qualified Data.Vector.Unboxed as Vector
23import qualified Data.Vector.Unboxed as Vector
25
24
26-- | capability evaluator state
25-- | capability evaluator state
27data EvalState = EvalState
26data EvalState = EvalState
28− { evalStack :: ![CapParam]
27+ { eval_stack :: ![CapParam]
29− , evalExpression :: !CapExpression
28+ , eval_expression :: !CapExpression
30− , evalParams :: ![CapParam]
29+ , eval_params :: ![CapParam]
31 }
30 }
32
31
33type Eval a = StateT EvalState (Writer Write) a
32type Eval a = StateT EvalState (Writer Write) a
@@ -35,98 +34,99 @@ type Eval a = StateT EvalState (Writer Write) a
35pop :: Eval CapParam
34pop :: Eval CapParam
36pop = do
35pop = do
37 s <- get
36 s <- get
38− let v : stack' = evalStack s
37+ let v : stack' = eval_stack s
39− s' = s { evalStack = stack' }
38+ s' = s { eval_stack = stack' }
40 put s'
39 put s'
41 return v
40 return v
42
41
43−readParam :: Word -> Eval CapParam
42+read_param :: Word -> Eval CapParam
44−readParam pn = do
43+read_param pn = do
45− !params <- evalParams <$> get
44+ !params <- get >>= return . eval_params
46 return $! genericIndex params pn
45 return $! genericIndex params pn
47
46
48push :: CapParam -> Eval ()
47push :: CapParam -> Eval ()
49push !v = do
48push !v = do
50 s <- get
49 s <- get
51− let s' = s { evalStack = v : evalStack s }
50+ let s' = s { eval_stack = v : eval_stack s }
52 put s'
51 put s'
53
52
54−applyParamOps :: CapExpression -> [CapParam] -> [CapParam]
53+apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]
55−applyParamOps cap params = foldl applyParamOp params (paramOps cap)
54+apply_param_ops cap params = foldl apply_param_op params (param_ops cap)
56
55
57−applyParamOp :: [CapParam] -> ParamOp -> [CapParam]
56+apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
58−applyParamOp params IncFirstTwo = map (+ 1) params
57+apply_param_op params IncFirstTwo = map (+ 1) params
59
58
60−writeCapExpr :: CapExpression -> [CapParam] -> Write
59+write_cap_expr :: CapExpression -> [CapParam] -> Write
61−writeCapExpr cap params =
60+write_cap_expr cap params =
62− let params' = applyParamOps cap params
61+ let params' = apply_param_ops cap params
63− s0 = EvalState [] cap params'
62+ s_0 = EvalState [] cap params'
64− in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
63+ in snd $ runWriter (runStateT (write_cap_ops (cap_ops cap)) s_0)
65
64
66−writeCapOps :: CapOps -> Eval ()
65+write_cap_ops :: CapOps -> Eval ()
67−writeCapOps = mapM_ writeCapOp
66+write_cap_ops ops = mapM_ write_cap_op ops
68
67
69−writeCapOp :: CapOp -> Eval ()
68+write_cap_op :: CapOp -> Eval ()
70−writeCapOp (Bytes !offset !count) = do
69+write_cap_op (Bytes !offset !count) = do
71− !cap <- evalExpression <$> get
70+ !cap <- get >>= return . eval_expression
72− let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
71+ let bytes = Vector.take count $ Vector.drop offset (cap_bytes cap)
73 Vector.forM_ bytes $ tell.writeWord8
72 Vector.forM_ bytes $ tell.writeWord8
74−writeCapOp DecOut = do
73+write_cap_op DecOut = do
75 p <- pop
74 p <- pop
75+ let out_str = show p
76− forM_ (show p) $ tell.writeWord8.toEnum.fromEnum
76+ forM_ out_str $ tell.writeWord8.toEnum.fromEnum
77−writeCapOp CharOut = do
77+write_cap_op CharOut = do
78− pop >>= tell.writeWord8.toEnum.fromEnum
78+ pop >>= tell.writeWord8.toEnum.fromEnum
79−writeCapOp (PushParam pn) = do
79+write_cap_op (PushParam pn) = do
80− readParam pn >>= push
80+ read_param pn >>= push
81−writeCapOp (PushValue v) = do
81+write_cap_op (PushValue v) = do
82 push v
82 push v
83−writeCapOp (Conditional expr parts) = do
83+write_cap_op (Conditional expr parts) = do
84− writeCapOps expr
84+ write_cap_ops expr
85− writeContitionalParts parts
85+ write_contitional_parts parts
86− where
86+ where
87− writeContitionalParts [] = return ()
87+ write_contitional_parts [] = return ()
88− writeContitionalParts ((trueOps, falseOps) : falseParts) = do
88+ write_contitional_parts ((true_ops, false_ops) : false_parts) = do
89 -- (man 5 terminfo)
89 -- (man 5 terminfo)
90− -- Usually the %? expr part pushes a value onto the stack,
90+ -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
91− -- and %t pops it from the stack, testing if it is nonzero
92− -- (true). If it is zero (false), control passes to the %e
91+ -- stack, testing if it is nonzero (true). If it is zero (false), control
93− -- (else) part.
92+ -- passes to the %e (else) part.
94 v <- pop
93 v <- pop
95 if v /= 0
94 if v /= 0
96− then writeCapOps trueOps
95+ then write_cap_ops true_ops
97 else do
96 else do
98− writeCapOps falseOps
97+ write_cap_ops false_ops
99− writeContitionalParts falseParts
98+ write_contitional_parts false_parts
100−
99+
101−writeCapOp BitwiseOr = do
100+write_cap_op BitwiseOr = do
102− v0 <- pop
101+ v_0 <- pop
103− v1 <- pop
102+ v_1 <- pop
104− push $ v0 .|. v1
103+ push $ v_0 .|. v_1
105−writeCapOp BitwiseAnd = do
104+write_cap_op BitwiseAnd = do
106− v0 <- pop
105+ v_0 <- pop
107− v1 <- pop
106+ v_1 <- pop
108− push $ v0 .&. v1
107+ push $ v_0 .&. v_1
109−writeCapOp BitwiseXOr = do
108+write_cap_op BitwiseXOr = do
110− v1 <- pop
109+ v_1 <- pop
111− v0 <- pop
110+ v_0 <- pop
112− push $ v0 `xor` v1
111+ push $ v_0 `xor` v_1
113−writeCapOp ArithPlus = do
112+write_cap_op ArithPlus = do
114− v1 <- pop
113+ v_1 <- pop
115− v0 <- pop
114+ v_0 <- pop
116− push $ v0 + v1
115+ push $ v_0 + v_1
117−writeCapOp ArithMinus = do
116+write_cap_op ArithMinus = do
118− v1 <- pop
117+ v_1 <- pop
119− v0 <- pop
118+ v_0 <- pop
120− push $ v0 - v1
119+ push $ v_0 - v_1
121−writeCapOp CompareEq = do
120+write_cap_op CompareEq = do
122− v1 <- pop
121+ v_1 <- pop
123− v0 <- pop
122+ v_0 <- pop
124− push $ if v0 == v1 then 1 else 0
123+ push $ if v_0 == v_1 then 1 else 0
125−writeCapOp CompareLt = do
124+write_cap_op CompareLt = do
126− v1 <- pop
125+ v_1 <- pop
127− v0 <- pop
126+ v_0 <- pop
128− push $ if v0 < v1 then 1 else 0
127+ push $ if v_0 < v_1 then 1 else 0
129−writeCapOp CompareGt = do
128+write_cap_op CompareGt = do
130− v1 <- pop
129+ v_1 <- pop
131− v0 <- pop
130+ v_0 <- pop
132− push $ if v0 > v1 then 1 else 0
131+ push $ if v_0 > v_1 then 1 else 0
132+
src/Data/Terminfo/Parse.hs+202−212
@@ -1,64 +1,58 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE CPP #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE NamedFieldPuns #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
4{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6−{-# OPTIONS_HADDOCK hide #-}
7−
8−module Data.Terminfo.Parse
5+module Data.Terminfo.Parse ( module Data.Terminfo.Parse
9− ( module Data.Terminfo.Parse
10− , Text.Parsec.ParseError
6+ , Text.ParserCombinators.Parsec.ParseError
11− )
7+ )
12−where
8+ where
13
9
14import Control.Monad ( liftM )
10import Control.Monad ( liftM )
15import Control.DeepSeq
11import Control.DeepSeq
16
12
17−#if !(MIN_VERSION_base(4,11,0))
18−import Data.Semigroup (Semigroup(..))
13+import Data.Monoid
19−#endif
20import Data.Word
14import Data.Word
21import qualified Data.Vector.Unboxed as Vector
15import qualified Data.Vector.Unboxed as Vector
22
16
23import Numeric (showHex)
17import Numeric (showHex)
24
18
25−import Text.Parsec
19+import Text.ParserCombinators.Parsec
26
20
27data CapExpression = CapExpression
21data CapExpression = CapExpression
28− { capOps :: !CapOps
22+ { cap_ops :: !CapOps
29− , capBytes :: !(Vector.Vector Word8)
23+ , cap_bytes :: !(Vector.Vector Word8)
30− , sourceString :: !String
24+ , source_string :: !String
31− , paramCount :: !Int
25+ , param_count :: !Int
32− , paramOps :: !ParamOps
26+ , param_ops :: !ParamOps
33 } deriving (Eq)
27 } deriving (Eq)
34
28
35instance Show CapExpression where
29instance Show CapExpression where
36 show c
30 show c
37− = "CapExpression { " ++ show (capOps c) ++ " }"
31+ = "CapExpression { " ++ show (cap_ops c) ++ " }"
38− ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]"
32+ ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]"
39− ++ " <= " ++ show (sourceString c)
33+ ++ " <= " ++ show (source_string c)
40 where
34 where
41− hexDump :: [Word8] -> String
35+ hex_dump :: [Word8] -> String
42− hexDump = foldr showHex ""
36+ hex_dump = foldr (\b s -> showHex b s) ""
43
37
44instance NFData CapExpression where
38instance NFData CapExpression where
45− rnf (CapExpression ops !_bytes !str !c !pOps)
39+ rnf (CapExpression ops !_bytes !str !c !p_ops)
46− = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps
40+ = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops
47
41
48type CapParam = Word
42type CapParam = Word
49
43
50type CapOps = [CapOp]
44type CapOps = [CapOp]
51−data CapOp =
45+data CapOp =
52 Bytes !Int !Int -- offset count
46 Bytes !Int !Int -- offset count
53 | DecOut | CharOut
47 | DecOut | CharOut
54− -- This stores a 0-based index to the parameter. However the
48+ -- This stores a 0-based index to the parameter. However the operation that implies this op is
55− -- operation that implies this op is 1-based
49+ -- 1-based
56 | PushParam !Word | PushValue !Word
50 | PushParam !Word | PushValue !Word
57− -- The conditional parts are the sequence of (%t expression, %e
51+ -- The conditional parts are the sequence of (%t expression, %e expression) pairs.
58− -- The expression) pairs. %e expression may be NOP
52+ -- The %e expression may be NOP
59− | Conditional
53+ | Conditional
60− { conditionalExpr :: !CapOps
54+ { conditional_expr :: !CapOps
61− , conditionalParts :: ![(CapOps, CapOps)]
55+ , conditional_parts :: ![(CapOps, CapOps)]
62 }
56 }
63 | BitwiseOr | BitwiseXOr | BitwiseAnd
57 | BitwiseOr | BitwiseXOr | BitwiseAnd
64 | ArithPlus | ArithMinus
58 | ArithPlus | ArithMinus
@@ -66,10 +60,10 @@ data CapOp =
66 deriving (Show, Eq)
60 deriving (Show, Eq)
67
61
68instance NFData CapOp where
62instance NFData CapOp where
69− rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount
63+ rnf (Bytes offset byte_count ) = rnf offset `seq` rnf byte_count
70 rnf (PushParam pn) = rnf pn
64 rnf (PushParam pn) = rnf pn
71− rnf (PushValue v) = rnf v
65+ rnf (PushValue v) = rnf v
72− rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts
66+ rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts
73 rnf BitwiseOr = ()
67 rnf BitwiseOr = ()
74 rnf BitwiseXOr = ()
68 rnf BitwiseXOr = ()
75 rnf BitwiseAnd = ()
69 rnf BitwiseAnd = ()
@@ -89,260 +83,256 @@ data ParamOp =
89instance NFData ParamOp where
83instance NFData ParamOp where
90 rnf IncFirstTwo = ()
84 rnf IncFirstTwo = ()
91
85
92−parseCapExpression :: String -> Either ParseError CapExpression
86+parse_cap_expression :: String -> Either ParseError CapExpression
93−parseCapExpression capString =
87+parse_cap_expression cap_string =
94− let v = runParser capExpressionParser
88+ let v = runParser cap_expression_parser
95− initialBuildState
89+ initial_build_state
96− "terminfo cap"
90+ "terminfo cap"
97− capString
91+ cap_string
98 in case v of
92 in case v of
99 Left e -> Left e
93 Left e -> Left e
100− Right buildResults -> Right $ constructCapExpression capString buildResults
94+ Right build_results -> Right $ construct_cap_expression cap_string build_results
101
95
102−constructCapExpression :: String -> BuildResults -> CapExpression
96+construct_cap_expression :: [Char] -> BuildResults -> CapExpression
103−constructCapExpression capString buildResults =
97+construct_cap_expression cap_string build_results =
104 let expr = CapExpression
98 let expr = CapExpression
105− { capOps = outCapOps buildResults
99+ { cap_ops = out_cap_ops build_results
106− -- The cap bytes are the lower 8 bits of the input
100+ -- The cap bytes are the lower 8 bits of the input string's characters.
107− -- string's characters.
101+ -- \todo Verify the input string actually contains an 8bit byte per character.
108− , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
102+ , cap_bytes = Vector.fromList $ map (toEnum.fromEnum) cap_string
109− , sourceString = capString
103+ , source_string = cap_string
110− , paramCount = outParamCount buildResults
104+ , param_count = out_param_count build_results
111− , paramOps = outParamOps buildResults
105+ , param_ops = out_param_ops build_results
112− }
106+ }
113 in rnf expr `seq` expr
107 in rnf expr `seq` expr
114
108
115−type CapParser a = Parsec String BuildState a
109+type CapParser a = GenParser Char BuildState a
116
110
117−capExpressionParser :: CapParser BuildResults
111+cap_expression_parser :: CapParser BuildResults
118−capExpressionParser = do
112+cap_expression_parser = do
119− rs <- many $ paramEscapeParser <|> bytesOpParser
113+ rs <- many $ param_escape_parser <|> bytes_op_parser
120 return $ mconcat rs
114 return $ mconcat rs
121
115
122−paramEscapeParser :: CapParser BuildResults
116+param_escape_parser :: CapParser BuildResults
123−paramEscapeParser = do
117+param_escape_parser = do
124 _ <- char '%'
118 _ <- char '%'
125− incOffset 1
119+ inc_offset 1
126− literalPercentParser <|> paramOpParser
120+ literal_percent_parser <|> param_op_parser
127
121
128−literalPercentParser :: CapParser BuildResults
122+literal_percent_parser :: CapParser BuildResults
129−literalPercentParser = do
123+literal_percent_parser = do
130 _ <- char '%'
124 _ <- char '%'
131− startOffset <- nextOffset <$> getState
125+ start_offset <- getState >>= return . next_offset
132− incOffset 1
126+ inc_offset 1
133− return $ BuildResults 0 [Bytes startOffset 1] []
127+ return $ BuildResults 0 [Bytes start_offset 1] []
134−
128+
135−paramOpParser :: CapParser BuildResults
129+param_op_parser :: CapParser BuildResults
136−paramOpParser
130+param_op_parser
137− = incrementOpParser
131+ = increment_op_parser
138− <|> pushOpParser
132+ <|> push_op_parser
139− <|> decOutParser
133+ <|> dec_out_parser
140− <|> charOutParser
134+ <|> char_out_parser
141− <|> conditionalOpParser
135+ <|> conditional_op_parser
142− <|> bitwiseOpParser
136+ <|> bitwise_op_parser
143− <|> arithOpParser
137+ <|> arith_op_parser
144− <|> literalIntOpParser
138+ <|> literal_int_op_parser
145− <|> compareOpParser
139+ <|> compare_op_parser
146− <|> charConstParser
140+ <|> char_const_parser
147−
141+
148−incrementOpParser :: CapParser BuildResults
142+increment_op_parser :: CapParser BuildResults
149−incrementOpParser = do
143+increment_op_parser = do
150 _ <- char 'i'
144 _ <- char 'i'
151− incOffset 1
145+ inc_offset 1
152 return $ BuildResults 0 [] [ IncFirstTwo ]
146 return $ BuildResults 0 [] [ IncFirstTwo ]
153
147
154−pushOpParser :: CapParser BuildResults
148+push_op_parser :: CapParser BuildResults
155−pushOpParser = do
149+push_op_parser = do
156 _ <- char 'p'
150 _ <- char 'p'
157− paramN <- read . pure <$> digit
151+ param_n <- digit >>= return . (\d -> read [d])
158− incOffset 2
152+ inc_offset 2
159− return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
153+ return $ BuildResults (fromEnum param_n) [PushParam $ param_n - 1] []
160
154
161−decOutParser :: CapParser BuildResults
155+dec_out_parser :: CapParser BuildResults
162−decOutParser = do
156+dec_out_parser = do
163 _ <- char 'd'
157 _ <- char 'd'
164− incOffset 1
158+ inc_offset 1
165 return $ BuildResults 0 [ DecOut ] []
159 return $ BuildResults 0 [ DecOut ] []
166
160
167−charOutParser :: CapParser BuildResults
161+char_out_parser :: CapParser BuildResults
168−charOutParser = do
162+char_out_parser = do
169 _ <- char 'c'
163 _ <- char 'c'
170− incOffset 1
164+ inc_offset 1
171 return $ BuildResults 0 [ CharOut ] []
165 return $ BuildResults 0 [ CharOut ] []
172
166
173−conditionalOpParser :: CapParser BuildResults
167+conditional_op_parser :: CapParser BuildResults
174−conditionalOpParser = do
168+conditional_op_parser = do
175 _ <- char '?'
169 _ <- char '?'
176− incOffset 1
170+ inc_offset 1
177− condPart <- manyExpr conditionalTrueParser
171+ cond_part <- many_expr conditional_true_parser
178− parts <- manyP
172+ parts <- many_p
179− ( do
173+ ( do
180− truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
174+ true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
181− , conditionalFalseParser
175+ , conditional_false_parser
182− ]
176+ ]
183− falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
177+ false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
184− , conditionalTrueParser
178+ , conditional_true_parser
185− ]
179+ ]
186− return ( truePart, falsePart )
180+ return ( true_part, false_part )
187− )
181+ )
188− conditionalEndParser
182+ conditional_end_parser
189−
183+
190− let trueParts = map fst parts
184+ let true_parts = map fst parts
191− falseParts = map snd parts
185+ false_parts = map snd parts
192− BuildResults n cond condParamOps = condPart
186+ BuildResults n cond cond_param_ops = cond_part
193−
187+
194− let n' = maximum $ n : map outParamCount trueParts
188+ let n' = maximum $ n : map out_param_count true_parts
195− n'' = maximum $ n' : map outParamCount falseParts
189+ n'' = maximum $ n' : map out_param_count false_parts
196−
190+
197− let trueOps = map outCapOps trueParts
191+ let true_ops = map out_cap_ops true_parts
198− falseOps = map outCapOps falseParts
192+ false_ops = map out_cap_ops false_parts
199− condParts = zip trueOps falseOps
193+ cond_parts = zip true_ops false_ops
200−
194+
201− let trueParamOps = mconcat $ map outParamOps trueParts
195+ let true_param_ops = mconcat $ map out_param_ops true_parts
202− falseParamOps = mconcat $ map outParamOps falseParts
196+ false_param_ops = mconcat $ map out_param_ops false_parts
203− pOps = mconcat [condParamOps, trueParamOps, falseParamOps]
197+ p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]
204−
198+
205− return $ BuildResults n'' [ Conditional cond condParts ] pOps
199+ return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops
206−
200+
207− where
201+ where
208− manyP !p !end = choice
202+ many_p !p !end = choice
209 [ try end >> return []
203 [ try end >> return []
210− , do !v <- p
204+ , do !v <- p
211− !vs <- manyP p end
205+ !vs <- many_p p end
212 return $! v : vs
206 return $! v : vs
213 ]
207 ]
214− manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end
208+ many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end
215
209
216−conditionalTrueParser :: CapParser ()
210+conditional_true_parser :: CapParser ()
217−conditionalTrueParser = do
211+conditional_true_parser = do
218 _ <- string "%t"
212 _ <- string "%t"
219− incOffset 2
213+ inc_offset 2
220
214
221−conditionalFalseParser :: CapParser ()
215+conditional_false_parser :: CapParser ()
222−conditionalFalseParser = do
216+conditional_false_parser = do
223 _ <- string "%e"
217 _ <- string "%e"
224− incOffset 2
218+ inc_offset 2
225
219
226−conditionalEndParser :: CapParser ()
220+conditional_end_parser :: CapParser ()
227−conditionalEndParser = do
221+conditional_end_parser = do
228 _ <- string "%;"
222 _ <- string "%;"
229− incOffset 2
223+ inc_offset 2
230
224
231−bitwiseOpParser :: CapParser BuildResults
225+bitwise_op_parser :: CapParser BuildResults
232−bitwiseOpParser
226+bitwise_op_parser
233− = bitwiseOrParser
227+ = bitwise_or_parser
234− <|> bitwiseAndParser
228+ <|> bitwise_and_parser
235− <|> bitwiseXorParser
229+ <|> bitwise_xor_parser
236
230
237−bitwiseOrParser :: CapParser BuildResults
231+bitwise_or_parser :: CapParser BuildResults
238−bitwiseOrParser = do
232+bitwise_or_parser = do
239 _ <- char '|'
233 _ <- char '|'
240− incOffset 1
234+ inc_offset 1
241 return $ BuildResults 0 [ BitwiseOr ] [ ]
235 return $ BuildResults 0 [ BitwiseOr ] [ ]
242
236
243−bitwiseAndParser :: CapParser BuildResults
237+bitwise_and_parser :: CapParser BuildResults
244−bitwiseAndParser = do
238+bitwise_and_parser = do
245 _ <- char '&'
239 _ <- char '&'
246− incOffset 1
240+ inc_offset 1
247 return $ BuildResults 0 [ BitwiseAnd ] [ ]
241 return $ BuildResults 0 [ BitwiseAnd ] [ ]
248
242
249−bitwiseXorParser :: CapParser BuildResults
243+bitwise_xor_parser :: CapParser BuildResults
250−bitwiseXorParser = do
244+bitwise_xor_parser = do
251 _ <- char '^'
245 _ <- char '^'
252− incOffset 1
246+ inc_offset 1
253 return $ BuildResults 0 [ BitwiseXOr ] [ ]
247 return $ BuildResults 0 [ BitwiseXOr ] [ ]
254
248
255−arithOpParser :: CapParser BuildResults
249+arith_op_parser :: CapParser BuildResults
256−arithOpParser
250+arith_op_parser
257− = plusOp
251+ = plus_op
258− <|> minusOp
252+ <|> minus_op
259 where
253 where
260− plusOp = do
254+ plus_op = do
261 _ <- char '+'
255 _ <- char '+'
262− incOffset 1
256+ inc_offset 1
263 return $ BuildResults 0 [ ArithPlus ] [ ]
257 return $ BuildResults 0 [ ArithPlus ] [ ]
264− minusOp = do
258+ minus_op = do
265 _ <- char '-'
259 _ <- char '-'
266− incOffset 1
260+ inc_offset 1
267 return $ BuildResults 0 [ ArithMinus ] [ ]
261 return $ BuildResults 0 [ ArithMinus ] [ ]
268
262
269−literalIntOpParser :: CapParser BuildResults
263+literal_int_op_parser :: CapParser BuildResults
270−literalIntOpParser = do
264+literal_int_op_parser = do
271 _ <- char '{'
265 _ <- char '{'
272− incOffset 1
266+ inc_offset 1
273− nStr <- many1 digit
267+ n_str <- many1 digit
274− incOffset $ toEnum $ length nStr
268+ inc_offset $ toEnum $ length n_str
275− let n :: Word = read nStr
269+ let n :: Word = read n_str
276 _ <- char '}'
270 _ <- char '}'
277− incOffset 1
271+ inc_offset 1
278 return $ BuildResults 0 [ PushValue n ] [ ]
272 return $ BuildResults 0 [ PushValue n ] [ ]
279
273
280−compareOpParser :: CapParser BuildResults
274+compare_op_parser :: CapParser BuildResults
281−compareOpParser
275+compare_op_parser
282− = compareEqOp
276+ = compare_eq_op
283− <|> compareLtOp
277+ <|> compare_lt_op
284− <|> compareGtOp
278+ <|> compare_gt_op
285 where
279 where
286− compareEqOp = do
280+ compare_eq_op = do
287 _ <- char '='
281 _ <- char '='
288− incOffset 1
282+ inc_offset 1
289 return $ BuildResults 0 [ CompareEq ] [ ]
283 return $ BuildResults 0 [ CompareEq ] [ ]
290− compareLtOp = do
284+ compare_lt_op = do
291 _ <- char '<'
285 _ <- char '<'
292− incOffset 1
286+ inc_offset 1
293 return $ BuildResults 0 [ CompareLt ] [ ]
287 return $ BuildResults 0 [ CompareLt ] [ ]
294− compareGtOp = do
288+ compare_gt_op = do
295 _ <- char '>'
289 _ <- char '>'
296− incOffset 1
290+ inc_offset 1
297 return $ BuildResults 0 [ CompareGt ] [ ]
291 return $ BuildResults 0 [ CompareGt ] [ ]
298
292
299−bytesOpParser :: CapParser BuildResults
293+bytes_op_parser :: CapParser BuildResults
300−bytesOpParser = do
294+bytes_op_parser = do
301 bytes <- many1 $ satisfy (/= '%')
295 bytes <- many1 $ satisfy (/= '%')
302− startOffset <- nextOffset <$> getState
296+ start_offset <- getState >>= return . next_offset
303 let !c = length bytes
297 let !c = length bytes
304 !s <- getState
298 !s <- getState
305− let s' = s { nextOffset = startOffset + c }
299+ let s' = s { next_offset = start_offset + c }
306 setState s'
300 setState s'
307− return $ BuildResults 0 [Bytes startOffset c] []
301+ return $ BuildResults 0 [Bytes start_offset c] []
308
302
309−charConstParser :: CapParser BuildResults
303+char_const_parser :: CapParser BuildResults
310−charConstParser = do
304+char_const_parser = do
311 _ <- char '\''
305 _ <- char '\''
312− charValue <- liftM (toEnum . fromEnum) anyChar
306+ char_value <- liftM (toEnum . fromEnum) anyChar
313 _ <- char '\''
307 _ <- char '\''
314− incOffset 3
308+ inc_offset 3
315− return $ BuildResults 0 [ PushValue charValue ] [ ]
309+ return $ BuildResults 0 [ PushValue char_value ] [ ]
316
310
317−data BuildState = BuildState
311+data BuildState = BuildState
318− { nextOffset :: Int
312+ { next_offset :: Int
319− }
313+ }
320
314
321−incOffset :: Int -> CapParser ()
315+inc_offset :: Int -> CapParser ()
322−incOffset n = do
316+inc_offset n = do
323 s <- getState
317 s <- getState
324− let s' = s { nextOffset = nextOffset s + n }
318+ let s' = s { next_offset = next_offset s + n }
325 setState s'
319 setState s'
326
320
327−initialBuildState :: BuildState
321+initial_build_state :: BuildState
328−initialBuildState = BuildState 0
322+initial_build_state = BuildState 0
329
323
330data BuildResults = BuildResults
324data BuildResults = BuildResults
331− { outParamCount :: !Int
325+ { out_param_count :: !Int
332− , outCapOps :: !CapOps
326+ , out_cap_ops :: !CapOps
333− , outParamOps :: !ParamOps
327+ , out_param_ops :: !ParamOps
334 }
328 }
335
329
336−instance Semigroup BuildResults where
330+instance Monoid BuildResults where
331+ mempty = BuildResults 0 [] []
337− v0 <> v1
332+ v0 `mappend` v1
338 = BuildResults
333 = BuildResults
339− { outParamCount = outParamCount v0 `max` outParamCount v1
334+ { out_param_count = (out_param_count v0) `max` (out_param_count v1)
340− , outCapOps = outCapOps v0 <> outCapOps v1
335+ , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)
341− , outParamOps = outParamOps v0 <> outParamOps v1
336+ , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)
342 }
337 }
343
338
344−instance Monoid BuildResults where
345− mempty = BuildResults 0 [] []
346−#if !(MIN_VERSION_base(4,11,0))
347− mappend = (<>)
348−#endif
src/Graphics/Text/Width.hs+26−56
@@ -1,64 +1,34 @@
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@.
13−module Graphics.Text.Width
4+module Graphics.Text.Width ( wcwidth
14− ( wcwidth
15− , wcswidth
5+ , wcswidth
16− , wctwidth
6+ , safe_wcwidth
17− , wctlwidth
7+ , safe_wcswidth
18− , safeWcwidth
19− , safeWcswidth
20− , safeWctwidth
21− , safeWctlwidth
22− )
8+ )
23−where
9+ where
24−
25−import Data.List (foldl')
26−import qualified Data.Text as T
27−import qualified Data.Text.Lazy as TL
28
10
29foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
11foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
30
12
31wcswidth :: String -> Int
13wcswidth :: String -> Int
32−wcswidth = foldl' (\l c -> wcwidth c + l) 0
14+wcswidth = sum . map wcwidth
33−{-# INLINE [1] wcswidth #-}
15+
34−
16+-- XXX: Characters with unknown widths occupy 1 column?
35−wctwidth :: T.Text -> Int
17+--
36−wctwidth = T.foldl' (\l c -> wcwidth c + l) 0
18+-- Not sure if this is actually correct. I presume there is a replacement character that is output
37−
19+-- by the terminal instead of the character and this replacement character is 1 column wide. If this
38−wctlwidth :: TL.Text -> Int
20+-- is not true for all terminals then a per-terminal replacement character width needs to be
39−wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0
21+-- implemented.
40−
22+
41−{-# RULES
42−"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x
43−"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x
44− #-}
45−
46−-- | Returns the display width of a character. Assumes all characters
23+-- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width
47−-- with unknown widths are 0 width.
24+safe_wcwidth :: Char -> Int
48−safeWcwidth :: Char -> Int
25+safe_wcwidth c = case wcwidth c of
49−safeWcwidth = max 0 . wcwidth
26+ i | i < 0 -> 0
50−
27+ | otherwise -> i
28+
51−-- | Returns the display width of a string. Assumes all characters with
29+-- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width
52−-- unknown widths are 0 width.
53−safeWcswidth :: String -> Int
30+safe_wcswidth :: String -> Int
54−safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0
31+safe_wcswidth str = case wcswidth str of
55−
32+ i | i < 0 -> 0
56−-- | Returns the display width of a text. Assumes all characters with
33+ | otherwise -> i
57−-- unknown widths are 0 width.
58−safeWctwidth :: T.Text -> Int
59−safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0
60
34
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+133−235
@@ -1,255 +1,153 @@
1−{-# LANGUAGE CPP #-}
1+-- | Vty supports input and output to terminal devices.
2−{-# LANGUAGE ScopedTypeVariables #-}
2+--
3+-- - The input is provides as a sequence of 'Event's.
4+--
5+-- - The output is defined by a 'Picture'. Which is one or more layers of 'Image's.
6+-- The constructors in "Graphics.Vty.Image.Internal" should not be used directly. The module
7+-- "Graphics.Vty.Image" provides a number of constructor equations that will build correct
8+-- 'Image' values. See 'string', '<|>', and '<->' for starters.
9+--
10+-- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
11+--
12+-- Good sources of documentation for terminal programming are:
13+--
14+-- - <https://github.com/b4winckler/vim/blob/master/src/term.c>
15+--
16+-- - <http://invisible-island.net/xterm/ctlseqs/ctlseqs.html>
17+--
18+-- - <http://ulisse.elettra.trieste.it/services/doc/serial/config.html>
19+--
20+-- - <http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html>
21+--
22+-- - <http://www.unixwiz.net/techtips/termios-vmin-vtime.html>
23+--
24+-- - <http://vt100.net/docs/vt100-ug/chapter3.html vt100 control sequences>
25+module Graphics.Vty ( Vty(..)
26+ , mkVty
27+ , module Graphics.Vty.Input
28+ , module Graphics.Vty.Output
29+ , module Graphics.Vty.Picture
30+ , DisplayRegion
31+ )
32+ where
3
33
4−-- | Vty provides interfaces for both terminal input and terminal
5−-- output.
6−--
7−-- - Input to the terminal is provided to the Vty application as a
8−-- sequence of 'Event's.
9−--
10−-- - Output is provided to Vty by the application in the form of a
11−-- 'Picture'. A 'Picture' is one or more layers of 'Image's.
12−-- 'Image' values can be built by the various constructors in
13−-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
14−-- values in the "Graphics.Vty.Attributes" module.
15−--
16−-- Vty uses threads internally, so programs made with Vty need to be
17−-- compiled with the threaded runtime using the GHC @-threaded@ option.
18−--
19−-- @
20−-- import "Graphics.Vty"
21−--
22−-- main = do
23−-- cfg <- 'standardIOConfig'
24−-- vty <- 'mkVty' cfg
25−-- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\"
26−-- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\"
27−-- img = line0 '<->' line1
28−-- pic = 'picForImage' img
29−-- 'update' vty pic
30−-- e <- 'nextEvent' vty
31−-- 'shutdown' vty
32−-- 'print' (\"Last event was: \" '++' 'show' e)
33−-- @
34−module Graphics.Vty
34+import Graphics.Vty.Prelude
35− ( Vty(..)
36− , mkVty
37− , setWindowTitle
38− , Mode(..)
39− , module Graphics.Vty.Config
40− , module Graphics.Vty.Input
41− , module Graphics.Vty.Output
42− , module Graphics.Vty.Output.Interface
43− , module Graphics.Vty.Picture
44− , module Graphics.Vty.Image
45− , module Graphics.Vty.Attributes
46− )
47−where
48
35
49−import Graphics.Vty.Config
50import Graphics.Vty.Input
36import Graphics.Vty.Input
51−import Graphics.Vty.Input.Events
52import Graphics.Vty.Output
37import Graphics.Vty.Output
53−import Graphics.Vty.Output.Interface
54import Graphics.Vty.Picture
38import Graphics.Vty.Picture
55−import Graphics.Vty.Image
56−import Graphics.Vty.Attributes
57−import Graphics.Vty.UnicodeWidthTable.IO
58−import Graphics.Vty.UnicodeWidthTable.Install
59
39
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)
65−import Control.Concurrent.STM
40+import Control.Concurrent
66
41
67import Data.IORef
42import Data.IORef
68−#if !(MIN_VERSION_base(4,11,0))
69−import Data.Semigroup ((<>))
70−#endif
71
43
72−-- | A Vty value represents a handle to the Vty library that the
44+-- | The main object. At most one should be created.
73−-- application must create in order to use Vty.
74--
45--
75-- The use of Vty typically follows this process:
46-- The use of Vty typically follows this process:
76--
47--
77−-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
48+-- 0. initialize vty
78−--
49+--
79−-- 2. Use 'update' to display a picture.
50+-- 1. use the update equation of Vty to display a picture
51+--
52+-- 2. repeat
80−--
53+--
81−-- 3. Use 'nextEvent' to get the next input event.
54+-- 3. shutdown vty.
82−--
55+--
83−-- 4. Depending on the event, go to 2 or 5.
56+-- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe".
84−--
85−-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
86−-- this point the 'Vty' handle cannot be used again.
87−--
57+--
88−-- Operations on Vty handles are not thread-safe.
58+-- This does not assure any thread safety. In theory, as long as an update action is not executed
59+-- when another update action is already then it's safe to call this on multiple threads.
60+--
61+-- \todo Remove explicit `shutdown` requirement.
89−data Vty =
62+data Vty = Vty
63+ { -- | Outputs the given Picture. Equivalent to 'output_picture' applied to a display context
64+ -- implicitly managed by Vty. The managed display context is reset on resize.
90− Vty { update :: Picture -> IO ()
65+ update :: Picture -> IO ()
91− -- ^ Outputs the given 'Picture'.
66+ -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event
92− , nextEvent :: IO Event
67+ -- is a 'EvResize'.
93− -- ^ Return the next 'Event' or block until one becomes
68+ , next_event :: IO Event
94− -- available.
95− , nextEventNonblocking :: IO (Maybe Event)
96− -- ^ Non-blocking version of 'nextEvent'.
97− , inputIface :: Input
98− -- ^ The input interface. See 'Input'.
69+ -- | The input interface. See 'Input'
99− , outputIface :: Output
70+ , input_iface :: Input
100− -- ^ The output interface. See 'Output'.
71+ -- | The output interface. See 'Output'
101− , refresh :: IO ()
72+ , output_iface :: Output
102− -- ^ Refresh the display. If other programs output to the
73+ -- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some
103− -- terminal and mess up the display then the application might
74+ -- other program might output to the terminal and mess up the display. In that case the
104− -- want to force a refresh using this function.
75+ -- application might want to force a refresh.
105− , shutdown :: IO ()
76+ , refresh :: IO ()
106− -- ^ Clean up after vty. A call to this function is necessary to
77+ -- | Clean up after vty.
107− -- cleanly restore the terminal state before application exit.
108− -- The above methods will throw an exception if executed after
78+ -- The above methods will throw an exception if executed after this is executed.
109− -- this is executed. Idempotent.
79+ , shutdown :: IO ()
110− , isShutdown :: IO Bool
111− }
80+ }
112−
81+
82+-- | Set up the state object for using vty. At most one state object should be
113−-- | Create a Vty handle. At most one handle should be created at a time
83+-- created at a time.
114−-- for a given terminal device.
115−--
116−-- The specified configuration is added to the the configuration
117−-- loaded by 'userConfig' with the 'userConfig' configuration taking
118−-- precedence. See "Graphics.Vty.Config".
119−--
120−-- For most applications @mkVty defaultConfig@ is sufficient.
121mkVty :: Config -> IO Vty
84mkVty :: Config -> IO Vty
122−mkVty appConfig = do
85+mkVty config = do
123− config <- (<> appConfig) <$> userConfig
86+ input <- input_for_current_terminal config
124−
87+ out <- output_for_current_terminal
125− when (allowCustomUnicodeWidthTables config /= Just False) $
126− installCustomWidthTable config
127−
128− input <- inputForConfig config
129− out <- outputForConfig config
130− internalMkVty input out
88+ intMkVty input out
131−
89+
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
90+intMkVty :: Input -> Output -> IO Vty
168−internalMkVty input out = do
91+intMkVty input out = do
169− reserveDisplay out
92+ reserve_display out
170−
93+ let shutdown_io = do
171− shutdownVar <- newTVarIO False
94+ shutdown_input input
172− let shutdownIo = do
95+ release_display out
173− alreadyShutdown <- atomically $ swapTVar shutdownVar True
96+ release_terminal out
174− when (not alreadyShutdown) $ do
175− shutdownInput input
176− releaseDisplay out
177− releaseTerminal out
178−
179− let shutdownStatus = readTVarIO shutdownVar
180−
181− lastPicRef <- newIORef Nothing
97+ last_pic_ref <- newIORef Nothing
182− lastUpdateRef <- newIORef Nothing
98+ last_update_ref <- newIORef Nothing
183−
99+
184− let innerUpdate inPic = do
100+ let inner_update in_pic = do
185− b <- displayBounds out
101+ b@(w,h) <- display_bounds out
186− mlastUpdate <- readIORef lastUpdateRef
102+ let cursor = pic_cursor in_pic
187− updateData <- case mlastUpdate of
103+ in_pic' = case cursor of
104+ Cursor x y ->
105+ let
106+ x' = case x of
107+ _ | x < 0 -> 0
108+ | x >= w -> w - 1
109+ | otherwise -> x
110+ y' = case y of
111+ _ | y < 0 -> 0
112+ | y >= h -> h - 1
113+ | otherwise -> y
114+ in in_pic { pic_cursor = Cursor x' y' }
115+ _ -> in_pic
116+ mlast_update <- readIORef last_update_ref
117+ update_data <- case mlast_update of
188 Nothing -> do
118 Nothing -> do
189− dc <- displayContext out b
119+ dc <- display_context out b
190− outputPicture dc inPic
120+ output_picture dc in_pic'
191 return (b, dc)
121 return (b, dc)
192− Just (lastBounds, lastContext) -> do
122+ Just (last_bounds, last_context) -> do
193− if b /= lastBounds
123+ if b /= last_bounds
194 then do
124 then do
195− dc <- displayContext out b
125+ dc <- display_context out b
196− outputPicture dc inPic
126+ output_picture dc in_pic'
197 return (b, dc)
127 return (b, dc)
198 else do
128 else do
199− outputPicture lastContext inPic
129+ output_picture last_context in_pic'
200− return (b, lastContext)
130+ return (b, last_context)
201− writeIORef lastUpdateRef $ Just updateData
131+ writeIORef last_update_ref $ Just update_data
202− writeIORef lastPicRef $ Just inPic
132+ writeIORef last_pic_ref $ Just in_pic'
203−
133+
204− let innerRefresh = do
134+ let inner_refresh
205− writeIORef lastUpdateRef Nothing
135+ = writeIORef last_update_ref Nothing
206− bounds <- displayBounds out
207− dc <- displayContext out bounds
208− writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState
209− mPic <- readIORef lastPicRef
136+ >> readIORef last_pic_ref
210− maybe (return ()) innerUpdate mPic
137+ >>= maybe ( return () ) ( \pic -> inner_update pic )
211−
138+
212− let mkResize = uncurry EvResize <$> displayBounds out
139+ let gkey = do k <- readChan $ _event_channel input
213−
214− translateInternalEvent ResumeAfterSignal = mkResize
215− translateInternalEvent (InputEvent e) = return e
216−
217− gkey = do
218− e <- atomically $ readTChan $ _eventChannel input
219− translateInternalEvent e
220− gkey' = do
221− mEv <- atomically $ tryReadTChan $ _eventChannel input
222− case mEv of
140+ case k of
223− Just e -> Just <$> translateInternalEvent e
141+ (EvResize _ _) -> inner_refresh
142+ >> display_bounds out
143+ >>= return . (\(w,h)-> EvResize w h)
224− Nothing -> return Nothing
144+ _ -> return k
225−
145+
226− return $ Vty { update = innerUpdate
146+ return $ Vty { update = inner_update
227− , nextEvent = gkey
147+ , next_event = gkey
228− , nextEventNonblocking = gkey'
148+ , input_iface = input
229− , inputIface = input
149+ , output_iface = out
230− , outputIface = out
150+ , refresh = inner_refresh
231− , refresh = innerRefresh
232− , shutdown = shutdownIo
151+ , shutdown = shutdown_io
233− , isShutdown = shutdownStatus
234 }
152 }
235
153
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+135−150
@@ -1,89 +1,58 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE StandaloneDeriving #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE RankNTypes #-}
4−
5-- | Display attributes
4-- | Display attributes
6--
5--
7−-- Attributes have three components: a foreground color, a background
6+-- Typically the values 'def_attr' or 'current_attr' are modified to form attributes:
8−-- color, and a style mask. The simplest attribute is the default
9−-- attribute, or 'defAttr'. Attributes can be modified with
10−-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,
11--
7--
12-- @
8-- @
13−-- defAttr \`withForeColor\` red
9+-- def_attr `with_fore_color` red
14-- @
10-- @
15--
11--
16−-- 'Image' constructors often require an 'Attr' to indicate the
12+-- Is the attribute that will set the foreground color to red and the background color to the
17−-- attributes used in the image, e.g.,
13+-- default.
14+--
15+-- This can then be used to build an image wiht a red foreground like so:
18--
16--
19-- @
17-- @
20−-- string (defAttr \`withForeColor\` red) "this text will be red"
18+-- string (def_attr `with_fore_color` red) "this text will be red"
21-- @
19-- @
22--
20--
23−-- The appearance of 'Image's using 'defAttr' is determined by the The
21+-- The default attributes set by 'def_attr' have a presentation determined by the terminal. This is
24−-- terminal, so this is not something VTY can control. The user is free
25−-- to The define the color scheme of the terminal as they see fit.
22+-- not something VTY can control. The user is free to define the color scheme of the terminal as
23+-- they see fit. Up to the limits of the terminal anyways.
26−--
24+--
27−-- The value 'currentAttr' will keep the attributes of whatever was
25+-- The value 'current_attr' will keep the attributes of whatever was output previously.
28−-- output previously.
26+--
27+-- \todo This API is very verbose IMO. I'd like something more succinct.
29−module Graphics.Vty.Attributes
28+module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes
30− ( module Graphics.Vty.Attributes.Color
29+ , module Graphics.Vty.Attributes.Color
31−
30+ , module Graphics.Vty.Attributes.Color240
32− , Attr(..)
33− , FixedAttr(..)
34− , MaybeDefault(..)
35− , defAttr
36− , currentAttr
37−
38− -- * Styles
39− , Style
40− , withStyle
41− , standout
42− , italic
43− , strikethrough
44− , underline
45− , reverseVideo
46− , blink
47− , dim
48− , bold
49− , defaultStyleMask
50− , styleMask
51− , hasStyle
52−
53− -- * Setting attribute colors
54− , withForeColor
55− , withBackColor
56−
57− -- * Setting hyperlinks
58− , withURL
59− )
31+ )
60−where
32+ where
61−
33+
62−import Control.DeepSeq
63import Data.Bits
34import Data.Bits
64−import Data.Text (Text)
35+import Data.Monoid
65import Data.Word
36import Data.Word
66−import GHC.Generics
67
37
68import Graphics.Vty.Attributes.Color
38import Graphics.Vty.Attributes.Color
39+import Graphics.Vty.Attributes.Color240
69
40
70−-- | A display attribute defines the Color and Style of all the
41+-- | A display attribute defines the Color and Style of all the characters rendered after the
71−-- characters rendered after the attribute is applied.
42+-- attribute is applied.
72--
43--
73−-- At most 256 colors, picked from a 240 and 16 color palette, are
44+-- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and
74−-- possible for the background and foreground. The 240 colors and
75−-- 16 colors are points in different palettes. See Color for more
45+-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more
76−-- information.
46+-- information.
77data Attr = Attr
47data Attr = Attr
78− { attrStyle :: !(MaybeDefault Style)
48+ { attr_style :: !(MaybeDefault Style)
79− , attrForeColor :: !(MaybeDefault Color)
49+ , attr_fore_color :: !(MaybeDefault Color)
80− , attrBackColor :: !(MaybeDefault Color)
50+ , attr_back_color :: !(MaybeDefault Color)
81− , attrURL :: !(MaybeDefault Text)
82− } deriving ( Eq, Show, Read, Generic, NFData )
51+ } deriving ( Eq, Show )
83−
52+
84−-- This could be encoded into a single 32 bit word. The 32 bit word is
53+-- This could be encoded into a single 32 bit word. The 32 bit word is first divided
85−-- first divided into 4 groups of 8 bits where: The first group codes
54+-- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to
86−-- what action should be taken with regards to the other groups.
55+-- the other groups.
87-- XXYYZZ__
56-- XXYYZZ__
88-- XX - style action
57-- XX - style action
89-- 00 => reset to default
58-- 00 => reset to default
@@ -100,53 +69,90 @@ data Attr = Attr
100-- __ - unused
69-- __ - unused
101--
70--
102-- Next is the style flags
71-- Next is the style flags
103−-- SURBDOI_
72+-- SURBDO__
104-- S - standout
73-- S - standout
105-- U - underline
74-- U - underline
106-- R - reverse video
75-- R - reverse video
107-- B - blink
76-- B - blink
108-- D - dim
77-- D - dim
109-- O - bold
78-- O - bold
110−-- I - italic
111−-- _ - unused
79+-- __ - unused
112--
80--
113-- Then the foreground color encoded into 8 bits.
81-- Then the foreground color encoded into 8 bits.
114-- Then the background color encoded into 8 bits.
82-- Then the background color encoded into 8 bits.
115
83
84+instance Monoid Attr where
85+ mempty = Attr mempty mempty mempty
86+ mappend attr_0 attr_1 =
87+ Attr ( attr_style attr_0 `mappend` attr_style attr_1 )
88+ ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 )
89+ ( attr_back_color attr_0 `mappend` attr_back_color attr_1 )
90+
116−-- | Specifies the display attributes such that the final style and
91+-- | Specifies the display attributes such that the final style and color values do not depend on
117−-- color values do not depend on the previously applied display
118−-- attribute. The display attributes can still depend on the terminal's
92+-- the previously applied display attribute. The display attributes can still depend on the
119−-- default colors (unfortunately).
93+-- terminal's default colors (unfortunately).
120data FixedAttr = FixedAttr
94data FixedAttr = FixedAttr
121− { fixedStyle :: !Style
95+ { fixed_style :: !Style
122− , fixedForeColor :: !(Maybe Color)
96+ , fixed_fore_color :: !(Maybe Color)
123− , fixedBackColor :: !(Maybe Color)
97+ , fixed_back_color :: !(Maybe Color)
124− , fixedURL :: !(Maybe Text)
125 } deriving ( Eq, Show )
98 } deriving ( Eq, Show )
126
99
127−-- | The style and color attributes can either be the terminal defaults.
100+-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the
128−-- Or be equivalent to the previously applied style. Or be a specific
101+-- previously applied style. Or be a specific value.
129−-- value.
130−data MaybeDefault v = Default | KeepCurrent | SetTo !v
102+data MaybeDefault v where
131− deriving (Eq, Read, Show)
103+ Default :: MaybeDefault v
132−
104+ KeepCurrent :: MaybeDefault v
105+ SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
106+
107+deriving instance Eq v => Eq (MaybeDefault v)
108+deriving instance Eq v => Show (MaybeDefault v)
109+
133−instance (NFData v) => NFData (MaybeDefault v) where
110+instance Eq v => Monoid ( MaybeDefault v ) where
134− rnf Default = ()
111+ mempty = KeepCurrent
112+ mappend Default Default = Default
113+ mappend Default KeepCurrent = Default
114+ mappend Default ( SetTo v ) = SetTo v
115+ mappend KeepCurrent Default = Default
116+ mappend KeepCurrent KeepCurrent = KeepCurrent
135− rnf KeepCurrent = ()
117+ mappend KeepCurrent ( SetTo v ) = SetTo v
136− rnf (SetTo v) = rnf v
118+ mappend ( SetTo _v ) Default = Default
137−
119+ mappend ( SetTo v ) KeepCurrent = SetTo v
120+ mappend ( SetTo _ ) ( SetTo v ) = SetTo v
121+
122+-- | Standard 8-color ANSI terminal color codes.
123+black, red, green, yellow, blue, magenta, cyan, white :: Color
124+black = ISOColor 0
125+red = ISOColor 1
126+green = ISOColor 2
127+yellow = ISOColor 3
128+blue = ISOColor 4
129+magenta= ISOColor 5
130+cyan = ISOColor 6
131+white = ISOColor 7
132+
133+-- | Bright/Vivid variants of the standard 8-color ANSI
134+bright_black, bright_red, bright_green, bright_yellow :: Color
135+bright_blue, bright_magenta, bright_cyan, bright_white :: Color
136+bright_black = ISOColor 8
137+bright_red = ISOColor 9
138+bright_green = ISOColor 10
139+bright_yellow = ISOColor 11
140+bright_blue = ISOColor 12
141+bright_magenta= ISOColor 13
142+bright_cyan = ISOColor 14
143+bright_white = ISOColor 15
144+
138−-- | Styles are represented as an 8 bit word. Each bit in the word is 1
145+-- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute
139−-- if the style attribute assigned to that bit should be applied and 0
140−-- if the style attribute should not be applied.
146+-- assigned to that bit should be applied and 0 if the style attribute should not be applied.
141type Style = Word8
147type Style = Word8
142
148
143−-- | Valid style attributes include:
149+-- | The 6 possible style attributes:
144--
150--
145-- * standout
151-- * standout
146--
152--
147-- * underline
153-- * underline
148--
154--
149−-- * reverseVideo
155+-- * reverse_video
150--
156--
151-- * blink
157-- * blink
152--
158--
@@ -154,75 +160,54 @@ type Style = Word8
154--
160--
155-- * bold/bright
161-- * bold/bright
156--
162--
157−-- * italic
158−--
159−-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160−--
161−-- (The invisible, protect, and altcharset display attributes some
163+-- ( The invisible, protect, and altcharset display attributes some terminals support are not
162−-- terminals support are not supported via VTY.)
164+-- supported via VTY.)
163−standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
165+standout, underline, reverse_video, blink, dim, bold :: Style
164standout = 0x01
166standout = 0x01
165underline = 0x02
167underline = 0x02
166−reverseVideo = 0x04
168+reverse_video = 0x04
167blink = 0x08
169blink = 0x08
168dim = 0x10
170dim = 0x10
169bold = 0x20
171bold = 0x20
170−italic = 0x40
171−strikethrough = 0x80
172
172
173−defaultStyleMask :: Style
173+default_style_mask :: Style
174−defaultStyleMask = 0x00
174+default_style_mask = 0x00
175
175
176−styleMask :: Attr -> Word8
176+style_mask :: Attr -> Word8
177−styleMask attr
177+style_mask attr
178− = case attrStyle attr of
178+ = case attr_style attr of
179 Default -> 0
179 Default -> 0
180 KeepCurrent -> 0
180 KeepCurrent -> 0
181 SetTo v -> v
181 SetTo v -> v
182
182
183-- | true if the given Style value has the specified Style set.
183-- | true if the given Style value has the specified Style set.
184−hasStyle :: Style -> Style -> Bool
184+has_style :: Style -> Style -> Bool
185−hasStyle s bitMask = ( s .&. bitMask ) /= 0
185+has_style s bit_mask = ( s .&. bit_mask ) /= 0
186
186
187-- | Set the foreground color of an `Attr'.
187-- | Set the foreground color of an `Attr'.
188−withForeColor :: Attr -> Color -> Attr
188+with_fore_color :: Attr -> Color -> Attr
189−withForeColor attr c = attr { attrForeColor = SetTo c }
189+with_fore_color attr c = attr { attr_fore_color = SetTo c }
190
190
191-- | Set the background color of an `Attr'.
191-- | Set the background color of an `Attr'.
192−withBackColor :: Attr -> Color -> Attr
192+with_back_color :: Attr -> Color -> Attr
193−withBackColor attr c = attr { attrBackColor = SetTo c }
193+with_back_color attr c = attr { attr_back_color = SetTo c }
194
194
195-- | Add the given style attribute
195-- | Add the given style attribute
196−withStyle :: Attr -> Style -> Attr
196+with_style :: Attr -> Style -> Attr
197−withStyle attr 0 = attr
197+with_style attr style_flag = attr { attr_style = SetTo $ style_mask attr .|. style_flag }
198−withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
198+
199−
200−-- | Add a hyperlinked URL using the proposed [escape sequences for
201−-- hyperlinked
202−-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
203−-- These escape sequences are comparatively new and aren't widely
204−-- supported in terminal emulators yet, but most terminal emulators
205−-- that don't know about these sequences will ignore these sequences,
206−-- and therefore this should fall back sensibly. In some cases they
207−-- won't and this will result in garbage, so this is why hyperlinking is
208−-- disabled by default, in which case this combinator has no observable
209−-- effect. To enable it, enable 'Hyperlink' mode on your Vty output
210−-- interface.
211−withURL :: Attr -> Text -> Attr
212−withURL attr url = attr { attrURL = SetTo url }
213−
214−-- | Sets the style, background color and foreground color to the
199+-- | Sets the style, background color and foreground color to the default values for the terminal.
215−-- default values for the terminal. There is no easy way to determine
216−-- what the default background and foreground colors are.
200+-- There is no easy way to determine what the default background and foreground colors are.
217−defAttr :: Attr
201+def_attr :: Attr
218−defAttr = Attr Default Default Default Default
202+def_attr = Attr Default Default Default
219−
203+
220−-- | Keeps the style, background color and foreground color that was
204+-- | Keeps the style, background color and foreground color that was previously set. Used to
221−-- previously set. Used to override some part of the previous style.
205+-- override some part of the previous style.
222−--
206+--
223−-- EG: current_style `withForeColor` brightMagenta
207+-- EG: current_style `with_fore_color` bright_magenta
224−--
208+--
225−-- Would be the currently applied style (be it underline, bold, etc) but
209+-- Would be the currently applied style (be it underline, bold, etc) but with the foreground color
226−-- with the foreground color set to brightMagenta.
210+-- set to bright_magenta.
227−currentAttr :: Attr
211+current_attr :: Attr
228−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
212+current_attr = Attr KeepCurrent KeepCurrent KeepCurrent
213+
src/Graphics/Vty/Attributes/Color.hs+21−161
@@ -1,75 +1,16 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3−{-# LANGUAGE MultiWayIf #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−
6−module Graphics.Vty.Attributes.Color
1+module Graphics.Vty.Attributes.Color where
7− ( Color(..)
8− , ColorMode(..)
9−
10− -- * Detecting Terminal Color Support
11− , detectColorMode
12−
13− -- ** Fixed Colors
14− -- | Standard 8-color ANSI terminal color codes.
15− --
16− -- Note that these map to colors in the terminal's custom palette. For
17− -- instance, `white` maps to whatever the terminal color theme uses for
18− -- white.
19− --
20− -- Use these functions if you want to make apps that fit the terminal theme.
21− -- If you want access to more/stronger colors use `rgbColor`
22− , black
23− , red
24− , green
25− , yellow
26− , blue
27− , magenta
28− , cyan
29− , white
30−
31− -- | Bright/Vivid variants of the standard 8-color ANSI
32− , brightBlack
33− , brightRed
34− , brightGreen
35− , brightYellow
36− , brightBlue
37− , brightMagenta
38− , brightCyan
39− , brightWhite
40− -- ** Creating Colors From RGB
41− , linearColor
42− , srgbColor
43− , rgbColor
44− , color240
45− , module Graphics.Vty.Attributes.Color240
46− )
47−where
48−
49import Data.Word
2import 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
3
60-- | Abstract data type representing a color.
4-- | Abstract data type representing a color.
5+--
6+-- Currently the foreground and background color are specified as points in either a:
61--
7--
62−-- Currently the foreground and background color are specified as points
63−-- in either a:
64−--
65−-- * 16 color palette. Where the first 8 colors are equal to the 8
8+-- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8
66−-- colors of the ISO 6429 (ANSI) 8 color palette and the second 8
67−-- colors are bright/vivid versions of the first 8 colors.
9+-- color palette and the second 8 colors are bright/vivid versions of the first 8 colors.
68−--
69−-- * 240 color palette. This palette is a regular sampling of the full
70−-- RGB colorspace for the first 224 colors. The remaining 16 colors is
71−-- a greyscale palette.
72--
10--
11+-- * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first
12+-- 224 colors. The remaining 16 colors is a greyscale palette.
13+--
73-- The 8 ISO 6429 (ANSI) colors are as follows:
14-- The 8 ISO 6429 (ANSI) colors are as follows:
74--
15--
75-- 0. black
16-- 0. black
@@ -88,104 +29,23 @@ import Graphics.Vty.Attributes.Color240
88--
29--
89-- 7. white
30-- 7. white
90--
31--
91−-- The mapping from points in the 240 color palette to colors actually
32+-- The mapping from points in the 240 color palette to colors actually displayable by the terminal
92−-- displayable by the terminal depends on the number of colors the
93−-- terminal claims to support. Which is usually determined by the
33+-- depends on the number of colors the terminal claims to support. Which is usually determined by
94−-- terminfo "colors" property. If this property is not being accurately
34+-- the terminfo "colors" property. If this property is not being accurately reported then the color
95−-- reported then the color reproduction will be incorrect.
35+-- reproduction will be incorrect.
96--
36--
97−-- If the terminal reports <= 16 colors then the 240 color palette
37+-- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8
98−-- points are only mapped to the 8 color palette. I'm not sure of
99−-- the RGB points for the "bright" colors which is why they are not
38+-- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not
100−-- addressable via the 240 color palette.
39+-- addressable via the 240 color palette.
101--
40--
102−-- If the terminal reports > 16 colors then the 240 color palette
41+-- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest
103−-- points are mapped to the nearest points in a ("color count" - 16)
104−-- subsampling of the 240 color palette.
42+-- points in a ("color count" - 16) subsampling of the 240 color palette.
105--
43--
106−-- All of this assumes the terminals are behaving similarly to xterm and
44+-- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors.
107−-- rxvt when handling colors. And that the individual colors have not
108−-- been remapped by the user. There may be a way to verify this through
45+-- And that the individual colors have not been remapped by the user. There may be a way to verify
109−-- terminfo but I don't know it.
46+-- this through terminfo but I don't know it.
110--
47--
111-- Seriously, terminal color support is INSANE.
48-- Seriously, terminal color support is INSANE.
112−data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8
49+data Color = ISOColor !Word8 | Color240 !Word8
113− deriving ( Eq, Show, Read, Generic, NFData )
114−
115−data ColorMode
116− = NoColor
117− | ColorMode8
118− | ColorMode16
119− | ColorMode240 !Word8
120− | FullColor
121 deriving ( Eq, Show )
50 deriving ( Eq, Show )
122
51
123−detectColorMode :: String -> IO ColorMode
124−detectColorMode termName' = do
125− term <- catch (Just <$> Terminfo.setupTerm termName')
126− (\(_ :: Terminfo.SetupTermError) -> return Nothing)
127− let getCap cap = term >>= \t -> Terminfo.getCapability t cap
128− termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")
129− colorterm <- lookupEnv "COLORTERM"
130− return $ if
131− | termColors < 8 -> NoColor
132− | termColors < 16 -> ColorMode8
133− | termColors == 16 -> ColorMode16
134− | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)
135− | colorterm == Just "truecolor" -> FullColor
136− | colorterm == Just "24bit" -> FullColor
137− | otherwise -> ColorMode240 240
138−
139−black, red, green, yellow, blue, magenta, cyan, white :: Color
140−black = ISOColor 0
141−red = ISOColor 1
142−green = ISOColor 2
143−yellow = ISOColor 3
144−blue = ISOColor 4
145−magenta= ISOColor 5
146−cyan = ISOColor 6
147−white = ISOColor 7
148−
149−brightBlack, brightRed, brightGreen, brightYellow :: Color
150−brightBlue, brightMagenta, brightCyan, brightWhite :: Color
151−brightBlack = ISOColor 8
152−brightRed = ISOColor 9
153−brightGreen = ISOColor 10
154−brightYellow = ISOColor 11
155−brightBlue = ISOColor 12
156−brightMagenta= ISOColor 13
157−brightCyan = ISOColor 14
158−brightWhite = ISOColor 15
159−
160−linearColor :: Integral i => i -> i -> i -> Color
161−linearColor r g b = RGBColor r' g' b'
162− where
163− r' = fromIntegral (clamp r) :: Word8
164− g' = fromIntegral (clamp g) :: Word8
165− b' = fromIntegral (clamp b) :: Word8
166− clamp = min 255 . max 0
167−
168−srgbColor :: Integral i => i -> i -> i -> Color
169−srgbColor r g b =
170− -- srgb to rgb transformation as described at
171− -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation
172− --
173− -- TODO: it may be worth translating this to a lookup table, as with color240
174− let shrink n = fromIntegral n / 255 :: Double
175− -- called gamma^-1 in wiki
176− gamma u
177− | u <= 0.04045 = u/12.92
178− | otherwise = ((u + 0.055) / 1.055) ** 2.4
179− -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?
180− expand n = round (255 * n)
181− convert = expand . gamma . shrink
182− in RGBColor (convert r) (convert g) (convert b)
183−
184−color240 :: Integral i => i -> i -> i -> Color
185−color240 r g b = Color240 (rgbColorToColor240 r g b)
186−
187−-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.
188−-- This function is lossy in the sense that we only internally support 240 colors but the
189−-- #RRGGBB format supports 16^3 colors.
190−rgbColor :: Integral i => i -> i -> i -> Color
191−rgbColor = color240
src/Graphics/Vty/Attributes/Color240.hs+255−292
@@ -1,298 +1,261 @@
1+{-
1−-- This header file was generated by ./256colres.pl
2+ - This header file was generated by ./256colres.pl
3+ -}
2−module Graphics.Vty.Attributes.Color240
4+module Graphics.Vty.Attributes.Color240 where
3− ( rgbColorToColor240
4− , color240CodeToRGB
5− )
6−where
7
5
8−import Data.Word (Word8)
6+import Graphics.Vty.Attributes.Color
9−import Text.Printf
10
7
11−-- Note: rgbColor's mapping from RGB to 240 colors was generated from
8+import Text.Printf
12−-- 256colres.pl which is forked from xterm 256colres.pl.
13
9
14−-- | Create a value in the Color240 set from an RGB triple
10+-- | RGB color to 240 color palette.
15−rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
11+--
16−rgbColorToColor240 r g b
12+-- generated from 256colres.pl which is forked from xterm 256colres.pl
17− | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
13+-- todo: all values get clamped high.
18− | r == 8 && g == 8 && b == 8 = 216
14+rgb_color :: Integral i => i -> i -> i -> Color
19− | r == 18 && g == 18 && b == 18 = 217
15+rgb_color r g b
20− | r == 28 && g == 28 && b == 28 = 218
16+ | r < 0 && g < 0 && b < 0 = error "rgb_color with negative color component intensity"
21− | r == 38 && g == 38 && b == 38 = 219
17+ | r == 8 && g == 8 && b == 8 = Color240 216
22− | r == 48 && g == 48 && b == 48 = 220
18+ | r == 18 && g == 18 && b == 18 = Color240 217
23− | r == 58 && g == 58 && b == 58 = 221
19+ | r == 28 && g == 28 && b == 28 = Color240 218
24− | r == 68 && g == 68 && b == 68 = 222
20+ | r == 38 && g == 38 && b == 38 = Color240 219
25− | r == 78 && g == 78 && b == 78 = 223
21+ | r == 48 && g == 48 && b == 48 = Color240 220
26− | r == 88 && g == 88 && b == 88 = 224
22+ | r == 58 && g == 58 && b == 58 = Color240 221
27− | r == 98 && g == 98 && b == 98 = 225
23+ | r == 68 && g == 68 && b == 68 = Color240 222
28− | r == 108 && g == 108 && b == 108 = 226
24+ | r == 78 && g == 78 && b == 78 = Color240 223
29− | r == 118 && g == 118 && b == 118 = 227
25+ | r == 88 && g == 88 && b == 88 = Color240 224
30− | r == 128 && g == 128 && b == 128 = 228
26+ | r == 98 && g == 98 && b == 98 = Color240 225
31− | r == 138 && g == 138 && b == 138 = 229
27+ | r == 108 && g == 108 && b == 108 = Color240 226
32− | r == 148 && g == 148 && b == 148 = 230
28+ | r == 118 && g == 118 && b == 118 = Color240 227
33− | r == 158 && g == 158 && b == 158 = 231
29+ | r == 128 && g == 128 && b == 128 = Color240 228
34− | r == 168 && g == 168 && b == 168 = 232
30+ | r == 138 && g == 138 && b == 138 = Color240 229
35− | r == 178 && g == 178 && b == 178 = 233
31+ | r == 148 && g == 148 && b == 148 = Color240 230
36− | r == 188 && g == 188 && b == 188 = 234
32+ | r == 158 && g == 158 && b == 158 = Color240 231
37− | r == 198 && g == 198 && b == 198 = 235
33+ | r == 168 && g == 168 && b == 168 = Color240 232
38− | r == 208 && g == 208 && b == 208 = 236
34+ | r == 178 && g == 178 && b == 178 = Color240 233
39− | r == 218 && g == 218 && b == 218 = 237
35+ | r == 188 && g == 188 && b == 188 = Color240 234
40− | r == 228 && g == 228 && b == 228 = 238
36+ | r == 198 && g == 198 && b == 198 = Color240 235
41− | r == 238 && g == 238 && b == 238 = 239
37+ | r == 208 && g == 208 && b == 208 = Color240 236
42− | otherwise = 36 * go r + 6 * go g + go b
38+ | r == 218 && g == 218 && b == 218 = Color240 237
43− where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."
39+ | r == 228 && g == 228 && b == 228 = Color240 238
40+ | r == 238 && g == 238 && b == 238 = Color240 239
41+ | r <= 0 && g <= 0 && b <= 0 = Color240 0
42+ | r <= 0 && g <= 0 && b <= 95 = Color240 1
43+ | r <= 0 && g <= 0 && b <= 135 = Color240 2
44+ | r <= 0 && g <= 0 && b <= 175 = Color240 3
45+ | r <= 0 && g <= 0 && b <= 215 = Color240 4
46+ | r <= 0 && g <= 0 && b <= 255 = Color240 5
47+ | r <= 0 && g <= 95 && b <= 0 = Color240 6
48+ | r <= 0 && g <= 95 && b <= 95 = Color240 7
49+ | r <= 0 && g <= 95 && b <= 135 = Color240 8
50+ | r <= 0 && g <= 95 && b <= 175 = Color240 9
51+ | r <= 0 && g <= 95 && b <= 215 = Color240 10
52+ | r <= 0 && g <= 95 && b <= 255 = Color240 11
53+ | r <= 0 && g <= 135 && b <= 0 = Color240 12
54+ | r <= 0 && g <= 135 && b <= 95 = Color240 13
55+ | r <= 0 && g <= 135 && b <= 135 = Color240 14
56+ | r <= 0 && g <= 135 && b <= 175 = Color240 15
57+ | r <= 0 && g <= 135 && b <= 215 = Color240 16
58+ | r <= 0 && g <= 135 && b <= 255 = Color240 17
59+ | r <= 0 && g <= 175 && b <= 0 = Color240 18
60+ | r <= 0 && g <= 175 && b <= 95 = Color240 19
61+ | r <= 0 && g <= 175 && b <= 135 = Color240 20
62+ | r <= 0 && g <= 175 && b <= 175 = Color240 21
63+ | r <= 0 && g <= 175 && b <= 215 = Color240 22
64+ | r <= 0 && g <= 175 && b <= 255 = Color240 23
65+ | r <= 0 && g <= 215 && b <= 0 = Color240 24
66+ | r <= 0 && g <= 215 && b <= 95 = Color240 25
67+ | r <= 0 && g <= 215 && b <= 135 = Color240 26
68+ | r <= 0 && g <= 215 && b <= 175 = Color240 27
69+ | r <= 0 && g <= 215 && b <= 215 = Color240 28
70+ | r <= 0 && g <= 215 && b <= 255 = Color240 29
71+ | r <= 0 && g <= 255 && b <= 0 = Color240 30
72+ | r <= 0 && g <= 255 && b <= 95 = Color240 31
73+ | r <= 0 && g <= 255 && b <= 135 = Color240 32
74+ | r <= 0 && g <= 255 && b <= 175 = Color240 33
75+ | r <= 0 && g <= 255 && b <= 215 = Color240 34
76+ | r <= 0 && g <= 255 && b <= 255 = Color240 35
77+ | r <= 95 && g <= 0 && b <= 0 = Color240 36
78+ | r <= 95 && g <= 0 && b <= 95 = Color240 37
79+ | r <= 95 && g <= 0 && b <= 135 = Color240 38
80+ | r <= 95 && g <= 0 && b <= 175 = Color240 39
81+ | r <= 95 && g <= 0 && b <= 215 = Color240 40
82+ | r <= 95 && g <= 0 && b <= 255 = Color240 41
83+ | r <= 95 && g <= 95 && b <= 0 = Color240 42
84+ | r <= 95 && g <= 95 && b <= 95 = Color240 43
85+ | r <= 95 && g <= 95 && b <= 135 = Color240 44
86+ | r <= 95 && g <= 95 && b <= 175 = Color240 45
87+ | r <= 95 && g <= 95 && b <= 215 = Color240 46
88+ | r <= 95 && g <= 95 && b <= 255 = Color240 47
89+ | r <= 95 && g <= 135 && b <= 0 = Color240 48
90+ | r <= 95 && g <= 135 && b <= 95 = Color240 49
91+ | r <= 95 && g <= 135 && b <= 135 = Color240 50
92+ | r <= 95 && g <= 135 && b <= 175 = Color240 51
93+ | r <= 95 && g <= 135 && b <= 215 = Color240 52
94+ | r <= 95 && g <= 135 && b <= 255 = Color240 53
95+ | r <= 95 && g <= 175 && b <= 0 = Color240 54
96+ | r <= 95 && g <= 175 && b <= 95 = Color240 55
97+ | r <= 95 && g <= 175 && b <= 135 = Color240 56
98+ | r <= 95 && g <= 175 && b <= 175 = Color240 57
99+ | r <= 95 && g <= 175 && b <= 215 = Color240 58
100+ | r <= 95 && g <= 175 && b <= 255 = Color240 59
101+ | r <= 95 && g <= 215 && b <= 0 = Color240 60
102+ | r <= 95 && g <= 215 && b <= 95 = Color240 61
103+ | r <= 95 && g <= 215 && b <= 135 = Color240 62
104+ | r <= 95 && g <= 215 && b <= 175 = Color240 63
105+ | r <= 95 && g <= 215 && b <= 215 = Color240 64
106+ | r <= 95 && g <= 215 && b <= 255 = Color240 65
107+ | r <= 95 && g <= 255 && b <= 0 = Color240 66
108+ | r <= 95 && g <= 255 && b <= 95 = Color240 67
109+ | r <= 95 && g <= 255 && b <= 135 = Color240 68
110+ | r <= 95 && g <= 255 && b <= 175 = Color240 69
111+ | r <= 95 && g <= 255 && b <= 215 = Color240 70
112+ | r <= 95 && g <= 255 && b <= 255 = Color240 71
113+ | r <= 135 && g <= 0 && b <= 0 = Color240 72
114+ | r <= 135 && g <= 0 && b <= 95 = Color240 73
115+ | r <= 135 && g <= 0 && b <= 135 = Color240 74
116+ | r <= 135 && g <= 0 && b <= 175 = Color240 75
117+ | r <= 135 && g <= 0 && b <= 215 = Color240 76
118+ | r <= 135 && g <= 0 && b <= 255 = Color240 77
119+ | r <= 135 && g <= 95 && b <= 0 = Color240 78
120+ | r <= 135 && g <= 95 && b <= 95 = Color240 79
121+ | r <= 135 && g <= 95 && b <= 135 = Color240 80
122+ | r <= 135 && g <= 95 && b <= 175 = Color240 81
123+ | r <= 135 && g <= 95 && b <= 215 = Color240 82
124+ | r <= 135 && g <= 95 && b <= 255 = Color240 83
125+ | r <= 135 && g <= 135 && b <= 0 = Color240 84
126+ | r <= 135 && g <= 135 && b <= 95 = Color240 85
127+ | r <= 135 && g <= 135 && b <= 135 = Color240 86
128+ | r <= 135 && g <= 135 && b <= 175 = Color240 87
129+ | r <= 135 && g <= 135 && b <= 215 = Color240 88
130+ | r <= 135 && g <= 135 && b <= 255 = Color240 89
131+ | r <= 135 && g <= 175 && b <= 0 = Color240 90
132+ | r <= 135 && g <= 175 && b <= 95 = Color240 91
133+ | r <= 135 && g <= 175 && b <= 135 = Color240 92
134+ | r <= 135 && g <= 175 && b <= 175 = Color240 93
135+ | r <= 135 && g <= 175 && b <= 215 = Color240 94
136+ | r <= 135 && g <= 175 && b <= 255 = Color240 95
137+ | r <= 135 && g <= 215 && b <= 0 = Color240 96
138+ | r <= 135 && g <= 215 && b <= 95 = Color240 97
139+ | r <= 135 && g <= 215 && b <= 135 = Color240 98
140+ | r <= 135 && g <= 215 && b <= 175 = Color240 99
141+ | r <= 135 && g <= 215 && b <= 215 = Color240 100
142+ | r <= 135 && g <= 215 && b <= 255 = Color240 101
143+ | r <= 135 && g <= 255 && b <= 0 = Color240 102
144+ | r <= 135 && g <= 255 && b <= 95 = Color240 103
145+ | r <= 135 && g <= 255 && b <= 135 = Color240 104
146+ | r <= 135 && g <= 255 && b <= 175 = Color240 105
147+ | r <= 135 && g <= 255 && b <= 215 = Color240 106
148+ | r <= 135 && g <= 255 && b <= 255 = Color240 107
149+ | r <= 175 && g <= 0 && b <= 0 = Color240 108
150+ | r <= 175 && g <= 0 && b <= 95 = Color240 109
151+ | r <= 175 && g <= 0 && b <= 135 = Color240 110
152+ | r <= 175 && g <= 0 && b <= 175 = Color240 111
153+ | r <= 175 && g <= 0 && b <= 215 = Color240 112
154+ | r <= 175 && g <= 0 && b <= 255 = Color240 113
155+ | r <= 175 && g <= 95 && b <= 0 = Color240 114
156+ | r <= 175 && g <= 95 && b <= 95 = Color240 115
157+ | r <= 175 && g <= 95 && b <= 135 = Color240 116
158+ | r <= 175 && g <= 95 && b <= 175 = Color240 117
159+ | r <= 175 && g <= 95 && b <= 215 = Color240 118
160+ | r <= 175 && g <= 95 && b <= 255 = Color240 119
161+ | r <= 175 && g <= 135 && b <= 0 = Color240 120
162+ | r <= 175 && g <= 135 && b <= 95 = Color240 121
163+ | r <= 175 && g <= 135 && b <= 135 = Color240 122
164+ | r <= 175 && g <= 135 && b <= 175 = Color240 123
165+ | r <= 175 && g <= 135 && b <= 215 = Color240 124
166+ | r <= 175 && g <= 135 && b <= 255 = Color240 125
167+ | r <= 175 && g <= 175 && b <= 0 = Color240 126
168+ | r <= 175 && g <= 175 && b <= 95 = Color240 127
169+ | r <= 175 && g <= 175 && b <= 135 = Color240 128
170+ | r <= 175 && g <= 175 && b <= 175 = Color240 129
171+ | r <= 175 && g <= 175 && b <= 215 = Color240 130
172+ | r <= 175 && g <= 175 && b <= 255 = Color240 131
173+ | r <= 175 && g <= 215 && b <= 0 = Color240 132
174+ | r <= 175 && g <= 215 && b <= 95 = Color240 133
175+ | r <= 175 && g <= 215 && b <= 135 = Color240 134
176+ | r <= 175 && g <= 215 && b <= 175 = Color240 135
177+ | r <= 175 && g <= 215 && b <= 215 = Color240 136
178+ | r <= 175 && g <= 215 && b <= 255 = Color240 137
179+ | r <= 175 && g <= 255 && b <= 0 = Color240 138
180+ | r <= 175 && g <= 255 && b <= 95 = Color240 139
181+ | r <= 175 && g <= 255 && b <= 135 = Color240 140
182+ | r <= 175 && g <= 255 && b <= 175 = Color240 141
183+ | r <= 175 && g <= 255 && b <= 215 = Color240 142
184+ | r <= 175 && g <= 255 && b <= 255 = Color240 143
185+ | r <= 215 && g <= 0 && b <= 0 = Color240 144
186+ | r <= 215 && g <= 0 && b <= 95 = Color240 145
187+ | r <= 215 && g <= 0 && b <= 135 = Color240 146
188+ | r <= 215 && g <= 0 && b <= 175 = Color240 147
189+ | r <= 215 && g <= 0 && b <= 215 = Color240 148
190+ | r <= 215 && g <= 0 && b <= 255 = Color240 149
191+ | r <= 215 && g <= 95 && b <= 0 = Color240 150
192+ | r <= 215 && g <= 95 && b <= 95 = Color240 151
193+ | r <= 215 && g <= 95 && b <= 135 = Color240 152
194+ | r <= 215 && g <= 95 && b <= 175 = Color240 153
195+ | r <= 215 && g <= 95 && b <= 215 = Color240 154
196+ | r <= 215 && g <= 95 && b <= 255 = Color240 155
197+ | r <= 215 && g <= 135 && b <= 0 = Color240 156
198+ | r <= 215 && g <= 135 && b <= 95 = Color240 157
199+ | r <= 215 && g <= 135 && b <= 135 = Color240 158
200+ | r <= 215 && g <= 135 && b <= 175 = Color240 159
201+ | r <= 215 && g <= 135 && b <= 215 = Color240 160
202+ | r <= 215 && g <= 135 && b <= 255 = Color240 161
203+ | r <= 215 && g <= 175 && b <= 0 = Color240 162
204+ | r <= 215 && g <= 175 && b <= 95 = Color240 163
205+ | r <= 215 && g <= 175 && b <= 135 = Color240 164
206+ | r <= 215 && g <= 175 && b <= 175 = Color240 165
207+ | r <= 215 && g <= 175 && b <= 215 = Color240 166
208+ | r <= 215 && g <= 175 && b <= 255 = Color240 167
209+ | r <= 215 && g <= 215 && b <= 0 = Color240 168
210+ | r <= 215 && g <= 215 && b <= 95 = Color240 169
211+ | r <= 215 && g <= 215 && b <= 135 = Color240 170
212+ | r <= 215 && g <= 215 && b <= 175 = Color240 171
213+ | r <= 215 && g <= 215 && b <= 215 = Color240 172
214+ | r <= 215 && g <= 215 && b <= 255 = Color240 173
215+ | r <= 215 && g <= 255 && b <= 0 = Color240 174
216+ | r <= 215 && g <= 255 && b <= 95 = Color240 175
217+ | r <= 215 && g <= 255 && b <= 135 = Color240 176
218+ | r <= 215 && g <= 255 && b <= 175 = Color240 177
219+ | r <= 215 && g <= 255 && b <= 215 = Color240 178
220+ | r <= 215 && g <= 255 && b <= 255 = Color240 179
221+ | r <= 255 && g <= 0 && b <= 0 = Color240 180
222+ | r <= 255 && g <= 0 && b <= 95 = Color240 181
223+ | r <= 255 && g <= 0 && b <= 135 = Color240 182
224+ | r <= 255 && g <= 0 && b <= 175 = Color240 183
225+ | r <= 255 && g <= 0 && b <= 215 = Color240 184
226+ | r <= 255 && g <= 0 && b <= 255 = Color240 185
227+ | r <= 255 && g <= 95 && b <= 0 = Color240 186
228+ | r <= 255 && g <= 95 && b <= 95 = Color240 187
229+ | r <= 255 && g <= 95 && b <= 135 = Color240 188
230+ | r <= 255 && g <= 95 && b <= 175 = Color240 189
231+ | r <= 255 && g <= 95 && b <= 215 = Color240 190
232+ | r <= 255 && g <= 95 && b <= 255 = Color240 191
233+ | r <= 255 && g <= 135 && b <= 0 = Color240 192
234+ | r <= 255 && g <= 135 && b <= 95 = Color240 193
235+ | r <= 255 && g <= 135 && b <= 135 = Color240 194
236+ | r <= 255 && g <= 135 && b <= 175 = Color240 195
237+ | r <= 255 && g <= 135 && b <= 215 = Color240 196
238+ | r <= 255 && g <= 135 && b <= 255 = Color240 197
239+ | r <= 255 && g <= 175 && b <= 0 = Color240 198
240+ | r <= 255 && g <= 175 && b <= 95 = Color240 199
241+ | r <= 255 && g <= 175 && b <= 135 = Color240 200
242+ | r <= 255 && g <= 175 && b <= 175 = Color240 201
243+ | r <= 255 && g <= 175 && b <= 215 = Color240 202
244+ | r <= 255 && g <= 175 && b <= 255 = Color240 203
245+ | r <= 255 && g <= 215 && b <= 0 = Color240 204
246+ | r <= 255 && g <= 215 && b <= 95 = Color240 205
247+ | r <= 255 && g <= 215 && b <= 135 = Color240 206
248+ | r <= 255 && g <= 215 && b <= 175 = Color240 207
249+ | r <= 255 && g <= 215 && b <= 215 = Color240 208
250+ | r <= 255 && g <= 215 && b <= 255 = Color240 209
251+ | r <= 255 && g <= 255 && b <= 0 = Color240 210
252+ | r <= 255 && g <= 255 && b <= 95 = Color240 211
253+ | r <= 255 && g <= 255 && b <= 135 = Color240 212
254+ | r <= 255 && g <= 255 && b <= 175 = Color240 213
255+ | r <= 255 && g <= 255 && b <= 215 = Color240 214
256+ | r <= 255 && g <= 255 && b <= 255 = Color240 215
257+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
44 (fromIntegral r :: Int)
258 (fromIntegral r :: Int)
45 (fromIntegral g :: Int)
259 (fromIntegral g :: Int)
46− (fromIntegral b :: Int)))
260+ (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
261
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.hsdeleted−488
@@ -1,488 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE LambdaCase, MultiWayIf #-}
7−-- | Vty supports a configuration file format and associated 'Config'
8−-- data type. The 'Config' can be provided to 'mkVty' to customize the
9−-- application's use of Vty.
10−--
11−-- Lines in config files that fail to parse are ignored. Later entries
12−-- take precedence over earlier ones.
13−--
14−-- = Debug
15−--
16−-- == @debugLog@
17−--
18−-- Format:
19−--
20−-- @
21−-- \"debugLog\" string
22−-- @
23−--
24−-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent
25−-- to a debugLog entry at the end of the last config file.
26−--
27−-- = Input Processing
28−--
29−-- == @map@
30−--
31−-- Format:
32−--
33−-- @
34−-- \"map\" term string key modifier_list
35−-- where
36−-- key := KEsc | KChar Char | KBS ... (same as 'Key')
37−-- modifier_list := \"[\" modifier+ \"]\"
38−-- modifier := MShift | MCtrl | MMeta | MAlt
39−-- term := "_" | string
40−-- @
41−--
42−-- E.g., if the contents are
43−--
44−-- @
45−-- map _ \"\\ESC[B\" KUp []
46−-- map _ \"\\ESC[1;3B\" KDown [MAlt]
47−-- map \"xterm\" \"\\ESC[D\" KLeft []
48−-- @
49−--
50−-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all
51−-- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown
52−-- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will
53−-- result in the KLeft event when @TERM@ is @xterm@.
54−--
55−-- 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
57−-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
58−-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.
59−--
60−-- = Unicode Character Width Maps
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.
85−module Graphics.Vty.Config
86− ( InputMap
87− , Config(..)
88− , VtyConfigurationError(..)
89− , userConfig
90− , overrideEnvConfig
91− , standardIOConfig
92− , runParseConfig
93− , parseConfigFile
94− , defaultConfig
95− , getTtyEraseChar
96− , currentTerminalName
97−
98− , vtyConfigPath
99− , widthTableFilename
100− , vtyDataDirectory
101− , terminalWidthTablePath
102− , vtyConfigFileEnvName
103−
104− , ConfigUpdateResult(..)
105− , addConfigWidthMap
106− )
107−where
108−
109−import Prelude
110−
111−import Control.Applicative hiding (many)
112−
113−import Control.Exception (catch, IOException, Exception(..), throwIO)
114−import Control.Monad (liftM, guard, void)
115−
116−import qualified Data.ByteString as BS
117−#if !(MIN_VERSION_base(4,8,0))
118−import Data.Monoid (Monoid(..))
119−#endif
120−#if !(MIN_VERSION_base(4,11,0))
121−import Data.Semigroup (Semigroup(..))
122−#endif
123−import Data.Typeable (Typeable)
124−
125−import Graphics.Vty.Input.Events
126−import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
127−
128−import GHC.Generics
129−
130−import System.Directory ( getAppUserDataDirectory, doesFileExist
131− , createDirectoryIfMissing
132− )
133−import System.Environment (lookupEnv)
134−import System.FilePath ((</>), takeDirectory)
135−import System.Posix.IO (stdInput, stdOutput)
136−import System.Posix.Types (Fd(..))
137−import Foreign.C.Types (CInt(..), CChar(..))
138−
139−import Text.Parsec hiding ((<|>))
140−import Text.Parsec.Token ( GenLanguageDef(..) )
141−import qualified Text.Parsec.Token as P
142−
143−-- | Type of errors that can be thrown when configuring VTY
144−data VtyConfigurationError =
145− VtyMissingTermEnvVar
146− -- ^ TERM environment variable not set
147− deriving (Show, Eq, Typeable)
148−
149−instance Exception VtyConfigurationError where
150− displayException VtyMissingTermEnvVar = "TERM environment variable not set"
151−
152−-- | Mappings from input bytes to event in the order specified. Later
153−-- entries take precedence over earlier in the case multiple entries
154−-- have the same byte string.
155−type InputMap = [(Maybe String, String, Event)]
156−
157−-- | A Vty configuration.
158−data Config =
159− Config { vmin :: Maybe Int
160− -- ^ The default is 1 character.
161− , vtime :: Maybe Int
162− -- ^ The default is 100 milliseconds, 0.1 seconds.
163− , mouseMode :: Maybe Bool
164− -- ^ The default is False.
165− , bracketedPasteMode :: Maybe Bool
166− -- ^ The default is False.
167− , debugLog :: Maybe FilePath
168− -- ^ Debug information is appended to this file if not
169− -- Nothing.
170− , inputMap :: InputMap
171− -- ^ The (input byte, output event) pairs extend the internal
172− -- input table of VTY and the table from terminfo.
173− --
174− -- See "Graphics.Vty.Config" module documentation for
175− -- documentation of the @map@ directive.
176− , inputFd :: Maybe Fd
177− -- ^ The input file descriptor to use. The default is
178− -- 'System.Posix.IO.stdInput'
179− , outputFd :: Maybe Fd
180− -- ^ The output file descriptor to use. The default is
181− -- 'System.Posix.IO.stdOutput'
182− , termName :: Maybe String
183− -- ^ The terminal name used to look up terminfo capabilities.
184− -- The default is the value of the TERM environment variable.
185− , termWidthMaps :: [(String, FilePath)]
186− -- ^ Terminal width map files.
187− , allowCustomUnicodeWidthTables :: Maybe Bool
188− -- ^ Whether to permit custom Unicode width table loading by
189− -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that
190− -- table loading should not be performed. Other values permit
191− -- table loading.
192− --
193− -- If a table load is attempted and fails, information
194− -- about the failure will be logged to the debug log if the
195− -- configuration specifies one. If no custom table is loaded
196− -- (or if a load fails), the built-in character width table
197− -- will be used.
198− , colorMode :: Maybe ColorMode
199− -- ^ The color mode used to know how many colors the terminal
200− -- supports.
201− }
202− deriving (Show, Eq)
203−
204−defaultConfig :: Config
205−defaultConfig = mempty
206−
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−
225−instance Monoid Config where
226− mempty =
227− Config { vmin = Nothing
228− , vtime = Nothing
229− , mouseMode = Nothing
230− , bracketedPasteMode = Nothing
231− , debugLog = mempty
232− , inputMap = mempty
233− , inputFd = Nothing
234− , outputFd = Nothing
235− , termName = Nothing
236− , termWidthMaps = []
237− , allowCustomUnicodeWidthTables = Nothing
238− , colorMode = Nothing
239− }
240−#if !(MIN_VERSION_base(4,11,0))
241− mappend = (<>)
242−#endif
243−
244−vtyDataDirectory :: IO FilePath
245−vtyDataDirectory = getAppUserDataDirectory "vty"
246−
247−vtyConfigPath :: IO FilePath
248−vtyConfigPath = do
249− dir <- vtyDataDirectory
250− return $ dir </> "config"
251−
252−vtyConfigFileEnvName :: String
253−vtyConfigFileEnvName = "VTY_CONFIG_FILE"
254−
255−-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
256−userConfig :: IO Config
257−userConfig = do
258− configFile <- vtyConfigPath >>= parseConfigFile
259− overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
260− lookupEnv vtyConfigFileEnvName
261− let base = configFile <> overrideConfig
262− mappend base <$> overrideEnvConfig
263−
264−widthTableFilename :: String -> String
265−widthTableFilename term = "width_table_" <> term <> ".dat"
266−
267−termVariable :: String
268−termVariable = "TERM"
269−
270−currentTerminalName :: IO (Maybe String)
271−currentTerminalName = lookupEnv termVariable
272−
273−terminalWidthTablePath :: IO (Maybe FilePath)
274−terminalWidthTablePath = do
275− dataDir <- vtyDataDirectory
276− result <- lookupEnv termVariable
277− case result of
278− Nothing -> return Nothing
279− Just term -> do
280− return $ Just $ dataDir </> widthTableFilename term
281−
282−overrideEnvConfig :: IO Config
283−overrideEnvConfig = do
284− d <- lookupEnv "VTY_DEBUG_LOG"
285− return $ defaultConfig { debugLog = d }
286−
287−-- | Configures VTY using defaults suitable for terminals. This function
288−-- can raise 'VtyConfigurationError'.
289−standardIOConfig :: IO Config
290−standardIOConfig = do
291− mb <- lookupEnv termVariable
292− case mb of
293− Nothing -> throwIO VtyMissingTermEnvVar
294− Just t -> do
295− mcolorMode <- detectColorMode t
296− return defaultConfig
297− { vmin = Just 1
298− , mouseMode = Just False
299− , bracketedPasteMode = Just False
300− , vtime = Just 100
301− , inputFd = Just stdInput
302− , outputFd = Just stdOutput
303− , termName = Just t
304− , colorMode = Just mcolorMode
305− }
306−
307−parseConfigFile :: FilePath -> IO Config
308−parseConfigFile path = do
309− catch (runParseConfig path <$> BS.readFile path)
310− (\(_ :: IOException) -> return defaultConfig)
311−
312−runParseConfig :: String -> BS.ByteString -> Config
313−runParseConfig name cfgTxt =
314− case runParser parseConfig () name cfgTxt of
315− Right cfg -> cfg
316− Left{} -> defaultConfig
317−
318−------------------------------------------------------------------------
319−
320−type Parser = Parsec BS.ByteString ()
321−
322−configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
323−configLanguage = LanguageDef
324− { commentStart = "{-"
325− , commentEnd = "-}"
326− , commentLine = "--"
327− , nestedComments = True
328− , identStart = letter <|> char '_'
329− , identLetter = alphaNum <|> oneOf "_'"
330− , opStart = opLetter configLanguage
331− , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
332− , reservedOpNames = []
333− , reservedNames = []
334− , caseSensitive = True
335− }
336−
337−configLexer :: Monad m => P.GenTokenParser BS.ByteString () m
338−configLexer = P.makeTokenParser configLanguage
339−
340−mapDecl :: Parser Config
341−mapDecl = do
342− "map" <- P.identifier configLexer
343− termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)
344− <|> (Just <$> P.stringLiteral configLexer)
345− bytes <- P.stringLiteral configLexer
346− key <- parseValue
347− modifiers <- parseValue
348− return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
349−
350−debugLogDecl :: Parser Config
351−debugLogDecl = do
352− "debugLog" <- P.identifier configLexer
353− path <- P.stringLiteral configLexer
354− return defaultConfig { debugLog = Just path }
355−
356−widthMapDecl :: Parser Config
357−widthMapDecl = do
358− "widthMap" <- P.identifier configLexer
359− tName <- P.stringLiteral configLexer
360− path <- P.stringLiteral configLexer
361− return defaultConfig { termWidthMaps = [(tName, path)] }
362−
363−ignoreLine :: Parser ()
364−ignoreLine = void $ manyTill anyChar newline
365−
366−parseConfig :: Parser Config
367−parseConfig = liftM mconcat $ many $ do
368− P.whiteSpace configLexer
369− let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]
370− choice directives <|> (ignoreLine >> return defaultConfig)
371−
372−class Parse a where parseValue :: Parser a
373−instance Parse Char where parseValue = P.charLiteral configLexer
374−instance Parse Int where parseValue = fromInteger <$> P.natural configLexer
375−instance Parse Key where parseValue = genericParse
376−instance Parse Modifier where parseValue = genericParse
377−instance Parse a => Parse [a] where
378− parseValue = P.brackets configLexer
379− (parseValue `sepBy` P.symbol configLexer ",")
380−
381−------------------------------------------------------------------------
382−-- Derived parser for ADTs via generics
383−------------------------------------------------------------------------
384−
385−genericParse :: (Generic a, GParse (Rep a)) => Parser a
386−genericParse = to <$> gparse
387−
388−class GParse f where gparse :: Parser (f a)
389−instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse
390−instance GParse U1 where gparse = return U1
391−instance Parse a => GParse (K1 i a) where gparse = K1 <$> parseValue
392−
393−instance (GParse f, GParse g) => GParse (f :*: g) where
394− gparse = (:*:) <$> gparse <*> gparse
395−
396−instance GParseAlts f => GParse (M1 D i f) where
397− gparse =
398− do con <- P.identifier configLexer
399− M1 <$> gparseAlts con
400−
401−------------------------------------------------------------------------
402−
403−class GParseAlts f where
404− gparseAlts :: String -> Parser (f a)
405−
406−instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where
407− gparseAlts con =
408− do guard (con == conName (M1 Nothing :: C1 i Maybe a))
409− M1 <$> gparse
410−
411−instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
412− gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
413−
414−instance 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+22−21
@@ -1,39 +1,40 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2−module Graphics.Vty.Debug
2+module Graphics.Vty.Debug ( module Graphics.Vty.Debug
3− ( module Graphics.Vty.Debug
4− , module Graphics.Vty.Debug.Image
3+ , module Graphics.Vty.Debug.Image
5− )
4+ )
6where
5where
7
6
7+import Graphics.Vty.Prelude
8+
8import Graphics.Vty.Attributes
9import Graphics.Vty.Attributes
9−import Graphics.Vty.Image (DisplayRegion)
10import Graphics.Vty.Debug.Image
10import Graphics.Vty.Debug.Image
11import Graphics.Vty.Span
11import Graphics.Vty.Span
12
12
13−import qualified Data.Vector as Vector
13+import qualified Data.Vector as Vector
14
14
15−rowOpsAffectedColumns :: DisplayOps -> [Int]
15+row_ops_effected_columns :: DisplayOps -> [Int]
16−rowOpsAffectedColumns ops
16+row_ops_effected_columns ops
17− = Vector.toList $ Vector.map spanOpsAffectedColumns ops
17+ = Vector.toList $ Vector.map span_ops_effected_columns ops
18
18
19−allSpansHaveWidth :: DisplayOps -> Int -> Bool
19+all_spans_have_width :: DisplayOps -> Int -> Bool
20−allSpansHaveWidth ops expected
20+all_spans_have_width ops expected
21− = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops
21+ = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns ops
22
22
23−spanOpsAffectedRows :: DisplayOps -> Int
23+span_ops_effected_rows :: DisplayOps -> Int
24−spanOpsAffectedRows ops
24+span_ops_effected_rows 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]
28data SpanConstructEvent = SpanSetAttr Attr
28data SpanConstructEvent = SpanSetAttr Attr
29
29
30−isSetAttr :: Attr -> SpanConstructEvent -> Bool
30+is_set_attr :: Attr -> SpanConstructEvent -> Bool
31−isSetAttr expectedAttr (SpanSetAttr inAttr)
31+is_set_attr expected_attr (SpanSetAttr in_attr)
32− | inAttr == expectedAttr = True
32+ | in_attr == expected_attr = True
33−isSetAttr _attr _event = False
33+is_set_attr _attr _event = False
34
34
35data MockWindow = MockWindow Int Int
35data MockWindow = MockWindow Int Int
36 deriving (Show, Eq)
36 deriving (Show, Eq)
37
37
38−regionForWindow :: MockWindow -> DisplayRegion
38+region_for_window :: MockWindow -> DisplayRegion
39−regionForWindow (MockWindow w h) = (w,h)
39+region_for_window (MockWindow w h) = (w,h)
40+
src/Graphics/Vty/Debug/Image.hs+14−15
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2module Graphics.Vty.Debug.Image where
1module Graphics.Vty.Debug.Image where
3
2
4import Graphics.Vty.Image
3import Graphics.Vty.Image
@@ -7,26 +6,26 @@ type ImageConstructLog = [ImageConstructEvent]
7data ImageConstructEvent = ImageConstructEvent
6data ImageConstructEvent = ImageConstructEvent
8 deriving ( Show, Eq )
7 deriving ( Show, Eq )
9
8
10−forwardImageOps :: [Image -> Image]
9+forward_image_ops :: [Image -> Image]
11−forwardImageOps = map forwardTransform debugImageOps
10+forward_image_ops = map forward_transform debug_image_ops
12
11
13−forwardTransform, reverseTransform :: ImageOp -> (Image -> Image)
12+forward_transform, reverse_transform :: ImageOp -> (Image -> Image)
14
13
15−forwardTransform (ImageOp f _) = f
14+forward_transform (ImageOp f _) = f
16−reverseTransform (ImageOp _ r) = r
15+reverse_transform (ImageOp _ r) = r
17
16
18data ImageOp = ImageOp ImageEndo ImageEndo
17data ImageOp = ImageOp ImageEndo ImageEndo
19type ImageEndo = Image -> Image
18type ImageEndo = Image -> Image
20
19
21−debugImageOps :: [ImageOp]
20+debug_image_ops :: [ImageOp]
22−debugImageOps =
21+debug_image_ops =
23− [ idImageOp
22+ [ id_image_op
24− -- , renderSingleColumnCharOp
23+ -- , render_single_column_char_op
25− -- , renderDoubleColumnCharOp
24+ -- , render_double_column_char_op
26 ]
25 ]
27
26
28−idImageOp :: ImageOp
27+id_image_op :: ImageOp
29−idImageOp = ImageOp id id
28+id_image_op = ImageOp id id
30
29
31−-- renderCharOp :: ImageOp
30+-- render_char_op :: ImageOp
32−-- renderCharOp = ImageOp id id
31+-- render_char_op = ImageOp id id
src/Graphics/Vty/DisplayAttributes.hs+68−108
@@ -1,86 +1,65 @@
1-- Copyright 2009-2010 Corey O'Connor
1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE CPP #-}
4−
5−module Graphics.Vty.DisplayAttributes where
3+module Graphics.Vty.DisplayAttributes
4+ where
6
5
7import Graphics.Vty.Attributes
6import Graphics.Vty.Attributes
8
7
9import Data.Bits ((.&.))
8import Data.Bits ((.&.))
10−import Data.ByteString (ByteString)
9+import Data.Monoid (Monoid(..), mconcat)
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
10
17−-- | Given the previously applied display attributes as a FixedAttr and
11+-- | Given the previously applied display attributes as a FixedAttr and the current display
18−-- the current display attributes as an Attr produces a FixedAttr that
19−-- represents the current display attributes. This is done by using the
12+-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This
20−-- previously applied display attributes to remove the "KeepCurrent"
13+-- is done by using the previously applied display attributes to remove the "KeepCurrent"
21-- abstraction.
14-- abstraction.
22−fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr
15+fix_display_attr :: FixedAttr -> Attr -> FixedAttr
23−fixDisplayAttr fattr attr
16+fix_display_attr fattr attr
24− = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
17+ = FixedAttr (fix_style (fixed_style fattr) (attr_style attr))
25− (fixColor (fixedForeColor fattr) (attrForeColor attr))
18+ (fix_color (fixed_fore_color fattr) (attr_fore_color attr))
26− (fixColor (fixedBackColor fattr) (attrBackColor attr))
19+ (fix_color (fixed_back_color fattr) (attr_back_color attr))
27− (fixURL (fixedURL fattr) (attrURL attr))
28 where
20 where
29− fixStyle _s Default = defaultStyleMask
21+ fix_style _s Default = default_style_mask
30− fixStyle s KeepCurrent = s
22+ fix_style s KeepCurrent = s
31− fixStyle _s (SetTo newStyle) = newStyle
23+ fix_style _s (SetTo new_style) = new_style
32− fixColor _c Default = Nothing
24+ fix_color _c Default = Nothing
33− fixColor c KeepCurrent = c
25+ fix_color c KeepCurrent = c
34− fixColor _c (SetTo c) = Just c
26+ fix_color _c (SetTo c) = Just c
35− fixURL c KeepCurrent = c
27+
36− fixURL _c (SetTo n) = Just n
37− fixURL _c Default = Nothing
38−
39−-- | difference between two display attributes. Used in the calculation
28+-- | difference between two display attributes. Used in the calculation of the operations required
40−-- of the operations required to go from one display attribute to the
29+-- to go from one display attribute to the next.
41−-- next.
42--
30--
43−-- Previously, vty would reset display attributes to default then apply
31+-- Previously, vty would reset display attributes to default then apply the new display attributes.
44−-- the new display attributes. This turned out to be very expensive: A
45−-- *lot* more data would be sent to the terminal than required.
32+-- This turned out to be very expensive: A *lot* more data would be sent to the terminal than
33+-- required.
46data DisplayAttrDiff = DisplayAttrDiff
34data DisplayAttrDiff = DisplayAttrDiff
47− { styleDiffs :: [StyleStateChange]
35+ { style_diffs :: [StyleStateChange]
48− , foreColorDiff :: DisplayColorDiff
36+ , fore_color_diff :: DisplayColorDiff
49− , backColorDiff :: DisplayColorDiff
37+ , back_color_diff :: DisplayColorDiff
50− , urlDiff :: URLDiff
51 }
38 }
52 deriving (Show)
39 deriving (Show)
53
40
54−instance Semigroup DisplayAttrDiff where
55− d0 <> d1 =
56− let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
57− fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
58− bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
59− ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
60− in DisplayAttrDiff ds fcd bcd ud
61−
62instance Monoid DisplayAttrDiff where
41instance Monoid DisplayAttrDiff where
63− mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
42+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange
64−#if !(MIN_VERSION_base(4,11,0))
65− mappend = (<>)
43+ mappend d_0 d_1 =
66−#endif
44+ let ds = simplify_style_diffs (style_diffs d_0) (style_diffs d_1)
45+ fcd = simplify_color_diffs (fore_color_diff d_0) (fore_color_diff d_1)
46+ bcd = simplify_color_diffs (back_color_diff d_0) (back_color_diff d_1)
47+ in DisplayAttrDiff ds fcd bcd
67
48
68-- | Used in the computation of a final style attribute change.
49-- | Used in the computation of a final style attribute change.
69−simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
50+--
70−simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
51+-- TODO(corey): not really a simplify but a monoid instance.
71−
52+simplify_style_diffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
72−-- | Consider two display color attributes diffs. What display color
53+simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1
73−-- attribute diff are these equivalent to?
74−simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
75−simplifyColorDiffs _cd ColorToDefault = ColorToDefault
76−simplifyColorDiffs cd NoColorChange = cd
77−simplifyColorDiffs _cd (SetColor !c) = SetColor c
78
54
79−-- | Consider two URL changes, which are mostly going to be the latter
55+-- | Consider two display color attributes diffs. What display color attribute diff are these
80−-- unless the latter specifies no change.
56+-- equivalent to?
81−simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
57+--
82−simplifyUrlDiffs ud NoLinkChange = ud
58+-- TODO(corey): not really a simplify but a monoid instance.
83−simplifyUrlDiffs _ ud = ud
59+simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
60+simplify_color_diffs _cd ColorToDefault = ColorToDefault
61+simplify_color_diffs cd NoColorChange = cd
62+simplify_color_diffs _cd (SetColor !c) = SetColor c
84
63
85-- | Difference between two display color attribute changes.
64-- | Difference between two display color attribute changes.
86data DisplayColorDiff
65data DisplayColorDiff
@@ -89,15 +68,11 @@ data DisplayColorDiff
89 | SetColor !Color
68 | SetColor !Color
90 deriving (Show, Eq)
69 deriving (Show, Eq)
91
70
92−-- | Style attribute changes are transformed into a sequence of
71+-- | Style attribute changes are transformed into a sequence of apply/removes of the individual
93−-- apply/removes of the individual attributes.
72+-- attributes.
94−data StyleStateChange
73+data StyleStateChange
95 = ApplyStandout
74 = ApplyStandout
96 | RemoveStandout
75 | RemoveStandout
97− | ApplyItalic
98− | RemoveItalic
99− | ApplyStrikethrough
100− | RemoveStrikethrough
101 | ApplyUnderline
76 | ApplyUnderline
102 | RemoveUnderline
77 | RemoveUnderline
103 | ApplyReverseVideo
78 | ApplyReverseVideo
@@ -110,50 +85,35 @@ data StyleStateChange
110 | RemoveBold
85 | RemoveBold
111 deriving (Show, Eq)
86 deriving (Show, Eq)
112
87
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
88+-- | Determines the diff between two display&color attributes. This diff determines the operations
121−-- determines the operations that actually get output to the terminal.
89+-- that actually get output to the terminal.
122−displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
90+display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
123−displayAttrDiffs attr attr' = DisplayAttrDiff
91+display_attr_diffs attr attr' = DisplayAttrDiff
124− { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
92+ { style_diffs = diff_styles (fixed_style attr) (fixed_style attr')
125− , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
93+ , fore_color_diff = diff_color (fixed_fore_color attr) (fixed_fore_color attr')
126− , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
94+ , back_color_diff = diff_color (fixed_back_color attr) (fixed_back_color attr')
127− , urlDiff = diffURL (fixedURL attr) (fixedURL attr')
128 }
95 }
129
96
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−
135−diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
97+diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff
136−diffColor Nothing (Just c') = SetColor c'
98+diff_color Nothing (Just c') = SetColor c'
137−diffColor (Just c) (Just c')
99+diff_color (Just c) (Just c')
138 | c == c' = NoColorChange
100 | c == c' = NoColorChange
139 | otherwise = SetColor c'
101 | otherwise = SetColor c'
140−diffColor Nothing Nothing = NoColorChange
102+diff_color Nothing Nothing = NoColorChange
141−diffColor (Just _) Nothing = ColorToDefault
103+diff_color (Just _) Nothing = ColorToDefault
142
104
143−diffStyles :: Style -> Style -> [StyleStateChange]
105+diff_styles :: Style -> Style -> [StyleStateChange]
144−diffStyles prev cur
106+diff_styles prev cur
145 = mconcat
107 = mconcat
146− [ styleDiff standout ApplyStandout RemoveStandout
108+ [ style_diff standout ApplyStandout RemoveStandout
147− , styleDiff underline ApplyUnderline RemoveUnderline
109+ , style_diff underline ApplyUnderline RemoveUnderline
148− , styleDiff italic ApplyItalic RemoveItalic
149− , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
150− , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
110+ , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo
151− , styleDiff blink ApplyBlink RemoveBlink
111+ , style_diff blink ApplyBlink RemoveBlink
152− , styleDiff dim ApplyDim RemoveDim
112+ , style_diff dim ApplyDim RemoveDim
153− , styleDiff bold ApplyBold RemoveBold
113+ , style_diff bold ApplyBold RemoveBold
154 ]
114 ]
155 where
115 where
156− styleDiff s sm rm
116+ style_diff s sm rm
157 = case (0 == prev .&. s, 0 == cur .&. s) of
117 = case (0 == prev .&. s, 0 == cur .&. s) of
158 -- not set in either
118 -- not set in either
159 (True, True) -> []
119 (True, True) -> []
src/Graphics/Vty/Error.hs+3−3
@@ -1,8 +1,8 @@
1−module Graphics.Vty.Error where
1+module Graphics.Vty.Error
2+ where
2
3
3-- | The type of exceptions specific to vty.
4-- | The type of exceptions specific to vty.
4--
5--
5−-- These have fully qualified names by default since, IMO, exception
6+-- These have fully qualified names by default since, IMO, exception handling requires this.
6−-- handling requires this.
7data VtyException
7data VtyException
8 = VtyFailure String -- ^ Uncategorized failure specific to vty.
8 = VtyFailure String -- ^ Uncategorized failure specific to vty.
src/Graphics/Vty/Image.hs+223−299
@@ -1,63 +1,48 @@
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+module Graphics.Vty.Image ( DisplayText
5−-- the core constructors for creating, combining, and modifying
6+ , Image
6−-- 'Image's.
7+ , image_width
7−module Graphics.Vty.Image
8+ , image_height
8− (
9+ , horiz_join
9− -- * Images
10+ , (<|>)
10− Image
11+ , vert_join
11− , imageWidth
12+ , (<->)
12− , imageHeight
13+ , horiz_cat
13− -- * Image constructors
14+ , vert_cat
14− , emptyImage
15+ , background_fill
16+ , text
17+ , text'
15− , char
18+ , char
16− , string
19+ , string
17− , iso10646String
20+ , iso_10646_string
18− , utf8String
21+ , utf8_string
19− , text
22+ , utf8_bytestring
20− , text'
23+ , utf8_bytestring'
21− , backgroundFill
24+ , char_fill
22− , utf8Bytestring
25+ , empty_image
23− , utf8Bytestring'
26+ , safe_wcwidth
24− , charFill
27+ , safe_wcswidth
25− -- * Combinators
28+ , wcwidth
26− , horizJoin
29+ , wcswidth
27− , (<|>)
28− , vertJoin
29− , (<->)
30− , horizCat
31− , vertCat
32− -- * Image modifications
33− , crop
30+ , crop
34− , cropRight
31+ , crop_right
35− , cropLeft
32+ , crop_left
36− , cropBottom
33+ , crop_bottom
37− , cropTop
34+ , crop_top
38− , pad
35+ , pad
39− , resize
36+ , resize
40− , resizeWidth
37+ , resize_width
41− , resizeHeight
38+ , resize_height
42− , translate
39+ , translate
43− , translateX
40+ , translate_x
44− , translateY
41+ , translate_y
45− -- * Character width functions
42+ -- | The possible display attributes used in constructing an `Image`.
46− , safeWcwidth
43+ , module Graphics.Vty.Attributes
47− , safeWcswidth
48− , safeWctwidth
49− , safeWctlwidth
50− , wcwidth
51− , wcswidth
52− , wctwidth
53− , wctlwidth
54− -- * Display Regions
55− , DisplayText
56− , DisplayRegion
57− , regionWidth
58− , regionHeight
59− )
44+ )
60−where
45+ where
61
46
62import Graphics.Vty.Attributes
47import Graphics.Vty.Attributes
63import Graphics.Vty.Image.Internal
48import Graphics.Vty.Image.Internal
@@ -71,311 +56,250 @@ import qualified Data.Text.Lazy as TL
71import qualified Data.Text.Lazy.Encoding as TL
56import qualified Data.Text.Lazy.Encoding as TL
72import Data.Word
57import Data.Word
73
58
74−-- | A region of the display (first width, then height)
75−type DisplayRegion = (Int,Int)
76−
77−regionWidth :: DisplayRegion -> Int
78−regionWidth = fst
79−
80−regionHeight :: DisplayRegion -> Int
81−regionHeight = snd
82−
83infixr 5 <|>
59infixr 5 <|>
84infixr 4 <->
60infixr 4 <->
85
61
86−-- | An area of the picture's background (See 'Background').
62+-- | An area of the picture's bacground (See Background) of w columns and h rows.
87−backgroundFill :: Int
63+background_fill :: Int -> Int -> Image
88− -- ^ Fill width in columns
64+background_fill w h
89− -> Int
90− -- ^ Fill height in rows
91− -> Image
92−backgroundFill w h
93 | w == 0 = EmptyImage
65 | w == 0 = EmptyImage
94 | h == 0 = EmptyImage
66 | h == 0 = EmptyImage
95 | otherwise = BGFill w h
67 | otherwise = BGFill w h
96
68
97−-- | Combines two images horizontally. This is an alias for 'horizJoin'.
69+-- | Combines two images horizontally. Alias for horiz_join
98--
70--
99-- infixr 5
71-- infixr 5
100(<|>) :: Image -> Image -> Image
72(<|>) :: Image -> Image -> Image
101−(<|>) = horizJoin
73+(<|>) = horiz_join
102
74
103−-- | Combines two images vertically. This is an alias for 'vertJoin'.
75+-- | Combines two images vertically. Alias for vert_join
104--
76--
105-- infixr 4
77-- infixr 4
106(<->) :: Image -> Image -> Image
78(<->) :: Image -> Image -> Image
107−(<->) = vertJoin
79+(<->) = vert_join
108
80
109−-- | Compose any number of images together horizontally, with the first
81+-- | Compose any number of images horizontally.
110−-- in the list being leftmost.
111−horizCat :: [Image] -> Image
82+horiz_cat :: [Image] -> Image
112−horizCat = foldr horizJoin EmptyImage
83+horiz_cat = foldr horiz_join EmptyImage
113
84
114−-- | Compose any number of images vertically, with the first in the list
85+-- | Compose any number of images vertically.
115−-- being topmost.
116−vertCat :: [Image] -> Image
86+vert_cat :: [Image] -> Image
117−vertCat = foldr vertJoin EmptyImage
87+vert_cat = foldr vert_join EmptyImage
118
88
119−-- | Make an 'Image' from a lazy text value. The text value should be
89+-- | A Data.Text.Lazy value
120−-- sanitized of escape sequences (ASCII 27) and carriage returns;
121−-- otherwise layout and attribute problems may result.
122text :: Attr -> TL.Text -> Image
90text :: Attr -> TL.Text -> Image
123−text a txt = let displayWidth = safeWctlwidth txt
91+text a txt
92+ | TL.length txt == 0 = EmptyImage
93+ | otherwise = let display_width = safe_wcswidth (TL.unpack txt)
124− in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
94+ in HorizText a txt display_width (fromIntegral $! TL.length txt)
125
95
126−-- | Make an 'Image' from a text value. The text value should be
96+-- | A Data.Text value
127−-- sanitized of escape sequences (ASCII 27) and carriage returns;
128−-- otherwise layout and attribute problems may result.
129text' :: Attr -> T.Text -> Image
97text' :: Attr -> T.Text -> Image
130−text' a txt = let displayWidth = safeWctwidth txt
98+text' a txt
99+ | T.length txt == 0 = EmptyImage
100+ | otherwise = let display_width = safe_wcswidth (T.unpack txt)
131− in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
101+ in HorizText a (TL.fromStrict txt) display_width (T.length txt)
132
102
133−-- | Make an image from a single character. This is a standard Haskell
103+-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in
134−-- 31-bit character assumed to be in the ISO-10646 encoding.
104+-- the ISO-10646 encoding.
135char :: Attr -> Char -> Image
105char :: Attr -> Char -> Image
136char a c =
106char a c =
137− let displayWidth = safeWcwidth c
107+ let display_width = safe_wcwidth c
138− in HorizText a (TL.singleton c) displayWidth 1
108+ in HorizText a (TL.singleton c) display_width 1
139−
140−-- | Make an image from a string of characters laid out on a single
141−-- row with the same display attribute. The string is assumed to be a
142−-- sequence of ISO-10646 characters. The input string should be
143−-- sanitized of escape sequences (ASCII 27) and carriage returns;
144−-- otherwise layout and attribute problems may result.
145−--
146−-- Note: depending on how the Haskell compiler represents string
147−-- literals, a string literal in a UTF-8 encoded source file, for
148−-- example, may be represented as a ISO-10646 string. That is, I think,
149−-- the case with GHC 6.10. This means, for the most part, you don't need
150−-- to worry about the encoding format when outputting string literals.
151−-- Just provide the string literal directly to iso10646String or string.
152−iso10646String :: Attr -> String -> Image
153−iso10646String a str =
154− let displayWidth = safeWcswidth str
155− in HorizText a (TL.pack str) displayWidth (length str)
156
109
157−-- | Make an 'Image' from a 'String'.
110+-- | A string of characters layed out on a single row with the same display attribute. The string is
111+-- assumed to be a sequence of ISO-10646 characters.
158--
112--
159−-- This is an alias for iso10646String since the usual case is that a
113+-- Note: depending on how the Haskell compiler represents string literals a string literal in a
114+-- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string.
115+-- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry
116+-- about the encoding format when outputting string literals. Just provide the string literal
117+-- directly to iso_10646_string or string.
118+--
119+iso_10646_string :: Attr -> String -> Image
120+iso_10646_string a str =
121+ let display_width = safe_wcswidth str
122+ in HorizText a (TL.pack str) display_width (length str)
123+
124+-- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is
160−-- literal string like "foo" is represented internally as a list of ISO
125+-- represented internally as a list of ISO 10646 31 bit characters.
161−-- 10646 31 bit characters.
162--
126--
163−-- Note: Keep in mind that GHC will compile source encoded as UTF-8
127+-- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while
164−-- but the literal strings, while UTF-8 encoded in the source, will be
165−-- transcoded to a ISO 10646 31 bit characters runtime representation.
128+-- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime
129+-- representation.
166string :: Attr -> String -> Image
130string :: Attr -> String -> Image
167−string = iso10646String
131+string = iso_10646_string
168−
132+
169−-- | Make an 'Image' from a string of characters layed out on a single
133+-- | A string of characters layed out on a single row. The input is assumed to be the bytes for
170−-- row. The input is assumed to be the bytes for UTF-8 encoded text.
134+-- UTF-8 encoded text.
171−utf8String :: Attr -> [Word8] -> Image
135+utf8_string :: Attr -> [Word8] -> Image
172−utf8String a bytes = utf8Bytestring a (BL.pack bytes)
136+utf8_string a bytes = utf8_bytestring a (BL.pack bytes)
173−
137+
174−-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
138+-- | Renders a UTF-8 encoded lazy bytestring.
175−utf8Bytestring :: Attr -> BL.ByteString -> Image
139+utf8_bytestring :: Attr -> BL.ByteString -> Image
176−utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
140+utf8_bytestring a bs = text a (TL.decodeUtf8 bs)
177−
141+
178−-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
142+-- | Renders a UTF-8 encoded strict bytestring.
179−utf8Bytestring' :: Attr -> B.ByteString -> Image
143+utf8_bytestring' :: Attr -> B.ByteString -> Image
180−utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
144+utf8_bytestring' a bs = text' a (T.decodeUtf8 bs)
181−
145+
182−-- | Make an image filling a region with the specified character.
146+-- | creates a fill of the specified character. The dimensions are in number of characters wide and
183−--
147+-- number of rows high.
184−-- If either the width or height are less than or equal to 0, then
148+char_fill :: Integral d => Attr -> Char -> d -> d -> Image
185−-- the result is the empty image.
149+char_fill _a _c 0 _h = EmptyImage
186−charFill :: Integral d
150+char_fill _a _c _w 0 = EmptyImage
187− => Attr
151+char_fill a c w h =
188− -- ^ The attribute to use.
189− -> Char
190− -- ^ The character to use in filling the region.
191− -> d
192− -- ^ The region width.
193− -> d
194− -- ^ The region height.
195− -> Image
196−charFill a c w h
197− | w <= 0 || h <= 0 = EmptyImage
198− | otherwise = vertCat
199− $ replicate (fromIntegral h)
152+ vert_cat $ replicate (fromIntegral h) $ HorizText a txt display_width char_width
200− $ HorizText a txt displayWidth charWidth
201− where
153+ where
202− txt = TL.replicate charWidth (TL.singleton c)
154+ txt = TL.replicate (fromIntegral w) (TL.singleton c)
203− displayWidth = safeWcwidth c * charWidth
155+ display_width = safe_wcwidth c * (fromIntegral w)
204−
205− charWidth :: Num a => a
206− charWidth = fromIntegral w
156+ char_width = fromIntegral w
207−
157+
208−-- | The empty image. Useful for fold combinators. These occupy no space
158+-- | The empty image. Useful for fold combinators. These occupy no space nor define any display
209−-- and do not affect display attributes.
159+-- attributes.
210−emptyImage :: Image
160+empty_image :: Image
211−emptyImage = EmptyImage
161+empty_image = EmptyImage
212−
162+
213−-- | Pad the given image. This adds background character fills to the
163+-- | pad the given image. This adds background character fills to the left, top, right, bottom.
214−-- left, top, right, bottom.
164+-- The pad values are how many display columns or rows to add.
215−pad :: Int
165+pad :: Int -> Int -> Int -> Int -> Image -> Image
216− -- ^ How much padding to add to the left side of the image.
217− -> Int
218− -- ^ How much padding to add to the top of the image.
219− -> Int
220− -- ^ How much padding to add to the right side of the image.
221− -> Int
222− -- ^ How much padding to add to the bottom of the image.
223− -> Image
224− -- ^ The image to pad.
225− -> Image
226pad 0 0 0 0 i = i
166pad 0 0 0 0 i = i
227−pad inL inT inR inB inImage
167+pad in_l in_t in_r in_b in_image
228− | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
168+ | in_l < 0 || in_t < 0 || in_r < 0 || in_b < 0 = error "cannot pad by negative amount"
229− | otherwise = go inL inT inR inB inImage
169+ | otherwise = go in_l in_t in_r in_b in_image
230− where
170+ where
171+ -- TODO: uh.
231 go 0 0 0 0 i = i
172 go 0 0 0 0 i = i
232 go 0 0 0 b i = VertJoin i (BGFill w b) w h
173 go 0 0 0 b i = VertJoin i (BGFill w b) w h
233− where w = imageWidth i
174+ where w = image_width i
234− h = imageHeight i + b
175+ h = image_height i + b
235 go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h
176 go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h
236− where w = imageWidth i + r
177+ where w = image_width i + r
237− h = imageHeight i
178+ h = image_height i
238 go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h
179 go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h
239− where w = imageWidth i
180+ where w = image_width i
240− h = imageHeight i + t
181+ h = image_height i + t
241 go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h
182 go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h
242− where w = imageWidth i + l
183+ where w = image_width i + l
243− h = imageHeight i
184+ h = image_height i
244
185
245−-- | Translates an image by padding or cropping the left and top.
186+-- | translates an image by padding or cropping the top and left.
246--
187--
247−-- If translation offsets are negative then the image is cropped.
188+-- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than
248−translate :: Int
189+-- (0,0) will crop the image.
249− -- ^ The horizontal translation offset (can be negative)
190+translate :: Int -> Int -> Image -> Image
250− -> Int
251− -- ^ The vertical translation offset (can be negative)
252− -> Image
253− -- ^ The image to translate.
254− -> Image
255−translate x y i = translateX x (translateY y i)
191+translate x y i = translate_x x (translate_y y i)
256−
192+
257−-- | Translates an image by padding or cropping its left side.
193+-- | translates an image by padding or cropping the left
258−translateX :: Int -> Image -> Image
194+translate_x :: Int -> Image -> Image
259−translateX x i
195+translate_x x i
260− | x < 0 && (abs x > imageWidth i) = emptyImage
261− | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)
196+ | x < 0 = let s = abs x in CropLeft i s (image_width i - s) (image_height i)
262 | x == 0 = i
197 | x == 0 = i
263− | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h
198+ | otherwise = let h = image_height i in HorizJoin (BGFill x h) i (image_width i + x) h
264
199
265−-- | Translates an image by padding or cropping its top.
200+-- | translates an image by padding or cropping the top
266−translateY :: Int -> Image -> Image
201+translate_y :: Int -> Image -> Image
267−translateY y i
202+translate_y y i
268− | y < 0 && (abs y > imageHeight i) = emptyImage
269− | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)
203+ | y < 0 = let s = abs y in CropTop i s (image_width i) (image_height i - s)
270 | y == 0 = i
204 | y == 0 = i
271− | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)
205+ | otherwise = let w = image_width i in VertJoin (BGFill w y) i w (image_height i + y)
272
206
273−-- | Ensure an image is no larger than the provided size. If the image
207+-- | Ensure an image is no larger than the provided size. If the image is larger then crop the right
274−-- is larger then crop the right or bottom.
208+-- or bottom.
275--
209--
276−-- This is equivalent to a vertical crop from the bottom followed by
210+-- This is transformed to a vertical crop from the bottom followed by horizontal crop from the
277−-- horizontal crop from the right.
211+-- right.
278−crop :: Int
212+crop :: Int -> Int -> Image -> Image
279− -- ^ Cropping width
280− -> Int
281− -- ^ Cropping height
282− -> Image
283− -- ^ The image to crop
284− -> Image
285crop 0 _ _ = EmptyImage
213crop 0 _ _ = EmptyImage
286crop _ 0 _ = EmptyImage
214crop _ 0 _ = EmptyImage
287−crop w h i = cropBottom h (cropRight w i)
215+crop w h i = crop_bottom h (crop_right w i)
288
216
289−-- | Crop an image's height. If the image's height is less than or equal
217+-- | crop the display height. If the image is less than or equal in height then this operation has
290−-- to the specified height then this operation has no effect. Otherwise
291−-- the image is cropped from the bottom.
218+-- no effect. Otherwise the image is cropped from the bottom.
292−cropBottom :: Int -> Image -> Image
219+crop_bottom :: Int -> Image -> Image
293−cropBottom 0 _ = EmptyImage
220+crop_bottom 0 _ = EmptyImage
294−cropBottom h inI
221+crop_bottom h in_i
295 | h < 0 = error "cannot crop height to less than zero"
222 | h < 0 = error "cannot crop height to less than zero"
296− | otherwise = go inI
223+ | otherwise = go in_i
297 where
224 where
298 go EmptyImage = EmptyImage
225 go EmptyImage = EmptyImage
299− go i@(CropBottom {croppedImage, outputWidth, outputHeight})
226+ go i@(CropBottom {cropped_image, output_width, output_height})
300− | outputHeight <= h = i
227+ | output_height <= h = i
301− | otherwise = CropBottom croppedImage outputWidth h
228+ | otherwise = CropBottom cropped_image output_width h
302 go i
229 go i
303− | h >= imageHeight i = i
230+ | h >= image_height i = i
304− | otherwise = CropBottom i (imageWidth i) h
231+ | otherwise = CropBottom i (image_width i) h
305−
232+
306−-- | Crop an image's width. If the image's width is less than or equal
233+-- | ensure the image is no wider than the given width. If the image is wider then crop the right
307−-- to the specified width then this operation has no effect. Otherwise
234+-- side.
308−-- the image is cropped from the right.
309−cropRight :: Int -> Image -> Image
235+crop_right :: Int -> Image -> Image
310−cropRight 0 _ = EmptyImage
236+crop_right 0 _ = EmptyImage
311−cropRight w inI
237+crop_right w in_i
312 | w < 0 = error "cannot crop width to less than zero"
238 | w < 0 = error "cannot crop width to less than zero"
313− | otherwise = go inI
239+ | otherwise = go in_i
314 where
240 where
315 go EmptyImage = EmptyImage
241 go EmptyImage = EmptyImage
316− go i@(CropRight {croppedImage, outputWidth, outputHeight})
242+ go i@(CropRight {cropped_image, output_width, output_height})
317− | outputWidth <= w = i
243+ | output_width <= w = i
318− | otherwise = CropRight croppedImage w outputHeight
244+ | otherwise = CropRight cropped_image w output_height
319 go i
245 go i
320− | w >= imageWidth i = i
246+ | w >= image_width i = i
321− | otherwise = CropRight i w (imageHeight i)
247+ | otherwise = CropRight i w (image_height i)
322−
248+
323−-- | Crop an image's width. If the image's width is less than or equal
249+-- | ensure the image is no wider than the given width. If the image is wider then crop the left
324−-- to the specified width then this operation has no effect. Otherwise
250+-- side.
325−-- the image is cropped from the left.
326−cropLeft :: Int -> Image -> Image
251+crop_left :: Int -> Image -> Image
327−cropLeft 0 _ = EmptyImage
252+crop_left 0 _ = EmptyImage
328−cropLeft w inI
253+crop_left w in_i
329 | w < 0 = error "cannot crop the width to less than zero"
254 | w < 0 = error "cannot crop the width to less than zero"
330− | otherwise = go inI
255+ | otherwise = go in_i
331 where
256 where
332 go EmptyImage = EmptyImage
257 go EmptyImage = EmptyImage
333− go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})
258+ go i@(CropLeft {cropped_image, left_skip, output_width, output_height})
334− | outputWidth <= w = i
259+ | output_width <= w = i
335 | otherwise =
260 | otherwise =
336− let leftSkip' = leftSkip + outputWidth - w
261+ let left_skip' = left_skip + output_width - w
337− in CropLeft croppedImage leftSkip' w outputHeight
262+ in CropLeft cropped_image left_skip' w output_height
338 go i
263 go i
339− | imageWidth i <= w = i
264+ | image_width i <= w = i
340− | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
265+ | otherwise = CropLeft i (image_width i - w) w (image_height i)
341−
266+
342−-- | Crop an image's height. If the image's height is less than or equal
267+-- | crop the display height. If the image is less than or equal in height then this operation has
343−-- to the specified height then this operation has no effect. Otherwise
344−-- the image is cropped from the top.
268+-- no effect. Otherwise the image is cropped from the top.
345−cropTop :: Int -> Image -> Image
269+crop_top :: Int -> Image -> Image
346−cropTop 0 _ = EmptyImage
270+crop_top 0 _ = EmptyImage
347−cropTop h inI
271+crop_top h in_i
348 | h < 0 = error "cannot crop the height to less than zero"
272 | h < 0 = error "cannot crop the height to less than zero"
349− | otherwise = go inI
273+ | otherwise = go in_i
350 where
274 where
351 go EmptyImage = EmptyImage
275 go EmptyImage = EmptyImage
352− go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight})
276+ go i@(CropTop {cropped_image, top_skip, output_width, output_height})
353− | outputHeight <= h = i
277+ | output_height <= h = i
354− | otherwise =
278+ | otherwise =
355− let topSkip' = topSkip + outputHeight - h
279+ let top_skip' = top_skip + output_height - h
356− in CropTop croppedImage topSkip' outputWidth h
280+ in CropTop cropped_image top_skip' output_width h
357 go i
281 go i
358− | imageHeight i <= h = i
282+ | image_height i <= h = i
359− | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
283+ | otherwise = CropTop i (image_height i - h) (image_width i) h
360
284
361−-- | Generic resize. Pads and crops are added to ensure that the
285+-- | Generic resize. Pads and crops as required to assure the given display width and height.
362−-- resulting image matches the specified dimensions. This is biased to
363−-- pad/crop the right and bottom.
286+-- This is biased to pad/crop the right and bottom.
364resize :: Int -> Int -> Image -> Image
287resize :: Int -> Int -> Image -> Image
365−resize w h i = resizeHeight h (resizeWidth w i)
288+resize w h i = resize_height h (resize_width w i)
366
289
367−-- | Resize the width. Pads and crops as required to assure the given
290+-- | Resize the width. Pads and crops as required to assure the given display width.
368−-- display width. This is biased to pad/crop on the right.
291+-- This is biased to pad/crop the right.
369−resizeWidth :: Int -> Image -> Image
292+resize_width :: Int -> Image -> Image
370−resizeWidth w i = case w `compare` imageWidth i of
293+resize_width w i = case w `compare` image_width i of
371− LT -> cropRight w i
294+ LT -> crop_right w i
372 EQ -> i
295 EQ -> i
373− GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
296+ GT -> i <|> BGFill (w - image_width i) (image_height i)
374
297
375−-- | Resize the height. Pads and crops as required to assure the given
298+-- | Resize the height. Pads and crops as required to assure the given display height.
376−-- display height. This is biased to pad/crop on the bottom.
299+-- This is biased to pad/crop the bottom.
377−resizeHeight :: Int -> Image -> Image
300+resize_height :: Int -> Image -> Image
378−resizeHeight h i = case h `compare` imageHeight i of
301+resize_height h i = case h `compare` image_height i of
379− LT -> cropBottom h i
302+ LT -> crop_bottom h i
380 EQ -> i
303 EQ -> i
381− GT -> i <-> BGFill (imageWidth i) (h - imageHeight i)
304+ GT -> i <-> BGFill (image_width i) (h - image_height i)
305+
src/Graphics/Vty/Image/Internal.hs+205−197
@@ -1,44 +1,46 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE NamedFieldPuns #-}
1{-# LANGUAGE NamedFieldPuns #-}
3−{-# LANGUAGE DeriveGeneric #-}
4{-# OPTIONS_HADDOCK hide #-}
2{-# OPTIONS_HADDOCK hide #-}
5−
6module Graphics.Vty.Image.Internal where
3module Graphics.Vty.Image.Internal where
7
4
8import Graphics.Vty.Attributes
5import Graphics.Vty.Attributes
9import Graphics.Text.Width
6import Graphics.Text.Width
10
7
11−import GHC.Generics
12−
13import Control.DeepSeq
8import Control.DeepSeq
14
9
15−#if !(MIN_VERSION_base(4,11,0))
16−import Data.Semigroup (Semigroup(..))
10+import Data.Monoid
17−#endif
18import qualified Data.Text.Lazy as TL
11import qualified Data.Text.Lazy as TL
19
12
20-- | A display text is a Data.Text.Lazy
13-- | A display text is a Data.Text.Lazy
14+--
15+-- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each
16+-- application probably uses a single type. Perhaps parameterize the entire vty interface by the
17+-- input text type?
18+-- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance
19+-- for the usual case of appending a bunch of characters with the same attribute together.
21type DisplayText = TL.Text
20type DisplayText = TL.Text
22
21
22+-- TODO: store a skip list in HorizText(?)
23+-- TODO: represent display strings containing chars that are not 1 column chars as a separate
24+-- display string value?
23−clipText :: DisplayText -> Int -> Int -> DisplayText
25+clip_text :: DisplayText -> Int -> Int -> DisplayText
24−clipText txt leftSkip rightClip =
26+clip_text txt left_skip right_clip =
25 -- CPS would clarify this I think
27 -- CPS would clarify this I think
26− let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0
28+ let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0
27− txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt
29+ txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt
28− (toTake,padSuffix) = clipForCharWidth rightClip txt' 0
30+ (to_take,pad_suffix) = clip_for_char_width right_clip txt' 0
29− txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)
31+ txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)
30− -- Note: some characters and zero-width and combining characters
32+ clip_for_char_width 0 _ n = (n, False)
31− -- combine to the left, so keep taking characters even if the
33+ clip_for_char_width w t n
32− -- width is zero.
33− clipForCharWidth w t n
34 | TL.null t = (n, False)
34 | TL.null t = (n, False)
35− | w < cw = (n, w /= 0)
35+ | w < cw = (n, True)
36− | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1)
36+ | w == cw = (n+1, False)
37+ | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)
37− where cw = safeWcwidth (TL.head t)
38+ where cw = safe_wcwidth (TL.head t)
39+ clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"
38 in txt''
40 in txt''
39
41
40−-- | This is the internal representation of Images. Use the constructors
42+-- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to
41−-- in "Graphics.Vty.Image" to create instances.
43+-- create instances.
42--
44--
43-- Images are:
45-- Images are:
44--
46--
@@ -51,128 +53,140 @@ clipText txt leftSkip rightClip =
51-- * a cropped image
53-- * a cropped image
52--
54--
53-- * an empty image of no size or content.
55-- * an empty image of no size or content.
54−data Image =
56+data Image =
55− -- | A horizontal text span has a row height of 1.
57+ -- | A horizontal text span is always >= 1 column and has a row height of 1.
56 HorizText
58 HorizText
57 { attr :: Attr
59 { attr :: Attr
58− -- | The text to display. The display width of the text is always
60+ -- | The text to display. The display width of the text is always output_width.
59− -- outputWidth.
60− , displayText :: DisplayText
61+ , display_text :: DisplayText
61− -- | The number of display columns for the text.
62+ -- | The number of display columns for the text. Always > 0.
62− , outputWidth :: Int
63+ , output_width :: Int
63− -- | the number of characters in the text.
64+ -- | the number of characters in the text. Always > 0.
64− , charWidth :: Int
65+ , char_width :: Int
65 }
66 }
66− -- | A horizontal join can be constructed between any two images.
67+ -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is
67− -- However a HorizJoin instance is required to be between two images
68− -- of equal height. The horizJoin constructor adds background fills
68+ -- required to be between two images of equal height. The horiz_join constructor adds background
69− -- to the provided images that assure this is true for the HorizJoin
69+ -- fills to the provided images that assure this is true for the HorizJoin value produced.
70− -- value produced.
71 | HorizJoin
70 | HorizJoin
72− { partLeft :: Image
71+ { part_left :: Image
73− , partRight :: Image
72+ , part_right :: Image
74− , outputWidth :: Int
73+ , output_width :: Int -- ^ image_width part_left == image_width part_right. Always > 1
75− -- ^ imageWidth partLeft == imageWidth partRight. Always > 0
74+ , output_height :: Int -- ^ image_height part_left == image_height part_right. Always > 0
76− , outputHeight :: Int
77− -- ^ imageHeight partLeft == imageHeight partRight. Always > 0
78 }
75 }
79− -- | A veritical join can be constructed between any two images.
76+ -- | A veritical join can be constructed between any two images. However a VertJoin instance is
80− -- However a VertJoin instance is required to be between two images
81− -- of equal width. The vertJoin constructor adds background fills
77+ -- required to be between two images of equal width. The vert_join constructor adds background
82− -- to the provides images that assure this is true for the VertJoin
78+ -- fills to the provides images that assure this is true for the VertJoin value produced.
83− -- value produced.
84 | VertJoin
79 | VertJoin
85− { partTop :: Image
80+ { part_top :: Image
86− , partBottom :: Image
81+ , part_bottom :: Image
87− , outputWidth :: Int
82+ , output_width :: Int -- ^ image_width part_top == image_width part_bottom. always > 0
88− -- ^ imageWidth partTop == imageWidth partBottom. always > 0
83+ , output_height :: Int -- ^ image_height part_top == image_height part_bottom. always > 1
89− , outputHeight :: Int
90− -- ^ imageHeight partTop == imageHeight partBottom. always > 1
91 }
84 }
92− -- | A background fill will be filled with the background char. The
85+ -- | A background fill will be filled with the background char. The background char is
93− -- background char is defined as a property of the Picture this
86+ -- defined as a property of the Picture this Image is used to form.
94− -- Image is used to form.
95 | BGFill
87 | BGFill
96− { outputWidth :: Int -- ^ always > 0
88+ { output_width :: Int -- ^ always > 0
97− , outputHeight :: Int -- ^ always > 0
89+ , output_height :: Int -- ^ always > 0
98 }
90 }
99− -- | Crop an image horizontally to a size by reducing the size from
91+ -- | Crop an image horizontally to a size by reducing the size from the right.
100− -- the right.
101 | CropRight
92 | CropRight
102− { croppedImage :: Image
93+ { cropped_image :: Image
103− -- | Always < imageWidth croppedImage > 0
94+ -- | Always < image_width cropped_image > 0
104− , outputWidth :: Int
95+ , output_width :: Int
105− , outputHeight :: Int -- ^ imageHeight croppedImage
96+ , output_height :: Int -- ^ image_height cropped_image
106 }
97 }
107− -- | Crop an image horizontally to a size by reducing the size from
98+ -- | Crop an image horizontally to a size by reducing the size from the left.
108− -- the left.
109 | CropLeft
99 | CropLeft
110− { croppedImage :: Image
100+ { cropped_image :: Image
111− -- | Always < imageWidth croppedImage > 0
101+ -- | Always < image_width cropped_image > 0
112− , leftSkip :: Int
102+ , left_skip :: Int
113− -- | Always < imageWidth croppedImage > 0
103+ -- | Always < image_width cropped_image > 0
114− , outputWidth :: Int
104+ , output_width :: Int
115− , outputHeight :: Int
105+ , output_height :: Int
116 }
106 }
117− -- | Crop an image vertically to a size by reducing the size from
107+ -- | Crop an image vertically to a size by reducing the size from the bottom
118− -- the bottom
119 | CropBottom
108 | CropBottom
120− { croppedImage :: Image
109+ { cropped_image :: Image
121− -- | imageWidth croppedImage
110+ -- | image_width cropped_image
122− , outputWidth :: Int
111+ , output_width :: Int
123− -- | height image is cropped to. Always < imageHeight croppedImage > 0
112+ -- | height image is cropped to. Always < image_height cropped_image > 0
124− , outputHeight :: Int
113+ , output_height :: Int
125 }
114 }
126− -- | Crop an image vertically to a size by reducing the size from
115+ -- | Crop an image vertically to a size by reducing the size from the top
127− -- the top
128 | CropTop
116 | CropTop
129− { croppedImage :: Image
117+ { cropped_image :: Image
130− -- | Always < imageHeight croppedImage > 0
118+ -- | Always < image_height cropped_image > 0
131− , topSkip :: Int
119+ , top_skip :: Int
132− -- | imageWidth croppedImage
120+ -- | image_width cropped_image
133− , outputWidth :: Int
121+ , output_width :: Int
134− -- | Always < imageHeight croppedImage > 0
122+ -- | Always < image_height cropped_image > 0
135− , outputHeight :: Int
123+ , output_height :: Int
136 }
124 }
137 -- | The empty image
125 -- | The empty image
138 --
126 --
139− -- The combining operators identity constant.
127+ -- The combining operators identity constant.
140 -- EmptyImage <|> a = a
128 -- EmptyImage <|> a = a
141 -- EmptyImage <-> a = a
129 -- EmptyImage <-> a = a
142− --
130+ --
143 -- Any image of zero size equals the empty image.
131 -- Any image of zero size equals the empty image.
144 | EmptyImage
132 | EmptyImage
145− deriving (Eq, Generic, Show, Read)
133+ deriving Eq
134+
135+instance Show Image where
136+ show ( HorizText { attr, display_text, output_width, char_width } )
137+ = "HorizText " ++ show display_text
138+ ++ "@(" ++ show attr ++ ","
139+ ++ show output_width ++ ","
140+ ++ show char_width ++ ")"
141+ show ( BGFill { output_width, output_height } )
142+ = "BGFill (" ++ show output_width ++ "," ++ show output_height ++ ")"
143+ show ( HorizJoin { part_left = l, part_right = r, output_width = c } )
144+ = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
145+ show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } )
146+ = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
147+ show ( CropRight { cropped_image, output_width, output_height } )
148+ = "CropRight [" ++ show output_width ++ "," ++ show output_height ++ "]"
149+ ++ " (" ++ show cropped_image ++ ")"
150+ show ( CropLeft { cropped_image, left_skip, output_width, output_height } )
151+ = "CropLeft [" ++ show left_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]"
152+ ++ " (" ++ show cropped_image ++ ")"
153+ show ( CropBottom { cropped_image, output_width, output_height } )
154+ = "CropBottom [" ++ show output_width ++ "," ++ show output_height ++ "]"
155+ ++ " (" ++ show cropped_image ++ ")"
156+ show ( CropTop { cropped_image, top_skip, output_width, output_height } )
157+ = "CropTop [" ++ show top_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]"
158+ ++ " (" ++ show cropped_image ++ ")"
159+ show ( EmptyImage ) = "EmptyImage"
146
160
147−-- | pretty print just the structure of an image.
161+-- | Attempts to pretty print just the structure of an image.
148−ppImageStructure :: Image -> String
162+pp_image_structure :: Image -> String
149−ppImageStructure = go 0
163+pp_image_structure in_img = go 0 in_img
150 where
164 where
151 go indent img = tab indent ++ pp indent img
165 go indent img = tab indent ++ pp indent img
152 tab indent = concat $ replicate indent " "
166 tab indent = concat $ replicate indent " "
153− pp _ (HorizText {outputWidth}) = "HorizText(" ++ show outputWidth ++ ")"
167+ pp _ (HorizText {output_width}) = "HorizText(" ++ show output_width ++ ")"
154− pp _ (BGFill {outputWidth, outputHeight})
168+ pp _ (BGFill {output_width, output_height})
155− = "BGFill(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"
169+ = "BGFill(" ++ show output_width ++ "," ++ show output_height ++ ")"
156− pp i (HorizJoin {partLeft = l, partRight = r, outputWidth = c})
170+ pp i (HorizJoin {part_left = l, part_right = r, output_width = c})
157 = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r
171 = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r
158− pp i (VertJoin {partTop = t, partBottom = b, outputWidth = c, outputHeight = r})
172+ pp i (VertJoin {part_top = t, part_bottom = b, output_width = c, output_height = r})
159 = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n"
173 = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n"
160 ++ go (i+1) t ++ "\n"
174 ++ go (i+1) t ++ "\n"
161 ++ go (i+1) b
175 ++ go (i+1) b
162− pp i (CropRight {croppedImage, outputWidth, outputHeight})
176+ pp i (CropRight {cropped_image, output_width, output_height})
163− = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"
177+ = "CropRight(" ++ show output_width ++ "," ++ show output_height ++ ")\n"
164− ++ go (i+1) croppedImage
178+ ++ go (i+1) cropped_image
165− pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})
179+ pp i (CropLeft {cropped_image, left_skip, output_width, output_height})
166− = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"
180+ = "CropLeft(" ++ show left_skip ++ "->" ++ show output_width ++ "," ++ show output_height ++ ")\n"
167− ++ go (i+1) croppedImage
181+ ++ go (i+1) cropped_image
168− pp i (CropBottom {croppedImage, outputWidth, outputHeight})
182+ pp i (CropBottom {cropped_image, output_width, output_height})
169− = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"
183+ = "CropBottom(" ++ show output_width ++ "," ++ show output_height ++ ")\n"
170− ++ go (i+1) croppedImage
184+ ++ go (i+1) cropped_image
171− pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight})
185+ pp i (CropTop {cropped_image, top_skip, output_width, output_height})
172− = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n"
186+ = "CropTop("++ show output_width ++ "," ++ show top_skip ++ "->" ++ show output_height ++ ")\n"
173− ++ go (i+1) croppedImage
187+ ++ go (i+1) cropped_image
174 pp _ EmptyImage = "EmptyImage"
188 pp _ EmptyImage = "EmptyImage"
175−
189+
176instance NFData Image where
190instance NFData Image where
177 rnf EmptyImage = ()
191 rnf EmptyImage = ()
178 rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()
192 rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()
@@ -184,102 +198,96 @@ instance NFData Image where
184 rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()
198 rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()
185 rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()
199 rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()
186
200
187−-- | The width of an Image. This is the number display columns the image
201+-- | The width of an Image. This is the number display columns the image will occupy.
188−-- will occupy.
189−imageWidth :: Image -> Int
202+image_width :: Image -> Int
190−imageWidth HorizText { outputWidth = w } = w
203+image_width HorizText { output_width = w } = w
191−imageWidth HorizJoin { outputWidth = w } = w
204+image_width HorizJoin { output_width = w } = w
192−imageWidth VertJoin { outputWidth = w } = w
205+image_width VertJoin { output_width = w } = w
193−imageWidth BGFill { outputWidth = w } = w
206+image_width BGFill { output_width = w } = w
194−imageWidth CropRight { outputWidth = w } = w
207+image_width CropRight { output_width = w } = w
195−imageWidth CropLeft { outputWidth = w } = w
208+image_width CropLeft { output_width = w } = w
196−imageWidth CropBottom { outputWidth = w } = w
209+image_width CropBottom { output_width = w } = w
197−imageWidth CropTop { outputWidth = w } = w
210+image_width CropTop { output_width = w } = w
198−imageWidth EmptyImage = 0
199−
200−-- | The height of an Image. This is the number of display rows the
201−-- image will occupy.
202−imageHeight :: Image -> Int
203−imageHeight HorizText {} = 1
204−imageHeight HorizJoin { outputHeight = h } = h
205−imageHeight VertJoin { outputHeight = h } = h
206−imageHeight BGFill { outputHeight = h } = h
207−imageHeight CropRight { outputHeight = h } = h
208−imageHeight CropLeft { outputHeight = h } = h
209−imageHeight CropBottom { outputHeight = h } = h
210−imageHeight CropTop { outputHeight = h } = h
211−imageHeight EmptyImage = 0
211+image_width EmptyImage = 0
212
212
213−-- | Append in the 'Semigroup' instance is equivalent to '<->'.
213+-- | The height of an Image. This is the number of display rows the image will occupy.
214−instance Semigroup Image where
214+image_height :: Image -> Int
215− (<>) = vertJoin
215+image_height HorizText {} = 1
216+image_height HorizJoin { output_height = h } = h
217+image_height VertJoin { output_height = h } = h
218+image_height BGFill { output_height = h } = h
219+image_height CropRight { output_height = h } = h
220+image_height CropLeft { output_height = h } = h
221+image_height CropBottom { output_height = h } = h
222+image_height CropTop { output_height = h } = h
223+image_height EmptyImage = 0
216
224
217−-- | Append in the 'Monoid' instance is equivalent to '<->'.
225+-- | Append in the Monoid instance is equivalent to <->.
218instance Monoid Image where
226instance Monoid Image where
219 mempty = EmptyImage
227 mempty = EmptyImage
220−#if !(MIN_VERSION_base(4,11,0))
221− mappend = (<>)
228+ mappend = vert_join
222−#endif
223
229
224-- | combines two images side by side
230-- | combines two images side by side
225--
231--
226−-- Combines text chunks where possible. Assures outputWidth and
232+-- Combines text chunks where possible. Assures output_width and output_height properties are not
227−-- outputHeight properties are not violated.
233+-- violated.
234+--
235+-- The result image will have a width equal to the sum of the two images width. And the height will
236+-- equal the largest height of the two images. The area not defined in one image due to a height
237+-- missmatch will be filled with the background pattern.
228--
238--
229−-- The result image will have a width equal to the sum of the two images
239+-- TODO: the bg fill is biased towards top to bottom languages(?)
230−-- 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
232−-- will be filled with the background pattern.
233−horizJoin :: Image -> Image -> Image
240+horiz_join :: Image -> Image -> Image
234−horizJoin EmptyImage i = i
241+horiz_join EmptyImage i = i
235−horizJoin i EmptyImage = i
242+horiz_join i EmptyImage = i
236−horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)
243+horiz_join i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1)
237− | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)
244+ | a_0 == a_1 = HorizText a_0 (TL.append t_0 t_1) (w_0 + w_1) (cw_0 + cw_1)
238− -- assumes horiz text height is always 1
245+ -- TODO: assumes horiz text height is always 1
239− | otherwise = HorizJoin i0 i1 (w0 + w1) 1
246+ | otherwise = HorizJoin i_0 i_1 (w_0 + w_1) 1
240−horizJoin i0 i1
247+horiz_join i_0 i_1
241 -- If the images are of the same height then no padding is required
248 -- If the images are of the same height then no padding is required
242− | h0 == h1 = HorizJoin i0 i1 w h0
249+ | h_0 == h_1 = HorizJoin i_0 i_1 w h_0
243 -- otherwise one of the images needs to be padded to the right size.
250 -- otherwise one of the images needs to be padded to the right size.
244− | h0 < h1 -- Pad i0
251+ | h_0 < h_1 -- Pad i_0
245− = let padAmount = h1 - h0
252+ = let pad_amount = h_1 - h_0
246− in HorizJoin (VertJoin i0 (BGFill w0 padAmount) w0 h1) i1 w h1
253+ in HorizJoin (VertJoin i_0 (BGFill w_0 pad_amount) w_0 h_1) i_1 w h_1
247− | h0 > h1 -- Pad i1
254+ | h_0 > h_1 -- Pad i_1
248− = let padAmount = h0 - h1
255+ = let pad_amount = h_0 - h_1
249− in HorizJoin i0 (VertJoin i1 (BGFill w1 padAmount) w1 h0) w h0
256+ in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 pad_amount) w_1 h_0) w h_0
250 where
257 where
251− w0 = imageWidth i0
258+ w_0 = image_width i_0
252− w1 = imageWidth i1
259+ w_1 = image_width i_1
253− w = w0 + w1
260+ w = w_0 + w_1
254− h0 = imageHeight i0
261+ h_0 = image_height i_0
255− h1 = imageHeight i1
262+ h_1 = image_height i_1
256−horizJoin _ _ = error "horizJoin applied to undefined values."
263+horiz_join _ _ = error "horiz_join applied to undefined values."
257
264
258-- | combines two images vertically
265-- | combines two images vertically
259--
266--
260−-- The result image will have a height equal to the sum of the heights
267+-- The result image will have a height equal to the sum of the heights of both images.
261−-- of both images. The width will equal the largest width of the two
268+-- The width will equal the largest width of the two images.
262−-- images. The area not defined in one image due to a width mismatch
269+-- The area not defined in one image due to a width missmatch will be filled with the background
263−-- will be filled with the background pattern.
270+-- pattern.
271+--
272+-- TODO: the bg fill is biased towards right to left languages(?)
264−vertJoin :: Image -> Image -> Image
273+vert_join :: Image -> Image -> Image
265−vertJoin EmptyImage i = i
274+vert_join EmptyImage i = i
266−vertJoin i EmptyImage = i
275+vert_join i EmptyImage = i
267−vertJoin i0 i1
276+vert_join i_0 i_1
268− -- If the images are of the same width then no background padding is
277+ -- If the images are of the same width then no background padding is required
269− -- required
270− | w0 == w1 = VertJoin i0 i1 w0 h
278+ | w_0 == w_1 = VertJoin i_0 i_1 w_0 h
271− -- Otherwise one of the images needs to be padded to the size of the
279+ -- Otherwise one of the images needs to be padded to the size of the other image.
272− -- other image.
280+ | w_0 < w_1
273− | w0 < w1
281+ = let pad_amount = w_1 - w_0
274− = let padAmount = w1 - w0
275− in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h
282+ in VertJoin (HorizJoin i_0 (BGFill pad_amount h_0) w_1 h_0) i_1 w_1 h
276− | w0 > w1
283+ | w_0 > w_1
277− = let padAmount = w0 - w1
284+ = let pad_amount = w_0 - w_1
278− in VertJoin i0 (HorizJoin i1 (BGFill padAmount h1) w0 h1) w0 h
285+ in VertJoin i_0 (HorizJoin i_1 (BGFill pad_amount h_1) w_0 h_1) w_0 h
279 where
286 where
280− w0 = imageWidth i0
287+ w_0 = image_width i_0
281− w1 = imageWidth i1
288+ w_1 = image_width i_1
282− h0 = imageHeight i0
289+ h_0 = image_height i_0
283− h1 = imageHeight i1
290+ h_1 = image_height i_1
284− h = h0 + h1
291+ h = h_0 + h_1
285−vertJoin _ _ = error "vertJoin applied to undefined values."
292+vert_join _ _ = error "vert_join applied to undefined values."
293+
src/Graphics/Vty/Inline.hs+68−83
@@ -1,126 +1,111 @@
1−-- | The inline module provides a limited interface to changing the
1+-- | The inline module provides a limited interface to changing the style of terminal output. The
2−-- style of terminal output. The intention is for this interface to be
3−-- used inline with other output systems.
2+-- intention is for this interface to be used inline with other output systems.
4--
3--
5−-- The changes specified by the InlineM monad are applied to the
4+-- The changes specified by the InlineM monad are applied to the terminals display attributes. These
6−-- terminal's display attributes. These display attributes affect the
7−-- display of all following text output to the terminal file descriptor.
5+-- display attributes effect the display of all following text output to the terminal file
6+-- descriptor.
8--
7--
9−-- For example, in an IO monad the following code will print the text
8+-- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the
10−-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
11−-- background and underlined.
9+-- text \" Styled! \" drawn over a red background and underlined.
12--
10--
13-- @
11-- @
14-- putStr \"Not styled. \"
12-- putStr \"Not styled. \"
15−-- putAttrChange_ $ do
13+-- put_attr_change_ $ do
16−-- backColor red
14+-- back_color red
17−-- applyStyle underline
15+-- apply_style underline
18-- putStr \" Styled! \"
16-- putStr \" Styled! \"
19−-- putAttrChange_ $ defaultAll
17+-- put_attr_change_ $ default_all
20-- putStrLn \"Not styled.\"
18-- putStrLn \"Not styled.\"
21-- @
19-- @
22--
20--
23−-- 'putAttrChange' emits the control codes to the terminal device
21+-- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate
24−-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when
25−-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been
22+-- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been
26−-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a
23+-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than
27−-- different 'Handle' than 'putAttrChange'.
24+-- 'put_attr_change'
28--
25--
29-- Copyright 2009-2010 Corey O'Connor
26-- Copyright 2009-2010 Corey O'Connor
27+{-# LANGUAGE BangPatterns #-}
30−module Graphics.Vty.Inline
28+module Graphics.Vty.Inline ( module Graphics.Vty.Inline
31− ( module Graphics.Vty.Inline
32− , withVty
29+ , withVty
33− )
30+ )
34−where
31+ where
35
32
36import Graphics.Vty
33import Graphics.Vty
37import Graphics.Vty.DisplayAttributes
34import Graphics.Vty.DisplayAttributes
38import Graphics.Vty.Inline.Unsafe
35import Graphics.Vty.Inline.Unsafe
36+import Graphics.Vty.Output.Interface
39
37
40import Blaze.ByteString.Builder (writeToByteString)
38import Blaze.ByteString.Builder (writeToByteString)
41
39
40+import Control.Applicative
42import Control.Monad.State.Strict
41import Control.Monad.State.Strict
43
42
44import Data.Bits ( (.&.), complement )
43import Data.Bits ( (.&.), complement )
45import Data.IORef
44import Data.IORef
45+import Data.Monoid ( mappend )
46
46
47import System.IO
47import System.IO
48
48
49−type InlineM v = State InlineState v
49+type InlineM v = State Attr v
50
50
51−data InlineState =
51+-- | Set the background color to the provided 'Color'
52− InlineState { inlineAttr :: Attr
52+back_color :: Color -> InlineM ()
53− , inlineUrlsEnabled :: Bool
53+back_color c = modify $ flip mappend ( current_attr `with_back_color` c )
54− }
55
54
56−-- | Set the background color to the provided 'Color'.
55+-- | Set the foreground color to the provided 'Color'
57−backColor :: Color -> InlineM ()
56+fore_color :: Color -> InlineM ()
58−backColor c = modify $ \s ->
57+fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )
59− s { inlineAttr = inlineAttr s `withBackColor` c
60− }
61
58
62−-- | Set the foreground color to the provided 'Color'.
63−foreColor :: Color -> InlineM ()
64−foreColor c = modify $ \s ->
65− s { inlineAttr = inlineAttr s `withForeColor` c
66− }
67−
68−-- | Attempt to change the 'Style' of the following text..
59+-- | Attempt to change the 'Style' of the following text.
69--
60--
70−-- If the terminal does not support the style change then no error is
61+-- If the terminal does not support the style change no error is produced. The style can still be
71−-- produced. The style can still be removed.
62+-- removed.
72−applyStyle :: Style -> InlineM ()
63+apply_style :: Style -> InlineM ()
73−applyStyle st = modify $ \s ->
64+apply_style s = modify $ flip mappend ( current_attr `with_style` s )
74− s { inlineAttr = inlineAttr s `withStyle` st
75− }
76
65
77−-- | Attempt to remove the specified 'Style' from the display of the
66+-- | Attempt to remove the specified 'Style' from the display of the following text.
78−-- following text.
79--
67--
80−-- This will fail if 'applyStyle' for the given style has not been
68+-- This will fail if apply_style for the given style has not been previously called.
81−-- previously called.
82−removeStyle :: Style -> InlineM ()
69+remove_style :: Style -> InlineM ()
83−removeStyle sMask = modify $ \s ->
70+remove_style s_mask = modify $ \attr ->
84− s { inlineAttr =
85− let style' = case attrStyle (inlineAttr s) of
71+ let style' = case attr_style attr of
86− Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
72+ Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
87− KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
73+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
88− SetTo st -> st .&. complement sMask
74+ SetTo s -> s .&. complement s_mask
89− in (inlineAttr s) { attrStyle = SetTo style' }
75+ in attr { attr_style = SetTo style' }
90− }
91
76
92−-- | Reset the display attributes.
77+-- | Reset the display attributes
93−defaultAll :: InlineM ()
78+default_all :: InlineM ()
94−defaultAll = modify $ \s -> s { inlineAttr = defAttr }
79+default_all = put def_attr
95
80
96−-- | Apply the provided display attribute changes to the given terminal
81+-- | Apply the provided display attribute changes to the given terminal.
97−-- output device.
98--
82--
99-- This does not flush the terminal.
83-- This does not flush the terminal.
100−putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()
84+put_attr_change :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()
101−putAttrChange out c = liftIO $ do
85+put_attr_change out c = liftIO $ do
102− bounds <- displayBounds out
86+ bounds <- display_bounds out
103− dc <- displayContext out bounds
87+ dc <- display_context out bounds
104− mfattr <- prevFattr <$> readIORef (assumedStateRef out)
88+ mfattr <- prev_fattr <$> readIORef (assumed_state_ref out)
105 fattr <- case mfattr of
89 fattr <- case mfattr of
106 Nothing -> do
90 Nothing -> do
107− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
91+ liftIO $ output_byte_buffer out $ writeToByteString $ write_default_attr dc
108− return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
92+ return $ FixedAttr default_style_mask Nothing Nothing
109 Just v -> return v
93 Just v -> return v
110− let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
94+ let attr = execState c current_attr
111− attr' = limitAttrForDisplay out attr
95+ attr' = limit_attr_for_display out attr
112− fattr' = fixDisplayAttr fattr attr'
96+ fattr' = fix_display_attr fattr attr'
113− diffs = displayAttrDiffs fattr fattr'
97+ diffs = display_attr_diffs fattr fattr'
114− outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
98+ output_byte_buffer out $ writeToByteString $ write_set_attr dc fattr attr' diffs
115− modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
99+ modifyIORef (assumed_state_ref out) $ \s -> s { prev_fattr = Just fattr' }
116− inlineHack dc
100+ inline_hack dc
117
101
118−-- | Apply the provided display attributes changes to the terminal
102+-- | Apply the provided display attributes changes to the terminal that was current at the time this
119−-- output device.
103+-- was first used. Which, for most use cases, is the current terminal.
120--
104--
121-- This will flush the terminal output.
105-- This will flush the terminal output.
122−putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
106+put_attr_change_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
123−putAttrChange_ c = liftIO $ withOutput $ \out -> do
107+put_attr_change_ c = liftIO $ do
108+ out <- withVty $ return . output_iface
124 hFlush stdout
109 hFlush stdout
125− putAttrChange out c
110+ put_attr_change out c
126 hFlush stdout
111 hFlush stdout
src/Graphics/Vty/Inline/Unsafe.hs+9−42
@@ -1,59 +1,26 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−
3module Graphics.Vty.Inline.Unsafe where
1module Graphics.Vty.Inline.Unsafe where
4
2
5import Graphics.Vty
3import Graphics.Vty
6
4
5+import Data.Default
7import Data.IORef
6import Data.IORef
8
7
9−import GHC.IO.Handle (hDuplicate)
10−
11−import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering))
12−
13import System.IO.Unsafe
8import System.IO.Unsafe
14
9
15−import System.Posix.IO (handleToFd)
16−
17−globalVty :: IORef (Maybe Vty)
10+global_vty :: IORef (Maybe Vty)
18−{-# NOINLINE globalVty #-}
11+{-# NOINLINE global_vty #-}
19−globalVty = unsafePerformIO $ newIORef Nothing
12+global_vty = unsafePerformIO $ newIORef Nothing
20
13
21−globalOutput :: IORef (Maybe Output)
22−{-# NOINLINE globalOutput #-}
23−globalOutput = unsafePerformIO $ newIORef Nothing
24−
25−mkDupeConfig :: IO Config
26−mkDupeConfig = do
27− hSetBuffering stdout NoBuffering
28− hSetBuffering stdin NoBuffering
29− stdinDupe <- hDuplicate stdin >>= handleToFd
30− stdoutDupe <- hDuplicate stdout >>= handleToFd
31− return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
32−
33−-- | This will create a Vty instance using 'mkVty' and execute an IO
14+-- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.
34−-- action provided that instance. The created Vty instance will be
15+-- The created Vty instance will be stored to the unsafe 'IORef' 'global_vty'.
35−-- stored to the unsafe 'IORef' 'globalVty'.
36−--
37−-- This instance will use duplicates of the stdin and stdout Handles.
38withVty :: (Vty -> IO b) -> IO b
16withVty :: (Vty -> IO b) -> IO b
39withVty f = do
17withVty f = do
40− mvty <- readIORef globalVty
18+ mvty <- readIORef global_vty
41 vty <- case mvty of
19 vty <- case mvty of
42 Nothing -> do
20 Nothing -> do
43− vty <- mkDupeConfig >>= mkVty
21+ vty <- mkVty def
44− writeIORef globalVty (Just vty)
22+ writeIORef global_vty (Just vty)
45 return vty
23 return vty
46 Just vty -> return vty
24 Just vty -> return vty
47 f vty
25 f vty
48
26
49−withOutput :: (Output -> IO b) -> IO b
50−withOutput f = do
51− mout <- readIORef globalOutput
52− out <- case mout of
53− Nothing -> do
54− config <- mappend <$> userConfig <*> mkDupeConfig
55− out <- outputForConfig config
56− writeIORef globalOutput (Just out)
57− return out
58− Just out -> return out
59− f out
src/Graphics/Vty/Input.hs+83−148
@@ -1,176 +1,111 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
2−
3−-- | This module provides the input layer for Vty, including methods
4−-- for initializing an 'Input' structure and reading 'Event's from the
1+-- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can
5−-- terminal.
2+-- then be used to read 'Event's from the terminal.
6−--
7−-- Note that due to the evolution of terminal emulators, some keys
8−-- and combinations will not reliably map to the expected events by
9−-- any terminal program. There is no 1:1 mapping from key events to
10−-- bytes read from the terminal input device. In very limited cases the
11−-- terminal and vty's input process can be customized to resolve these
12−-- issues; see "Graphics.Vty.Config" for how to configure vty's input
13−-- processing.
14−--
15−-- = VTY's Implementation
16−--
17−-- There are two input modes:
18−--
19−-- 1. 7-bit
20−--
21−-- 2. 8-bit
22−--
23−-- The 7-bit input mode is the default and the expected mode in most use
24−-- cases. This is what Vty uses.
25−--
26−-- == 7-bit input encoding
27−--
28−-- Control key combinations are represented by masking the two high bits
29−-- of the 7-bit input. Historically the control key actually grounded
30−-- the two high bit wires: 6 and 7. This is why control key combos
31−-- map to single character events: the input bytes are identical. The
32−-- input byte is the bit encoding of the character with bits 6 and 7
33−-- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For
34−-- example,
35−--
36−-- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become
37−-- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key.
38−--
39−-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
40−-- which is `0000011` and is the "End of Text" code.
41--
3--
42−-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this
4+-- Right, brain rot trying to figure this out exactly. So, as far as I can care:
43−-- is the value 1 with bit 7 set and 6 unset.
44--
5--
45−-- * Hypothesis: Bit 6 is unset by upper case letters because,
6+-- There are two input modes for control sequences:
46−-- initially, there were only upper case letters used and a 5 bit
47−-- encoding.
48--
7--
49−-- == 8-bit encoding
8+-- 1. 7 bit
50--
9--
51−-- The 8th bit was originally used for parity checking which is useless
10+-- 2. 8 bit
52−-- for terminal emulators. Some terminal emulators support an 8-bit
53−-- input encoding. While this provides some advantages, the actual usage
54−-- is low. Most systems use 7-bit mode but recognize 8-bit control
55−-- characters when escaped. This is what Vty does.
56--
11--
57−-- == Escaped Control Keys
12+-- Which should be used depends on the need to enter Unicode as UTF-8 or not.
58--
13--
59−-- Using 7-bit input encoding, the @ESC@ byte can signal the start of
14+-- * 7 bit mode: UTF-8 can be input unambiguiously. The timing of ESC in the input sequence
60−-- an encoded control key. To differentiate a single @ESC@ event from a
15+-- determines whether the ESC is: Individual, part of a control key sequence, part of a meta key
61−-- control key, the timing of the input is used.
16+-- combination.
62--
17--
63−-- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of
18+-- * 8 bit mode: UTF-8 cannot be input unamboguiously AFAIK. Does not require an escape delay.
64−-- 'VMIN' milliseconds.
65--
19--
66−-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte
20+-- vty assumes 7 bit mode. Which is the default AFAIK.
67−-- is followed by more bytes read within 'VMIN' milliseconds. All bytes
68−-- up until the next valid input block are passed to the classifier.
69--
21--
70−-- If the current runtime is the threaded runtime then the terminal's
22+-- 1. ESC individually: ESC byte, no bytes for control-seq-period,
71−-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
23+-- no bytes for meta-combo-period.
72−-- the current runtime does not support 'forkOS' then there is currently
73−-- no implementation.
74--
24--
75−-- == Unicode Input and Escaped Control Key Sequences
25+-- 2. control keys that contain ESC in their byte sequence: ESC byte, bytes read within
26+-- control-seq-period are part of the sequence. Up until the next valid input block.
76--
27--
77−-- The input encoding determines how UTF-8 encoded characters are
28+-- 3. ESC used as meta in a key combination: ESC byte, no other bytes read within
78−-- recognized.
29+-- control-seq-period. Bytes up until next valid input block are the input events plus meta.
79--
30--
80−-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
31+-- If the current runtime is the threaded runtime then the terminal's VMIN and VTIME parameters can
81−-- a superset of ASCII. UTF-8 does not overlap escaped control key
32+-- be applied to implement the above rules.
82−-- sequences. However, the escape key must be differentiated from
33+-- If the current runtime does not support forkOS then there is currently no implementation. Vty
83−-- escaped control key sequences by the timing of the input bytes.
34+-- used to implement a parser which did tricky things with non-blocking reads and timers. This could
84−--
35+-- be revived.
85−-- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not
86−-- require using the timing of input bytes to differentiate the escape
87−-- key. Many terminals do not support 8-bit mode.
88−--
89−-- == Terminfo
90−--
91−-- The terminfo system is used to determine how some keys are encoded.
92−-- Terminfo is incomplete and in some cases terminfo is incorrect. Vty
93−-- assumes terminfo is correct but provides a mechanism to override
94−-- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'.
95−--
96−-- == Terminal Input is Broken
97−--
98−-- Clearly terminal input has fundamental issues. There is no easy way
99−-- to reliably resolve these issues.
100−--
101−-- One resolution would be to ditch standard terminal interfaces
102−-- entirely and just go directly to scancodes. This would be a
103−-- reasonable option for Vty if everybody used the linux kernel console
104−-- but for obvious reasons this is not possible.
105−--
106−-- The "Graphics.Vty.Config" module supports customizing the
107−-- input-byte-to-event mapping and xterm supports customizing the
108−-- scancode-to-input-byte mapping. With a lot of work a user's system
109−-- can be set up to encode all the key combos in an almost-sane manner.
110−--
111−-- == See also
112−--
113−-- * http://www.leonerd.org.uk/hacks/fixterms/
114−module Graphics.Vty.Input
36+module Graphics.Vty.Input ( Key(..)
115− ( Key(..)
116− , Modifier(..)
37+ , Modifier(..)
117− , Button(..)
38+ , Button(..)
118− , Event(..)
39+ , Event(..)
119− , Input(..)
40+ , Input(..)
120− , inputForConfig
41+ , Config(..)
42+ , input_for_current_terminal
43+ , input_for_name_and_io
121− )
44+ )
122−where
45+ where
123
46
124−import Graphics.Vty.Config
125import Graphics.Vty.Input.Events
47import Graphics.Vty.Input.Events
126−import Graphics.Vty.Input.Loop
48+import Graphics.Vty.Input.Internal
127import Graphics.Vty.Input.Terminfo
49import Graphics.Vty.Input.Terminfo
128
50
129−import Control.Concurrent.STM
51+import Control.Concurrent
130−import Lens.Micro
52+import Control.Lens
131
53
132import qualified System.Console.Terminfo as Terminfo
54import qualified System.Console.Terminfo as Terminfo
55+import System.Environment
133import System.Posix.Signals.Exts
56import System.Posix.Signals.Exts
57+import System.Posix.IO (stdInput)
58+import System.Posix.Types (Fd)
134
59
135−#if !MIN_VERSION_base(4,11,0)
60+-- | Set up the current terminal for input.
136−import Data.Monoid ((<>))
61+-- This determines the current terminal then invokes 'input_for_name_and_io'
137−#endif
62+input_for_current_terminal :: Config -> IO Input
63+input_for_current_terminal config = do
64+ term_name <- getEnv "TERM"
65+ input_for_name_and_io config term_name stdInput
138
66
139−-- | Set up the terminal with file descriptor `inputFd` for input.
67+-- | Set up the terminal attached to the given Fd for input. Returns a 'Input'.
140−-- Returns an 'Input'.
141−--
68+--
142−-- The table used to determine the 'Events' to produce for the input
69+-- The terminal is modified as follows:
143−-- bytes comes from 'classifyMapForTerm' which is then overridden by
70+--
144−-- the the applicable entries from the configuration's 'inputMap'.
71+-- * IXON disabled
72+-- - disables software flow control on outgoing data. This stops the process from being
73+-- suspended if the output terminal cannot keep up. I presume this has little effect these
74+-- days. I hope this means that output will be buffered if the terminal cannot keep up. In the
75+-- old days the output might of been dropped?
76+--
77+-- "raw" mode is used for input.
78+--
79+-- * ISIG disabled
80+-- - enables keyboard combinations that result in signals. This should probably be a dynamic
81+-- option.
82+--
83+-- * ECHO disabled
84+-- - input is not echod to the output. Pobably should be a dynamic option.
145−--
85+--
146−-- The terminal device's mode flags are configured by the
86+-- * ICANON disabled
147−-- 'attributeControl' function.
87+-- - canonical mode (line mode) input is not used. Probably should be a dynamic option.
148−inputForConfig :: Config -> IO Input
88+--
149−inputForConfig config@Config{ termName = Just termName
89+-- * IEXTEN disabled
150− , inputFd = Just termFd
90+-- - extended functions are disabled. Uh. Whatever these are.
151− , vmin = Just _
91+--
152− , vtime = Just _
92+input_for_name_and_io :: Config -> String -> Fd -> IO Input
153− , .. } = do
93+input_for_name_and_io config term_name term_fd = do
154− terminal <- Terminfo.setupTerm termName
94+ terminal <- Terminfo.setupTerm term_name
155− let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
95+ let classify_table = classify_table_for_term term_name terminal
156− activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
96+ (set_attrs,unset_attrs) <- attributeControl term_fd
157− (setAttrs, unsetAttrs) <- attributeControl termFd
97+ set_attrs
158− setAttrs
98+ input <- initInputForFd config classify_table term_fd
159− input <- initInput config activeInputMap
160 let pokeIO = Catch $ do
99 let pokeIO = Catch $ do
161− setAttrs
100+ let e = error "(getsize in input layer)"
162− atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
101+ set_attrs
102+ writeChan (input^.event_channel) (EvResize e e)
163 _ <- installHandler windowChange pokeIO Nothing
103 _ <- installHandler windowChange pokeIO Nothing
164 _ <- installHandler continueProcess pokeIO Nothing
104 _ <- installHandler continueProcess pokeIO Nothing
165−
166− let restore = unsetAttrs
167−
168 return $ input
105 return $ input
169− { shutdownInput = do
106+ { shutdown_input = do
170− shutdownInput input
107+ shutdown_input input
171 _ <- installHandler windowChange Ignore Nothing
108 _ <- installHandler windowChange Ignore Nothing
172 _ <- installHandler continueProcess Ignore Nothing
109 _ <- installHandler continueProcess Ignore Nothing
173− restore
110+ unset_attrs
174− , restoreInputState = restoreInputState input >> restore
175 }
111 }
176−inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Classify.hsdeleted−110
@@ -1,110 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−-- This makes a kind of trie. Has space efficiency issues with large
3−-- input blocks. Likely building a parser and just applying that would
4−-- be better.
5−module Graphics.Vty.Input.Classify
6− ( classify
7− , KClass(..)
8− , ClassifierState(..)
9− )
10−where
11−
12−import Graphics.Vty.Input.Events
13−import Graphics.Vty.Input.Mouse
14−import Graphics.Vty.Input.Focus
15−import Graphics.Vty.Input.Paste
16−import Graphics.Vty.Input.Classify.Types
17−
18−import Codec.Binary.UTF8.Generic (decode)
19−
20−import Control.Arrow (first)
21−import qualified Data.Map as M( fromList, lookup )
22−import Data.Maybe ( mapMaybe )
23−import qualified Data.Set as S( fromList, member )
24−
25−import Data.Word
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
43−compile table = cl' where
44− -- take all prefixes and create a set of these
45− prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
46− maxValidInputLength = maximum (map (length . fst) table)
47− eventForInput = M.fromList $ map (first BS8.pack) table
48− cl' inputBlock | BS8.null inputBlock = Prefix
49− cl' inputBlock = case M.lookup inputBlock eventForInput of
50− -- if the inputBlock is exactly what is expected for an
51− -- event then consume the whole block and return the event
52− Just e -> Valid e BS8.empty
53− Nothing -> case S.member inputBlock prefixSet of
54− True -> Prefix
55− -- look up progressively smaller tails of the input
56− -- block until an event is found The assumption is that
57− -- the event that consumes the most input bytes should
58− -- be produced.
59− -- The test verifyFullSynInputToEvent2x verifies this.
60− -- H: There will always be one match. The prefixSet
61− -- contains, by definition, all prefixes of an event.
62− False ->
63− let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
64− in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
65− (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
66− -- neither a prefix or a full event.
67− [] -> Invalid
68−
69−classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
70−classify table = process
71− where
72− standardClassifier = compile table
73−
74− process ClassifierStart s =
75− case BS.uncons s of
76− _ | bracketedPasteStarted s ->
77− if bracketedPasteFinished s
78− then parseBracketedPaste s
79− else Chunk
80− _ | isMouseEvent s -> classifyMouseEvent s
81− _ | isFocusEvent s -> classifyFocusEvent s
82− Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs
83− _ -> standardClassifier s
84−
85− process (ClassifierInChunk p ps) s | bracketedPasteStarted p =
86− if bracketedPasteFinished s
87− then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
88− else Chunk
89− process ClassifierInChunk{} _ = Invalid
90−
91−classifyUtf8 :: Word8 -> ByteString -> KClass
92−classifyUtf8 c cs =
93− let n = utf8Length c
94− (codepoint,rest) = BS8.splitAt (n - 1) cs
95−
96− codepoint8 :: [Word8]
97− codepoint8 = c:BS.unpack codepoint
98−
99− in case decode codepoint8 of
100− _ | n < BS.length codepoint + 1 -> Prefix
101− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
102− -- something bad happened; just ignore and continue.
103− Nothing -> Invalid
104−
105−utf8Length :: Word8 -> Int
106−utf8Length c
107− | c < 0x80 = 1
108− | c < 0xE0 = 2
109− | c < 0xF0 = 3
110− | otherwise = 4
src/Graphics/Vty/Input/Classify/Parse.hsdeleted−61
@@ -1,61 +0,0 @@
1−-- | This module provides a simple parser for parsing input event
2−-- control sequences.
3−module Graphics.Vty.Input.Classify.Parse
4− ( Parser
5− , runParser
6− , failParse
7− , readInt
8− , readChar
9− , expectChar
10− )
11−where
12−
13−import Graphics.Vty.Input.Events
14−import Graphics.Vty.Input.Classify.Types
15−
16−import Control.Monad.Trans.Maybe
17−import Control.Monad.State
18−
19−import qualified Data.ByteString.Char8 as BS8
20−import Data.ByteString.Char8 (ByteString)
21−
22−type Parser a = MaybeT (State ByteString) a
23−
24−-- | Run a parser on a given input string. If the parser fails, return
25−-- 'Invalid'. Otherwise return the valid event ('Valid') and the
26−-- remaining unparsed characters.
27−runParser :: ByteString -> Parser Event -> KClass
28−runParser s parser =
29− case runState (runMaybeT parser) s of
30− (Nothing, _) -> Invalid
31− (Just e, remaining) -> Valid e remaining
32−
33−-- | Fail a parsing operation.
34−failParse :: Parser a
35−failParse = fail "invalid parse"
36−
37−-- | Read an integer from the input stream. If an integer cannot be
38−-- read, fail parsing. E.g. calling readInt on an input of "123abc" will
39−-- return '123' and consume those characters.
40−readInt :: Parser Int
41−readInt = do
42− s <- BS8.unpack <$> get
43− case (reads :: ReadS Int) s of
44− [(i, rest)] -> put (BS8.pack rest) >> return i
45− _ -> failParse
46−
47−-- | Read a character from the input stream. If one cannot be read (e.g.
48−-- we are out of characters), fail parsing.
49−readChar :: Parser Char
50−readChar = do
51− s <- get
52− case BS8.uncons s of
53− Just (c,rest) -> put rest >> return c
54− Nothing -> failParse
55−
56−-- | Read a character from the input stream and fail parsing if it is
57−-- not the specified character.
58−expectChar :: Char -> Parser ()
59−expectChar c = do
60− c' <- readChar
61− if c' == c then return () else failParse
src/Graphics/Vty/Input/Classify/Types.hsdeleted−25
@@ -1,25 +0,0 @@
1−-- | This module exports the input classification type to avoid import
2−-- cycles between other modules that need this.
3−{-# LANGUAGE StrictData #-}
4−module Graphics.Vty.Input.Classify.Types
5− ( KClass(..)
6− )
7−where
8−
9−import Graphics.Vty.Input.Events
10−
11−import Data.ByteString.Char8 (ByteString)
12−
13−data KClass
14− = Valid Event ByteString
15− -- ^ A valid event was parsed. Any unused characters from the input
16− -- stream are also provided.
17− | Invalid
18− -- ^ The input characters did not represent a valid event.
19− | Prefix
20− -- ^ The input characters form the prefix of a valid event character
21− -- sequence.
22− | Chunk
23− -- ^ The input characters are either start of a bracketed paste chunk
24− -- or in the middle of a bracketed paste chunk.
25− deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs+23−64
@@ -1,83 +1,42 @@
1−{-# Language DeriveGeneric #-}
2−{-# Language StrictData #-}
3module Graphics.Vty.Input.Events where
1module Graphics.Vty.Input.Events where
4
2
5−import Control.DeepSeq
6−import Data.ByteString
7−import GHC.Generics
8−
9-- | Representations of non-modifier keys.
3-- | Representations of non-modifier keys.
10--
4--
11−-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by
5+-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by terminal and keyboard.
12−-- terminal and keyboard.
13--
6--
14−-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by
7+-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by terminal and keyboard.
15−-- terminal and keyboard.
16--
8--
17−-- * Actually, support for most of these but KEsc, KChar, KBS, and
9+-- * Actually, support for most of these but KEsc, KChar, KBS, and KEnter vary by terminal and
18−-- KEnter vary by terminal and keyboard.
10+-- keyboard.
19−data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter
11+data Key = KEsc | KChar Char | KBS | KEnter
20 | KLeft | KRight | KUp | KDown
12 | KLeft | KRight | KUp | KDown
21 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
13 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
22− | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns
14+ | KFun Int | KBackTab | KPrtScr | KPause | KIns
23 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
15 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
24− deriving (Eq,Show,Read,Ord,Generic)
16+ deriving (Eq,Show,Ord)
25−
26−instance NFData Key
27
17
28−-- | Modifier keys. Key codes are interpreted such that users are more
18+-- | Modifier keys. Key codes are interpreted such that users are more likely to
29−-- likely to have Meta than Alt; for instance on the PC Linux console,
19+-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
30−-- 'MMeta' will generally correspond to the physical Alt key.
20+-- generally correspond to the physical Alt key.
31data Modifier = MShift | MCtrl | MMeta | MAlt
21data Modifier = MShift | MCtrl | MMeta | MAlt
32− deriving (Eq,Show,Read,Ord,Generic)
22+ deriving (Eq,Show,Ord)
33−
34−instance NFData Modifier
35
23
36-- | Mouse buttons.
24-- | Mouse buttons.
25+--
26+-- \todo not supported.
37−data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
27+data Button = BLeft | BMiddle | BRight
38− deriving (Eq,Show,Read,Ord,Generic)
28+ deriving (Eq,Show,Ord)
39−
40−instance NFData Button
41
29
42-- | Events.
30-- | Events.
43data Event
31data Event
44 = EvKey Key [Modifier]
32 = EvKey Key [Modifier]
45− -- ^ A keyboard key was pressed with the specified modifiers.
33+ -- | \todo mouse events are not supported
46− | EvMouseDown Int Int Button [Modifier]
34+ | EvMouse Int Int Button [Modifier]
47− -- ^ A mouse button was pressed at the specified column and row. Any
35+ -- | if read from 'event_channel' this is the size at the time of the signal. If read from
48− -- modifiers available in the event are also provided.
36+ -- 'next_event' this is the size at the time the event was processed by Vty. Typically these are
49− | EvMouseUp Int Int (Maybe Button)
37+ -- the same, but if somebody is resizing the terminal quickly they can be different.
50− -- ^ A mouse button was released at the specified column and
51− -- row. Some terminals report only that a button was released
52− -- without specifying which one; in that case, Nothing is provided.
53− -- Otherwise Just the button released is included in the event.
54 | EvResize Int Int
38 | EvResize Int Int
55− -- The terminal window was resized and the size is provided in the
56− -- integer fields (width, height).
57− | EvPaste ByteString
58− -- ^ A paste event occurs when a bracketed paste input sequence is
59− -- received. For terminals that support bracketed paste mode, these
60− -- events will be triggered on a paste event. Terminals that do not
61− -- support bracketed pastes will send the paste contents as ordinary
62− -- input (which is probably bad, so beware!) Note that the data is
63− -- provided in raw form and you'll have to decode (e.g. as UTF-8) if
64− -- that's what your application expects.
65− | EvLostFocus
66− -- ^ The terminal running the application lost input focus.
67− | EvGainedFocus
68− -- ^ The terminal running the application gained input focus.
69− deriving (Eq,Show,Read,Ord,Generic)
39+ deriving (Eq,Show,Ord)
70−
71−instance NFData Event
72−
73−type ClassifyMap = [(String,Event)]
74
40
75−-- | The type of internal events that drive the internal Vty event
41+-- | representation of mapping from input bytes to event
76−-- dispatching to the application.
42+type ClassifyTable = [(String, Event)]
77−data InternalEvent =
78− ResumeAfterSignal
79− -- ^ Vty resumed operation after the process was interrupted with a
80− -- signal. In practice this translates into a screen redraw in the
81− -- input event loop.
82− | InputEvent Event
83− -- ^ An input event was received.
src/Graphics/Vty/Input/Focus.hsdeleted−49
@@ -1,49 +0,0 @@
1−module Graphics.Vty.Input.Focus
2− ( requestFocusEvents
3− , disableFocusEvents
4− , isFocusEvent
5− , classifyFocusEvent
6− )
7−where
8−
9−import Graphics.Vty.Input.Events
10−import Graphics.Vty.Input.Classify.Types
11−import Graphics.Vty.Input.Classify.Parse
12−
13−import Control.Monad.State
14−
15−import qualified Data.ByteString.Char8 as BS8
16−import Data.ByteString.Char8 (ByteString)
17−
18−-- | These sequences set xterm-based terminals to send focus event
19−-- sequences.
20−requestFocusEvents :: ByteString
21−requestFocusEvents = BS8.pack "\ESC[?1004h"
22−
23−-- | These sequences disable focus events.
24−disableFocusEvents :: ByteString
25−disableFocusEvents = BS8.pack "\ESC[?1004l"
26−
27−-- | Does the specified string begin with a focus event?
28−isFocusEvent :: ByteString -> Bool
29−isFocusEvent s = BS8.isPrefixOf focusIn s ||
30− BS8.isPrefixOf focusOut s
31−
32−focusIn :: ByteString
33−focusIn = BS8.pack "\ESC[I"
34−
35−focusOut :: ByteString
36−focusOut = BS8.pack "\ESC[O"
37−
38−-- | Attempt to classify an input string as a focus event.
39−classifyFocusEvent :: ByteString -> KClass
40−classifyFocusEvent s = runParser s $ do
41− when (not $ isFocusEvent s) failParse
42−
43− expectChar '\ESC'
44− expectChar '['
45− ty <- readChar
46− case ty of
47− 'I' -> return EvGainedFocus
48− 'O' -> return EvLostFocus
49− _ -> failParse
src/Graphics/Vty/Input/Internal.hsnew file+234
@@ -0,0 +1,234 @@
1+{-# LANGUAGE NoMonomorphismRestriction #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE CPP #-}
4+-- | The input layer used to be a single function that correctly accounted for the non-threaded
5+-- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with
6+-- a more straightforward parser. The non-threaded runtime is no longer supported.
7+module Graphics.Vty.Input.Internal where
8+
9+import Graphics.Vty.Input.Events
10+
11+import Codec.Binary.UTF8.Generic (decode)
12+import Control.Applicative
13+import Control.Concurrent
14+import Control.Lens
15+import Control.Monad (when, mzero, forM_)
16+import Control.Monad.IO.Class (liftIO)
17+import Control.Monad.Trans.State (StateT(..), evalStateT)
18+import Control.Monad.Trans.Reader (ReaderT(..))
19+
20+import Data.Char
21+import Data.Default
22+import Data.IORef
23+import Data.List(tails,inits)
24+import qualified Data.Map as M( fromList, lookup )
25+import Data.Maybe ( mapMaybe )
26+import qualified Data.Set as S( fromList, member )
27+import Data.Word
28+
29+import Foreign ( allocaArray, peekArray, Ptr )
30+import Foreign.C.Types (CInt(..))
31+
32+import System.Posix.IO (fdReadBuf)
33+import System.Posix.Terminal
34+import System.Posix.Types (Fd(..))
35+
36+data Config = Config
37+ { singleEscPeriod :: Int -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
38+ } deriving (Show, Eq)
39+
40+instance Default Config where
41+ def = Config
42+ { singleEscPeriod = 100000
43+ }
44+
45+data Input = Input
46+ { -- | Channel of events direct from input processing. Unlike 'next_event' this will not refresh
47+ -- the display if the next event is an 'EvResize'.
48+ _event_channel :: Chan Event
49+ -- | Shuts down the input processing. This should return the terminal input state to before
50+ -- the input initialized.
51+ , shutdown_input :: IO ()
52+ -- | Changes to this value are reflected after the next event.
53+ , _config_ref :: IORef Config
54+ -- | File descriptor used for input.
55+ , _input_fd :: Fd
56+ }
57+
58+makeLenses ''Input
59+
60+data KClass
61+ = Valid Event [Char]
62+ | Invalid
63+ | Prefix
64+ deriving(Show, Eq)
65+
66+data InputBuffer = InputBuffer
67+ { _ptr :: Ptr Word8
68+ , _size :: Int
69+ }
70+
71+makeLenses ''InputBuffer
72+
73+data InputState = InputState
74+ { _unprocessed_bytes :: String
75+ , _applied_config :: Config
76+ , _input_buffer :: InputBuffer
77+ , _stop_request_ref :: IORef Bool
78+ , _classifier :: String -> KClass
79+ }
80+
81+makeLenses ''InputState
82+
83+type InputM a = StateT InputState (ReaderT Input IO) a
84+
85+-- this must be run on an OS thread dedicated to this input handling.
86+-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
87+loop_input_processor :: InputM ()
88+loop_input_processor = do
89+ read_from_device >>= add_bytes_to_process
90+ valid_events <- many parse_event
91+ forM_ valid_events emit
92+ drop_invalid
93+ stop_if_requested <|> loop_input_processor
94+
95+add_bytes_to_process :: String -> InputM ()
96+add_bytes_to_process block = unprocessed_bytes <>= block
97+
98+emit :: Event -> InputM ()
99+emit event = view event_channel >>= liftIO . flip writeChan event
100+
101+-- There should be two versions of this method:
102+-- 1. using VMIN and VTIME when under the threaded runtime
103+-- 2. emulating VMIN and VTIME in userspace when under the non-threaded runtime.
104+read_from_device :: InputM String
105+read_from_device = do
106+ new_config <- view config_ref >>= liftIO . readIORef
107+ old_config <- use applied_config
108+ fd <- view input_fd
109+ when (new_config /= old_config) $ do
110+ liftIO $ apply_timing_config fd new_config
111+ applied_config .= new_config
112+ buffer_ptr <- use $ input_buffer.ptr
113+ max_bytes <- use $ input_buffer.size
114+ liftIO $ do
115+ bytes_read <- fdReadBuf fd buffer_ptr (fromIntegral max_bytes)
116+ if bytes_read > 0
117+ then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytes_read) buffer_ptr
118+ else return []
119+
120+apply_timing_config :: Fd -> Config -> IO ()
121+apply_timing_config fd config =
122+ let vtime = min 255 $ singleEscPeriod config `div` 100000
123+ in set_term_timing fd 1 vtime
124+
125+parse_event :: InputM Event
126+parse_event = do
127+ c <- use classifier
128+ b <- use unprocessed_bytes
129+ case c b of
130+ Valid e remaining -> do
131+ unprocessed_bytes .= remaining
132+ return e
133+ _ -> mzero
134+
135+drop_invalid :: InputM ()
136+drop_invalid = do
137+ c <- use classifier
138+ b <- use unprocessed_bytes
139+ when (c b == Invalid) $ unprocessed_bytes .= []
140+
141+stop_if_requested :: InputM ()
142+stop_if_requested = do
143+ True <- (liftIO . readIORef) =<< use stop_request_ref
144+ return ()
145+
146+-- This makes a kind of tri. Has space efficiency issues with large input blocks.
147+-- Likely building a parser and just applying that would be better.
148+-- I did not write this so I might just rewrite it for better understanding. Not the best of
149+-- reasons...
150+-- TODO: measure and rewrite if required.
151+compile :: ClassifyTable -> [Char] -> KClass
152+compile table = cl' where
153+ -- take all prefixes and create a set of these
154+ prefix_set = S.fromList $ concatMap (init . inits . fst) $ table
155+ event_for_input = M.fromList table
156+ cl' [] = Prefix
157+ cl' input_block = case M.lookup input_block event_for_input of
158+ Just e -> Valid e []
159+ Nothing -> case S.member input_block prefix_set of
160+ True -> Prefix
161+ -- if the input_block is exactly what is expected for an event then consume the whole
162+ -- block and return the event
163+ -- look up progressively smaller tails of the input block until an event is found
164+ -- The assumption is that the event that consumes the most input bytes should be
165+ -- produced.
166+ -- The test verify_full_syn_input_to_event_2x verifies this.
167+ -- H: There will always be one match. The prefix_set contains, by definition, all
168+ -- prefixes of an event.
169+ False ->
170+ let input_tails = init $ tail $ tails input_block
171+ in case mapMaybe (\s -> (,) s `fmap` M.lookup s event_for_input) input_tails of
172+ (s,e) : _ -> Valid e (drop (length s) input_block)
173+ -- neither a prefix or a full event. Might be interesting to log.
174+ [] -> Invalid
175+
176+classify, classifyTab :: ClassifyTable -> [Char] -> KClass
177+
178+-- As soon as
179+classify _table s@(c:_) | ord c >= 0xC2
180+ = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
181+classify table other
182+ = classifyTab table other
183+
184+classifyUtf8 :: [Char] -> KClass
185+classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
186+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) []
187+ _ -> Invalid -- something bad happened; just ignore and continue.
188+
189+classifyTab table = compile table
190+
191+first :: (a -> b) -> (a,c) -> (b,c)
192+first f (x,y) = (f x, y)
193+
194+utf8Length :: (Num t, Ord a, Num a) => a -> t
195+utf8Length c
196+ | c < 0x80 = 1
197+ | c < 0xE0 = 2
198+ | c < 0xF0 = 3
199+ | otherwise = 4
200+
201+run_input_processor_loop :: ClassifyTable -> Input -> IORef Bool -> IO ()
202+run_input_processor_loop classify_table input stop_flag = do
203+ let buffer_size = 1024
204+ allocaArray buffer_size $ \(buffer_ptr :: Ptr Word8) -> do
205+ s0 <- InputState [] <$> readIORef (_config_ref input)
206+ <*> pure (InputBuffer buffer_ptr buffer_size)
207+ <*> pure stop_flag
208+ <*> pure (classify classify_table)
209+ runReaderT (evalStateT loop_input_processor s0) input
210+
211+attributeControl :: Fd -> IO (IO (), IO ())
212+attributeControl fd = do
213+ original <- getTerminalAttributes fd
214+ let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
215+ , EnableEcho, ProcessInput, ExtendedFunctions
216+ ]
217+ let set_attrs = setTerminalAttributes fd vtyMode Immediately
218+ unset_attrs = setTerminalAttributes fd original Immediately
219+ return (set_attrs,unset_attrs)
220+
221+-- This is an example of an algorithm where code coverage could be high, even 100%, but the
222+-- algorithm still under tested. I should collect more of these examples...
223+initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input
224+initInputForFd config classify_table in_fd = do
225+ apply_timing_config in_fd config
226+ stop_flag <- newIORef False
227+ input <- Input <$> newChan
228+ <*> pure (writeIORef stop_flag True)
229+ <*> newIORef config
230+ <*> pure in_fd
231+ _ <- forkOS $ run_input_processor_loop classify_table input stop_flag
232+ return input
233+
234+foreign import ccall "vty_set_term_timing" set_term_timing :: Fd -> Int -> Int -> IO ()
src/Graphics/Vty/Input/Loop.hsdeleted−286
@@ -1,286 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoMonomorphismRestriction #-}
3−{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TemplateHaskell #-}
6−{-# OPTIONS_HADDOCK hide #-}
7−-- | The input layer used to be a single function that correctly
8−-- accounted for the non-threaded runtime by emulating the terminal
9−-- VMIN adn VTIME handling. This has been removed and replace with a
10−-- more straightforward parser. The non-threaded runtime is no longer
11−-- supported.
12−--
13−-- This is an example of an algorithm where code coverage could be high,
14−-- even 100%, but the behavior is still under tested. I should collect
15−-- more of these examples...
16−--
17−-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
18−module Graphics.Vty.Input.Loop where
19−
20−import Graphics.Vty.Config
21−import Graphics.Vty.Input.Classify
22−import Graphics.Vty.Input.Events
23−
24−import Control.Applicative
25−import Control.Concurrent
26−import Control.Concurrent.STM
27−import Control.Exception (mask, try, SomeException)
28−import Lens.Micro hiding ((<>~))
29−import Lens.Micro.Mtl
30−import Lens.Micro.TH
31−import Control.Monad (when, mzero, forM_)
32−import Control.Monad.IO.Class (liftIO)
33−import Control.Monad.Trans.State (StateT(..), evalStateT)
34−import Control.Monad.State.Class (MonadState, modify)
35−import Control.Monad.Trans.Reader (ReaderT(..))
36−
37−import qualified Data.ByteString.Char8 as BS8
38−import qualified Data.ByteString as BS
39−import Data.ByteString.Char8 (ByteString)
40−import Data.IORef
41−import Data.Word (Word8)
42−
43−import Foreign (allocaArray)
44−import Foreign.C.Types (CInt(..))
45−import Foreign.Ptr (Ptr, castPtr)
46−
47−import System.IO
48−import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
49−import System.Posix.Terminal
50−import System.Posix.Types (Fd(..))
51−
52−import Text.Printf (hPrintf)
53−
54−data Input = Input
55− { -- | Channel of events direct from input processing. Unlike
56− -- 'nextEvent' this will not refresh the display if the next event
57− -- is an 'EvResize'.
58− _eventChannel :: TChan InternalEvent
59− -- | Shuts down the input processing. As part of shutting down the
60− -- input, this should also restore the input state.
61− , shutdownInput :: IO ()
62− -- | Restore the terminal's input state to what it was prior
63− -- to configuring input for Vty. This should be done as part of
64− -- 'shutdownInput' but is exposed in case you need to access it
65− -- directly.
66− , restoreInputState :: IO ()
67− -- | Changes to this value are reflected after the next event.
68− , _configRef :: IORef Config
69− -- | input debug log
70− , _inputDebug :: Maybe Handle
71− }
72−
73−makeLenses ''Input
74−
75−data InputBuffer = InputBuffer
76− { _ptr :: Ptr Word8
77− , _size :: Int
78− }
79−
80−makeLenses ''InputBuffer
81−
82−data InputState = InputState
83− { _unprocessedBytes :: ByteString
84− , _classifierState :: ClassifierState
85− , _appliedConfig :: Config
86− , _inputBuffer :: InputBuffer
87− , _classifier :: ClassifierState -> ByteString -> KClass
88− }
89−
90−makeLenses ''InputState
91−
92−type InputM a = StateT InputState (ReaderT Input IO) a
93−
94−logMsg :: String -> InputM ()
95−logMsg msg = do
96− d <- view inputDebug
97− case d of
98− Nothing -> return ()
99− Just h -> liftIO $ hPutStrLn h msg >> hFlush h
100−
101−-- this must be run on an OS thread dedicated to this input handling.
102−-- otherwise the terminal timing read behavior will block the execution
103−-- of the lightweight threads.
104−loopInputProcessor :: InputM ()
105−loopInputProcessor = do
106− readFromDevice >>= addBytesToProcess
107− validEvents <- many parseEvent
108− forM_ validEvents emit
109− dropInvalid
110− loopInputProcessor
111−
112−addBytesToProcess :: ByteString -> InputM ()
113−addBytesToProcess block = unprocessedBytes <>= block
114−
115−emit :: Event -> InputM ()
116−emit event = do
117− logMsg $ "parsed event: " ++ show event
118− view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
119−
120−-- The timing requirements are assured by the VMIN and VTIME set for the
121−-- device.
122−--
123−-- Precondition: Under the threaded runtime. Only current use is from a
124−-- forkOS thread. That case satisfies precondition.
125−readFromDevice :: InputM ByteString
126−readFromDevice = do
127− newConfig <- view configRef >>= liftIO . readIORef
128− oldConfig <- use appliedConfig
129− let Just fd = inputFd newConfig
130− when (newConfig /= oldConfig) $ do
131− logMsg $ "new config: " ++ show newConfig
132− liftIO $ applyConfig fd newConfig
133− appliedConfig .= newConfig
134− bufferPtr <- use $ inputBuffer.ptr
135− maxBytes <- use $ inputBuffer.size
136− stringRep <- liftIO $ do
137− -- The killThread used in shutdownInput will not interrupt the
138− -- foreign call fdReadBuf uses this provides a location to be
139− -- interrupted prior to the foreign call. If there is input on
140− -- the FD then the fdReadBuf will return in a finite amount of
141− -- time due to the vtime terminal setting.
142− threadWaitRead fd
143− bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
144− if bytesRead > 0
145− then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
146− else return BS.empty
147− when (not $ BS.null stringRep) $
148− logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
149− return stringRep
150−
151−applyConfig :: Fd -> Config -> IO ()
152−applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })
153− = setTermTiming fd theVmin (theVtime `div` 100)
154−applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"
155−
156−parseEvent :: InputM Event
157−parseEvent = do
158− c <- use classifier
159− s <- use classifierState
160− b <- use unprocessedBytes
161− case c s b of
162− Valid e remaining -> do
163− logMsg $ "valid parse: " ++ show e
164− logMsg $ "remaining: " ++ show remaining
165− classifierState .= ClassifierStart
166− unprocessedBytes .= remaining
167− return e
168− _ -> mzero
169−
170−dropInvalid :: InputM ()
171−dropInvalid = do
172− c <- use classifier
173− s <- use classifierState
174− b <- use unprocessedBytes
175− case c s b of
176− Chunk -> do
177− classifierState .=
178− case s of
179− ClassifierStart -> ClassifierInChunk b []
180− ClassifierInChunk p bs -> ClassifierInChunk p (b:bs)
181− unprocessedBytes .= BS8.empty
182− Invalid -> do
183− logMsg "dropping input bytes"
184− classifierState .= ClassifierStart
185− unprocessedBytes .= BS8.empty
186− _ -> return ()
187−
188−runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
189−runInputProcessorLoop classifyTable input = do
190− let bufferSize = 1024
191− allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
192− s0 <- InputState BS8.empty ClassifierStart
193− <$> readIORef (_configRef input)
194− <*> pure (InputBuffer bufferPtr bufferSize)
195− <*> pure (classify classifyTable)
196− runReaderT (evalStateT loopInputProcessor s0) input
197−
198−-- | Construct two IO actions: one to configure the terminal for Vty and
199−-- one to restore the terminal mode flags to the values they had at the
200−-- time this function was called.
201−--
202−-- This function constructs a configuration action to clear the
203−-- following terminal mode flags:
204−--
205−-- * IXON disabled: disables software flow control on outgoing data.
206−-- This stops the process from being suspended if the output terminal
207−-- cannot keep up.
208−--
209−-- * Raw mode is used for input.
210−--
211−-- * ISIG (enables keyboard combinations that result in
212−-- signals)
213−--
214−-- * ECHO (input is not echoed to the output)
215−--
216−-- * ICANON (canonical mode (line mode) input is not used)
217−--
218−-- * IEXTEN (extended functions are disabled)
219−--
220−-- The configuration action also explicitly sets these flags:
221−--
222−-- * ICRNL (input carriage returns are mapped to newlines)
223−attributeControl :: Fd -> IO (IO (), IO ())
224−attributeControl fd = do
225− original <- getTerminalAttributes fd
226− let vtyMode = foldl withMode clearedFlags flagsToSet
227− clearedFlags = foldl withoutMode original flagsToUnset
228− flagsToSet = [ MapCRtoLF -- ICRNL
229− ]
230− flagsToUnset = [ StartStopOutput -- IXON
231− , KeyboardInterrupts -- ISIG
232− , EnableEcho -- ECHO
233− , ProcessInput -- ICANON
234− , ExtendedFunctions -- IEXTEN
235− ]
236− let setAttrs = setTerminalAttributes fd vtyMode Immediately
237− unsetAttrs = setTerminalAttributes fd original Immediately
238− return (setAttrs, unsetAttrs)
239−
240−logInitialInputState :: Input -> ClassifyMap -> IO()
241−logInitialInputState input classifyTable = case _inputDebug input of
242− Nothing -> return ()
243− Just h -> do
244− Config{ vmin = Just theVmin
245− , vtime = Just theVtime
246− , termName = Just theTerm } <- readIORef $ _configRef input
247− _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
248− forM_ classifyTable $ \i -> case i of
249− (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
250− (show inBytes)
251− (show k)
252− (show mods)
253− _ -> return ()
254−
255−initInput :: Config -> ClassifyMap -> IO Input
256−initInput config classifyTable = do
257− let Just fd = inputFd config
258− setFdOption fd NonBlockingRead False
259− applyConfig fd config
260− stopSync <- newEmptyMVar
261− input <- Input <$> atomically newTChan
262− <*> pure (return ())
263− <*> pure (return ())
264− <*> newIORef config
265− <*> maybe (return Nothing)
266− (\f -> Just <$> openFile f AppendMode)
267− (debugLog config)
268− logInitialInputState input classifyTable
269− inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input)
270− (\_ -> putMVar stopSync ())
271− let killAndWait = do
272− killThread inputThread
273− takeMVar stopSync
274− return $ input { shutdownInput = killAndWait }
275−
276−foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()
277−
278−forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
279−forkOSFinally action and_then =
280− mask $ \restore -> forkOS $ try (restore action) >>= and_then
281−
282−(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()
283−l <>= a = modify (l <>~ a)
284−
285−(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t
286−l <>~ n = over l (`mappend` n)
src/Graphics/Vty/Input/Mouse.hsdeleted−163
@@ -1,163 +0,0 @@
1−-- | This module provides parsers for mouse events for both "normal" and
2−-- "extended" modes. This implementation was informed by
3−--
4−-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
5−module Graphics.Vty.Input.Mouse
6− ( requestMouseEvents
7− , disableMouseEvents
8− , isMouseEvent
9− , classifyMouseEvent
10− )
11−where
12−
13−import Graphics.Vty.Input.Events
14−import Graphics.Vty.Input.Classify.Types
15−import Graphics.Vty.Input.Classify.Parse
16−
17−import Control.Monad.State
18−import Data.Maybe (catMaybes)
19−import Data.Bits ((.&.))
20−
21−import qualified Data.ByteString.Char8 as BS8
22−import Data.ByteString.Char8 (ByteString)
23−
24−-- A mouse event in SGR extended mode is
25−--
26−-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
27−--
28−-- where
29−--
30−-- * B is the number with button and modifier bits set,
31−-- * X is the X coordinate of the event starting at 1
32−-- * Y is the Y coordinate of the event starting at 1
33−-- * the final character is 'M' for a press, 'm' for a release
34−
35−-- | These sequences set xterm-based terminals to send mouse event
36−-- sequences.
37−requestMouseEvents :: ByteString
38−requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
39−
40−-- | These sequences disable mouse events.
41−disableMouseEvents :: ByteString
42−disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
43−
44−-- | Does the specified string begin with a mouse event?
45−isMouseEvent :: ByteString -> Bool
46−isMouseEvent s = isSGREvent s || isNormalEvent s
47−
48−isSGREvent :: ByteString -> Bool
49−isSGREvent = BS8.isPrefixOf sgrPrefix
50−
51−sgrPrefix :: ByteString
52−sgrPrefix = BS8.pack "\ESC[M"
53−
54−isNormalEvent :: ByteString -> Bool
55−isNormalEvent = BS8.isPrefixOf normalPrefix
56−
57−normalPrefix :: ByteString
58−normalPrefix = BS8.pack "\ESC[<"
59−
60−-- Modifier bits:
61−shiftBit :: Int
62−shiftBit = 4
63−
64−metaBit :: Int
65−metaBit = 8
66−
67−ctrlBit :: Int
68−ctrlBit = 16
69−
70−-- These bits indicate the buttons involved:
71−buttonMask :: Int
72−buttonMask = 67
73−
74−leftButton :: Int
75−leftButton = 0
76−
77−middleButton :: Int
78−middleButton = 1
79−
80−rightButton :: Int
81−rightButton = 2
82−
83−scrollUp :: Int
84−scrollUp = 64
85−
86−scrollDown :: Int
87−scrollDown = 65
88−
89−hasBitSet :: Int -> Int -> Bool
90−hasBitSet val bit = val .&. bit > 0
91−
92−-- | Attempt to classify an input string as a mouse event.
93−classifyMouseEvent :: ByteString -> KClass
94−classifyMouseEvent s = runParser s $ do
95− when (not $ isMouseEvent s) failParse
96−
97− expectChar '\ESC'
98− expectChar '['
99− ty <- readChar
100− case ty of
101− '<' -> classifySGRMouseEvent
102− 'M' -> classifyNormalMouseEvent
103− _ -> failParse
104−
105−-- Given a modifier/button value, determine which button was indicated
106−getSGRButton :: Int -> Parser Button
107−getSGRButton mods =
108− let buttonMap = [ (leftButton, BLeft)
109− , (middleButton, BMiddle)
110− , (rightButton, BRight)
111− , (scrollUp, BScrollUp)
112− , (scrollDown, BScrollDown)
113− ]
114− in case lookup (mods .&. buttonMask) buttonMap of
115− Nothing -> failParse
116− Just b -> return b
117−
118−getModifiers :: Int -> [Modifier]
119−getModifiers mods =
120− catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing
121− , if mods `hasBitSet` metaBit then Just MMeta else Nothing
122− , if mods `hasBitSet` ctrlBit then Just MCtrl else Nothing
123− ]
124−
125−-- Attempt to classify a control sequence as a "normal" mouse event. To
126−-- get here we should have already read "\ESC[M" so that will not be
127−-- included in the string to be parsed.
128−classifyNormalMouseEvent :: Parser Event
129−classifyNormalMouseEvent = do
130− statusChar <- readChar
131− xCoordChar <- readChar
132− yCoordChar <- readChar
133−
134− let xCoord = fromEnum xCoordChar - 32
135− yCoord = fromEnum yCoordChar - 32
136− status = fromEnum statusChar
137− modifiers = getModifiers status
138−
139− let press = status .&. buttonMask /= 3
140− case press of
141− True -> do
142− button <- getSGRButton status
143− return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers
144− False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing
145−
146−-- Attempt to classify a control sequence as an SGR mouse event. To
147−-- get here we should have already read "\ESC[<" so that will not be
148−-- included in the string to be parsed.
149−classifySGRMouseEvent :: Parser Event
150−classifySGRMouseEvent = do
151− mods <- readInt
152− expectChar ';'
153− xCoord <- readInt
154− expectChar ';'
155− yCoord <- readInt
156− final <- readChar
157−
158− let modifiers = getModifiers mods
159− button <- getSGRButton mods
160− case final of
161− 'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers
162− 'm' -> return $ EvMouseUp (xCoord-1) (yCoord-1) (Just button)
163− _ -> failParse
src/Graphics/Vty/Input/Paste.hsdeleted−41
@@ -1,41 +0,0 @@
1−-- | This module provides bracketed paste support as described at
2−--
3−-- http://cirw.in/blog/bracketed-paste
4−module Graphics.Vty.Input.Paste
5− ( parseBracketedPaste
6− , bracketedPasteStarted
7− , bracketedPasteFinished
8− )
9−where
10−
11−import qualified Data.ByteString.Char8 as BS8
12−import Data.ByteString.Char8 (ByteString)
13−
14−import Graphics.Vty.Input.Events
15−import Graphics.Vty.Input.Classify.Types
16−
17−bracketedPasteStart :: ByteString
18−bracketedPasteStart = BS8.pack "\ESC[200~"
19−
20−bracketedPasteEnd :: ByteString
21−bracketedPasteEnd = BS8.pack "\ESC[201~"
22−
23−-- | Does the input start a bracketed paste?
24−bracketedPasteStarted :: ByteString -> Bool
25−bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart
26−
27−-- | Does the input contain a complete bracketed paste?
28−bracketedPasteFinished :: ByteString -> Bool
29−bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd
30−
31−-- | Parse a bracketed paste. This should only be called on a string if
32−-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
33−-- 'True'.
34−parseBracketedPaste :: ByteString -> KClass
35−parseBracketedPaste s =
36− Valid (EvPaste p) (BS8.drop endLen rest')
37− where
38− startLen = BS8.length bracketedPasteStart
39− endLen = BS8.length bracketedPasteEnd
40− (_, rest ) = BS8.breakSubstring bracketedPasteStart s
41− (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest
src/Graphics/Vty/Input/Terminfo.hs+65−67
@@ -1,14 +1,14 @@
1−{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
2module Graphics.Vty.Input.Terminfo where
1module Graphics.Vty.Input.Terminfo where
3
2
4import Graphics.Vty.Input.Events
3import Graphics.Vty.Input.Events
5−import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT
4+import qualified Graphics.Vty.Input.Terminfo.ANSI as ANSI
5+import qualified Graphics.Vty.Input.Terminfo.XTerm7Bit as XTerm7Bit
6
6
7import Control.Arrow
7import Control.Arrow
8import System.Console.Terminfo
8import System.Console.Terminfo
9
9
10−-- | Queries the terminal for all capability-based input sequences and
10+-- | queries the terminal for all capability based input sequences then adds on a terminal dependent
11−-- then adds on a terminal-dependent input sequence mapping.
11+-- input sequence mapping.
12--
12--
13-- For reference see:
13-- For reference see:
14--
14--
@@ -20,86 +20,84 @@ import System.Console.Terminfo
20--
20--
21-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
21-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
22--
22--
23−-- Terminfo is incomplete. The vim source implies that terminfo is also
23+-- This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect.
24−-- incorrect. Vty assumes that the internal terminfo table added to the
24+-- Vty assumes that the an internal terminfo table added to the system provided terminfo table is
25−-- system-provided terminfo table is correct.
25+-- correct.
26--
26--
27−-- The procedure used here is:
27+-- 1. build terminfo table for all caps. Missing caps are not added.
28--
28--
29−-- 1. Build terminfo table for all caps. Missing caps are not added.
29+-- 2. add tables for visible chars, esc, del plus ctrl and meta.
30--
30--
31−-- 2. Add tables for visible chars, esc, del, ctrl, and meta.
31+-- 3. add internally defined table for given terminal type.
32--
32--
33−-- 3. Add internally-defined table for given terminal type.
33+-- The override is currently done in 'compile'. Which is a bit odd.
34--
34--
35−-- Precedence is currently implicit in the 'compile' algorithm.
35+-- \todo terminfo meta is not supported.
36−classifyMapForTerm :: String -> Terminal -> ClassifyMap
36+-- \todo no 8bit
37−classifyMapForTerm termName term =
37+classify_table_for_term :: String -> Terminal -> ClassifyTable
38− concat $ capsClassifyMap term keysFromCapsTable
38+classify_table_for_term term_name term =
39− : universalTable
39+ concat $ caps_classify_table term keys_from_caps_table
40− : termSpecificTables termName
40+ : universal_table
41+ : term_specific_tables term_name
41
42
42−-- | The key table applicable to all terminals.
43+-- | key table assumed to be applicable to all terminals.
43−--
44+universal_table :: ClassifyTable
44−-- Note that some of these entries are probably only applicable to
45+universal_table = concat [visible_chars, ctrl_chars, ctrl_meta_chars, special_support_keys]
45−-- ANSI/VT100 terminals.
46−universalTable :: ClassifyMap
47−universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
48
46
49−capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap
47+caps_classify_table :: Terminal -> [(String,Event)] -> ClassifyTable
50−capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]
48+caps_classify_table terminal table = [(x,y) | (Just x,y) <- map extract_cap table]
51− where extractCap = first (getCapability terminal . tiGetStr)
49+ where extract_cap = first (getCapability terminal . tiGetStr)
52
50
53−-- | Tables specific to a given terminal that are not derivable from
51+-- | tables specific to a given terminal that are not derivable from terminfo.
54−-- terminfo.
52+term_specific_tables :: String -> [ClassifyTable]
55−--
53+term_specific_tables term_name
56−-- Note that this adds the ANSI/VT100/VT50 tables regardless of term
54+ | ANSI.supports term_name = ANSI.tables
57−-- identifier.
55+ | XTerm7Bit.supports term_name = XTerm7Bit.tables
58−termSpecificTables :: String -> [ClassifyMap]
56+ | otherwise = []
59−termSpecificTables _termName = ANSIVT.classifyTable
60
57
61-- | Visible characters in the ISO-8859-1 and UTF-8 common set.
58-- | Visible characters in the ISO-8859-1 and UTF-8 common set.
62--
59--
63−-- We limit to < 0xC1. The UTF8 sequence detector will catch all values
60+-- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this
64−-- 0xC2 and above before this classify table is reached.
61+-- classify table is reached.
65−visibleChars :: ClassifyMap
62+--
63+-- TODO: resolve
64+-- 1. start at ' '. The earlier characters are all ctrl_char_keys
65+visible_chars :: ClassifyTable
66−visibleChars = [ ([x], EvKey (KChar x) [])
66+visible_chars = [ ([x], EvKey (KChar x) [])
67− | x <- [' ' .. toEnum 0xC1]
67+ | x <- [' ' .. toEnum 0xC1]
68− ]
68+ ]
69
69
70−-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set
70+-- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.
71−-- translated to ctrl + char.
72--
71--
73−-- This treats CTRL-i the same as tab.
72+-- \todo resolve CTRL-i is the same as tab
74−ctrlChars :: ClassifyMap
73+ctrl_chars :: ClassifyTable
75−ctrlChars =
74+ctrl_chars =
76 [ ([toEnum x],EvKey (KChar y) [MCtrl])
75 [ ([toEnum x],EvKey (KChar y) [MCtrl])
77− | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
76+ | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),
78− , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
77+ y /= 'i', -- Resolve issue #3 where CTRL-i hides TAB.
79− , y /= 'h' -- CTRL-h should not hide BS
78+ y /= 'h' -- CTRL-h should not hide BS
80 ]
79 ]
81
80
82-- | Ctrl+Meta+Char
81-- | Ctrl+Meta+Char
83−ctrlMetaChars :: ClassifyMap
82+ctrl_meta_chars :: ClassifyTable
84−ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
83+ctrl_meta_chars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrl_chars
85
84
86−-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
85+-- | esc, meta esc, delete, meta delete, enter, meta enter
87−specialSupportKeys :: ClassifyMap
86+special_support_keys :: ClassifyTable
88−specialSupportKeys =
87+special_support_keys =
89− [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90− , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
91− -- special support for ESC
88+ [ -- special support for ESC
92− , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
89+ ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
93 -- Special support for backspace
90 -- Special support for backspace
94− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
91+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
95 -- Special support for Enter
92 -- Special support for Enter
96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
93 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
97 -- explicit support for tab
94 -- explicit support for tab
98 , ("\t", EvKey (KChar '\t') [])
95 , ("\t", EvKey (KChar '\t') [])
99 ]
96 ]
100
97
101−-- | A classification table directly generated from terminfo cap
98+-- | classify table directly generated from terminfo cap strings
102−-- strings. These are:
99+--
100+-- these are:
103--
101--
104-- * ka1 - keypad up-left
102-- * ka1 - keypad up-left
105--
103--
@@ -114,7 +112,7 @@ specialSupportKeys =
114-- * kcbt - back tab
112-- * kcbt - back tab
115--
113--
116-- * kc1 - keypad left-down
114-- * kc1 - keypad left-down
117−--
115+--
118-- * kc3 - keypad right-down
116-- * kc3 - keypad right-down
119--
117--
120-- * kdch1 - delete
118-- * kdch1 - delete
@@ -122,7 +120,7 @@ specialSupportKeys =
122-- * kcud1 - down
120-- * kcud1 - down
123--
121--
124-- * kend - end
122-- * kend - end
125−--
123+--
126-- * kent - enter
124-- * kent - enter
127--
125--
128-- * kf0 - kf63 - function keys
126-- * kf0 - kf63 - function keys
@@ -152,8 +150,8 @@ specialSupportKeys =
152-- * kRIT - shift right
150-- * kRIT - shift right
153--
151--
154-- * kcuu1 - up
152-- * kcuu1 - up
155−keysFromCapsTable :: ClassifyMap
153+keys_from_caps_table :: ClassifyTable
156−keysFromCapsTable =
154+keys_from_caps_table =
157 [ ("ka1", EvKey KUpLeft [])
155 [ ("ka1", EvKey KUpLeft [])
158 , ("ka3", EvKey KUpRight [])
156 , ("ka3", EvKey KUpRight [])
159 , ("kb2", EvKey KCenter [])
157 , ("kb2", EvKey KCenter [])
@@ -179,8 +177,8 @@ keysFromCapsTable =
179 , ("kLFT", EvKey KLeft [MShift])
177 , ("kLFT", EvKey KLeft [MShift])
180 , ("kRIT", EvKey KRight [MShift])
178 , ("kRIT", EvKey KRight [MShift])
181 , ("kcuu1", EvKey KUp [])
179 , ("kcuu1", EvKey KUp [])
182− ] ++ functionKeyCapsTable
180+ ] ++ function_key_caps_table
183
181
184−-- | Cap names for function keys.
182+-- | cap names for function keys
185−functionKeyCapsTable :: ClassifyMap
183+function_key_caps_table :: ClassifyTable
186−functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
184+function_key_caps_table = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
src/Graphics/Vty/Input/Terminfo/ANSI.hsnew file+88
@@ -0,0 +1,88 @@
1+module Graphics.Vty.Input.Terminfo.ANSI where
2+
3+import Graphics.Vty.Input.Events
4+
5+-- | Terminals augmented by the built in ANSI input mapping.
6+supports :: String -> Bool
7+supports "ansi" = True
8+supports _ = False
9+
10+-- | Encoding for navigation keys.
11+nav_keys_0 :: ClassifyTable
12+nav_keys_0 =
13+ [ k "G" KCenter
14+ , k "P" KPause
15+ , k "A" KUp
16+ , k "B" KDown
17+ , k "C" KRight
18+ , k "D" KLeft
19+ , k "H" KHome
20+ , k "F" KEnd
21+ , k "E" KBegin
22+ ]
23+ where k c s = ("\ESC["++c, EvKey s [])
24+
25+-- | VT 100 (?) encoding for shift, meta and ctrl plus arrows/home/end
26+nav_keys_1 :: ClassifyTable
27+nav_keys_1 =
28+ [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
29+ | charCnt <- ["1;", ""], -- we can have a count or not
30+ (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
31+ ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
32+ -- directions and their codes
33+ (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)]
34+ ]
35+
36+-- | VT 100 (?) encoding for ins, del, pageup, pagedown, home, end
37+nav_keys_2 :: ClassifyTable
38+nav_keys_2 =
39+ let k n s = ("\ESC["++show n++"~",EvKey s [])
40+ in zipWith k [2::Int,3,5,6,1,4]
41+ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
42+
43+-- | VT 100 (?) encoding for ctrl + ins, del, pageup, pagedown, home, end
44+nav_keys_3 :: ClassifyTable
45+nav_keys_3 =
46+ let k n s = ("\ESC["++show n++";5~", EvKey s [MCtrl])
47+ in zipWith k [2::Int,3,5,6,1,4]
48+ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
49+
50+-- | VT 100 (?) encoding for shift plus function keys
51+--
52+-- TODO: I suspect this should be generated by interpretting the terminals use of meta mode:
53+-- "If the terminal has a ``meta key'' which acts as a shift key, setting the 8th bit of any
54+-- character transmitted, this fact can be indicated with km. Other- wise, software will
55+-- assume that the 8th bit is parity and it will usually be cleared. If strings exist to turn this
56+-- ``meta mode'' on and off, they can be given as smm and rmm."
57+--
58+-- That is more complex than below. I cannot fault the original author for just hard coding a table.
59+function_keys_1 :: ClassifyTable
60+function_keys_1 =
61+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
62+ concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
63+
64+-- | VT 100 (?) encoding for meta plus char
65+--
66+-- TODO: resolve -
67+--
68+-- 1. removed 'ESC' from second list due to duplication with "special_support_keys".
69+-- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is
70+-- the same as ESC should examine km and current encoding.
71+-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by
72+-- special_support_keys.
73+function_keys_2 :: ClassifyTable
74+function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
75+ | x <- '\t':[' ' .. '~']
76+ , x /= '['
77+ ]
78+
79+tables :: [ClassifyTable]
80+tables =
81+ [ nav_keys_0
82+ , nav_keys_1
83+ , nav_keys_2
84+ , nav_keys_3
85+ , function_keys_1
86+ , function_keys_2
87+ ]
88+
src/Graphics/Vty/Input/Terminfo/ANSIVT.hsdeleted−88
@@ -1,88 +0,0 @@
1−-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from
2−-- terminfo.
3−--
4−-- Or that are sent regardless of terminfo by terminal emulators. EG:
5−-- Terminal emulators will often use VT50 input bytes regardless of
6−-- declared terminal type. This provides compatibility with programs
7−-- that don't follow terminfo.
8−module Graphics.Vty.Input.Terminfo.ANSIVT where
9−
10−import Graphics.Vty.Input.Events
11−
12−-- | Encoding for navigation keys.
13−navKeys0 :: ClassifyMap
14−navKeys0 =
15− [ k "G" KCenter
16− , k "P" KPause
17− , k "A" KUp
18− , k "B" KDown
19− , k "C" KRight
20− , k "D" KLeft
21− , k "H" KHome
22− , k "F" KEnd
23− , k "E" KBegin
24− ]
25− where k c s = ("\ESC["++c,EvKey s [])
26−
27−-- | encoding for shift, meta and ctrl plus arrows/home/end
28−navKeys1 :: ClassifyMap
29−navKeys1 =
30− [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
31− | charCnt <- ["1;", ""], -- we can have a count or not
32− (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
33− -- modifiers and their codes
34− ([MShift, MCtrl],6), ([MShift, MMeta],4)],
35− -- directions and their codes
36− (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)]
37− ]
38−
39−-- | encoding for ins, del, pageup, pagedown, home, end
40−navKeys2 :: ClassifyMap
41−navKeys2 =
42− let k n s = ("\ESC["++show n++"~",EvKey s [])
43− in zipWith k [2::Int,3,5,6,1,4]
44− [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
45−
46−-- | encoding for ctrl + ins, del, pageup, pagedown, home, end
47−navKeys3 :: ClassifyMap
48−navKeys3 =
49− let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])
50− in zipWith k [2::Int,3,5,6,1,4]
51− [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
52−
53−-- | encoding for shift plus function keys
54−--
55−-- According to
56−--
57−-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
58−--
59−-- This encoding depends on the terminal.
60−functionKeys1 :: ClassifyMap
61−functionKeys1 =
62− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in
63− concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
64−
65−-- | encoding for meta plus char
66−--
67−-- 1. removed 'ESC' from second list due to duplication with
68−-- "special_support_keys".
69−-- 2. removed '[' from second list due to conflict with 7-bit encoding
70−-- for ESC. Whether meta+[ is the same as ESC should examine km and
71−-- current encoding.
72−-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped
73−-- to KBS by special_support_keys.
74−functionKeys2 :: ClassifyMap
75−functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
76− | x <- '\t':[' ' .. '~']
77− , x /= '['
78− ]
79−
80−classifyTable :: [ClassifyMap]
81−classifyTable =
82− [ navKeys0
83− , navKeys1
84− , navKeys2
85− , navKeys3
86− , functionKeys1
87− , functionKeys2
88− ]
src/Graphics/Vty/Input/Terminfo/XTerm7Bit.hsnew file+92
@@ -0,0 +1,92 @@
1+module Graphics.Vty.Input.Terminfo.XTerm7Bit where
2+
3+import Graphics.Vty.Input.Events
4+
5+import Data.List (isInfixOf, isPrefixOf)
6+
7+-- | The built in input augmentation for XTerm supports any TERM starting with xterm except those
8+-- containing 8bit.
9+supports :: String -> Bool
10+supports term_name = "xterm" `isPrefixOf` term_name && not ("8bit" `isInfixOf` term_name)
11+
12+-- | Encoding for navigation keys.
13+--
14+-- TODO: This is not the same as the input bytes pulled from teh caps table.
15+nav_keys_0 :: ClassifyTable
16+nav_keys_0 =
17+ [ k "G" KCenter
18+ , k "P" KPause
19+ , k "A" KUp
20+ , k "B" KDown
21+ , k "C" KRight
22+ , k "D" KLeft
23+ , k "H" KHome
24+ , k "F" KEnd
25+ , k "E" KBegin
26+ ]
27+ where k c s = ("\ESC["++c,EvKey s [])
28+
29+-- | VT 100 (?) encoding for shift, meta and ctrl plus arrows/home/end
30+nav_keys_1 :: ClassifyTable
31+nav_keys_1 =
32+ [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
33+ | charCnt <- ["1;", ""], -- we can have a count or not
34+ (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
35+ ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
36+ (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes
37+ ]
38+
39+-- | VT 100 (?) encoding for ins, del, pageup, pagedown, home, end
40+nav_keys_2 :: ClassifyTable
41+nav_keys_2 =
42+ let k n s = ("\ESC["++show n++"~",EvKey s [])
43+ in zipWith k [2::Int,3,5,6,1,4]
44+ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
45+
46+-- | VT 100 (?) encoding for ctrl + ins, del, pageup, pagedown, home, end
47+nav_keys_3 :: ClassifyTable
48+nav_keys_3 =
49+ let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])
50+ in zipWith k [2::Int,3,5,6,1,4]
51+ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
52+
53+-- | VT 100 (?) encoding for shift plus function keys
54+--
55+-- TODO: I suspect this should be generated by interpretting the terminals use of meta mode:
56+-- "If the terminal has a ``meta key'' which acts as a shift key, setting the 8th bit of any
57+-- character transmitted, this fact can be indicated with km. Other- wise, software will
58+-- assume that the 8th bit is parity and it will usually be cleared. If strings exist to turn this
59+-- ``meta mode'' on and off, they can be given as smm and rmm."
60+--
61+-- That is more complex than below. I cannot fault the original author for just hard coding a table.
62+function_keys_1 :: ClassifyTable
63+function_keys_1 =
64+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
65+ concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
66+
67+-- | VT 100 (?) encoding for meta plus char
68+--
69+-- TODO: resolve -
70+--
71+-- 1. removed 'ESC' from second list due to duplication with "special_support_keys".
72+-- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is
73+-- the same as ESC should examine km and current encoding.
74+-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by
75+-- special_support_keys.
76+function_keys_2 :: ClassifyTable
77+function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
78+ | x <- '\t':[' ' .. '~']
79+ , x /= '['
80+ ]
81+
82+-- | classify table for ANSI terminals
83+tables :: [ClassifyTable]
84+tables =
85+ [ nav_keys_0
86+ , nav_keys_1
87+ , nav_keys_2
88+ , nav_keys_3
89+ , function_keys_1
90+ , function_keys_2
91+ ]
92+
src/Graphics/Vty/Output.hs+112−81
@@ -1,107 +1,138 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
1+-- | Output interface.
2−-- | This module provides functions for accessing the current terminal
3−-- or a specific terminal device.
4--
2--
5−-- See also:
3+-- Access to the current terminal or a specific terminal device.
6--
4--
7−-- 1. "Graphics.Vty.Output": This instantiates an abtract interface
5+-- See also:
8−-- to the terminal based on the @TERM@ and @COLORTERM@ environment
9−-- variables.
10--
6--
7+-- 1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based
8+-- on the TERM and COLORTERM environment variables.
9+--
11−-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
10+-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement.
12−-- terminal modules need to implement.
13--
11--
14−-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
12+-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance that uses terminfo for all
15−-- that uses terminfo for all control strings. No attempt is made to
16−-- change the character set to UTF-8 for these terminals.
13+-- control strings. No attempt is made to change the character set to UTF-8 for these terminals.
14+-- I don't know a way to reliably determine if that is required or how to do so.
17--
15--
18−-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
16+-- 4. "Graphics.Vty.Output.XTermColor": This module contains an interface suitable for xterm-like
19−-- interface suitable for xterm-like terminals. These are the terminals
20−-- where @TERM@ begins with @xterm@. This does use terminfo for as many
17+-- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many
21−-- control codes as possible.
18+-- control codes as possible.
22−module Graphics.Vty.Output
19+module Graphics.Vty.Output ( module Graphics.Vty.Output
23− ( outputForConfig
20+ , Output(..) -- \todo hide constructors
24− , setCursorPos
21+ , AssumedState(..)
25− , hideCursor
22+ , DisplayContext(..) -- \todo hide constructors
26− , showCursor
23+ , output_picture
24+ , display_context
27− )
25+ )
28−where
26+ where
29
27
30−import Control.Monad (when)
31
28
32−import Graphics.Vty.Config
29+import Graphics.Vty.Prelude
33−import Graphics.Vty.Image (regionWidth, regionHeight)
30+
34import Graphics.Vty.Output.Interface
31import Graphics.Vty.Output.Interface
32+import Graphics.Vty.Output.MacOSX as MacOSX
35import Graphics.Vty.Output.XTermColor as XTermColor
33import Graphics.Vty.Output.XTermColor as XTermColor
36import Graphics.Vty.Output.TerminfoBased as TerminfoBased
34import Graphics.Vty.Output.TerminfoBased as TerminfoBased
37
35
38import Blaze.ByteString.Builder (writeToByteString)
36import Blaze.ByteString.Builder (writeToByteString)
39
37
40−import Data.List (isPrefixOf)
38+import Control.Exception ( SomeException, try )
39+import Control.Monad.Trans
41
40
42−#if !MIN_VERSION_base(4,11,0)
43−import Data.Monoid ((<>))
41+import Data.List ( isPrefixOf )
44−#endif
45
42
46−-- | Returns an `Output` for the terminal specified in `Config`.
43+import GHC.IO.Handle
47−--
44+
48−-- The specific Output implementation used is hidden from the API user.
45+import System.Environment
49−-- All terminal implementations are assumed to perform more, or less,
46+import System.IO
50−-- the same. Currently, all implementations use terminfo for at least
47+
51−-- some terminal specific information.
48+-- | Returns a `Output` for the current terminal as determined by TERM.
52--
49--
50+-- The specific Output implementation used is hidden from the API user. All terminal implementations
51+-- are assumed to perform more, or less, the same. Currently all implementations use terminfo for at
52+-- least some terminal specific information. This is why platforms without terminfo are not
53+-- supported. However, as mentioned before, any specifics about it being based on terminfo are
53−-- If a terminal implementation is developed for a terminal without
54+-- hidden from the API user. If a terminal implementation is developed for a terminal for a
54−-- terminfo support then Vty should work as expected on that terminal.
55+-- platform without terminfo support then Vty should work as expected on that terminal.
55--
56--
56-- Selection of a terminal is done as follows:
57-- Selection of a terminal is done as follows:
57--
58--
58−-- * If TERM contains "xterm" or "screen", use XTermColor.
59+-- * If TERM == xterm
60+-- then the terminal might be one of the Mac OS X .app terminals. Check if that might be
61+-- the case and use MacOSX if so.
59−-- * otherwise use the TerminfoBased driver.
62+-- otherwise use XTermColor.
60−outputForConfig :: Config -> IO Output
63+--
61−outputForConfig Config{ outputFd = Just fd, termName = Just termName
64+-- * for any other TERM value TerminfoBased is used.
62− , colorMode = Just colorMode, .. } = do
65+--
63− t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
66+-- To differentiate between Mac OS X terminals this uses the TERM_PROGRAM environment variable.
64− then XTermColor.reserveTerminal termName fd colorMode
67+-- However, an xterm started by Terminal or iTerm *also* has TERM_PROGRAM defined since the
65− -- Not an xterm-like terminal. try for generic terminfo.
68+-- environment variable is not reset/cleared by xterm. However a Terminal.app or iTerm.app started
66− else TerminfoBased.reserveTerminal termName fd colorMode
69+-- from an xterm under X11 on mac os x will likely be done via open. Since this does not propogate
67−
70+-- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true
68− case mouseMode of
71+-- Terminal.app or iTerm.app session.
69− Just s -> setMode t Mouse s
72+--
70− Nothing -> return ()
73+-- The file descriptor used for output will a be a duplicate of the current stdout file descriptor.
71−
74+--
72− case bracketedPasteMode of
75+-- \todo add an implementation for windows that does not depend on terminfo. Should be installable
73− Just s -> setMode t BracketedPaste s
76+-- with only what is provided in the haskell platform. Use ansi-terminal
74− Nothing -> return ()
77+output_for_current_terminal :: ( Applicative m, MonadIO m ) => m Output
78+output_for_current_terminal = do
79+ term_type <- liftIO $ getEnv "TERM"
80+ out_handle <- liftIO $ hDuplicate stdout
81+ output_for_name_and_io term_type out_handle
75
82
83+-- | gives an output method structure for a terminal with the given name and the given 'Handle'.
84+output_for_name_and_io :: (Applicative m, MonadIO m) => String -> Handle -> m Output
85+output_for_name_and_io term_type out_handle = do
86+ t <- if "xterm" `isPrefixOf` term_type
87+ then do
88+ maybe_terminal_app <- get_env "TERM_PROGRAM"
89+ case maybe_terminal_app of
90+ Nothing
91+ -> XTermColor.reserve_terminal term_type out_handle
92+ Just v | v == "Apple_Terminal" || v == "iTerm.app"
93+ -> do
94+ maybe_xterm <- get_env "XTERM_VERSION"
95+ case maybe_xterm of
96+ Nothing -> MacOSX.reserve_terminal v out_handle
97+ Just _ -> XTermColor.reserve_terminal term_type out_handle
98+ -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app
99+ -- like terminal?
100+ _ -> XTermColor.reserve_terminal term_type out_handle
101+ -- Not an xterm-like terminal. try for generic terminfo.
102+ else TerminfoBased.reserve_terminal term_type out_handle
76 return t
103 return t
77−outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
104+ where
105+ get_env var = do
106+ mv <- liftIO $ try $ getEnv var
107+ case mv of
108+ Left (_e :: SomeException) -> return $ Nothing
109+ Right v -> return $ Just v
78
110
79−-- | Sets the cursor position to the given output column and row.
111+-- | Sets the cursor position to the given output column and row.
80--
112--
81−-- This is not necessarily the same as the character position with the
113+-- This is not necessarially the same as the character position with the same coordinates.
82−-- same coordinates. Characters can be a variable number of columns in
114+-- Characters can be a variable number of columns in width.
83−-- width.
84--
115--
85−-- Currently, the only way to set the cursor position to a given
116+-- Currently, the only way to set the cursor position to a given character coordinate is to specify
86−-- character coordinate is to specify the coordinate in the Picture
87−-- instance provided to 'outputPicture' or 'refresh'.
117+-- the coordinate in the Picture instance provided to output_picture or refresh.
88−setCursorPos :: Output -> Int -> Int -> IO ()
118+set_cursor_pos :: MonadIO m => Output -> Int -> Int -> m ()
89−setCursorPos t x y = do
119+set_cursor_pos t x y = do
90− bounds <- displayBounds t
120+ bounds <- display_bounds t
91− when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
121+ when (x >= 0 && x < region_width bounds && y >= 0 && y < region_height bounds) $ do
92− dc <- displayContext t bounds
122+ dc <- display_context t bounds
93− outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
123+ liftIO $ output_byte_buffer t $ writeToByteString $ write_move_cursor dc x y
94
124
95−-- | Hides the cursor.
125+-- | Hides the cursor
96−hideCursor :: Output -> IO ()
126+hide_cursor :: MonadIO m => Output -> m ()
97−hideCursor t = do
127+hide_cursor t = do
98− bounds <- displayBounds t
128+ bounds <- display_bounds t
99− dc <- displayContext t bounds
129+ dc <- display_context t bounds
100− outputByteBuffer t $ writeToByteString $ writeHideCursor dc
130+ liftIO $ output_byte_buffer t $ writeToByteString $ write_hide_cursor dc
131+
132+-- | Shows the cursor
133+show_cursor :: MonadIO m => Output -> m ()
134+show_cursor t = do
135+ bounds <- display_bounds t
136+ dc <- display_context t bounds
137+ liftIO $ output_byte_buffer t $ writeToByteString $ write_show_cursor dc
101
138
102−-- | Shows the cursor.
103−showCursor :: Output -> IO ()
104−showCursor t = do
105− bounds <- displayBounds t
106− dc <- displayContext t bounds
107− outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+185−260
@@ -1,25 +1,15 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2+-- General philosophy is: MonadIO is for equations exposed to clients.
3+{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
5{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−-- | This module provides an abstract interface for performing terminal
8−-- output. The only user-facing part of this API is 'Output'.
9module Graphics.Vty.Output.Interface
8module Graphics.Vty.Output.Interface
10− ( Output(..)
11− , AssumedState(..)
12− , DisplayContext(..)
13− , Mode(..)
14− , displayContext
15− , outputPicture
16− , initialAssumedState
17− , limitAttrForDisplay
18− )
19where
9where
20
10
21−import Graphics.Vty.Attributes
11+import Graphics.Vty.Prelude
22−import Graphics.Vty.Image (DisplayRegion, regionHeight)
12+
23import Graphics.Vty.Picture
13import Graphics.Vty.Picture
24import Graphics.Vty.PictureToSpans
14import Graphics.Vty.PictureToSpans
25import Graphics.Vty.Span
15import Graphics.Vty.Span
@@ -29,303 +19,238 @@ import Graphics.Vty.DisplayAttributes
29import Blaze.ByteString.Builder (Write, writeToByteString)
19import Blaze.ByteString.Builder (Write, writeToByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
20import Blaze.ByteString.Builder.ByteString (writeByteString)
31
21
22+import Control.Monad.Trans
23+
32import qualified Data.ByteString as BS
24import qualified Data.ByteString as BS
33import Data.IORef
25import Data.IORef
26+import Data.Monoid (mempty, mappend)
34import qualified Data.Text.Encoding as T
27import qualified Data.Text.Encoding as T
35import qualified Data.Text.Lazy as TL
28import qualified Data.Text.Lazy as TL
36import qualified Data.Vector as Vector
29import qualified Data.Vector as Vector
37
30
38−-- | Modal terminal features that can be enabled and disabled.
39−data Mode = Mouse
40− -- ^ Mouse mode (whether the terminal is configured to provide
41− -- mouse input events)
42− | BracketedPaste
43− -- ^ Paste mode (whether the terminal is configured to provide
44− -- events on OS pastes)
45− | Focus
46− -- ^ Focus-in/focus-out events (whether the terminal is
47− -- configured to provide events on focus change)
48− | Hyperlink
49− -- ^ Hyperlink mode via the 'withURL' attribute modifier (see
50− -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
51− -- Note that this may not work gracefully in all terminal
52− -- emulators so be sure to test this mode with the terminals
53− -- you intend to support. It is off by default.
54− deriving (Eq, Read, Show)
55−
56−-- | The Vty terminal output interface.
57data Output = Output
31data Output = Output
58− { -- | Text identifier for the output device. Used for debugging.
32+ { -- | Text identifier for the output device. Used for debugging.
59− terminalID :: String
33+ terminal_ID :: String
60− -- | Release the terminal just prior to application exit and reset
34+ , release_terminal :: MonadIO m => m ()
61− -- it to its state prior to application startup.
62− , releaseTerminal :: IO ()
63− -- | Clear the display and initialize the terminal to some initial
35+ -- | Clear the display and initialize the terminal to some initial display state.
64− -- display state.
65− --
36+ --
66− -- The expectation of a program is that the display starts in some
37+ -- The expectation of a program is that the display starts in some initial state.
67− -- The initial state. initial state would consist of fixed values:
38+ -- The initial state would consist of fixed values:
68− --
39+ --
69− -- - cursor at top left
40+ -- - cursor at top left
70− -- - UTF-8 character encoding
41+ -- - UTF-8 character encoding
71− -- - drawing characteristics are the default
42+ -- - drawing characteristics are the default
72− , reserveDisplay :: IO ()
43+ --
44+ -- The abstract operation I think all these behaviors are instances of is reserving exclusive
45+ -- access to a display such that:
46+ --
47+ -- - The previous state cannot be determined
48+ -- - When exclusive access to a display is released the display returns to the previous state.
49+ , reserve_display :: MonadIO m => m ()
73− -- | Return the display to the state before `reserveDisplay` If no
50+ -- | Return the display to the state before reserve_display
74− -- previous state then set the display state to the initial state.
51+ -- If no previous state then set the display state to the initial state.
75− , releaseDisplay :: IO ()
52+ , release_display :: MonadIO m => m ()
76− -- | Sets the current display bounds (width, height).
77− , setDisplayBounds :: (Int, Int) -> IO ()
78− -- | Returns the current display bounds.
53+ -- | Returns the current display bounds.
79− , displayBounds :: IO DisplayRegion
54+ , display_bounds :: MonadIO m => m DisplayRegion
80− -- | Output the bytestring to the terminal device.
55+ -- | Output the byte string to the terminal device.
81− , outputByteBuffer :: BS.ByteString -> IO ()
56+ , output_byte_buffer :: BS.ByteString -> IO ()
57+ -- | Maximum number of colors supported by the context.
58+ , context_color_count :: Int
82− -- | Specifies whether the cursor can be shown / hidden.
59+ -- | if the cursor can be shown / hidden
83− , supportsCursorVisibility :: Bool
60+ , supports_cursor_visibility :: Bool
84− -- | Indicates support for terminal modes for this output device.
85− , supportsMode :: Mode -> Bool
86− -- | Enables or disables a mode (does nothing if the mode is
87− -- unsupported).
88− , setMode :: Mode -> Bool -> IO ()
89− -- | Returns whether a mode is enabled.
90− , getModeStatus :: Mode -> IO Bool
91− , assumedStateRef :: IORef AssumedState
61+ , assumed_state_ref :: IORef AssumedState
92− -- | Acquire display access to the given region of the display.
62+ -- | Acquire display access to the given region of the display.
93− -- Currently all regions have the upper left corner of (0,0) and
63+ -- Currently all regions have the upper left corner of (0,0) and the lower right corner at
94− -- the lower right corner at (max displayWidth providedWidth, max
64+ -- (max display_width provided_width, max display_height provided_height)
95− -- displayHeight providedHeight)
96− , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
65+ , mk_display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
97− -- | Ring the terminal bell if supported.
98− , ringTerminalBell :: IO ()
99− -- | Returns whether the terminal has an audio bell feature.
100− , supportsBell :: IO Bool
101− -- | Returns whether the terminal supports italicized text.
102− --
103− -- This is terminal-dependent and should make a best effort to
104− -- determine whether this feature is supported, but even if the
105− -- terminal advertises support (e.g. via terminfo) that might not
106− -- be a reliable indicator of whether the feature will work as
107− -- desired.
108− , supportsItalics :: IO Bool
109− -- | Returns whether the terminal supports strikethrough text.
110− --
111− -- This is terminal-dependent and should make a best effort to
112− -- determine whether this feature is supported, but even if the
113− -- terminal advertises support (e.g. via terminfo) that might not
114− -- be a reliable indicator of whether the feature will work as
115− -- desired.
116− , supportsStrikethrough :: IO Bool
117− -- | Returns how many colors the terminal supports.
118− , outputColorMode :: ColorMode
119 }
66 }
120
67
121−displayContext :: Output -> DisplayRegion -> IO DisplayContext
68+display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
122−displayContext t = mkDisplayContext t t
69+display_context t = liftIO . mk_display_context t t
123
70
124data AssumedState = AssumedState
71data AssumedState = AssumedState
125− { prevFattr :: Maybe FixedAttr
72+ { prev_fattr :: Maybe FixedAttr
126− , prevOutputOps :: Maybe DisplayOps
73+ , prev_output_ops :: Maybe DisplayOps
127 }
74 }
128
75
129−initialAssumedState :: AssumedState
76+initial_assumed_state :: AssumedState
130−initialAssumedState = AssumedState Nothing Nothing
77+initial_assumed_state = AssumedState Nothing Nothing
131
78
132data DisplayContext = DisplayContext
79data DisplayContext = DisplayContext
133− { contextDevice :: Output
80+ { context_device :: Output
134− -- | Provide the bounds of the display context.
81+ -- | Provide the bounds of the display context.
135− , contextRegion :: DisplayRegion
82+ , context_region :: DisplayRegion
136− -- | Sets the output position to the specified row and column
83+ -- | sets the output position to the specified row and column. Where the number of bytes
137− -- where the number of bytes required for the control codes can be
138− -- specified seperate from the actual byte sequence.
84+ -- required for the control codes can be specified seperate from the actual byte sequence.
139− , writeMoveCursor :: Int -> Int -> Write
85+ , write_move_cursor :: Int -> Int -> Write
140− , writeShowCursor :: Write
86+ , write_show_cursor :: Write
141− , writeHideCursor :: Write
87+ , write_hide_cursor :: Write
142− -- Ensure that the specified output attributes will be applied to
88+ -- | Assure the specified output attributes will be applied to all the following text until the
143− -- all the following text until the next output attribute change
144− -- where the number of bytes required for the control codes can be
89+ -- next output attribute change. Where the number of bytes required for the control codes can
145− -- specified seperately from the actual byte sequence. The required
90+ -- be specified seperate from the actual byte sequence. The required number of bytes must be
146− -- number of bytes must be at least the maximum number of bytes
147− -- required by any attribute changes. The serialization equations
91+ -- at least the maximum number of bytes required by any attribute changes. The serialization
148− -- must provide the ptr to the next byte to be specified in the
92+ -- equations must provide the ptr to the next byte to be specified in the output buffer.
149− -- output buffer.
150 --
93 --
151− -- The currently applied display attributes are provided as well.
94+ -- The currently applied display attributes are provided as well. The Attr data type can
152− -- The Attr data type can specify the style or color should not be
153− -- changed from the currently applied display attributes. In order
95+ -- specify the style or color should not be changed from the currently applied display
154− -- to support this the currently applied display attributes are
96+ -- attributes. In order to support this the currently applied display attributes are required.
155− -- required. In addition it may be possible to optimize the state
97+ -- In addition it may be possible to optimize the state changes based off the currently applied
156− -- changes based off the currently applied display attributes.
98+ -- display attributes.
157− , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
99+ , write_set_attr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
158− -- | Reset the display attributes to the default display attributes.
100+ -- | Reset the display attributes to the default display attributes
159− , writeDefaultAttr :: Bool -> Write
101+ , write_default_attr :: Write
160− , writeRowEnd :: Write
102+ , write_row_end :: Write
161− -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
103+ -- | See Graphics.Vty.Output.XTermColor.inline_hack
162− , inlineHack :: IO ()
104+ , inline_hack :: IO ()
163 }
105 }
164
106
165−-- | All terminals serialize UTF8 text to the terminal device exactly as
107+-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
166−-- serialized in memory.
167−writeUtf8Text :: BS.ByteString -> Write
108+write_utf8_text :: BS.ByteString -> Write
168−writeUtf8Text = writeByteString
109+write_utf8_text = writeByteString
169
110
170-- | Displays the given `Picture`.
111-- | Displays the given `Picture`.
171--
112--
172−-- 1. The image is cropped to the display size.
113+-- 0. The image is cropped to the display size.
173−--
174−-- 2. Converted into a sequence of attribute changes and text spans.
175--
114--
115+-- 1. Converted into a sequence of attribute changes and text spans.
116+--
176−-- 3. The cursor is hidden.
117+-- 2. The cursor is hidden.
177--
118--
178−-- 4. Serialized to the display.
119+-- 3. Serialized to the display.
179--
120--
180−-- 5. The cursor is then shown and positioned or kept hidden.
121+-- 4. The cursor is then shown and positioned or kept hidden.
122+--
123+-- todo: specify possible IO exceptions.
124+-- abstract from IO monad to a MonadIO instance.
181−outputPicture :: DisplayContext -> Picture -> IO ()
125+output_picture :: MonadIO m => DisplayContext -> Picture -> m ()
182−outputPicture dc pic = do
126+output_picture dc pic = liftIO $ do
183− urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
127+ as <- readIORef (assumed_state_ref $ context_device dc)
184− as <- readIORef (assumedStateRef $ contextDevice dc)
128+ let manip_cursor = supports_cursor_visibility (context_device dc)
185− let manipCursor = supportsCursorVisibility (contextDevice dc)
129+ r = context_region dc
186− r = contextRegion dc
130+ ops = display_ops_for_pic pic r
187− ops = displayOpsForPic pic r
188− initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
131+ initial_attr = FixedAttr default_style_mask Nothing Nothing
189− -- Diff the previous output against the requested output.
132+ -- Diff the previous output against the requested output. Differences are currently on a per-row
190− -- Differences are currently on a per-row basis.
133+ -- basis.
134+ -- \todo handle resizes that crop the dominate directions better.
191− diffs :: [Bool] = case prevOutputOps as of
135+ diffs :: [Bool] = case prev_output_ops as of
192− Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
136+ Nothing -> replicate (fromEnum $ region_height $ effected_region ops) True
193− Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
137+ Just previous_ops -> if effected_region previous_ops /= effected_region ops
194− then replicate (displayOpsRows ops) True
138+ then replicate (display_ops_rows ops) True
195− else Vector.toList $ Vector.zipWith (/=) previousOps ops
139+ else zipWith (/=) (Vector.toList previous_ops)
140+ (Vector.toList ops)
196 -- build the Write corresponding to the output image
141 -- build the Write corresponding to the output image
197− out = (if manipCursor then writeHideCursor dc else mempty)
142+ out = (if manip_cursor then write_hide_cursor dc else mempty)
198− `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
143+ `mappend` write_default_attr dc
144+ `mappend` write_output_ops dc initial_attr diffs ops
199 `mappend`
145 `mappend`
200− (let (w,h) = contextRegion dc
201− clampX = max 0 . min (w-1)
202− clampY = max 0 . min (h-1) in
203− case picCursor pic of
146+ (case pic_cursor pic of
204− _ | not manipCursor -> mempty
147+ _ | not manip_cursor -> mempty
205− NoCursor -> mempty
148+ NoCursor -> mempty
206− AbsoluteCursor x y ->
207− writeShowCursor dc `mappend`
208− writeMoveCursor dc (clampX x) (clampY y)
209− PositionOnly isAbs x y ->
210− if isAbs
211− then writeMoveCursor dc (clampX x) (clampY y)
212− else let (ox, oy) = charToOutputPos m (clampX x, clampY y)
213− m = cursorOutputMap ops $ picCursor pic
214− in writeMoveCursor dc (clampX ox) (clampY oy)
215 Cursor x y ->
149 Cursor x y ->
216− let m = cursorOutputMap ops $ picCursor pic
150+ let m = cursor_output_map ops $ pic_cursor pic
217− (ox, oy) = charToOutputPos m (clampX x, clampY y)
151+ (ox, oy) = char_to_output_pos m (x,y)
218− in writeShowCursor dc `mappend`
152+ in write_show_cursor dc `mappend` write_move_cursor dc ox oy
219− writeMoveCursor dc (clampX ox) (clampY oy)
220 )
153 )
221 -- ... then serialize
154 -- ... then serialize
222− outputByteBuffer (contextDevice dc) (writeToByteString out)
155+ output_byte_buffer (context_device dc) (writeToByteString out)
223 -- Cache the output spans.
156 -- Cache the output spans.
224− let as' = as { prevOutputOps = Just ops }
157+ let as' = as { prev_output_ops = Just ops }
225− writeIORef (assumedStateRef $ contextDevice dc) as'
158+ writeIORef (assumed_state_ref $ context_device dc) as'
226
159
227−writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
160+write_output_ops :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
228−writeOutputOps urlsEnabled dc initialAttr diffs ops =
161+write_output_ops dc in_fattr diffs ops =
229− let (_, out, _) = Vector.foldl' writeOutputOps'
162+ let (_, out, _, _) = Vector.foldl' write_output_ops'
230− (0, mempty, diffs)
163+ (0, mempty, in_fattr, diffs)
231− ops
164+ ops
232 in out
165 in out
233− where
166+ where
234− writeOutputOps' (y, out, True : diffs') spanOps
167+ write_output_ops' (y, out, fattr, True : diffs') span_ops
235− = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
168+ = let (span_out, fattr') = write_span_ops dc y fattr span_ops
236− out' = out `mappend` spanOut
237− in (y+1, out', diffs')
169+ in (y+1, out `mappend` span_out, fattr', diffs')
238− writeOutputOps' (y, out, False : diffs') _spanOps
170+ write_output_ops' (y, out, fattr, False : diffs') _span_ops
239− = (y + 1, out, diffs')
171+ = (y + 1, out, fattr, diffs')
240− writeOutputOps' (_y, _out, []) _spanOps
172+ write_output_ops' (_y, _out, _fattr, []) _span_ops
241 = error "vty - output spans without a corresponding diff."
173 = error "vty - output spans without a corresponding diff."
242
174
243−writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
175+write_span_ops :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)
244−writeSpanOps urlsEnabled dc y initialAttr spanOps =
176+write_span_ops dc y in_fattr span_ops =
245 -- The first operation is to set the cursor to the start of the row
177 -- 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
178+ let start = write_move_cursor dc 0 y
247 -- then the span ops are serialized in the order specified
179 -- 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
180+ in Vector.foldl' (\(out, fattr) op -> case write_span_op dc op fattr of
249− (opOut, fattr') -> (out `mappend` opOut, fattr')
181+ (op_out, fattr') -> (out `mappend` op_out, fattr')
250− )
182+ )
251− (start, initialAttr)
183+ (start, in_fattr)
252− spanOps
184+ span_ops
253
185
254−writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
186+write_span_op :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
255−writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
187+write_span_op dc (TextSpan attr _ _ str) fattr =
256− let attr' = limitAttrForDisplay (contextDevice dc) attr
188+ let attr' = limit_attr_for_display (context_device dc) attr
257− fattr' = fixDisplayAttr fattr attr'
189+ fattr' = fix_display_attr fattr attr'
258− diffs = displayAttrDiffs fattr fattr'
190+ diffs = display_attr_diffs fattr fattr'
259− out = writeSetAttr dc urlsEnabled fattr attr' diffs
191+ out = write_set_attr dc fattr attr' diffs
260− `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
192+ `mappend` write_utf8_text (T.encodeUtf8 $ TL.toStrict str)
261 in (out, fattr')
193 in (out, fattr')
262−writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
194+write_span_op _dc (Skip _) _fattr = error "serialize_span_op for Skip"
263−writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
195+write_span_op dc (RowEnd _) fattr = (write_row_end dc, fattr)
264
196
265−-- | The cursor position is given in X,Y character offsets. Due to
197+-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
266−-- multi-column characters this needs to be translated to column, row
198+-- needs to be translated to column, row positions.
267−-- positions.
268data CursorOutputMap = CursorOutputMap
199data CursorOutputMap = CursorOutputMap
269− { charToOutputPos :: (Int, Int) -> (Int, Int)
200+ { char_to_output_pos :: (Int, Int) -> (Int, Int)
270− }
201+ }
271
202
272−cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
203+cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap
273−cursorOutputMap spanOps _cursor = CursorOutputMap
204+cursor_output_map span_ops _cursor = CursorOutputMap
274− { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)
205+ { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
275 }
206 }
276
207
277−cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
208+cursor_column_offset :: DisplayOps -> Int -> Int -> Int
278−cursorColumnOffset ops cx cy =
209+cursor_column_offset ops cx cy =
279− let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
210+ let cursor_row_ops = Vector.unsafeIndex ops (fromEnum cy)
280− (outOffset, _, _)
211+ (out_offset, _, _)
281− = Vector.foldl' ( \(d, currentCx, done) op ->
212+ = Vector.foldl' ( \(d, current_cx, done) op ->
282− if done then (d, currentCx, done) else case spanOpHasWidth op of
213+ if done then (d, current_cx, done) else case span_op_has_width op of
283− Nothing -> (d, currentCx, False)
214+ Nothing -> (d, current_cx, False)
284− Just (cw, ow) -> case compare cx (currentCx + cw) of
215+ Just (cw, ow) -> case compare cx (current_cx + cw) of
285 GT -> ( d + ow
216 GT -> ( d + ow
286− , currentCx + cw
217+ , current_cx + cw
287− , False
218+ , False
288 )
219 )
289 EQ -> ( d + ow
220 EQ -> ( d + ow
290− , currentCx + cw
221+ , current_cx + cw
291− , True
222+ , True
292 )
223 )
293− LT -> ( d + columnsToCharOffset (cx - currentCx) op
224+ LT -> ( d + columns_to_char_offset (cx - current_cx) op
294− , currentCx + cw
225+ , current_cx + cw
295 , True
226 , True
296 )
227 )
297 )
228 )
298 (0, 0, False)
229 (0, 0, False)
299− cursorRowOps
230+ cursor_row_ops
300− in outOffset
231+ in out_offset
301
232
302−-- | Not all terminals support all display attributes. This filters a
233+-- | Not all terminals support all display attributes. This filters a display attribute to what the
303−-- display attribute to what the given terminal can display.
234+-- given terminal can display.
304−limitAttrForDisplay :: Output -> Attr -> Attr
235+limit_attr_for_display :: Output -> Attr -> Attr
305−limitAttrForDisplay t attr
236+limit_attr_for_display t attr
306− = attr { attrForeColor = clampColor $ attrForeColor attr
237+ = attr { attr_fore_color = clamp_color $ attr_fore_color attr
307− , attrBackColor = clampColor $ attrBackColor attr
238+ , attr_back_color = clamp_color $ attr_back_color attr
308 }
239 }
309 where
240 where
310− clampColor Default = Default
241+ clamp_color Default = Default
311− clampColor KeepCurrent = KeepCurrent
242+ clamp_color KeepCurrent = KeepCurrent
312− clampColor (SetTo c) = clampColor' (outputColorMode t) c
243+ clamp_color (SetTo c) = clamp_color' c
313−
244+ clamp_color' (ISOColor v)
314− clampColor' NoColor _ = Default
245+ | context_color_count t < 8 = Default
315−
316− clampColor' ColorMode8 (ISOColor v)
317− | v >= 8 = SetTo $ ISOColor (v - 8)
246+ | context_color_count t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
318− | otherwise = SetTo $ ISOColor v
247+ | otherwise = SetTo $ ISOColor v
319− clampColor' ColorMode8 _ = Default
248+ clamp_color' (Color240 v)
320−
249+ -- TODO: Choose closes ISO color?
321− clampColor' ColorMode16 c@(ISOColor _) = SetTo c
250+ | context_color_count t < 8 = Default
322− clampColor' ColorMode16 _ = Default
251+ | context_color_count t < 16 = Default
323−
252+ | context_color_count t == 240 = 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
253+ | otherwise
328− clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
254+ = let p :: Double = fromIntegral v / 240.0
329− clampColor' colorMode (color240 r g b)
255+ v' = floor $ p * (fromIntegral $ context_color_count t)
330−
256+ in SetTo $ Color240 v'
331− clampColor' FullColor c = SetTo c
src/Graphics/Vty/Output/MacOSX.hsnew file+63
@@ -0,0 +1,63 @@
1+-- Copyright Corey O'Connor
2+-- The standard Mac OS X terminals Terminal.app and iTerm both declare themselves to be
3+-- "xterm-color" by default. However the terminfo database for xterm-color included with OS X is
4+-- incomplete.
5+--
6+-- This terminal implementation modifies the standard terminfo terminal as required for complete OS
7+-- X support.
8+{-# LANGUAGE MagicHash #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE TypeFamilies #-}
11+module Graphics.Vty.Output.MacOSX ( reserve_terminal )
12+ where
13+
14+import Graphics.Vty.Output.Interface
15+import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
16+
17+import Control.Applicative
18+import Control.Monad.Trans
19+
20+import System.IO
21+
22+-- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier
23+-- "xterm-256color" is used.
24+--
25+-- This effects the terminfo lookup.
26+reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
27+reserve_terminal v out_handle = do
28+ let remap_term "iTerm.app" = "xterm-256color"
29+ remap_term _ = "xterm"
30+ flushed_put :: String -> IO ()
31+ flushed_put str = do
32+ hPutStr out_handle str
33+ hFlush out_handle
34+ t <- TerminfoBased.reserve_terminal (remap_term v) out_handle
35+ return $ t { terminal_ID = terminal_ID t ++ " (Mac)"
36+ , reserve_display = terminal_app_reserve_display flushed_put
37+ , release_display = terminal_app_release_display flushed_put
38+ }
39+
40+-- | Terminal.app requires the xterm-color smcup and rmcup caps. Not the generic xterm ones.
41+-- Otherwise, Terminal.app expects the xterm caps.
42+smcup_str, rmcup_str :: String
43+smcup_str = "\ESC7\ESC[?47h"
44+rmcup_str = "\ESC[2J\ESC[?47l\ESC8"
45+
46+-- | always smcup then clear the screen on terminal.app
47+--
48+-- \todo really?
49+terminal_app_reserve_display :: MonadIO m => (String -> IO ()) -> m ()
50+terminal_app_reserve_display flushed_put = liftIO $ do
51+ flushed_put smcup_str
52+ flushed_put clear_screen_str
53+
54+terminal_app_release_display :: MonadIO m => (String -> IO ()) -> m ()
55+terminal_app_release_display flushed_put = liftIO $ do
56+ flushed_put rmcup_str
57+
58+-- | iTerm needs a clear screen after smcup as well.
59+--
60+-- \todo but we apply to all mac terminals?
61+clear_screen_str :: String
62+clear_screen_str = "\ESC[H\ESC[2J"
63+
src/Graphics/Vty/Output/Mock.hs+48−68
@@ -1,17 +1,13 @@
1-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4−-- | This provides a mock terminal implementation that is nice for
4+-- | This provides a mock terminal implementation that is nice for testing. This transforms the
5−-- testing. This transforms the output operations to visible characters
5+-- output operations to visible characters. Which is nice for some tests.
6−-- which is useful for testing.
7−module Graphics.Vty.Output.Mock
6+module Graphics.Vty.Output.Mock ( MockData, mock_terminal )
8− ( MockData
9− , mockTerminal
10− )
11−where
7+ where
8+
9+import Graphics.Vty.Prelude
12
10
13−import Graphics.Vty.Image (DisplayRegion)
14−import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
15import Graphics.Vty.Output.Interface
11import Graphics.Vty.Output.Interface
16
12
17import Blaze.ByteString.Builder.Word (writeWord8)
13import Blaze.ByteString.Builder.Word (writeWord8)
@@ -24,67 +20,51 @@ import qualified Data.String.UTF8 as UTF8
24
20
25type MockData = IORef (UTF8.UTF8 BS.ByteString)
21type MockData = IORef (UTF8.UTF8 BS.ByteString)
26
22
27−-- | The mock display terminal produces a string representation of
23+-- | The mock display terminal produces a string representation of the requested picture. There is
28−-- the requested picture. There is *not* an isomorphism between the
29−-- string representation and the picture. The string representation is
24+-- *not* an isomorphism between the string representation and the picture. The string
30−-- a simplification of the picture that is only useful in debugging VTY
25+-- representation is a simplification of the picture that is only useful in debugging VTY without
31−-- without considering terminal specific issues.
26+-- considering terminal specific issues.
32--
27--
33−-- The mock implementation is useful in manually determining if the
28+-- The mock implementation is useful in manually determining if the sequence of terminal operations
34−-- sequence of terminal operations matches the expected sequence. The
35−-- requirement of the produced representation is simplicity in parsing
29+-- matches the expected sequence. So requirement of the produced representation is simplicity in
36−-- the text representation and determining how the picture was mapped to
30+-- parsing the text representation and determining how the picture was mapped to terminal
37−-- terminal operations.
31+-- operations.
38--
32--
39−-- The string representation is a sequence of identifiers where each
33+-- The string representation is a sequence of identifiers where each identifier is the name of an
40−-- identifier is the name of an operation in the algebra.
34+-- operation in the algebra.
41−mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)
35+mock_terminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)
42−mockTerminal r = liftIO $ do
36+mock_terminal r = liftIO $ do
43− outRef <- newIORef undefined
37+ out_ref <- newIORef undefined
44− newAssumedStateRef <- newIORef initialAssumedState
38+ new_assumed_state_ref <- newIORef initial_assumed_state
45 let t = Output
39 let t = Output
46− { terminalID = "mock terminal"
40+ { terminal_ID = "mock terminal"
47− , releaseTerminal = return ()
41+ , release_terminal = return ()
48− , reserveDisplay = return ()
42+ , reserve_display = return ()
49− , releaseDisplay = return ()
43+ , release_display = return ()
50− , ringTerminalBell = return ()
44+ , display_bounds = return r
51− , supportsBell = return False
45+ , output_byte_buffer = \bytes -> do
52− , supportsItalics = return False
53− , supportsStrikethrough = return False
54− , setDisplayBounds = const $ return ()
55− , displayBounds = return r
56− , outputByteBuffer = \bytes -> do
57− putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
46+ putStrLn $ "mock output_byte_buffer of " ++ show (BS.length bytes) ++ " bytes"
58− writeIORef outRef $ UTF8.fromRep bytes
47+ writeIORef out_ref $ UTF8.fromRep bytes
59− , supportsCursorVisibility = True
48+ , context_color_count = 16
60− , supportsMode = const False
49+ , supports_cursor_visibility = True
61− , setMode = const $ const $ return ()
50+ , assumed_state_ref = new_assumed_state_ref
62− , getModeStatus = const $ return False
51+ , mk_display_context = \t_actual r_actual -> return $ DisplayContext
63− , assumedStateRef = newAssumedStateRef
52+ { context_region = r_actual
64− , outputColorMode = ColorMode16
53+ , context_device = t_actual
65− , mkDisplayContext = \tActual rActual -> return $ DisplayContext
66− { contextRegion = rActual
67− , contextDevice = tActual
68− -- A cursor move is always visualized as the single
54+ -- A cursor move is always visualized as the single character 'M'
69− -- character 'M'
70− , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'
55+ , write_move_cursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'
71− -- Show cursor is always visualized as the single
56+ -- Show cursor is always visualized as the single character 'S'
72− -- character 'S'
73− , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S'
57+ , write_show_cursor = writeWord8 $ toEnum $ fromEnum 'S'
74− -- Hide cursor is always visualized as the single
58+ -- Hide cursor is always visualized as the single character 'H'
75− -- character 'H'
76− , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
59+ , write_hide_cursor = writeWord8 $ toEnum $ fromEnum 'H'
77− -- An attr change is always visualized as the single
60+ -- An attr change is always visualized as the single character 'A'
78− -- character 'A'
79− , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
61+ , write_set_attr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
80− -- default attr is always visualized as the single
62+ -- default attr is always visualized as the single character 'D'
81− -- character 'D'
82− , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
63+ , write_default_attr = writeWord8 $ toEnum $ fromEnum 'D'
83− -- row end is always visualized as the single character
64+ -- row end is always visualized as the single character 'E'
84− -- 'E'
85− , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
65+ , write_row_end = writeWord8 $ toEnum $ fromEnum 'E'
86− , inlineHack = return ()
66+ , inline_hack = return ()
87 }
67 }
88 }
68 }
89− return (outRef, t)
69+ return (out_ref, t)
90
70
src/Graphics/Vty/Output/TerminfoBased.hs+333−504
@@ -1,606 +1,435 @@
1+-- | Terminfo based terminal handling.
2+--
3+-- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I
4+-- have easy access to then color support is entirely based of the docs. Probably with some
5+-- assumptions mixed in.
6+--
7+-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
1{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE CPP #-}
4−{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
9+{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}
5{-# CFILES gwinsz.c #-}
10{-# CFILES gwinsz.c #-}
11+module Graphics.Vty.Output.TerminfoBased ( reserve_terminal )
12+ where
6
13
7−-- | Terminfo-based terminal output driver.
14+import Graphics.Vty.Prelude
8−--
9−-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
10−module Graphics.Vty.Output.TerminfoBased
11− ( reserveTerminal
12− , setWindowSize
13− )
14−where
15
15
16−import Control.Monad (when)
17−import Data.Bits (shiftL, (.&.))
18import qualified Data.ByteString as BS
16import qualified Data.ByteString as BS
19−import Data.ByteString.Internal (toForeignPtr)
20import Data.Terminfo.Parse
17import Data.Terminfo.Parse
21import Data.Terminfo.Eval
18import Data.Terminfo.Eval
22
19
23import Graphics.Vty.Attributes
20import Graphics.Vty.Attributes
24−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)
25+
26+import Control.Monad.Trans
29
27
28+import Data.Bits ((.&.))
29+import Data.Foldable (foldMap)
30import Data.IORef
30import Data.IORef
31import Data.Maybe (isJust, isNothing, fromJust)
31import Data.Maybe (isJust, isNothing, fromJust)
32−import Data.Word
32+import Data.Monoid
33
33
34−#if !MIN_VERSION_base(4,8,0)
34+import Foreign.C.Types ( CLong(..) )
35−import Data.Foldable (foldMap)
36−#endif
37
35
38−import Foreign.C.Types ( CInt(..), CLong(..) )
36+import GHC.IO.Handle
39−import Foreign.ForeignPtr (withForeignPtr)
40−import Foreign.Ptr (Ptr, plusPtr)
41
37
42import qualified System.Console.Terminfo as Terminfo
38import qualified System.Console.Terminfo as Terminfo
43−import System.Posix.IO (fdWriteBuf)
44−import System.Posix.Types (Fd(..))
45
39
46−data TerminfoCaps = TerminfoCaps
40+data TerminfoCaps = TerminfoCaps
47 { smcup :: Maybe CapExpression
41 { smcup :: Maybe CapExpression
48 , rmcup :: Maybe CapExpression
42 , rmcup :: Maybe CapExpression
49 , cup :: CapExpression
43 , cup :: CapExpression
50 , cnorm :: Maybe CapExpression
44 , cnorm :: Maybe CapExpression
51 , civis :: Maybe CapExpression
45 , civis :: Maybe CapExpression
52− , useAltColorMap :: Bool
46+ , supports_no_colors :: Bool
47+ , use_alt_color_map :: Bool
53− , setForeColor :: CapExpression
48+ , set_fore_color :: CapExpression
54− , setBackColor :: CapExpression
49+ , set_back_color :: CapExpression
55− , setDefaultAttr :: CapExpression
50+ , set_default_attr :: CapExpression
56− , clearScreen :: CapExpression
51+ , clear_screen :: CapExpression
57− , clearEol :: CapExpression
52+ , clear_eol :: CapExpression
58− , displayAttrCaps :: DisplayAttrCaps
53+ , display_attr_caps :: DisplayAttrCaps
59− , ringBellAudio :: Maybe CapExpression
60 }
54 }
61
55
62data DisplayAttrCaps = DisplayAttrCaps
56data DisplayAttrCaps = DisplayAttrCaps
63− { setAttrStates :: Maybe CapExpression
57+ { set_attr_states :: Maybe CapExpression
64− , enterStandout :: Maybe CapExpression
58+ , enter_standout :: Maybe CapExpression
65− , exitStandout :: Maybe CapExpression
59+ , exit_standout :: Maybe CapExpression
66− , enterItalic :: Maybe CapExpression
60+ , enter_underline :: Maybe CapExpression
67− , exitItalic :: Maybe CapExpression
61+ , exit_underline :: Maybe CapExpression
68− , enterStrikethrough :: Maybe CapExpression
62+ , enter_reverse_video :: Maybe CapExpression
69− , exitStrikethrough :: Maybe CapExpression
63+ , enter_dim_mode :: Maybe CapExpression
70− , enterUnderline :: Maybe CapExpression
71− , exitUnderline :: Maybe CapExpression
72− , enterReverseVideo :: Maybe CapExpression
73− , enterDimMode :: Maybe CapExpression
74− , enterBoldMode :: Maybe CapExpression
64+ , enter_bold_mode :: Maybe CapExpression
75 }
65 }
76−
66+
77−-- kinda like:
78−-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
79−-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
80−-- the write will be retried.
81−fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
82−fdWriteAll outFd ptr len count
83− | len < 0 = fail "fdWriteAll: len is less than 0"
84− | len == 0 = return count
85− | otherwise = do
86− writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)
87− let len' = len - writeCount
88− ptr' = ptr `plusPtr` writeCount
89− count' = count + writeCount
90− fdWriteAll outFd ptr' len' count'
91−
92−sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
67+send_cap_to_terminal :: Output -> CapExpression -> [CapParam] -> IO ()
93−sendCapToTerminal t cap capParams = do
68+send_cap_to_terminal t cap cap_params = do
94− outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
69+ output_byte_buffer t $ writeToByteString $ write_cap_expr cap cap_params
95−
70+
96−-- | Constructs an output driver that uses terminfo for all control
97−-- codes. While this should provide the most compatible terminal,
71+{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
98−-- terminfo does not support some features that would increase
72+ - terminfo does not support some features that would increase efficiency and improve compatibility:
99−-- efficiency and improve compatibility:
100−--
101−-- * determining the character encoding supported by the terminal.
73+ - * determine the character encoding supported by the terminal. Should this be taken from the LANG
102−-- Should this be taken from the LANG environment variable?
74+ - environment variable?
103−--
104−-- * Providing independent string capabilities for all display
75+ - * Provide independent string capabilities for all display attributes.
105−-- attributes.
76+ -
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
77+ -
107−reserveTerminal termName outFd colorMode = do
78+ - todo: Some display attributes like underline and bold have independent string capabilities that
79+ - should be used instead of the generic "sgr" string capability.
80+ -}
81+reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
82+reserve_terminal in_ID out_handle = liftIO $ do
108− ti <- Terminfo.setupTerm termName
83+ ti <- Terminfo.setupTerm in_ID
109 -- assumes set foreground always implies set background exists.
84 -- assumes set foreground always implies set background exists.
110− -- if set foreground is not set then all color changing style
85+ -- if set foreground is not set then all color changing style attributes are filtered.
111− -- attributes are filtered.
112− msetaf <- probeCap ti "setaf"
86+ msetaf <- probe_cap ti "setaf"
113− msetf <- probeCap ti "setf"
87+ msetf <- probe_cap ti "setf"
114− let (useAlt, setForeCap)
88+ let (no_colors, use_alt, set_fore_cap)
115 = case msetaf of
89 = case msetaf of
116− Just setaf -> (False, setaf)
90+ Just setaf -> (False, False, setaf)
117 Nothing -> case msetf of
91 Nothing -> case msetf of
118− Just setf -> (True, setf)
92+ Just setf -> (False, True, setf)
119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
93+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ in_ID)
120− msetab <- probeCap ti "setab"
94+ msetab <- probe_cap ti "setab"
121− msetb <- probeCap ti "setb"
95+ msetb <- probe_cap ti "setb"
122− let setBackCap
96+ let set_back_cap
123 = case msetab of
97 = case msetab of
124− Just setab -> setab
125 Nothing -> case msetb of
98 Nothing -> case msetb of
126 Just setb -> setb
99 Just setb -> setb
127− Nothing -> error $ "no back color support for terminal " ++ termName
100+ Nothing -> error $ "no back color support for terminal " ++ in_ID
128−
101+ 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
102+ terminfo_caps <- pure TerminfoCaps
148− <*> probeCap ti "smcup"
103+ <*> probe_cap ti "smcup"
149− <*> probeCap ti "rmcup"
104+ <*> probe_cap ti "rmcup"
150− <*> requireCap ti "cup"
105+ <*> require_cap ti "cup"
151− <*> probeCap ti "cnorm"
106+ <*> probe_cap ti "cnorm"
152− <*> probeCap ti "civis"
107+ <*> probe_cap ti "civis"
153− <*> pure useAlt
108+ <*> pure no_colors
154− <*> pure setForeCap
109+ <*> pure use_alt
155− <*> pure setBackCap
110+ <*> pure set_fore_cap
156− <*> requireCap ti "sgr0"
111+ <*> pure set_back_cap
112+ <*> require_cap ti "sgr0"
157− <*> requireCap ti "clear"
113+ <*> require_cap ti "clear"
158− <*> requireCap ti "el"
114+ <*> require_cap ti "el"
159− <*> currentDisplayAttrCaps ti
115+ <*> current_display_attr_caps ti
160− <*> probeCap ti "bel"
116+ new_assumed_state_ref <- newIORef initial_assumed_state
161 let t = Output
117 let t = Output
162− { terminalID = termName
118+ { terminal_ID = in_ID
163− , releaseTerminal = do
119+ , release_terminal = liftIO $ do
164− sendCap setDefaultAttr []
120+ send_cap set_default_attr []
165− maybeSendCap cnorm []
121+ maybe_send_cap cnorm []
166− , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
122+ hClose out_handle
167− , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) &&
123+ , reserve_display = liftIO $ do
168− (isJust $ exitItalic (displayAttrCaps terminfoCaps))
169− , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
170− (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
171− , ringTerminalBell = maybeSendCap ringBellAudio []
172− , reserveDisplay = do
173− -- If there is no support for smcup: Clear the screen
124+ -- If there is no support for smcup: Clear the screen and then move the mouse to the
174− -- and then move the mouse to the home position to
175− -- approximate the behavior.
125+ -- home position to approximate the behavior.
176− maybeSendCap smcup []
126+ maybe_send_cap smcup []
177− sendCap clearScreen []
127+ hFlush out_handle
178− , releaseDisplay = do
128+ send_cap clear_screen []
179− maybeSendCap rmcup []
129+ , release_display = liftIO $ do
180− maybeSendCap cnorm []
130+ maybe_send_cap rmcup []
181− , setDisplayBounds = \(w, h) ->
131+ maybe_send_cap cnorm []
182− setWindowSize outFd (w, h)
132+ , display_bounds = do
183− , displayBounds = do
133+ raw_size <- liftIO $ get_window_size
184− rawSize <- getWindowSize outFd
185− case rawSize of
134+ case raw_size of
186− (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
135+ (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size
187 | otherwise -> return (w,h)
136 | otherwise -> return (w,h)
188− , outputByteBuffer = \outBytes -> do
137+ , output_byte_buffer = \out_bytes -> do
189− let (fptr, offset, len) = toForeignPtr outBytes
138+ BS.hPut out_handle out_bytes
190− actualLen <- withForeignPtr fptr
139+ hFlush out_handle
191− $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0
140+ , context_color_count
192− when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
141+ = case supports_no_colors terminfo_caps of
193− ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
142+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
194− ++ " Please report this bug to vty project."
143+ Nothing -> 8
195− , supportsCursorVisibility = isJust $ civis terminfoCaps
144+ Just v -> toEnum v
196− , supportsMode = terminfoModeSupported
145+ True -> 1
197− , setMode = terminfoSetMode
146+ , supports_cursor_visibility = isJust $ civis terminfo_caps
198− , getModeStatus = terminfoModeStatus
147+ , assumed_state_ref = new_assumed_state_ref
199− , assumedStateRef = newAssumedStateRef
200− , outputColorMode = colorMode
201− -- I think fix would help assure tActual is the only
148+ -- I think fix would help assure t_actual is the only reference. I was having issues
202− -- reference. I was having issues tho.
149+ -- tho.
203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
150+ , mk_display_context = \t_actual -> liftIO . terminfo_display_context t_actual terminfo_caps
204 }
151 }
205− sendCap s = sendCapToTerminal t (s terminfoCaps)
152+ send_cap s = send_cap_to_terminal t (s terminfo_caps)
206− maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
153+ maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)
207 return t
154 return t
208
155
209−requireCap :: Terminfo.Terminal -> String -> IO CapExpression
156+require_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
210−requireCap ti capName
157+require_cap ti cap_name
211− = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
158+ = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
212− Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
159+ Nothing -> fail $ "Terminal does not define required capability \"" ++ cap_name ++ "\""
213− Just capStr -> parseCap capStr
160+ Just cap_str -> parse_cap cap_str
214−
161+
215−probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
162+probe_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
216−probeCap ti capName
163+probe_cap ti cap_name
217− = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
164+ = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
218− Nothing -> return Nothing
165+ Nothing -> return Nothing
219− Just capStr -> Just <$> parseCap capStr
166+ Just cap_str -> Just <$> parse_cap cap_str
220−
167+
221−parseCap :: String -> IO CapExpression
168+parse_cap :: (Applicative m, MonadIO m) => String -> m CapExpression
222−parseCap capStr = do
169+parse_cap cap_str = do
223− case parseCapExpression capStr of
170+ case parse_cap_expression cap_str of
224 Left e -> fail $ show e
171 Left e -> fail $ show e
225 Right cap -> return cap
172 Right cap -> return cap
226
173
174+current_display_attr_caps :: ( Applicative m, MonadIO m )
227−currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
175+ => Terminfo.Terminal
228−currentDisplayAttrCaps ti
176+ -> m DisplayAttrCaps
177+current_display_attr_caps ti
229− = pure DisplayAttrCaps
178+ = pure DisplayAttrCaps
230− <*> probeCap ti "sgr"
179+ <*> probe_cap ti "sgr"
231− <*> probeCap ti "smso"
180+ <*> probe_cap ti "smso"
232− <*> probeCap ti "rmso"
181+ <*> probe_cap ti "rmso"
233− <*> probeCap ti "sitm"
234− <*> probeCap ti "ritm"
235− <*> probeCap ti "smxx"
236− <*> probeCap ti "rmxx"
237− <*> probeCap ti "smul"
182+ <*> probe_cap ti "smul"
238− <*> probeCap ti "rmul"
183+ <*> probe_cap ti "rmul"
239− <*> probeCap ti "rev"
184+ <*> probe_cap ti "rev"
240− <*> probeCap ti "dim"
185+ <*> probe_cap ti "dim"
241− <*> probeCap ti "bold"
186+ <*> probe_cap ti "bold"
242−
187+
243−foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
188+foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size :: IO CLong
244−
189+
245−getWindowSize :: Fd -> IO (Int,Int)
190+get_window_size :: IO (Int,Int)
246−getWindowSize fd = do
191+get_window_size = do
247− (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
192+ (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
248 return (fromIntegral b, fromIntegral a)
193 return (fromIntegral b, fromIntegral a)
249
194
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−
257−terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
195+terminfo_display_context :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
258−terminfoDisplayContext tActual terminfoCaps r = return dc
196+terminfo_display_context t_actual terminfo_caps r = return dc
259 where dc = DisplayContext
197 where dc = DisplayContext
260− { contextDevice = tActual
198+ { context_device = t_actual
261− , contextRegion = r
199+ , context_region = r
262− , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]
200+ , write_move_cursor = \x y -> write_cap_expr (cup terminfo_caps) [toEnum y, toEnum x]
263− , writeShowCursor = case cnorm terminfoCaps of
201+ , write_show_cursor = case cnorm terminfo_caps of
264 Nothing -> error "this terminal does not support show cursor"
202 Nothing -> error "this terminal does not support show cursor"
265− Just c -> writeCapExpr c []
203+ Just c -> write_cap_expr c []
266− , writeHideCursor = case civis terminfoCaps of
204+ , write_hide_cursor = case civis terminfo_caps of
267 Nothing -> error "this terminal does not support hide cursor"
205 Nothing -> error "this terminal does not support hide cursor"
268− Just c -> writeCapExpr c []
206+ Just c -> write_cap_expr c []
269− , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
207+ , write_set_attr = terminfo_write_set_attr dc terminfo_caps
270− , writeDefaultAttr = \urlsEnabled ->
208+ , write_default_attr = write_cap_expr (set_default_attr terminfo_caps) []
271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
209+ , write_row_end = write_cap_expr (clear_eol terminfo_caps) []
272− (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
210+ , inline_hack = return ()
273− (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274− Just cap -> writeCapExpr cap []
275− Nothing -> mempty
276− )
277− , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
278− , inlineHack = return ()
279 }
211 }
280
212
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.
213-- | Portably setting the display attributes is a giant pain in the ass.
296--
214--
297−-- If the terminal supports the sgr capability (which sets the on/off
215+-- If the terminal supports the sgr capability (which sets the on/off state of each style
298−-- state of each style directly; and, for no good reason, resets the
299−-- colors to the default) this procedure is used:
216+-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
300--
217--
301-- 0. set the style attributes. This resets the fore and back color.
218-- 0. set the style attributes. This resets the fore and back color.
302−--
303-- 1, If a foreground color is to be set then set the foreground color
219-- 1, If a foreground color is to be set then set the foreground color
304−--
305-- 2. likewise with the background color
220-- 2. likewise with the background color
221+--
222+-- If the terminal does not support the sgr cap then:
223+-- if there is a change from an applied color to the default (in either the fore or back color)
224+-- then:
225+-- 0. reset all display attributes (sgr0)
226+-- 1. enter required style modes
227+-- 2. set the fore color if required
228+-- 3. set the back color if required
306--
229--
307−-- If the terminal does not support the sgr cap then: if there is a
308−-- change from an applied color to the default (in either the fore or
309−-- back color) then:
310−--
311−-- 0. reset all display attributes (sgr0)
312−--
313−-- 1. enter required style modes
314−--
315−-- 2. set the fore color if required
316−--
317−-- 3. set the back color if required
318−--
319−-- Entering the required style modes could require a reset of the
230+-- Entering the required style modes could require a reset of the display attributes. If this is
320−-- display attributes. If this is the case then the back and fore colors
321−-- always need to be set if not default.
231+-- the case then the back and fore colors always need to be set if not default.
322--
232--
323-- This equation implements the above logic.
233-- This equation implements the above logic.
324--
234--
325−-- Note that this assumes the removal of color changes in the
235+-- \todo This assumes the removal of color changes in the display attributes is done as expected
326−-- display attributes is done as expected with noColors == True. See
236+-- with no_colors == True. See `limit_attr_for_display`
327−-- `limitAttrForDisplay`.
328--
237--
329−-- Note that this optimizes for fewer state changes followed by fewer
238+-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
330−-- bytes.
239+-- haven't measured this or even examined terminal implementations. *shrug*
331−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
240+terminfo_write_set_attr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
332−terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
241+terminfo_write_set_attr dc terminfo_caps prev_attr req_attr diffs = do
333− urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
242+ case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of
334− -- The only way to reset either color, portably, to the default
243+ -- The only way to reset either color, portably, to the default is to use either the set
335− -- is to use either the set state capability or the set default
244+ -- state capability or the set default capability.
336− -- capability.
337− True -> do
245+ True -> do
338− case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
246+ case req_display_cap_seq_for (display_attr_caps terminfo_caps)
339− (fixedStyle attr)
247+ (fixed_style attr )
340− (styleToApplySeq $ fixedStyle attr) of
248+ (style_to_apply_seq $ fixed_style attr) of
341 -- only way to reset a color to the defaults
249 -- only way to reset a color to the defaults
342− EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
250+ EnterExitSeq caps -> write_default_attr dc
251+ `mappend`
252+ foldMap (\cap -> write_cap_expr cap []) caps
343 `mappend`
253 `mappend`
344− foldMap (\cap -> writeCapExpr cap []) caps
254+ set_colors
345− `mappend`
346− setColors
347 -- implicitly resets the colors to the defaults
255 -- implicitly resets the colors to the defaults
348− SetState state -> writeCapExpr (fromJust $ setAttrStates
256+ SetState state -> write_cap_expr (fromJust $ set_attr_states
349− $ displayAttrCaps terminfoCaps
257+ $ display_attr_caps
258+ $ terminfo_caps
350− )
259+ )
351− (sgrArgsForState state)
260+ (sgr_args_for_state state)
352− `mappend` setItalics
261+ `mappend`
353− `mappend` setStrikethrough
262+ set_colors
354− `mappend` setColors
355− -- Otherwise the display colors are not changing or changing
263+ -- Otherwise the display colors are not changing or changing between two non-default
356− -- between two non-default points.
264+ -- points.
357 False -> do
265 False -> do
358− -- Still, it could be the case that the change in display
266+ -- Still, it could be the case that the change in display attributes requires the
359− -- attributes requires the colors to be reset because the
360− -- required capability was not available.
267+ -- colors to be reset because the required capability was not available.
361− case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
268+ case req_display_cap_seq_for (display_attr_caps terminfo_caps)
362− (fixedStyle attr)
269+ (fixed_style attr)
363− (styleDiffs diffs) of
270+ (style_diffs diffs) of
364− -- Really, if terminals were re-implemented with modern
271+ -- Really, if terminals were re-implemented with modern concepts instead of bowing
365− -- concepts instead of bowing down to 40 yr old dumb
366− -- terminal requirements this would be the only case
272+ -- down to 40 yr old dumb terminal requirements this would be the only case ever
367− -- ever reached! Changes the style and color states
273+ -- reached! Changes the style and color states according to the differences with
368− -- according to the differences with the currently
369− -- applied states.
274+ -- the currently applied states.
370− EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
275+ EnterExitSeq caps -> foldMap (\cap -> write_cap_expr cap []) caps
371 `mappend`
276 `mappend`
372− writeColorDiff Foreground (foreColorDiff diffs)
277+ write_color_diff set_fore_color (fore_color_diff diffs)
373 `mappend`
278 `mappend`
374− writeColorDiff Background (backColorDiff diffs)
279+ write_color_diff set_back_color (back_color_diff diffs)
375 -- implicitly resets the colors to the defaults
280 -- implicitly resets the colors to the defaults
376− SetState state -> writeCapExpr (fromJust $ setAttrStates
281+ SetState state -> write_cap_expr (fromJust $ set_attr_states
377− $ displayAttrCaps terminfoCaps
282+ $ display_attr_caps terminfo_caps
378− )
283+ )
379− (sgrArgsForState state)
284+ (sgr_args_for_state state)
380− `mappend` setItalics
285+ `mappend` set_colors
381− `mappend` setStrikethrough
382− `mappend` setColors
383− where
286+ where
384− urlAttrs True = writeURLEscapes (urlDiff diffs)
287+ color_map = case use_alt_color_map terminfo_caps of
385− urlAttrs False = mempty
288+ False -> ansi_color_index
386− colorMap = case useAltColorMap terminfoCaps of
289+ True -> alt_color_index
387− False -> ansiColorIndex
290+ attr = fix_display_attr prev_attr req_attr
388− True -> altColorIndex
291+ set_colors =
389− attr = fixDisplayAttr prevAttr reqAttr
390−
391− -- italics can't be set via SGR, so here we manually
392− -- apply the enter and exit sequences as needed after
393− -- changing the SGR
394− setItalics
395− | hasStyle (fixedStyle attr) italic
396− , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
397− = writeCapExpr sitm []
398− | otherwise = mempty
399− setStrikethrough
400− | hasStyle (fixedStyle attr) strikethrough
401− , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)
402− = writeCapExpr smxx []
403− | otherwise = mempty
404− setColors =
405− (case fixedForeColor attr of
292+ (case fixed_fore_color attr of
406− Just c -> writeColor Foreground c
293+ Just c -> write_cap_expr (set_fore_color terminfo_caps)
294+ [toEnum $ color_map c]
407 Nothing -> mempty)
295 Nothing -> mempty)
408 `mappend`
296 `mappend`
409− (case fixedBackColor attr of
297+ (case fixed_back_color attr of
410− Just c -> writeColor Background c
298+ Just c -> write_cap_expr (set_back_color terminfo_caps)
299+ [toEnum $ color_map c]
411 Nothing -> mempty)
300 Nothing -> mempty)
412− writeColorDiff _side NoColorChange
301+ write_color_diff _f NoColorChange
413 = mempty
302 = mempty
414− writeColorDiff _side ColorToDefault
303+ write_color_diff _f ColorToDefault
415− = error "ColorToDefault is not a possible case for applyColorDiffs"
304+ = error "ColorToDefault is not a possible case for apply_color_diffs"
416− writeColorDiff side (SetColor c)
305+ write_color_diff f (SetColor c)
417− = writeColor side c
306+ = write_cap_expr (f terminfo_caps) [toEnum $ color_map c]
418
307
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]
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−
453−-- | The color table used by a terminal is a 16 color set followed by a
308+-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
454−-- 240 color set that might not be supported by the terminal.
309+-- be supported by the terminal.
455--
310--
456−-- This takes a Color which clearly identifies which palette to use and
311+-- This takes a Color which clearly identifies which pallete to use and computes the index
457−-- computes the index into the full 256 color palette.
312+-- into the full 256 color pallete.
458−ansiColorIndex :: Color -> Int
313+ansi_color_index :: Color -> Int
459−ansiColorIndex (ISOColor v) = fromEnum v
314+ansi_color_index (ISOColor v) = fromEnum v
460−ansiColorIndex (Color240 v) = 16 + fromEnum v
315+ansi_color_index (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
316
466-- | For terminals without setaf/setab
317-- | For terminals without setaf/setab
467−--
318+--
468-- See table in `man terminfo`
319-- See table in `man terminfo`
469-- Will error if not in table.
320-- Will error if not in table.
470−altColorIndex :: Color -> Int
321+alt_color_index :: Color -> Int
471−altColorIndex (ISOColor 0) = 0
322+alt_color_index (ISOColor 0) = 0
472−altColorIndex (ISOColor 1) = 4
323+alt_color_index (ISOColor 1) = 4
473−altColorIndex (ISOColor 2) = 2
324+alt_color_index (ISOColor 2) = 2
474−altColorIndex (ISOColor 3) = 6
325+alt_color_index (ISOColor 3) = 6
475−altColorIndex (ISOColor 4) = 1
326+alt_color_index (ISOColor 4) = 1
476−altColorIndex (ISOColor 5) = 5
327+alt_color_index (ISOColor 5) = 5
477−altColorIndex (ISOColor 6) = 3
328+alt_color_index (ISOColor 6) = 3
478−altColorIndex (ISOColor 7) = 7
329+alt_color_index (ISOColor 7) = 7
479−altColorIndex (ISOColor v) = fromEnum v
330+alt_color_index (ISOColor v) = fromEnum v
480−altColorIndex (Color240 v) = 16 + fromEnum v
331+alt_color_index (Color240 v) = 16 + fromEnum v
481−altColorIndex (RGBColor _ _ _) =
332+
482− error $ unlines [ "Attempted to create color index from rgb color."
483− , "This is currently unsupported, and shouldn't ever happen"
484− ]
485−
486−{- | The sequence of terminfo caps to apply a given style are determined
333+{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
487− - according to these rules.
334+ -
335+ - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
336+ - the full set display attribute state capability.
488 -
337 -
489− - 1. The assumption is that it's preferable to use the simpler
338+ - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
490− - enter/exit mode capabilities than the full set display attribute
339+ - display attributes are reset to defaults then the display attribute state is set.
491− - state capability.
492 -
340 -
493− - 2. If a mode is supposed to be removed but there is not an exit
341+ - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
494− - capability defined then the display attributes are reset to defaults
495− - then the display attribute state is set.
342+ - display attribute state is set if possible. Otherwise the mode is not applied.
496 -
343 -
497− - 3. If a mode is supposed to be applied but there is not an enter
498− - capability defined then then display attribute state is set if
344+ - 4. If the display attribute state is being set then just update the arguments to that for any
499− - possible. Otherwise the mode is not applied.
345+ - apply/remove.
500 -
346 -
501− - 4. If the display attribute state is being set then just update the
502− - arguments to that for any apply/remove.
503 -}
347 -}
504data DisplayAttrSeq
348data DisplayAttrSeq
505 = EnterExitSeq [CapExpression]
349 = EnterExitSeq [CapExpression]
506 | SetState DisplayAttrState
350 | SetState DisplayAttrState
507
351
508data DisplayAttrState = DisplayAttrState
352data DisplayAttrState = DisplayAttrState
509− { applyStandout :: Bool
353+ { apply_standout :: Bool
510− , applyUnderline :: Bool
354+ , apply_underline :: Bool
511− , applyItalic :: Bool
355+ , apply_reverse_video :: Bool
512− , applyStrikethrough :: Bool
356+ , apply_blink :: Bool
513− , applyReverseVideo :: Bool
357+ , apply_dim :: Bool
514− , applyBlink :: Bool
358+ , apply_bold :: Bool
515− , applyDim :: Bool
516− , applyBold :: Bool
517 }
359 }
518
360
519−sgrArgsForState :: DisplayAttrState -> [CapParam]
361+sgr_args_for_state :: DisplayAttrState -> [CapParam]
520−sgrArgsForState attrState = map (\b -> if b then 1 else 0)
362+sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
521− [ applyStandout attrState
363+ [ apply_standout attr_state
522− , applyUnderline attrState
364+ , apply_underline attr_state
523− , applyReverseVideo attrState
365+ , apply_reverse_video attr_state
524− , applyBlink attrState
366+ , apply_blink attr_state
525− , applyDim attrState
367+ , apply_dim attr_state
526− , applyBold attrState
368+ , apply_bold attr_state
527 , False -- invis
369 , False -- invis
528 , False -- protect
370 , False -- protect
529 , False -- alt char set
371 , False -- alt char set
530 ]
372 ]
531
373
532−reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
374+req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
533−reqDisplayCapSeqFor caps s diffs
375+req_display_cap_seq_for caps s diffs
534− -- if the state transition implied by any diff cannot be supported
376+ -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
535− -- with an enter/exit mode cap then either the state needs to be set
536− -- or the attribute change ignored.
377+ -- then either the state needs to be set or the attribute change ignored.
537− = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
378+ = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
538 -- If all the diffs have an enter-exit cap then just use those
379 -- If all the diffs have an enter-exit cap then just use those
539− ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
380+ ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs
540− -- If not all the diffs have an enter-exit cap and there is no
381+ -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
541− -- set state cap then filter out all unsupported diffs and just
382+ -- all unsupported diffs and just apply the rest
542− -- apply the rest
543− ( True, False ) -> EnterExitSeq $ map enterExitCap
383+ ( True, False ) -> EnterExitSeq $ map enter_exit_cap
544− $ filter (not . noEnterExitCap) diffs
384+ $ filter (not . no_enter_exit_cap) diffs
545− -- if not all the diffs have an enter-exit can and there is a
385+ -- if not all the diffs have an enter-exit can and there is a set state cap then just use
546− -- set state cap then just use the set state cap.
386+ -- the set state cap.
547− ( True, True ) -> SetState $ stateForStyle s
387+ ( True, True ) -> SetState $ state_for_style s
548 where
388 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
389+ no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
554− noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
390+ no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
555− noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
391+ no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
556− noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
392+ no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
557− noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
393+ no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
558− noEnterExitCap RemoveReverseVideo = True
394+ no_enter_exit_cap RemoveReverseVideo = True
559− noEnterExitCap ApplyBlink = True
395+ no_enter_exit_cap ApplyBlink = True
560− noEnterExitCap RemoveBlink = True
396+ no_enter_exit_cap RemoveBlink = True
561− noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
397+ no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
562− noEnterExitCap RemoveDim = True
398+ no_enter_exit_cap RemoveDim = True
563− noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
399+ no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
564− noEnterExitCap RemoveBold = True
400+ no_enter_exit_cap 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
401+ enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
570− enterExitCap RemoveStandout = fromJust $ exitStandout caps
402+ enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
571− enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
403+ enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
572− enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
404+ enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
573− enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
405+ enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
574− enterExitCap ApplyDim = fromJust $ enterDimMode caps
406+ enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
575− enterExitCap ApplyBold = fromJust $ enterBoldMode caps
407+ enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
576− enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
408+ enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
577−
409+
578−stateForStyle :: Style -> DisplayAttrState
410+state_for_style :: Style -> DisplayAttrState
579−stateForStyle s = DisplayAttrState
411+state_for_style s = DisplayAttrState
580− { applyStandout = isStyleSet standout
412+ { apply_standout = is_style_set standout
581− , applyUnderline = isStyleSet underline
413+ , apply_underline = is_style_set underline
582− , applyItalic = isStyleSet italic
414+ , apply_reverse_video = is_style_set reverse_video
583− , applyStrikethrough = isStyleSet strikethrough
415+ , apply_blink = is_style_set blink
584− , applyReverseVideo = isStyleSet reverseVideo
416+ , apply_dim = is_style_set dim
585− , applyBlink = isStyleSet blink
417+ , apply_bold = is_style_set bold
586− , applyDim = isStyleSet dim
587− , applyBold = isStyleSet bold
588 }
418 }
589− where isStyleSet = hasStyle s
419+ where is_style_set = has_style s
590−
420+
591−styleToApplySeq :: Style -> [StyleStateChange]
421+style_to_apply_seq :: Style -> [StyleStateChange]
592−styleToApplySeq s = concat
422+style_to_apply_seq s = concat
593− [ applyIfRequired ApplyStandout standout
423+ [ apply_if_required ApplyStandout standout
594− , applyIfRequired ApplyUnderline underline
424+ , apply_if_required ApplyUnderline underline
595− , applyIfRequired ApplyItalic italic
425+ , apply_if_required ApplyReverseVideo reverse_video
596− , applyIfRequired ApplyStrikethrough strikethrough
597− , applyIfRequired ApplyReverseVideo reverseVideo
598− , applyIfRequired ApplyBlink blink
426+ , apply_if_required ApplyBlink blink
599− , applyIfRequired ApplyDim dim
427+ , apply_if_required ApplyDim dim
600− , applyIfRequired ApplyBold bold
428+ , apply_if_required ApplyBlink bold
601 ]
429 ]
602− where
430+ where
603− applyIfRequired op flag
431+ apply_if_required op flag
604 = if 0 == (flag .&. s)
432 = if 0 == (flag .&. s)
605 then []
433 then []
606 else [op]
434 else [op]
435+
src/Graphics/Vty/Output/XTermColor.hs+34−111
@@ -1,131 +1,54 @@
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
4−-- extensions for Xterm.
5−module Graphics.Vty.Output.XTermColor
2+module Graphics.Vty.Output.XTermColor ( reserve_terminal )
6− ( reserveTerminal
7− )
8−where
3+ where
9
4
10import Graphics.Vty.Output.Interface
5import Graphics.Vty.Output.Interface
11−import Graphics.Vty.Input.Mouse
12−import Graphics.Vty.Input.Focus
13−import Graphics.Vty.Attributes.Color (ColorMode)
14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
6import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
15
7
16import Blaze.ByteString.Builder (writeToByteString)
8import Blaze.ByteString.Builder (writeToByteString)
17import Blaze.ByteString.Builder.Word (writeWord8)
9import Blaze.ByteString.Builder.Word (writeWord8)
18
10
19−import qualified Data.ByteString.Char8 as BS8
11+import Control.Applicative
20−import Data.ByteString.Char8 (ByteString)
21−import Foreign.Ptr (castPtr)
22−
23−import Control.Monad (void, when)
24import Control.Monad.Trans
12import Control.Monad.Trans
25−import Data.Char (toLower)
26−import Data.IORef
27−
28−import System.Posix.IO (fdWriteBuf)
29−import System.Posix.Types (ByteCount, Fd)
30−import System.Posix.Env (getEnv)
31−
32−import Data.List (isInfixOf)
33−import Data.Maybe (catMaybes)
34
13
35−#if !MIN_VERSION_base(4,11,0)
36−import Data.Monoid ((<>))
14+import Data.Foldable (foldMap)
37−#endif
38
15
39−-- | Write a 'ByteString' to an 'Fd'.
16+import System.IO
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
17
45−-- | Construct an Xterm output driver. Initialize the display to UTF-8.
18+-- | Initialize the display to UTF-8.
46−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
19+reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
47−reserveTerminal variant outFd colorMode = liftIO $ do
20+reserve_terminal variant out_handle = liftIO $ do
48− let flushedPut = void . fdWrite outFd
21+ let flushed_put str = do
22+ hPutStr out_handle str
23+ hFlush out_handle
49− -- If the terminal variant is xterm-color use xterm instead since,
24+ -- If the terminal variant is xterm-color use xterm instead since, more often than not,
50− -- more often than not, xterm-color is broken.
25+ -- xterm-color is broken.
51 let variant' = if variant == "xterm-color" then "xterm" else variant
26 let variant' = if variant == "xterm-color" then "xterm" else variant
52−
27+ flushed_put set_utf8_char_set
53− utf8a <- utf8Active
54− when (not utf8a) $ flushedPut setUtf8CharSet
55− t <- TerminfoBased.reserveTerminal variant' outFd colorMode
28+ t <- TerminfoBased.reserve_terminal variant' out_handle
56−
57− mouseModeStatus <- newIORef False
58− focusModeStatus <- newIORef False
59− pasteModeStatus <- newIORef False
60−
61− let xtermSetMode t' m newStatus = do
62− curStatus <- getModeStatus t' m
63− when (newStatus /= curStatus) $
64− case m of
65− Focus -> liftIO $ do
66− case newStatus of
67− True -> flushedPut requestFocusEvents
68− False -> flushedPut disableFocusEvents
69− writeIORef focusModeStatus newStatus
70− Mouse -> liftIO $ do
71− case newStatus of
72− True -> flushedPut requestMouseEvents
73− False -> flushedPut disableMouseEvents
74− writeIORef mouseModeStatus newStatus
75− BracketedPaste -> liftIO $ do
76− case newStatus of
77− True -> flushedPut enableBracketedPastes
78− False -> flushedPut disableBracketedPastes
79− writeIORef pasteModeStatus newStatus
80− Hyperlink -> setMode t Hyperlink newStatus
81−
82− xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
83− xtermGetMode Focus = liftIO $ readIORef focusModeStatus
84− xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
85− xtermGetMode Hyperlink = getModeStatus t Hyperlink
86−
87 let t' = t
29 let t' = t
88− { terminalID = terminalID t ++ " (xterm-color)"
30+ { terminal_ID = terminal_ID t ++ " (xterm-color)"
89− , releaseTerminal = do
31+ , release_terminal = do
90− when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
32+ liftIO $ flushed_put set_default_char_set
91− setMode t' BracketedPaste False
33+ release_terminal t
92− setMode t' Mouse False
34+ , mk_display_context = \t_actual r -> do
93− setMode t' Focus False
35+ dc <- mk_display_context t t_actual r
94− releaseTerminal t
36+ return $ dc { inline_hack = xterm_inline_hack t' }
95− , mkDisplayContext = \tActual r -> do
96− dc <- mkDisplayContext t tActual r
97− return $ dc { inlineHack = xtermInlineHack t' }
98− , supportsMode = const True
99− , getModeStatus = xtermGetMode
100− , setMode = xtermSetMode t'
101 }
37 }
102 return t'
38 return t'
103
39
104−utf8Active :: IO Bool
105−utf8Active = do
106− let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
107− results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars
108− let matches = filter ("utf8" `isInfixOf`) results <>
109− filter ("utf-8" `isInfixOf`) results
110− return $ not $ null matches
111−
112−-- | Enable bracketed paste mode:
113−-- http://cirw.in/blog/bracketed-paste
114−enableBracketedPastes :: ByteString
115−enableBracketedPastes = BS8.pack "\ESC[?2004h"
116−
117−-- | Disable bracketed paste mode:
118−disableBracketedPastes :: ByteString
119−disableBracketedPastes = BS8.pack "\ESC[?2004l"
120−
121-- | These sequences set xterm based terminals to UTF-8 output.
40-- | These sequences set xterm based terminals to UTF-8 output.
122--
41--
123−-- There is no known terminfo capability equivalent to this.
42+-- \todo I don't know of a terminfo cap that is equivalent to this.
124−setUtf8CharSet, setDefaultCharSet :: ByteString
43+set_utf8_char_set, set_default_char_set :: String
125−setUtf8CharSet = BS8.pack "\ESC%G"
44+set_utf8_char_set = "\ESC%G"
126−setDefaultCharSet = BS8.pack "\ESC%@"
45+set_default_char_set = "\ESC%@"
46+
47+-- | I think xterm is broken: Reseting the background color as the first bytes serialized on a
48+-- new line does not effect the background color xterm uses to clear the line. Which is used
49+-- *after* the next newline.
50+xterm_inline_hack :: Output -> IO ()
51+xterm_inline_hack t = do
52+ let write_reset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
53+ output_byte_buffer t $ writeToByteString write_reset
127
54
128−xtermInlineHack :: Output -> IO ()
129−xtermInlineHack t = do
130− let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
131− outputByteBuffer t $ writeToByteString writeReset
src/Graphics/Vty/Picture.hs+66−92
@@ -1,36 +1,25 @@
1−-- A 'Picture' is a background paired with a set of 'Image' layers. The
1+{-# LANGUAGE BangPatterns #-}
2−-- 'Picture' data structure is representative of the final terminal
2+-- | The 'Picture' data structure is representative of the final terminal view.
3−-- view.
3+--
4+-- A 'Picture' is a background paired with a layer of 'Image's.
4−module Graphics.Vty.Picture
5+module Graphics.Vty.Picture ( module Graphics.Vty.Picture
5− ( Picture(..)
6+ , module Graphics.Vty.Image
6− , Cursor(..)
7− , Background(..)
8− , emptyPicture
9− , addToTop
10− , addToBottom
11− , picForImage
12− , picForLayers
13− , picImage
14− )
7+ )
15−where
8+ where
16
9
17import Graphics.Vty.Image
10import Graphics.Vty.Image
18−import Graphics.Vty.Attributes
19
11
20import Control.DeepSeq
12import Control.DeepSeq
21
13
22−-- | A Vty picture.
14+-- | The type of images to be displayed using 'update'.
23--
15--
24−-- These can be constructed directly or using `picForImage`.
16+-- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with
17+-- reasonable defaults for pic_cursor and pic_background.
25data Picture = Picture
18data Picture = Picture
26− { picCursor :: Cursor
19+ { pic_cursor :: Cursor
27− -- ^ The picture's cursor.
20+ , pic_layers :: [Image]
28− , picLayers :: [Image]
29− -- ^ The picture's image layers (top-most first).
30− , picBackground :: Background
21+ , pic_background :: Background
31− -- ^ The picture's background to be displayed in locations with no
22+ }
32− -- Image data.
33− } deriving Eq
34
23
35instance Show Picture where
24instance Show Picture where
36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
25 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -38,94 +27,79 @@ instance Show Picture where
38instance NFData Picture where
27instance NFData Picture where
39 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
28 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
40
29
41−-- | A picture with no cursor, background or image layers.
30+-- | a picture with no cursor, background or image layers
42−emptyPicture :: Picture
31+empty_picture :: Picture
43−emptyPicture = Picture NoCursor [] ClearBackground
32+empty_picture = Picture NoCursor [] ClearBackground
44
33
45−-- | Add an 'Image' as the top-most layer of a 'Picture'.
34+-- | The given 'Image' is added as the top layer of the 'Picture'
46−addToTop :: Picture -> Image -> Picture
35+add_to_top :: Picture -> Image -> Picture
47−addToTop p i = p {picLayers = i : picLayers p}
36+add_to_top p i = p {pic_layers = i : pic_layers p}
48
37
49−-- | Add an 'Image' as the bottom-most layer of a 'Picture'.
38+-- | The given 'Image' is added as the bottom layer of the 'Picture'
50−addToBottom :: Picture -> Image -> Picture
39+add_to_bottom :: Picture -> Image -> Picture
51−addToBottom p i = p {picLayers = picLayers p ++ [i]}
40+add_to_bottom p i = p {pic_layers = pic_layers p ++ [i]}
52
41
53−-- | Create a picture from the given image. The picture will not have a
42+-- | Create a picture for display for the given image. The picture will not have a displayed cursor
54−-- displayed cursor and no background pattern (ClearBackground) will be
43+-- and no background pattern (ClearBackground) will be used.
55−-- used.
56−picForImage :: Image -> Picture
44+pic_for_image :: Image -> Picture
57−picForImage i = Picture
45+pic_for_image i = Picture
58− { picCursor = NoCursor
46+ { pic_cursor = NoCursor
59− , picLayers = [i]
47+ , pic_layers = [i]
60− , picBackground = ClearBackground
48+ , pic_background = ClearBackground
61 }
49 }
62
50
63−-- | Create a picture with the given layers, top-most first.
51+-- | Create a picture for display with the given layers. Ordered top to bottom.
64--
52--
65−-- The picture will not have a displayed cursor and no background
53+-- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be
66−-- pattern (ClearBackgroun) will be used.
54+-- used.
55+--
56+-- The first 'Image' is the top layer.
67−picForLayers :: [Image] -> Picture
57+pic_for_layers :: [Image] -> Picture
68−picForLayers is = Picture
58+pic_for_layers is = Picture
69− { picCursor = NoCursor
59+ { pic_cursor = NoCursor
70− , picLayers = is
60+ , pic_layers = is
71− , picBackground = ClearBackground
61+ , pic_background = ClearBackground
72 }
62 }
73
63
74−-- | A picture can be configured to hide the cursor or to show the
64+-- | A picture can be configured either to not show the cursor or show the cursor at the specified
75−-- cursor at the specified character position.
65+-- character position.
76--
66--
77−-- There is not a 1:1 map from character positions to a row and column
67+-- There is not a 1 to 1 map from character positions to a row and column on the screen due to
78−-- on the screen due to characters that take more than 1 column.
68+-- characters that take more than 1 column.
69+--
70+-- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the
71+-- output region. In this case the cursor will not be shown.
79−data Cursor =
72+data Cursor =
80− -- | Hide the cursor
81− NoCursor
73+ 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
91− -- character width in the presence of multi-column characters.
92− | Cursor !Int !Int
74+ | Cursor Int Int
93− -- | Show the cursor at the given absolute terminal column and row
94− | AbsoluteCursor !Int !Int
95− deriving Eq
96
75
97instance NFData Cursor where
76instance NFData Cursor where
98− rnf c = c `seq` ()
77+ rnf NoCursor = ()
78+ rnf (Cursor w h) = w `seq` h `seq` ()
99
79
100−-- | A 'Picture' has a background pattern. The background is either:
80+-- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the
101−--
81+-- layer below or is blank if the bottom layer. Or the background pattern is a character and a
102−-- * ClearBackground, which shows the layer below or is blank if the
82+-- display attribute. If the display attribute used previously should be used for a background fill
103−-- bottom layer
83+-- then use `current_attr` for the background attribute.
104−-- * A character and a display attribute
105--
84--
106−-- If the display attribute used previously should be used for a
85+-- \todo The current attribute is always set to the default attributes at the start of updating the
107−-- background fill then use `currentAttr` for the background attribute.
86+-- screen to a picture.
108data Background
87data Background
109− = Background
88+ = Background
110− { backgroundChar :: Char
89+ { background_char :: Char
111− , backgroundAttr :: Attr
90+ , background_attr :: Attr
112 }
91 }
113− -- | A ClearBackground is:
92+ -- | A ClearBackground is:
114 --
93 --
115 -- * the space character if there are remaining non-skip ops
94 -- * the space character if there are remaining non-skip ops
116 --
95 --
117 -- * End of line if there are no remaining non-skip ops.
96 -- * End of line if there are no remaining non-skip ops.
118 | ClearBackground
97 | ClearBackground
119− deriving Eq
120
98
121instance NFData Background where
99instance NFData Background where
122 rnf (Background c a) = c `seq` a `seq` ()
100 rnf (Background c a) = c `seq` a `seq` ()
123 rnf ClearBackground = ()
101 rnf ClearBackground = ()
124
102
125−-- | Return the top-most 'Image' layer for a picture. This is unsafe for
126−-- 'Picture's without at least one layer.
127−--
128−-- This is provided for compatibility with applications that do not use
129−-- more than a single layer.
103+-- | Compatibility with applications that do not use more than a single layer.
130−picImage :: Picture -> Image
104+pic_image :: Picture -> Image
131−picImage = head . picLayers
105+pic_image = head . pic_layers
src/Graphics/Vty/PictureToSpans.hs+239−243
@@ -1,27 +1,27 @@
1-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
1-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE BangPatterns #-}
4{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE NamedFieldPuns #-}
6{-# LANGUAGE NamedFieldPuns #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE TemplateHaskell #-}
7−
8−-- | Transforms an image into rows of operations.
7+{- | Transforms an image into rows of operations.
8+ -}
9module Graphics.Vty.PictureToSpans where
9module Graphics.Vty.PictureToSpans where
10
10
11−import Graphics.Vty.Attributes (Attr, currentAttr)
11+import Graphics.Vty.Prelude
12+
12import Graphics.Vty.Image
13import Graphics.Vty.Image
13import Graphics.Vty.Image.Internal
14import Graphics.Vty.Image.Internal
14import Graphics.Vty.Picture
15import Graphics.Vty.Picture
15import Graphics.Vty.Span
16import Graphics.Vty.Span
16
17
17−import Lens.Micro
18+import Control.Lens hiding ( op )
18−import Lens.Micro.Mtl
19−import Lens.Micro.TH
20import Control.Monad.Reader
19import Control.Monad.Reader
21import Control.Monad.State.Strict hiding ( state )
20import Control.Monad.State.Strict hiding ( state )
22−import Control.Monad.ST.Strict
21+import Control.Monad.ST.Strict hiding ( unsafeIOToST )
23
22
24import qualified Data.Vector as Vector hiding ( take, replicate )
23import qualified Data.Vector as Vector hiding ( take, replicate )
24+import Data.Monoid (mappend)
25import Data.Vector.Mutable ( MVector(..))
25import Data.Vector.Mutable ( MVector(..))
26import qualified Data.Vector.Mutable as MVector
26import qualified Data.Vector.Mutable as MVector
27
27
@@ -33,259 +33,254 @@ type MSpanOps s = MVector s SpanOp
33
33
34-- transform plus clip. More or less.
34-- transform plus clip. More or less.
35data BlitState = BlitState
35data BlitState = BlitState
36− -- we always snoc to the operation vectors. Thus the columnOffset =
36+ -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset
37− -- length of row at rowOffset although, one possibility is to merge
38− -- layers right in snocOp (naming it something else, of course). In
37+ -- although, one possibility is to merge layers right in snoc_op (naming it something else, of
39− -- which case columnnOffset would be applicable. Right now we need
38+ -- course). In which case columnn_offset would be applicable.
40− -- it to exist.
39+ -- Right now we need it to exist.
41− { _columnOffset :: Int
40+ { _column_offset :: Int
42− , _rowOffset :: Int
41+ , _row_offset :: Int
43− -- clip coordinate space is in image space. Which means it's >= 0
42+ -- clip coordinate space is in image space. Which means it's >= 0 and < image_width.
44− -- and < imageWidth.
43+ , _skip_columns :: Int
45− , _skipColumns :: Int
44+ -- >= 0 and < image_height
46− -- >= 0 and < imageHeight
45+ , _skip_rows :: Int
47− , _skipRows :: Int
48− -- includes consideration of skipColumns. In display space. The
46+ -- includes consideration of skip_columns. In display space.
49− -- number of columns from the next column to be defined to the end
47+ -- The number of columns from the next column to be defined to the end of the display for the
50− -- of the display for the row.
48+ -- row.
51− , _remainingColumns :: Int
49+ , _remaining_columns :: Int
52− -- includes consideration of skipRows. In display space.
50+ -- includes consideration of skip_rows. In display space.
53− , _remainingRows :: Int
51+ , _remaining_rows :: Int
54 }
52 }
55
53
56makeLenses ''BlitState
54makeLenses ''BlitState
57
55
58data BlitEnv s = BlitEnv
56data BlitEnv s = BlitEnv
59 { _region :: DisplayRegion
57 { _region :: DisplayRegion
60− , _mrowOps :: MRowOps s
58+ , _mrow_ops :: MRowOps s
61 }
59 }
62
60
63makeLenses ''BlitEnv
61makeLenses ''BlitEnv
64
62
65type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
63type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
66
64
67−-- | Produces the span ops that will render the given picture, possibly
65+-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
68−-- cropped or padded, into the specified region.
66+-- specified region.
69−displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
67+display_ops_for_pic :: Picture -> DisplayRegion -> DisplayOps
70−displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
68+display_ops_for_pic pic r = Vector.create (combined_ops_for_layers pic r)
71
69
72−-- | Returns the DisplayOps for an image rendered to a window the size
70+-- | Returns the DisplayOps for an image rendered to a window the size of the image.
73−-- of the image.
74--
71--
75−-- largely used only for debugging.
72+-- largerly used only for debugging.
76−displayOpsForImage :: Image -> DisplayOps
73+display_ops_for_image :: Image -> DisplayOps
77−displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
74+display_ops_for_image i = display_ops_for_pic (pic_for_image i) (image_width i, image_height i)
78
75
79-- | Produces the span ops for each layer then combines them.
76-- | Produces the span ops for each layer then combines them.
77+--
78+-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
79+-- region.
80−combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
80+combined_ops_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)
81−combinedOpsForLayers pic r
81+combined_ops_for_layers pic r
82− | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
82+ | region_width r == 0 || region_height r == 0 = MVector.new 0
83 | otherwise = do
83 | otherwise = do
84− layerOps <- mapM (`buildSpans` r) (picLayers pic)
84+ layer_ops <- mapM (\layer -> build_spans layer r) (pic_layers pic)
85− case layerOps of
85+ case layer_ops of
86 [] -> fail "empty picture"
86 [] -> fail "empty picture"
87− [ops] -> substituteSkips (picBackground pic) ops
87+ [ops] -> substitute_skips (pic_background pic) ops
88− -- instead of merging ops after generation the merging can
88+ -- instead of merging ops after generation the merging can be performed as part of
89− -- be performed as part of snocOp.
89+ -- snoc_op.
90− topOps : lowerOps -> do
90+ top_ops : lower_ops -> do
91− ops <- foldM mergeUnder topOps lowerOps
91+ ops <- foldM merge_under top_ops lower_ops
92− substituteSkips (picBackground pic) ops
92+ substitute_skips (pic_background pic) ops
93
93
94−substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)
94+substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)
95−substituteSkips ClearBackground ops = do
95+substitute_skips ClearBackground ops = do
96 forM_ [0 .. MVector.length ops - 1] $ \row -> do
96 forM_ [0 .. MVector.length ops - 1] $ \row -> do
97− rowOps <- MVector.read ops row
97+ row_ops <- MVector.read ops row
98− -- the image operations assure that background fills are
98+ -- the image operations assure that background fills are combined.
99− -- combined. clipping a background fill does not split the
99+ -- clipping a background fill does not split the background fill.
100− -- background fill. merging of image layers can split a skip,
100+ -- merging of image layers can split a skip, but only by the insertion of a non skip.
101− -- but only by the insertion of a non skip. all this combines to
102− -- mean we can check the last operation and remove it if it's a
101+ -- all this combines to mean we can check the last operation and remove it if it's a skip
103− -- skip
102+ -- todo: or does it?
104− let rowOps' = case Vector.last rowOps of
103+ let row_ops' = case Vector.last row_ops of
105− Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w
104+ Skip w -> Vector.init row_ops `Vector.snoc` RowEnd w
106− _ -> rowOps
105+ _ -> row_ops
107− -- now all the skips can be replaced by replications of ' ' of
106+ -- now all the skips can be replaced by replications of ' ' of the required width.
108− -- the required width.
107+ let row_ops'' = swap_skips_for_single_column_char_span ' ' current_attr row_ops'
109− let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'
110− MVector.write ops row rowOps''
108+ MVector.write ops row row_ops''
111 return ops
109 return ops
112−substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do
110+substitute_skips (Background {background_char, background_attr}) ops = do
113− -- At this point we decide if the background character is single
111+ -- At this point we decide if the background character is single column or not.
114− -- column or not. obviously, single column is easier.
112+ -- obviously, single column is easier.
115− case safeWcwidth backgroundChar of
113+ case safe_wcwidth background_char of
116− w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar
114+ w | w == 0 -> fail $ "invalid background character " ++ show background_char
117 | w == 1 -> do
115 | w == 1 -> do
118 forM_ [0 .. MVector.length ops - 1] $ \row -> do
116 forM_ [0 .. MVector.length ops - 1] $ \row -> do
119− rowOps <- MVector.read ops row
117+ row_ops <- MVector.read ops row
120− let rowOps' = swapSkipsForSingleColumnCharSpan backgroundChar backgroundAttr rowOps
118+ let row_ops' = swap_skips_for_single_column_char_span background_char background_attr row_ops
121− MVector.write ops row rowOps'
119+ MVector.write ops row row_ops'
122 | otherwise -> do
120 | otherwise -> do
123 forM_ [0 .. MVector.length ops - 1] $ \row -> do
121 forM_ [0 .. MVector.length ops - 1] $ \row -> do
124− rowOps <- MVector.read ops row
122+ row_ops <- MVector.read ops row
125− let rowOps' = swapSkipsForCharSpan w backgroundChar backgroundAttr rowOps
123+ let row_ops' = swap_skips_for_char_span w background_char background_attr row_ops
126− MVector.write ops row rowOps'
124+ MVector.write ops row row_ops'
127 return ops
125 return ops
128
126
129−mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s)
127+merge_under :: MRowOps s -> MRowOps s -> ST s (MRowOps s)
130−mergeUnder upper lower = do
128+merge_under upper lower = do
131 forM_ [0 .. MVector.length upper - 1] $ \row -> do
129 forM_ [0 .. MVector.length upper - 1] $ \row -> do
132− upperRowOps <- MVector.read upper row
130+ upper_row_ops <- MVector.read upper row
133− lowerRowOps <- MVector.read lower row
131+ lower_row_ops <- MVector.read lower row
134− let rowOps = mergeRowUnder upperRowOps lowerRowOps
132+ let row_ops = merge_row_under upper_row_ops lower_row_ops
135− MVector.write upper row rowOps
133+ MVector.write upper row row_ops
136 return upper
134 return upper
137
135
136+-- fugly
138−mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
137+merge_row_under :: SpanOps -> SpanOps -> SpanOps
139−mergeRowUnder upperRowOps =
138+merge_row_under upper_row_ops lower_row_ops =
140− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)
139+ on_upper_op Vector.empty (Vector.head upper_row_ops) (Vector.tail upper_row_ops) lower_row_ops
141 where
140 where
142− -- H: it will never be the case that we are out of upper ops
141+ -- H: it will never be the case that we are out of upper ops before lower ops.
143− -- before lower ops.
144− onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
142+ on_upper_op :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
145− onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =
143+ on_upper_op out_ops op@(TextSpan _ w _ _) upper_ops lower_ops =
146− let lowerOps' = dropOps w lowerOps
144+ let lower_ops' = drop_ops w lower_ops
147− outOps' = Vector.snoc outOps op
145+ out_ops' = Vector.snoc out_ops op
148− in if Vector.null lowerOps'
146+ in if Vector.null lower_ops'
149− then outOps'
147+ then out_ops'
150− else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps'
148+ else on_upper_op out_ops' (Vector.head upper_ops) (Vector.tail upper_ops) lower_ops'
151− onUpperOp outOps (Skip w) upperOps lowerOps =
149+ on_upper_op out_ops (Skip w) upper_ops lower_ops =
152− let (ops', lowerOps') = splitOpsAt w lowerOps
150+ let (ops', lower_ops') = split_ops_at w lower_ops
153− outOps' = outOps `mappend` ops'
151+ out_ops' = out_ops `mappend` ops'
154− in if Vector.null lowerOps'
152+ in if Vector.null lower_ops'
155− then outOps'
153+ then out_ops'
156− else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps'
154+ else on_upper_op out_ops' (Vector.head upper_ops) (Vector.tail upper_ops) lower_ops'
157− onUpperOp _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops"
155+ on_upper_op _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops"
158
156
159
157
160−swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps
158+swap_skips_for_single_column_char_span :: Char -> Attr -> SpanOps -> SpanOps
161−swapSkipsForSingleColumnCharSpan c a = Vector.map f
159+swap_skips_for_single_column_char_span c a = Vector.map f
162 where f (Skip ow) = let txt = TL.pack $ replicate ow c
160 where f (Skip ow) = let txt = TL.pack $ replicate ow c
163 in TextSpan a ow ow txt
161 in TextSpan a ow ow txt
164 f v = v
162 f v = v
165
163
166−swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps
164+swap_skips_for_char_span :: Int -> Char -> Attr -> SpanOps -> SpanOps
167−swapSkipsForCharSpan w c a = Vector.map f
165+swap_skips_for_char_span w c a = Vector.map f
168 where
166 where
169− f (Skip ow) = let txt0Cw = ow `div` w
167+ f (Skip ow) = let txt_0_cw = ow `div` w
170− txt0 = TL.pack $ replicate txt0Cw c
168+ txt_0 = TL.pack $ replicate txt_0_cw c
171− txt1Cw = ow `mod` w
169+ txt_1_cw = ow `mod` w
172− txt1 = TL.pack $ replicate txt1Cw '…'
170+ txt_1 = TL.pack $ replicate txt_1_cw '…'
173− cw = txt0Cw + txt1Cw
171+ cw = txt_0_cw + txt_1_cw
174− txt = txt0 `TL.append` txt1
172+ txt = txt_0 `TL.append` txt_1
175 in TextSpan a ow cw txt
173 in TextSpan a ow cw txt
176 f v = v
174 f v = v
177
175
178−-- | Builds a vector of row operations that will output the given
176+-- | Builds a vector of row operations that will output the given picture to the terminal.
179−-- picture to the terminal.
180--
177--
181-- Crops to the given display region.
178-- Crops to the given display region.
179+--
180+-- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer.
182−buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
181+build_spans :: Image -> DisplayRegion -> ST s (MRowOps s)
183−buildSpans image outRegion = do
182+build_spans image out_region = do
184 -- First we create a mutable vector for each rows output operations.
183 -- First we create a mutable vector for each rows output operations.
185− outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
184+ out_ops <- MVector.replicate (region_height out_region) Vector.empty
186− -- It's possible that building the span operations in display order
185+ -- \todo I think building the span operations in display order would provide better performance.
187− -- would provide better performance.
186+ -- However, I got stuck trying to implement an algorithm that did this. This will be considered
187+ -- as a possible future optimization.
188 --
188 --
189− -- A depth first traversal of the image is performed. ordered
189+ -- A depth first traversal of the image is performed. ordered according to the column range
190− -- according to the column range defined by the image from least
191− -- to greatest. The output row ops will at least have the region
190+ -- defined by the image from least to greatest. The output row ops will at least have the
192− -- of the image specified. Iterate over all output rows and output
191+ -- region of the image specified. Iterate over all output rows and output background fills for
193− -- background fills for all unspecified columns.
192+ -- all unspecified columns.
194 --
193 --
195− -- The images are made into span operations from left to right. It's
194+ -- The images are made into span operations from left to right. It's possible that this could
196− -- possible that this could easily be made to assure top to bottom
195+ -- easily be made to assure top to bottom output as well.
197− -- output as well.
196+ when (region_height out_region > 0 && region_width out_region > 0) $ do
198− when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do
199− -- The ops builder recursively descends the image and outputs
197+ -- The ops builder recursively descends the image and outputs span ops that would
200− -- span ops that would display that image. The number of columns
201− -- remaining in this row before exceeding the bounds is also
198+ -- display that image. The number of columns remaining in this row before exceeding the
202− -- provided. This is used to clip the span ops produced to the
199+ -- bounds is also provided. This is used to clip the span ops produced to the display.
203− -- display.
200+ let full_build = do
204− let fullBuild = do
201+ start_image_build image
205− startImageBuild image
206 -- Fill in any unspecified columns with a skip.
202 -- Fill in any unspecified columns with a skip.
207− forM_ [0 .. (regionHeight outRegion - 1)] (addRowCompletion outRegion)
203+ forM_ [0 .. (region_height out_region - 1)] (add_row_completion out_region)
208− initEnv = BlitEnv outRegion outOps
204+ init_env = BlitEnv out_region out_ops
209− initState = BlitState 0 0 0 0 (regionWidth outRegion) (regionHeight outRegion)
205+ init_state = BlitState 0 0 0 0 (region_width out_region) (region_height out_region)
210− _ <- runStateT (runReaderT fullBuild initEnv) initState
206+ _ <- runStateT (runReaderT full_build init_env) init_state
211 return ()
207 return ()
212− return outOps
208+ return out_ops
213
209
214−-- | Add the operations required to build a given image to the current
210+-- | Add the operations required to build a given image to the current set of row operations
215−-- set of row operations.
211+-- returns the number of columns and rows contributed to the output.
216−startImageBuild :: Image -> BlitM s ()
212+start_image_build :: Image -> BlitM s ()
217−startImageBuild image = do
213+start_image_build image = do
218− outOfBounds <- isOutOfBounds image <$> get
214+ out_of_bounds <- is_out_of_bounds image <$> get
219− when (not outOfBounds) $ addMaybeClipped image
215+ when (not out_of_bounds) $ add_maybe_clipped image
220
216
221−isOutOfBounds :: Image -> BlitState -> Bool
217+is_out_of_bounds :: Image -> BlitState -> Bool
222−isOutOfBounds i s
218+is_out_of_bounds i s
223− | s ^. remainingColumns <= 0 = True
219+ | s ^. remaining_columns <= 0 = True
224− | s ^. remainingRows <= 0 = True
220+ | s ^. remaining_rows <= 0 = True
225− | s ^. skipColumns >= imageWidth i = True
221+ | s ^. skip_columns >= image_width i = True
226− | s ^. skipRows >= imageHeight i = True
222+ | s ^. skip_rows >= image_height i = True
227 | otherwise = False
223 | otherwise = False
228
224
229−-- | This adds an image that might be partially clipped to the output
225+-- | This adds an image that might be partially clipped to the output ops.
230−-- ops.
226+--
227+-- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom
228+-- implementations are odd. They pass the current tests but something seems terribly wrong about all
229+-- this.
231--
230--
232−-- This is a very touchy algorithm. Too touchy. For instance, the
231+-- \todo prove this cannot be called in an out of bounds case.
233−-- CropRight and CropBottom implementations are odd. They pass the
234−-- current tests but something seems terribly wrong about all this.
235−addMaybeClipped :: forall s . Image -> BlitM s ()
232+add_maybe_clipped :: forall s . Image -> BlitM s ()
236−addMaybeClipped EmptyImage = return ()
233+add_maybe_clipped EmptyImage = return ()
237−addMaybeClipped (HorizText a textStr ow _cw) = do
234+add_maybe_clipped (HorizText a text_str ow _cw) = do
238− -- This assumes that text spans are only 1 row high.
235+ -- TODO: assumption that text spans are only 1 row high.
239− s <- use skipRows
236+ s <- use skip_rows
240 when (s < 1) $ do
237 when (s < 1) $ do
241− leftClip <- use skipColumns
238+ left_clip <- use skip_columns
242− rightClip <- use remainingColumns
239+ right_clip <- use remaining_columns
243− let leftClipped = leftClip > 0
240+ let left_clipped = left_clip > 0
244− rightClipped = (ow - leftClip) > rightClip
241+ right_clipped = (ow - left_clip) > right_clip
245− if leftClipped || rightClipped
242+ if left_clipped || right_clipped
246− then let textStr' = clipText textStr leftClip rightClip
243+ then let text_str' = clip_text text_str left_clip right_clip
247− in addUnclippedText a textStr'
244+ in add_unclipped_text a text_str'
248− else addUnclippedText a textStr
245+ else add_unclipped_text a text_str
249−addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do
246+add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do
250− when (imageHeight topImage + imageHeight bottomImage > 0) $
247+ add_maybe_clipped_join "vert_join" skip_rows remaining_rows row_offset
251− addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset
248+ (image_height top_image)
252− (imageHeight topImage)
249+ top_image
253− topImage
250+ bottom_image
254− bottomImage
255− oh
251+ oh
256−addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do
252+add_maybe_clipped (HorizJoin left_image right_image ow _oh) = do
257− when (imageWidth leftImage + imageWidth rightImage > 0) $
253+ add_maybe_clipped_join "horiz_join" skip_columns remaining_columns column_offset
258− addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset
254+ (image_width left_image)
259− (imageWidth leftImage)
255+ left_image
260− leftImage
256+ right_image
261− rightImage
262− ow
257+ ow
263−addMaybeClipped BGFill {outputWidth, outputHeight} = do
258+add_maybe_clipped BGFill {output_width, output_height} = do
264 s <- get
259 s <- get
265− let outputWidth' = min (outputWidth - s^.skipColumns) (s^.remainingColumns)
260+ let output_width' = min (output_width - s^.skip_columns) (s^.remaining_columns)
266− outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows)
261+ output_height' = min (output_height - s^.skip_rows ) (s^.remaining_rows)
267− y <- use rowOffset
262+ y <- use row_offset
268− forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth')
263+ forM_ [y..y+output_height'-1] $ snoc_op (Skip output_width')
269−addMaybeClipped CropRight {croppedImage, outputWidth} = do
264+add_maybe_clipped CropRight {cropped_image, output_width} = do
270− s <- use skipColumns
265+ s <- use skip_columns
271− r <- use remainingColumns
266+ r <- use remaining_columns
272− let x = outputWidth - s
267+ let x = output_width - s
273− when (x < r) $ remainingColumns .= x
268+ when (x < r) $ remaining_columns .= x
274− addMaybeClipped croppedImage
269+ add_maybe_clipped cropped_image
275−addMaybeClipped CropLeft {croppedImage, leftSkip} = do
270+add_maybe_clipped CropLeft {cropped_image, left_skip} = do
276− skipColumns += leftSkip
271+ skip_columns += left_skip
277− addMaybeClipped croppedImage
272+ add_maybe_clipped cropped_image
278−addMaybeClipped CropBottom {croppedImage, outputHeight} = do
273+add_maybe_clipped CropBottom {cropped_image, output_height} = do
279− s <- use skipRows
274+ s <- use skip_rows
280− r <- use remainingRows
275+ r <- use remaining_rows
281− let x = outputHeight - s
276+ let x = output_height - s
282− when (x < r) $ remainingRows .= x
277+ when (x < r) $ remaining_rows .= x
283− addMaybeClipped croppedImage
278+ add_maybe_clipped cropped_image
284−addMaybeClipped CropTop {croppedImage, topSkip} = do
279+add_maybe_clipped CropTop {cropped_image, top_skip} = do
285− skipRows += topSkip
280+ skip_rows += top_skip
286− addMaybeClipped croppedImage
281+ add_maybe_clipped cropped_image
287
282
288−addMaybeClippedJoin :: forall s . String
283+add_maybe_clipped_join :: forall s . String
289 -> Lens BlitState BlitState Int Int
284 -> Lens BlitState BlitState Int Int
290 -> Lens BlitState BlitState Int Int
285 -> Lens BlitState BlitState Int Int
291 -> Lens BlitState BlitState Int Int
286 -> Lens BlitState BlitState Int Int
@@ -294,55 +289,56 @@ addMaybeClippedJoin :: forall s . String
294 -> Image
289 -> Image
295 -> Int
290 -> Int
296 -> BlitM s ()
291 -> BlitM s ()
297−addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
292+add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
298 state <- get
293 state <- get
299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
294 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
300 case state^.skip of
295 case state^.skip of
301− s | s > size -> put $ state & skip %~ subtract size
296+ s -- TODO: check if clipped in other dim. if not use add_unclipped
297+ | s >= size -> fail $ name ++ " on fully clipped"
302− | s == 0 -> if state^.remaining > i0Dim
298+ | s == 0 -> if state^.remaining > i0_dim
303 then do
299 then do
304− addMaybeClipped i0
300+ add_maybe_clipped i0
305− put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim
301+ put $ state & offset +~ i0_dim & remaining -~ i0_dim
306− addMaybeClipped i1
302+ add_maybe_clipped i1
307− else addMaybeClipped i0
303+ else add_maybe_clipped i0
308− | s < i0Dim ->
304+ | s < i0_dim ->
309− let i0Dim' = i0Dim - s
305+ let i0_dim' = i0_dim - s
310− in if state^.remaining <= i0Dim'
306+ in if state^.remaining <= i0_dim'
311− then addMaybeClipped i0
307+ then add_maybe_clipped i0
312 else do
308 else do
313− addMaybeClipped i0
309+ add_maybe_clipped i0
314− put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0
310+ put $ state & offset +~ i0_dim' & remaining -~ i0_dim' & skip .~ 0
315− addMaybeClipped i1
311+ add_maybe_clipped i1
316− | s >= i0Dim -> do
312+ | s >= i0_dim -> do
317− put $ state & skip %~ subtract i0Dim
313+ put $ state & skip -~ i0_dim
318− addMaybeClipped i1
314+ add_maybe_clipped i1
319 _ -> fail $ name ++ " has unhandled skip class"
315 _ -> fail $ name ++ " has unhandled skip class"
320
316
321−addUnclippedText :: Attr -> DisplayText -> BlitM s ()
317+add_unclipped_text :: Attr -> DisplayText -> BlitM s ()
322−addUnclippedText a txt = do
318+add_unclipped_text a txt = do
323− let op = TextSpan a usedDisplayColumns
319+ let op = TextSpan a used_display_columns
324 (fromIntegral $ TL.length txt)
320 (fromIntegral $ TL.length txt)
325 txt
321 txt
326− usedDisplayColumns = wctlwidth txt
322+ used_display_columns = wcswidth $ TL.unpack txt
327− use rowOffset >>= snocOp op
323+ use row_offset >>= snoc_op op
328
324
329−addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
325+add_row_completion :: DisplayRegion -> Int -> BlitM s ()
330−addRowCompletion displayRegion row = do
326+add_row_completion display_region row = do
331− allRowOps <- view mrowOps
327+ all_row_ops <- view mrow_ops
332− rowOps <- lift $ lift $ MVector.read allRowOps row
328+ row_ops <- lift $ lift $ MVector.read all_row_ops row
333− let endX = spanOpsAffectedColumns rowOps
329+ let end_x = span_ops_effected_columns row_ops
334− when (endX < regionWidth displayRegion) $ do
330+ when (end_x < region_width display_region) $ do
335− let ow = regionWidth displayRegion - endX
331+ let ow = region_width display_region - end_x
336− snocOp (Skip ow) row
332+ snoc_op (Skip ow) row
337
333
338-- | snocs the operation to the operations for the given row.
334-- | snocs the operation to the operations for the given row.
339−snocOp :: SpanOp -> Int -> BlitM s ()
335+snoc_op :: SpanOp -> Int -> BlitM s ()
340−snocOp !op !row = do
336+snoc_op !op !row = do
341− theMrowOps <- view mrowOps
337+ the_mrow_ops <- view mrow_ops
342− theRegion <- view region
338+ the_region <- view region
343 lift $ lift $ do
339 lift $ lift $ do
344− ops <- MVector.read theMrowOps row
340+ ops <- MVector.read the_mrow_ops row
345 let ops' = Vector.snoc ops op
341 let ops' = Vector.snoc ops op
346− when (spanOpsAffectedColumns ops' > regionWidth theRegion)
342+ when (span_ops_effected_columns ops' > region_width the_region)
347 $ fail $ "row " ++ show row ++ " now exceeds region width"
343 $ fail $ "row " ++ show row ++ " now exceeds region width"
348− MVector.write theMrowOps row ops'
344+ MVector.write the_mrow_ops row ops'
src/Graphics/Vty/Prelude.hsnew file+18
@@ -0,0 +1,18 @@
1+-- | Prelude for Vty modules. Not particularly useful outside of Vty.
2+module Graphics.Vty.Prelude ( module Graphics.Vty.Prelude
3+ , module Control.Applicative
4+ , module Control.Monad
5+ )
6+where
7+
8+import Control.Applicative hiding ((<|>))
9+import Control.Monad
10+
11+-- | Named alias for a Int pair
12+type DisplayRegion = (Int,Int)
13+
14+region_width :: DisplayRegion -> Int
15+region_width = fst
16+
17+region_height :: DisplayRegion -> Int
18+region_height = snd
src/Graphics/Vty/Span.hs+97−88
@@ -1,89 +1,97 @@
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 character spans.
4−-- character spans. The attribute is applied to all following spans,
6+ - State changes are currently limited to new attribute values. The attribute is applied to all
5−-- including spans of the next row. The nth element of the sequence
7+ - following spans. Including spans of the next row. The nth element of the sequence represents the
6−-- represents the nth row (from top to bottom) of the picture to render.
8+ - nth row (from top to bottom) of the picture to render.
7−--
9+ -
8−-- A span op sequence will be defined for all rows and columns (and no
10+ - A span op sequence will be defined for all rows and columns (and no more) of the region provided
9−-- more) of the region provided with the picture to 'spansForPic'.
11+ - with the picture to spans_for_pic.
12+ -
13+ - todo: Partition attribute changes into multiple categories according to the serialized
14+ - representation of the various attributes.
15+ -}
10−module Graphics.Vty.Span where
16+module Graphics.Vty.Span
17+ where
18+
19+import Graphics.Vty.Prelude
11
20
12−import Graphics.Vty.Attributes (Attr)
13import Graphics.Vty.Image
21import Graphics.Vty.Image
14−import Graphics.Vty.Image.Internal ( clipText )
22+import Graphics.Vty.Image.Internal ( clip_text )
15
23
16import qualified Data.Text.Lazy as TL
24import qualified Data.Text.Lazy as TL
17import Data.Vector (Vector)
25import Data.Vector (Vector)
18import qualified Data.Vector as Vector
26import qualified Data.Vector as Vector
19
27
20−-- | This represents an operation on the terminal: either an attribute
28+-- | This represents an operation on the terminal. Either an attribute change or the output of a
21−-- change or the output of a text string.
29+-- text string.
22data SpanOp =
30data SpanOp =
23− -- | A span of UTF-8 text occupies a specific number of screen space
31+ -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
24− -- columns. A single UTF character does not necessarily represent 1
32+ -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width
25− -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width
33+ -- TextSpan [Attr] [output width in columns] [number of characters] [data]
26− -- in columns] [number of characters] [data]
34+ TextSpan
27− TextSpan
35+ { text_span_attr :: !Attr
28− { textSpanAttr :: !Attr
36+ , text_span_output_width :: !Int
29− , textSpanOutputWidth :: !Int
37+ , text_span_char_width :: !Int
30− , textSpanCharWidth :: !Int
38+ , text_span_text :: DisplayText
31− , textSpanText :: DisplayText
32 }
39 }
33− -- | Skips the given number of columns.
40+ -- | Skips the given number of columns
41+ -- A skip is transparent.... maybe? I am not sure how attribute changes interact.
42+ -- todo: separate from this type.
34 | Skip !Int
43 | Skip !Int
35− -- | Marks the end of a row. Specifies how many columns are
44+ -- | Marks the end of a row. specifies how many columns are remaining. These columns will not be
36− -- remaining. These columns will not be explicitly overwritten with
45+ -- explicitly overwritten with the span ops. The terminal is require to assure the remaining
37− -- the span ops. The terminal is require to assure the remaining
38 -- columns are clear.
46 -- columns are clear.
47+ -- todo: separate from this type.
39 | RowEnd !Int
48 | RowEnd !Int
40 deriving Eq
49 deriving Eq
41
50
42−-- | A vector of span operations executed in succession. This represents
51+-- | vector of span operations. executed in succession. This represents the operations required to
43−-- the operations required to render a row of the terminal. The
52+-- render a row of the terminal. The operations in one row may effect subsequent rows.
44−-- operations in one row may affect subsequent rows. For example,
53+-- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground
45−-- setting the foreground color in one row will affect all subsequent
54+-- color is changed.
46−-- rows until the foreground color is changed.
47type SpanOps = Vector SpanOp
55type SpanOps = Vector SpanOp
48
56
49−dropOps :: Int -> SpanOps -> SpanOps
57+drop_ops :: Int -> SpanOps -> SpanOps
50−dropOps w = snd . splitOpsAt w
58+drop_ops w = snd . split_ops_at w
51
59
52−splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
60+split_ops_at :: Int -> SpanOps -> (SpanOps, SpanOps)
53−splitOpsAt = splitOpsAt'
61+split_ops_at in_w in_ops = split_ops_at' in_w in_ops
54 where
62 where
55− splitOpsAt' 0 ops = (Vector.empty, ops)
63+ split_ops_at' 0 ops = (Vector.empty, ops)
56− splitOpsAt' remainingColumns ops = case Vector.head ops of
64+ split_ops_at' remaining_columns ops = case Vector.head ops of
57− t@(TextSpan {}) -> if remainingColumns >= textSpanOutputWidth t
65+ t@(TextSpan {}) -> if remaining_columns >= text_span_output_width t
58− then let (pre,post) = splitOpsAt' (remainingColumns - textSpanOutputWidth t)
66+ then let (pre,post) = split_ops_at' (remaining_columns - text_span_output_width t)
59− (Vector.tail ops)
67+ (Vector.tail ops)
60 in (Vector.cons t pre, post)
68 in (Vector.cons t pre, post)
61− else let preTxt = clipText (textSpanText t) 0 remainingColumns
69+ else let pre_txt = clip_text (text_span_text t) 0 remaining_columns
62− preOp = TextSpan { textSpanAttr = textSpanAttr t
70+ pre_op = TextSpan { text_span_attr = text_span_attr t
63− , textSpanOutputWidth = remainingColumns
71+ , text_span_output_width = remaining_columns
64− , textSpanCharWidth = fromIntegral $! TL.length preTxt
72+ , text_span_char_width = fromIntegral $! TL.length pre_txt
65− , textSpanText = preTxt
73+ , text_span_text = pre_txt
66 }
74 }
67− postWidth = textSpanOutputWidth t - remainingColumns
75+ post_width = text_span_output_width t - remaining_columns
68− postTxt = clipText (textSpanText t) remainingColumns postWidth
76+ post_txt = clip_text (text_span_text t) remaining_columns post_width
69− postOp = TextSpan { textSpanAttr = textSpanAttr t
77+ post_op = TextSpan { text_span_attr = text_span_attr t
70− , textSpanOutputWidth = postWidth
78+ , text_span_output_width = post_width
71− , textSpanCharWidth = fromIntegral $! TL.length postTxt
79+ , text_span_char_width = fromIntegral $! TL.length post_txt
72− , textSpanText = postTxt
80+ , text_span_text = post_txt
73 }
81 }
74− in ( Vector.singleton preOp
82+ in ( Vector.singleton pre_op
75− , Vector.cons postOp (Vector.tail ops)
83+ , Vector.cons post_op (Vector.tail ops)
76 )
84 )
77− Skip w -> if remainingColumns >= w
85+ Skip w -> if remaining_columns >= w
78− then let (pre,post) = splitOpsAt' (remainingColumns - w) (Vector.tail ops)
86+ then let (pre,post) = split_ops_at' (remaining_columns - w) (Vector.tail ops)
79 in (Vector.cons (Skip w) pre, post)
87 in (Vector.cons (Skip w) pre, post)
80− else ( Vector.singleton $ Skip remainingColumns
88+ else ( Vector.singleton $ Skip remaining_columns
81− , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops)
89+ , Vector.cons (Skip (w - remaining_columns)) (Vector.tail ops)
82 )
90 )
83 RowEnd _ -> error "cannot split ops containing a row end"
91 RowEnd _ -> error "cannot split ops containing a row end"
92+
84
93
85−-- | A vector of span operation vectors for display, one per row of the
94+-- | vector of span operation vectors for display. One per row of the output region.
86−-- output region.
87type DisplayOps = Vector SpanOps
95type DisplayOps = Vector SpanOps
88
96
89instance Show SpanOp where
97instance Show SpanOp where
@@ -91,39 +99,40 @@ instance Show SpanOp where
91 show (Skip ow) = "Skip(" ++ show ow ++ ")"
99 show (Skip ow) = "Skip(" ++ show ow ++ ")"
92 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
100 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
93
101
94−-- | The number of columns the DisplayOps are defined for.
102+-- | Number of columns the DisplayOps are defined for
95--
103--
96−-- All spans are verified to define same number of columns.
104+-- All spans are verified to define same number of columns. See: VerifySpanOps
97−displayOpsColumns :: DisplayOps -> Int
105+display_ops_columns :: DisplayOps -> Int
98−displayOpsColumns ops
106+display_ops_columns ops
99 | Vector.length ops == 0 = 0
107 | Vector.length ops == 0 = 0
100 | otherwise = Vector.length $ Vector.head ops
108 | otherwise = Vector.length $ Vector.head ops
101
109
102−-- | The number of rows the DisplayOps are defined for.
110+-- | Number of rows the DisplayOps are defined for
103−displayOpsRows :: DisplayOps -> Int
111+display_ops_rows :: DisplayOps -> Int
104−displayOpsRows = Vector.length
112+display_ops_rows ops = Vector.length ops
105
113
106−affectedRegion :: DisplayOps -> DisplayRegion
114+effected_region :: DisplayOps -> DisplayRegion
107−affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
115+effected_region ops = (display_ops_columns ops, display_ops_rows ops)
116+
117+-- | The number of columns a SpanOps effects.
118+span_ops_effected_columns :: SpanOps -> Int
119+span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops
120+ where
121+ span_ops_effected_columns' t (TextSpan _ w _ _ ) = t + w
122+ span_ops_effected_columns' t (Skip w) = t + w
123+ span_ops_effected_columns' t (RowEnd w) = t + w
124+
125+-- | The width of a single SpanOp in columns
126+span_op_has_width :: SpanOp -> Maybe (Int, Int)
127+span_op_has_width (TextSpan _ ow cw _) = Just (cw, ow)
128+span_op_has_width (Skip ow) = Just (ow,ow)
129+span_op_has_width (RowEnd ow) = Just (ow,ow)
130+
131+-- | returns the number of columns to the character at the given position in the span op
132+columns_to_char_offset :: Int -> SpanOp -> Int
133+columns_to_char_offset cx (TextSpan _ _ _ utf8_str) =
134+ let str = TL.unpack utf8_str
135+ in wcswidth (take cx str)
136+columns_to_char_offset cx (Skip _) = cx
137+columns_to_char_offset cx (RowEnd _) = cx
108
138
109−-- | The number of columns a SpanOps affects.
110−spanOpsAffectedColumns :: SpanOps -> Int
111−spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps
112− where
113− spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w
114− spanOpsAffectedColumns' t (Skip w) = t + w
115− spanOpsAffectedColumns' t (RowEnd w) = t + w
116−
117−-- | The width of a single SpanOp in columns.
118−spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
119−spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
120−spanOpHasWidth (Skip ow) = Just (ow,ow)
121−spanOpHasWidth (RowEnd ow) = Just (ow,ow)
122−
123−-- | The number of columns to the character at the given position in the
124−-- span op.
125−columnsToCharOffset :: Int -> SpanOp -> Int
126−columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
127− wctlwidth (TL.take (fromIntegral cx) utf8Str)
128−columnsToCharOffset cx (Skip _) = cx
129−columnsToCharOffset cx (RowEnd _) = cx
src/Graphics/Vty/UnicodeWidthTable/IO.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−module Graphics.Vty.UnicodeWidthTable.IO
3− ( readUnicodeWidthTable
4− , parseUnicodeWidthTable
5− , writeUnicodeWidthTable
6− )
7−where
8−
9−import Control.Monad (when, forM)
10−import Data.Binary
11−import Data.Binary.Get
12−import Data.Binary.Put
13−import qualified Data.ByteString.Lazy as BSL
14−#if !(MIN_VERSION_base(4,11,0))
15−import Data.Semigroup ((<>))
16−#endif
17−
18−import Graphics.Vty.UnicodeWidthTable.Types
19−
20−-- | Load a binary unicode width table from the specified file.
21−--
22−-- This either returns a successfully parsed table or a table parsing
23−-- error message. This does not handle I/O exceptions.
24−readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)
25−readUnicodeWidthTable path = parseUnicodeWidthTable <$> BSL.readFile path
26−
27−-- | Parse a binary unicode width table.
28−parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable
29−parseUnicodeWidthTable bs =
30− case runGetOrFail tableParser bs of
31− Left (_, _, msg) ->
32− Left msg
33−
34− -- Even if we parsed a table, leftover bytes indicate something
35− -- could be wrong.
36− Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->
37− Left $ "Error: " <> show (BSL.length remainingBytes) <>
38− " byte(s) left unconsumed"
39−
40− Right (_, _, table) ->
41− Right table
42−
43−-- | Write the unicode width table to the specified path.
44−--
45−-- This does not handle I/O exceptions.
46−writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
47−writeUnicodeWidthTable path table = do
48− let body = runPut (tableV1Writer table)
49− BSL.writeFile path body
50−
51−-- | Width table magic bytes for use in the binary format.
52−widthTableMagic :: Word32
53−widthTableMagic = 0xc1a9f7e0
54−
55−tableParser :: Get UnicodeWidthTable
56−tableParser = do
57− magic <- getWord32le
58−
59− when (magic /= widthTableMagic) $
60− fail "Table magic number invalid"
61−
62− version <- getWord8
63−
64− case version of
65− 1 -> tableV1Parser
66− _ -> fail "Table version invalid"
67−
68−tableV1Parser :: Get UnicodeWidthTable
69−tableV1Parser = do
70− numRanges <- getWord32le
71−
72− let parseRange = do
73− start <- getWord32le
74− size <- getWord32le
75− cols <- getWord8
76− return WidthTableRange { rangeStart = start
77− , rangeSize = size
78− , rangeColumns = cols
79− }
80−
81− ranges <- forM [1..numRanges] $ const parseRange
82−
83− return UnicodeWidthTable { unicodeWidthTableRanges = ranges
84− }
85−
86−tableV1Writer :: UnicodeWidthTable -> Put
87−tableV1Writer table = do
88− -- Magic bytes
89− putWord32le widthTableMagic
90−
91− -- Version
92− putWord8 1
93−
94− -- Number of ranges
95− let ranges = unicodeWidthTableRanges table
96− let numRanges = length ranges
97− putWord32le (fromIntegral numRanges)
98−
99− -- Ranges
100− let putRange r = do
101− putWord32le $ rangeStart r
102− putWord32le $ rangeSize r
103− putWord8 $ rangeColumns r
104−
105− mapM_ putRange ranges
src/Graphics/Vty/UnicodeWidthTable/Install.hsdeleted−129
@@ -1,129 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ForeignFunctionInterface #-}
3−module Graphics.Vty.UnicodeWidthTable.Install
4− ( TableInstallException(..)
5− , installUnicodeWidthTable
6− , isCustomTableReady
7− )
8−where
9−
10−import Control.Monad (when, forM_)
11−import qualified Control.Exception as E
12−import GHC.Conc.Sync (withMVar)
13−import Control.Concurrent.MVar (MVar, newMVar)
14−import Data.Word (Word8, Word32)
15−#if !(MIN_VERSION_base(4,11,0))
16−import Data.Semigroup ((<>))
17−#endif
18−import System.IO.Unsafe (unsafePerformIO)
19−
20−import Graphics.Vty.UnicodeWidthTable.Types
21−
22−-- | The lock used to make functions in this module thread-safe.
23−installLock :: MVar ()
24−{-# NOINLINE installLock #-}
25−installLock = unsafePerformIO $ newMVar ()
26−
27−-- | Returns True if and only if a custom table has been allocated and
28−-- marked as ready for use.
29−--
30−-- This function is thread-safe.
31−isCustomTableReady :: IO Bool
32−isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady
33−
34−withInstallLock :: IO a -> IO a
35−withInstallLock act = withMVar installLock $ const act
36−
37−-- This is the size of the allocated custom character width table, in
38−-- character slots. It's important that this be large enough to hold all
39−-- possible Unicode character values. At the time of this writing, the
40−-- valid Unicode range is 0 - 0x10ffff, hence this value.
41−tableSize :: Int
42−tableSize = 0x110000
43−
44−-- | Exception type raised by 'installUnicodeWidthTable'.
45−data TableInstallException =
46− TableInitFailure Int Int
47− -- ^ The width table could not be initialized. Args: failure status,
48− -- requested table size.
49− | TableRangeFailure Int WidthTableRange
50− -- ^ A code point range could not be configured. Args: failure
51− -- status, offending range.
52− | TableActivationFailure Int
53− -- ^ The table could not be activated. Args: failure status.
54− deriving (Eq, Show)
55−
56−instance E.Exception TableInstallException
57−
58−-- | Install a custom unicode character width
59−-- table. Such tables are obtained with
60−-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and
61−-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.
62−--
63−-- ALERT! This function is probably not what you want to use because
64−-- it is automatically called by 'Graphics.Vty.mkVty'. You will only
65−-- ever need to call this function if you want to use functions
66−-- in 'Graphics.Text.Width' without controlling the terminal with
67−-- 'Graphics.Vty.mkVty'.
68−--
69−-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'
70−-- function and functions that call it. It does so by
71−-- changing global state available to the C implementation
72−-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your
73−-- program gets consistent results from evaluating calls to
74−-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table
75−-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in
76−-- your program.
77−--
78−-- This is best done at Vty startup, and if you use
79−-- 'Graphics.Vty.mkVty', that function calls this automatically based on
80−-- the Vty configuration's declared width tables. It is exposed as part
81−-- of the public API so that applications can call this as needed if
82−-- they don't want to control the terminal with 'mkVty' but do want to
83−-- make calls to 'Graphics.Vty.Image.wcwidth'.
84−--
85−-- It's also important to note that once a custom table has been
86−-- installed, it is permanent for the life of the process. No new table
87−-- can be installed, and the new custom table cannot be removed.
88−--
89−-- If this function fails for any reason -- if the table cannot be
90−-- installed or is invalid, or if a custom table already exists -- this
91−-- will raise a 'TableInstallException' exception.
92−--
93−-- This function is thread-safe.
94−installUnicodeWidthTable :: UnicodeWidthTable -> IO ()
95−installUnicodeWidthTable table = withInstallLock $ do
96− initResult <- initCustomTable tableSize
97− when (initResult /= 0) $
98− E.throwIO $ TableInitFailure initResult tableSize
99−
100− forM_ (unicodeWidthTableRanges table) $ \r -> do
101− result <- setCustomTableRange (rangeStart r)
102− (rangeSize r)
103− (rangeColumns r)
104−
105− when (result /= 0) $ do
106− deallocateCustomTable
107− E.throwIO $ TableRangeFailure result r
108−
109− actResult <- activateCustomTable
110− when (actResult /= 0) $
111− E.throwIO $ TableActivationFailure actResult
112−
113−------------------------------------------------------------------------
114−-- C imports
115−
116−foreign import ccall unsafe "vty_init_custom_table"
117− initCustomTable :: Int -> IO Int
118−
119−foreign import ccall unsafe "vty_set_custom_table_range"
120− setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int
121−
122−foreign import ccall unsafe "vty_activate_custom_table"
123− activateCustomTable :: IO Int
124−
125−foreign import ccall unsafe "vty_custom_table_ready"
126− c_isCustomTableReady :: IO Int
127−
128−foreign import ccall unsafe "vty_deallocate_custom_table"
129− deallocateCustomTable :: IO ()
src/Graphics/Vty/UnicodeWidthTable/Query.hsdeleted−79
@@ -1,79 +0,0 @@
1−{-# LANGUAGE TupleSections #-}
2−module Graphics.Vty.UnicodeWidthTable.Query
3− ( buildUnicodeWidthTable
4− , defaultUnicodeTableUpperBound
5− )
6−where
7−
8−import Control.Monad (forM)
9−import Data.Char (generalCategory, GeneralCategory(..))
10−import System.Console.ANSI (getCursorPosition)
11−import Text.Printf (printf)
12−
13−import Graphics.Vty.UnicodeWidthTable.Types
14−
15−shouldConsider :: Char -> Bool
16−shouldConsider c =
17− case generalCategory c of
18− Control -> False
19− NotAssigned -> False
20− Surrogate -> False
21− _ -> True
22−
23−charWidth :: Char -> IO Int
24−charWidth c = do
25− printf "\r"
26− putChar c
27− Just (_, col) <- getCursorPosition
28− return col
29−
30−-- | Convert a sequence of character/width pairs into a list of
31−-- run-length encoded ranges. This function assumes the pairs come
32−-- sorted by character ordinal value. It does not require that the
33−-- character range is fully covered by the sequence.
34−--
35−-- The result of this function is a list of ranges in reverse order
36−-- relative to the input sequence.
37−mkRanges :: [(Char, Int)] -> [WidthTableRange]
38−mkRanges pairs =
39− let convertedPairs = convert <$> pairs
40− convert (c, i) = (fromIntegral $ fromEnum c, fromIntegral i)
41−
42− go Nothing finishedRanges [] = finishedRanges
43− go (Just r) finishedRanges [] = r:finishedRanges
44−
45− go Nothing finishedRanges ((c, width):rest) =
46− go (Just $ WidthTableRange c 1 width) finishedRanges rest
47−
48− go (Just r@(WidthTableRange prevCh sz prevWidth)) finishedRanges ((c, width):rest) =
49− if c == prevCh + sz && prevWidth == width
50− then go (Just (WidthTableRange prevCh (sz + 1) prevWidth)) finishedRanges rest
51− else go (Just (WidthTableRange c 1 width)) (r:finishedRanges) rest
52−
53− in go Nothing [] convertedPairs
54−
55−-- The uppermost code point to consider when building Unicode width
56−-- tables.
57−defaultUnicodeTableUpperBound :: Char
58−defaultUnicodeTableUpperBound = '\xe0000'
59−
60−-- | Construct a unicode character width table by querying the terminal
61−-- connected to stdout. This works by emitting characters to stdout
62−-- and then querying the terminal to determine the resulting cursor
63−-- position in order to measure character widths. Consequently this will
64−-- generate a lot of output and may take a while, depending on your
65−-- system performance. This should not be run in a terminal while it is
66−-- controlled by Vty.
67−--
68−-- The argument specifies the upper bound code point to test when
69−-- building the table. This allows callers to decide how much of the
70−-- Unicode code point space to scan when building the table.
71−--
72−-- This does not handle exceptions.
73−buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
74−buildUnicodeWidthTable tableUpperBound = do
75− pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i ->
76− (i,) <$> charWidth i
77−
78− return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs
79− }
src/Graphics/Vty/UnicodeWidthTable/Types.hsdeleted−29
@@ -1,29 +0,0 @@
1−module Graphics.Vty.UnicodeWidthTable.Types
2− ( UnicodeWidthTable(..)
3− , WidthTableRange(..)
4− )
5−where
6−
7−import Data.Word (Word8, Word32)
8−
9−-- | A range of code points in a width table.
10−data WidthTableRange =
11− WidthTableRange { rangeStart :: Word32
12− -- ^ The range's starting code point.
13− , rangeSize :: Word32
14− -- ^ The number of code points in the contiguous
15− -- range, beginning with the starting code point
16− -- ('rangeStart').
17− , rangeColumns :: Word8
18− -- ^ The terminal width, in columns, of all of the
19− -- characters corresponding to the code points in
20− -- this range.
21− }
22− deriving (Eq, Show)
23−
24−-- | A run-length-encoded table of Unicode character widths.
25−data UnicodeWidthTable =
26− UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
27− -- ^ The ranges in the table.
28− }
29− deriving (Show)
test/BenchImageFuzz.hs+9−7
@@ -8,20 +8,22 @@ import Verify
8import Control.Applicative
8import Control.Applicative
9import Control.Monad
9import Control.Monad
10
10
11+import Data.Default (def)
12+
11import System.Random
13import System.Random
12
14
13rand :: Arbitrary a => IO a
15rand :: Arbitrary a => IO a
14rand = head <$> sample' arbitrary
16rand = head <$> sample' arbitrary
15
17
16−randomImage :: IO Image
18+random_image :: IO Image
17−randomImage = rand
19+random_image = rand
18
20
19−randomPicture = picForImage <$> randomImage
21+random_picture = pic_for_image <$> random_image
20
22
21−bench0 = do
23+bench_0 = do
22− vty <- mkVty defaultConfig
24+ vty <- mkVty def
23− (w,h) <- displayBounds $ outputIface vty
25+ (w,h) <- display_bounds $ output_iface vty
24− let pictures = replicateM 3000 randomPicture
26+ let pictures = replicateM 3000 random_picture
25 bench ps = do
27 bench ps = do
26 forM ps (update vty)
28 forM ps (update vty)
27 shutdown vty
29 shutdown vty
test/BenchNoDiffOpt.hs+18−17
@@ -9,30 +9,31 @@ import Control.Concurrent( threadDelay )
9import Control.Monad( liftM2 )
9import Control.Monad( liftM2 )
10
10
11import qualified Data.ByteString.Char8 as B
11import qualified Data.ByteString.Char8 as B
12+import Data.Default (def)
12import Data.List
13import Data.List
13
14
14import System.Environment( getArgs )
15import System.Environment( getArgs )
15import System.IO
16import System.IO
16import System.Random
17import System.Random
17
18
18−bench0 = do
19+bench_0 = do
19− let fixedGen = mkStdGen 0
20+ let fixed_gen = mkStdGen 0
20− setStdGen fixedGen
21+ setStdGen fixed_gen
21− vty <- mkVty defaultConfig
22+ vty <- mkVty def
22− (w,h) <- displayBounds $ outputIface vty
23+ (w,h) <- display_bounds $ output_iface vty
23− let images = return $ (image0, image1)
24+ let images = return $ (image_0, image_1)
24− image0 = charFill defAttr 'X' w h
25+ image_0 = char_fill def_attr 'X' w h
25− image1 = charFill defAttr '0' w h
26+ image_1 = char_fill def_attr '0' w h
26 bench d = do
27 bench d = do
27− flipOut vty 300 image0 image1
28+ flip_out vty 300 image_0 image_1
28 shutdown vty
29 shutdown vty
29 return $ Bench images bench
30 return $ Bench images bench
30
31
31−flipOut vty n image0 image1 =
32+flip_out vty n image_0 image_1 =
32− let !pLeft = picForImage image0
33+ let !p_left = pic_for_image image_0
33− !pRight = picForImage image1
34+ !p_right = pic_for_image image_1
34− wLeft 0 = return ()
35+ w_left 0 = return ()
35− wLeft n = update vty pLeft >> wRight (n-1)
36+ w_left n = update vty p_left >> w_right (n-1)
36− wRight 0 = return ()
37+ w_right 0 = return ()
37− wRight n = update vty pRight >> wLeft (n-1)
38+ w_right n = update vty p_right >> w_left (n-1)
38− in wLeft n
39+ in w_left n
test/BenchRenderChar.hs+27−25
@@ -1,7 +1,7 @@
1−-- benchmarks composing images using the renderChar operation. This is
1+{- benchmarks composing images using the renderChar operation.
2−-- what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar
2+ - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally
3−-- images horizontally composed should provide no worse performance than
3+ - composed should provide no worse performance than a fill render op.
4−-- a fill render op.
4+ -}
5module BenchRenderChar where
5module BenchRenderChar where
6
6
7import Graphics.Vty
7import Graphics.Vty
@@ -9,30 +9,32 @@ import Verify
9
9
10import Control.Monad ( forM_ )
10import Control.Monad ( forM_ )
11
11
12−bench0 = do
12+import Data.Default (def)
13− vty <- mkVty defaultConfig
13+
14− (w,h) <- displayBounds $ outputIface vty
14+bench_0 = do
15− let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
15+ vty <- mkVty def
16+ (w,h) <- display_bounds $ output_iface vty
17+ let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
16 bench d = do
18 bench d = do
17− forM_ d $ \testChar -> do
19+ forM_ d $ \test_char -> do
18− let testImage = testImageUsingChar testChar w h
20+ let test_image = test_image_using_char test_char w h
19− outPic = picForImage testImage
21+ out_pic = pic_for_image test_image
20− update vty outPic
22+ update vty out_pic
21 shutdown vty
23 shutdown vty
22− return $ Bench testChars bench
24+ return $ Bench test_chars bench
23
25
24−testImageUsingChar c w h
26+test_image_using_char c w h
25− = vertCat $ replicate (fromIntegral h)
27+ = vert_cat $ replicate (fromIntegral h)
26− $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
28+ $ horiz_cat $ map (char def_attr) (replicate (fromIntegral w) c)
27
29
28−bench1 = do
30+bench_1 = do
29− vty <- mkVty defaultConfig
31+ vty <- mkVty def
30− (w,h) <- displayBounds $ outputIface vty
32+ (w,h) <- display_bounds $ output_iface vty
31− let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
33+ let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
32 bench d = do
34 bench d = do
33− forM_ d $ \testChar -> do
35+ forM_ d $ \test_char -> do
34− let testImage = charFill defAttr testChar w h
36+ let test_image = char_fill def_attr test_char w h
35− outPic = picForImage testImage
37+ out_pic = pic_for_image test_image
36− update vty outPic
38+ update vty out_pic
37 shutdown vty
39 shutdown vty
38− return $ Bench testChars bench
40+ return $ Bench test_chars bench
test/BenchVerticalScroll.hs+12−10
@@ -6,6 +6,7 @@ import Verify
6import Control.Concurrent( threadDelay )
6import Control.Concurrent( threadDelay )
7import Control.Monad( liftM2 )
7import Control.Monad( liftM2 )
8
8
9+import Data.Default (def)
9import Data.List
10import Data.List
10import Data.Word
11import Data.Word
11
12
@@ -13,12 +14,12 @@ import System.Environment( getArgs )
13import System.IO
14import System.IO
14import System.Random
15import System.Random
15
16
16−bench0 = do
17+bench_0 = do
17− let fixedGen = mkStdGen 0
18+ let fixed_gen = mkStdGen 0
18− setStdGen fixedGen
19+ setStdGen fixed_gen
19− return $ Bench (return ()) (\() -> mkVty defaultConfig >>= liftM2 (>>) run shutdown)
20+ return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)
20
21
21−run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)
22+run vt = mapM_ (\p -> update vt p) . benchgen =<< display_bounds (output_iface vt)
22
23
23-- Currently, we just do scrolling.
24-- Currently, we just do scrolling.
24takem :: (a -> Int) -> Int -> [a] -> ([a],[a])
25takem :: (a -> Int) -> Int -> [a] -> ([a],[a])
@@ -40,20 +41,21 @@ lengths ml g =
40nums :: StdGen -> [(Attr, String)]
41nums :: StdGen -> [(Attr, String)]
41nums g = let (x,g2) = (random g :: (Int, StdGen))
42nums g = let (x,g2) = (random g :: (Int, StdGen))
42 (c,g3) = random g2
43 (c,g3) = random g2
43− in ( if c then defAttr `withForeColor` red else defAttr
44+ in ( if c then def_attr `with_fore_color` red else def_attr
44 , shows x " "
45 , shows x " "
45 ) : nums g3
46 ) : nums g3
46
47
47pad :: Int -> Image -> Image
48pad :: Int -> Image -> Image
48−pad ml img = img <|> charFill defAttr ' ' (ml - imageWidth img) 1
49+pad ml img = img <|> char_fill def_attr ' ' (ml - image_width img) 1
49
50
50clines :: StdGen -> Int -> [Image]
51clines :: StdGen -> Int -> [Image]
51−clines g maxll = map (pad maxll . horizCat . map (uncurry string))
52+clines g maxll = map (pad maxll . horiz_cat . map (uncurry string))
52 $ fold (length . snd) (lengths maxll g1) (nums g2)
53 $ fold (length . snd) (lengths maxll g1) (nums g2)
53 where (g1,g2) = split g
54 where (g1,g2) = split g
54
55
55benchgen :: DisplayRegion -> [Picture]
56benchgen :: DisplayRegion -> [Picture]
56−benchgen (w,h)
57+benchgen (w,h)
57− = take 2000 $ map ((\i -> picForImage i) . vertCat . take (fromEnum h))
58+ = take 2000 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h))
58 $ tails
59 $ tails
59 $ clines (mkStdGen 80) w
60 $ clines (mkStdGen 80) w
61+
test/ControlTable.hs+4−4
@@ -5,10 +5,10 @@ import Graphics.Vty.ControlStrings
5import System.Console.Terminfo
5import System.Console.Terminfo
6
6
7main = do
7main = do
8− terminal <- setupTermFromEnv
8+ terminal <- setupTermFromEnv
9− controlTable <- init_controlTable terminal
9+ control_table <- init_control_table terminal
10 putStrLn $ "ANSI terminal show cursor string: " ++ show cvis
10 putStrLn $ "ANSI terminal show cursor string: " ++ show cvis
11− putStrLn $ "Current terminal show cursor string: " ++ show (showCursorStr controlTable)
11+ putStrLn $ "Current terminal show cursor string: " ++ show (show_cursor_str control_table)
12 putStrLn $ "ANSI terminal hide cursor string: " ++ show civis
12 putStrLn $ "ANSI terminal hide cursor string: " ++ show civis
13− putStrLn $ "Current terminal hide cursor string: " ++ show (hideCursorStr controlTable)
13+ putStrLn $ "Current terminal hide cursor string: " ++ show (hide_cursor_str control_table)
14
14
test/EventEcho.hs+16−15
@@ -6,35 +6,36 @@ import Control.Applicative
6import Control.Arrow
6import Control.Arrow
7import Control.Monad.RWS
7import Control.Monad.RWS
8
8
9+import Data.Default (def)
9import Data.Sequence (Seq, (<|) )
10import Data.Sequence (Seq, (<|) )
10import qualified Data.Sequence as Seq
11import qualified Data.Sequence as Seq
11import Data.Foldable
12import Data.Foldable
12
13
13−eventBufferSize = 1000
14+event_buffer_size = 1000
14
15
15type App = RWST Vty () (Seq String) IO
16type App = RWST Vty () (Seq String) IO
16
17
17main = do
18main = do
18− vty <- mkVty defaultConfig
19+ vty <- mkVty def
19− _ <- execRWST (vtyInteract False) vty Seq.empty
20+ _ <- execRWST (vty_interact False) vty Seq.empty
20 shutdown vty
21 shutdown vty
21
22
22−vtyInteract :: Bool -> App ()
23+vty_interact :: Bool -> App ()
23−vtyInteract shouldExit = do
24+vty_interact should_exit = do
24− updateDisplay
25+ update_display
25− unless shouldExit $ handleNextEvent >>= vtyInteract
26+ unless should_exit $ handle_next_event >>= vty_interact
26
27
27−updateDisplay :: App ()
28+update_display :: App ()
28−updateDisplay = do
29+update_display = do
29− let info = string defAttr "Press ESC to exit."
30+ let info = string def_attr "Press ESC to exit."
30− eventLog <- foldMap (string defAttr) <$> get
31+ event_log <- foldMap (string def_attr) <$> get
31− let pic = picForImage $ info <-> eventLog
32+ let pic = pic_for_image $ info <-> event_log
32 vty <- ask
33 vty <- ask
33 liftIO $ update vty pic
34 liftIO $ update vty pic
34
35
35−handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent
36+handle_next_event = ask >>= liftIO . next_event >>= handle_event
36 where
37 where
37− handleEvent e = do
38+ handle_event e = do
38− modify $ (<|) (show e) >>> Seq.take eventBufferSize
39+ modify $ (<|) (show e) >>> Seq.take event_buffer_size
39 return $ e == EvKey KEsc []
40 return $ e == EvKey KEsc []
40
41
test/HereDoc.hs+4−2
@@ -1,7 +1,8 @@
1{-# LANGUAGE QuasiQuotes #-}
1{-# LANGUAGE QuasiQuotes #-}
2{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
3−-- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/
3+{- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/
4−-- copyright unknown?
4+ - copyright unknown?
5+ -}
5module HereDoc (heredoc) where
6module HereDoc (heredoc) where
6
7
7import Language.Haskell.TH.Quote
8import Language.Haskell.TH.Quote
@@ -10,3 +11,4 @@ import Language.Haskell.TH.Lib
10
11
11heredoc :: QuasiQuoter
12heredoc :: QuasiQuoter
12heredoc = QuasiQuoter (litE . stringL) (litP . stringL) undefined undefined
13heredoc = QuasiQuoter (litE . stringL) (litP . stringL) undefined undefined
14+
test/Issue76.hsdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−import Control.Monad (void)
4−import Graphics.Vty
5−
6−main :: IO ()
7−main = do
8− cfg <- standardIOConfig
9− vty <- mkVty cfg
10− let line1 = charFill (defAttr `withBackColor` blue) ' ' 10 1
11− line2 = charFill (defAttr `withBackColor` green) ' ' 10 1
12− img = translate 10 5 (line1 `vertJoin` line2)
13− pic = picForImage img
14−
15− update vty pic
16− void $ nextEvent vty
17− shutdown vty
test/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Stefan O'Rear nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31−
test/Makefile+2−2
@@ -45,7 +45,7 @@ all : $(VERIF_TESTS)
45
45
46.PHONY: $(TESTS)
46.PHONY: $(TESTS)
47.SECONDEXPANSION:
47.SECONDEXPANSION:
48−$(TESTS) :
48+$(TESTS) :
49 @echo running test $@
49 @echo running test $@
50 @mkdir -p results/$@
50 @mkdir -p results/$@
51 ( ghc $(GHC_PROF_ARGS) $@ \
51 ( ghc $(GHC_PROF_ARGS) $@ \
@@ -54,7 +54,7 @@ $(TESTS) :
54 )
54 )
55
55
56.PHONY: interactive_terminal_test
56.PHONY: interactive_terminal_test
57−interactive_terminal_test :
57+interactive_terminal_test :
58 ghc $(GHC_ARGS) $@ && ./$@
58 ghc $(GHC_ARGS) $@ && ./$@
59
59
60.PHONY: core
60.PHONY: core
test/MinimalExample.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−import Graphics.Vty
4−
5−main = do
6− vty <- mkVty defaultConfig
7− let line0 = string (def `withForeColor` green) "first line"
8− line1 = string (def `withBackColor` blue) "second line"
9− img = line0 <-> line1
10− pic = picForImage img
11− update vty pic
12− e <- nextEvent vty
13− shutdown vty
14− print $ "Last event was: " ++ show e
test/Rogue.hsdeleted−175
@@ -1,175 +0,0 @@
1−module Main where
2−
3−import Graphics.Vty
4−
5−import Data.Array
6−
7−import Control.Applicative
8−import Control.Monad
9−import Control.Monad.RWS
10−
11−import System.Random
12−
13−data Player = Player
14− { playerCoord :: Coord
15− } deriving (Show,Eq)
16−
17−data World = World
18− { player :: Player
19− , level :: Level
20− }
21− deriving (Show,Eq)
22−
23−data Level = Level
24− { levelStart :: Coord
25− , levelEnd :: Coord
26− , levelGeo :: Geo
27− -- building the geo image is expensive. Cache it. Though VTY should go
28− -- through greater lengths to avoid the need to cache images.
29− , levelGeoImage :: Image
30− }
31− deriving (Show,Eq)
32−
33−data LevelPiece
34− = EmptySpace
35− | Rock
36− deriving (Show, Eq)
37−
38−type Game = RWST Vty () World IO
39−type Geo = Array Coord LevelPiece
40−type Coord = (Int, Int)
41−
42−main :: IO ()
43−main = do
44− vty <- mkVty defaultConfig
45− level0 <- mkLevel 1
46− let world0 = World (Player (levelStart level0)) level0
47− (_finalWorld, ()) <- execRWST play vty world0
48− shutdown vty
49−
50−-- |Generate a level randomly using the specified difficulty. Higher
51−-- difficulty means the level will have more rooms and cover a larger area.
52−mkLevel :: Int -> IO Level
53−mkLevel difficulty = do
54− let size = 80 * difficulty
55− [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
56− let randomP = (,) <$> randomRIO (2, levelWidth-3) <*> randomRIO (2, levelHeight-3)
57− start <- randomP
58− end <- randomP
59− -- first the base geography: all rocks
60− let baseGeo = array ((0,0), (levelWidth-1, levelHeight-1))
61− [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]
62− -- next the empty spaces that make the rooms
63− -- for this we generate a number of center points
64− centers <- replicateM (2 ^ difficulty + difficulty) randomP
65− -- generate rooms for all those points, plus the start and end
66− geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
67− return $ Level start end geo (buildGeoImage geo)
68−
69−-- |Add a room to a geography and return a new geography. Adds a
70−-- randomly-sized room centered at the specified coordinates.
71−addRoom :: Int
72− -> Int
73− -- ^The width and height of the geographical area
74− -> Geo
75− -- ^The geographical area to which a new room should be added
76− -> Coord
77− -- ^The desired center of the new room.
78− -> IO Geo
79−addRoom levelWidth levelHeight geo (centerX, centerY) = do
80− size <- randomRIO (5,15)
81− let xMin = max 1 (centerX - size)
82− xMax = min (levelWidth - 1) (centerX + size)
83− yMin = max 1 (centerY - size)
84− yMax = min (levelHeight - 1) (centerY + size)
85− let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
86− return (geo // room)
87−
88−pieceA, dumpA :: Attr
89−pieceA = defAttr `withForeColor` blue `withBackColor` green
90−dumpA = defAttr `withStyle` reverseVideo
91−
92−play :: Game ()
93−play = do
94− updateDisplay
95− done <- processEvent
96− unless done play
97−
98−processEvent :: Game Bool
99−processEvent = do
100− k <- ask >>= liftIO . nextEvent
101− if k == EvKey KEsc []
102− then return True
103− else do
104− case k of
105− EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh
106− EvKey KLeft [] -> movePlayer (-1) 0
107− EvKey KRight [] -> movePlayer 1 0
108− EvKey KUp [] -> movePlayer 0 (-1)
109− EvKey KDown [] -> movePlayer 0 1
110− _ -> return ()
111− return False
112−
113−movePlayer :: Int -> Int -> Game ()
114−movePlayer dx dy = do
115− world <- get
116− let Player (x, y) = player world
117− let x' = x + dx
118− y' = y + dy
119− -- this is only valid because the level generation assures the border is
120− -- always Rock
121− case levelGeo (level world) ! (x',y') of
122− EmptySpace -> put $ world { player = Player (x',y') }
123− _ -> return ()
124−
125−updateDisplay :: Game ()
126−updateDisplay = do
127− let info = string defAttr "Move with the arrows keys. Press ESC to exit."
128− -- determine offsets to place the player in the center of the level.
129− (w,h) <- asks outputIface >>= liftIO . displayBounds
130− thePlayer <- gets player
131− let ox = (w `div` 2) - playerX thePlayer
132− oy = (h `div` 2) - playerY thePlayer
133− -- translate the world images to place the player in the center of the
134− -- level.
135− world' <- map (translate ox oy) <$> worldImages
136− let pic = picForLayers $ info : world'
137− vty <- ask
138− liftIO $ update vty pic
139−
140−--
141−-- Image-generation functions
142−--
143−
144−worldImages :: Game [Image]
145−worldImages = do
146− thePlayer <- gets player
147− theLevel <- gets level
148− let playerImage = translate (playerX thePlayer) (playerY thePlayer) (char pieceA '@')
149− return [playerImage, levelGeoImage theLevel]
150−
151−imageForGeo :: LevelPiece -> Image
152−imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
153−imageForGeo Rock = char defAttr 'X'
154−
155−buildGeoImage :: Geo -> Image
156−buildGeoImage geo =
157− let (geoWidth, geoHeight) = snd $ bounds geo
158− -- seems like a the repeated index operation should be removable. This is
159− -- not performing random access but (presumably) access in order of index.
160− in vertCat [ geoRow
161− | y <- [0..geoHeight-1]
162− , let geoRow = horizCat [ i
163− | x <- [0..geoWidth-1]
164− , let i = imageForGeo (geo ! (x,y))
165− ]
166− ]
167−
168−--
169−-- Miscellaneous
170−--
171−playerX :: Player -> Int
172−playerX = fst . playerCoord
173−
174−playerY :: Player -> Int
175−playerY = snd . playerCoord
test/Rouge.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+module Main where
3+
4+import Graphics.Vty
5+
6+import Data.Array
7+import qualified Data.ByteString as B
8+import Data.Default (def)
9+import Data.Word
10+
11+import Control.Applicative
12+import Control.Lens hiding (Level)
13+import Control.Monad
14+import Control.Monad.RWS
15+import Control.Monad.Writer
16+
17+import System.IO
18+import System.Random
19+
20+data Dude = Dude
21+ { dude_x :: Int
22+ , dude_y :: Int
23+ } deriving (Show,Eq)
24+
25+data World = World
26+ { dude :: Dude
27+ , level :: Level
28+ }
29+ deriving (Show,Eq)
30+
31+data Level = Level
32+ { start :: (Int, Int)
33+ , end :: (Int, Int)
34+ , geo :: Array (Int, Int) LevelPiece
35+ -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
36+ -- to avoid the need to cache images.
37+ , geo_image :: Image
38+ }
39+ deriving (Show,Eq)
40+
41+data LevelPiece
42+ = EmptySpace
43+ | Rock
44+ deriving (Show, Eq)
45+
46+type Game = RWST Vty () World IO
47+
48+main = do
49+ vty <- mkVty def
50+ level_0 <- mkLevel 1
51+ let world_0 = World (Dude (fst $ start level_0) (snd $ start level_0)) level_0
52+ (_final_world, ()) <- execRWST (play >> update_display) vty world_0
53+ shutdown vty
54+
55+mkLevel difficulty = do
56+ let size = 80 * difficulty
57+ [level_width, level_height] <- replicateM 2 $ randomRIO (size,size)
58+ let randomP = (,) <$> randomRIO (2, level_width-3) <*> randomRIO (2, level_height-3)
59+ start <- randomP
60+ end <- randomP
61+ -- first the base geography: all rocks
62+ let base_geo = array ((0,0), (level_width, level_height))
63+ [((x,y),Rock) | x <- [0..level_width-1], y <- [0..level_height-1]]
64+ -- next the empty spaces that make the rooms
65+ -- for this we generate a number of center points
66+ centers <- replicateM (2 ^ difficulty + difficulty) randomP
67+ -- generate rooms for all those points, plus the start and end
68+ geo <- foldM (add_room level_width level_height) base_geo (start : end : centers)
69+ return $ Level start end geo (build_geo_image geo)
70+
71+add_room level_width level_height geo (center_x, center_y) = do
72+ size <- randomRIO (5,15)
73+ let x_min = max 1 (center_x - size)
74+ x_max = min (level_width - 1) (center_x + size)
75+ y_min = max 1 (center_y - size)
76+ y_max = min (level_height - 1) (center_y + size)
77+ let room = [((x,y), EmptySpace) | x <- [x_min..x_max - 1], y <- [y_min..y_max - 1]]
78+ return (geo // room)
79+
80+image_for_geo EmptySpace = char (def_attr `with_back_color` green) ' '
81+image_for_geo Rock = char def_attr 'X'
82+
83+pieceA = def_attr `with_fore_color` blue `with_back_color` green
84+dumpA = def_attr `with_style` reverse_video
85+
86+play = do
87+ update_display
88+ done <- process_event
89+ unless done play
90+
91+process_event = do
92+ k <- ask >>= liftIO . next_event
93+ if k == EvKey KEsc []
94+ then return True
95+ else do
96+ case k of
97+ EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh
98+ EvKey KLeft [] -> move_dude (-1) 0
99+ EvKey KRight [] -> move_dude 1 0
100+ EvKey KUp [] -> move_dude 0 (-1)
101+ EvKey KDown [] -> move_dude 0 1
102+ _ -> return ()
103+ return False
104+
105+move_dude dx dy = do
106+ vty <- ask
107+ world <- get
108+ let Dude x y = dude world
109+ let x' = x + dx
110+ y' = y + dy
111+ -- this is only valid because the level generation assures the border is always Rock
112+ case geo (level world) ! (x',y') of
113+ EmptySpace -> put $ world { dude = Dude x' y' }
114+ _ -> return ()
115+
116+update_display :: Game ()
117+update_display = do
118+ let info = string def_attr "Move with the arrows keys. Press ESC to exit."
119+ -- determine offsets to place the dude in the center of the level.
120+ (w,h) <- asks output_iface >>= liftIO . display_bounds
121+ the_dude <- gets dude
122+ let ox = (w `div` 2) - dude_x the_dude
123+ oy = (h `div` 2) - dude_y the_dude
124+ -- translate the world images to place the dude in the center of the level.
125+ world' <- map (translate ox oy) <$> world
126+ let pic = pic_for_layers $ info : world'
127+ vty <- ask
128+ liftIO $ update vty pic
129+
130+world :: Game [Image]
131+world = do
132+ the_dude <- gets dude
133+ the_level <- gets level
134+ let dude_image = translate (dude_x the_dude) (dude_y the_dude) (char pieceA '@')
135+ return [dude_image, geo_image the_level]
136+
137+build_geo_image geo =
138+ let (geo_width, geo_height) = snd $ bounds geo
139+ -- seems like a the repeated index operation should be removable. This is not performing random
140+ -- access but (presumably) access in order of index.
141+ in vert_cat [ geo_row
142+ | y <- [0..geo_height-1]
143+ , let geo_row = horiz_cat [ i
144+ | x <- [0..geo_width-1]
145+ , let i = image_for_geo (geo ! (x,y))
146+ ]
147+ ]
test/RougeStory.hsnew file+185
@@ -0,0 +1,185 @@
1+{-# LANGUAGE NoMonomorphismRestriction #-}
2+-- investigation using typed tagless interpretter of an AST representation of a story.
3+-- Use extensible effects instead?
4+module RougeStory where
5+
6+import Text.Printf
7+
8+import Graphics.Vty
9+import Graphics.Vty.Inline
10+
11+import Control.Applicative
12+import Control.Concurrent (threadDelay)
13+import Control.Monad
14+import Control.Monad.Trans
15+import Control.Monad.Trans.State.Strict
16+
17+import Data.Foldable
18+import Data.Map.Strict (Map)
19+import qualified Data.Map.Strict as Map
20+
21+import System.Random
22+
23+-- Characters are identified by Names
24+type Character = Name
25+type Name = String
26+type Type = String
27+
28+-- The game is the view of a story.
29+class Story repr where
30+ -- A story is the quest of a character which becomes a history
31+ story :: Character -> repr Quest -> repr History
32+ quest :: repr Goal -> repr Aspects -> repr Quest
33+
34+ -- A quest is for a goal where some aspects are known and others unknown.
35+ -- TODO: abstract to any Foldable?
36+ empty_aspects :: repr Aspects
37+ add_known_history :: repr History -> repr Aspects -> repr Aspects
38+ add_known_obj :: repr Object -> repr Aspects -> repr Aspects
39+ add_unknown_history :: repr History -> repr Aspects -> repr Aspects
40+ add_unknown_obj :: repr Object -> repr Aspects -> repr Aspects
41+
42+ -- Aspects are animate objects, inanimate objects or histories.
43+ animate_obj :: Type -> repr Object
44+ inanimate_obj :: Type -> repr Object
45+ history :: repr History
46+
47+ -- The goal is to acquire, or dispose of an object.
48+ dispose_obj :: repr Object -> repr Goal
49+ acquire_obj :: repr Object -> repr Goal
50+
51+ -- What is an object? Well, that's anything that fits in the story language.
52+ -- Which at least means it's something that can be named
53+ named :: repr Object -> Name -> repr Object
54+
55+data Quest
56+data History
57+data Goal
58+data Aspects
59+data Object
60+
61+story_0 =
62+ let bob = animate_obj "Human" `named` "Bob"
63+ the_quest = quest (dispose_obj (inanimate_obj "YoYo" `named` "The Kitten Slayer"))
64+ (add_known_obj bob empty_aspects)
65+ in story "Bob" the_quest
66+
67+{- TEMPLATE
68+instance Story X where
69+ story c q =
70+ quest g as =
71+ empty_aspects =
72+ add_known_history h as =
73+ add_known_obj obj as =
74+ add_unknown_history h as =
75+ add_unknown_obj obj as =
76+ animate_obj t =
77+ inanimate_obj t =
78+ history =
79+ dispose_obj obj =
80+ acquire_obj obj =
81+ named obj n =
82+-}
83+
84+newtype ShowStory t = ShowStory { unShowStory :: String }
85+instance Story ShowStory where
86+ story c q = ShowStory $ printf "History(%s,%s)" c (unShowStory q)
87+ quest g as = ShowStory $ printf "Quest(%s,%s)" (unShowStory g) (unShowStory as)
88+ empty_aspects = ShowStory $ printf "EmptyAspects"
89+ add_known_history h as = ShowStory $ printf "Known(%s):%s" (unShowStory h) (unShowStory as)
90+ add_known_obj obj as = ShowStory $ printf "Known(%s):%s" (unShowStory obj) (unShowStory as)
91+ add_unknown_history h as = ShowStory $ printf "Unknown(%s):%s" (unShowStory h) (unShowStory as)
92+ add_unknown_obj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)
93+ animate_obj t = ShowStory $ printf "%s :: AnimateObj" t
94+ inanimate_obj t = ShowStory $ printf "%s :: InanimateObj" t
95+ history = ShowStory $ printf "History"
96+ dispose_obj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)
97+ acquire_obj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)
98+ named obj n = ShowStory $ printf "%s+Name(%s)" (unShowStory obj) (show n)
99+
100+newtype TellStory t = TellStory { unTellStory :: String }
101+
102+instance Story TellStory where
103+ story c (TellStory quest) = TellStory $ "The story of " ++ c ++ " on the quest " ++ quest
104+ quest (TellStory g) (TellStory as)
105+ | as == "" = TellStory $ g ++ "."
106+ | otherwise = TellStory $ g ++ ". In a world where... " ++ as
107+ empty_aspects = TellStory ""
108+ add_known_history (TellStory h) (TellStory as)
109+ = TellStory $ "Our hero knows the tale of\n\t" ++ h ++ ".\n" ++ as
110+ add_known_obj (TellStory obj) (TellStory as)
111+ = TellStory $ "Our hero knows of " ++ obj ++ ". " ++ as
112+ add_unknown_history _ as = as
113+ add_unknown_obj _ as = as
114+ animate_obj t = TellStory t
115+ inanimate_obj t = TellStory t
116+ history = TellStory "History"
117+ dispose_obj (TellStory obj)
118+ = TellStory $ "to dispose of the accursed " ++ obj
119+ acquire_obj (TellStory obj)
120+ = TellStory $ "to acquire the great " ++ obj
121+ named (TellStory obj) name
122+ = TellStory $ obj ++ " with the name " ++ name
123+
124+newtype BuildSprites m t = BuildSprites {build_sprites :: StateT SpriteDB m ()}
125+
126+type Sprite = (Int, Int, Image)
127+type Collider = (Int,Int,Int,Int)
128+data SpriteDB = SpriteDB
129+ { next_sprite_ID :: Int -- globally monotonic. H: Can fst . findMax + 1 be used?
130+ , this_sprite_ID :: Int
131+ , sprites :: Map Int Sprite
132+ }
133+ deriving (Show)
134+
135+get_sprite_ID :: MonadIO m => StateT SpriteDB m Int
136+get_sprite_ID = gets this_sprite_ID
137+
138+new_sprite_ID :: MonadIO m => StateT SpriteDB m Int
139+new_sprite_ID = do
140+ ctx <- get
141+ let the_ID = next_sprite_ID ctx
142+ put $ ctx {next_sprite_ID = the_ID + 1, this_sprite_ID = the_ID}
143+ return the_ID
144+
145+empty_sprite_db = SpriteDB 0 1 Map.empty
146+
147+add_sprite x y img i
148+ = modify (\ctx -> ctx {sprites = Map.insert i (x,y,img) (sprites ctx)})
149+
150+add_random_sprite c i = do
151+ let img = char def_attr c
152+ [x,y] <- liftIO $ replicateM 2 $ randomRIO (-100,100)
153+ add_sprite x y img i
154+
155+instance MonadIO m => Story (BuildSprites m) where
156+ story _c (BuildSprites q) = BuildSprites q
157+ quest (BuildSprites g) (BuildSprites as) = BuildSprites (g >> as)
158+ empty_aspects = BuildSprites $ return ()
159+ add_known_history h (BuildSprites as) = BuildSprites as
160+ add_known_obj obj (BuildSprites as) = BuildSprites as
161+ add_unknown_history h (BuildSprites as) = BuildSprites as
162+ add_unknown_obj obj (BuildSprites as) = BuildSprites as
163+ animate_obj _t = BuildSprites $ do
164+ add_random_sprite '@' =<< new_sprite_ID
165+ inanimate_obj _t = BuildSprites $ do
166+ add_random_sprite 'X' =<< new_sprite_ID
167+ history = BuildSprites $ return ()
168+ dispose_obj (BuildSprites obj) = BuildSprites obj
169+ acquire_obj (BuildSprites obj) = BuildSprites obj
170+ named (BuildSprites obj) n = BuildSprites obj
171+
172+render_sprites = foldMap render_sprite . sprites
173+render_sprite (x,y,img) = return $ translate x y img
174+
175+main = do
176+ putStrLn $ unTellStory story_0
177+ putStrLn $ unShowStory story_0
178+ sprite_db <- execStateT (build_sprites story_0) empty_sprite_db
179+ print sprite_db
180+ let imgs = render_sprites sprite_db
181+ p = pic_for_layers imgs
182+ withVty $ flip update p
183+ threadDelay 5000000
184+ withVty $ shutdown
185+ return ()
test/Setup.lhsdeleted−3
@@ -1,3 +0,0 @@
1−#!/usr/bin/env runhaskell
2−> import Distribution.Simple
3−> main = defaultMain
test/Test2.hs−1
@@ -1,5 +1,4 @@
1module Main where
1module Main where
2−
3import Graphics.Vty
2import Graphics.Vty
4
3
5main = do
4main = do
test/Verify.hs+37−25
@@ -1,29 +1,30 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE CPP #-}
4{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE DisambiguateRecordFields #-}
8{-# LANGUAGE DisambiguateRecordFields #-}
8{-# LANGUAGE NamedFieldPuns #-}
9{-# LANGUAGE NamedFieldPuns #-}
9−module Verify
10+module Verify ( module Verify
10− ( module Verify
11+ , module Control.Applicative
11− , module Control.Applicative
12+ , module Control.DeepSeq
12− , module Control.DeepSeq
13+ , module Control.Exception
13− , module Control.Exception
14+ , module Control.Monad
14− , module Control.Monad
15+ , module Test.QuickCheck
15− , module Test.QuickCheck
16+ , module Test.QuickCheck.Modifiers
16− , module Test.QuickCheck.Modifiers
17+ , module Text.Printf
17− , module Text.Printf
18+ , succeeded
18− , succeeded
19+ , failed
19− , failed
20+ , result
20− , monadicIO
21+ , monadicIO
21− , liftIO
22+ , liftIO
22− , liftBool
23+ , liftBool
23− , Test(..)
24+ , Test(..)
24− , Prop.Result(..)
25+ , Prop.Result(..)
25− )
26+ )
26−where
27+ where
27
28
28import Control.Exception ( bracket, try, SomeException(..) )
29import Control.Exception ( bracket, try, SomeException(..) )
29
30
@@ -35,7 +36,7 @@ import qualified Test.QuickCheck as QC
35import Test.QuickCheck.Modifiers
36import Test.QuickCheck.Modifiers
36import Test.QuickCheck.Property hiding ( Result(..) )
37import Test.QuickCheck.Property hiding ( Result(..) )
37import qualified Test.QuickCheck.Property as Prop
38import qualified Test.QuickCheck.Property as Prop
38−import Test.QuickCheck.Monadic ( monadicIO )
39+import Test.QuickCheck.Monadic ( monadicIO )
39
40
40import Text.Printf
41import Text.Printf
41
42
@@ -49,14 +50,14 @@ import Control.Monad.State.Strict
49import Numeric ( showHex )
50import Numeric ( showHex )
50
51
51verify :: Testable t => String -> t -> Test
52verify :: Testable t => String -> t -> Test
52−verify testName p = Test $ TestInstance
53+verify test_name p = Test $ TestInstance
53− { name = testName
54+ { name = test_name
54 , run = do
55 , run = do
55− qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p
56+ qc_result <- quickCheckResult p
56− case qcResult of
57+ case qc_result of
57 QC.Success {..} -> return $ Finished TS.Pass
58 QC.Success {..} -> return $ Finished TS.Pass
58 QC.Failure {numShrinks,reason} -> return $ Finished
59 QC.Failure {numShrinks,reason} -> return $ Finished
59− $ TS.Fail $ "After "
60+ $ TS.Fail $ "After "
60 ++ show numShrinks ++ " shrinks determined failure to be: "
61 ++ show numShrinks ++ " shrinks determined failure to be: "
61 ++ show reason
62 ++ show reason
62 _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"
63 _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"
@@ -83,7 +84,18 @@ instance Arbitrary DoubleColumnChar where
83 ++ [ toEnum 0x309B .. toEnum 0xA4CF ]
84 ++ [ toEnum 0x309B .. toEnum 0xA4CF ]
84
85
85liftIOResult :: Testable prop => IO prop -> Property
86liftIOResult :: Testable prop => IO prop -> Property
86−liftIOResult = ioProperty
87+liftIOResult = morallyDubiousIOProperty
88+
89+#if __GLASGOW_HASKELL__ <= 701
90+instance Random Word where
91+ random g =
92+ let (i :: Int, g') = random g
93+ in (toEnum i, g')
94+ randomR (l,h) g =
95+ let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g
96+ in (toEnum i, g')
97+#endif
87
98
88data Bench where
99data Bench where
89 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
100 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
101+
test/Verify/Data/Terminfo/Parse.hs+55−55
@@ -1,8 +1,7 @@
1−module Verify.Data.Terminfo.Parse
1+module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse
2− ( module Verify.Data.Terminfo.Parse
2+ , module Data.Terminfo.Parse
3− , module Data.Terminfo.Parse
3+ )
4− )
4+ where
5−where
6
5
7import Data.Terminfo.Parse
6import Data.Terminfo.Parse
8import Data.Terminfo.Eval
7import Data.Terminfo.Eval
@@ -13,29 +12,29 @@ import qualified Data.Vector.Unboxed as Vector
13
12
14import Numeric
13import Numeric
15
14
16−hexDump :: [Word8] -> String
15+hex_dump :: [Word8] -> String
17−hexDump bytes = foldr (\b s -> showHex b s) "" bytes
16+hex_dump bytes = foldr (\b s -> showHex b s) "" bytes
18
17
19data NonParamCapString = NonParamCapString String
18data NonParamCapString = NonParamCapString String
20 deriving Show
19 deriving Show
21
20
22instance Arbitrary NonParamCapString where
21instance Arbitrary NonParamCapString where
23− arbitrary
22+ arbitrary
24 = ( do
23 = ( do
25 s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')
24 s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')
26 return $ NonParamCapString s
25 return $ NonParamCapString s
27− ) `suchThat` ( \(NonParamCapString str) -> length str < 255 )
26+ ) `suchThat` ( \(NonParamCapString str) -> length str < 255 )
28
27
29data LiteralPercentCap = LiteralPercentCap String [Word8]
28data LiteralPercentCap = LiteralPercentCap String [Word8]
30 deriving ( Show )
29 deriving ( Show )
31
30
32instance Arbitrary LiteralPercentCap where
31instance Arbitrary LiteralPercentCap where
33− arbitrary
32+ arbitrary
34 = ( do
33 = ( do
35 NonParamCapString s <- arbitrary
34 NonParamCapString s <- arbitrary
36− (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s
35+ (s', bytes) <- insert_escape_op "%" [toEnum $ fromEnum '%'] s
37 return $ LiteralPercentCap s' bytes
36 return $ LiteralPercentCap s' bytes
38− ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )
37+ ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )
39
38
40data IncFirstTwoCap = IncFirstTwoCap String [Word8]
39data IncFirstTwoCap = IncFirstTwoCap String [Word8]
41 deriving ( Show )
40 deriving ( Show )
@@ -44,9 +43,9 @@ instance Arbitrary IncFirstTwoCap where
44 arbitrary
43 arbitrary
45 = ( do
44 = ( do
46 NonParamCapString s <- arbitrary
45 NonParamCapString s <- arbitrary
47− (s', bytes) <- insertEscapeOp "i" [] s
46+ (s', bytes) <- insert_escape_op "i" [] s
48 return $ IncFirstTwoCap s' bytes
47 return $ IncFirstTwoCap s' bytes
49− ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )
48+ ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )
50
49
51data PushParamCap = PushParamCap String Int [Word8]
50data PushParamCap = PushParamCap String Int [Word8]
52 deriving ( Show )
51 deriving ( Show )
@@ -56,9 +55,9 @@ instance Arbitrary PushParamCap where
56 = ( do
55 = ( do
57 NonParamCapString s <- arbitrary
56 NonParamCapString s <- arbitrary
58 n <- choose (1,9)
57 n <- choose (1,9)
59− (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s
58+ (s', bytes) <- insert_escape_op ("p" ++ show n) [] s
60 return $ PushParamCap s' n bytes
59 return $ PushParamCap s' n bytes
61− ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )
60+ ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )
62
61
63data DecPrintCap = DecPrintCap String Int [Word8]
62data DecPrintCap = DecPrintCap String Int [Word8]
64 deriving ( Show )
63 deriving ( Show )
@@ -68,45 +67,46 @@ instance Arbitrary DecPrintCap where
68 = ( do
67 = ( do
69 NonParamCapString s <- arbitrary
68 NonParamCapString s <- arbitrary
70 n <- choose (1,9)
69 n <- choose (1,9)
71− (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s
70+ (s', bytes) <- insert_escape_op ("p" ++ show n ++ "%d") [] s
72 return $ DecPrintCap s' n bytes
71 return $ DecPrintCap s' n bytes
73− ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )
72+ ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )
74−
73+
75−insertEscapeOp opStr replBytes s = do
74+insert_escape_op op_str repl_bytes s = do
76− insertPoints <- listOf1 $ elements [0 .. length s - 1]
75+ insert_points <- listOf1 $ elements [0 .. length s - 1]
77− let s' = f s ('%' : opStr)
76+ let s' = f s ('%' : op_str)
78− remainingBytes = f (map (toEnum . fromEnum) s) replBytes
77+ remaining_bytes = f (map (toEnum . fromEnum) s) repl_bytes
79− f inVs out_v = concat [ vs
78+ f in_vs out_v = concat [ vs
80− | vi <- zip inVs [0 .. length s - 1]
79+ | vi <- zip in_vs [0 .. length s - 1]
81− , let vs = fst vi : ( if snd vi `elem` insertPoints
80+ , let vs = fst vi : ( if snd vi `elem` insert_points
82− then out_v
81+ then out_v
83− else []
82+ else []
84− )
83+ )
85− ]
84+ ]
86− return (s', remainingBytes)
85+ return (s', remaining_bytes)
87−
86+
88−isBytesOp :: CapOp -> Bool
87+is_bytes_op :: CapOp -> Bool
89−isBytesOp (Bytes {}) = True
88+is_bytes_op (Bytes {}) = True
90−-- isBytesOp _ = False
89+-- is_bytes_op _ = False
91−
90+
92−bytesForRange cap offset count
91+bytes_for_range cap offset count
93− = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap
92+ = Vector.toList $ Vector.take count $ Vector.drop offset $ cap_bytes cap
94−
93+
95−collectBytes :: CapExpression -> [Word8]
94+collect_bytes :: CapExpression -> [Word8]
96−collectBytes e = concat [ bytes
95+collect_bytes e = concat [ bytes
97− | Bytes offset count <- capOps e
96+ | Bytes offset count <- cap_ops e
98− , let bytes = bytesForRange e offset count
97+ , let bytes = bytes_for_range e offset count
99− ]
98+ ]
100−
99+
101−
100+
102−verifyBytesEqual :: [Word8] -> [Word8] -> Result
101+verify_bytes_equal :: [Word8] -> [Word8] -> Result
103−verifyBytesEqual outBytes expectedBytes
102+verify_bytes_equal out_bytes expected_bytes
104− = if outBytes == expectedBytes
103+ = if out_bytes == expected_bytes
105 then succeeded
104 then succeeded
106− else failed
105+ else failed
107− { reason = "outBytes ["
106+ { reason = "out_bytes ["
108− ++ hexDump outBytes
107+ ++ hex_dump out_bytes
109− ++ "] /= expectedBytes ["
108+ ++ "] /= expected_bytes ["
110− ++ hexDump expectedBytes
109+ ++ hex_dump expected_bytes
111− ++ "]"
110+ ++ "]"
112 }
111 }
112+
test/Verify/Graphics/Vty/Attributes.hs+35−35
@@ -1,16 +1,15 @@
1−module Verify.Graphics.Vty.Attributes
1+module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes
2− ( module Verify.Graphics.Vty.Attributes
2+ , module Graphics.Vty.Attributes
3− , module Graphics.Vty.Attributes
3+ )
4− )
4+ where
5−where
6
5
7import Graphics.Vty.Attributes
6import Graphics.Vty.Attributes
8import Verify
7import Verify
9
8
10import Data.List ( delete )
9import Data.List ( delete )
11
10
12−allColors :: [Color]
11+all_colors :: [Color]
13−allColors =
12+all_colors =
14 [ black
13 [ black
15 , red
14 , red
16 , green
15 , green
@@ -19,55 +18,56 @@ allColors =
19 , magenta
18 , magenta
20 , cyan
19 , cyan
21 , white
20 , white
22− , brightBlack
21+ , bright_black
23− , brightRed
22+ , bright_red
24− , brightGreen
23+ , bright_green
25− , brightYellow
24+ , bright_yellow
26− , brightBlue
25+ , bright_blue
27− , brightMagenta
26+ , bright_magenta
28− , brightCyan
27+ , bright_cyan
29− , brightWhite
28+ , bright_white
30 ] ++ map Color240 [0..239]
29 ] ++ map Color240 [0..239]
31
30
32−allStyles :: [Style]
31+all_styles :: [Style]
33−allStyles =
32+all_styles =
34 [ standout
33 [ standout
35 , underline
34 , underline
36− , reverseVideo
35+ , reverse_video
37 , blink
36 , blink
38 , dim
37 , dim
39 , bold
38 , bold
40 ]
39 ]
41
40
42-- Limit the possible attributes to just a few for now.
41-- Limit the possible attributes to just a few for now.
43−possibleAttrMods :: [ AttrOp ]
42+possible_attr_mods :: [ AttrOp ]
44−possibleAttrMods =
43+possible_attr_mods =
45− [ idOp
44+ [ id_op
46− ] ++ map setForeColorOp allColors
45+ ] ++ map set_fore_color_op all_colors
47− ++ map setBackColorOp allColors
46+ ++ map set_back_color_op all_colors
48− ++ map setStyleOp allStyles
47+ ++ map set_style_op all_styles
49
48
50instance Arbitrary Attr where
49instance Arbitrary Attr where
51− arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr
50+ arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr
52
51
53data DiffAttr = DiffAttr Attr Attr
52data DiffAttr = DiffAttr Attr Attr
54
53
55instance Arbitrary DiffAttr where
54instance Arbitrary DiffAttr where
56 arbitrary = do
55 arbitrary = do
57− op0 <- elements possibleAttrMods
56+ op0 <- elements possible_attr_mods
58− let possibleAttrMods' = delete op0 possibleAttrMods
57+ let possible_attr_mods' = delete op0 possible_attr_mods
59− op1 <- elements possibleAttrMods'
58+ op1 <- elements possible_attr_mods'
60− return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr)
59+ return $ DiffAttr (apply_op op0 def_attr) (apply_op op1 def_attr)
61
60
62data AttrOp = AttrOp String (Attr -> Attr)
61data AttrOp = AttrOp String (Attr -> Attr)
63
62
64instance Eq AttrOp where
63instance Eq AttrOp where
65 AttrOp n0 _ == AttrOp n1 _ = n0 == n1
64 AttrOp n0 _ == AttrOp n1 _ = n0 == n1
66
65
67−setStyleOp s = AttrOp "set_style" (flip withStyle s)
66+set_style_op s = AttrOp "set_style" (flip with_style s)
68−setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c)
67+set_fore_color_op c = AttrOp "set_fore_color" (flip with_fore_color c)
69−setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c)
68+set_back_color_op c = AttrOp "set_back_color" (flip with_back_color c)
70−idOp = AttrOp "id" id
69+id_op = AttrOp "id" id
70+
71+apply_op :: AttrOp -> Attr -> Attr
72+apply_op (AttrOp _ f) a = f a
71
73
72−applyOp :: AttrOp -> Attr -> Attr
73−applyOp (AttrOp _ f) a = f a
test/Verify/Graphics/Vty/DisplayAttributes.hs+5−5
@@ -1,8 +1,8 @@
1−module Verify.Graphics.Vty.DisplayAttributes
1+module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes
2− ( module Verify.Graphics.Vty.DisplayAttributes
2+ , module Graphics.Vty.DisplayAttributes
3− , module Graphics.Vty.DisplayAttributes
3+ )
4− )
4+ where
5−where
6
5
7import Graphics.Vty.DisplayAttributes
6import Graphics.Vty.DisplayAttributes
8import Verify
7import Verify
8+
test/Verify/Graphics/Vty/Image.hs+97−97
@@ -1,11 +1,10 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE DisambiguateRecordFields #-}
3{-# LANGUAGE DisambiguateRecordFields #-}
4−module Verify.Graphics.Vty.Image
4+module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image
5− ( module Verify.Graphics.Vty.Image
5+ , module Graphics.Vty.Image
6− , module Graphics.Vty.Image
6+ )
7− )
7+ where
8−where
9
8
10import Verify.Graphics.Vty.Attributes
9import Verify.Graphics.Vty.Attributes
11import Graphics.Vty.Image
10import Graphics.Vty.Image
@@ -27,23 +26,23 @@ instance Show UnitImage where
27data DefaultImage = DefaultImage Image
26data DefaultImage = DefaultImage Image
28
27
29instance Show DefaultImage where
28instance Show DefaultImage where
30− show (DefaultImage i)
29+ show (DefaultImage i)
31− = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i)
30+ = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i)
32
31
33instance Arbitrary DefaultImage where
32instance Arbitrary DefaultImage where
34 arbitrary = do
33 arbitrary = do
35− i <- return $ char defAttr 'X'
34+ i <- return $ char def_attr 'X'
36 return $ DefaultImage i
35 return $ DefaultImage i
37
36
38−data SingleRowSingleAttrImage
37+data SingleRowSingleAttrImage
39− = SingleRowSingleAttrImage
38+ = SingleRowSingleAttrImage
40− { expectedAttr :: Attr
39+ { expected_attr :: Attr
41− , expectedColumns :: Int
40+ , expected_columns :: Int
42− , rowImage :: Image
41+ , row_image :: Image
43 }
42 }
44
43
45instance Show SingleRowSingleAttrImage where
44instance Show SingleRowSingleAttrImage where
46− show (SingleRowSingleAttrImage attr columns image)
45+ show (SingleRowSingleAttrImage attr columns image)
47 = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"
46 = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"
48
47
49newtype WidthResize = WidthResize (Image -> (Image, Int))
48newtype WidthResize = WidthResize (Image -> (Image, Int))
@@ -53,10 +52,10 @@ instance Arbitrary WidthResize where
53 WidthResize f <- arbitrary
52 WidthResize f <- arbitrary
54 w <- choose (1,64)
53 w <- choose (1,64)
55 oneof $ map (return . WidthResize)
54 oneof $ map (return . WidthResize)
56− [ \i -> (i, imageWidth i)
55+ [ \i -> (i, image_width i)
57− , \i -> (resizeWidth w $ fst $ f i, w)
56+ , \i -> (resize_width w $ fst $ f i, w)
58− , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w)
57+ , \i -> let i' = fst $ f i in (crop_left w i', min (image_width i') w)
59− , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w)
58+ , \i -> let i' = fst $ f i in (crop_right w i', min (image_width i') w)
60 ]
59 ]
61
60
62newtype HeightResize = HeightResize (Image -> (Image, Int))
61newtype HeightResize = HeightResize (Image -> (Image, Int))
@@ -66,134 +65,134 @@ instance Arbitrary HeightResize where
66 HeightResize f <- arbitrary
65 HeightResize f <- arbitrary
67 h <- choose (1,64)
66 h <- choose (1,64)
68 oneof $ map (return . HeightResize)
67 oneof $ map (return . HeightResize)
69− [ \i -> (i, imageHeight i)
68+ [ \i -> (i, image_height i)
70− , \i -> (resizeHeight h $ fst $ f i, h)
69+ , \i -> (resize_height h $ fst $ f i, h)
71− , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h)
70+ , \i -> let i' = fst $ f i in (crop_top h i', min (image_height i') h)
72− , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h)
71+ , \i -> let i' = fst $ f i in (crop_bottom h i', min (image_height i') h)
73 ]
72 ]
74
73
75newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))
74newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))
76
75
77instance Arbitrary ImageResize where
76instance Arbitrary ImageResize where
78 arbitrary = oneof
77 arbitrary = oneof
79− [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))
78+ [ return $! ImageResize $! \i -> (i, (image_width i, image_height i))
80− , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))
79+ , return $! ImageResize $! \i -> (i, (image_width i, image_height i))
81− , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))
80+ , return $! ImageResize $! \i -> (i, (image_width i, image_height i))
82− , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))
81+ , return $! ImageResize $! \i -> (i, (image_width i, image_height i))
83− , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))
82+ , return $! ImageResize $! \i -> (i, (image_width i, image_height i))
84− , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))
83+ , return $! ImageResize $! \i -> (i, (image_width i, image_height i))
85 , do
84 , do
86 ImageResize f <- arbitrary
85 ImageResize f <- arbitrary
87 WidthResize g <- arbitrary
86 WidthResize g <- arbitrary
88− return $! ImageResize $! \i ->
87+ return $! ImageResize $! \i ->
89− let (i0, (_, outHeight)) = f i
88+ let (i_0, (_, out_height)) = f i
90− gI = g i0
89+ g_i = g i_0
91− in (fst gI, (snd gI, outHeight))
90+ in (fst g_i, (snd g_i, out_height))
92 , do
91 , do
93 ImageResize f <- arbitrary
92 ImageResize f <- arbitrary
94 HeightResize g <- arbitrary
93 HeightResize g <- arbitrary
95− return $! ImageResize $! \i ->
94+ return $! ImageResize $! \i ->
96− let (i0, (outWidth, _)) = f i
95+ let (i_0, (out_width, _)) = f i
97− gI = g i0
96+ g_i = g i_0
98− in (fst gI, (outWidth, snd gI))
97+ in (fst g_i, (out_width, snd g_i))
99 ]
98 ]
100
99
101
100
102instance Arbitrary SingleRowSingleAttrImage where
101instance Arbitrary SingleRowSingleAttrImage where
103 arbitrary = do
102 arbitrary = do
104− -- The text must contain at least one character. Otherwise the
103+ -- The text must contain at least one character. Otherwise the image simplifies to the
105− -- image simplifies to the IdImage which has a height of 0. If
104+ -- IdImage which has a height of 0. If this is to represent a single row then the height
106− -- this is to represent a single row then the height must be 1
105+ -- must be 1
107− singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)
106+ single_column_row_text <- Verify.resize 16 (listOf1 arbitrary)
108 a <- arbitrary
107 a <- arbitrary
109− let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]
108+ let out_image = horiz_cat $ [char a c | SingleColumnChar c <- single_column_row_text]
110− outWidth = length singleColumnRowText
109+ out_width = length single_column_row_text
111− return $ SingleRowSingleAttrImage a outWidth outImage
110+ return $ SingleRowSingleAttrImage a out_width out_image
112−
111+
113−data SingleRowTwoAttrImage
112+data SingleRowTwoAttrImage
114− = SingleRowTwoAttrImage
113+ = SingleRowTwoAttrImage
115− { part0 :: SingleRowSingleAttrImage
114+ { part_0 :: SingleRowSingleAttrImage
116− , part1 :: SingleRowSingleAttrImage
115+ , part_1 :: SingleRowSingleAttrImage
117− , joinImage :: Image
116+ , join_image :: Image
118 } deriving Show
117 } deriving Show
119
118
120instance Arbitrary SingleRowTwoAttrImage where
119instance Arbitrary SingleRowTwoAttrImage where
121 arbitrary = do
120 arbitrary = do
122 p0 <- arbitrary
121 p0 <- arbitrary
123 p1 <- arbitrary
122 p1 <- arbitrary
124− return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1)
123+ return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1)
125
124
126−data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
125+data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
127− { stackImage :: Image
126+ { stack_image :: Image
128− , stackSourceImages :: [SingleRowSingleAttrImage]
127+ , stack_source_images :: [SingleRowSingleAttrImage]
129− , stackWidth :: Int
128+ , stack_width :: Int
130− , stackHeight :: Int
129+ , stack_height :: Int
131 }
130 }
132 deriving Show
131 deriving Show
133
132
134instance Arbitrary SingleAttrSingleSpanStack where
133instance Arbitrary SingleAttrSingleSpanStack where
135 arbitrary = do
134 arbitrary = do
136− imageList <- Verify.resize 16 (listOf1 arbitrary)
135+ image_list <- Verify.resize 16 (listOf1 arbitrary)
137− return $ mkSingleAttrSingleSpanStack imageList
136+ return $ mk_single_attr_single_span_stack image_list
138 shrink s = do
137 shrink s = do
139− imageList <- shrink $ stackSourceImages s
138+ image_list <- shrink $ stack_source_images s
140− if null imageList
139+ if null image_list
141 then []
140 then []
142− else return $ mkSingleAttrSingleSpanStack imageList
141+ else return $ mk_single_attr_single_span_stack image_list
143
142
144−mkSingleAttrSingleSpanStack imageList =
143+mk_single_attr_single_span_stack image_list =
145− let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ]
144+ let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]
146− in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList)
145+ in SingleAttrSingleSpanStack image image_list (maximum $ map expected_columns image_list)
147− (toEnum $ length imageList)
146+ (toEnum $ length image_list)
148
147
149instance Arbitrary Image where
148instance Arbitrary Image where
150 arbitrary = oneof
149 arbitrary = oneof
151 [ return EmptyImage
150 [ return EmptyImage
152 , do
151 , do
153− SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary
152+ SingleAttrSingleSpanStack {stack_image} <- Verify.resize 8 arbitrary
154 ImageResize f <- Verify.resize 2 arbitrary
153 ImageResize f <- Verify.resize 2 arbitrary
155− return $! fst $! f stackImage
154+ return $! fst $! f stack_image
156 , do
155 , do
157− SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary
156+ SingleAttrSingleSpanStack {stack_image} <- Verify.resize 8 arbitrary
158 ImageResize f <- Verify.resize 2 arbitrary
157 ImageResize f <- Verify.resize 2 arbitrary
159− return $! fst $! f stackImage
158+ return $! fst $! f stack_image
160 , do
159 , do
161− i0 <- arbitrary
160+ i_0 <- arbitrary
162− i1 <- arbitrary
161+ i_1 <- arbitrary
163− let i = i0 <|> i1
162+ let i = i_0 <|> i_1
164 ImageResize f <- Verify.resize 2 arbitrary
163 ImageResize f <- Verify.resize 2 arbitrary
165 return $! fst $! f i
164 return $! fst $! f i
166 , do
165 , do
167− i0 <- arbitrary
166+ i_0 <- arbitrary
168− i1 <- arbitrary
167+ i_1 <- arbitrary
169− let i = i0 <-> i1
168+ let i = i_0 <-> i_1
170 ImageResize f <- Verify.resize 2 arbitrary
169 ImageResize f <- Verify.resize 2 arbitrary
171 return $! fst $! f i
170 return $! fst $! f i
172 ]
171 ]
173 {-
172 {-
174− shrink i@(HorizJoin {partLeft, partRight}) = do
173+ shrink i@(HorizJoin {part_left, part_right}) = do
175− let !i_alt = backgroundFill (imageWidth i) (imageHeight i)
174+ let !i_alt = background_fill (image_width i) (image_height i)
176− !partLeft' <- shrink partLeft
175+ !part_left' <- shrink part_left
177− !partRight' <- shrink partRight
176+ !part_right' <- shrink part_right
178− [i_alt, partLeft' <|> partRight']
177+ [i_alt, part_left' <|> part_right']
179− shrink i@(VertJoin {partTop, partBottom}) = do
178+ shrink i@(VertJoin {part_top, part_bottom}) = do
180− let !i_alt = backgroundFill (imageWidth i) (imageHeight i)
179+ let !i_alt = background_fill (image_width i) (image_height i)
181− !partTop' <- shrink partTop
180+ !part_top' <- shrink part_top
182− !partBottom' <- shrink partBottom
181+ !part_bottom' <- shrink part_bottom
183− [i_alt, partTop' <-> partBottom']
182+ [i_alt, part_top' <-> part_bottom']
184− shrink i@(CropRight {croppedImage, outputWidth}) = do
183+ shrink i@(CropRight {cropped_image, output_width}) = do
185− let !i_alt = backgroundFill (imageWidth i) (imageHeight i)
184+ let !i_alt = background_fill (image_width i) (image_height i)
186− [i_alt, croppedImage]
185+ [i_alt, cropped_image]
187− shrink i@(CropLeft {croppedImage, leftSkip, outputWidth}) = do
186+ shrink i@(CropLeft {cropped_image, left_skip, output_width}) = do
188− let !i_alt = backgroundFill (imageWidth i) (imageHeight i)
187+ let !i_alt = background_fill (image_width i) (image_height i)
189− [i_alt, croppedImage]
188+ [i_alt, cropped_image]
190− shrink i@(CropBottom {croppedImage, outputHeight}) = do
189+ shrink i@(CropBottom {cropped_image, output_height}) = do
191− let !i_alt = backgroundFill (imageWidth i) (imageHeight i)
190+ let !i_alt = background_fill (image_width i) (image_height i)
192− [i_alt, croppedImage]
191+ [i_alt, cropped_image]
193− shrink i@(CropTop {croppedImage, topSkip, outputHeight}) = do
192+ shrink i@(CropTop {cropped_image, top_skip, output_height}) = do
194− let !i_alt = backgroundFill (imageWidth i) (imageHeight i)
193+ let !i_alt = background_fill (image_width i) (image_height i)
195− [i_alt, croppedImage]
194+ [i_alt, cropped_image]
196− shrink i = [emptyImage, backgroundFill (imageWidth i) (imageHeight i)]
195+ shrink i = [empty_image, background_fill (image_width i) (image_height i)]
197 -}
196 -}
198
197
199data CropOperation
198data CropOperation
@@ -216,3 +215,4 @@ instance Arbitrary Translation where
216 y <- arbitrary `suchThat` (> 0)
215 y <- arbitrary `suchThat` (> 0)
217 let i' = translate x y i
216 let i' = translate x y i
218 return $ Translation i (x,y) i'
217 return $ Translation i (x,y) i'
218+
test/Verify/Graphics/Vty/Output.hs+16−15
@@ -1,20 +1,19 @@
1module Verify.Graphics.Vty.Output where
1module Verify.Graphics.Vty.Output where
2
2
3−import Control.Applicative ((<$>))
4−
5import Graphics.Vty.Output.Mock
3import Graphics.Vty.Output.Mock
6
4
5+import qualified Data.ByteString as BS
7import Data.IORef
6import Data.IORef
8import qualified Data.String.UTF8 as UTF8
7import qualified Data.String.UTF8 as UTF8
9
8
10import Test.QuickCheck.Property
9import Test.QuickCheck.Property
11
10
12−-- A list of terminals that should be supported. This started with a
11+-- A list of terminals that should be supported.
13−-- list of terminals ubuntu supported. Then those terminals that really
12+-- This started with a list of terminals ubuntu supported. Then those terminals that really could
14−-- could not be supported were removed. Then a few more were pruned
13+-- not be supported were removed. Then a few more were pruned until a reasonable looking set was
15−-- until a reasonable looking set was made.
14+-- made.
16−terminalsOfInterest :: [String]
15+terminals_of_interest :: [String]
17−terminalsOfInterest =
16+terminals_of_interest =
18 [ "vt100"
17 [ "vt100"
19 , "vt220"
18 , "vt220"
20 , "vt102"
19 , "vt102"
@@ -48,12 +47,14 @@ terminalsOfInterest =
48 , "cygwin"
47 , "cygwin"
49 ]
48 ]
50
49
51−compareMockOutput :: MockData -> String -> IO Result
50+compare_mock_output :: MockData -> String -> IO Result
52−compareMockOutput mockData expectedStr = do
51+compare_mock_output mock_data expected_str = do
53− outStr <- UTF8.toString <$> readIORef mockData
52+ out_bytes <- readIORef mock_data >>= return . UTF8.toRep
54− if outStr /= expectedStr
53+ let expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected_str
55− then return $ failed { reason = "bytes\n" ++ outStr
54+ if out_bytes /= expected_bytes
56− ++ "\nare not the expected bytes\n"
55+ then return $ failed { reason = "bytes\n" ++ show out_bytes
57− ++ expectedStr
56+ ++ "\nare not the expected bytes\n"
57+ ++ show expected_bytes
58 }
58 }
59 else return succeeded
59 else return succeeded
60+
test/Verify/Graphics/Vty/Picture.hs+21−21
@@ -1,9 +1,8 @@
1{-# LANGUAGE DisambiguateRecordFields #-}
1{-# LANGUAGE DisambiguateRecordFields #-}
2−module Verify.Graphics.Vty.Picture
2+module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture
3− ( module Verify.Graphics.Vty.Picture
3+ , module Graphics.Vty.Picture
4− , module Graphics.Vty.Picture
4+ )
5− )
5+ where
6−where
7
6
8import Verify.Graphics.Vty.Prelude
7import Verify.Graphics.Vty.Prelude
9
8
@@ -15,9 +14,9 @@ import Verify.Graphics.Vty.Image
15
14
16import Verify
15import Verify
17
16
18−data DefaultPic = DefaultPic
17+data DefaultPic = DefaultPic
19− { defaultPic :: Picture
18+ { default_pic :: Picture
20− , defaultWin :: MockWindow
19+ , default_win :: MockWindow
21 }
20 }
22
21
23instance Show DefaultPic where
22instance Show DefaultPic where
@@ -27,26 +26,27 @@ instance Show DefaultPic where
27instance Arbitrary DefaultPic where
26instance Arbitrary DefaultPic where
28 arbitrary = do
27 arbitrary = do
29 DefaultImage image <- arbitrary
28 DefaultImage image <- arbitrary
30− let win = MockWindow (imageWidth image) (imageHeight image)
29+ let win = MockWindow (image_width image) (image_height image)
31− return $ DefaultPic (picForImage image)
30+ return $ DefaultPic (pic_for_image image)
32− win
31+ win
33−
32+
34−data PicWithBGAttr = PicWithBGAttr
33+data PicWithBGAttr = PicWithBGAttr
35− { withAttrPic :: Picture
34+ { with_attr_pic :: Picture
36− , withAttrWin :: MockWindow
35+ , with_attr_win :: MockWindow
37− , withAttrSpecifiedAttr :: Attr
36+ , with_attr_specified_attr :: Attr
38 } deriving ( Show )
37 } deriving ( Show )
39
38
40instance Arbitrary PicWithBGAttr where
39instance Arbitrary PicWithBGAttr where
41 arbitrary = do
40 arbitrary = do
42 DefaultImage image <- arbitrary
41 DefaultImage image <- arbitrary
43− let win = MockWindow (imageWidth image) (imageHeight image)
42+ let win = MockWindow (image_width image) (image_height image)
44 attr <- arbitrary
43 attr <- arbitrary
45− return $ PicWithBGAttr (picForImage image)
44+ return $ PicWithBGAttr (pic_for_image image)
46− win
45+ win
47 attr
46 attr
48−
47+
49instance Arbitrary Picture where
48instance Arbitrary Picture where
50 arbitrary = do
49 arbitrary = do
51 layers <- Verify.resize 20 (listOf1 arbitrary)
50 layers <- Verify.resize 20 (listOf1 arbitrary)
52− return $ picForLayers layers
51+ return $ pic_for_layers layers
52+
test/Verify/Graphics/Vty/Prelude.hs+7−5
@@ -1,8 +1,10 @@
1−module Verify.Graphics.Vty.Prelude
1+module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude
2− ( module Verify.Graphics.Vty.Prelude
2+ , module Graphics.Vty.Prelude
3− , MockWindow(..)
3+ , MockWindow(..)
4− )
4+ )
5−where
5+ where
6+
7+import Graphics.Vty.Prelude
6
8
7import Graphics.Vty.Debug
9import Graphics.Vty.Debug
8
10
test/Verify/Graphics/Vty/Span.hs+12−12
@@ -1,9 +1,8 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2−module Verify.Graphics.Vty.Span
2+module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span
3− ( module Verify.Graphics.Vty.Span
3+ , module Graphics.Vty.Span
4− , module Graphics.Vty.Span
4+ )
5− )
5+ where
6−where
7
6
8import Graphics.Vty.Debug
7import Graphics.Vty.Debug
9import Graphics.Vty.Span
8import Graphics.Vty.Span
@@ -15,23 +14,24 @@ import Data.Word
15
14
16import Verify
15import Verify
17
16
18−isAttrSpanOp :: SpanOp -> Bool
17+is_attr_span_op :: SpanOp -> Bool
19−isAttrSpanOp TextSpan {} = True
18+is_attr_span_op TextSpan {} = True
20−isAttrSpanOp _ = False
19+is_attr_span_op _ = False
21
20
22−verifyAllSpansHaveWidth i spans w
21+verify_all_spans_have_width i spans w
23− = let v = map (\s -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)
22+ = let v = map (\s -> (span_ops_effected_columns s /= w, s)) (Vector.toList spans)
24 in case any ((== True) . fst) v of
23 in case any ((== True) . fst) v of
25 False -> succeeded
24 False -> succeeded
26− True -> failed { reason = "Not all spans contained operations defining exactly "
25+ True -> failed { reason = "Not all spans contained operations defining exactly "
27 ++ show w
26 ++ show w
28 ++ " columns of output - \n"
27 ++ " columns of output - \n"
29 ++ (concatMap ((++ "\n") . show)) v
28 ++ (concatMap ((++ "\n") . show)) v
30 }
29 }
31
30
32−verifyOpsEquality i_ops i_alt_ops =
31+verify_ops_equality i_ops i_alt_ops =
33 if i_ops == i_alt_ops
32 if i_ops == i_alt_ops
34 then succeeded
33 then succeeded
35 else failed { reason = "ops for alternate image " ++ show i_alt_ops
34 else failed { reason = "ops for alternate image " ++ show i_alt_ops
36 ++ " are not the same as " ++ show i_ops
35 ++ " are not the same as " ++ show i_ops
37 }
36 }
37+
test/VerifyAttributeOps.hsnew file+9
@@ -0,0 +1,9 @@
1+module VerifyAttributeOps where
2+
3+import Verify.Graphics.Vty.Attributes
4+
5+import Verify
6+
7+tests :: IO [Test]
8+tests = return []
9+
test/VerifyColor240.hsdeleted−269
@@ -1,269 +0,0 @@
1−module VerifyColor240 where
2−
3−import Data.Word(Word8)
4−import Verify
5−
6−import Graphics.Vty.Attributes.Color240(rgbColorToColor240)
7−
8−oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8
9−oldRgbColorToColor240 r g b
10− | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
11− | r == 8 && g == 8 && b == 8 = 216
12− | r == 18 && g == 18 && b == 18 = 217
13− | r == 28 && g == 28 && b == 28 = 218
14− | r == 38 && g == 38 && b == 38 = 219
15− | r == 48 && g == 48 && b == 48 = 220
16− | r == 58 && g == 58 && b == 58 = 221
17− | r == 68 && g == 68 && b == 68 = 222
18− | r == 78 && g == 78 && b == 78 = 223
19− | r == 88 && g == 88 && b == 88 = 224
20− | r == 98 && g == 98 && b == 98 = 225
21− | r == 108 && g == 108 && b == 108 = 226
22− | r == 118 && g == 118 && b == 118 = 227
23− | r == 128 && g == 128 && b == 128 = 228
24− | r == 138 && g == 138 && b == 138 = 229
25− | r == 148 && g == 148 && b == 148 = 230
26− | r == 158 && g == 158 && b == 158 = 231
27− | r == 168 && g == 168 && b == 168 = 232
28− | r == 178 && g == 178 && b == 178 = 233
29− | r == 188 && g == 188 && b == 188 = 234
30− | r == 198 && g == 198 && b == 198 = 235
31− | r == 208 && g == 208 && b == 208 = 236
32− | r == 218 && g == 218 && b == 218 = 237
33− | r == 228 && g == 228 && b == 228 = 238
34− | r == 238 && g == 238 && b == 238 = 239
35− | r <= 0 && g <= 0 && b <= 0 = 0
36− | r <= 0 && g <= 0 && b <= 95 = 1
37− | r <= 0 && g <= 0 && b <= 135 = 2
38− | r <= 0 && g <= 0 && b <= 175 = 3
39− | r <= 0 && g <= 0 && b <= 215 = 4
40− | r <= 0 && g <= 0 && b <= 255 = 5
41− | r <= 0 && g <= 95 && b <= 0 = 6
42− | r <= 0 && g <= 95 && b <= 95 = 7
43− | r <= 0 && g <= 95 && b <= 135 = 8
44− | r <= 0 && g <= 95 && b <= 175 = 9
45− | r <= 0 && g <= 95 && b <= 215 = 10
46− | r <= 0 && g <= 95 && b <= 255 = 11
47− | r <= 0 && g <= 135 && b <= 0 = 12
48− | r <= 0 && g <= 135 && b <= 95 = 13
49− | r <= 0 && g <= 135 && b <= 135 = 14
50− | r <= 0 && g <= 135 && b <= 175 = 15
51− | r <= 0 && g <= 135 && b <= 215 = 16
52− | r <= 0 && g <= 135 && b <= 255 = 17
53− | r <= 0 && g <= 175 && b <= 0 = 18
54− | r <= 0 && g <= 175 && b <= 95 = 19
55− | r <= 0 && g <= 175 && b <= 135 = 20
56− | r <= 0 && g <= 175 && b <= 175 = 21
57− | r <= 0 && g <= 175 && b <= 215 = 22
58− | r <= 0 && g <= 175 && b <= 255 = 23
59− | r <= 0 && g <= 215 && b <= 0 = 24
60− | r <= 0 && g <= 215 && b <= 95 = 25
61− | r <= 0 && g <= 215 && b <= 135 = 26
62− | r <= 0 && g <= 215 && b <= 175 = 27
63− | r <= 0 && g <= 215 && b <= 215 = 28
64− | r <= 0 && g <= 215 && b <= 255 = 29
65− | r <= 0 && g <= 255 && b <= 0 = 30
66− | r <= 0 && g <= 255 && b <= 95 = 31
67− | r <= 0 && g <= 255 && b <= 135 = 32
68− | r <= 0 && g <= 255 && b <= 175 = 33
69− | r <= 0 && g <= 255 && b <= 215 = 34
70− | r <= 0 && g <= 255 && b <= 255 = 35
71− | r <= 95 && g <= 0 && b <= 0 = 36
72− | r <= 95 && g <= 0 && b <= 95 = 37
73− | r <= 95 && g <= 0 && b <= 135 = 38
74− | r <= 95 && g <= 0 && b <= 175 = 39
75− | r <= 95 && g <= 0 && b <= 215 = 40
76− | r <= 95 && g <= 0 && b <= 255 = 41
77− | r <= 95 && g <= 95 && b <= 0 = 42
78− | r <= 95 && g <= 95 && b <= 95 = 43
79− | r <= 95 && g <= 95 && b <= 135 = 44
80− | r <= 95 && g <= 95 && b <= 175 = 45
81− | r <= 95 && g <= 95 && b <= 215 = 46
82− | r <= 95 && g <= 95 && b <= 255 = 47
83− | r <= 95 && g <= 135 && b <= 0 = 48
84− | r <= 95 && g <= 135 && b <= 95 = 49
85− | r <= 95 && g <= 135 && b <= 135 = 50
86− | r <= 95 && g <= 135 && b <= 175 = 51
87− | r <= 95 && g <= 135 && b <= 215 = 52
88− | r <= 95 && g <= 135 && b <= 255 = 53
89− | r <= 95 && g <= 175 && b <= 0 = 54
90− | r <= 95 && g <= 175 && b <= 95 = 55
91− | r <= 95 && g <= 175 && b <= 135 = 56
92− | r <= 95 && g <= 175 && b <= 175 = 57
93− | r <= 95 && g <= 175 && b <= 215 = 58
94− | r <= 95 && g <= 175 && b <= 255 = 59
95− | r <= 95 && g <= 215 && b <= 0 = 60
96− | r <= 95 && g <= 215 && b <= 95 = 61
97− | r <= 95 && g <= 215 && b <= 135 = 62
98− | r <= 95 && g <= 215 && b <= 175 = 63
99− | r <= 95 && g <= 215 && b <= 215 = 64
100− | r <= 95 && g <= 215 && b <= 255 = 65
101− | r <= 95 && g <= 255 && b <= 0 = 66
102− | r <= 95 && g <= 255 && b <= 95 = 67
103− | r <= 95 && g <= 255 && b <= 135 = 68
104− | r <= 95 && g <= 255 && b <= 175 = 69
105− | r <= 95 && g <= 255 && b <= 215 = 70
106− | r <= 95 && g <= 255 && b <= 255 = 71
107− | r <= 135 && g <= 0 && b <= 0 = 72
108− | r <= 135 && g <= 0 && b <= 95 = 73
109− | r <= 135 && g <= 0 && b <= 135 = 74
110− | r <= 135 && g <= 0 && b <= 175 = 75
111− | r <= 135 && g <= 0 && b <= 215 = 76
112− | r <= 135 && g <= 0 && b <= 255 = 77
113− | r <= 135 && g <= 95 && b <= 0 = 78
114− | r <= 135 && g <= 95 && b <= 95 = 79
115− | r <= 135 && g <= 95 && b <= 135 = 80
116− | r <= 135 && g <= 95 && b <= 175 = 81
117− | r <= 135 && g <= 95 && b <= 215 = 82
118− | r <= 135 && g <= 95 && b <= 255 = 83
119− | r <= 135 && g <= 135 && b <= 0 = 84
120− | r <= 135 && g <= 135 && b <= 95 = 85
121− | r <= 135 && g <= 135 && b <= 135 = 86
122− | r <= 135 && g <= 135 && b <= 175 = 87
123− | r <= 135 && g <= 135 && b <= 215 = 88
124− | r <= 135 && g <= 135 && b <= 255 = 89
125− | r <= 135 && g <= 175 && b <= 0 = 90
126− | r <= 135 && g <= 175 && b <= 95 = 91
127− | r <= 135 && g <= 175 && b <= 135 = 92
128− | r <= 135 && g <= 175 && b <= 175 = 93
129− | r <= 135 && g <= 175 && b <= 215 = 94
130− | r <= 135 && g <= 175 && b <= 255 = 95
131− | r <= 135 && g <= 215 && b <= 0 = 96
132− | r <= 135 && g <= 215 && b <= 95 = 97
133− | r <= 135 && g <= 215 && b <= 135 = 98
134− | r <= 135 && g <= 215 && b <= 175 = 99
135− | r <= 135 && g <= 215 && b <= 215 = 100
136− | r <= 135 && g <= 215 && b <= 255 = 101
137− | r <= 135 && g <= 255 && b <= 0 = 102
138− | r <= 135 && g <= 255 && b <= 95 = 103
139− | r <= 135 && g <= 255 && b <= 135 = 104
140− | r <= 135 && g <= 255 && b <= 175 = 105
141− | r <= 135 && g <= 255 && b <= 215 = 106
142− | r <= 135 && g <= 255 && b <= 255 = 107
143− | r <= 175 && g <= 0 && b <= 0 = 108
144− | r <= 175 && g <= 0 && b <= 95 = 109
145− | r <= 175 && g <= 0 && b <= 135 = 110
146− | r <= 175 && g <= 0 && b <= 175 = 111
147− | r <= 175 && g <= 0 && b <= 215 = 112
148− | r <= 175 && g <= 0 && b <= 255 = 113
149− | r <= 175 && g <= 95 && b <= 0 = 114
150− | r <= 175 && g <= 95 && b <= 95 = 115
151− | r <= 175 && g <= 95 && b <= 135 = 116
152− | r <= 175 && g <= 95 && b <= 175 = 117
153− | r <= 175 && g <= 95 && b <= 215 = 118
154− | r <= 175 && g <= 95 && b <= 255 = 119
155− | r <= 175 && g <= 135 && b <= 0 = 120
156− | r <= 175 && g <= 135 && b <= 95 = 121
157− | r <= 175 && g <= 135 && b <= 135 = 122
158− | r <= 175 && g <= 135 && b <= 175 = 123
159− | r <= 175 && g <= 135 && b <= 215 = 124
160− | r <= 175 && g <= 135 && b <= 255 = 125
161− | r <= 175 && g <= 175 && b <= 0 = 126
162− | r <= 175 && g <= 175 && b <= 95 = 127
163− | r <= 175 && g <= 175 && b <= 135 = 128
164− | r <= 175 && g <= 175 && b <= 175 = 129
165− | r <= 175 && g <= 175 && b <= 215 = 130
166− | r <= 175 && g <= 175 && b <= 255 = 131
167− | r <= 175 && g <= 215 && b <= 0 = 132
168− | r <= 175 && g <= 215 && b <= 95 = 133
169− | r <= 175 && g <= 215 && b <= 135 = 134
170− | r <= 175 && g <= 215 && b <= 175 = 135
171− | r <= 175 && g <= 215 && b <= 215 = 136
172− | r <= 175 && g <= 215 && b <= 255 = 137
173− | r <= 175 && g <= 255 && b <= 0 = 138
174− | r <= 175 && g <= 255 && b <= 95 = 139
175− | r <= 175 && g <= 255 && b <= 135 = 140
176− | r <= 175 && g <= 255 && b <= 175 = 141
177− | r <= 175 && g <= 255 && b <= 215 = 142
178− | r <= 175 && g <= 255 && b <= 255 = 143
179− | r <= 215 && g <= 0 && b <= 0 = 144
180− | r <= 215 && g <= 0 && b <= 95 = 145
181− | r <= 215 && g <= 0 && b <= 135 = 146
182− | r <= 215 && g <= 0 && b <= 175 = 147
183− | r <= 215 && g <= 0 && b <= 215 = 148
184− | r <= 215 && g <= 0 && b <= 255 = 149
185− | r <= 215 && g <= 95 && b <= 0 = 150
186− | r <= 215 && g <= 95 && b <= 95 = 151
187− | r <= 215 && g <= 95 && b <= 135 = 152
188− | r <= 215 && g <= 95 && b <= 175 = 153
189− | r <= 215 && g <= 95 && b <= 215 = 154
190− | r <= 215 && g <= 95 && b <= 255 = 155
191− | r <= 215 && g <= 135 && b <= 0 = 156
192− | r <= 215 && g <= 135 && b <= 95 = 157
193− | r <= 215 && g <= 135 && b <= 135 = 158
194− | r <= 215 && g <= 135 && b <= 175 = 159
195− | r <= 215 && g <= 135 && b <= 215 = 160
196− | r <= 215 && g <= 135 && b <= 255 = 161
197− | r <= 215 && g <= 175 && b <= 0 = 162
198− | r <= 215 && g <= 175 && b <= 95 = 163
199− | r <= 215 && g <= 175 && b <= 135 = 164
200− | r <= 215 && g <= 175 && b <= 175 = 165
201− | r <= 215 && g <= 175 && b <= 215 = 166
202− | r <= 215 && g <= 175 && b <= 255 = 167
203− | r <= 215 && g <= 215 && b <= 0 = 168
204− | r <= 215 && g <= 215 && b <= 95 = 169
205− | r <= 215 && g <= 215 && b <= 135 = 170
206− | r <= 215 && g <= 215 && b <= 175 = 171
207− | r <= 215 && g <= 215 && b <= 215 = 172
208− | r <= 215 && g <= 215 && b <= 255 = 173
209− | r <= 215 && g <= 255 && b <= 0 = 174
210− | r <= 215 && g <= 255 && b <= 95 = 175
211− | r <= 215 && g <= 255 && b <= 135 = 176
212− | r <= 215 && g <= 255 && b <= 175 = 177
213− | r <= 215 && g <= 255 && b <= 215 = 178
214− | r <= 215 && g <= 255 && b <= 255 = 179
215− | r <= 255 && g <= 0 && b <= 0 = 180
216− | r <= 255 && g <= 0 && b <= 95 = 181
217− | r <= 255 && g <= 0 && b <= 135 = 182
218− | r <= 255 && g <= 0 && b <= 175 = 183
219− | r <= 255 && g <= 0 && b <= 215 = 184
220− | r <= 255 && g <= 0 && b <= 255 = 185
221− | r <= 255 && g <= 95 && b <= 0 = 186
222− | r <= 255 && g <= 95 && b <= 95 = 187
223− | r <= 255 && g <= 95 && b <= 135 = 188
224− | r <= 255 && g <= 95 && b <= 175 = 189
225− | r <= 255 && g <= 95 && b <= 215 = 190
226− | r <= 255 && g <= 95 && b <= 255 = 191
227− | r <= 255 && g <= 135 && b <= 0 = 192
228− | r <= 255 && g <= 135 && b <= 95 = 193
229− | r <= 255 && g <= 135 && b <= 135 = 194
230− | r <= 255 && g <= 135 && b <= 175 = 195
231− | r <= 255 && g <= 135 && b <= 215 = 196
232− | r <= 255 && g <= 135 && b <= 255 = 197
233− | r <= 255 && g <= 175 && b <= 0 = 198
234− | r <= 255 && g <= 175 && b <= 95 = 199
235− | r <= 255 && g <= 175 && b <= 135 = 200
236− | r <= 255 && g <= 175 && b <= 175 = 201
237− | r <= 255 && g <= 175 && b <= 215 = 202
238− | r <= 255 && g <= 175 && b <= 255 = 203
239− | r <= 255 && g <= 215 && b <= 0 = 204
240− | r <= 255 && g <= 215 && b <= 95 = 205
241− | r <= 255 && g <= 215 && b <= 135 = 206
242− | r <= 255 && g <= 215 && b <= 175 = 207
243− | r <= 255 && g <= 215 && b <= 215 = 208
244− | r <= 255 && g <= 215 && b <= 255 = 209
245− | r <= 255 && g <= 255 && b <= 0 = 210
246− | r <= 255 && g <= 255 && b <= 95 = 211
247− | r <= 255 && g <= 255 && b <= 135 = 212
248− | r <= 255 && g <= 255 && b <= 175 = 213
249− | r <= 255 && g <= 255 && b <= 215 = 214
250− | r <= 255 && g <= 255 && b <= 255 = 215
251− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
252− (fromIntegral r :: Int)
253− (fromIntegral g :: Int)
254− (fromIntegral b :: Int))
255−
256−sameColor :: Int -> Int -> Int -> Bool
257−sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b
258−
259−genVal :: Gen Int
260−genVal = chooseInt (0, 255)
261−
262−sameColorCheck :: Property
263−sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g)))
264−
265−tests :: IO [Test]
266−tests = return
267− [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck
268− ]
269−
test/VerifyConfig.hsdeleted−44
@@ -1,44 +0,0 @@
1−{-# LANGUAGE QuasiQuotes #-}
2−module Main where
3−
4−import Graphics.Vty.Config
5−import Graphics.Vty.Input.Events
6−
7−import Data.String.QQ
8−import qualified Data.ByteString.Char8 as B
9−
10−import Test.Framework
11−import Test.Framework.Providers.HUnit
12−import Test.HUnit hiding (Test)
13−
14−exampleConfig :: B.ByteString
15−exampleConfig = B.pack [s|
16−-- comments should be ignored.
17−map _ "\ESC[B" KUp []
18−askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored
19−map _ "\ESC[1;3B" KDown [MAlt]
20−map "xterm" "\ESC[1;3B" KDown [MAlt]
21−map "xterm-256-color" "\ESC[1;3B" KDown [MAlt]
22−debugLog "/tmp/vty-debug.txt"
23−|]
24−
25−exampleConfigConfig :: Config
26−exampleConfigConfig = defaultConfig
27− { debugLog = Just "/tmp/vty-debug.txt"
28− , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])
29− , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])
30− , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt])
31− , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt])
32− ]
33− }
34−
35−exampleConfigParses :: IO ()
36−exampleConfigParses =
37− assertEqual "example config parses as expected"
38− exampleConfigConfig
39− (runParseConfig "exampleConfig" exampleConfig)
40−
41−main :: IO ()
42−main = defaultMain
43− [ testCase "example config parses" $ exampleConfigParses
44− ]
test/VerifyCropSpanGeneration.hs+62−61
@@ -13,80 +13,81 @@ import Graphics.Vty.PictureToSpans
13
13
14import Verify
14import Verify
15
15
16−import qualified Data.Vector as Vector
16+import qualified Data.Vector as Vector
17−
17+
18−cropOpDisplayOps :: (Int -> Image -> Image) ->
18+crop_op_display_ops :: (Int -> Image -> Image) ->
19− Int -> Image -> (DisplayOps, Image)
19+ Int -> Image -> (DisplayOps, Image)
20−cropOpDisplayOps cropOp v i =
20+crop_op_display_ops crop_op v i =
21− let iOut = cropOp v i
21+ let i_out = crop_op v i
22− p = picForImage iOut
22+ p = pic_for_image i_out
23− w = MockWindow (imageWidth iOut) (imageHeight iOut)
23+ w = MockWindow (image_width i_out) (image_height i_out)
24− in (displayOpsForPic p (regionForWindow w), iOut)
24+ in (display_ops_for_pic p (region_for_window w), i_out)
25−
25+
26−widthCropOutputColumns :: (Int -> Image -> Image) ->
26+width_crop_output_columns :: (Int -> Image -> Image) ->
27− SingleAttrSingleSpanStack ->
27+ SingleAttrSingleSpanStack ->
28− NonNegative Int ->
28+ NonNegative Int ->
29− Property
29+ Property
30−widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==>
30+width_crop_output_columns crop_op s (NonNegative w) = stack_width s > w ==>
31− let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s)
31+ let (ops, i_out) = crop_op_display_ops crop_op w (stack_image s)
32− in verifyAllSpansHaveWidth iOut ops w
32+ in verify_all_spans_have_width i_out ops w
33−
33+
34−heightCropOutputColumns :: (Int -> Image -> Image) ->
34+height_crop_output_columns :: (Int -> Image -> Image) ->
35− SingleAttrSingleSpanStack ->
35+ SingleAttrSingleSpanStack ->
36− NonNegative Int ->
36+ NonNegative Int ->
37− Property
37+ Property
38−heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==>
38+height_crop_output_columns crop_op s (NonNegative h) = stack_height s > h ==>
39− let (ops, _) = cropOpDisplayOps cropOp h (stackImage s)
39+ let (ops, _) = crop_op_display_ops crop_op h (stack_image s)
40− in displayOpsRows ops == h
40+ in display_ops_rows ops == h
41−
41+
42−cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
42+crop_right_output_columns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
43−cropRightOutputColumns = widthCropOutputColumns cropRight
43+crop_right_output_columns = width_crop_output_columns crop_right
44−
44+
45−cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
45+crop_left_output_columns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
46−cropLeftOutputColumns = widthCropOutputColumns cropLeft
46+crop_left_output_columns = width_crop_output_columns crop_left
47−
47+
48−cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
48+crop_top_output_rows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
49−cropTopOutputRows = heightCropOutputColumns cropTop
49+crop_top_output_rows = height_crop_output_columns crop_top
50−
50+
51−cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
51+crop_bottom_output_rows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property
52−cropBottomOutputRows = heightCropOutputColumns cropBottom
52+crop_bottom_output_rows = height_crop_output_columns crop_bottom
53
53
54-- TODO: known benign failure.
54-- TODO: known benign failure.
55−cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property
55+crop_right_and_left_rejoined_equivalence :: SingleAttrSingleSpanStack -> Property
56−cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==>
56+crop_right_and_left_rejoined_equivalence stack = image_width (stack_image stack) `mod` 2 == 0 ==>
57− let i = stackImage stack
57+ let i = stack_image stack
58 -- the right part is made by cropping the image from the left.
58 -- the right part is made by cropping the image from the left.
59− iR = cropLeft (imageWidth i `div` 2) i
59+ i_r = crop_left (image_width i `div` 2) i
60 -- the left part is made by cropping the image from the right
60 -- the left part is made by cropping the image from the right
61− iL = cropRight (imageWidth i `div` 2) i
61+ i_l = crop_right (image_width i `div` 2) i
62− iAlt = iL <|> iR
62+ i_alt = i_l <|> i_r
63− iOps = displayOpsForImage i
63+ i_ops = display_ops_for_image i
64− iAltOps = displayOpsForImage iAlt
64+ i_alt_ops = display_ops_for_image i_alt
65− in verifyOpsEquality iOps iAltOps
65+ in verify_ops_equality i_ops i_alt_ops
66−
66+
67−cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property
67+crop_top_and_bottom_rejoined_equivalence :: SingleAttrSingleSpanStack -> Property
68−cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==>
68+crop_top_and_bottom_rejoined_equivalence stack = image_height (stack_image stack) `mod` 2 == 0 ==>
69− let i = stackImage stack
69+ let i = stack_image stack
70 -- the top part is made by cropping the image from the bottom.
70 -- the top part is made by cropping the image from the bottom.
71− iT = cropBottom (imageHeight i `div` 2) i
71+ i_t = crop_bottom (image_height i `div` 2) i
72 -- the bottom part is made by cropping the image from the top.
72 -- the bottom part is made by cropping the image from the top.
73− iB = cropTop (imageHeight i `div` 2) i
73+ i_b = crop_top (image_height i `div` 2) i
74− iAlt = iT <-> iB
74+ i_alt = i_t <-> i_b
75− in displayOpsForImage i == displayOpsForImage iAlt
75+ in display_ops_for_image i == display_ops_for_image i_alt
76
76
77tests :: IO [Test]
77tests :: IO [Test]
78−tests = return
78+tests = return
79 [ verify "cropping from the bottom produces display operations covering the expected rows"
79 [ verify "cropping from the bottom produces display operations covering the expected rows"
80− cropBottomOutputRows
80+ crop_bottom_output_rows
81 , verify "cropping from the top produces display operations covering the expected rows"
81 , verify "cropping from the top produces display operations covering the expected rows"
82− cropTopOutputRows
82+ crop_top_output_rows
83 , verify "cropping from the left produces display operations covering the expected columns"
83 , verify "cropping from the left produces display operations covering the expected columns"
84− cropLeftOutputColumns
84+ crop_left_output_columns
85 , verify "cropping from the right produces display operations covering the expected columns"
85 , verify "cropping from the right produces display operations covering the expected columns"
86− cropRightOutputColumns
86+ crop_right_output_columns
87 -- TODO: known benign failure.
87 -- TODO: known benign failure.
88 -- , verify "the output of a stack is the same as that stack cropped left & right and joined together"
88 -- , verify "the output of a stack is the same as that stack cropped left & right and joined together"
89− -- cropRightAndLeftRejoinedEquivalence
89+ -- crop_right_and_left_rejoined_equivalence
90 , verify "the output of a stack is the same as that stack cropped top & bottom and joined together"
90 , verify "the output of a stack is the same as that stack cropped top & bottom and joined together"
91− cropTopAndBottomRejoinedEquivalence
91+ crop_top_and_bottom_rejoined_equivalence
92 ]
92 ]
93+
test/VerifyEmptyImageProps.hs+2−3
@@ -1,14 +1,13 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyEmptyImageProps where
1module VerifyEmptyImageProps where
3
2
4import Verify
3import Verify
5
4
6-- should be exported by Graphics.Vty.Picture
5-- should be exported by Graphics.Vty.Picture
7−import Graphics.Vty.Image ( Image, emptyImage )
6+import Graphics.Vty.Picture ( Image, empty_image )
8
7
9tests :: IO [Test]
8tests :: IO [Test]
10tests = do
9tests = do
11 -- should provide an image type.
10 -- should provide an image type.
12− let _ :: Image = emptyImage
11+ let _ :: Image = empty_image
13 return []
12 return []
14
13
test/VerifyEvalTerminfoCaps.hs+33−35
@@ -1,10 +1,9 @@
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)
7−import Data.Terminfo.Eval
6+import Data.Terminfo.Eval
8import Data.Terminfo.Parse
7import Data.Terminfo.Parse
9import Control.DeepSeq
8import Control.DeepSeq
10
9
@@ -25,9 +24,8 @@ import Foreign.Marshal.Alloc (mallocBytes)
25import Foreign.Ptr (Ptr, minusPtr)
24import Foreign.Ptr (Ptr, minusPtr)
26import Numeric
25import Numeric
27
26
28−-- If a terminal defines one of the caps then it's expected to be
27+-- If a terminal defines one of the caps then it's expected to be parsable.
29−-- parsable.
28+caps_of_interest =
30−capsOfInterest =
31 [ "cup"
29 [ "cup"
32 , "sc"
30 , "sc"
33 , "rc"
31 , "rc"
@@ -47,46 +45,46 @@ capsOfInterest =
47 , "sgr0"
45 , "sgr0"
48 ]
46 ]
49
47
50−fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)
48+from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)
51
49
52tests :: IO [Test]
50tests :: IO [Test]
53tests = do
51tests = do
54− -- 1 MB should be big enough for any termcaps ;-)
52+ eval_buffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)
55− evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024)
53+ fmap concat $ forM terminals_of_interest $ \term_name -> do
56− fmap concat $ forM terminalsOfInterest $ \termName -> do
54+ putStrLn $ "adding tests for terminal: " ++ term_name
57− putStrLn $ "adding tests for terminal: " ++ termName
55+ mti <- try $ Terminfo.setupTerm term_name
58− mti <- try $ Terminfo.setupTerm termName
59 case mti of
56 case mti of
60− Left (_e :: SomeException)
57+ Left (_e :: SomeException)
61 -> return []
58 -> return []
62 Right ti -> do
59 Right ti -> do
63− fmap concat $ forM capsOfInterest $ \capName -> do
60+ fmap concat $ forM caps_of_interest $ \cap_name -> do
64− case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
61+ case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
65− Just capDef -> do
62+ Just cap_def -> do
66− putStrLn $ "\tadding test for cap: " ++ capName
63+ putStrLn $ "\tadding test for cap: " ++ cap_name
67− let testName = termName ++ "(" ++ capName ++ ")"
64+ let test_name = term_name ++ "(" ++ cap_name ++ ")"
68− case parseCapExpression capDef of
65+ case parse_cap_expression cap_def of
69− Left error -> return [verify testName (failed {reason = "parse error " ++ show error})]
66+ Left error -> return [verify test_name (failed {reason = "parse error " ++ show error})]
70− Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)]
67+ Right !cap_expr -> return [verify test_name (verify_eval_cap eval_buffer cap_expr)]
71 Nothing -> do
68 Nothing -> do
72 return []
69 return []
73
70
74−{-# NOINLINE verifyEvalCap #-}
71+{-# NOINLINE verify_eval_cap #-}
75−verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property
72+verify_eval_cap :: Ptr Word8 -> CapExpression -> Int -> Property
76−verifyEvalCap evalBuffer expr !junkInt = do
73+verify_eval_cap eval_buffer expr !junk_int = do
77− forAll (vector 9) $ \inputValues ->
74+ forAll (vector 9) $ \input_values ->
78− let write = writeCapExpr expr inputValues
75+ let write = write_cap_expr expr input_values
79− !byteCount = getBound write
76+ !byte_count = getBound write
80 in liftIOResult $ do
77 in liftIOResult $ do
81− let startPtr :: Ptr Word8 = evalBuffer
78+ let start_ptr :: Ptr Word8 = eval_buffer
82− forM_ [0..100] $ \i -> runWrite write startPtr
79+ forM_ [0..100] $ \i -> runWrite write start_ptr
83− endPtr <- runWrite write startPtr
80+ end_ptr <- runWrite write start_ptr
84− case endPtr `minusPtr` startPtr of
81+ case end_ptr `minusPtr` start_ptr of
85− count | count < 0 ->
82+ count | count < 0 ->
86 return $ failed { reason = "End pointer before start pointer." }
83 return $ failed { reason = "End pointer before start pointer." }
87− | toEnum count > byteCount ->
84+ | toEnum count > byte_count ->
88− return $ failed { reason = "End pointer past end of buffer by "
85+ return $ failed { reason = "End pointer past end of buffer by "
89− ++ show (toEnum count - byteCount)
86+ ++ show (toEnum count - byte_count)
90 }
87 }
91− | otherwise ->
88+ | otherwise ->
92 return succeeded
89 return succeeded
90+
test/VerifyImageOps.hs+126−126
@@ -1,4 +1,3 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyImageOps where
1module VerifyImageOps where
3
2
4import Graphics.Vty.Attributes
3import Graphics.Vty.Attributes
@@ -9,166 +8,167 @@ import Verify
9
8
10import Control.DeepSeq
9import Control.DeepSeq
11
10
12−twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool
11+two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool
13−twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =
12+two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) =
14− imageWidth (char defAttr c1 <|> char defAttr c2) == 2
13+ image_width (char def_attr c1 <|> char def_attr c2) == 2
15
14
16−manySwHorizConcat :: [SingleColumnChar] -> Bool
15+many_sw_horiz_concat :: [SingleColumnChar] -> Bool
17−manySwHorizConcat cs =
16+many_sw_horiz_concat cs =
18 let chars = [ char | SingleColumnChar char <- cs ]
17 let chars = [ char | SingleColumnChar char <- cs ]
19 l = fromIntegral $ length cs
18 l = fromIntegral $ length cs
20− in imageWidth ( horizCat $ map (char defAttr) chars ) == l
19+ in image_width ( horiz_cat $ map (char def_attr) chars ) == l
21
20
22−twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool
21+two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool
23−twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =
22+two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) =
24− imageHeight (char defAttr c1 <-> char defAttr c2) == 2
23+ image_height (char def_attr c1 <-> char def_attr c2) == 2
25
24
26−horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool
25+horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool
27−horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
26+horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
28− (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
27+ (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2
29− ==
28+ ==
30− char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)
29+ char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)
31
30
32−twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
31+two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool
33−twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
32+two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) =
34− imageWidth (char defAttr c1 <|> char defAttr c2) == 4
33+ image_width (char def_attr c1 <|> char def_attr c2) == 4
35
34
36−manyDwHorizConcat :: [DoubleColumnChar] -> Bool
35+many_dw_horiz_concat :: [DoubleColumnChar] -> Bool
37−manyDwHorizConcat cs =
36+many_dw_horiz_concat cs =
38 let chars = [ char | DoubleColumnChar char <- cs ]
37 let chars = [ char | DoubleColumnChar char <- cs ]
39 l = fromIntegral $ length cs
38 l = fromIntegral $ length cs
40− in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2
39+ in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2
41−
40+
42−twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
41+two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool
43−twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
42+two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) =
44− imageHeight (char defAttr c1 <-> char defAttr c2) == 2
43+ image_height (char def_attr c1 <-> char def_attr c2) == 2
45−
44+
46−horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool
45+horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool
47−horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
46+horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
48− (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
47+ (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2
49− ==
48+ ==
50− char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)
49+ char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)
51−
50+
52−vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool
51+vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool
53−vertContatSingleRow (NonEmpty stack) =
52+vert_contat_single_row (NonEmpty stack) =
54− let expectedHeight :: Int = length stack
53+ let expected_height :: Int = length stack
55− stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]
54+ stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ]
56− in imageHeight stackImage == expectedHeight
55+ in image_height stack_image == expected_height
57−
56+
58−disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage
57+disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage
59− -> NonEmptyList SingleRowSingleAttrImage
60− -> Bool
61−disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =
62− let expectedHeight :: Int = max (length stack0) (length stack1)
63− stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
64− stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
65− in imageHeight (stackImage0 <|> stackImage1) == expectedHeight
66−
67−
68−disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
69 -> NonEmptyList SingleRowSingleAttrImage
58 -> NonEmptyList SingleRowSingleAttrImage
70 -> Bool
59 -> Bool
71−disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
60+disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) =
72− let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
61+ let expected_height :: Int = max (length stack_0) (length stack_1)
73− stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
62+ stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
74− image = stackImage0 <|> stackImage1
63+ stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
75− expectedHeight = imageHeight image
64+ in image_height (stack_image_0 <|> stack_image_1) == expected_height
65+
66+
67+disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage
68+ -> NonEmptyList SingleRowSingleAttrImage
69+ -> Bool
70+disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =
71+ let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
72+ stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
73+ image = stack_image_0 <|> stack_image_1
74+ expected_height = image_height image
76 in case image of
75 in case image of
77− HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) )
76+ HorizJoin {} -> ( expected_height == (image_height $ part_left image) )
78− &&
77+ &&
79− ( expectedHeight == (imageHeight $ partRight image) )
78+ ( expected_height == (image_height $ part_right image) )
80 _ -> True
79 _ -> True
81
80
82−disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage
81+disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage
83− -> NonEmptyList SingleRowSingleAttrImage
84− -> Bool
85−disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) =
86− let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
87− stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
88− stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
89− stack0Image = vertCat stack0Images
90− stack1Image = vertCat stack1Images
91− image = stack0Image <-> stack1Image
92− in imageWidth image == expectedWidth
93−
94−disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
95 -> NonEmptyList SingleRowSingleAttrImage
82 -> NonEmptyList SingleRowSingleAttrImage
96 -> Bool
83 -> Bool
97−disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
84+disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) =
98− let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
85+ let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)
99− stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
86+ stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
100− stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
87+ stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
101− stack0Image = vertCat stack0Images
88+ stack_0_image = vert_cat stack_0_images
102− stack1Image = vertCat stack1Images
89+ stack_1_image = vert_cat stack_1_images
103− image = stack0Image <-> stack1Image
90+ image = stack_0_image <-> stack_1_image
91+ in image_width image == expected_width
92+
93+disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage
94+ -> NonEmptyList SingleRowSingleAttrImage
95+ -> Bool
96+disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =
97+ let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)
98+ stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
99+ stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
100+ stack_0_image = vert_cat stack_0_images
101+ stack_1_image = vert_cat stack_1_images
102+ image = stack_0_image <-> stack_1_image
104 in case image of
103 in case image of
105− VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )
104+ VertJoin {} -> ( expected_width == (image_width $ part_top image) )
106 &&
105 &&
107− ( expectedWidth == (imageWidth $ partBottom image) )
106+ ( expected_width == (image_width $ part_bottom image) )
108 _ -> True
107 _ -> True
109
108
110−translationIsLinearOnOutSize :: Translation -> Bool
109+translation_is_linear_on_out_size :: Translation -> Bool
111−translationIsLinearOnOutSize (Translation i (x,y) i') =
110+translation_is_linear_on_out_size (Translation i (x,y) i') =
112− imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y
111+ image_width i' == image_width i + x && image_height i' == image_height i + y
113
112
114−paddingIsLinearOnOutSize :: Image -> Gen Bool
113+padding_is_linear_on_out_size :: Image -> Gen Bool
115−paddingIsLinearOnOutSize i = do
114+padding_is_linear_on_out_size i = do
116 l <- offset
115 l <- offset
117 t <- offset
116 t <- offset
118 r <- offset
117 r <- offset
119 b <- offset
118 b <- offset
120 let i' = pad l t r b i
119 let i' = pad l t r b i
121− return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b
120+ return $ image_width i' == image_width i + l + r && image_height i' == image_height i + t + b
122 where offset = choose (1,1024)
121 where offset = choose (1,1024)
123
122
124−cropLeftLimitsWidth :: Image -> Int -> Property
123+crop_left_limits_width :: Image -> Int -> Property
125−cropLeftLimitsWidth i v = v >= 0 ==>
124+crop_left_limits_width i v = v >= 0 ==>
126− v >= imageWidth (cropLeft v i)
125+ v >= image_width (crop_left v i)
127
126
128−cropRightLimitsWidth :: Image -> Int -> Property
127+crop_right_limits_width :: Image -> Int -> Property
129−cropRightLimitsWidth i v = v >= 0 ==>
128+crop_right_limits_width i v = v >= 0 ==>
130− v >= imageWidth (cropRight v i)
129+ v >= image_width (crop_right v i)
131
130
132−cropTopLimitsHeight :: Image -> Int -> Property
131+crop_top_limits_height :: Image -> Int -> Property
133−cropTopLimitsHeight i v = v >= 0 ==>
132+crop_top_limits_height i v = v >= 0 ==>
134− v >= imageHeight (cropTop v i)
133+ v >= image_height (crop_top v i)
135
134
136−cropBottomLimitsHeight :: Image -> Int -> Property
135+crop_bottom_limits_height :: Image -> Int -> Property
137−cropBottomLimitsHeight i v = v >= 0 ==>
136+crop_bottom_limits_height i v = v >= 0 ==>
138− v >= imageHeight (cropBottom v i)
137+ v >= image_height (crop_bottom 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
141−canShowImage :: Image -> Bool
140+can_show_image :: Image -> Bool
142−canShowImage i = length (show i) > 0
141+can_show_image i = length (show i) > 0
143
142
144−canRnfImage :: Image -> Bool
143+can_rnf_image :: Image -> Bool
145−canRnfImage i = rnf i == ()
144+can_rnf_image i = rnf i == ()
146
145
147−canPpImage :: Image -> Bool
146+can_pp_image :: Image -> Bool
148−canPpImage i = length (ppImageStructure i) > 0
147+can_pp_image i = length (pp_image_structure i) > 0
149
148
150tests :: IO [Test]
149tests :: IO [Test]
151tests = return
150tests = return
152− [ verify "twoSwHorizConcat" twoSwHorizConcat
151+ [ verify "two_sw_horiz_concat" two_sw_horiz_concat
153− , verify "manySwHorizConcat" manySwHorizConcat
152+ , verify "many_sw_horiz_concat" many_sw_horiz_concat
154− , verify "twoSwVertConcat" twoSwVertConcat
153+ , verify "two_sw_vert_concat" two_sw_vert_concat
155− , verify "horizConcatSwAssoc" horizConcatSwAssoc
154+ , verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc
156− , verify "manyDwHorizConcat" manyDwHorizConcat
155+ , verify "many_dw_horiz_concat" many_dw_horiz_concat
157− , verify "twoDwHorizConcat" twoDwHorizConcat
156+ , verify "two_dw_horiz_concat" two_dw_horiz_concat
158− , verify "twoDwVertConcat" twoDwVertConcat
157+ , verify "two_dw_vert_concat" two_dw_vert_concat
159− , verify "horizConcatDwAssoc" horizConcatDwAssoc
158+ , verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc
160− , verify "single row vert concats to correct height" vertContatSingleRow
159+ , verify "single row vert concats to correct height" vert_contat_single_row
161− , verify "disjointHeightHorizJoin" disjointHeightHorizJoin
160+ , verify "disjoint_height_horiz_join" disjoint_height_horiz_join
162− , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill
161+ , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill
163− , verify "disjointWidthVertJoin" disjointWidthVertJoin
162+ , verify "disjoint_width_vert_join" disjoint_width_vert_join
164− , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill
163+ , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill
165− , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize
164+ , verify "translation effects output dimensions linearly" translation_is_linear_on_out_size
166− , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize
165+ , verify "padding effects output dimensions linearly" padding_is_linear_on_out_size
167− , verify "crop left limits width" cropLeftLimitsWidth
166+ , verify "crop left limits width" crop_left_limits_width
168− , verify "crop right limits width" cropRightLimitsWidth
167+ , verify "crop right limits width" crop_right_limits_width
169− , verify "crop top limits height" cropTopLimitsHeight
168+ , verify "crop top limits height" crop_top_limits_height
170− , verify "crop bottom limits height" cropBottomLimitsHeight
169+ , verify "crop bottom limits height" crop_bottom_limits_height
171− , verify "can show image" canShowImage
170+ , verify "can show image" can_show_image
172− , verify "can rnf image" canRnfImage
171+ , verify "can rnf image" can_rnf_image
173− , verify "can pp image" canPpImage
172+ , verify "can pp image" can_pp_image
174 ]
173 ]
174+
test/VerifyImageTrans.hs+18−18
@@ -9,26 +9,26 @@ import Verify
9
9
10import Data.Word
10import Data.Word
11
11
12−isHorizTextOfColumns :: Image -> Int -> Bool
12+is_horiz_text_of_columns :: Image -> Int -> Bool
13−isHorizTextOfColumns (HorizText { outputWidth = inW }) expectedW = inW == expectedW
13+is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w
14−isHorizTextOfColumns (BGFill { outputWidth = inW }) expectedW = inW == expectedW
14+is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w
15−isHorizTextOfColumns _image _expectedW = False
15+is_horiz_text_of_columns _image _expected_w = False
16−
16+
17−verifyHorizContatWoAttrChangeSimplifies :: SingleRowSingleAttrImage -> Bool
17+verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool
18−verifyHorizContatWoAttrChangeSimplifies (SingleRowSingleAttrImage _attr charCount image) =
18+verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) =
19− isHorizTextOfColumns image charCount
19+ is_horiz_text_of_columns image char_count
20−
20+
21−verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool
21+verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool
22−verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0)
22+verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0)
23− (SingleRowSingleAttrImage attr1 charCount1 _image1)
23+ (SingleRowSingleAttrImage attr1 char_count1 _image1)
24− i
24+ i
25− )
25+ )
26− | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1)
26+ | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)
27− | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1)
27+ | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)
28
28
29tests :: IO [Test]
29tests :: IO [Test]
30tests = return
30tests = return
31− [ verify "verifyHorizContatWoAttrChangeSimplifies" verifyHorizContatWoAttrChangeSimplifies
31+ [ verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies
32− , verify "verifyHorizContatWAttrChangeSimplifies" verifyHorizContatWAttrChangeSimplifies
32+ , verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies
33 ]
33 ]
34
34
test/VerifyInline.hs+5−5
@@ -13,15 +13,15 @@ import Distribution.TestSuite
13import System.IO
13import System.IO
14
14
15tests :: IO [Test]
15tests :: IO [Test]
16−tests = concat <$> forM terminalsOfInterest (\termName -> return $
16+tests = concat <$> forM terminals_of_interest (\term_name -> return $
17 [ Test $ TestInstance
17 [ Test $ TestInstance
18 { name = "verify vty inline"
18 { name = "verify vty inline"
19 , run = do
19 , run = do
20 {- disabled because I cannot get useful output out of cabal why this fails.
20 {- disabled because I cannot get useful output out of cabal why this fails.
21− nullOut <- openFile "/dev/null" WriteMode
21+ null_out <- openFile "/dev/null" WriteMode
22− t <- TerminfoBased.reserveTerminal termName nullOut
22+ t <- TerminfoBased.reserve_terminal term_name null_out
23− putAttrChange t $ default_all
23+ put_attr_change t $ default_all
24− releaseTerminal t
24+ release_terminal t
25 -}
25 -}
26 return $ Finished Pass
26 return $ Finished Pass
27 , tags = []
27 , tags = []
test/VerifyLayersSpanGeneration.hs+94−96
@@ -4,7 +4,6 @@ module VerifyLayersSpanGeneration where
4
4
5import Verify.Graphics.Vty.Prelude
5import Verify.Graphics.Vty.Prelude
6
6
7−import Verify.Graphics.Vty.Attributes
8import Verify.Graphics.Vty.Image
7import Verify.Graphics.Vty.Image
9import Verify.Graphics.Vty.Picture
8import Verify.Graphics.Vty.Picture
10import Verify.Graphics.Vty.Span
9import Verify.Graphics.Vty.Span
@@ -14,117 +13,116 @@ import Graphics.Vty.PictureToSpans
14
13
15import Verify
14import Verify
16
15
17−import qualified Data.Vector as Vector
16+import qualified Data.Vector as Vector
18
17
19−largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
18+larger_horiz_span_occlusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
20−largerHorizSpanOcclusion row0 row1 =
19+larger_horiz_span_occlusion row_0 row_1 =
21− let i0 = rowImage row0
20+ let i_0 = row_image row_0
22− i1 = rowImage row1
21+ i_1 = row_image row_1
23− (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0)
22+ (i_larger, i_smaller) = if image_width i_0 > image_width i_1 then (i_0, i_1) else (i_1, i_0)
24− expectedOps = displayOpsForImage iLarger
23+ expected_ops = display_ops_for_image i_larger
25− p = picForLayers [iLarger, iSmaller]
24+ p = pic_for_layers [i_larger, i_smaller]
26− ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)
25+ ops = display_ops_for_pic p (image_width i_larger,image_height i_larger)
27− in verifyOpsEquality expectedOps ops
26+ in verify_ops_equality expected_ops ops
28
27
29−-- | Two rows stacked vertical is equivalent to the first row rendered
28+-- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the
30−-- as the top layer and the second row rendered as a bottom layer with a
29+-- second row rendered as a bottom layer with a background fill where the first row would be.
31−-- background fill where the first row would be.
30+vert_stack_layer_equivalence_0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
32−vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
31+vert_stack_layer_equivalence_0 row_0 row_1 =
33−vertStackLayerEquivalence0 row0 row1 =
32+ let i_0 = row_image row_0
34− let i0 = rowImage row0
33+ i_1 = row_image row_1
35− i1 = rowImage row1
34+ i = i_0 <-> i_1
36− i = i0 <-> i1
35+ p = pic_for_image i
37− p = picForImage i
36+ i_lower = background_fill (image_width i_0) 1 <-> i_1
38− iLower = backgroundFill (imageWidth i0) 1 <-> i1
37+ p_layered = pic_for_layers [i_0, i_lower]
39− pLayered = picForLayers [i0, iLower]
38+ expected_ops = display_ops_for_image i
40− expectedOps = displayOpsForImage i
39+ ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)
41− opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
40+ in verify_ops_equality expected_ops ops_layered
42− in verifyOpsEquality expectedOps opsLayered
43
41
44−vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
42+vert_stack_layer_equivalence_1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
45−vertStackLayerEquivalence1 row0 row1 =
43+vert_stack_layer_equivalence_1 row_0 row_1 =
46− let i0 = rowImage row0
44+ let i_0 = row_image row_0
47− i1 = rowImage row1
45+ i_1 = row_image row_1
48− i = i0 <-> i1
46+ i = i_0 <-> i_1
49− p = picForImage i
47+ p = pic_for_image i
50− iLower = i0 <-> backgroundFill (imageWidth i1) 1
48+ i_lower = i_0 <-> background_fill (image_width i_1) 1
51− iUpper = backgroundFill (imageWidth i0) 1 <-> i1
49+ i_upper = background_fill (image_width i_0) 1 <-> i_1
52− pLayered = picForLayers [iUpper, iLower]
50+ p_layered = pic_for_layers [i_upper, i_lower]
53− expectedOps = displayOpsForImage i
51+ expected_ops = display_ops_for_image i
54− opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
52+ ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)
55− in verifyOpsEquality expectedOps opsLayered
53+ in verify_ops_equality expected_ops ops_layered
56
54
57−-- | Two rows horiz joined is equivalent to the first row rendered as
55+-- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the
58−-- the top layer and the second row rendered as a bottom layer with a
56+-- second row rendered as a bottom layer with a background fill where the first row would be.
59−-- background fill where the first row would be.
57+horiz_join_layer_equivalence_0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
60−horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
58+horiz_join_layer_equivalence_0 row_0 row_1 =
61−horizJoinLayerEquivalence0 row0 row1 =
59+ let i_0 = row_image row_0
62− let i0 = rowImage row0
60+ i_1 = row_image row_1
63− i1 = rowImage row1
61+ i = i_0 <|> i_1
64− i = i0 <|> i1
62+ p = pic_for_image i
65− p = picForImage i
63+ i_lower = background_fill (image_width i_0) 1 <|> i_1
66− iLower = backgroundFill (imageWidth i0) 1 <|> i1
64+ p_layered = pic_for_layers [i_0, i_lower]
67− pLayered = picForLayers [i0, iLower]
65+ expected_ops = display_ops_for_image i
68− expectedOps = displayOpsForImage i
66+ ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)
69− opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
67+ in verify_ops_equality expected_ops ops_layered
70− in verifyOpsEquality expectedOps opsLayered
71
68
72−horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
69+horiz_join_layer_equivalence_1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
73−horizJoinLayerEquivalence1 row0 row1 =
70+horiz_join_layer_equivalence_1 row_0 row_1 =
74− let i0 = rowImage row0
71+ let i_0 = row_image row_0
75− i1 = rowImage row1
72+ i_1 = row_image row_1
76− i = i0 <|> i1
73+ i = i_0 <|> i_1
77− p = picForImage i
74+ p = pic_for_image i
78− iLower = i0 <|> backgroundFill (imageWidth i1) 1
75+ i_lower = i_0 <|> background_fill (image_width i_1) 1
79− iUpper = backgroundFill (imageWidth i0) 1 <|> i1
76+ i_upper = background_fill (image_width i_0) 1 <|> i_1
80− pLayered = picForLayers [iUpper, iLower]
77+ p_layered = pic_for_layers [i_upper, i_lower]
81− expectedOps = displayOpsForImage i
78+ expected_ops = display_ops_for_image i
82− opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
79+ ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)
83− in verifyOpsEquality expectedOps opsLayered
80+ in verify_ops_equality expected_ops ops_layered
84
81
85−horizJoinAlternate0 :: Result
82+horiz_join_alternate_0 :: Result
86−horizJoinAlternate0 =
83+horiz_join_alternate_0 =
87 let size = 4
84 let size = 4
88− str0 = replicate size 'a'
85+ str_0 = replicate size 'a'
89− str1 = replicate size 'b'
86+ str_1 = replicate size 'b'
90− i0 = string defAttr str0
87+ i_0 = string def_attr str_0
91− i1 = string defAttr str1
88+ i_1 = string def_attr str_1
92− i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)
89+ i = horiz_cat $ zipWith horiz_join (replicate size i_0) (replicate size i_1)
93− layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1
90+ layer_0 = horiz_cat $ replicate size $ i_0 <|> background_fill size 1
94− layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1
91+ layer_1 = horiz_cat $ replicate size $ background_fill size 1 <|> i_1
95− expectedOps = displayOpsForImage i
92+ expected_ops = display_ops_for_image i
96− opsLayered = displayOpsForPic (picForLayers [layer0, layer1])
93+ ops_layered = display_ops_for_pic (pic_for_layers [layer_0, layer_1])
97− (imageWidth i,imageHeight i)
94+ (image_width i,image_height i)
98− in verifyOpsEquality expectedOps opsLayered
95+ in verify_ops_equality expected_ops ops_layered
99
96
100−horizJoinAlternate1 :: Result
97+horiz_join_alternate_1 :: Result
101−horizJoinAlternate1 =
98+horiz_join_alternate_1 =
102 let size = 4
99 let size = 4
103− str0 = replicate size 'a'
100+ str_0 = replicate size 'a'
104− str1 = replicate size 'b'
101+ str_1 = replicate size 'b'
105− i0 = string defAttr str0
102+ i_0 = string def_attr str_0
106− i1 = string defAttr str1
103+ i_1 = string def_attr str_1
107− i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)
104+ i = horiz_cat $ zipWith horiz_join (replicate size i_0) (replicate size i_1)
108− layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1]
105+ layers = [l | b <- take 4 [0,size*2..], let l = background_fill b 1 <|> i_0 <|> i_1]
109− expectedOps = displayOpsForImage i
106+ expected_ops = display_ops_for_image i
110− opsLayered = displayOpsForPic (picForLayers layers)
107+ ops_layered = display_ops_for_pic (pic_for_layers layers)
111− (imageWidth i,imageHeight i)
108+ (image_width i,image_height i)
112− in verifyOpsEquality expectedOps opsLayered
109+ in verify_ops_equality expected_ops ops_layered
113
110
114tests :: IO [Test]
111tests :: IO [Test]
115−tests = return
112+tests = return
116 [ verify "a larger horiz span occludes a smaller span on a lower layer"
113 [ verify "a larger horiz span occludes a smaller span on a lower layer"
117− largerHorizSpanOcclusion
114+ larger_horiz_span_occlusion
118 , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"
115 , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"
119− vertStackLayerEquivalence0
116+ vert_stack_layer_equivalence_0
120 , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)"
117 , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)"
121− vertStackLayerEquivalence1
118+ vert_stack_layer_equivalence_1
122 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)"
119 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)"
123− -- horizJoinLayerEquivalence0
120+ -- horiz_join_layer_equivalence_0
124 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)"
121 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)"
125− -- horizJoinLayerEquivalence1
122+ -- horiz_join_layer_equivalence_1
126 -- , verify "alternating images using joins is the same as alternating images using layers (0)"
123 -- , verify "alternating images using joins is the same as alternating images using layers (0)"
127− -- horizJoinAlternate0
124+ -- horiz_join_alternate_0
128 -- , verify "alternating images using joins is the same as alternating images using layers (1)"
125 -- , verify "alternating images using joins is the same as alternating images using layers (1)"
129− -- horizJoinAlternate1
126+ -- horiz_join_alternate_1
130 ]
127 ]
128+
test/VerifyOutput.hs+42−37
@@ -1,9 +1,8 @@
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 for the terminals of
3−-- for the terminals of interest.
3+ - interest.
4−{-# LANGUAGE ScopedTypeVariables #-}
4+ -}
5module VerifyOutput where
5module VerifyOutput where
6−
7import Verify
6import Verify
8
7
9import Graphics.Vty
8import Graphics.Vty
@@ -14,45 +13,51 @@ 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
17−import System.Posix.IO
16+import System.Posix.Env
17+import System.IO
18
18
19tests :: IO [Test]
19tests :: IO [Test]
20−tests = concat <$> forM terminalsOfInterest (\termName -> do
20+tests = concat <$> forM terminals_of_interest (\term_name -> do
21 -- check if that terminfo exists
21 -- check if that terminfo exists
22− -- putStrLn $ "testing end to end for terminal: " ++ termName
22+ putStrLn $ "testing end to end for terminal: " ++ term_name
23− mti <- try $ Terminfo.setupTerm termName
23+ mti <- try $ Terminfo.setupTerm term_name
24 case mti of
24 case mti of
25 Left (_ :: SomeException) -> return []
25 Left (_ :: SomeException) -> return []
26− Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture")
26+ Right _ -> return [ verify ("verify " ++ term_name ++ " could output a picture")
27− (smokeTestTermNonMac termName)
27+ (smoke_test_term_non_mac term_name)
28+ -- this is excessive.
29+ , verify ("verify " ++ term_name ++ " could output a picture on a Mac.")
30+ (smoke_test_term_mac term_name)
28 ]
31 ]
29 )
32 )
30
33
31−smokeTestTermNonMac :: String -> Image -> Property
34+smoke_test_term_non_mac :: String -> Image -> Property
32−smokeTestTermNonMac termName i = liftIOResult $ do
35+smoke_test_term_non_mac term_name i = liftIOResult $ do
33− smokeTestTerm termName i
36+ -- unset the TERM_PROGRAM environment variable if set.
34−
37+ -- Required to execute regression test for #42 on a mac
35−smokeTestTerm :: String -> Image -> IO Result
38+ unsetEnv "TERM_PROGRAM"
36−smokeTestTerm termName i = do
39+ smoke_test_term term_name i
37− nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
40+
38− t <- outputForConfig $ defaultConfig
41+smoke_test_term_mac :: String -> Image -> Property
39− { outputFd = Just nullOut
42+smoke_test_term_mac term_name i = liftIOResult $ do
40− , termName = Just termName
43+ setEnv "TERM_PROGRAM" "Apple_Terminal" True
41− , colorMode = Just NoColor
44+ smoke_test_term term_name i
42− }
45+
43− -- putStrLn $ "context color count: " ++ show (contextColorCount t)
46+smoke_test_term :: String -> Image -> IO Result
44− reserveDisplay t
47+smoke_test_term term_name i = do
45− dc <- displayContext t (100,100)
48+ null_out <- openFile "/dev/null" WriteMode
46− -- always show the cursor to produce tests for terminals with no
49+ t <- output_for_name_and_io term_name null_out
47− -- cursor support.
50+ putStrLn $ "context color count: " ++ show (context_color_count t)
48− let pic = (picForImage i) { picCursor = Cursor 0 0 }
51+ reserve_display t
49− outputPicture dc pic
52+ dc <- display_context t (100,100)
50− setCursorPos t 0 0
53+ -- always show the cursor to produce tests for terminals with no cursor support.
51− when (supportsCursorVisibility t) $ do
54+ let pic = (pic_for_image i) { pic_cursor = Cursor 0 0 }
52− hideCursor t
55+ output_picture dc pic
53− showCursor t
56+ set_cursor_pos t 0 0
54− releaseDisplay t
57+ when (supports_cursor_visibility t) $ do
55− releaseTerminal t
58+ hide_cursor t
56− closeFd nullOut
59+ show_cursor t
60+ release_display t
61+ release_terminal t
57 return succeeded
62 return succeeded
58
63
test/VerifyParseTerminfoCaps.hs+50−50
@@ -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 )
@@ -17,7 +16,7 @@ import Numeric
17
16
18-- If a terminal defines one of the caps then it's expected to be parsable.
17-- If a terminal defines one of the caps then it's expected to be parsable.
19-- TODO: reduce duplication with terminfo terminal implementation.
18-- TODO: reduce duplication with terminfo terminal implementation.
20−capsOfInterest =
19+caps_of_interest =
21 [ "cup"
20 [ "cup"
22 , "sc"
21 , "sc"
23 , "rc"
22 , "rc"
@@ -37,65 +36,66 @@ capsOfInterest =
37 , "sgr0"
36 , "sgr0"
38 ]
37 ]
39
38
40−fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)
39+from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)
41
40
42tests :: IO [Test]
41tests :: IO [Test]
43tests = do
42tests = do
44− parseTests <- concat <$> forM terminalsOfInterest (\termName ->
43+ parse_tests <- concat <$> forM terminals_of_interest (\term_name ->
45− liftIO (try $ Terminfo.setupTerm termName)
44+ liftIO (try $ Terminfo.setupTerm term_name)
46 >>= either (\(_e :: SomeException) -> return [])
45 >>= either (\(_e :: SomeException) -> return [])
47− (\ti -> concat <$> forM capsOfInterest (\capName -> do
46+ (\ti -> concat <$> forM caps_of_interest (\cap_name -> do
48− let caseName = "\tparsing cap: " ++ capName
47+ let case_name = "\tparsing cap: " ++ cap_name
49− liftIO $ putStrLn caseName
48+ liftIO $ putStrLn case_name
50− return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
49+ return $ case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
51− Just capDef -> [verify (caseName ++ " -> " ++ show capDef)
50+ Just cap_def -> [verify (case_name ++ " -> " ++ show cap_def)
52− (verifyParseCap capDef $ const succeeded)]
51+ (verify_parse_cap cap_def $ const succeeded)]
53 Nothing -> []
52 Nothing -> []
54 )
53 )
55 )
54 )
56 )
55 )
57− return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps
56+ return $ [ verify "parse_non_paramaterized_caps" non_paramaterized_caps
58− , verify "parse cap string with literal %" literalPercentCaps
57+ , verify "parse cap string with literal %" literal_percent_caps
59− , verify "parse cap string with %i op" incFirstTwoCaps
58+ , verify "parse cap string with %i op" inc_first_two_caps
60− , verify "parse cap string with %pN op" pushParamCaps
59+ , verify "parse cap string with %pN op" push_param_caps
61− ] ++ parseTests
60+ ] ++ parse_tests
62−
61+
63−verifyParseCap capString onParse =
62+verify_parse_cap cap_string on_parse =
64− case parseCapExpression capString of
63+ case parse_cap_expression cap_string of
65 Left error -> failed { reason = "parse error " ++ show error }
64 Left error -> failed { reason = "parse error " ++ show error }
66− Right e -> onParse e
65+ Right e -> on_parse e
67−
66+
68−nonParamaterizedCaps (NonParamCapString cap) = do
67+non_paramaterized_caps (NonParamCapString cap) = do
69− verifyParseCap cap $ \e ->
68+ verify_parse_cap cap $ \e ->
70− let expectedBytes = map (toEnum . fromEnum) cap
69+ let expected_bytes = map (toEnum . fromEnum) cap
71− outBytes = bytesForRange e 0 (length cap)
70+ out_bytes = bytes_for_range e 0 (length cap)
72− in verifyBytesEqual outBytes expectedBytes
71+ in verify_bytes_equal out_bytes expected_bytes
73−
72+
74−literalPercentCaps (LiteralPercentCap capString expectedBytes) = do
73+literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do
75− verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes
74+ verify_parse_cap cap_string $ \e -> verify_bytes_equal (collect_bytes e) expected_bytes
76−
75+
77−incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do
76+inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do
78− verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes
77+ verify_parse_cap cap_string $ \e -> verify_bytes_equal (collect_bytes e) expected_bytes
79−
78+
80−pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do
79+push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do
81− verifyParseCap capString $ \e ->
80+ verify_parse_cap cap_string $ \e ->
82− let outBytes = collectBytes e
81+ let out_bytes = collect_bytes e
83− outParamCount = paramCount e
82+ out_param_count = param_count e
84− in if outParamCount == expectedParamCount
83+ in if out_param_count == expected_param_count
85− then verifyBytesEqual outBytes expectedBytes
84+ then verify_bytes_equal out_bytes expected_bytes
86 else failed { reason = "out param count /= expected param count" }
85 else failed { reason = "out param count /= expected param count" }
87
86
88−decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do
87+dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do
89− verifyParseCap capString $ \e ->
88+ verify_parse_cap cap_string $ \e ->
90− let outBytes = collectBytes e
89+ let out_bytes = collect_bytes e
91− outParamCount = paramCount e
90+ out_param_count = param_count e
92− in if outParamCount == expectedParamCount
91+ in if out_param_count == expected_param_count
93− then verifyBytesEqual outBytes expectedBytes
92+ then verify_bytes_equal out_bytes expected_bytes
94 else failed { reason = "out param count /= expected param count" }
93 else failed { reason = "out param count /= expected param count" }
95
94
96−printCap ti capName = do
95+print_cap ti cap_name = do
97− putStrLn $ capName ++ ": " ++ show (fromCapname ti capName)
96+ putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name)
97+
98+print_expression ti cap_name = do
99+ let parse_result = parse_cap_expression $ from_capname ti cap_name
100+ putStrLn $ cap_name ++ ": " ++ show parse_result
98
101
99−printExpression ti capName = do
100− let parseResult = parseCapExpression $ fromCapname ti capName
101− putStrLn $ capName ++ ": " ++ show parseResult
test/VerifySimpleSpanGeneration.hs+157−157
@@ -13,176 +13,176 @@ import Graphics.Vty.PictureToSpans
13
13
14import Verify
14import Verify
15
15
16−import qualified Data.Vector as Vector
16+import qualified Data.Vector as Vector
17−
17+
18−unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool
18+unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool
19−unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =
19+unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) =
20− let p = picForImage i
20+ let p = pic_for_image i
21− ops = displayOpsForPic p (regionForWindow w)
21+ ops = display_ops_for_pic p (region_for_window w)
22− in displayOpsColumns ops == 0 && displayOpsRows ops == 0
22+ in display_ops_columns ops == 0 && display_ops_rows ops == 0
23−
23+
24−unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool
24+unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool
25−unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
25+unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) =
26− let p = picForImage i
26+ let p = pic_for_image i
27− ops = displayOpsForPic p (regionForWindow w)
27+ ops = display_ops_for_pic p (region_for_window w)
28− in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
28+ in ( span_ops_effected_rows ops == 0 ) && ( all_spans_have_width ops 0 )
29−
29+
30−horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
30+horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
31−horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
31+horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) =
32− let p = picForImage i
32+ let p = pic_for_image i
33− ops = displayOpsForPic p (regionForWindow w)
33+ ops = display_ops_for_pic p (region_for_window w)
34− in displayOpsColumns ops == 0 && displayOpsRows ops == 0
34+ in display_ops_columns ops == 0 && display_ops_rows ops == 0
35−
35+
36−horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
36+horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
37−horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
37+horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) =
38− let p = picForImage i
38+ let p = pic_for_image i
39− ops = displayOpsForPic p (regionForWindow w)
39+ ops = display_ops_for_pic p (region_for_window w)
40− in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
40+ in ( span_ops_effected_rows ops == 0 ) && ( all_spans_have_width ops 0 )
41−
41+
42−horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result
42+horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result
43−horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
43+horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =
44− let p = picForImage i
44+ let p = pic_for_image i
45 w = MockWindow c 1
45 w = MockWindow c 1
46− ops = displayOpsForPic p (regionForWindow w)
46+ ops = display_ops_for_pic p (region_for_window w)
47− in verifyAllSpansHaveWidth i ops c
47+ in verify_all_spans_have_width i ops c
48
48
49−horizSpanImageAndEqualWindow1 :: SingleRowSingleAttrImage -> Bool
49+horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool
50−horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
50+horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =
51− let p = picForImage i
51+ let p = pic_for_image i
52 w = MockWindow c 1
52 w = MockWindow c 1
53− ops = displayOpsForPic p (regionForWindow w)
53+ ops = display_ops_for_pic p (region_for_window w)
54− in spanOpsAffectedRows ops == 1
54+ in span_ops_effected_rows ops == 1
55−
55+
56−horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result
56+horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result
57−horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
57+horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =
58− let p = picForImage i
58+ let p = pic_for_image i
59− lesserWidth = c `div` 2
59+ lesser_width = c `div` 2
60− w = MockWindow lesserWidth 1
60+ w = MockWindow lesser_width 1
61− ops = displayOpsForPic p (regionForWindow w)
61+ ops = display_ops_for_pic p (region_for_window w)
62− in verifyAllSpansHaveWidth i ops lesserWidth
62+ in verify_all_spans_have_width i ops lesser_width
63−
63+
64−singleAttrSingleSpanStackCropped0 :: SingleAttrSingleSpanStack -> Result
64+single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result
65−singleAttrSingleSpanStackCropped0 stack =
65+single_attr_single_span_stack_cropped_0 stack =
66− let p = picForImage (stackImage stack)
66+ let p = pic_for_image (stack_image stack)
67− w = MockWindow (stackWidth stack `div` 2) (stackHeight stack)
67+ w = MockWindow (stack_width stack `div` 2) (stack_height stack)
68− ops = displayOpsForPic p (regionForWindow w)
68+ ops = display_ops_for_pic p (region_for_window w)
69− in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack `div` 2)
69+ in verify_all_spans_have_width (stack_image stack) ops (stack_width stack `div` 2)
70−
70+
71−singleAttrSingleSpanStackCropped1 :: SingleAttrSingleSpanStack -> Bool
71+single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool
72−singleAttrSingleSpanStackCropped1 stack =
72+single_attr_single_span_stack_cropped_1 stack =
73− let p = picForImage (stackImage stack)
73+ let p = pic_for_image (stack_image stack)
74− expectedRowCount = stackHeight stack `div` 2
74+ expected_row_count = stack_height stack `div` 2
75− w = MockWindow (stackWidth stack) expectedRowCount
75+ w = MockWindow (stack_width stack) expected_row_count
76− ops = displayOpsForPic p (regionForWindow w)
76+ ops = display_ops_for_pic p (region_for_window w)
77− actualRowCount = spanOpsAffectedRows ops
77+ actual_row_count = span_ops_effected_rows ops
78− in expectedRowCount == actualRowCount
78+ in expected_row_count == actual_row_count
79−
79+
80−singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
80+single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
81−singleAttrSingleSpanStackCropped2 stack0 stack1 =
81+single_attr_single_span_stack_cropped_2 stack_0 stack_1 =
82− let p = picForImage (stackImage stack0 <|> stackImage stack1)
82+ let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)
83− w = MockWindow (stackWidth stack0) (imageHeight (picImage p))
83+ w = MockWindow (stack_width stack_0) (image_height (pic_image p))
84− ops = displayOpsForPic p (regionForWindow w)
84+ ops = display_ops_for_pic p (region_for_window w)
85− in verifyAllSpansHaveWidth (picImage p) ops (stackWidth stack0)
85+ in verify_all_spans_have_width (pic_image p) ops (stack_width stack_0)
86−
86+
87−singleAttrSingleSpanStackCropped3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool
87+single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool
88−singleAttrSingleSpanStackCropped3 stack0 stack1 =
88+single_attr_single_span_stack_cropped_3 stack_0 stack_1 =
89− let p = picForImage (stackImage stack0 <|> stackImage stack1)
89+ let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)
90− w = MockWindow (imageWidth (picImage p)) expectedRowCount
90+ w = MockWindow (image_width (pic_image p)) expected_row_count
91− ops = displayOpsForPic p (regionForWindow w)
91+ ops = display_ops_for_pic p (region_for_window w)
92− expectedRowCount = imageHeight (picImage p) `div` 2
92+ expected_row_count = image_height (pic_image p) `div` 2
93− actualRowCount = spanOpsAffectedRows ops
93+ actual_row_count = span_ops_effected_rows ops
94− in expectedRowCount == actualRowCount
94+ in expected_row_count == actual_row_count
95−
95+
96−singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
96+single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
97−singleAttrSingleSpanStackCropped4 stack0 stack1 =
97+single_attr_single_span_stack_cropped_4 stack_0 stack_1 =
98− let p = picForImage (stackImage stack0 <-> stackImage stack1)
98+ let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)
99− w = MockWindow expectedWidth (imageHeight (picImage p))
99+ w = MockWindow expected_width (image_height (pic_image p))
100− ops = displayOpsForPic p (regionForWindow w)
100+ ops = display_ops_for_pic p (region_for_window w)
101− expectedWidth = imageWidth (picImage p) `div` 2
101+ expected_width = image_width (pic_image p) `div` 2
102− in verifyAllSpansHaveWidth (picImage p) ops expectedWidth
102+ in verify_all_spans_have_width (pic_image p) ops expected_width
103−
103+
104−singleAttrSingleSpanStackCropped5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool
104+single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool
105−singleAttrSingleSpanStackCropped5 stack0 stack1 =
105+single_attr_single_span_stack_cropped_5 stack_0 stack_1 =
106− let p = picForImage (stackImage stack0 <-> stackImage stack1)
106+ let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)
107− w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)
107+ w = MockWindow (image_width (pic_image p)) (stack_height stack_0)
108− ops = displayOpsForPic p (regionForWindow w)
108+ ops = display_ops_for_pic p (region_for_window w)
109− expectedRowCount = stackHeight stack0
109+ expected_row_count = stack_height stack_0
110− actualRowCount = spanOpsAffectedRows ops
110+ actual_row_count = span_ops_effected_rows ops
111− in expectedRowCount == actualRowCount
111+ in expected_row_count == actual_row_count
112−
112+
113−horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result
113+horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result
114−horizSpanImageAndGreaterWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
114+horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =
115− let p = picForImage i
115+ let p = pic_for_image i
116 -- SingleRowSingleAttrImage always has width >= 1
116 -- SingleRowSingleAttrImage always has width >= 1
117− greaterWidth = c * 2
117+ greater_width = c * 2
118− w = MockWindow greaterWidth 1
118+ w = MockWindow greater_width 1
119− ops = displayOpsForPic p (regionForWindow w)
119+ ops = display_ops_for_pic p (region_for_window w)
120− in verifyAllSpansHaveWidth i ops greaterWidth
120+ in verify_all_spans_have_width i ops greater_width
121−
121+
122−arbImageIsCropped :: DefaultImage -> MockWindow -> Bool
122+arb_image_is_cropped :: DefaultImage -> MockWindow -> Bool
123−arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =
123+arb_image_is_cropped (DefaultImage image) win@(MockWindow w h) =
124− let pic = picForImage image
124+ let pic = pic_for_image image
125− ops = displayOpsForPic pic (regionForWindow win)
125+ ops = display_ops_for_pic pic (region_for_window win)
126− in ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w )
126+ in ( span_ops_effected_rows ops == h ) && ( all_spans_have_width ops w )
127−
127+
128−spanOpsActuallyFillRows :: DefaultPic -> Bool
128+span_ops_actually_fill_rows :: DefaultPic -> Bool
129−spanOpsActuallyFillRows (DefaultPic pic win) =
129+span_ops_actually_fill_rows (DefaultPic pic win) =
130− let ops = displayOpsForPic pic (regionForWindow win)
130+ let ops = display_ops_for_pic pic (region_for_window win)
131− expectedRowCount = regionHeight (regionForWindow win)
131+ expected_row_count = region_height (region_for_window win)
132− actualRowCount = spanOpsAffectedRows ops
132+ actual_row_count = span_ops_effected_rows ops
133− in expectedRowCount == actualRowCount
133+ in expected_row_count == actual_row_count
134−
134+
135−spanOpsActuallyFillColumns :: DefaultPic -> Bool
135+span_ops_actually_fill_columns :: DefaultPic -> Bool
136−spanOpsActuallyFillColumns (DefaultPic pic win) =
136+span_ops_actually_fill_columns (DefaultPic pic win) =
137− let ops = displayOpsForPic pic (regionForWindow win)
137+ let ops = display_ops_for_pic pic (region_for_window win)
138− expectedColumnCount = regionWidth (regionForWindow win)
138+ expected_column_count = region_width (region_for_window win)
139− in allSpansHaveWidth ops expectedColumnCount
139+ in all_spans_have_width ops expected_column_count
140−
140+
141−firstSpanOpSetsAttr :: DefaultPic -> Bool
141+first_span_op_sets_attr :: DefaultPic -> Bool
142−firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =
142+first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } =
143− let ops = displayOpsForPic pic (regionForWindow win)
143+ let ops = display_ops_for_pic pic (region_for_window win)
144− in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops )
144+ in all ( is_attr_span_op . Vector.head ) ( Vector.toList ops )
145−
145+
146−singleAttrSingleSpanStackOpCoverage :: SingleAttrSingleSpanStack -> Result
146+single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result
147−singleAttrSingleSpanStackOpCoverage stack =
147+single_attr_single_span_stack_op_coverage stack =
148− let p = picForImage (stackImage stack)
148+ let p = pic_for_image (stack_image stack)
149− w = MockWindow (stackWidth stack) (stackHeight stack)
149+ w = MockWindow (stack_width stack) (stack_height stack)
150− ops = displayOpsForPic p (regionForWindow w)
150+ ops = display_ops_for_pic p (region_for_window w)
151− in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack)
151+ in verify_all_spans_have_width (stack_image stack) ops (stack_width stack)
152−
152+
153−imageCoverageMatchesBounds :: Image -> Result
153+image_coverage_matches_bounds :: Image -> Result
154−imageCoverageMatchesBounds i =
154+image_coverage_matches_bounds i =
155− let p = picForImage i
155+ let p = pic_for_image i
156− r = (imageWidth i,imageHeight i)
156+ r = (image_width i,image_height i)
157− ops = displayOpsForPic p r
157+ ops = display_ops_for_pic p r
158− in verifyAllSpansHaveWidth i ops (imageWidth i)
158+ in verify_all_spans_have_width i ops (image_width i)
159
159
160tests :: IO [Test]
160tests :: IO [Test]
161−tests = return
161+tests = return
162− [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0
162+ [ verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0
163− , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1
163+ , verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1
164− , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0
164+ , verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0
165− , verify "horiz span image is cropped when window size == (0,0) [1]" horizSpanImageAndZeroWindow1
165+ , verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1
166− , verify "horiz span image is not cropped when window size == size of image [width]" horizSpanImageAndEqualWindow0
166+ , verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0
167− , verify "horiz span image is not cropped when window size == size of image [height]" horizSpanImageAndEqualWindow1
167+ , verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1
168− , verify "horiz span image is not cropped when window size < size of image [width]" horizSpanImageAndLesserWindow0
168+ , verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0
169− , verify "horiz span image is not cropped when window size > size of image [width]" horizSpanImageAndGreaterWindow0
169+ , verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0
170− , verify "first span op is always to set the text attribute" firstSpanOpSetsAttr
170+ , verify "first span op is always to set the text attribute" first_span_op_sets_attr
171 , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"
171 , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"
172− singleAttrSingleSpanStackOpCoverage
172+ single_attr_single_span_stack_op_coverage
173 , verify "a single attr text span is cropped when window size < size of stack image [width]"
173 , verify "a single attr text span is cropped when window size < size of stack image [width]"
174− singleAttrSingleSpanStackCropped0
174+ single_attr_single_span_stack_cropped_0
175 , verify "a single attr text span is cropped when window size < size of stack image [height]"
175 , verify "a single attr text span is cropped when window size < size of stack image [height]"
176− singleAttrSingleSpanStackCropped1
176+ single_attr_single_span_stack_cropped_1
177 , verify "single attr text span <|> single attr text span display cropped. [width]"
177 , verify "single attr text span <|> single attr text span display cropped. [width]"
178− singleAttrSingleSpanStackCropped2
178+ single_attr_single_span_stack_cropped_2
179 , verify "single attr text span <|> single attr text span display cropped. [height]"
179 , verify "single attr text span <|> single attr text span display cropped. [height]"
180− singleAttrSingleSpanStackCropped3
180+ single_attr_single_span_stack_cropped_3
181 , verify "single attr text span <-> single attr text span display cropped. [width]"
181 , verify "single attr text span <-> single attr text span display cropped. [width]"
182− singleAttrSingleSpanStackCropped4
182+ single_attr_single_span_stack_cropped_4
183 , verify "single attr text span <-> single attr text span display cropped. [height]"
183 , verify "single attr text span <-> single attr text span display cropped. [height]"
184− singleAttrSingleSpanStackCropped5
184+ single_attr_single_span_stack_cropped_5
185 , verify "an arbitrary image when rendered to a window of the same size will cover the entire window"
185 , verify "an arbitrary image when rendered to a window of the same size will cover the entire window"
186− imageCoverageMatchesBounds
186+ image_coverage_matches_bounds
187 ]
187 ]
188
188
test/VerifyUsingMockInput.hs+132−143
@@ -1,25 +1,27 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
3+{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced
4−-- Generate some input bytes and delays between blocks of input bytes.
4+ - are as expected.
5−-- Verify the events produced are as expected.
5+ -}
6module Main where
6module Main where
7
7
8import Verify.Graphics.Vty.Output
8import Verify.Graphics.Vty.Output
9
9
10+import Data.List (intersperse)
11+
10import Graphics.Vty hiding (resize)
12import Graphics.Vty hiding (resize)
11import Graphics.Vty.Input.Events
13import Graphics.Vty.Input.Events
12−import Graphics.Vty.Input.Loop
14+import Graphics.Vty.Input.Internal
13import Graphics.Vty.Input.Terminfo
15import Graphics.Vty.Input.Terminfo
14
16
17+import Control.Applicative
15import Control.Concurrent
18import Control.Concurrent
16−import Control.Concurrent.STM
17import Control.Exception
19import Control.Exception
18−import Lens.Micro ((^.))
20+import Control.Lens ((^.))
19import Control.Monad
21import Control.Monad
20
22
23+import Data.Default
21import Data.IORef
24import Data.IORef
22−import Data.List (intersperse, reverse, nubBy)
23
25
24import System.Console.Terminfo
26import System.Console.Terminfo
25import System.Posix.IO
27import System.Posix.IO
@@ -34,111 +36,100 @@ import Test.SmallCheck.Series
34
36
35import Text.Printf
37import Text.Printf
36
38
37−-- processing a block of 16 chars is the largest I can do without taking
39+-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
38−-- too long to run the test.
40+max_block_size :: Int
39−maxBlockSize :: Int
41+max_block_size = 16
40−maxBlockSize = 16
41
42
42−maxTableSize :: Int
43+max_table_size :: Int
43−maxTableSize = 28
44+max_table_size = 28
44
45
45forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
46forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
46forEachOf l = over (generate (\n -> take n l))
47forEachOf l = over (generate (\n -> take n l))
47
48
48data InputEvent
49data InputEvent
49− = Bytes String
50+ = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
50− -- ^ Input sequence encoded as a string. Regardless, the input is
51+ | Delay Int -- | microsecond delay
51− -- read a byte at a time.
52− | Delay Int
53− -- ^ Microsecond delay
54 deriving Show
52 deriving Show
55
53
56type InputSpec = [InputEvent]
54type InputSpec = [InputEvent]
57
55
58type ExpectedSpec = [Event]
56type ExpectedSpec = [Event]
59
57
60−synthesizeInput :: InputSpec -> Fd -> IO ()
58+synthesize_input :: InputSpec -> Fd -> IO ()
61−synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")
59+synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
62 where
60 where
63− f (Bytes str) = void $ fdWrite outHandle str
61+ f (Bytes str) = void $ fdWrite out_handle str
64 f (Delay t) = threadDelay t
62 f (Delay t) = threadDelay t
65
63
66−minDetectableDelay :: Int
64+min_detectable_delay :: Int
67−minDetectableDelay = 4000
65+min_detectable_delay = 4000
68
66
69−minTimout :: Int
67+min_timout :: Int
70−minTimout = 4000000
68+min_timout = 4000000
71
69
72−testKeyDelay :: Int
70+test_key_delay :: Int
73−testKeyDelay = minDetectableDelay * 4
71+test_key_delay = min_detectable_delay * 4
74
72
75−testEscSampleDelay :: Int
73+test_esc_sample_delay :: Int
76−testEscSampleDelay = minDetectableDelay * 2
74+test_esc_sample_delay = min_detectable_delay * 2
77
75
78−genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()
76+gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
79−genEventsUsingIoActions maxDuration inputAction outputAction = do
77+gen_events_using_io_actions max_duration input_action output_action = do
80− let maxDuration' = max minTimout maxDuration
78+ let max_duration' = max min_timout max_duration
81− readComplete <- newEmptyMVar
79+ read_complete <- newEmptyMVar
82− writeComplete <- newEmptyMVar
80+ write_complete <- newEmptyMVar
83− _ <- forkOS $ inputAction `finally` putMVar writeComplete ()
81+ _ <- forkOS $ input_action `finally` putMVar write_complete ()
84− _ <- forkOS $ outputAction `finally` putMVar readComplete ()
82+ _ <- forkOS $ output_action `finally` putMVar read_complete ()
85− Just () <- timeout maxDuration' $ takeMVar writeComplete
83+ Just () <- timeout max_duration' $ takeMVar write_complete
86− Just () <- timeout maxDuration' $ takeMVar readComplete
84+ Just () <- timeout max_duration' $ takeMVar read_complete
87 return ()
85 return ()
88
86
89−compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
87+compare_events :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
90−compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents
88+compare_events input_spec expected_events out_events = compare_events' expected_events out_events
91 where
89 where
92− compareEvents' [] [] = return True
90+ compare_events' [] [] = return True
93− compareEvents' [] outEvents' = do
91+ compare_events' [] out_events' = do
94− printf "extra events %s\n" (show outEvents') :: IO ()
92+ printf "extra events %s\n" (show out_events') :: IO ()
95 return False
93 return False
96− compareEvents' expectedEvents' [] = do
94+ compare_events' expected_events' [] = do
97− printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()
95+ printf "events %s were not produced for input %s\n" (show expected_events') (show input_spec) :: IO ()
98− printf "expected events %s\n" (show expectedEvents) :: IO ()
96+ printf "expected events %s\n" (show expected_events) :: IO ()
99− printf "received events %s\n" (show outEvents) :: IO ()
97+ printf "received events %s\n" (show out_events) :: IO ()
100 return False
98 return False
101− compareEvents' (e : expectedEvents') (o : outEvents')
99+ compare_events' (e : expected_events') (o : out_events')
102− | e == o = compareEvents' expectedEvents' outEvents'
100+ | e == o = compare_events' expected_events' out_events'
103 | otherwise = do
101 | otherwise = do
104− printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()
102+ printf "%s expected not %s for input %s\n" (show e) (show o) (show input_spec) :: IO ()
105− printf "expected events %s\n" (show expectedEvents) :: IO ()
103+ printf "expected events %s\n" (show expected_events) :: IO ()
106− printf "received events %s\n" (show outEvents) :: IO ()
104+ printf "received events %s\n" (show out_events) :: IO ()
107 return False
105 return False
108
106
109−assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool
107+assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
110−assertEventsFromSynInput table inputSpec expectedEvents = do
108+assert_events_from_syn_input table input_spec expected_events = do
111− let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay
109+ let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
112− eventCount = length expectedEvents
110+ event_count = length expected_events
113− (writeFd, readFd) <- openPseudoTerminal
111+ (write_fd, read_fd) <- openPseudoTerminal
114− (setTermAttr,_) <- attributeControl readFd
112+ (set_term_attr,_) <- attributeControl read_fd
115− setTermAttr
113+ set_term_attr
116− let testConfig = defaultConfig { inputFd = Just readFd
114+ input <- initInputForFd def table read_fd
117− , termName = Just "dummy"
115+ events_ref <- newIORef []
118− , vmin = Just 1
116+ let write_wait_close = do
119− , vtime = Just 100
117+ synthesize_input input_spec write_fd
120− }
118+ threadDelay min_detectable_delay
121− input <- initInput testConfig table
119+ shutdown_input input
122− eventsRef <- newIORef []
120+ threadDelay min_detectable_delay
123− let writeWaitClose = do
121+ closeFd write_fd
124− synthesizeInput inputSpec writeFd
122+ closeFd read_fd
125− threadDelay minDetectableDelay
126− shutdownInput input
127− threadDelay minDetectableDelay
128− closeFd writeFd
129− closeFd readFd
130 -- drain output pipe
123 -- drain output pipe
131− let readEvents = readLoop eventCount
124+ let read_events = read_loop event_count
132− readLoop 0 = return ()
125+ read_loop 0 = return ()
133− readLoop n = do
126+ read_loop n = do
134− e <- atomically $ readTChan $ input^.eventChannel
127+ e <- readChan $ input^.event_channel
135− case e of
128+ modifyIORef events_ref ((:) e)
136− InputEvent ev -> modifyIORef eventsRef ((:) ev)
129+ read_loop (n - 1)
137− ResumeAfterSignal -> return ()
130+ gen_events_using_io_actions max_duration write_wait_close read_events
138− readLoop (n - 1)
131+ out_events <- reverse <$> readIORef events_ref
139− genEventsUsingIoActions maxDuration writeWaitClose readEvents
132+ compare_events input_spec expected_events out_events
140− outEvents <- reverse <$> readIORef eventsRef
141− compareEvents inputSpec expectedEvents outEvents
142
133
143newtype InputBlocksUsingTable event
134newtype InputBlocksUsingTable event
144 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
135 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
@@ -148,76 +139,74 @@ instance Show (InputBlocksUsingTable event) where
148
139
149instance Monad m => Serial m (InputBlocksUsingTable event) where
140instance Monad m => Serial m (InputBlocksUsingTable event) where
150 series = do
141 series = do
151− n :: Int <- localDepth (const maxTableSize) series
142+ n :: Int <- localDepth (const max_table_size) series
152− return $ InputBlocksUsingTable $ \raw_table ->
143+ return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
153− let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table
154− in concat (take n (selections table))
155 where
144 where
156 selections [] = []
145 selections [] = []
157 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
146 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
158
147
159−verifyVisibleSynInputToEvent :: Property IO
148+verify_visible_syn_input_to_event :: Property IO
160−verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
149+verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
161− let table = visibleChars
150+ let table = visible_chars
162− inputSeq = gen table
151+ input_seq = gen table
163− events = map snd inputSeq
152+ events = map snd input_seq
164− keydowns = map (Bytes . fst) inputSeq
153+ keydowns = map (Bytes . fst) input_seq
165− input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
154+ input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
166− assertEventsFromSynInput universalTable input events
155+ assert_events_from_syn_input universal_table input events
167−
156+
168−verifyCapsSynInputToEvent :: Property IO
157+verify_caps_syn_input_to_event :: Property IO
169−verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
158+verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
170− forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
159+ forEachOf terminals_of_interest $ \term_name -> monadic $ do
171− term <- setupTerm terminalName
160+ term <- setupTerm term_name
172− let table = capsClassifyMap term keysFromCapsTable
161+ let table = caps_classify_table term keys_from_caps_table
173− inputSeq = gen table
162+ input_seq = gen table
174− events = map snd inputSeq
163+ events = map snd input_seq
175− keydowns = map (Bytes . fst) inputSeq
164+ keydowns = map (Bytes . fst) input_seq
176− input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
165+ input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
177− assertEventsFromSynInput table input events
166+ assert_events_from_syn_input table input events
178−
167+
179−verifySpecialSynInputToEvent :: Property IO
168+verify_special_syn_input_to_event :: Property IO
180−verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
169+verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
181− let table = specialSupportKeys
170+ let table = special_support_keys
182− inputSeq = gen table
171+ input_seq = gen table
183− events = map snd inputSeq
172+ events = map snd input_seq
184− keydowns = map (Bytes . fst) inputSeq
173+ keydowns = map (Bytes . fst) input_seq
185− input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
174+ input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
186− assertEventsFromSynInput universalTable input events
175+ assert_events_from_syn_input universal_table input events
187−
176+
188−verifyFullSynInputToEvent :: Property IO
177+verify_full_syn_input_to_event :: Property IO
189−verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
178+verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
190− forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
179+ forEachOf terminals_of_interest $ \term_name -> monadic $ do
191− term <- setupTerm terminalName
180+ term <- setupTerm term_name
192− let table = classifyMapForTerm terminalName term
181+ let table = classify_table_for_term term_name term
193− inputSeq = gen table
182+ input_seq = gen table
194− events = map snd inputSeq
183+ events = map snd input_seq
195− keydowns = map (Bytes . fst) inputSeq
184+ keydowns = map (Bytes . fst) input_seq
196− input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
185+ input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
197− assertEventsFromSynInput table input events
186+ assert_events_from_syn_input table input events
198−
187+
199−verifyFullSynInputToEvent_2x :: Property IO
188+verify_full_syn_input_to_event_2x :: Property IO
200−verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
189+verify_full_syn_input_to_event_2x = forAll $ \(InputBlocksUsingTable gen) ->
201− forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
190+ forEachOf terminals_of_interest $ \term_name -> monadic $ do
202− term <- setupTerm terminalName
191+ term <- setupTerm term_name
203− let table = classifyMapForTerm terminalName term
192+ let table = classify_table_for_term term_name term
204− inputSeq = gen table
193+ input_seq = gen table
205− events = concatMap ((\s -> [s,s]) . snd) inputSeq
194+ events = concatMap ((\s -> [s,s]) . snd) input_seq
206− keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
195+ keydowns = map (Bytes . (\s -> s ++ s) . fst) input_seq
207− input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
196+ input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
208− assertEventsFromSynInput table input events
197+ assert_events_from_syn_input table input events
209
198
210main :: IO ()
199main :: IO ()
211main = defaultMain
200main = defaultMain
212 [ testProperty "synthesized typing of single visible chars translates to expected events"
201 [ testProperty "synthesized typing of single visible chars translates to expected events"
213− verifyVisibleSynInputToEvent
202+ verify_visible_syn_input_to_event
214 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"
203 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"
215− verifyCapsSynInputToEvent
204+ verify_caps_syn_input_to_event
216 , testProperty "synthesized typing of hard coded special keys translates to expected events"
205 , testProperty "synthesized typing of hard coded special keys translates to expected events"
217− verifySpecialSynInputToEvent
206+ verify_special_syn_input_to_event
218 , testProperty "synthesized typing of any key in the table translates to its paired event"
207 , testProperty "synthesized typing of any key in the table translates to its paired event"
219− verifyFullSynInputToEvent
208+ verify_full_syn_input_to_event
220 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
209 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
221− verifyFullSynInputToEvent_2x
210+ verify_full_syn_input_to_event_2x
222 ]
211 ]
223
212
test/VerifyUsingMockTerminal.hs+70−78
@@ -4,11 +4,9 @@ import Verify.Graphics.Vty.Prelude
4
4
5import Verify.Graphics.Vty.Picture
5import Verify.Graphics.Vty.Picture
6import Verify.Graphics.Vty.Image
6import Verify.Graphics.Vty.Image
7−import Verify.Graphics.Vty.Attributes
8import Verify.Graphics.Vty.Span
7import Verify.Graphics.Vty.Span
9import Verify.Graphics.Vty.Output
8import Verify.Graphics.Vty.Output
10import Graphics.Vty.Output
9import Graphics.Vty.Output
11−import Graphics.Vty.Output.Interface
12import Graphics.Vty.Output.Mock
10import Graphics.Vty.Output.Mock
13
11
14import Graphics.Vty.Debug
12import Graphics.Vty.Debug
@@ -21,88 +19,82 @@ import qualified Data.String.UTF8 as UTF8
21
19
22import System.IO
20import System.IO
23
21
24−unitImageUnitBounds :: UnitImage -> Property
22+unit_image_unit_bounds :: UnitImage -> Property
25−unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do
23+unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do
26− (_,t) <- mockTerminal (1,1)
24+ (_,t) <- mock_terminal (1,1)
27− dc <- displayBounds t >>= displayContext t
25+ dc <- display_bounds t >>= display_context t
28− let pic = picForImage i
26+ let pic = pic_for_image i
29− outputPicture dc pic
27+ output_picture dc pic
30 return succeeded
28 return succeeded
31
29
32−unitImageArbBounds :: UnitImage -> MockWindow -> Property
30+unit_image_arb_bounds :: UnitImage -> MockWindow -> Property
33−unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do
31+unit_image_arb_bounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do
34− (_,t) <- mockTerminal (w,h)
32+ (_,t) <- mock_terminal (w,h)
35− dc <- displayBounds t >>= displayContext t
33+ dc <- display_bounds t >>= display_context t
36− let pic = picForImage i
34+ let pic = pic_for_image i
37− outputPicture dc pic
35+ output_picture dc pic
38 return succeeded
36 return succeeded
39
37
40−singleTRow :: MockWindow -> Property
38+single_T_row :: MockWindow -> Property
41−singleTRow (MockWindow w h) = liftIOResult $ do
39+single_T_row (MockWindow w h) = liftIOResult $ do
42− (mockData,t) <- mockTerminal (w,h)
40+ (mock_data,t) <- mock_terminal (w,h)
43− dc <- displayBounds t >>= displayContext t
41+ dc <- display_bounds t >>= display_context t
44− -- create an image that contains just the character T repeated for a
42+ -- create an image that contains just the character T repeated for a single row
45− -- single row
43+ let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T')
46− let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')
44+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }
47− pic = (picForImage i) { picBackground = Background 'B' defAttr }
45+ output_picture dc pic
48− outputPicture dc pic
46+ -- The mock output string that represents the output bytes a single line containing the T
49− -- The mock output string that represents the output bytes a single
47+ -- string: Followed by h - 1 lines of a change to the background attribute and then the
50− -- line containing the T string: Followed by h - 1 lines of a change
48+ -- background character
51− -- to the background attribute and then the background character
49+ let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T'
52− let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'
50+ ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B')
53− ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')
51+ compare_mock_output mock_data expected
54− compareMockOutput mockData expected
52+
53+many_T_rows :: MockWindow -> Property
54+many_T_rows (MockWindow w h) = liftIOResult $ do
55+ (mock_data, t) <- mock_terminal (w,h)
56+ dc <- display_bounds t >>= display_context t
57+ -- create an image that contains the character 'T' repeated for all the rows
58+ let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')
59+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }
60+ output_picture dc pic
61+ -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
62+ -- attribute change. 'A', followed by w 'T's
63+ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')
64+ compare_mock_output mock_data expected
55
65
56−manyTRows :: MockWindow -> Property
66+many_T_rows_cropped_width :: MockWindow -> Property
57−manyTRows (MockWindow w h) = liftIOResult $ do
67+many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do
58− (mockData, t) <- mockTerminal (w,h)
68+ (mock_data,t) <- mock_terminal (w,h)
59− dc <- displayBounds t >>= displayContext t
69+ dc <- display_bounds t >>= display_context t
60− -- create an image that contains the character 'T' repeated for all
70+ -- create an image that contains the character 'T' repeated for all the rows
61− -- the rows
71+ let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T')
62− let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
72+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }
63− pic = (picForImage i) { picBackground = Background 'B' defAttr }
73+ output_picture dc pic
64− outputPicture dc pic
74+ -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
65− -- The UTF8 string that represents the output bytes is h repeats of
75+ -- attribute change. 'A', followed by w 'T's
66− -- a move, 'M', followed by an attribute change. 'A', followed by w
76+ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')
67− -- 'T's
77+ compare_mock_output mock_data expected
68− let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
69− compareMockOutput mockData expected
70
78
71−manyTRowsCroppedWidth :: MockWindow -> Property
79+many_T_rows_cropped_height :: MockWindow -> Property
72−manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do
80+many_T_rows_cropped_height (MockWindow w h) = liftIOResult $ do
73− (mockData,t) <- mockTerminal (w,h)
81+ (mock_data,t) <- mock_terminal (w,h)
74− dc <- displayBounds t >>= displayContext t
82+ dc <- display_bounds t >>= display_context t
75− -- create an image that contains the character 'T' repeated for all
83+ -- create an image that contains the character 'T' repeated for all the rows
76− -- the rows
84+ let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')
77− let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')
85+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }
78− pic = (picForImage i) { picBackground = Background 'B' defAttr }
86+ output_picture dc pic
79− outputPicture dc pic
87+ -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
80− -- The UTF8 string that represents the output bytes is h repeats of
88+ -- attribute change. 'A', followed by w count 'T's
81− -- a move, 'M', followed by an attribute change. 'A', followed by w
89+ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')
82− -- 'T's
90+ compare_mock_output mock_data expected
83− let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
84− compareMockOutput mockData expected
85−
86−manyTRowsCroppedHeight :: MockWindow -> Property
87−manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do
88− (mockData,t) <- mockTerminal (w,h)
89− dc <- displayBounds t >>= displayContext t
90− -- create an image that contains the character 'T' repeated for all
91− -- the rows
92− let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
93− pic = (picForImage i) { picBackground = Background 'B' defAttr }
94− outputPicture dc pic
95− -- The UTF8 string that represents the output bytes is h repeats of
96− -- a move, 'M', followed by an attribute change. 'A', followed by w
97− -- count 'T's
98− let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
99− compareMockOutput mockData expected
100
91
101tests :: IO [Test]
92tests :: IO [Test]
102−tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds
93+tests = return [ verify "unit_image_unit_bounds" unit_image_unit_bounds
103− , verify "unitImageArbBounds" unitImageArbBounds
94+ , verify "unit_image_arb_bounds" unit_image_arb_bounds
104− , verify "singleTRow" singleTRow
95+ , verify "single_T_row" single_T_row
105− , verify "manyTRows" manyTRows
96+ , verify "many_T_rows" many_T_rows
106− , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth
97+ , verify "many_T_rows_cropped_width" many_T_rows_cropped_width
107− , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight
98+ , verify "many_T_rows_cropped_height" many_T_rows_cropped_height
108 ]
99 ]
100+
test/VerifyUtf8Width.hs+13−15
@@ -1,30 +1,28 @@
1module VerifyUtf8Width where
1module VerifyUtf8Width where
2−
3import Verify
2import Verify
4
3
5import Graphics.Text.Width
4import Graphics.Text.Width
6import Graphics.Vty.Attributes
5import Graphics.Vty.Attributes
7import Graphics.Vty.Picture
6import Graphics.Vty.Picture
8−import Graphics.Vty.Image
9
7
10−swIs1Column :: SingleColumnChar -> Bool
8+sw_is_1_column :: SingleColumnChar -> Bool
11−swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1
9+sw_is_1_column (SingleColumnChar c) = image_width (char def_attr c) == 1
12
10
13−dwIs2Column :: DoubleColumnChar -> Bool
11+dw_is_2_column :: DoubleColumnChar -> Bool
14−dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2
12+dw_is_2_column (DoubleColumnChar c) = image_width (char def_attr c) == 2
15
13
16−dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool
14+dc_string_is_even :: NonEmptyList DoubleColumnChar -> Bool
17−dcStringIsEven (NonEmpty dw_list) =
15+dc_string_is_even (NonEmpty dw_list) =
18− even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ]
16+ even $ safe_wcswidth [ c | DoubleColumnChar c <- dw_list ]
19
17
20−safeWcwidthForControlChars :: Bool
18+safe_wcwidth_for_control_chars :: Bool
21−safeWcwidthForControlChars = 0 == safeWcwidth '\NUL'
19+safe_wcwidth_for_control_chars = 0 == safe_wcwidth '\NUL'
22
20
23tests :: IO [Test]
21tests :: IO [Test]
24tests = return
22tests = return
25− [ verify "swIs1Column" swIs1Column
23+ [ verify "sw_is_1_column" sw_is_1_column
26− , verify "dwIs2Column" dwIs2Column
24+ , verify "dw_is_2_column" dw_is_2_column
27− , verify "a string of double characters is an even width" dcStringIsEven
25+ , verify "a string of double characters is an even width" dc_string_is_even
28− , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars
26+ , verify "safe_wcwidth provides a width of 0 for chars without widths" safe_wcwidth_for_control_chars
29 ]
27 ]
30
28
test/benchmark.hs+21−21
@@ -20,11 +20,11 @@ import Verify
20
20
21main = do
21main = do
22 args <- getArgs
22 args <- getArgs
23− let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench0)
23+ let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench_0)
24− , ("render-char-0", BenchRenderChar.bench0)
24+ , ("render-char-0", BenchRenderChar.bench_0)
25− , ("render-char-1", BenchRenderChar.bench1)
25+ , ("render-char-1", BenchRenderChar.bench_1)
26− , ("vertical-scroll-0", BenchVerticalScroll.bench0)
26+ , ("vertical-scroll-0", BenchVerticalScroll.bench_0)
27− , ("image-fuzz-0", BenchImageFuzz.bench0) ]
27+ , ("image-fuzz-0", BenchImageFuzz.bench_0) ]
28 help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b
28 help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b
29 case args of
29 case args of
30 ["--help"] -> help
30 ["--help"] -> help
@@ -34,23 +34,23 @@ main = do
34 then map (drop 2) args
34 then map (drop 2) args
35 else map fst benches
35 else map fst benches
36 -- drop the dash-dash "--"
36 -- drop the dash-dash "--"
37− results <- forM args' $ \bName -> do
37+ results <- forM args' $ \b_name -> do
38− case lookup bName benches of
38+ case lookup b_name benches of
39− Just b -> bench bName b
39+ Just b -> bench b_name b
40− Nothing -> fail $ "No benchmark named " ++ bName
40+ Nothing -> fail $ "No benchmark named " ++ b_name
41 print results
41 print results
42 return ()
42 return ()
43
43
44−bench bName b = do
44+bench b_name b = do
45− putStrLn $ "starting " ++ bName
45+ putStrLn $ "starting " ++ b_name
46− Bench bDataGen bProc <- b
46+ Bench b_data_gen b_proc <- b
47− bData <- bDataGen
47+ b_data <- b_data_gen
48− startTimes <- bData `deepseq` getProcessTimes
48+ start_times <- b_data `deepseq` getProcessTimes
49− bProc bData
49+ b_proc b_data
50− endTimes <- getProcessTimes
50+ end_times <- getProcessTimes
51− let ut = userTime endTimes - userTime startTimes
51+ let user_time = userTime end_times - userTime start_times
52− st = systemTime endTimes - systemTime startTimes
52+ system_time = systemTime end_times - systemTime start_times
53− putStrLn $ "user time: " ++ show ut
53+ putStrLn $ "user time: " ++ show user_time
54− putStrLn $ "system time: " ++ show st
54+ putStrLn $ "system time: " ++ show system_time
55− return (bName, ut, st)
55+ return (b_name, user_time, system_time)
56
56
test/interactive_terminal_test.hs+591−598
@@ -1,5 +1,4 @@
1{-# LANGUAGE QuasiQuotes #-}
1{-# LANGUAGE QuasiQuotes #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3module Main where
2module Main where
4
3
5import Graphics.Vty
4import Graphics.Vty
@@ -12,24 +11,25 @@ import Control.Concurrent (threadDelay)
12import Control.Exception
11import Control.Exception
13import Control.Monad
12import Control.Monad
14
13
14+import Data.Default (def)
15import Data.List ( lookup )
15import Data.List ( lookup )
16import Data.Maybe ( isJust, fromJust )
16import Data.Maybe ( isJust, fromJust )
17import Data.Monoid
17import Data.Monoid
18import Data.String.QQ
18import Data.String.QQ
19import Data.Word
19import Data.Word
20
20
21−import Foreign.Marshal.Array
21+import Foreign.Marshal.Array
22
22
23import qualified System.Environment as Env
23import qualified System.Environment as Env
24
24
25import System.IO ( hFlush, hPutStr, hPutBuf, stdout )
25import System.IO ( hFlush, hPutStr, hPutBuf, stdout )
26
26
27main = do
27main = do
28− printIntro
28+ print_intro
29
29
30−outputFilePath = "test_results.list"
30+output_file_path = "test_results.list"
31
31
32−printIntro = do
32+print_intro = do
33 putStr $ [s|
33 putStr $ [s|
34This is an interactive verification program for the terminal input and output
34This is an interactive verification program for the terminal input and output
35support of the VTY library. This will ask a series of questions about what you
35support of the VTY library. This will ask a series of questions about what you
@@ -37,7 +37,7 @@ see on screen. The goal is to verify that VTY's output and input support
37performs as expected with your terminal.
37performs as expected with your terminal.
38
38
39This program produces a file named
39This program produces a file named
40− |] ++ outputFilePath ++ [s|
40+ |] ++ output_file_path ++ [s|
41in the current directory that contains the results for each test assertion. This
41in the current directory that contains the results for each test assertion. This
42can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve
42can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve
43support for your terminal. No personal information is contained in the report.
43support for your terminal. No personal information is contained in the report.
@@ -66,40 +66,41 @@ All the tests assume the following about the terminal display:
66Thanks for the help! :-D
66Thanks for the help! :-D
67To exit the test early enter "q" anytime at the following menu screen.
67To exit the test early enter "q" anytime at the following menu screen.
68
68
69−If any test fails then please post an issue to
69+If any test failed then please post an issue to
70 https://github.com/coreyoconnor/vty/issues
70 https://github.com/coreyoconnor/vty/issues
71−with the test_results.list file pasted into the issue. A suitable summary is:
71+with the test_results.list file pasted into the issue. The issue summary can
72−"interactive terminal test failure".
72+mention the specific tests that failed or just say "interactive terminal test
73+failure".
73|]
74|]
74− waitForReturn
75+ wait_for_return
75− results <- doTestMenu 1
76+ results <- do_test_menu 1
76− envAttributes <- mapM ( \envName -> Control.Exception.catch ( Env.getEnv envName >>= return . (,) envName )
77+ env_attributes <- mapM ( \env_name -> Control.Exception.catch ( Env.getEnv env_name >>= return . (,) env_name )
77− ( \ (_ :: SomeException) -> return (envName, "") )
78+ ( \ (_ :: SomeException) -> return (env_name, "") )
78− )
79+ )
79− [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
80+ [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
80− t <- standardIOConfig >>= outputForConfig
81+ t <- output_for_current_terminal
81− let resultsTxt = show envAttributes ++ "\n"
82+ let results_txt = show env_attributes ++ "\n"
82− ++ terminalID t ++ "\n"
83+ ++ terminal_ID t ++ "\n"
83− ++ show results ++ "\n"
84+ ++ show results ++ "\n"
84− releaseTerminal t
85+ release_terminal t
85− writeFile outputFilePath resultsTxt
86+ writeFile output_file_path results_txt
86−
87+
87−waitForReturn = do
88+wait_for_return = do
88 putStr "\n(press return to continue)"
89 putStr "\n(press return to continue)"
89 hFlush stdout
90 hFlush stdout
90 getLine
91 getLine
91
92
92−testMenu :: [(String, Test)]
93+test_menu :: [(String, Test)]
93−testMenu = zip (map show [1..]) allTests
94+test_menu = zip (map show [1..]) all_tests
94
95
95−doTestMenu :: Int -> IO [(String, Bool)]
96+do_test_menu :: Int -> IO [(String, Bool)]
96−doTestMenu nextID
97+do_test_menu next_ID
97− | nextID > length allTests = do
98+ | next_ID > length all_tests = do
98− putStrLn $ "Done! Please email the " ++ outputFilePath ++ " file to coreyoconnor@gmail.com"
99+ putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"
99 return []
100 return []
100 | otherwise = do
101 | otherwise = do
101− displayTestMenu
102+ display_test_menu
102− putStrLn $ "Press return to start with #" ++ show nextID ++ "."
103+ putStrLn $ "Press return to start with #" ++ show next_ID ++ "."
103 putStrLn "Enter a test number to perform only that test."
104 putStrLn "Enter a test number to perform only that test."
104 putStrLn "q (or control-C) to quit."
105 putStrLn "q (or control-C) to quit."
105 putStr "> "
106 putStr "> "
@@ -107,102 +108,102 @@ doTestMenu nextID
107 s <- getLine >>= return . filter (/= '\n')
108 s <- getLine >>= return . filter (/= '\n')
108 case s of
109 case s of
109 "q" -> return mempty
110 "q" -> return mempty
110− "" -> do
111+ "" -> do
111− r <- runTest $ show nextID
112+ r <- run_test $ show next_ID
112− rs <- doTestMenu ( nextID + 1 )
113+ rs <- do_test_menu ( next_ID + 1 )
113 return $ r : rs
114 return $ r : rs
114− i | isJust ( lookup i testMenu ) -> do
115+ i | isJust ( lookup i test_menu ) -> do
115− r <- runTest i
116+ r <- run_test i
116− rs <- doTestMenu ( read i + 1 )
117+ rs <- do_test_menu ( read i + 1 )
117 return $ r : rs
118 return $ r : rs
118 where
119 where
119− displayTestMenu
120+ display_test_menu
120− = mapM_ displayTestMenu' testMenu
121+ = mapM_ display_test_menu' test_menu
121− displayTestMenu' ( i, t )
122+ display_test_menu' ( i, t )
122− = putStrLn $ ( if i == show nextID
123+ = putStrLn $ ( if i == show next_ID
123− then "> "
124+ then "> "
124 else " "
125 else " "
125− ) ++ i ++ ". " ++ testName t
126+ ) ++ i ++ ". " ++ test_name t
126−
127+
127−runTest :: String -> IO (String, Bool)
128+run_test :: String -> IO (String, Bool)
128−runTest i = do
129+run_test i = do
129− let t = fromJust $ lookup i testMenu
130+ let t = fromJust $ lookup i test_menu
130− printSummary t
131+ print_summary t
131− waitForReturn
132+ wait_for_return
132− testAction t
133+ test_action t
133− r <- confirmResults t
134+ r <- confirm_results t
134− return (testID t, r)
135+ return (test_ID t, r)
135−
136+
136−defaultSuccessConfirmResults = do
137+default_success_confirm_results = do
137 putStr "\n"
138 putStr "\n"
138 putStr "[Y/n] "
139 putStr "[Y/n] "
139 hFlush stdout
140 hFlush stdout
140 r <- getLine
141 r <- getLine
141 case r of
142 case r of
142− "" -> return True
143+ "" -> return True
143 "y" -> return True
144 "y" -> return True
144 "Y" -> return True
145 "Y" -> return True
145 "n" -> return False
146 "n" -> return False
146
147
147data Test = Test
148data Test = Test
148− { testName :: String
149+ { test_name :: String
149− , testID :: String
150+ , test_ID :: String
150− , testAction :: IO ()
151+ , test_action :: IO ()
151− , printSummary :: IO ()
152+ , print_summary :: IO ()
152− , confirmResults :: IO Bool
153+ , confirm_results :: IO Bool
153 }
154 }
154
155
155−allTests
156+all_tests
156− = [ reserveOutputTest
157+ = [ reserve_output_test
157− , displayBoundsTest0
158+ , display_bounds_test_0
158− , displayBoundsTest1
159+ , display_bounds_test_1
159− , displayBoundsTest2
160+ , display_bounds_test_2
160− , displayBoundsTest3
161+ , display_bounds_test_3
161− , unicodeSingleWidth0
162+ , unicode_single_width_0
162− , unicodeSingleWidth1
163+ , unicode_single_width_1
163− , unicodeDoubleWidth0
164+ , unicode_double_width_0
164− , unicodeDoubleWidth1
165+ , unicode_double_width_1
165− , attributesTest0
166+ , attributes_test_0
166− , attributesTest1
167+ , attributes_test_1
167− , attributesTest2
168+ , attributes_test_2
168− , attributesTest3
169+ , attributes_test_3
169− , attributesTest4
170+ , attributes_test_4
170− , attributesTest5
171+ , attributes_test_5
171− , inlineTest0
172+ , inline_test_0
172− , inlineTest1
173+ , inline_test_1
173− , inlineTest2
174+ , inline_test_2
174− , cursorHideTest0
175+ , cursor_hide_test_0
175− , vertCropTest0
176+ , vert_crop_test_0
176− , vertCropTest1
177+ , vert_crop_test_1
177− , vertCropTest2
178+ , vert_crop_test_2
178− , vertCropTest3
179+ , vert_crop_test_3
179− , horizCropTest0
180+ , horiz_crop_test_0
180− , horizCropTest1
181+ , horiz_crop_test_1
181− , horizCropTest2
182+ , horiz_crop_test_2
182− , horizCropTest3
183+ , horiz_crop_test_3
183− , layer0
184+ , layer_0
184− , layer1
185+ , layer_1
185 ]
186 ]
186
187
187−reserveOutputTest = Test
188+reserve_output_test = Test
188− { testName = "Initialize and reserve terminal output then restore previous state."
189+ { test_name = "Initialize and reserve terminal output then restore previous state."
189− , testID = "reserveOutputTest"
190+ , test_ID = "reserve_output_test"
190− , testAction = do
191+ , test_action = do
191− t <- standardIOConfig >>= outputForConfig
192+ t <- output_for_current_terminal
192− reserveDisplay t
193+ reserve_display t
193 putStrLn "Line 1"
194 putStrLn "Line 1"
194 putStrLn "Line 2"
195 putStrLn "Line 2"
195 putStrLn "Line 3"
196 putStrLn "Line 3"
196 putStrLn "Line 4 (press return)"
197 putStrLn "Line 4 (press return)"
197 hFlush stdout
198 hFlush stdout
198 getLine
199 getLine
199− releaseDisplay t
200+ release_display t
200− releaseTerminal t
201+ release_terminal t
201 return ()
202 return ()
202− , printSummary = do
203+ , print_summary = do
203 putStr $ [s|
204 putStr $ [s|
204Once return is pressed:
205Once return is pressed:
205− 0. The screen will be cleared.
206+ 0. The screen will be cleared.
206 1. Four lines of text should be visible.
207 1. Four lines of text should be visible.
207 1. The cursor should be visible and at the start of the fifth line.
208 1. The cursor should be visible and at the start of the fifth line.
208
209
@@ -210,123 +211,123 @@ After return is pressed for the second time this test then:
210 * The screen containing the test summary should be restored;
211 * The screen containing the test summary should be restored;
211 * The cursor is visible.
212 * The cursor is visible.
212|]
213|]
213− , confirmResults = do
214+ , confirm_results = do
214 putStr $ [s|
215 putStr $ [s|
215Did the test output match the description?
216Did the test output match the description?
216|]
217|]
217− defaultSuccessConfirmResults
218+ default_success_confirm_results
218 }
219 }
219
220
220−displayBoundsTest0 = Test
221+display_bounds_test_0 = Test
221− { testName = "Verify display bounds are correct test 0: Using spaces."
222+ { test_name = "Verify display bounds are correct test 0: Using spaces."
222− , testID = "displayBoundsTest0"
223+ , test_ID = "display_bounds_test_0"
223− , testAction = do
224+ , test_action = do
224− t <- standardIOConfig >>= outputForConfig
225+ t <- output_for_current_terminal
225− reserveDisplay t
226+ reserve_display t
226− (w,h) <- displayBounds t
227+ (w,h) <- display_bounds t
227− let row0 = replicate (fromEnum w) 'X' ++ "\n"
228+ let row_0 = replicate (fromEnum w) 'X' ++ "\n"
228− rowH = replicate (fromEnum w - 1) 'X'
229+ row_h = replicate (fromEnum w - 1) 'X'
229− rowN = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
230+ row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
230− image = row0 ++ (concat $ replicate (fromEnum h - 2) rowN) ++ rowH
231+ image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h
231 putStr image
232 putStr image
232 hFlush stdout
233 hFlush stdout
233 getLine
234 getLine
234− releaseDisplay t
235+ release_display t
235− releaseTerminal t
236+ release_terminal t
236 return ()
237 return ()
237− , printSummary = displayBoundsTestSummary True
238+ , print_summary = display_bounds_test_summary True
238− , confirmResults = genericOutputMatchConfirm
239+ , confirm_results = generic_output_match_confirm
239 }
240 }
240
241
241−displayBoundsTest1 = Test
242+display_bounds_test_1 = Test
242− { testName = "Verify display bounds are correct test 0: Using cursor movement."
243+ { test_name = "Verify display bounds are correct test 0: Using cursor movement."
243− , testID = "displayBoundsTest1"
244+ , test_ID = "display_bounds_test_1"
244− , testAction = do
245+ , test_action = do
245− t <- standardIOConfig >>= outputForConfig
246+ t <- output_for_current_terminal
246− reserveDisplay t
247+ reserve_display t
247− (w,h) <- displayBounds t
248+ (w,h) <- display_bounds t
248− setCursorPos t 0 0
249+ set_cursor_pos t 0 0
249− let row0 = replicate (fromEnum w) 'X' ++ "\n"
250+ let row_0 = replicate (fromEnum w) 'X' ++ "\n"
250− putStr row0
251+ putStr row_0
251 forM_ [1 .. h - 2] $ \y -> do
252 forM_ [1 .. h - 2] $ \y -> do
252− setCursorPos t 0 y
253+ set_cursor_pos t 0 y
253 putStr "X"
254 putStr "X"
254 hFlush stdout
255 hFlush stdout
255− setCursorPos t (w - 1) y
256+ set_cursor_pos t (w - 1) y
256 putStr "X"
257 putStr "X"
257 hFlush stdout
258 hFlush stdout
258− setCursorPos t 0 (h - 1)
259+ set_cursor_pos t 0 (h - 1)
259− let rowH = replicate (fromEnum w - 1) 'X'
260+ let row_h = replicate (fromEnum w - 1) 'X'
260− putStr rowH
261+ putStr row_h
261 hFlush stdout
262 hFlush stdout
262 getLine
263 getLine
263− releaseDisplay t
264+ release_display t
264− releaseTerminal t
265+ release_terminal t
265 return ()
266 return ()
266− , printSummary = displayBoundsTestSummary True
267+ , print_summary = display_bounds_test_summary True
267− , confirmResults = genericOutputMatchConfirm
268+ , confirm_results = generic_output_match_confirm
268 }
269 }
269
270
270−displayBoundsTest2 = Test
271+display_bounds_test_2 = Test
271− { testName = "Verify display bounds are correct test 0: Using Image ops."
272+ { test_name = "Verify display bounds are correct test 0: Using Image ops."
272− , testID = "displayBoundsTest2"
273+ , test_ID = "display_bounds_test_2"
273− , testAction = do
274+ , test_action = do
274− t <- standardIOConfig >>= outputForConfig
275+ t <- output_for_current_terminal
275− reserveDisplay t
276+ reserve_display t
276− bounds@(w,h) <- displayBounds t
277+ bounds@(w,h) <- display_bounds t
277− let firstRow = horizCat $ replicate (fromEnum w) (char defAttr 'X')
278+ let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')
278− middleRows = vertCat $ replicate (fromEnum h - 2) middleRow
279+ middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row
279− middleRow = (char defAttr 'X') <|> backgroundFill (w - 2) 1 <|> (char defAttr 'X')
280+ middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')
280− endRow = firstRow
281+ end_row = first_row
281− image = firstRow <-> middleRows <-> endRow
282+ image = first_row <-> middle_rows <-> end_row
282− pic = (picForImage image) { picCursor = Cursor (w - 1) (h - 1) }
283+ pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }
283− d <- displayContext t bounds
284+ d <- display_context t bounds
284− outputPicture d pic
285+ output_picture d pic
285 getLine
286 getLine
286− releaseDisplay t
287+ release_display t
287− releaseTerminal t
288+ release_terminal t
288 return ()
289 return ()
289− , printSummary = displayBoundsTestSummary True
290+ , print_summary = display_bounds_test_summary True
290− , confirmResults = genericOutputMatchConfirm
291+ , confirm_results = generic_output_match_confirm
291 }
292 }
292
293
293−displayBoundsTest3 = Test
294+display_bounds_test_3 = Test
294− { testName = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
295+ { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
295− , testID = "displayBoundsTest3"
296+ , test_ID = "display_bounds_test_3"
296− , testAction = do
297+ , test_action = do
297− t <- standardIOConfig >>= outputForConfig
298+ t <- output_for_current_terminal
298− reserveDisplay t
299+ reserve_display t
299− (w,h) <- displayBounds t
300+ (w,h) <- display_bounds t
300− hideCursor t
301+ hide_cursor t
301− setCursorPos t 0 0
302+ set_cursor_pos t 0 0
302− let row0 = replicate (fromEnum w) 'X'
303+ let row_0 = replicate (fromEnum w) 'X'
303− putStrLn row0
304+ putStrLn row_0
304 forM_ [1 .. h - 2] $ \y -> do
305 forM_ [1 .. h - 2] $ \y -> do
305− setCursorPos t 0 y
306+ set_cursor_pos t 0 y
306 putStr "X"
307 putStr "X"
307 hFlush stdout
308 hFlush stdout
308− setCursorPos t (w - 1) y
309+ set_cursor_pos t (w - 1) y
309 putStr "X"
310 putStr "X"
310 hFlush stdout
311 hFlush stdout
311− setCursorPos t 0 (h - 1)
312+ set_cursor_pos t 0 (h - 1)
312− let rowH = row0
313+ let row_h = row_0
313− putStr rowH
314+ putStr row_h
314 hFlush stdout
315 hFlush stdout
315 getLine
316 getLine
316− showCursor t
317+ show_cursor t
317− releaseDisplay t
318+ release_display t
318− releaseTerminal t
319+ release_terminal t
319 return ()
320 return ()
320− , printSummary = displayBoundsTestSummary False
321+ , print_summary = display_bounds_test_summary False
321− , confirmResults = genericOutputMatchConfirm
322+ , confirm_results = generic_output_match_confirm
322 }
323 }
323
324
324−displayBoundsTestSummary hasCursor = do
325+display_bounds_test_summary has_cursor = do
325 putStr $ [s|
326 putStr $ [s|
326Once return is pressed:
327Once return is pressed:
327 0. The screen will be cleared.
328 0. The screen will be cleared.
328|]
329|]
329− if hasCursor
330+ if has_cursor
330 then putStr " 1. The cursor will be visible."
331 then putStr " 1. The cursor will be visible."
331 else putStr " 1. The cursor will NOT be visible."
332 else putStr " 1. The cursor will NOT be visible."
332 putStr [s|
333 putStr [s|
@@ -337,7 +338,7 @@ Once return is pressed:
337 |XXXXXXXXXXXXX|
338 |XXXXXXXXXXXXX|
338 |X X||]
339 |X X||]
339
340
340− if hasCursor
341+ if has_cursor
341 then putStr $ [s|
342 then putStr $ [s|
342
343
343 |XXXXXXXXXXXXC| |]
344 |XXXXXXXXXXXXC| |]
@@ -358,13 +359,13 @@ After return is pressed for the second time:
358 1. The cursor should be visible.
359 1. The cursor should be visible.
359|]
360|]
360
361
361−genericOutputMatchConfirm = do
362+generic_output_match_confirm = do
362 putStr $ [s|
363 putStr $ [s|
363Did the test output match the description?
364Did the test output match the description?
364|]
365|]
365− defaultSuccessConfirmResults
366+ default_success_confirm_results
366
367
367−-- Explicitly define the bytes that encode each example text.
368+-- Explicitely definethe bytes that encode each example text.
368-- This avoids any issues with how the compiler represents string literals.
369-- This avoids any issues with how the compiler represents string literals.
369--
370--
370-- This document is UTF-8 encoded so the UTF-8 string is still included for
371-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -373,24 +374,24 @@ Did the test output match the description?
373-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
374-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
374-- comments ;-)
375-- comments ;-)
375--
376--
376−-- txt0 = ↑↑↓↓←→←→BA
377+-- txt_0 = ↑↑↓↓←→←→BA
377−
378+
378−utf8Txt0 :: [[Word8]]
379+utf8_txt_0 :: [[Word8]]
379−utf8Txt0 = [ [ 0xe2 , 0x86 , 0x91 ]
380+utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]
380− , [ 0xe2 , 0x86 , 0x91 ]
381+ , [ 0xe2 , 0x86 , 0x91 ]
381− , [ 0xe2 , 0x86 , 0x93 ]
382+ , [ 0xe2 , 0x86 , 0x93 ]
382− , [ 0xe2 , 0x86 , 0x93 ]
383+ , [ 0xe2 , 0x86 , 0x93 ]
383− , [ 0xe2 , 0x86 , 0x90 ]
384+ , [ 0xe2 , 0x86 , 0x90 ]
384− , [ 0xe2 , 0x86 , 0x92 ]
385+ , [ 0xe2 , 0x86 , 0x92 ]
385− , [ 0xe2 , 0x86 , 0x90 ]
386+ , [ 0xe2 , 0x86 , 0x90 ]
386− , [ 0xe2 , 0x86 , 0x92 ]
387+ , [ 0xe2 , 0x86 , 0x92 ]
387− , [ 0x42 ]
388+ , [ 0x42 ]
388− , [ 0x41 ]
389+ , [ 0x41 ]
389− ]
390+ ]
390−
391+
391−iso10646Txt0 :: String
392+iso_10646_txt_0 :: String
392−iso10646Txt0 = map toEnum
393+iso_10646_txt_0 = map toEnum
393− [ 8593
394+ [ 8593
394 , 8593
395 , 8593
395 , 8595
396 , 8595
396 , 8595
397 , 8595
@@ -402,46 +403,46 @@ iso10646Txt0 = map toEnum
402 , 65
403 , 65
403 ]
404 ]
404
405
405−unicodeSingleWidth0 = Test
406+unicode_single_width_0 = Test
406− { testName = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
407+ { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
407− , testID = "unicodeSingleWidth0"
408+ , test_ID = "unicode_single_width_0"
408− , testAction = do
409+ , test_action = do
409− t <- standardIOConfig >>= outputForConfig
410+ t <- output_for_current_terminal
410− reserveDisplay t
411+ reserve_display t
411− hideCursor t
412+ hide_cursor t
412− withArrayLen (concat utf8Txt0) (flip $ hPutBuf stdout)
413+ withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)
413 hPutStr stdout "\n"
414 hPutStr stdout "\n"
414 hPutStr stdout "0123456789\n"
415 hPutStr stdout "0123456789\n"
415 hFlush stdout
416 hFlush stdout
416 getLine
417 getLine
417− releaseDisplay t
418+ release_display t
418− releaseTerminal t
419+ release_terminal t
419 return ()
420 return ()
420− , printSummary = unicodeSingleWidthSummary
421+ , print_summary = unicode_single_width_summary
421− , confirmResults = genericOutputMatchConfirm
422+ , confirm_results = generic_output_match_confirm
422 }
423 }
423
424
424−unicodeSingleWidth1 = Test
425+unicode_single_width_1 = Test
425− { testName = "Verify terminal can display unicode single-width characters. (Image ops)"
426+ { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"
426− , testID = "unicodeSingleWidth1"
427+ , test_ID = "unicode_single_width_1"
427− , testAction = do
428+ , test_action = do
428− t <- standardIOConfig >>= outputForConfig
429+ t <- output_for_current_terminal
429− reserveDisplay t
430+ reserve_display t
430− let pic = picForImage image
431+ let pic = pic_for_image image
431− image = line0 <-> line1
432+ image = line_0 <-> line_1
432− line0 = iso10646String defAttr iso10646Txt0
433+ line_0 = iso_10646_string def_attr iso_10646_txt_0
433− line1 = string defAttr "0123456789"
434+ line_1 = string def_attr "0123456789"
434− d <- displayBounds t >>= displayContext t
435+ d <- display_bounds t >>= display_context t
435− outputPicture d pic
436+ output_picture d pic
436 getLine
437 getLine
437− releaseDisplay t
438+ release_display t
438− releaseTerminal t
439+ release_terminal t
439 return ()
440 return ()
440− , printSummary = unicodeSingleWidthSummary
441+ , print_summary = unicode_single_width_summary
441− , confirmResults = genericOutputMatchConfirm
442+ , confirm_results = generic_output_match_confirm
442 }
443 }
443
444
444−unicodeSingleWidthSummary = putStr [s|
445+unicode_single_width_summary = putStr [s|
445Once return is pressed:
446Once return is pressed:
446 0. The screen will be cleared.
447 0. The screen will be cleared.
447 1. The cursor will be hidden.
448 1. The cursor will be hidden.
@@ -475,55 +476,55 @@ After return is pressed for the second time:
475
476
476-- The second example is a unicode string containing double-width glyphs
477-- The second example is a unicode string containing double-width glyphs
477-- 你好吗
478-- 你好吗
478−utf8Txt1 :: [[Word8]]
479+utf8_txt_1 :: [[Word8]]
479−utf8Txt1 = [ [0xe4,0xbd,0xa0]
480+utf8_txt_1 = [ [0xe4,0xbd,0xa0]
480− , [0xe5,0xa5,0xbd]
481+ , [0xe5,0xa5,0xbd]
481− , [0xe5,0x90,0x97]
482+ , [0xe5,0x90,0x97]
482− ]
483+ ]
483−
484+
484−iso10646Txt1 :: String
485+iso_10646_txt_1 :: String
485−iso10646Txt1 = map toEnum [20320,22909,21527]
486+iso_10646_txt_1 = map toEnum [20320,22909,21527]
486−
487+
487−unicodeDoubleWidth0 = Test
488+unicode_double_width_0 = Test
488− { testName = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
489+ { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
489− , testID = "unicodeDoubleWidth0"
490+ , test_ID = "unicode_double_width_0"
490− , testAction = do
491+ , test_action = do
491− t <- standardIOConfig >>= outputForConfig
492+ t <- output_for_current_terminal
492− reserveDisplay t
493+ reserve_display t
493− hideCursor t
494+ hide_cursor t
494− withArrayLen (concat utf8Txt1) (flip $ hPutBuf stdout)
495+ withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)
495 hPutStr stdout "\n"
496 hPutStr stdout "\n"
496 hPutStr stdout "012345\n"
497 hPutStr stdout "012345\n"
497 hFlush stdout
498 hFlush stdout
498 getLine
499 getLine
499− releaseDisplay t
500+ release_display t
500− releaseTerminal t
501+ release_terminal t
501 return ()
502 return ()
502− , printSummary = unicodeDoubleWidthSummary
503+ , print_summary = unicode_double_width_summary
503− , confirmResults = genericOutputMatchConfirm
504+ , confirm_results = generic_output_match_confirm
504 }
505 }
505
506
506−unicodeDoubleWidth1 = Test
507+unicode_double_width_1 = Test
507− { testName = "Verify terminal can display unicode double-width characters. (Image ops)"
508+ { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"
508− , testID = "unicodeDoubleWidth1"
509+ , test_ID = "unicode_double_width_1"
509− , testAction = do
510+ , test_action = do
510− t <- standardIOConfig >>= outputForConfig
511+ t <- output_for_current_terminal
511− reserveDisplay t
512+ reserve_display t
512− let pic = picForImage image
513+ let pic = pic_for_image image
513− image = line0 <-> line1
514+ image = line_0 <-> line_1
514− line0 = iso10646String defAttr iso10646Txt1
515+ line_0 = iso_10646_string def_attr iso_10646_txt_1
515− line1 = string defAttr "012345"
516+ line_1 = string def_attr "012345"
516− d <- displayBounds t >>= displayContext t
517+ d <- display_bounds t >>= display_context t
517− outputPicture d pic
518+ output_picture d pic
518 getLine
519 getLine
519− releaseDisplay t
520+ release_display t
520− releaseTerminal t
521+ release_terminal t
521 return ()
522 return ()
522− , printSummary = unicodeDoubleWidthSummary
523+ , print_summary = unicode_double_width_summary
523− , confirmResults = genericOutputMatchConfirm
524+ , confirm_results = generic_output_match_confirm
524 }
525 }
525
526
526−unicodeDoubleWidthSummary = putStr [s|
527+unicode_double_width_summary = putStr [s|
527Once return is pressed:
528Once return is pressed:
528 0. The screen will be cleared.
529 0. The screen will be cleared.
529 1. The cursor will be hidden.
530 1. The cursor will be hidden.
@@ -550,32 +551,32 @@ After return is pressed for the second time:
550 1. The cursor should be visible.
551 1. The cursor should be visible.
551|]
552|]
552
553
553−allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
554+all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
554− [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
555+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
555
556
556−allBrightColors
557+all_bright_colors
557− = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]
558+ = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]
558 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
559 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
559
560
560−attributesTest0 = Test
561+attributes_test_0 = Test
561− { testName = "Character attributes: foreground colors."
562+ { test_name = "Character attributes: foreground colors."
562− , testID = "attributesTest0"
563+ , test_ID = "attributes_test_0"
563− , testAction = do
564+ , test_action = do
564− t <- standardIOConfig >>= outputForConfig
565+ t <- output_for_current_terminal
565− reserveDisplay t
566+ reserve_display t
566− let pic = picForImage image
567+ let pic = pic_for_image image
567− image = border <|> column0 <|> border <|> column1 <|> border
568+ image = border <|> column_0 <|> border <|> column_1 <|> border
568− column0 = vertCat $ map lineWithColor allColors
569+ column_0 = vert_cat $ map line_with_color all_colors
569− border = vertCat $ replicate (length allColors) $ string defAttr " | "
570+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
570− column1 = vertCat $ map (string defAttr . snd) allColors
571+ column_1 = vert_cat $ map (string def_attr . snd) all_colors
571− lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName
572+ line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name
572− d <- displayBounds t >>= displayContext t
573+ d <- display_bounds t >>= display_context t
573− outputPicture d pic
574+ output_picture d pic
574 getLine
575 getLine
575− releaseDisplay t
576+ release_display t
576− releaseTerminal t
577+ release_terminal t
577 return ()
578 return ()
578− , printSummary = do
579+ , print_summary = do
579 putStr $ [s|
580 putStr $ [s|
580Once return is pressed:
581Once return is pressed:
581 0. The screen will be cleared.
582 0. The screen will be cleared.
@@ -596,32 +597,32 @@ After return is pressed for the second time:
596 0. The screen containing the test summary should be restored.
597 0. The screen containing the test summary should be restored.
597 1. The cursor should be visible.
598 1. The cursor should be visible.
598|]
599|]
599− , confirmResults = do
600+ , confirm_results = do
600 putStr $ [s|
601 putStr $ [s|
601Did the test output match the description?
602Did the test output match the description?
602|]
603|]
603− defaultSuccessConfirmResults
604+ default_success_confirm_results
604 }
605 }
605
606
606−attributesTest1 = Test
607+attributes_test_1 = Test
607− { testName = "Character attributes: background colors."
608+ { test_name = "Character attributes: background colors."
608− , testID = "attributesTest1"
609+ , test_ID = "attributes_test_1"
609− , testAction = do
610+ , test_action = do
610− t <- standardIOConfig >>= outputForConfig
611+ t <- output_for_current_terminal
611− reserveDisplay t
612+ reserve_display t
612− let pic = picForImage image
613+ let pic = pic_for_image image
613− image = border <|> column0 <|> border <|> column1 <|> border
614+ image = border <|> column_0 <|> border <|> column_1 <|> border
614− column0 = vertCat $ map lineWithColor allColors
615+ column_0 = vert_cat $ map line_with_color all_colors
615− border = vertCat $ replicate (length allColors) $ string defAttr " | "
616+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
616− column1 = vertCat $ map (string defAttr . snd) allColors
617+ column_1 = vert_cat $ map (string def_attr . snd) all_colors
617− lineWithColor (c, cName) = string (defAttr `withBackColor` c) cName
618+ line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name
618− d <- displayBounds t >>= displayContext t
619+ d <- display_bounds t >>= display_context t
619− outputPicture d pic
620+ output_picture d pic
620 getLine
621 getLine
621− releaseDisplay t
622+ release_display t
622− releaseTerminal t
623+ release_terminal t
623 return ()
624 return ()
624− , printSummary = do
625+ , print_summary = do
625 putStr $ [s|
626 putStr $ [s|
626Once return is pressed:
627Once return is pressed:
627 0. The screen will be cleared.
628 0. The screen will be cleared.
@@ -651,57 +652,57 @@ After return is pressed for the second time:
651 0. The screen containing the test summary should be restored.
652 0. The screen containing the test summary should be restored.
652 1. The cursor should be visible.
653 1. The cursor should be visible.
653|]
654|]
654− , confirmResults = do
655+ , confirm_results = do
655 putStr $ [s|
656 putStr $ [s|
656Did the test output match the description?
657Did the test output match the description?
657|]
658|]
658− defaultSuccessConfirmResults
659+ default_success_confirm_results
659 }
660 }
660
661
661−attributesTest2 = Test
662+attributes_test_2 = Test
662− { testName = "Character attributes: Vivid foreground colors."
663+ { test_name = "Character attributes: Vivid foreground colors."
663− , testID = "attributesTest2"
664+ , test_ID = "attributes_test_2"
664− , testAction = do
665+ , test_action = do
665− t <- standardIOConfig >>= outputForConfig
666+ t <- output_for_current_terminal
666− reserveDisplay t
667+ reserve_display t
667− let pic = picForImage image
668+ let pic = pic_for_image image
668− image = horizCat [border, column0, border, column1, border, column2, border]
669+ image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
669− border = vertCat $ replicate (length allColors) $ string defAttr " | "
670+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
670− column0 = vertCat $ map lineWithColor0 allColors
671+ column_0 = vert_cat $ map line_with_color_0 all_colors
671− column1 = vertCat $ map lineWithColor1 allBrightColors
672+ column_1 = vert_cat $ map line_with_color_1 all_bright_colors
672− column2 = vertCat $ map (string defAttr . snd) allColors
673+ column_2 = vert_cat $ map (string def_attr . snd) all_colors
673− lineWithColor0 (c, cName) = string (defAttr `withForeColor` c) cName
674+ line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name
674− lineWithColor1 (c, cName) = string (defAttr `withForeColor` c) cName
675+ line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name
675− d <- displayBounds t >>= displayContext t
676+ d <- display_bounds t >>= display_context t
676− outputPicture d pic
677+ output_picture d pic
677 getLine
678 getLine
678− releaseDisplay t
679+ release_display t
679− releaseTerminal t
680+ release_terminal t
680 return ()
681 return ()
681− , printSummary = do
682+ , print_summary = do
682 putStr $ [s|
683 putStr $ [s|
683Once return is pressed:
684Once return is pressed:
684 0. The screen will be cleared.
685 0. The screen will be cleared.
685 1. The cursor will be hidden.
686 1. The cursor will be hidden.
686 2. 9 lines of text in three columns will be drawn:
687 2. 9 lines of text in three columns will be drawn:
687 a. The first column will be a name of a standard color (for an 8 color
688 a. The first column will be a name of a standard color (for an 8 color
688− terminal) rendered with that color as the foreground color.
689+ terminal) rendered with that color as the foreground color.
689 b. The next column will be also be the name of a standard color rendered
690 b. The next column will be also be the name of a standard color rendered
690 with that color as the foreground color but the shade used should be
691 with that color as the foreground color but the shade used should be
691− more vivid than the shade used in the first column.
692+ more vivid than the shade used in the first column.
692 c. The final column will be the name of a color rendered with the
693 c. The final column will be the name of a color rendered with the
693 default attributes.
694 default attributes.
694
695
695For instance, one line will be the word "magenta" and that word should be
696For instance, one line will be the word "magenta" and that word should be
696−rendered in the magenta color.
697+rendered in the magenta color.
697
698
698I'm not actually sure exactly what "vivid" means in this context. For xterm the
699I'm not actually sure exactly what "vivid" means in this context. For xterm the
699−vivid colors are brighter.
700+vivid colors are brighter.
700
701
701−Verify:
702+Verify:
702 * The first column: The foreground color matches the named color.
703 * The first column: The foreground color matches the named color.
703 * The second column: The foreground color matches the named color but is
704 * The second column: The foreground color matches the named color but is
704− more vivid than the color used in the first column.
705+ more vivid than the color used in the first column.
705 * The third column: All text is rendered with the default attributes.
706 * The third column: All text is rendered with the default attributes.
706 * The vertical bars used in each line to mark the border of a column are
707 * The vertical bars used in each line to mark the border of a column are
707 lined up.
708 lined up.
@@ -710,34 +711,34 @@ After return is pressed for the second time:
710 0. The screen containing the test summary should be restored.
711 0. The screen containing the test summary should be restored.
711 1. The cursor should be visible.
712 1. The cursor should be visible.
712|]
713|]
713− , confirmResults = do
714+ , confirm_results = do
714 putStr $ [s|
715 putStr $ [s|
715Did the test output match the description?
716Did the test output match the description?
716|]
717|]
717− defaultSuccessConfirmResults
718+ default_success_confirm_results
718 }
719 }
719
720
720−attributesTest3 = Test
721+attributes_test_3 = Test
721− { testName = "Character attributes: Vivid background colors."
722+ { test_name = "Character attributes: Vivid background colors."
722− , testID = "attributesTest3"
723+ , test_ID = "attributes_test_3"
723− , testAction = do
724+ , test_action = do
724− t <- standardIOConfig >>= outputForConfig
725+ t <- output_for_current_terminal
725− reserveDisplay t
726+ reserve_display t
726− let pic = picForImage image
727+ let pic = pic_for_image image
727− image = horizCat [border, column0, border, column1, border, column2, border]
728+ image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
728− border = vertCat $ replicate (length allColors) $ string defAttr " | "
729+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
729− column0 = vertCat $ map lineWithColor0 allColors
730+ column_0 = vert_cat $ map line_with_color_0 all_colors
730− column1 = vertCat $ map lineWithColor1 allBrightColors
731+ column_1 = vert_cat $ map line_with_color_1 all_bright_colors
731− column2 = vertCat $ map (string defAttr . snd) allColors
732+ column_2 = vert_cat $ map (string def_attr . snd) all_colors
732− lineWithColor0 (c, cName) = string (defAttr `withBackColor` c) cName
733+ line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name
733− lineWithColor1 (c, cName) = string (defAttr `withBackColor` c) cName
734+ line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name
734− d <- displayBounds t >>= displayContext t
735+ d <- display_bounds t >>= display_context t
735− outputPicture d pic
736+ output_picture d pic
736 getLine
737 getLine
737− releaseDisplay t
738+ release_display t
738− releaseTerminal t
739+ release_terminal t
739 return ()
740 return ()
740− , printSummary = do
741+ , print_summary = do
741 putStr $ [s|
742 putStr $ [s|
742Once return is pressed:
743Once return is pressed:
743 0. The screen will be cleared.
744 0. The screen will be cleared.
@@ -745,23 +746,23 @@ Once return is pressed:
745 2. 9 lines of text in three columns will be drawn:
746 2. 9 lines of text in three columns will be drawn:
746 a. The first column will contain be a name of a standard color for an 8
747 a. The first column will contain be a name of a standard color for an 8
747 color terminal rendered with the default foreground color with a
748 color terminal rendered with the default foreground color with a
748− background the named color.
749+ background the named color.
749 b. The first column will contain be a name of a standard color for an 8
750 b. The first column will contain be a name of a standard color for an 8
750 color terminal rendered with the default foreground color with the
751 color terminal rendered with the default foreground color with the
751− background a vivid version of the named color.
752+ background a vivid version of the named color.
752 c. The third column will be the name of a standard color rendered with
753 c. The third column will be the name of a standard color rendered with
753 the default attributes.
754 the default attributes.
754−
755+
755For instance, one line will contain be the word "magenta" and the word should
756For instance, one line will contain be the word "magenta" and the word should
756−be rendered in the default foreground color over a magenta background.
757+be rendered in the default foreground color over a magenta background.
757
758
758I'm not actually sure exactly what "vivid" means in this context. For xterm the
759I'm not actually sure exactly what "vivid" means in this context. For xterm the
759vivid colors are brighter.
760vivid colors are brighter.
760
761
761−Verify:
762+Verify:
762 * The first column: The background color matches the named color.
763 * The first column: The background color matches the named color.
763 * The second column: The background color matches the named color and is
764 * The second column: The background color matches the named color and is
764− more vivid than the color used in the first column.
765+ more vivid than the color used in the first column.
765 * The third column column: All text is rendered with the default attributes.
766 * The third column column: All text is rendered with the default attributes.
766 * The vertical bars used in each line to mark the border of a column are
767 * The vertical bars used in each line to mark the border of a column are
767 lined up.
768 lined up.
@@ -777,51 +778,51 @@ After return is pressed for the second time:
777 0. The screen containing the test summary should be restored.
778 0. The screen containing the test summary should be restored.
778 1. The cursor should be visible.
779 1. The cursor should be visible.
779|]
780|]
780− , confirmResults = do
781+ , confirm_results = do
781 putStr $ [s|
782 putStr $ [s|
782Did the test output match the description?
783Did the test output match the description?
783|]
784|]
784− defaultSuccessConfirmResults
785+ default_success_confirm_results
785 }
786 }
786
787
787−attrCombos =
788+attr_combos =
788 [ ( "default", id )
789 [ ( "default", id )
789− , ( "bold", flip withStyle bold )
790+ , ( "bold", flip with_style bold )
790− , ( "blink", flip withStyle blink )
791+ , ( "blink", flip with_style blink )
791− , ( "underline", flip withStyle underline )
792+ , ( "underline", flip with_style underline )
792− , ( "bold + blink", flip withStyle (bold + blink) )
793+ , ( "bold + blink", flip with_style (bold + blink) )
793− , ( "bold + underline", flip withStyle (bold + underline) )
794+ , ( "bold + underline", flip with_style (bold + underline) )
794− , ( "underline + blink", flip withStyle (underline + blink) )
795+ , ( "underline + blink", flip with_style (underline + blink) )
795− , ( "bold + blink + underline", flip withStyle (bold + blink + underline) )
796+ , ( "bold + blink + underline", flip with_style (bold + blink + underline) )
796 ]
797 ]
797
798
798−attributesTest4 = Test
799+attributes_test_4 = Test
799− { testName = "Character attributes: Bold; Blink; Underline."
800+ { test_name = "Character attributes: Bold; Blink; Underline."
800− , testID = "attributesTest4"
801+ , test_ID = "attributes_test_4"
801− , testAction = do
802+ , test_action = do
802− t <- standardIOConfig >>= outputForConfig
803+ t <- output_for_current_terminal
803− reserveDisplay t
804+ reserve_display t
804− let pic = picForImage image
805+ let pic = pic_for_image image
805− image = horizCat [border, column0, border, column1, border]
806+ image = horiz_cat [border, column_0, border, column_1, border]
806− border = vertCat $ replicate (length attrCombos) $ string defAttr " | "
807+ border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "
807− column0 = vertCat $ map lineWithAttrs attrCombos
808+ column_0 = vert_cat $ map line_with_attrs attr_combos
808− column1 = vertCat $ map (string defAttr . fst) attrCombos
809+ column_1 = vert_cat $ map (string def_attr . fst) attr_combos
809− lineWithAttrs (desc, attrF) = string (attrF defAttr) desc
810+ line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc
810− d <- displayBounds t >>= displayContext t
811+ d <- display_bounds t >>= display_context t
811− outputPicture d pic
812+ output_picture d pic
812 getLine
813 getLine
813− releaseDisplay t
814+ release_display t
814− releaseTerminal t
815+ release_terminal t
815 return ()
816 return ()
816− , printSummary = do
817+ , print_summary = do
817 putStr $ [s|
818 putStr $ [s|
818Once return is pressed:
819Once return is pressed:
819 0. The screen will be cleared.
820 0. The screen will be cleared.
820 1. The cursor will be hidden.
821 1. The cursor will be hidden.
821− 2. 8 rows of text in two columns.
822+ 2. 8 rows of text in two columns.
822 The rows will contain the following text:
823 The rows will contain the following text:
823 default
824 default
824− bold
825+ bold
825 blink
826 blink
826 underline
827 underline
827 bold + blink
828 bold + blink
@@ -830,8 +831,8 @@ Once return is pressed:
830 bold + blink + underline
831 bold + blink + underline
831 The first column will be rendered with the described attributes. The second
832 The first column will be rendered with the described attributes. The second
832 column will be rendered with the default attributes.
833 column will be rendered with the default attributes.
833−
834+
834−Verify:
835+Verify:
835 * The vertical bars used in each line to mark the border of a column are
836 * The vertical bars used in each line to mark the border of a column are
836 lined up.
837 lined up.
837 * The text in the first column is rendered as described.
838 * The text in the first column is rendered as described.
@@ -840,31 +841,31 @@ After return is pressed for the second time:
840 0. The screen containing the test summary should be restored.
841 0. The screen containing the test summary should be restored.
841 1. The cursor should be visible.
842 1. The cursor should be visible.
842|]
843|]
843− , confirmResults = do
844+ , confirm_results = do
844 putStr $ [s|
845 putStr $ [s|
845Did the test output match the description?
846Did the test output match the description?
846|]
847|]
847− defaultSuccessConfirmResults
848+ default_success_confirm_results
848 }
849 }
849
850
850−attributesTest5 = Test
851+attributes_test_5 = Test
851− { testName = "Character attributes: 240 color palette"
852+ { test_name = "Character attributes: 240 color palette"
852− , testID = "attributesTest5"
853+ , test_ID = "attributes_test_5"
853− , testAction = do
854+ , test_action = do
854− t <- standardIOConfig >>= outputForConfig
855+ t <- output_for_current_terminal
855− reserveDisplay t
856+ reserve_display t
856− let pic = picForImage image
857+ let pic = pic_for_image image
857− image = vertCat $ map horizCat $ splitColorImages colorImages
858+ image = vert_cat $ map horiz_cat $ split_color_images color_images
858− colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
859+ color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]
859− splitColorImages [] = []
860+ split_color_images [] = []
860− splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
861+ split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))
861− d <- displayBounds t >>= displayContext t
862+ d <- display_bounds t >>= display_context t
862− outputPicture d pic
863+ output_picture d pic
863 getLine
864 getLine
864− releaseDisplay t
865+ release_display t
865− releaseTerminal t
866+ release_terminal t
866 return ()
867 return ()
867− , printSummary = do
868+ , print_summary = do
868 putStr $ [s|
869 putStr $ [s|
869Once return is pressed:
870Once return is pressed:
870 0. The screen will be cleared.
871 0. The screen will be cleared.
@@ -872,304 +873,296 @@ Once return is pressed:
872 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
873 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
873 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
874 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
874
875
875−Verify:
876+Verify:
876
877
877After return is pressed for the second time:
878After return is pressed for the second time:
878 0. The screen containing the test summary should be restored.
879 0. The screen containing the test summary should be restored.
879 1. The cursor should be visible.
880 1. The cursor should be visible.
880|]
881|]
881− , confirmResults = do
882+ , confirm_results = do
882 putStr $ [s|
883 putStr $ [s|
883Did the test output match the description?
884Did the test output match the description?
884|]
885|]
885− defaultSuccessConfirmResults
886+ default_success_confirm_results
886 }
887 }
887
888
888−inlineTest0 = Test
889+inline_test_0 = Test
889− { testName = "Verify styled output can be performed without clearing the screen."
890+ { test_name = "Verify styled output can be performed without clearing the screen."
890− , testID = "inlineTest0"
891+ , test_ID = "inline_test_0"
891− , testAction = do
892+ , test_action = do
892 putStrLn "line 1."
893 putStrLn "line 1."
893− putAttrChange_ $ backColor red >> applyStyle underline
894+ put_attr_change_ $ back_color red >> apply_style underline
894 putStrLn "line 2."
895 putStrLn "line 2."
895− putAttrChange_ $ defaultAll
896+ put_attr_change_ $ default_all
896 putStrLn "line 3."
897 putStrLn "line 3."
897− , printSummary = putStr $ [s|
898+ , print_summary = putStr $ [s|
898lines are in order.
899lines are in order.
899The second line "line 2" should have a red background and the text underline.
900The second line "line 2" should have a red background and the text underline.
900The third line "line 3" should be drawn in the same style as the first line.
901The third line "line 3" should be drawn in the same style as the first line.
901|]
902|]
902
903
903− , confirmResults = genericOutputMatchConfirm
904+ , confirm_results = generic_output_match_confirm
904 }
905 }
905
906
906−inlineTest1 = Test
907+inline_test_1 = Test
907− { testName = "Verify styled output can be performed without clearing the screen."
908+ { test_name = "Verify styled output can be performed without clearing the screen."
908− , testID = "inlineTest1"
909+ , test_ID = "inline_test_1"
909− , testAction = do
910+ , test_action = do
910 putStr "Not styled. "
911 putStr "Not styled. "
911− putAttrChange_ $ backColor red >> applyStyle underline
912+ put_attr_change_ $ back_color red >> apply_style underline
912 putStr " Styled! "
913 putStr " Styled! "
913− putAttrChange_ $ defaultAll
914+ put_attr_change_ $ default_all
914 putStrLn "Not styled."
915 putStrLn "Not styled."
915− , printSummary = putStr $ [s|
916+ , print_summary = putStr $ [s|
916|]
917|]
917
918
918− , confirmResults = genericOutputMatchConfirm
919+ , confirm_results = generic_output_match_confirm
919 }
920 }
920
921
921−inlineTest2 = Test
922+inline_test_2 = Test
922− { testName = "Verify styled output can be performed without clearing the screen."
923+ { test_name = "Verify styled output can be performed without clearing the screen."
923− , testID = "inlineTest1"
924+ , test_ID = "inline_test_1"
924− , testAction = do
925+ , test_action = do
925 putStr "Not styled. "
926 putStr "Not styled. "
926− putAttrChange_ $ backColor red >> applyStyle underline
927+ put_attr_change_ $ back_color red >> apply_style underline
927 putStr " Styled! "
928 putStr " Styled! "
928− putAttrChange_ $ defaultAll
929+ put_attr_change_ $ default_all
929 putStr "Not styled.\n"
930 putStr "Not styled.\n"
930− , printSummary = putStr $ [s|
931+ , print_summary = putStr $ [s|
931|]
932|]
932− , confirmResults = genericOutputMatchConfirm
933+ , confirm_results = generic_output_match_confirm
933 }
934 }
934
935
935−cursorHideTest0 :: Test
936+cursor_hide_test_0 :: Test
936−cursorHideTest0 = Test
937+cursor_hide_test_0 = Test
937− { testName = "Verify the cursor is hid and re-shown. issue #7"
938+ { test_name = "Verify the cursor is hid and re-shown. issue #7"
938− , testID = "cursorHideTest0"
939+ , test_ID = "cursor_hide_test_0"
939− , testAction = do
940+ , test_action = do
940− vty <- mkVty defaultConfig
941+ vty <- mkVty def
941− showCursor $ outputIface vty
942+ show_cursor $ output_iface vty
942− setCursorPos (outputIface vty) 5 5
943+ set_cursor_pos (output_iface vty) 5 5
943− nextEvent vty
944+ next_event vty
944− hideCursor $ outputIface vty
945+ hide_cursor $ output_iface vty
945− nextEvent vty
946+ next_event vty
946 shutdown vty
947 shutdown vty
947 return ()
948 return ()
948− , printSummary = putStr $ [s|
949+ , print_summary = putStr $ [s|
949 1. verify the cursor is displayed.
950 1. verify the cursor is displayed.
950 2. press enter
951 2. press enter
951 3. verify the cursor is hid.
952 3. verify the cursor is hid.
952 4. press enter.
953 4. press enter.
953 5. the display should return to the state before the test.
954 5. the display should return to the state before the test.
954|]
955|]
955− , confirmResults = genericOutputMatchConfirm
956+ , confirm_results = generic_output_match_confirm
956 }
957 }
957
958
958−outputImageAndWait :: Image -> IO ()
959+output_image_and_wait :: Image -> IO ()
959−outputImageAndWait image = do
960+output_image_and_wait image = do
960− let pic = picForImage image
961+ let pic = pic_for_image image
961− outputPicAndWait pic
962+ output_pic_and_wait pic
962−
963+
963−outputPicAndWait :: Picture -> IO ()
964+output_pic_and_wait :: Picture -> IO ()
964−outputPicAndWait pic = do
965+output_pic_and_wait pic = do
965− t <- standardIOConfig >>= outputForConfig
966+ t <- output_for_current_terminal
966− reserveDisplay t
967+ reserve_display t
967− d <- displayBounds t >>= displayContext t
968+ d <- display_bounds t >>= display_context t
968− outputPicture d pic
969+ output_picture d pic
969 getLine
970 getLine
970− releaseDisplay t
971+ release_display t
971− releaseTerminal t
972+ release_terminal t
972 return ()
973 return ()
973−
974+
974−vertCropTest0 :: Test
975+vert_crop_test_0 :: Test
975−vertCropTest0 = Test
976+vert_crop_test_0 = Test
976− { testName = "Verify bottom cropping works as expected with single column chars"
977+ { test_name = "Verify bottom cropping works as expected with single column chars"
977− , testID = "cropTest0"
978+ , test_ID = "crop_test_0"
978− , testAction = do
979+ , test_action = do
979− let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsum
980+ let block_0 = crop_bottom 2 $ vert_cat $ map (string def_attr) lorum_ipsum
980− block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsum
981+ block_1 = vert_cat $ map (string def_attr) $ take 2 lorum_ipsum
981− image = block0 <-> backgroundFill 10 2 <-> block1
982+ image = block_0 <-> background_fill 10 2 <-> block_1
982− outputImageAndWait image
983+ output_image_and_wait image
983− , printSummary = putStr $ [s|
984+ , print_summary = putStr $ [s|
984 1. Verify the two text blocks are identical.
985 1. Verify the two text blocks are identical.
985 2. press enter.
986 2. press enter.
986 3. the display should return to the state before the test.
987 3. the display should return to the state before the test.
987|]
988|]
988− , confirmResults = genericOutputMatchConfirm
989+ , confirm_results = generic_output_match_confirm
989 }
990 }
990
991
991−vertCropTest1 :: Test
992+vert_crop_test_1 :: Test
992−vertCropTest1 = Test
993+vert_crop_test_1 = Test
993− { testName = "Verify bottom cropping works as expected with double column chars"
994+ { test_name = "Verify bottom cropping works as expected with double column chars"
994− , testID = "cropTest0"
995+ , test_ID = "crop_test_0"
995− , testAction = do
996+ , test_action = do
996− let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsumChinese
997+ let block_0 = crop_bottom 2 $ vert_cat $ map (string def_attr) lorum_ipsum_chinese
997− block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsumChinese
998+ block_1 = vert_cat $ map (string def_attr) $ take 2 lorum_ipsum_chinese
998− image = block0 <-> backgroundFill 10 2 <-> block1
999+ image = block_0 <-> background_fill 10 2 <-> block_1
999− outputImageAndWait image
1000+ output_image_and_wait image
1000− , printSummary = putStr $ [s|
1001+ , print_summary = putStr $ [s|
1001 1. Verify the two text blocks are identical.
1002 1. Verify the two text blocks are identical.
1002 2. press enter.
1003 2. press enter.
1003 3. the display should return to the state before the test.
1004 3. the display should return to the state before the test.
1004|]
1005|]
1005− , confirmResults = genericOutputMatchConfirm
1006+ , confirm_results = generic_output_match_confirm
1006 }
1007 }
1007
1008
1008−vertCropTest2 :: Test
1009+vert_crop_test_2 :: Test
1009−vertCropTest2 = Test
1010+vert_crop_test_2 = Test
1010− { testName = "Verify top cropping works as expected with single column chars"
1011+ { test_name = "Verify top cropping works as expected with single column chars"
1011− , testID = "cropTest2"
1012+ , test_ID = "crop_test_0"
1012− , testAction = do
1013+ , test_action = do
1013− let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsum
1014+ let block_0 = crop_top 2 $ vert_cat $ map (string def_attr) lorum_ipsum
1014− block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsum - 2) lorumIpsum
1015+ block_1 = vert_cat $ map (string def_attr) $ drop (length lorum_ipsum - 2) lorum_ipsum
1015− image = block0 <-> backgroundFill 10 2 <-> block1
1016+ image = block_0 <-> background_fill 10 2 <-> block_1
1016− outputImageAndWait image
1017+ output_image_and_wait image
1017− , printSummary = putStr $ [s|
1018+ , print_summary = putStr $ [s|
1018 1. Verify the two text blocks are identical.
1019 1. Verify the two text blocks are identical.
1019 2. press enter.
1020 2. press enter.
1020 3. the display should return to the state before the test.
1021 3. the display should return to the state before the test.
1021|]
1022|]
1022− , confirmResults = genericOutputMatchConfirm
1023+ , confirm_results = generic_output_match_confirm
1023 }
1024 }
1024
1025
1025−vertCropTest3 :: Test
1026+vert_crop_test_3 :: Test
1026−vertCropTest3 = Test
1027+vert_crop_test_3 = Test
1027− { testName = "Verify top cropping works as expected with double column chars"
1028+ { test_name = "Verify top cropping works as expected with double column chars"
1028− , testID = "cropTest0"
1029+ , test_ID = "crop_test_0"
1029− , testAction = do
1030+ , test_action = do
1030− let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsumChinese
1031+ let block_0 = crop_top 2 $ vert_cat $ map (string def_attr) lorum_ipsum_chinese
1031− block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsumChinese - 2 ) lorumIpsumChinese
1032+ block_1 = vert_cat $ map (string def_attr) $ drop (length lorum_ipsum_chinese - 2 ) lorum_ipsum_chinese
1032− image = block0 <-> backgroundFill 10 2 <-> block1
1033+ image = block_0 <-> background_fill 10 2 <-> block_1
1033− outputImageAndWait image
1034+ output_image_and_wait image
1034− , printSummary = putStr $ [s|
1035+ , print_summary = putStr $ [s|
1035 1. Verify the two text blocks are identical.
1036 1. Verify the two text blocks are identical.
1036 2. press enter.
1037 2. press enter.
1037 3. the display should return to the state before the test.
1038 3. the display should return to the state before the test.
1038|]
1039|]
1039− , confirmResults = genericOutputMatchConfirm
1040+ , confirm_results = generic_output_match_confirm
1040 }
1041 }
1041
1042
1042−horizCropTest0 :: Test
1043+horiz_crop_test_0 :: Test
1043−horizCropTest0 = Test
1044+horiz_crop_test_0 = Test
1044− { testName = "Verify right cropping works as expected with single column chars"
1045+ { test_name = "Verify right cropping works as expected with single column chars"
1045− , testID = "cropTest0"
1046+ , test_ID = "crop_test_0"
1046− , testAction = do
1047+ , test_action = do
1047− let baseImage = vertCat $ map (string defAttr) lorumIpsum
1048+ let base_image = vert_cat $ map (string def_attr) lorum_ipsum
1048− croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1049+ cropped_image = crop_right (image_width base_image `div` 2) base_image
1049− image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1050+ image = base_image <-> background_fill 10 2 <-> cropped_image
1050− outputImageAndWait image
1051+ output_image_and_wait image
1051− , printSummary = putStr $ [s|
1052+ , print_summary = putStr $ [s|
1052 1. Verify the bottom text block is about half the width of the top text block.
1053 1. Verify the bottom text block is about half the width of the top text block.
1053 2. press enter.
1054 2. press enter.
1054 3. the display should return to the state before the test.
1055 3. the display should return to the state before the test.
1055|]
1056|]
1056− , confirmResults = genericOutputMatchConfirm
1057+ , confirm_results = generic_output_match_confirm
1057 }
1058 }
1058
1059
1059−horizCropTest1 :: Test
1060+horiz_crop_test_1 :: Test
1060−horizCropTest1 = Test
1061+horiz_crop_test_1 = Test
1061− { testName = "Verify right cropping works as expected with double column chars"
1062+ { test_name = "Verify right cropping works as expected with double column chars"
1062− , testID = "cropTest0"
1063+ , test_ID = "crop_test_0"
1063− , testAction = do
1064+ , test_action = do
1064− let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
1065+ let base_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese
1065− croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1066+ cropped_image = crop_right (image_width base_image `div` 2) base_image
1066− image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1067+ image = base_image <-> background_fill 10 2 <-> cropped_image
1067− outputImageAndWait image
1068+ output_image_and_wait image
1068− , printSummary = putStr $ [s|
1069+ , print_summary = putStr $ [s|
1069 1. Verify the bottom text block is the left half of the top block. Ellipses on the right edge are OK.
1070 1. Verify the bottom text block is the left half of the top block. Ellipses on the right edge are OK.
1070 2. press enter.
1071 2. press enter.
1071 3. the display should return to the state before the test.
1072 3. the display should return to the state before the test.
1072|]
1073|]
1073− , confirmResults = genericOutputMatchConfirm
1074+ , confirm_results = generic_output_match_confirm
1074 }
1075 }
1075
1076
1076−horizCropTest2 :: Test
1077+horiz_crop_test_2 :: Test
1077−horizCropTest2 = Test
1078+horiz_crop_test_2 = Test
1078− { testName = "Verify left cropping works as expected with single column chars"
1079+ { test_name = "Verify left cropping works as expected with single column chars"
1079− , testID = "cropTest0"
1080+ , test_ID = "crop_test_0"
1080− , testAction = do
1081+ , test_action = do
1081− let baseImage = vertCat $ map (string defAttr) lorumIpsum
1082+ let base_image = vert_cat $ map (string def_attr) lorum_ipsum
1082− croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
1083+ cropped_image = crop_left (image_width base_image `div` 2) base_image
1083− image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1084+ image = base_image <-> background_fill 10 2 <-> cropped_image
1084− outputImageAndWait image
1085+ output_image_and_wait image
1085− , printSummary = putStr $ [s|
1086+ , print_summary = putStr $ [s|
1086 1. Verify the bottom text block is the right half of the top text block.
1087 1. Verify the bottom text block is the right half of the top text block.
1087 2. press enter.
1088 2. press enter.
1088 3. the display should return to the state before the test.
1089 3. the display should return to the state before the test.
1089|]
1090|]
1090− , confirmResults = genericOutputMatchConfirm
1091+ , confirm_results = generic_output_match_confirm
1091 }
1092 }
1092
1093
1093−horizCropTest3 :: Test
1094+horiz_crop_test_3 :: Test
1094−horizCropTest3 = Test
1095+horiz_crop_test_3 = Test
1095− { testName = "Verify right cropping works as expected with double column chars"
1096+ { test_name = "Verify right cropping works as expected with double column chars"
1096− , testID = "cropTest0"
1097+ , test_ID = "crop_test_0"
1097− , testAction = do
1098+ , test_action = do
1098− let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
1099+ let base_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese
1099− croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
1100+ cropped_image = crop_left (image_width base_image `div` 2) base_image
1100− image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1101+ image = base_image <-> background_fill 10 2 <-> cropped_image
1101− outputImageAndWait image
1102+ output_image_and_wait image
1102− , printSummary = putStr $ [s|
1103+ , print_summary = putStr $ [s|
1103 1. Verify the bottom text block is the right half of the top block. Ellipses on the left edge are OK.
1104 1. Verify the bottom text block is the right half of the top block. Ellipses on the left edge are OK.
1104 2. press enter.
1105 2. press enter.
1105 3. the display should return to the state before the test.
1106 3. the display should return to the state before the test.
1106|]
1107|]
1107− , confirmResults = genericOutputMatchConfirm
1108+ , confirm_results = generic_output_match_confirm
1108 }
1109 }
1109
1110
1110−layer0 :: Test
1111+layer_0 :: Test
1111−layer0 = Test
1112+layer_0 = Test
1112− { testName = "verify layer 0"
1113+ { test_name = "verify layer 0"
1113− , testID = "layer0"
1114+ , test_ID = "layer_0"
1114− , testAction = do
1115+ , test_action = do
1115− let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese
1116+ let upper_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese
1116− lowerImage = vertCat $ map (string defAttr) lorumIpsum
1117+ lower_image = vert_cat $ map (string def_attr) lorum_ipsum
1117− p = picForLayers [upperImage, lowerImage]
1118+ p = pic_for_layers [upper_image, lower_image]
1118− outputPicAndWait p
1119+ output_pic_and_wait p
1119− , printSummary = putStr $ [s|
1120+ , print_summary = putStr $ [s|
1120 1. Verify the text block appears to be Chinese text placed on top Latin text.
1121 1. Verify the text block appears to be Chinese text placed on top Latin text.
1121 2. press enter.
1122 2. press enter.
1122 3. the display should return to the state before the test.
1123 3. the display should return to the state before the test.
1123|]
1124|]
1124− , confirmResults = genericOutputMatchConfirm
1125+ , confirm_results = generic_output_match_confirm
1125 }
1126 }
1126
1127
1127−layer1 :: Test
1128+layer_1 :: Test
1128−layer1 = Test
1129+layer_1 = Test
1129− { testName = "verify layer 1"
1130+ { test_name = "verify layer 1"
1130− , testID = "layer1"
1131+ , test_ID = "layer_1"
1131− , testAction = do
1132+ , test_action = do
1132− let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese
1133+ let upper_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese
1133− block = resize 10 10 upperImage
1134+ block = resize 10 10 upper_image
1134− layer0 = vertCat $ map (string defAttr) lorumIpsum
1135+ layer_0 = vert_cat $ map (string def_attr) lorum_ipsum
1135− layer1 = charFill (defAttr `withBackColor` blue) '#' 1000 1000
1136+ layer_1 = char_fill (def_attr `with_back_color` blue) '#' 1000 1000
1136− cheesyAnim0 block [layer0, layer1]
1137+ cheesy_anim_0 block [layer_0, layer_1]
1137− , printSummary = putStr $ [s|
1138+ , print_summary = putStr $ [s|
1138 1. Verify the text block appears to be Chinese text moving on top a Latin text.
1139 1. Verify the text block appears to be Chinese text moving on top a Latin text.
1139 Which is all on a background of '#' characters over blue.
1140 Which is all on a background of '#' characters over blue.
1140 2. press enter.
1141 2. press enter.
1141 3. the display should return to the state before the test.
1142 3. the display should return to the state before the test.
1142|]
1143|]
1143− , confirmResults = genericOutputMatchConfirm
1144+ , confirm_results = generic_output_match_confirm
1144 }
1145 }
1145
1146
1146−cheesyAnim0 :: Image -> [Image] -> IO ()
1147+cheesy_anim_0 :: Image -> [Image] -> IO ()
1147−cheesyAnim0 i background = do
1148+cheesy_anim_0 i background = do
1148− t <- standardIOConfig >>= outputForConfig
1149+ t <- output_for_current_terminal
1149− reserveDisplay t
1150+ reserve_display t
1150− bounds <- displayBounds t
1151+ bounds <- display_bounds t
1151− d <- displayContext t bounds
1152+ d <- display_context t bounds
1152− forM_ [0..2] $ \t -> do
1153+ forM_ [0..100] $ \t -> do
1153− forM_ [0..100] $ \t -> do
1154 let i_offset = translate (t `mod` fst bounds)
1154 let i_offset = translate (t `mod` fst bounds)
1155 (t `div` 2 `mod` snd bounds)
1155 (t `div` 2 `mod` snd bounds)
1156 i
1156 i
1157− let pic = picForLayers $ i_offset : background
1157+ let pic = pic_for_layers $ i_offset : background
1158− outputPicture d pic
1158+ output_picture d pic
1159− threadDelay 50000
1160− forM_ [0..100] $ \t -> do
1161− let i_offset = translate (t * (-1) `mod` fst bounds)
1162− (t * (-1) `div` 2 `mod` snd bounds)
1163− i
1164− let pic = picForLayers $ i_offset : background
1165− outputPicture d pic
1166 threadDelay 50000
1159 threadDelay 50000
1167− releaseDisplay t
1160+ release_display t
1168− releaseTerminal t
1161+ release_terminal t
1169 return ()
1162 return ()
1170
1163
1171−lorumIpsum :: [String]
1164+lorum_ipsum :: [String]
1172−lorumIpsum = lines [s|
1165+lorum_ipsum = lines [s|
1173Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium,
1166Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium,
1174totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae
1167totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae
1175dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit,
1168dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit,
@@ -1181,8 +1174,8 @@ commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate v
1181molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
1174molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
1182|]
1175|]
1183
1176
1184−lorumIpsumChinese :: [String]
1177+lorum_ipsum_chinese :: [String]
1185−lorumIpsumChinese = lines [s|
1178+lorum_ipsum_chinese = lines [s|
1186輐銛 螷蟞覮 裌覅詵 暕 鴅噮 槶 惝掭掝 婸媥媕 耏胠臿, 汫汭沎 忕汌卣 蚡袀 僣 蒮 瀁瀎瀊 渮湸湤 緌翢,
1179輐銛 螷蟞覮 裌覅詵 暕 鴅噮 槶 惝掭掝 婸媥媕 耏胠臿, 汫汭沎 忕汌卣 蚡袀 僣 蒮 瀁瀎瀊 渮湸湤 緌翢,
1187腠腶舝 糲蘥蠩 樏殣氀 蒮 蹢鎒 滍 鸄齴 櫧櫋瀩 鬄鵊鵙 莃荶衒, 毸溠 橀 簎艜薤 莃荶衒 翣聜蒢
1180腠腶舝 糲蘥蠩 樏殣氀 蒮 蹢鎒 滍 鸄齴 櫧櫋瀩 鬄鵊鵙 莃荶衒, 毸溠 橀 簎艜薤 莃荶衒 翣聜蒢
1188斔櫅檷 晛桼桾 拻敁柧 犿玒 膣, 墐 笓粊紒 bacon 鼀齕, 蔝蓶蓨 顊顃餭 姴怤 骱 暕 蹢鎒鎛 藒襓謥 鄻鎟霣
1181斔櫅檷 晛桼桾 拻敁柧 犿玒 膣, 墐 笓粊紒 bacon 鼀齕, 蔝蓶蓨 顊顃餭 姴怤 骱 暕 蹢鎒鎛 藒襓謥 鄻鎟霣
test/vty-examples.cabal+52−76
@@ -1,39 +1,25 @@
1name: vty-examples
1name: vty-examples
2−version: 5.7
2+version: 5.0.0
3license: BSD3
3license: BSD3
4−license-file: LICENSE
4+license-file: ../LICENSE
5author: AUTHORS
5author: AUTHORS
6−maintainer: Jonathan Daugherty (cygnus@foobox.com)
6+maintainer: Corey O'Connor (coreyoconnor@gmail.com)
7−homepage: https://github.com/jtdaugherty/vty
7+homepage: https://github.com/coreyoconnor/vty
8category: User Interfaces
8category: User Interfaces
9synopsis: Examples programs using the vty library.
9synopsis: Examples programs using the vty library.
10description:
10description:
11− vty is terminal GUI library in the niche of ncurses. It is intended to
11+ vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, have no
12− be easy to use, have no confusing corner cases, and good support for
12+ confusing corner cases, and good support for common terminal types.
13− common terminal types.
14 .
13 .
15− vty-interactive-terminal-test - interactive test. Useful for building
14+ vty-interactive-terminal-test - interactive test. Useful for building a bug report for vtys author.
16− a bug report for vtys author.
15+ vty-event-echo - view a input event log for vty. Example of interacting with user.
17− .
16+ vty-rouge - A bad rouge-like game. Go from the entrance to exit. Example of layers
18− vty-event-echo - view a input event log for vty. Example of
17+ vty-benchmark - benchmarks vty. A series of tests that push random pictures to the terminal.
19− interacting with user.
20− .
21− vty-rogue - A bad rogue-like game. Go from the entrance to exit.
22− Example of layers
23− .
24− vty-benchmark - benchmarks vty. A series of tests that push random
25− pictures to the terminal.
26 .
18 .
27 &#169; Corey O'Connor; BSD3 license.
19 &#169; Corey O'Connor; BSD3 license.
28− .
29− &#169; Jonathan Daugherty; BSD3 license.
30cabal-version: >= 1.18.0
20cabal-version: >= 1.18.0
31build-type: Simple
21build-type: Simple
32
22
33−source-repository head
34− type: git
35− location: https://github.com/jtdaugherty/vty.git
36−
37executable vty-interactive-terminal-test
23executable vty-interactive-terminal-test
38 main-is: interactive_terminal_test.hs
24 main-is: interactive_terminal_test.hs
39
25
@@ -41,67 +27,63 @@ executable vty-interactive-terminal-test
41 default-extensions: ScopedTypeVariables
27 default-extensions: ScopedTypeVariables
42 ghc-options: -threaded
28 ghc-options: -threaded
43
29
44− build-depends: vty >= 5.15,
30+ build-depends: vty,
45 base >= 4 && < 5,
31 base >= 4 && < 5,
46 bytestring,
32 bytestring,
47 containers,
33 containers,
48− data-default,
34+ data-default >= 0.5.3,
49− deepseq,
35+ deepseq >= 1.1 && < 1.4,
50 lens,
36 lens,
51− mtl,
37+ mtl >= 1.1.1.0 && < 2.2,
52− parallel,
38+ parallel >= 2.2 && < 3.3,
53− parsec,
39+ parsec >= 2 && < 4,
54 string-qq,
40 string-qq,
55− terminfo,
41+ terminfo >= 0.3 && < 0.4,
56− text,
42+ text >= 0.11.3,
57 unix,
43 unix,
58− utf8-string,
44+ utf8-string >= 0.3 && < 0.4,
59− vector
45+ vector >= 0.7
60−
61− other-modules: Verify.Data.Terminfo.Parse
62− Verify
63
46
64executable vty-event-echo
47executable vty-event-echo
65 main-is: EventEcho.hs
48 main-is: EventEcho.hs
66
49
67 default-language: Haskell2010
50 default-language: Haskell2010
68 default-extensions: ScopedTypeVariables
51 default-extensions: ScopedTypeVariables
69− FlexibleContexts
70 ghc-options: -threaded
52 ghc-options: -threaded
71
53
72− build-depends: vty >= 5.15,
54+ build-depends: vty,
73 base >= 4 && < 5,
55 base >= 4 && < 5,
74− array,
56+ array >= 0.4 && < 2.0,
75 bytestring,
57 bytestring,
76 containers,
58 containers,
77− data-default,
59+ data-default >= 0.5.3,
78 lens,
60 lens,
79− mtl,
61+ mtl >= 1.1.1.0 && < 2.2,
80− parallel,
62+ parallel >= 2.2 && < 3.3,
81− text,
63+ text >= 0.11.3,
82− utf8-string,
64+ utf8-string >= 0.3 && < 0.4,
83− vector
65+ vector >= 0.7
84
66
85−executable vty-rogue
67+executable vty-rouge
86− main-is: Rogue.hs
68+ main-is: Rouge.hs
87
69
88 default-language: Haskell2010
70 default-language: Haskell2010
89 default-extensions: ScopedTypeVariables
71 default-extensions: ScopedTypeVariables
90 ghc-options: -threaded
72 ghc-options: -threaded
91
73
92− build-depends: vty >= 5.15,
74+ build-depends: vty,
93 base >= 4 && < 5,
75 base >= 4 && < 5,
94− array,
76+ array >= 0.4 && < 2.0,
95 bytestring,
77 bytestring,
96 containers,
78 containers,
97− data-default,
79+ data-default >= 0.5.3,
98 lens,
80 lens,
99− mtl,
81+ mtl >= 1.1.1.0 && < 2.2,
100− parallel,
82+ parallel >= 2.2 && < 3.3,
101− random,
83+ random >= 1.0 && < 2.0,
102− text,
84+ text >= 0.11.3,
103− utf8-string,
85+ utf8-string >= 0.3 && < 0.4,
104− vector
86+ vector >= 0.7
105
87
106executable vty-benchmark
88executable vty-benchmark
107 main-is: benchmark.hs
89 main-is: benchmark.hs
@@ -110,29 +92,23 @@ executable vty-benchmark
110 default-extensions: ScopedTypeVariables
92 default-extensions: ScopedTypeVariables
111 ghc-options: -threaded
93 ghc-options: -threaded
112
94
113− build-depends: vty >= 5.15,
95+ build-depends: vty,
114 base >= 4 && < 5,
96 base >= 4 && < 5,
115 bytestring,
97 bytestring,
116− Cabal,
98+ Cabal == 1.18.*,
117 containers,
99 containers,
118− data-default,
100+ data-default >= 0.5.3,
119− deepseq,
101+ deepseq >= 1.1 && < 1.4,
120 lens,
102 lens,
121− mtl,
103+ mtl >= 1.1.1.0 && < 2.2,
122− parallel,
104+ parallel >= 2.2 && < 3.3,
123− parsec,
105+ parsec >= 2 && < 4,
124− QuickCheck,
106+ QuickCheck >= 2.4,
125− random,
107+ random == 1.0.*,
126 string-qq,
108 string-qq,
127− terminfo,
109+ terminfo >= 0.3 && < 0.4,
128− text,
110+ text >= 0.11.3,
129 unix,
111 unix,
130− utf8-string,
112+ utf8-string >= 0.3 && < 0.4,
131− vector
113+ vector >= 0.7
132
114
133− other-modules: BenchImageFuzz
134− BenchNoDiffOpt
135− BenchRenderChar
136− BenchVerticalScroll
137− Verify.Graphics.Vty.Image
138− Verify.Graphics.Vty.Attributes
test/vty_inline_example.hs+2−2
@@ -3,7 +3,7 @@ import Graphics.Vty.Inline
3
3
4main = do
4main = do
5 putStr "Not styled. "
5 putStr "Not styled. "
6− putAttrChange_ t $ backColor red >> applyStyle underline
6+ put_attr_change_ t $ back_color red >> apply_style underline
7 putStr " Styled! "
7 putStr " Styled! "
8− putAttrChange_ t $ defaultAll
8+ put_attr_change_ t $ default_all
9 putStrLn "Not styled."
9 putStrLn "Not styled."
test/Issue18.hs → test/vty_issue_18.hsrenamed+6−4
@@ -1,4 +1,5 @@
1−module Main where
1+module Main
2+ where
2
3
3import Graphics.Vty
4import Graphics.Vty
4import Graphics.Vty.Debug
5import Graphics.Vty.Debug
@@ -12,8 +13,8 @@ main = do
12 play vty sx sy
13 play vty sx sy
13
14
14play :: Vty -> Int -> Int -> IO ()
15play :: Vty -> Int -> Int -> IO ()
15−play vty sx sy =
16+play vty sx sy =
16− let
17+ let
17 testScreen = pic {
18 testScreen = pic {
18 pCursor = NoCursor
19 pCursor = NoCursor
19 , pImage = box 10 10 }
20 , pImage = box 10 10 }
@@ -30,5 +31,6 @@ box w h =
30 vertLine = renderFill attr '|' 1 (h - 2)
31 vertLine = renderFill attr '|' 1 (h - 2)
31 horizLine = corner <|> renderHFill attr '-' (w - 2) <|> corner
32 horizLine = corner <|> renderHFill attr '-' (w - 2) <|> corner
32 centerArea = vertLine <|> renderFill attr 'X' (w - 2) (h - 2) <|> vertLine
33 centerArea = vertLine <|> renderFill attr 'X' (w - 2) (h - 2) <|> vertLine
33− in
34+ in
34 horizLine <-> centerArea <-> horizLine
35 horizLine <-> centerArea <-> horizLine
36+
test/YiIssue264.hs → test/yi_issue_264.hsrenamed−1
@@ -1,5 +1,4 @@
1module Main where
1module Main where
2−
3import Graphics.Vty
2import Graphics.Vty
4import Control.Exception
3import Control.Exception
5
4
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
view-benchmark-corenew file+4
@@ -0,0 +1,4 @@
1+#!/bin/sh
2+ghc-core --no-asm --no-cast -- \
3+ -hide-package vty-5.0.0 -i../src -XScopedTypeVariables ../dist/build/cbits/*.o \
4+ benchmark
vty.cabal+187−272
@@ -1,76 +1,64 @@
1name: vty
1name: vty
2−version: 5.35.1
2+version: 5.0.0
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: AUTHORS
5author: AUTHORS
6−maintainer: Jonathan Daugherty (cygnus@foobox.com)
6+maintainer: Corey O'Connor (coreyoconnor@gmail.com)
7−homepage: https://github.com/jtdaugherty/vty
7+homepage: https://github.com/coreyoconnor/vty
8category: User Interfaces
8category: User Interfaces
9synopsis: A simple terminal UI library
9synopsis: A simple terminal UI library
10description:
10description:
11− vty is terminal GUI library in the niche of ncurses. It is intended to
11+ vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, have no
12− be easy to use, have no confusing corner cases, and good support for
12+ confusing corner cases, and good support for common terminal types.
13− common terminal types.
14 .
13 .
15− See the @vty-examples@ package as well as the program
14+ Included in the source distribution is a program test/interactive_terminal_test.hs that
16− @test/interactive_terminal_test.hs@ included in the @vty@ package for
15+ demonstrates the various features.
17− examples on how to use the library.
18 .
16 .
19− Import the "Graphics.Vty" convenience module to get access to the core
17+ If your terminal is not behaving as expected the results of the vty-interactive-terminal-test
20− parts of the library.
18+ executable should be sent to the Vty maintainter to aid in debugging the issue.
19+ .
20+ Notable infelicities: Sometimes poor efficiency; Assumes UTF-8 character encoding support by the
21+ terminal; Poor signal handling; Requires terminfo.
22+ .
23+ Project is hosted on github.com: https:\/\/github.com\/coreyoconnor\/vty
24+ .
25+ git clone git:\/\/github.com\/coreyoconnor\/vty.git
21 .
26 .
22 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
27 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
23 .
28 .
24 &#169; Corey O'Connor; BSD3 license.
29 &#169; Corey O'Connor; BSD3 license.
25− .
30+cabal-version: >= 1.18.0
26− &#169; Jonathan Daugherty; BSD3 license.
27−cabal-version: 1.18
28build-type: Simple
31build-type: Simple
29−extra-doc-files: README.md,
32+data-files: README.md,
33+ TODO,
30 AUTHORS,
34 AUTHORS,
31− CHANGELOG.md,
35+ CHANGELOG,
32 LICENSE
36 LICENSE
33−tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5
37+tested-with: GHC >= 7.6.2
34−
35−source-repository head
36− type: git
37− location: https://github.com/jtdaugherty/vty.git
38
38
39library
39library
40 default-language: Haskell2010
40 default-language: Haskell2010
41− build-depends: base >= 4.8 && < 5,
41+ build-depends: base >= 4 && < 5,
42− blaze-builder >= 0.3.3.2 && < 0.5,
42+ blaze-builder >= 0.3.3.2 && < 0.4,
43 bytestring,
43 bytestring,
44 containers,
44 containers,
45− deepseq >= 1.1 && < 1.5,
45+ data-default >= 0.5.3,
46− directory,
46+ deepseq >= 1.1 && < 1.4,
47− filepath >= 1.0 && < 2.0,
47+ lens >= 3.9.0.2 && < 5.0,
48− microlens < 0.4.13,
48+ -- required for nice installation with yi
49− microlens-mtl,
50− microlens-th,
51 hashable >= 1.2,
49 hashable >= 1.2,
52− mtl >= 1.1.1.0 && < 2.3,
50+ mtl >= 1.1.1.0 && < 2.2,
53 parallel >= 2.2 && < 3.3,
51 parallel >= 2.2 && < 3.3,
54 parsec >= 2 && < 4,
52 parsec >= 2 && < 4,
55− stm,
53+ terminfo >= 0.3 && < 0.4,
56− terminfo >= 0.3 && < 0.5,
57 transformers >= 0.3.0.0,
54 transformers >= 0.3.0.0,
58 text >= 0.11.3,
55 text >= 0.11.3,
59 unix,
56 unix,
60− utf8-string >= 0.3 && < 1.1,
57+ utf8-string >= 0.3 && < 0.4,
61− vector >= 0.7,
58+ 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
59
69 exposed-modules: Graphics.Vty
60 exposed-modules: Graphics.Vty
70 Graphics.Vty.Attributes
61 Graphics.Vty.Attributes
71− Graphics.Vty.Attributes.Color
72− Graphics.Vty.Attributes.Color240
73− Graphics.Vty.Config
74 Graphics.Vty.Error
62 Graphics.Vty.Error
75 Graphics.Vty.Image
63 Graphics.Vty.Image
76 Graphics.Vty.Inline
64 Graphics.Vty.Inline
@@ -78,94 +66,71 @@ library
78 Graphics.Vty.Input
66 Graphics.Vty.Input
79 Graphics.Vty.Input.Events
67 Graphics.Vty.Input.Events
80 Graphics.Vty.Picture
68 Graphics.Vty.Picture
69+ Graphics.Vty.Prelude
81 Graphics.Vty.Output
70 Graphics.Vty.Output
82 Graphics.Text.Width
71 Graphics.Text.Width
72+ -- the modules below are only meant to be used by the tests.
83 Codec.Binary.UTF8.Debug
73 Codec.Binary.UTF8.Debug
84 Data.Terminfo.Parse
74 Data.Terminfo.Parse
85 Data.Terminfo.Eval
75 Data.Terminfo.Eval
86 Graphics.Vty.Debug
76 Graphics.Vty.Debug
87 Graphics.Vty.DisplayAttributes
77 Graphics.Vty.DisplayAttributes
88 Graphics.Vty.Image.Internal
78 Graphics.Vty.Image.Internal
89− Graphics.Vty.Input.Classify
79+ Graphics.Vty.Input.Internal
90− Graphics.Vty.Input.Classify.Types
91− Graphics.Vty.Input.Classify.Parse
92− Graphics.Vty.Input.Loop
93− Graphics.Vty.Input.Mouse
94− Graphics.Vty.Input.Focus
95− Graphics.Vty.Input.Paste
96 Graphics.Vty.Input.Terminfo
80 Graphics.Vty.Input.Terminfo
97 Graphics.Vty.PictureToSpans
81 Graphics.Vty.PictureToSpans
98 Graphics.Vty.Span
82 Graphics.Vty.Span
99 Graphics.Vty.Output.Mock
83 Graphics.Vty.Output.Mock
100 Graphics.Vty.Output.Interface
84 Graphics.Vty.Output.Interface
85+ Graphics.Vty.Output.MacOSX
101 Graphics.Vty.Output.XTermColor
86 Graphics.Vty.Output.XTermColor
102 Graphics.Vty.Output.TerminfoBased
87 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
88
108− other-modules: Graphics.Vty.Debug.Image
89+ other-modules: Graphics.Vty.Attributes.Color
109− Graphics.Vty.Input.Terminfo.ANSIVT
90+ Graphics.Vty.Attributes.Color240
91+ Graphics.Vty.Input.Terminfo.ANSI
92+ Graphics.Vty.Input.Terminfo.XTerm7Bit
110
93
111 c-sources: cbits/gwinsz.c
94 c-sources: cbits/gwinsz.c
112 cbits/set_term_timing.c
95 cbits/set_term_timing.c
113− cbits/get_tty_erase.c
114 cbits/mk_wcwidth.c
96 cbits/mk_wcwidth.c
115
97
116 include-dirs: cbits
98 include-dirs: cbits
117
99
118 hs-source-dirs: src
100 hs-source-dirs: src
119
101
120− ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
102+ default-extensions: ScopedTypeVariables
121−
103+ ForeignFunctionInterface
122− ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
123−
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
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−
139−executable vty-mode-demo
140− main-is: ModeDemo.hs
141− hs-source-dirs: demos
142
104
143− default-language: Haskell2010
105+ ghc-options: -O2 -funbox-strict-fields -threaded -Wall -fspec-constr -fspec-constr-count=10
144− ghc-options: -threaded
145
106
146− build-depends: vty,
107+ ghc-prof-options: -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10
147− base >= 4.8 && < 5,
148− containers,
149− microlens,
150− microlens-mtl,
151− mtl >= 1.1.1.0 && < 2.3
152
108
153−executable vty-demo
109+ cc-options: -O2
154− main-is: Demo.hs
155− hs-source-dirs: demos
156
110
111+test-suite verify-attribute-ops
157 default-language: Haskell2010
112 default-language: Haskell2010
158− ghc-options: -threaded
113+ default-extensions: ScopedTypeVariables
159−
114+ type: detailed-0.9
115+ hs-source-dirs: test
116+ test-module: VerifyAttributeOps
160 build-depends: vty,
117 build-depends: vty,
161− base >= 4.8 && < 5,
118+ Cabal == 1.18.*,
119+ QuickCheck >= 2.4,
120+ random == 1.0.*,
121+ base >= 4 && < 5,
122+ bytestring,
162 containers,
123 containers,
163− microlens,
124+ deepseq >= 1.1 && < 1.4,
164− microlens-mtl,
125+ mtl >= 1.1.1.0 && < 2.2,
165− mtl >= 1.1.1.0 && < 2.3
126+ text >= 0.11.3,
127+ unix,
128+ utf8-string >= 0.3 && < 0.4,
129+ vector >= 0.7
166
130
167test-suite verify-using-mock-terminal
131test-suite verify-using-mock-terminal
168 default-language: Haskell2010
132 default-language: Haskell2010
133+ default-extensions: ScopedTypeVariables
169
134
170 type: detailed-0.9
135 type: detailed-0.9
171
136
@@ -182,22 +147,23 @@ test-suite verify-using-mock-terminal
182 Verify.Graphics.Vty.Output
147 Verify.Graphics.Vty.Output
183
148
184 build-depends: vty,
149 build-depends: vty,
185− Cabal >= 1.20,
150+ Cabal == 1.18.*,
186− QuickCheck >= 2.7,
151+ QuickCheck >= 2.4,
187− random >= 1.0 && < 1.3,
152+ random == 1.0.*,
188− base >= 4.8 && < 5,
153+ base >= 4 && < 5,
189 bytestring,
154 bytestring,
190 containers,
155 containers,
191− deepseq >= 1.1 && < 1.5,
156+ deepseq >= 1.1 && < 1.4,
192− mtl >= 1.1.1.0 && < 2.3,
157+ mtl >= 1.1.1.0 && < 2.2,
193 text >= 0.11.3,
158 text >= 0.11.3,
194− terminfo >= 0.3 && < 0.5,
159+ terminfo,
195 unix,
160 unix,
196− utf8-string >= 0.3 && < 1.1,
161+ utf8-string >= 0.3 && < 0.4,
197 vector >= 0.7
162 vector >= 0.7
198−
163+
199test-suite verify-terminal
164test-suite verify-terminal
200 default-language: Haskell2010
165 default-language: Haskell2010
166+ default-extensions: ScopedTypeVariables
201
167
202 type: detailed-0.9
168 type: detailed-0.9
203
169
@@ -214,22 +180,23 @@ test-suite verify-terminal
214 Verify.Graphics.Vty.Output
180 Verify.Graphics.Vty.Output
215
181
216 build-depends: vty,
182 build-depends: vty,
217− Cabal >= 1.20,
183+ Cabal == 1.18.*,
218− QuickCheck >= 2.7,
184+ QuickCheck >= 2.4,
219− random >= 1.0 && < 1.3,
185+ random == 1.0.*,
220− base >= 4.8 && < 5,
186+ base >= 4 && < 5,
221 bytestring,
187 bytestring,
222 containers,
188 containers,
223− deepseq >= 1.1 && < 1.5,
189+ deepseq >= 1.1 && < 1.4,
224− mtl >= 1.1.1.0 && < 2.3,
190+ mtl >= 1.1.1.0 && < 2.2,
225− terminfo >= 0.3 && < 0.5,
191+ terminfo >= 0.3 && < 0.4,
226 text >= 0.11.3,
192 text >= 0.11.3,
227 unix,
193 unix,
228− utf8-string >= 0.3 && < 1.1,
194+ utf8-string >= 0.3 && < 0.4,
229 vector >= 0.7
195 vector >= 0.7
230
196
231test-suite verify-display-attributes
197test-suite verify-display-attributes
232 default-language: Haskell2010
198 default-language: Haskell2010
199+ default-extensions: ScopedTypeVariables
233
200
234 type: detailed-0.9
201 type: detailed-0.9
235
202
@@ -239,28 +206,28 @@ test-suite verify-display-attributes
239
206
240 other-modules: Verify
207 other-modules: Verify
241 Verify.Graphics.Vty.Attributes
208 Verify.Graphics.Vty.Attributes
242− Verify.Graphics.Vty.DisplayAttributes
243 Verify.Graphics.Vty.Prelude
209 Verify.Graphics.Vty.Prelude
244 Verify.Graphics.Vty.Picture
210 Verify.Graphics.Vty.Picture
245 Verify.Graphics.Vty.Image
211 Verify.Graphics.Vty.Image
246 Verify.Graphics.Vty.Span
212 Verify.Graphics.Vty.Span
247
213
248 build-depends: vty,
214 build-depends: vty,
249− Cabal >= 1.20,
215+ Cabal == 1.18.*,
250− QuickCheck >= 2.7,
216+ QuickCheck >= 2.4,
251− random >= 1.0 && < 1.3,
217+ random == 1.0.*,
252− base >= 4.8 && < 5,
218+ base >= 4 && < 5,
253 bytestring,
219 bytestring,
254 containers,
220 containers,
255− deepseq >= 1.1 && < 1.5,
221+ deepseq >= 1.1 && < 1.4,
256− mtl >= 1.1.1.0 && < 2.3,
222+ mtl >= 1.1.1.0 && < 2.2,
257 text >= 0.11.3,
223 text >= 0.11.3,
258 unix,
224 unix,
259− utf8-string >= 0.3 && < 1.1,
225+ utf8-string >= 0.3 && < 0.4,
260 vector >= 0.7
226 vector >= 0.7
261
227
262test-suite verify-empty-image-props
228test-suite verify-empty-image-props
263 default-language: Haskell2010
229 default-language: Haskell2010
230+ default-extensions: ScopedTypeVariables
264
231
265 type: detailed-0.9
232 type: detailed-0.9
266
233
@@ -271,21 +238,22 @@ test-suite verify-empty-image-props
271 other-modules: Verify
238 other-modules: Verify
272
239
273 build-depends: vty,
240 build-depends: vty,
274− Cabal >= 1.20,
241+ Cabal == 1.18.*,
275− QuickCheck >= 2.7,
242+ QuickCheck >= 2.4,
276− random >= 1.0 && < 1.3,
243+ random == 1.0.*,
277− base >= 4.8 && < 5,
244+ base >= 4 && < 5,
278 bytestring,
245 bytestring,
279 containers,
246 containers,
280− deepseq >= 1.1 && < 1.5,
247+ deepseq >= 1.1 && < 1.4,
281− mtl >= 1.1.1.0 && < 2.3,
248+ mtl >= 1.1.1.0 && < 2.2,
282 text >= 0.11.3,
249 text >= 0.11.3,
283 unix,
250 unix,
284− utf8-string >= 0.3 && < 1.1,
251+ utf8-string >= 0.3 && < 0.4,
285 vector >= 0.7
252 vector >= 0.7
286
253
287test-suite verify-eval-terminfo-caps
254test-suite verify-eval-terminfo-caps
288 default-language: Haskell2010
255 default-language: Haskell2010
256+ default-extensions: ScopedTypeVariables
289
257
290 type: detailed-0.9
258 type: detailed-0.9
291
259
@@ -297,23 +265,24 @@ test-suite verify-eval-terminfo-caps
297 Verify.Graphics.Vty.Output
265 Verify.Graphics.Vty.Output
298
266
299 build-depends: vty,
267 build-depends: vty,
300− Cabal >= 1.20,
268+ Cabal == 1.18.*,
301− QuickCheck >= 2.7,
269+ QuickCheck >= 2.4,
302− random >= 1.0 && < 1.3,
270+ random == 1.0.*,
303− base >= 4.8 && < 5,
271+ base >= 4 && < 5,
304− blaze-builder >= 0.3.3.2 && < 0.5,
272+ blaze-builder >= 0.3.3.2 && < 0.4,
305 bytestring,
273 bytestring,
306 containers,
274 containers,
307− deepseq >= 1.1 && < 1.5,
275+ deepseq >= 1.1 && < 1.4,
308− mtl >= 1.1.1.0 && < 2.3,
276+ mtl >= 1.1.1.0 && < 2.2,
309− terminfo >= 0.3 && < 0.5,
277+ terminfo >= 0.3 && < 0.4,
310 text >= 0.11.3,
278 text >= 0.11.3,
311 unix,
279 unix,
312− utf8-string >= 0.3 && < 1.1,
280+ utf8-string >= 0.3 && < 0.4,
313 vector >= 0.7
281 vector >= 0.7
314
282
315test-suite verify-image-ops
283test-suite verify-image-ops
316 default-language: Haskell2010
284 default-language: Haskell2010
285+ default-extensions: ScopedTypeVariables
317
286
318 type: detailed-0.9
287 type: detailed-0.9
319
288
@@ -326,21 +295,22 @@ test-suite verify-image-ops
326 Verify.Graphics.Vty.Image
295 Verify.Graphics.Vty.Image
327
296
328 build-depends: vty,
297 build-depends: vty,
329− Cabal >= 1.20,
298+ Cabal == 1.18.*,
330− QuickCheck >= 2.7,
299+ QuickCheck >= 2.4,
331− random >= 1.0 && < 1.3,
300+ random == 1.0.*,
332− base >= 4.8 && < 5,
301+ base >= 4 && < 5,
333 bytestring,
302 bytestring,
334 containers,
303 containers,
335− deepseq >= 1.1 && < 1.5,
304+ deepseq >= 1.1 && < 1.4,
336− mtl >= 1.1.1.0 && < 2.3,
305+ mtl >= 1.1.1.0 && < 2.2,
337 text >= 0.11.3,
306 text >= 0.11.3,
338 unix,
307 unix,
339− utf8-string >= 0.3 && < 1.1,
308+ utf8-string >= 0.3 && < 0.4,
340 vector >= 0.7
309 vector >= 0.7
341
310
342test-suite verify-image-trans
311test-suite verify-image-trans
343 default-language: Haskell2010
312 default-language: Haskell2010
313+ default-extensions: ScopedTypeVariables
344
314
345 type: detailed-0.9
315 type: detailed-0.9
346
316
@@ -353,21 +323,22 @@ test-suite verify-image-trans
353 Verify.Graphics.Vty.Image
323 Verify.Graphics.Vty.Image
354
324
355 build-depends: vty,
325 build-depends: vty,
356− Cabal >= 1.20,
326+ Cabal == 1.18.*,
357− QuickCheck >= 2.7,
327+ QuickCheck >= 2.4,
358− random >= 1.0 && < 1.3,
328+ random == 1.0.*,
359− base >= 4.8 && < 5,
329+ base >= 4 && < 5,
360 bytestring,
330 bytestring,
361 containers,
331 containers,
362− deepseq >= 1.1 && < 1.5,
332+ deepseq >= 1.1 && < 1.4,
363− mtl >= 1.1.1.0 && < 2.3,
333+ mtl >= 1.1.1.0 && < 2.2,
364 text >= 0.11.3,
334 text >= 0.11.3,
365 unix,
335 unix,
366− utf8-string >= 0.3 && < 1.1,
336+ utf8-string >= 0.3 && < 0.4,
367 vector >= 0.7
337 vector >= 0.7
368
338
369test-suite verify-inline
339test-suite verify-inline
370 default-language: Haskell2010
340 default-language: Haskell2010
341+ default-extensions: ScopedTypeVariables
371
342
372 type: detailed-0.9
343 type: detailed-0.9
373
344
@@ -379,21 +350,22 @@ test-suite verify-inline
379 Verify.Graphics.Vty.Output
350 Verify.Graphics.Vty.Output
380
351
381 build-depends: vty,
352 build-depends: vty,
382− Cabal >= 1.20,
353+ Cabal == 1.18.*,
383− QuickCheck >= 2.7,
354+ QuickCheck >= 2.4,
384− random >= 1.0 && < 1.3,
355+ random == 1.0.*,
385− base >= 4.8 && < 5,
356+ base >= 4 && < 5,
386 bytestring,
357 bytestring,
387 containers,
358 containers,
388− deepseq >= 1.1 && < 1.5,
359+ deepseq >= 1.1 && < 1.4,
389− mtl >= 1.1.1.0 && < 2.3,
360+ mtl >= 1.1.1.0 && < 2.2,
390 text >= 0.11.3,
361 text >= 0.11.3,
391 unix,
362 unix,
392− utf8-string >= 0.3 && < 1.1,
363+ utf8-string >= 0.3 && < 0.4,
393 vector >= 0.7
364 vector >= 0.7
394
365
395test-suite verify-parse-terminfo-caps
366test-suite verify-parse-terminfo-caps
396 default-language: Haskell2010
367 default-language: Haskell2010
368+ default-extensions: ScopedTypeVariables
397
369
398 type: detailed-0.9
370 type: detailed-0.9
399
371
@@ -406,22 +378,23 @@ test-suite verify-parse-terminfo-caps
406 Verify.Graphics.Vty.Output
378 Verify.Graphics.Vty.Output
407
379
408 build-depends: vty,
380 build-depends: vty,
409− Cabal >= 1.20,
381+ Cabal == 1.18.*,
410− QuickCheck >= 2.7,
382+ QuickCheck >= 2.4,
411− random >= 1.0 && < 1.3,
383+ random == 1.0.*,
412− base >= 4.8 && < 5,
384+ base >= 4 && < 5,
413 bytestring,
385 bytestring,
414 containers,
386 containers,
415− deepseq >= 1.1 && < 1.5,
387+ deepseq >= 1.1 && < 1.4,
416− mtl >= 1.1.1.0 && < 2.3,
388+ mtl >= 1.1.1.0 && < 2.2,
417− terminfo >= 0.3 && < 0.5,
389+ terminfo >= 0.3 && < 0.4,
418 text >= 0.11.3,
390 text >= 0.11.3,
419 unix,
391 unix,
420− utf8-string >= 0.3 && < 1.1,
392+ utf8-string >= 0.3 && < 0.4,
421 vector >= 0.7
393 vector >= 0.7
422−
394+
423test-suite verify-simple-span-generation
395test-suite verify-simple-span-generation
424 default-language: Haskell2010
396 default-language: Haskell2010
397+ default-extensions: ScopedTypeVariables
425
398
426 type: detailed-0.9
399 type: detailed-0.9
427
400
@@ -437,22 +410,23 @@ test-suite verify-simple-span-generation
437 Verify.Graphics.Vty.Span
410 Verify.Graphics.Vty.Span
438
411
439 build-depends: vty,
412 build-depends: vty,
440− Cabal >= 1.20,
413+ Cabal == 1.18.*,
441− QuickCheck >= 2.7,
414+ QuickCheck >= 2.4,
442− random >= 1.0 && < 1.3,
415+ random == 1.0.*,
443− base >= 4.8 && < 5,
416+ base >= 4 && < 5,
444 bytestring,
417 bytestring,
445 containers,
418 containers,
446− deepseq >= 1.1 && < 1.5,
419+ deepseq >= 1.1 && < 1.4,
447− mtl >= 1.1.1.0 && < 2.3,
420+ mtl >= 1.1.1.0 && < 2.2,
448 text >= 0.11.3,
421 text >= 0.11.3,
449 unix,
422 unix,
450− utf8-string >= 0.3 && < 1.1,
423+ utf8-string >= 0.3 && < 0.4,
451 vector >= 0.7
424 vector >= 0.7
452−
425+
453−
426+
454test-suite verify-crop-span-generation
427test-suite verify-crop-span-generation
455 default-language: Haskell2010
428 default-language: Haskell2010
429+ default-extensions: ScopedTypeVariables
456
430
457 type: detailed-0.9
431 type: detailed-0.9
458
432
@@ -468,22 +442,23 @@ test-suite verify-crop-span-generation
468 Verify.Graphics.Vty.Span
442 Verify.Graphics.Vty.Span
469
443
470 build-depends: vty,
444 build-depends: vty,
471− Cabal >= 1.20,
445+ Cabal == 1.18.*,
472− QuickCheck >= 2.7,
446+ QuickCheck >= 2.4,
473− random >= 1.0 && < 1.3,
447+ random == 1.0.*,
474− base >= 4.8 && < 5,
448+ base >= 4 && < 5,
475 bytestring,
449 bytestring,
476 containers,
450 containers,
477− deepseq >= 1.1 && < 1.5,
451+ deepseq >= 1.1 && < 1.4,
478− mtl >= 1.1.1.0 && < 2.3,
452+ mtl >= 1.1.1.0 && < 2.2,
479 text >= 0.11.3,
453 text >= 0.11.3,
480 unix,
454 unix,
481− utf8-string >= 0.3 && < 1.1,
455+ utf8-string >= 0.3 && < 0.4,
482 vector >= 0.7
456 vector >= 0.7
483−
457+
484
458
485test-suite verify-layers-span-generation
459test-suite verify-layers-span-generation
486 default-language: Haskell2010
460 default-language: Haskell2010
461+ default-extensions: ScopedTypeVariables
487
462
488 type: detailed-0.9
463 type: detailed-0.9
489
464
@@ -499,46 +474,22 @@ test-suite verify-layers-span-generation
499 Verify.Graphics.Vty.Span
474 Verify.Graphics.Vty.Span
500
475
501 build-depends: vty,
476 build-depends: vty,
502− Cabal >= 1.20,
477+ Cabal == 1.18.*,
503− QuickCheck >= 2.7,
478+ QuickCheck >= 2.4,
504− random >= 1.0 && < 1.3,
479+ random == 1.0.*,
505− base >= 4.8 && < 5,
480+ base >= 4 && < 5,
506 bytestring,
481 bytestring,
507 containers,
482 containers,
508− deepseq >= 1.1 && < 1.5,
483+ deepseq >= 1.1 && < 1.4,
509− mtl >= 1.1.1.0 && < 2.3,
484+ mtl >= 1.1.1.0 && < 2.2,
510 text >= 0.11.3,
485 text >= 0.11.3,
511 unix,
486 unix,
512− utf8-string >= 0.3 && < 1.1,
487+ utf8-string >= 0.3 && < 0.4,
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,
531− bytestring,
532− containers,
533− deepseq >= 1.1 && < 1.5,
534− mtl >= 1.1.1.0 && < 2.3,
535− text >= 0.11.3,
536− unix,
537− utf8-string >= 0.3 && < 1.1,
538 vector >= 0.7
488 vector >= 0.7
539
489
540test-suite verify-utf8-width
490test-suite verify-utf8-width
541 default-language: Haskell2010
491 default-language: Haskell2010
492+ default-extensions: ScopedTypeVariables
542
493
543 type: detailed-0.9
494 type: detailed-0.9
544
495
@@ -549,21 +500,22 @@ test-suite verify-utf8-width
549 other-modules: Verify
500 other-modules: Verify
550
501
551 build-depends: vty,
502 build-depends: vty,
552− Cabal >= 1.20,
503+ Cabal == 1.18.*,
553− QuickCheck >= 2.7,
504+ QuickCheck >= 2.4,
554− random >= 1.0 && < 1.3,
505+ random == 1.0.*,
555− base >= 4.8 && < 5,
506+ base >= 4 && < 5,
556 bytestring,
507 bytestring,
557 containers,
508 containers,
558− deepseq >= 1.1 && < 1.5,
509+ deepseq >= 1.1 && < 1.4,
559− mtl >= 1.1.1.0 && < 2.3,
510+ mtl >= 1.1.1.0 && < 2.2,
560 text >= 0.11.3,
511 text >= 0.11.3,
561 unix,
512 unix,
562− utf8-string >= 0.3 && < 1.1,
513+ utf8-string >= 0.3 && < 0.4,
563 vector >= 0.7
514 vector >= 0.7
564−
515+
565test-suite verify-using-mock-input
516test-suite verify-using-mock-input
566 default-language: Haskell2010
517 default-language: Haskell2010
518+ default-extensions: ScopedTypeVariables
567
519
568 type: exitcode-stdio-1.0
520 type: exitcode-stdio-1.0
569
521
@@ -571,63 +523,26 @@ test-suite verify-using-mock-input
571
523
572 main-is: VerifyUsingMockInput.hs
524 main-is: VerifyUsingMockInput.hs
573
525
574− other-modules: Verify.Graphics.Vty.Output
575−
576 build-depends: vty,
526 build-depends: vty,
577− Cabal >= 1.20,
527+ Cabal == 1.18.*,
578− QuickCheck >= 2.7,
528+ data-default >= 0.5.3,
529+ QuickCheck >= 2.4,
579 smallcheck == 1.*,
530 smallcheck == 1.*,
580 quickcheck-assertions >= 0.1.1,
531 quickcheck-assertions >= 0.1.1,
581 test-framework == 0.8.*,
532 test-framework == 0.8.*,
582 test-framework-smallcheck == 0.2.*,
533 test-framework-smallcheck == 0.2.*,
583− random >= 1.0 && < 1.3,
534+ random == 1.0.*,
584− base >= 4.8 && < 5,
535+ base >= 4 && < 5,
585 bytestring,
536 bytestring,
586 containers,
537 containers,
587− deepseq >= 1.1 && < 1.5,
538+ deepseq >= 1.1 && < 1.4,
588− microlens,
539+ lens >= 3.9.0.2 && < 4.0,
589− microlens-mtl,
540+ mtl >= 1.1.1.0 && < 2.2,
590− mtl >= 1.1.1.0 && < 2.3,
541+ terminfo >= 0.3 && < 0.4,
591− stm,
592− terminfo >= 0.3 && < 0.5,
593 text >= 0.11.3,
542 text >= 0.11.3,
594 unix,
543 unix,
595− utf8-string >= 0.3 && < 1.1,
544+ utf8-string >= 0.3 && < 0.4,
596 vector >= 0.7
545 vector >= 0.7
597−
546+
598 ghc-options: -threaded -Wall
547 ghc-options: -threaded -Wall
599
548
600−test-suite verify-config
601− default-language: Haskell2010
602−
603− type: exitcode-stdio-1.0
604−
605− hs-source-dirs: test
606−
607− main-is: VerifyConfig.hs
608−
609− build-depends: vty,
610− Cabal >= 1.20,
611− HUnit,
612− QuickCheck >= 2.7,
613− smallcheck == 1.*,
614− quickcheck-assertions >= 0.1.1,
615− test-framework == 0.8.*,
616− test-framework-smallcheck == 0.2.*,
617− test-framework-hunit,
618− random >= 1.0 && < 1.3,
619− base >= 4.8 && < 5,
620− bytestring,
621− containers,
622− deepseq >= 1.1 && < 1.5,
623− microlens,
624− microlens-mtl,
625− mtl >= 1.1.1.0 && < 2.3,
626− string-qq,
627− terminfo >= 0.3 && < 0.5,
628− text >= 0.11.3,
629− unix,
630− utf8-string >= 0.3 && < 1.1,
631− vector >= 0.7
632−
633− ghc-options: -threaded -Wall