git.iko.soy/vty
on master help sign in
swap
4a29aec445 ahead, 0 behind
102 files changed+5707−3137
since splitsnapshots
unifiedsplit
.gitignore+4 .travis.yml+101−21 AUTHORS+4−2 CHANGELOG−265 CHANGELOG.md+861 LICENSE+2 README.md+147−71 TODO−15 build_examples−2 cbits/get_tty_erase.c+18 cbits/gwinsz.c+14−5 cbits/gwinsz.h+2−1 cbits/mk_wcwidth.c+126−97 Demo.hs → demos/Demo.hs+14−8 demos/ModeDemo.hs+55 DESIGN → docs/DESIGN install_examples−4 src/Codec/Binary/UTF8/Debug.hs+4−6 src/Data/Sequence/Extra.hs+2−2 src/Data/Terminfo/Eval.hs+15−23 src/Data/Terminfo/Parse.hs+61−61 src/Graphics/Text/Width.hs+51−21 src/Graphics/Vty.hs+186−113 src/Graphics/Vty/Attributes.hs+121−120 src/Graphics/Vty/Attributes/Color.hs+162−22 src/Graphics/Vty/Attributes/Color240.hs+291−254 src/Graphics/Vty/Config.hs+398−194 src/Graphics/Vty/Debug.hs+13−14 src/Graphics/Vty/Debug/Image.hs+1−1 src/Graphics/Vty/DisplayAttributes.hs+64−33 src/Graphics/Vty/Error.hs+3−3 src/Graphics/Vty/Image.hs+200−126 src/Graphics/Vty/Image/Internal.hs+81−98 src/Graphics/Vty/Inline.hs+62−55 src/Graphics/Vty/Inline/Unsafe.hs+4−14 src/Graphics/Vty/Input.hs+97−127 src/Graphics/Vty/Input/Classify.hs+70−73 src/Graphics/Vty/Input/Classify/Parse.hs+18−14 src/Graphics/Vty/Input/Classify/Types.hs+10−3 src/Graphics/Vty/Input/Events.hs+50−20 src/Graphics/Vty/Input/Focus.hs+49 src/Graphics/Vty/Input/Loop.hs+109−47 src/Graphics/Vty/Input/Mouse.hs+38−28 src/Graphics/Vty/Input/Paste.hs+41 src/Graphics/Vty/Input/Terminfo.hs+34−33 src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+21−20 src/Graphics/Vty/Output.hs+62−52 src/Graphics/Vty/Output/Interface.hs+191−125 src/Graphics/Vty/Output/Mock.hs+45−25 src/Graphics/Vty/Output/TerminfoBased.hs+293−157 src/Graphics/Vty/Output/XTermColor.hs+94−39 src/Graphics/Vty/Picture.hs+71−45 src/Graphics/Vty/PictureToSpans.hs+80−97 src/Graphics/Vty/Prelude.hs−18 src/Graphics/Vty/Span.hs+46−55 src/Graphics/Vty/UnicodeWidthTable/IO.hs+105 src/Graphics/Vty/UnicodeWidthTable/Install.hs+129 src/Graphics/Vty/UnicodeWidthTable/Query.hs+79 src/Graphics/Vty/UnicodeWidthTable/Types.hs+29 stack.yaml−40 test/BenchImageFuzz.hs+1−3 test/BenchNoDiffOpt.hs+3−4 test/BenchRenderChar.hs+7−9 test/BenchVerticalScroll.hs+4−6 test/ControlTable.hs+1−1 test/EventEcho.hs+1−2 test/HereDoc.hs+2−4 test/Issue18.hs+4−6 test/Makefile+2−2 test/MinimalExample.hs+1−3 test/Rogue.hs+1−3 test/Test2.hs+1 test/Verify.hs+20−31 test/Verify/Data/Terminfo/Parse.hs+17−17 test/Verify/Graphics/Vty/Attributes.hs+7−7 test/Verify/Graphics/Vty/DisplayAttributes.hs+5−5 test/Verify/Graphics/Vty/Image.hs+18−18 test/Verify/Graphics/Vty/Output.hs+5−7 test/Verify/Graphics/Vty/Picture.hs+13−13 test/Verify/Graphics/Vty/Prelude.hs+5−7 test/Verify/Graphics/Vty/Span.hs+7−7 test/VerifyAttributeOps.hs−9 test/VerifyColor240.hs+269 test/VerifyConfig.hs+8−8 test/VerifyCropSpanGeneration.hs+2−3 test/VerifyEmptyImageProps.hs+2−1 test/VerifyEvalTerminfoCaps.hs+14−12 test/VerifyImageOps.hs+27−27 test/VerifyImageTrans.hs+1−1 test/VerifyLayersSpanGeneration.hs+9−7 test/VerifyOutput.hs+12−9 test/VerifyParseTerminfoCaps.hs+4−4 test/VerifySimpleSpanGeneration.hs+16−16 test/VerifyUsingMockInput.hs+26−22 test/VerifyUsingMockTerminal.hs+23−15 test/VerifyUtf8Width.hs+2 test/YiIssue264.hs+1 test/interactive_terminal_test.hs+51−52 test/vty-examples.cabal+24−14 tools/BuildWidthTable.hs+144 view-benchmark-core−4 vty.cabal+119−109
.gitignore+4
@@ -4,8 +4,12 @@
44*.prof
55Setup
66dist
7+dist-newstyle
8+cabal.project.local
9+.ghc.environment.*
710test/benchmark
811.hpc
912.cabal-sandbox
1013cabal.sandbox.config
1114test/cabal.sandbox.config
15+.stack-work
.travis.yml+101−21
@@ -1,29 +1,109 @@
1−language: haskell
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
8+sudo: false
29
3−notifications:
4− email: false
10+git:
11+ submodules: false # whether to recursively clone submodules
12+
13+cache:
14+ directories:
15+ - $HOME/.cabal/packages
16+ - $HOME/.cabal/store
17+
18+before_cache:
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
20+ # remove files that are regenerated by 'cabal update'
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26+
27+ - rm -rfv $HOME/.cabal/packages/head.hackage
528
629matrix:
7− allow_failures:
8− - env: CABALVER=head GHCVER=head
9− - env: CABALVER=1.20 GHCVER=7.4.2
10−
11−env:
12− - CABALVER=1.20 GHCVER=7.4.2
13− - CABALVER=1.20 GHCVER=7.6.3
14− - CABALVER=1.20 GHCVER=7.8.3
15− - CABALVER=1.22 GHCVER=7.10.1
16− - CABALVER=1.24 GHCVER=8.0.1
17− - CABALVER=head GHCVER=head
30+ include:
31+ - compiler: "ghc-8.4.3"
32+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
33+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
34+ - compiler: "ghc-8.2.2"
35+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
36+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}
37+ - compiler: "ghc-8.0.2"
38+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
39+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}
40+ - compiler: "ghc-7.10.3"
41+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
42+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}
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
1853
1954install:
20− - ./ci/travis_ci_install
55+ - cabal --version
56+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
57+ - BENCH=${BENCH---enable-benchmarks}
58+ - TEST=${TEST---enable-tests}
59+ - HADDOCK=${HADDOCK-true}
60+ - UNCONSTRAINED=${UNCONSTRAINED-true}
61+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
62+ - GHCHEAD=${GHCHEAD-false}
63+ - travis_retry cabal update -v
64+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
65+ - rm -fv cabal.project cabal.project.local
66+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
67+ - "printf 'packages: \".\"\\n' > cabal.project"
68+ - touch cabal.project.local
69+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- vty | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
70+ - cat cabal.project || true
71+ - cat cabal.project.local || true
72+ - if [ -f "./configure.ac" ]; then
73+ (cd "." && autoreconf -i);
74+ fi
75+ - rm -f cabal.project.freeze
76+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
77+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
78+ - rm -rf .ghc.environment.* "."/dist
79+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
2180
81+# Here starts the actual work to be performed for the package under test;
82+# any command which exits with a non-zero exit code causes the build to fail.
2283script:
23− - ./ci/travis_ci_script
84+ # test that source-distributions can be generated
85+ - (cd "." && cabal sdist)
86+ - mv "."/dist/vty-*.tar.gz ${DISTDIR}/
87+ - cd ${DISTDIR} || false
88+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
89+ - "printf 'packages: vty-*/*.cabal\\n' > cabal.project"
90+ - touch cabal.project.local
91+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- vty | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
92+ - cat cabal.project || true
93+ - cat cabal.project.local || true
94+ # this builds all libraries and executables (without tests/benchmarks)
95+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
2496
25−before_install:
26− - sudo add-apt-repository -y ppa:hvr/ghc
27− - sudo apt-get update
28− - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
29− - export PATH=/opt/ghc/$GHCVER/bin:$PATH
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+4−2
@@ -1,4 +1,6 @@
1−The following people should be thanked for contributing to the vty library:
1+The following people should be thanked for contributing to the vty
2+library:
3+
24 * Andrea Vezzosi
35 * Corey O'Connor
46 * Emily Backes
@@ -17,4 +19,4 @@ The following people should be thanked for contributing to the vty library:
1719 * Yoshikuni Jujo
1820 * Dmitry Ivanov
1921
20−Plus others.. Check the git log for a full list.
22+Plus others.. Check the git log and CHANGELOG.md for a full list.
CHANGELOGdeleted−265
@@ -1,265 +0,0 @@
1−5.5.0
2− - Replaced lens dependency with microlens, microlens-mtl, microlens-th dependencies. Issue #90
3− - Thanks Jonathan Daugherty
4− - Cabal corrections.
5− - Thanks Lennart Spitzner
6−
7−5.4.0
8− - Changed eventChannel of Graphics.Vty.Input from Chan to TChan. This enables clients to query if
9− there are no pending events. The Graphics.Vty interface nextEvent is unchanged. Clients that use
10− eventChannel directly will require updating.
11− https://github.com/coreyoconnor/vty/issues/60
12−5.3.1
13− - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due
14− to possibly breaking this on reasonable GHC versions
15−
16−5.3
17− - Upgraded QuickCheck dependency to 2.7
18− - The standard IO Config (standardIOConfig) was overriding any provided application config.
19− In addition, the inputFd and outputFd could not be changed if mkVty was used.
20− Fixed.
21− - Correct handling of display attributes at end of line. The output attributes are set to default
22− at the end of content for the line and at the start of a new line. Previously the current
23− attribute would extend to the next start of content. This was odd to reason about and was the
24− cause of https://github.com/coreyoconnor/vty/issues/76
25− IIRC Yi requires the old behavior to display the selection region correctly.
26− - shutdown of the input thread is now performed using killThread and synchronization on an MVar.
27− For correct handling of the terminal read vmin and vtime the read must be a blocking read on an
28− OS thread. This places a threadWaitRead, which will be interrupted by the killThread, prior to
29− the uninterruptable read. An alternative would be to re-import the read foreign call as
30− interruptable.
31−
32−5.2.11
33− - deepseq bounds increased for tests.
34− - Clean up warnings when compiling on 7.10
35− - Thanks Eric Mertens
36− - Avoid discarding input bytes after multi-byte encoded codepoint
37− - Thanks Eric Mertens
38−
39−5.2.10
40− - "str" now returns EmptyImage for empty strings to match behavior of other string-like Image constructors (fixes #74)
41− - Thanks Jonathan Daugherty
42−
43−5.2.9
44− - dependency version bumps
45− - https://github.com/coreyoconnor/vty/pull/71
46− - https://github.com/coreyoconnor/vty/pull/70
47− - Correct/Simplify the example code
48− - Thanks glguy
49− - https://github.com/coreyoconnor/vty/pull/69
50−
51−5.2.8
52− - blaze-builder, lens, utf8-string version constraint bump
53− - Thanks glguy
54− - https://github.com/coreyoconnor/vty/pull/67
55− - Do not differentiate based on TERM_PROGRAM
56− - https://github.com/coreyoconnor/vty/issues/68
57−
58−5.2.7
59− - lens and deepseq constraint bump + misc
60− - Thanks ethercrow
61− - https://github.com/coreyoconnor/vty/pull/66
62−
63−5.2.6
64− - lens constraint bump
65− - Thanks alexander-b!
66− - https://github.com/coreyoconnor/vty/pull/64
67−
68−5.2.5
69− - lens and random version constraint bump.
70− - Thanks RyanGlScott!
71− - https://github.com/coreyoconnor/vty/pull/62
72−
73−5.2.4
74− - removed -fpic from cc-options. No longer required.
75− - https://github.com/coreyoconnor/vty/issues/61
76− - https://ghc.haskell.org/trac/ghc/ticket/9657
77− - Thanks Fuuzetsu!
78−
79−5.2.3
80− - evaluate/compile the input parsing table once instead of each keystroke.
81− - https://github.com/coreyoconnor/vty/pull/59
82− - Thanks ethercrow!
83−
84−5.2.2
85− - When looking at input for an event, don't look too deep.
86− - https://github.com/coreyoconnor/vty/pull/57
87− - Thanks ethercrow!
88−
89−5.2.1
90− - Bump upper version bound for lens to 4.5. Thanks markus1189!
91−
92−5.2.0
93− - Config structure now specifies file descriptor to use. The default is stdInput and stdOutput
94− file descriptors. Previously Vty used stdInput for input and the follow code for output:
95− - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` NoBuffering)
96− - the difference was required by Vty.Inline. Now, Vty.Inline uses the Config structure options
97− to acheive the same effect.
98− - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, inputForNameAndIO,
99− outputForCurrentTerminal, outputForNameAndIO
100− - added: inputForConfig, outputForConfig
101− - updates to vty-rogue from jtdaugherty. Thanks!
102− - the oldest version of GHC tested to support vty is 7.6.2.
103− - the oldest version of GHC that vty compiles under is 7.4.2
104−
105−5.1.4
106− - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!
107−
108−5.1.1
109− - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!
110− - jtdaugherty resolved a number of compiler warnings. Thanks!
111−
112−5.1.0
113− - vmin and vtime can be specified however the application requires. See Graphics.Vty.Config.
114− - fixed the processing of input when vmin is set > 1.
115−
116−5.0.0
117− - The naming convention now matches:
118− - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions
119− - all projects using vty for input must be compiled with -threaded. Please notify vty author if
120− this is not acceptable.
121− - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default
122− configuration.
123− - input handling changes
124− - KASCII is now KChar
125− - KPN5 is now KCenter
126− - tests exist.
127− - Applications can add to the input tables by setting inputMap of the Config.
128− See Graphics.Vty.Config
129− - Users can define input table extensions that will apply to all vty applications.
130− See Graphics.Vty.Config
131− - terminal timing is now handled by selecting an appropriate VTIME. Previously this was
132− implemented within Vty itself. This reduced complexity in vty but provides a different meta
133− key behavior and implies a requirement on -threaded.
134− - The time vty will wait to verify an ESC byte means a single ESC key is the
135− singleEscPeriod of the Input Config structure.
136− - removed the typeclass based terminal and display context interface in favor of a data
137− structure of properties interface.
138− - renamed the Terminal interface to Output
139− - The default picture for an image now uses the "clear" background. This background fills
140− background spans with spaces or just ends the line.
141− - Previously the background defaulted to the space character. This causes issues copying
142− text from a text editor. The text would end up with extra spaces at the end of the line.
143− - Layer support
144− - Each layer is an image.
145− - The layers for a picture are a list of images.
146− - The first image is the top-most layer. The images are ordered from top to bottom.
147− - The transparent areas for a layer are the backgroundFill areas. backgroundFill is
148− added to pad images when images of different sizes are joined.
149− - If the background is clear there is no background layer.
150− - If there is a background character then the bottom layer is the background layer.
151− - emptyPicture is a Picture with no layers and no cursor
152− - addToTop and addToBottom add a layer to the top and bottom of the given Picture.
153− - compatibility improvements:
154− - terminfo based terminals with no cursor support are silently accepted. The cursor
155− visibility changes in the Picture will have no effect.
156− - alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a
157− guess.
158− - added "rgbColor" for easy support of RGB specified colors.
159− - Both applications and users can add to the mapping used to translate from input bytes to
160− events.
161− - Additional information about input and output process can be appended to a debug log
162− - Set environment variable VTY_DEBUG_LOG to path of debug log
163− - Or use "debugLog <path>" config directive
164− - Or set 'debugLog' property of the Config provided to mkVty.
165− - examples moved to vty-examples package. See test directory for cabal file.
166− - vty-interactive-terminal-test
167− - interactive test. Useful for building a bug report for vty's author.
168− - test/interactive_terminal_test.hs
169− - vty-event-echo
170− - view a input event log for vty. Example of interacting with user.
171− - test/EventEcho.hs
172− - vty-rogue
173− - The start of a rogue-like game. Example of layers and image build operations.
174− - test/Rogue.hs
175− - vty-benchmark
176− - benchmarks vty. A series of tests that push random pictures to the terminal. The
177− random pictures are generated using QuickCheck. The same generators used in the
178− automated tests.
179− - test/benchmark.hs
180−
181−4.7.0.0
182− - API changes:
183− - Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size.
184− - Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size.
185− - Added Graphics.Vty.Image.translate: Offset an image.
186− - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.
187−
188−4.3.0.0
189−
190−4.2.1.0
191− - API changes:
192− - Attr record accessor fore_color changed to attr_fore_color
193− - Attr record accessor back_color changed to attr_back_color
194− - Attr record accessor style changed to attr_style
195− - Added an "inline" display attribute changing DSL:
196− - put_attr_change applies a display attribute change immediately to a terminal
197− - For instance, can be used to change the display attrbiutes of text output via putStrLn
198− and putStr. EX: "put_attr_change $ back_color red" will set the
199− background color to red.
200− - Changes do not apply to a Picture output via output_picture.
201− - See Graphics.Vty.Inline
202− - Moved all IO actions into any monad an instance of MonadIO
203−
204−4.0.0.1
205− - binding for mk_wcswidth was incorrect. Most platforms just magically worked due to
206− coincidence.
207−
208−4.0.0
209− - API changes:
210− - "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an
211− instance of the Vty data structure.
212− - added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated
213− with the Vty instance.
214− - Graphics.Vty.Types has undergone a number of changes. Summary:
215− - Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for
216− image combinators. Graphics.Vty.Picture for final picture construction.
217− - Graphics.Vty.Attributes:
218− - "setFG" and "setBG" are now "with_fore_color" and "with_back_color"
219− - All other "set.." equations similarly replaced.
220− - "attr" is now "def_attr", short for "default display attributes" Also added a
221− "current_attr" for "currently applied display attributes"
222− - Graphics.Vty.Image:
223− - "horzcat" is now "horiz_cat"
224− - "vertcat" is now "vert_cat"
225− - "renderBS" is now "utf8_bytestring"
226− - "renderChar" is now "char"
227− - "renderFill" is now "char_fill"
228− - added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings
229− and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime
230− representation.
231− - Graphics.Vty.Picture:
232− - exports Graphics.Vty.Image
233− - "pic" is now "pic_for_image"
234− - added API for setting background fill pattern.
235− - Completely rewritten output backend.
236− - Efficient, scanline style output span generator. Has not been fully optimized, but good
237− enough.
238− - The details required to display the desired picture on a terminal are well encapsulated.
239− - Terminfo based display terminal implementation. With specialized derivitives for xterm,
240− Terminal.app, and iTerm.app.
241− - Attempts to robustly handle even terminals that don't support all display attributes.
242− - I've tested the following terminals with success: iTerm.app, Terminal.app, xterm,
243− rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be
244− as successfull.
245− - Improved unicode support. Double wide characters will display as expected.
246− - 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted
247− according to the number of colors the terminal supports.
248− - The Graphics.Vty.Image combinators no longer require matching dimensions to arguments.
249− Unspecified areas are filled in with a user-customizable background pattern. See
250− Graphics.Vty.Picture.
251− - output images are always cropped to display size.
252− - Significant code coverage by QuickCheck tests. An interactive test for those final properties
253− that couldn't be automatically verified.
254−
255− issues resolved:
256− - "gnome terminal displays non-basic attributes as strikethrough"
257− - http://trac.haskell.org/vty/ticket/14
258− - "Multi-byte characters are not displayed correctly on update"
259− - http://trac.haskell.org/vty/ticket/10
260− - "Redraw does not handle rendering a line that extends beyond screen width characters"
261− - http://trac.haskell.org/vty/ticket/13
262− - "The <|> and <-> combinators should be more forgiving of mismatched dimensions"
263− - http://trac.haskell.org/vty/ticket/9
264− - "256-color support"
265− - http://trac.haskell.org/vty/ticket/19
CHANGELOG.mdnew file+861
@@ -0,0 +1,861 @@
1+
2+5.35.1
3+------
4+
5+Bug fixes:
6+ * Fixed a build issue with a test program.
7+
8+5.35
9+----
10+
11+New features:
12+ * Add support for 24-bit color (thanks @u-quark). This change
13+ updates Vty to look at the `COLORTERM` environment variable that is
14+ conventionally used to advertise support for truecolor escape
15+ sequences. The change also updates the Vty demo to demonstrate
16+ 24-bit colors. This change also adds a new data type, `ColorMode`,
17+ to represent the color mode in use, as well as an `Output` interface
18+ field, `outputColorMode`, to track the active color mode and use it
19+ to clamp emitted color escape sequences to the active color range.
20+
21+API changes:
22+ * All types in `Graphics.Vty.Input.Events` now have strict constructor
23+ fields.
24+ * Internal events are now wrapped in a new `InternalEvent` type to
25+ improve how signal handling is done. This change modifies the `Input`
26+ type's event channel API to produce `InternalEvents`, not `Events`.
27+ The new `InternalEvent` either wraps `Event` with the `InputEvent`
28+ constructor (the previous behavior) or indicates that Vty resumed
29+ after handling a signal using the `ResumeAfterSignal` constructor.
30+ This change avoids the previous use of `EvResize` with lazy exception
31+ arguments as a sentinel value for `ResumeAfterSignal`.
32+
33+Other enhancements:
34+ * Bracketed paste parsing performance has been greatly improved thanks
35+ to benchmarking and optimization work by @iphydf. As part of that
36+ work, Vty now uses bytestrings rather than Strings internally when
37+ parsing input to look for events.
38+ * The `\b` value is now interpreted as `KBS` (thanks @vglfr)
39+
40+5.34
41+----
42+
43+API changes:
44+ * Added an `NFData` instance for `Event` (thanks Mario Lang)
45+ * Removed `Monoid` and `Semigroup` instances for `Attr` and
46+ `MaybeDefault`. This change removed the instances because they were
47+ misbehaved; merging `Attr` and `MaybeDefault` values with these
48+ instances resulted in field value losses. For example, before this
49+ change,
50+```
51+(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)
52+```
53+ would result in just
54+```
55+ (defAttr `withBackColor` green)
56+```
57+ because the instances were designed to favor the right-hand
58+ arguments' fields even if they had not been explicitly set
59+ (a consequence of the `MaybeDefault` `Semigroup` instance).
60+ While that behavior was sensible specifically in the context of
61+ `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made
62+ for surprising instance behavior. Since there is actually no good way
63+ to handle this in a `Semigroup` instance for `Attr` -- some choices
64+ have to be made about how to merge two attributes' foreground colors,
65+ and that won't be much better than what we had -- the instance was
66+ just removed.
67+
68+
69+5.33
70+----
71+
72+API changes:
73+* The `Cursor` type got a new `PositionOnly` constructor for cursor
74+ placement without visibility.
75+
76+Package changes:
77+* Relaxed upper bound for `random`
78+* Updated `microlens` bounds to allow 0.4.12
79+
80+Other improvements:
81+* Various hlint-driven improvements (thanks Willem Van Onsem)
82+* The implementation of `color240` was improved (thanks (Willem Van
83+ Onsem)
84+
85+5.32
86+----
87+
88+New features:
89+ * Meta-PageUp and Meta-PageDown are now supported (#193)
90+ * Added `supportsItalics` and `supportsStrikethrough` functions to
91+ check for feature support in terminfo
92+
93+Bug fixes:
94+ * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka
95+ Nkurumeh)
96+
97+5.31
98+----
99+
100+New features and API changes:
101+ * Added support for strikethrough mode. This change adds a new
102+ `strikethrough` `Style` value and uses the `smxx` and `rmxx`
103+ Terminfo capabilities to activate and deactivate strikethrough mode,
104+ respectively. If the terminfo does not report those capabilities,
105+ this style is ignored.
106+ * `Output`: added the `setDisplayBounds` field to set the output
107+ dimensions of the output handle; added an implementation of this for
108+ the `TerminfoBased` backend.
109+
110+Other changes:
111+ * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.
112+
113+5.30
114+----
115+
116+New features:
117+ * Added `Graphics.Vty.setWindowTitle` to emit an escape
118+ sequence to set the window title, provide the terminal emulator
119+ accepts Xterm-style title sequences. For details, see:
120+ https://tldp.org/HOWTO/Xterm-Title-3.html
121+
122+5.29
123+----
124+
125+API changes:
126+ * The Input type got a new field, 'restoreInputState'. This field
127+ allows the end user to have direct access to the logic needed to
128+ restore the terminal's input state flags. Prior to having this field,
129+ this state restoration logic could only be invoked as part of calling
130+ 'shutdownInput', but since that function does other things (like
131+ killing threads) it is not advisable to call it repeatedly (which is
132+ necessary in the use case this change is intended to support). This
133+ can be called directly to restore the input state flags as needed,
134+ although this is not required if 'shutdown' (or 'shutdownInput') is
135+ called.
136+
137+Other changes:
138+ * attributeControl: explicitly enable the ICRNL terminal mode flag (see
139+ #187 and c572ad).
140+
141+5.28.2
142+------
143+
144+Bug fixes:
145+ * Added a package dependency on `semigroups` for the
146+ `vty-build-width-table` tool on older GHCs (#185)
147+
148+5.28.1
149+------
150+
151+Bug fixes:
152+ * `installUnicodeWidthTable`: use `throwIO`, not `throw`
153+
154+5.28
155+----
156+
157+This release improves Vty's support for multi-column Unicode characters
158+and provides greater compatibility with a wider array of terminal
159+emulators. The following sections summarize the relevant changes, but an
160+overview of the new functionality is motivated and detailed in the new
161+"Multi-Column Character Support" README section. For
162+historical context, please also consider reading over
163+[#175](https://github.com/jtdaugherty/vty/issues/175).
164+
165+API changes:
166+ * New modules were added:
167+ * `Graphics.Vty.UnicodeWidthTable.Types`
168+ * `Graphics.Vty.UnicodeWidthTable.IO`
169+ * `Graphics.Vty.UnicodeWidthTable.Query`
170+ * `Graphics.Vty.UnicodeWidthTable.Install`
171+ * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,
172+ that controls whether `mkVty` will attempt to load a Unicode width
173+ table if specified in the configuration.
174+
175+Configuration file changes:
176+ * A new syntax was added to support specifying Unicode width tables on
177+ a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the
178+ documentation for `Graphics.Vty.Config` for details. Since prior
179+ versions of this library will silently ignore any configuration file
180+ lines they cannot parse, this change to user configuration files is
181+ at least non-breaking for older versions of Vty.
182+
183+Other changes:
184+ * The `mkVty` function now automatically attempts to load a custom
185+ Unicode width table if one is specified in the configuration,
186+ provided `allowCustomUnicodeWidthTables` is not set to `Just False`.
187+ See the documentation for `Graphics.Vty.mkVty` for details.
188+ * Vty now includes a command line tool, `vty-build-width-table`, that
189+ queries the terminal emulator to construct a custom Unicode width
190+ table and optionally update the Vty configuration file to use it.
191+ Programs that want to use that tool's functionality may also do so
192+ via the API exposed in the various modules listed above.
193+
194+5.27
195+----
196+
197+* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the
198+ kernel for the current terminal's settings to obtain the character
199+ assigned by the `stty erase` command. That can then be added to the
200+ Vty configuration's input map to map to `KBS` (backspace) if desired.
201+
202+5.26
203+----
204+
205+* Resolved various import warnings (thanks @glguy)
206+* Removed the `MonadIO` constraint from the Output type's fields and
207+ removed `MonadFail` uses (PR #177, thanks @glguy)
208+* Clarified documentation for ANSI colors (thanks Colby Jenn)
209+* `Graphics.Vty.Attributes` no longer re-exports
210+ `Graphics.Vty.Attributes.Color`
211+* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks
212+ Colby Jenn)
213+* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)
214+* Changed from using `System.Posix.Env.getEnv` to
215+ `System.Environment.lookupEnv` (thanks Jonathan Osser)
216+* Added `Graphics.Vty.Image` functions for dealing with character width
217+ computations on `Text` values instead of `Strings`:
218+ * `safeWctwidth`
219+ * `safeWctlwidth`
220+ * `wctwidth`
221+ * `wctlwidth`
222+
223+5.25.1
224+------
225+
226+* Avoided a conflict with a Microlens 0.4.10 operator and added an
227+ upper bound on Microlens of 0.4.11.
228+
229+5.25
230+----
231+
232+* The Vty type got a new field, isShutdown, that returns whether the
233+ Vty handle has had its 'shutdown' function called (thanks Ian
234+ Jeffries)
235+* Vty's shutdown function is now thread-safe.
236+
237+5.24.1
238+------
239+
240+* The "shutdown" method of Vty handles is now idempotent (#159)
241+
242+5.24
243+----
244+
245+* Add Generic and NFData instances for some types
246+* Image: remove custom Show instance, add derived Show and Read
247+ instances
248+* Updated Travis build settings (thanks Eric Mertens)
249+
250+5.23.1
251+------
252+
253+* Fixed a bug where italics did not combine properly with other display
254+ modes (#155, thanks Eric Mertens)
255+
256+5.23
257+----
258+
259+* Added support for italicized output when terminfo supports it. This
260+ takes the form of a new Style, "italic". Note that most terminfo
261+ descriptors do not report capabilities for italics, so support for
262+ this will be very spotty.
263+* Updateed text/string function documentation to indicate that escapes
264+ are not permitted in their inputs.
265+
266+5.22
267+----
268+
269+* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function
270+ (thanks Brent Carmer)
271+* Added nextEventNonblocking function (field) to Vty type (#87)
272+
273+5.21
274+----
275+
276+* Picture and Background now provide Eq instances (thanks Jaro Reinders)
277+* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)
278+* #142: note requirement of threaded RTS
279+
280+5.20
281+----
282+
283+API changes:
284+* Split up Monoid instances into Monoid and Semigroup for newer GHCs
285+ (thanks Ryan Scott)
286+
287+5.19.1
288+------
289+
290+API changes:
291+* Cursor now provides an Eq instance (thanks Jaro Reinders)
292+
293+5.19
294+----
295+
296+API changes:
297+* URL hyperlinking (via 'withURL') is now optional and disabled by
298+ default due to poor support on some common terminals. A new 'Mode'
299+ constructor, 'Hyperlink', has been added to enable this feature. To
300+ change the hyperlinking mode, use 'setMode' on the 'outputIface' of a
301+ Vty handle.
302+
303+5.18.1
304+------
305+
306+Bug fixes:
307+* Reset the hyperlink state on line endings to avoid run-on hyperlinks
308+
309+5.18
310+----
311+
312+API changes:
313+* Added support for hyperlinking attributes (thanks Getty Ritter). This
314+ change adds a new Attr field for containing the hyperlink to apply,
315+ as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda
316+
317+5.17.1
318+------
319+
320+* withStyle now ignores zero arguments, leaving attribute styles
321+ untouched if the input style is the null style
322+
323+5.17
324+----
325+
326+API changes:
327+* Add support for terminal focus events. This change adds a new mode
328+ usable with setMode, Focus, that requests that the terminal send
329+ events on focus lose/gain. This change also adds two new Event
330+ constructors, EvLostFocus and EvGainedFocus.
331+* No longer enable UTF8 mouse event encoding. This encoding was not
332+ working properly with Terminal.app, and using the other modes (SGR,
333+ etc.) work.
334+* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes
335+ #131)
336+
337+5.16
338+----
339+
340+API changes:
341+* Added support for mouse wheel events while in mouse mode. The Button
342+ type got two new constructors as a result: BScrollUp and BScrollDown.
343+ Thanks to doublescale@tutanota.com for this contribution!
344+
345+Bug fixes:
346+* charFill now clamps negative arguments to zero (thanks Eric Mertens!)
347+
348+5.15.1
349+------
350+
351+Package changes:
352+* Documentation files are now marked accordingly (thanks Michal
353+ Suchánek)
354+
355+Bug fixes:
356+* translateX/Y: fix negative translations
357+
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
LICENSE+2
@@ -1,3 +1,5 @@
1+BSD 3-Clause License
2+
13Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
24
35All rights reserved.
README.md+147−71
@@ -1,13 +1,13 @@
1−[![Build Status](https://travis-ci.org/coreyoconnor/vty.png)](https://travis-ci.org/coreyoconnor/vty)
1+[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty)
22
3−`vty` is a terminal interface library.
4−
5−This project is hosted on github.com: https://github.com/coreyoconnor/vty
3+`vty` is a terminal interface library. It provides a high-level
4+interface for doing terminal I/O. Vty is supported on GHC versions
5+7.10.1 and up.
66
77Install via `git` with:
88
99```
10−git clone git://github.com/coreyoconnor/vty.git
10+git clone git://github.com/jtdaugherty/vty.git
1111```
1212
1313Install via `cabal` with:
@@ -18,108 +18,184 @@ cabal install vty
1818
1919# Features
2020
21−* Support for a large number of terminals. vt100, ansi, hurd, linux, screen etc
22− etc. Anything with a sufficient terminfo entry.
23−
24−* Automatic handling of window resizes.
21+* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,
22+ `screen`, etc., or anything with a sufficient terminfo entry.
2523
26−* If the terminal support UTF-8 then vty supports Unicode output.
24+* Automatically handles window resizes.
2725
28−* Handles multi-column glyphs. (Requires user to properly configure terminal.)
26+* Supports Unicode output on terminals with UTF-8 support.
2927
30−* Efficient output. Output buffering and terminal state changes are minimized.
28+* Provides an efficient output algorithm. Output buffering and terminal
29+ state changes are minimized.
3130
32−* Minimizes repaint area. Virtually eliminating the flicker problems that
33− plagues ncurses programs.
31+* Minimizes repaint area, which virtually eliminates the flicker
32+ problems that plague ncurses programs.
3433
35−* A pure, compositional interface for efficiently constructing display images.
34+* Provides a pure, compositional interface for efficiently constructing
35+ display images.
3636
3737* Automatically decodes keyboard keys into (key,[modifier]) tuples.
3838
3939* Automatically supports refresh on Ctrl-L.
4040
41−* Automatically supports timeout after for lone ESC. The timeout is
41+* Supports a keypress timeout after for lone ESC. The timeout is
4242 customizable.
4343
44−* Interface is designed for easy compatible extension.
45−
46−* Supports ANSI graphics modes (SGR as defined in console_codes(4)) with a
47− type-safe interface. Gracefull fallback for terminals that do not support, or
48− partially support the standard ANSI graphics modes.
44+* Provides extensible input and output interfaces.
4945
50−* Properly handles cleanup, but not due to signals.
46+* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)
47+ with a type-safe interface and graceful fallback for terminals
48+ with limited or nonexistent support for such modes.
5149
52−* Comprehensive test suite.
53−
54−# Known Issues
50+* Properly handles cleanup (but not due to signals).
5551
56−* Terminals have numerous quirks and bugs. vty picks what works best for the
57− author in ambigious, or buggy situations.
52+* Provides a comprehensive test suite.
5853
59−* Signal handling of STOP, TERM and INT are non existent.
54+* Supports "normal" and "extended" (SGR) mouse modes as described at
55+ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
6056
61−* The character encoding of the terminal is assumed to be UTF-8 if
62− unicode is used.
57+* Supports bracketed paste mode as described at
58+ http://cirw.in/blog/bracketed-paste
6359
64−* Terminfo is assumed to be correct unless there is an override configured.
65− Some terminals will not have correct special key support (shifted F10 etc).
66− See Config for customizing vty's behavior for a particular terminal.
60+* Supports multi-column Unicode characters such as emoji characters. In
61+ cases where Vty and your terminal emulator disagree on character
62+ widths, Vty provides a tool `vty-build-width-table` and library
63+ functionality to build a width table that will work for your terminal
64+ and load it on application startup.
6765
68−* Uses the TIOCGWINSZ ioctl to find the current window size, which appears to be
69− limited to Linux and BSD.
66+# Development Notes
7067
71−* Supports "normal" and "extended" (SGR) mouse modes as described at
72− http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
68+Vty uses threads internally, so programs made with Vty need to be
69+compiled with the threaded runtime using the GHC `-threaded` option.
7370
7471# Platform Support
7572
7673## Posix Terminals
7774
78−Uses terminfo to determine terminal protocol. With some special rules to handle
79−some omissions from terminfo.
75+For the most part, Vty uses `terminfo` to determine terminal protocol
76+with some special rules to handle some omissions from `terminfo`.
8077
8178## Windows
8279
83−cygwin only.
84−
85−# Development Notes
86−
87−## Under NixOS
80+Windows is not supported.
81+
82+# Multi-Column Character Support
83+
84+Vty supports rendering of multi-column characters such as two-column
85+Asian characters and Emoji characters. This section details how to
86+take advantage of this feature, since its behavior will depend on the
87+terminal emulator in use.
88+
89+Terminal emulators support Unicode to varying degrees, and each terminal
90+emulator relies on a table of column widths for each supported Unicode
91+character. Vty also needs to rely on such a table to compute the width
92+of Vty images to do image layout. Since those tables can disagree if
93+Vty and the terminal emulator support different versions of Unicode,
94+and since different terminal emulators will support different versions
95+of Unicode, it's likely that for some wide characters, Vty applications
96+will exhibit rendering problems. Those rendering problems arise from Vty
97+and the terminal emulator coming to different conclusions about how wide
98+some characters are.
99+
100+To address this, Vty supports loading custom character width tables
101+that are based on the terminal's behavior in order to eliminate these
102+disagreements. By default, though, Vty will use its built-in Unicode
103+character width table. Since the built-in table is likely to eventually
104+disagree with your terminal, Vty provides an API and a command-line tool
105+to generate and install custom tables.
106+
107+Custom Unicode width tables based on your terminal emulator can be
108+built by running Vty's built-in tool, `vty-build-width-table`. The tool
109+works by querying the current terminal emulator to obtain its width
110+measurements for the entire supported Unicode range. The
111+results are then saved to a disk file. These custom tables
112+can also be generated programmatically by using the API in
113+`Graphics.Vty.UnicodeWidthTable.Query`.
114+
115+Saved width tables can then be loaded in one of two ways:
116+
117+* Via the library API in `Graphics.Vty.UnicodeWidthTable.IO`
118+* By adding a `widthMap` directive to your Vty configuration file and
119+ then invoking `mkVty` to initialize Vty
120+
121+The Vty configuration file supports the `widthMap` directive to allow
122+users to specify which custom width table should be loaded for a given
123+terminal type. This is done by specifying, e.g.,
88124
89−### Using cabal
125+```
126+widthMap "xterm" "/path/to/map.dat"
127+```
90128
91−After installing ncurses to user env.
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.
92172
93−~~~
94−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib
95−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build
96−LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test
97−~~~
173+# Known Issues
98174
99−### Using stack
175+* Terminals have numerous quirks and bugs, so mileage may vary. Please
176+ report issues as you encounter them and provide details on your
177+ terminal emulator, operating system, etc.
100178
101−~~~
102−stack build
103−stack test
104−stack install
105−~~~
179+* STOP, TERM and INT signals are not handled.
106180
107−## Coverage
181+* The character encoding of the terminal is assumed to be UTF-8 if
182+ unicode is used.
108183
109−As of last testing, profiling causes issues with coverage when enabled. To
110−evaluate coverage configure as follows:
184+* Terminfo is assumed to be correct unless there is an override
185+ configured. Some terminals will not have correct special key support
186+ (shifted F10 etc). See `Config` for customizing vty's behavior for a
187+ particular terminal.
111188
112−~~~
113−rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \
114− --disable-library-profiling \
115− --disable-executable-profiling
116−~~~
189+* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which
190+ appears to be limited to Linux and BSD.
117191
118−## Profiling
192+# Further Reading
119193
194+Good sources of documentation for terminal programming are:
120195
121−~~~
122−rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \
123− --enable-library-profiling \
124− --enable-executable-profiling
125−~~~
196+* https://github.com/b4winckler/vim/blob/master/src/term.c
197+* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
198+* http://ulisse.elettra.trieste.it/services/doc/serial/config.html
199+* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html
200+* http://www.unixwiz.net/techtips/termios-vmin-vtime.html
201+* http://vt100.net/docs/vt100-ug/chapter3.html
TODOdeleted−15
@@ -1,15 +0,0 @@
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_examplesdeleted−2
@@ -1,2 +0,0 @@
1−#!/bin/bash
2−(cd test && cabal build)
cbits/get_tty_erase.cnew file+18
@@ -0,0 +1,18 @@
1+#include <termios.h>
2+#include <stdio.h>
3+#include <unistd.h>
4+#include <stdlib.h>
5+
6+// Given a file descriptor for a terminal, get the ERASE character for
7+// the terminal. If the terminal info cannot be obtained, this returns
8+// zero.
9+char vty_get_tty_erase(int fd)
10+{
11+ struct termios trm;
12+
13+ if (0 == tcgetattr(fd, &trm)) {
14+ return (char) trm.c_cc[VERASE];
15+ } else {
16+ return (char) 0;
17+ }
18+}
cbits/gwinsz.c+14−5
@@ -1,9 +1,18 @@
11#include <sys/ioctl.h>
22
33unsigned long vty_c_get_window_size(int fd) {
4− struct winsize w;
5− if (ioctl (fd, TIOCGWINSZ, &w) >= 0)
6− return (w.ws_row << 16) + w.ws_col;
7− else
8− return 0x190050;
4+ struct winsize w;
5+ if (ioctl (fd, TIOCGWINSZ, &w) >= 0)
6+ return (w.ws_row << 16) + w.ws_col;
7+ else
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+ }
918}
cbits/gwinsz.h+2−1
@@ -1 +1,2 @@
1−unsigned long vty_c_get_window_size(void);
1+unsigned long vty_c_get_window_size(int fd);
2+unsigned long vty_c_set_window_size(int fd, unsigned long val);
cbits/mk_wcwidth.c+126−97
@@ -59,7 +59,29 @@
5959 * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c
6060 */
6161
62−#include <wchar.h>
62+#include <HsFFI.h>
63+#include <stdlib.h>
64+#include <string.h>
65+
66+// The maximum size for a custom character width table is the total
67+// number of possible characters as dictated by the compiler.
68+#define MAX_CUSTOM_TABLE_SIZE (HS_CHAR_MAX + 1)
69+
70+// The pointer to the start of the custom character width table, if
71+// any. If this is NULL or this is set but the ready flag is false, the
72+// built-in tree search logic is used.
73+static uint8_t* custom_table = NULL;
74+
75+// The size of the custom table, in entries. This should only be set
76+// if custom_table is not NULL. Its value should be the size of the
77+// custom_table array.
78+static uint32_t custom_table_size = 0;
79+
80+// A flag indicating whether the custom table is ready for
81+// use. This should only be set once the table has been
82+// allocated with vty_init_custom_table and initialized with
83+// vty_set_custom_table_range.
84+static uint8_t custom_table_ready = 0;
6385
6486struct interval {
6587 int first;
@@ -67,7 +89,7 @@ struct interval {
6789};
6890
6991/* auxiliary function for binary search in interval table */
70−static int vty_bisearch(wchar_t ucs, const struct interval *table, int max) {
92+static int vty_bisearch(HsChar ucs, const struct interval *table, int max) {
7193 int min = 0;
7294 int mid;
7395
@@ -119,7 +141,7 @@ static int vty_bisearch(wchar_t ucs, const struct interval *table, int max) {
119141 * in ISO 10646.
120142 */
121143
122−int vty_mk_wcwidth(wchar_t ucs)
144+static HsInt builtin_wcwidth(HsChar ucs)
123145{
124146 /* sorted list of non-overlapping intervals of non-spacing characters */
125147 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
@@ -182,7 +204,7 @@ int vty_mk_wcwidth(wchar_t ucs)
182204
183205 /* binary search in table of non-spacing characters */
184206 if (vty_bisearch(ucs, combining,
185− sizeof(combining) / sizeof(struct interval) - 1))
207+ sizeof(combining) / sizeof(struct interval) - 1))
186208 return 0;
187209
188210 /* if we arrive here, ucs is not a combining or C0/C1 control character */
@@ -203,107 +225,114 @@ int vty_mk_wcwidth(wchar_t ucs)
203225 (ucs >= 0x30000 && ucs <= 0x3fffd)));
204226}
205227
206−
207−int vty_mk_wcswidth(const wchar_t *pwcs, size_t n)
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)
208235{
209− int w, width = 0;
210−
211− for (;n-- > 0; pwcs++)
212− if ((w = vty_mk_wcwidth(*pwcs)) < 0)
213− return -1;
214− else
215− width += w;
216−
217− return width;
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+ }
218245}
219246
220−
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)
247+// Initialize a custom character width table.
248+//
249+// This allocates a new character width table of the specified size
250+// (in characters). If a custom table has already been allocated, this
251+// returns 1. Otherwise it allocates a new table, initializes all of its
252+// entries to 1, and returns zero.
253+//
254+// Note that this does *not* mark the table as ready for use. Until the
255+// table is marked ready, it will not be used by vty_mk_wcwidth. To mark
256+// the table as ready, call vty_activate_custom_table() after the table
257+// has been set up with calls to vty_set_custom_table_range.
258+int vty_init_custom_table(int size)
231259{
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);
260+ if (custom_table == NULL) {
261+ if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) {
262+ custom_table_ready = 0;
263+ custom_table = malloc(size);
264+ memset(custom_table, 1, size);
265+ custom_table_size = size;
266+ return 0;
267+ } else {
268+ return 1;
269+ }
270+ } else {
271+ return 1;
272+ }
295273}
296274
275+// Set the specified character range in the custom width table to the
276+// specified width.
277+//
278+// This function sets 'width' as the character width for all entries
279+// in the custom character table starting at the 'start' entry and
280+// including all entries up to and including 'start + size - 1'.
281+//
282+// If this succeeds, it returns zero. If it fails, it returns 1. It
283+// fails if the table is not allocated, marked as ready (i.e. it is in
284+// use and has already been populated), or if the start or size values
285+// are not in bounds for the table.
286+int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width)
287+{
288+ if ((custom_table == NULL) ||
289+ (size >= custom_table_size) ||
290+ (start >= custom_table_size) ||
291+ ((start + 1) >= (custom_table_size - size)) ||
292+ custom_table_ready) {
293+ return 1;
294+ } else {
295+ memset(custom_table + start, width, size);
296+ return 0;
297+ }
298+}
297299
298−int vty_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n)
300+// Mark the allocated custom character width table as ready for use.
301+//
302+// After this call, further calls to vty_set_custom_table_range will
303+// fail.
304+//
305+// This function returns 0 if it succeeds. If it fails, it returns 1.
306+// It fails if the custom table is already ready or if it has not been
307+// allocated.
308+int vty_activate_custom_table()
299309{
300− int w, width = 0;
310+ if (custom_table_ready || (custom_table == NULL)) {
311+ return 1;
312+ } else {
313+ custom_table_ready = 1;
314+ return 0;
315+ }
316+}
301317
302− for (;n-- > 0; pwcs++)
303− if ((w = vty_mk_wcwidth_cjk(*pwcs)) < 0)
304− return -1;
305− else
306− width += w;
318+// Returns whether a custom character width table has been marked ready.
319+int vty_custom_table_ready()
320+{
321+ return custom_table_ready;
322+}
307323
308− return width;
324+// Deallocate the custom width table.
325+//
326+// This does nothing if there is no allocated custom width table, or if
327+// there is one but it is in use (marked ready). This is only useful if
328+// an initial allocation succeeds, but range population fails, after
329+// which point the application may want to deallocate the table to avoid
330+// leaving it in an intermediate state.
331+void vty_deallocate_custom_table()
332+{
333+ if ((custom_table != NULL) && (!custom_table_ready)) {
334+ free(custom_table);
335+ custom_table = NULL;
336+ custom_table_size = 0;
337+ }
309338}
Demo.hs → demos/Demo.hsrenamed+14−8
@@ -1,5 +1,4 @@
11{-# LANGUAGE FlexibleContexts #-}
2−
32module Main where
43
54import Graphics.Vty
@@ -8,7 +7,6 @@ import Control.Applicative hiding ((<|>))
87import Control.Arrow
98import Control.Monad.RWS
109
11−import Data.Default (def)
1210import Data.Sequence (Seq, (<|) )
1311import qualified Data.Sequence as Seq
1412import Data.Foldable
@@ -19,8 +17,8 @@ type App = RWST Vty () (Seq String) IO
1917
2018main = do
2119 vty <- if True -- change to false for emacs-like input processing
22− then mkVty def
23− else mkVty (def { vmin = Just 2, vtime = Just 300 } )
20+ then mkVty defaultConfig
21+ else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )
2422 _ <- execRWST (vtyInteract False) vty Seq.empty
2523 shutdown vty
2624
@@ -33,7 +31,8 @@ introText = vertCat $ map (string defAttr)
3331 [ "this line is hidden by the top layer"
3432 , "The vty demo program will echo the events generated by the pressed keys."
3533 , "Below there is a 240 color box."
36− , "Followed by a description of the 16 color pallete."
34+ , "Followed by a description of the 16 color palette."
35+ , "Followed by tones of red using a 24-bit palette."
3736 , "If the 240 color box is not visible then the terminal"
3837 , "claims 240 colors are not supported."
3938 , "Try setting TERM to xterm-256color"
@@ -44,12 +43,19 @@ introText = vertCat $ map (string defAttr)
4443 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
4544 ]
4645
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+
4755colorbox_240 :: Image
4856colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
4957 where
5058 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
51− splitColorImages [] = []
52− splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
5359
5460colorbox_16 :: Image
5561colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
@@ -72,7 +78,7 @@ updateDisplay = do
7278 "Press ESC to exit. Events for keys below."
7379 eventLog <- foldMap (string defAttr) <$> get
7480 let pic = picForImage (info <-> eventLog)
75− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
81+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)
7682 vty <- ask
7783 liftIO $ update vty pic
7884
demos/ModeDemo.hsnew file+55
@@ -0,0 +1,55 @@
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
DESIGN → docs/DESIGNrenamed

The content is the same.

install_examplesdeleted−4
@@ -1,4 +0,0 @@
1−#!/bin/bash
2−set -ex
3−cabal install
4−(cd test && cabal install)
src/Codec/Binary/UTF8/Debug.hs+4−6
@@ -1,7 +1,6 @@
11{-# OPTIONS_HADDOCK hide #-}
22-- Copyright 2009 Corey O'Connor
3−module Codec.Binary.UTF8.Debug
4− where
3+module Codec.Binary.UTF8.Debug where
54
65import Codec.Binary.UTF8.String ( encode )
76
@@ -9,11 +8,10 @@ import Data.Word
98
109import Numeric
1110
12−-- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the
13−-- corresponding UTF8 byte sequence
11+-- | Converts an array of ISO-10646 characters (Char type) to an array
12+-- of Word8 bytes that is the corresponding UTF8 byte sequence
1413utf8FromIso :: [Int] -> [Word8]
1514utf8FromIso = encode . map toEnum
1615
1716ppUtf8 :: [Int] -> IO ()
18−ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso
19−
17+ppUtf8 = print . map (`showHex` "") . utf8FromIso
src/Data/Sequence/Extra.hs+2−2
@@ -7,7 +7,7 @@ import Data.Sequence
77import Control.Parallel.Strategies
88
99instance NFData a => NFData (Seq a) where
10− rnf = \v -> rnf' (viewl v)
11− where
10+ rnf = rnf' . viewl
11+ where
1212 rnf' EmptyL = ()
1313 rnf' (a :< r) = rnf a >| rnf' (viewl r)
src/Data/Terminfo/Eval.hs+15−23
@@ -1,18 +1,14 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE BangPatterns #-}
32{-# LANGUAGE NoMonomorphismRestriction #-}
43{-# OPTIONS_GHC -funbox-strict-fields #-}
54{-# OPTIONS_HADDOCK hide #-}
65
7−#ifndef MIN_VERSION_base
8−#defined MIN_VERSION_base(x,y,z) 1
9−#endif
10−
11−{- Evaluates the paramaterized terminfo string capability with the given parameters.
12− -
13− -}
14−module Data.Terminfo.Eval (writeCapExpr)
15− where
6+-- | Evaluates the paramaterized terminfo string capability with the
7+-- given parameters.
8+module Data.Terminfo.Eval
9+ ( writeCapExpr
10+ )
11+where
1612
1713import Blaze.ByteString.Builder.Word
1814import Blaze.ByteString.Builder
@@ -27,10 +23,6 @@ import Data.List
2723
2824import qualified Data.Vector.Unboxed as Vector
2925
30−#if !(MIN_VERSION_base(4,8,0))
31−import Data.Word
32−#endif
33−
3426-- | capability evaluator state
3527data EvalState = EvalState
3628 { evalStack :: ![CapParam]
@@ -50,7 +42,7 @@ pop = do
5042
5143readParam :: Word -> Eval CapParam
5244readParam pn = do
53− !params <- get >>= return . evalParams
45+ !params <- evalParams <$> get
5446 return $! genericIndex params pn
5547
5648push :: CapParam -> Eval ()
@@ -72,18 +64,18 @@ writeCapExpr cap params =
7264 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
7365
7466writeCapOps :: CapOps -> Eval ()
75−writeCapOps ops = mapM_ writeCapOp ops
67+writeCapOps = mapM_ writeCapOp
7668
7769writeCapOp :: CapOp -> Eval ()
7870writeCapOp (Bytes !offset !count) = do
79− !cap <- get >>= return . evalExpression
71+ !cap <- evalExpression <$> get
8072 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
8173 Vector.forM_ bytes $ tell.writeWord8
8274writeCapOp DecOut = do
8375 p <- pop
8476 forM_ (show p) $ tell.writeWord8.toEnum.fromEnum
8577writeCapOp CharOut = do
86− pop >>= tell.writeWord8.toEnum.fromEnum
78+ pop >>= tell.writeWord8.toEnum.fromEnum
8779writeCapOp (PushParam pn) = do
8880 readParam pn >>= push
8981writeCapOp (PushValue v) = do
@@ -91,13 +83,14 @@ writeCapOp (PushValue v) = do
9183writeCapOp (Conditional expr parts) = do
9284 writeCapOps expr
9385 writeContitionalParts parts
94− where
86+ where
9587 writeContitionalParts [] = return ()
9688 writeContitionalParts ((trueOps, falseOps) : falseParts) = do
9789 -- (man 5 terminfo)
98− -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
99− -- stack, testing if it is nonzero (true). If it is zero (false), control
100− -- passes to the %e (else) part.
90+ -- Usually the %? expr part pushes a value onto the stack,
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
93+ -- (else) part.
10194 v <- pop
10295 if v /= 0
10396 then writeCapOps trueOps
@@ -137,4 +130,3 @@ writeCapOp CompareGt = do
137130 v1 <- pop
138131 v0 <- pop
139132 push $ if v0 > v1 then 1 else 0
140−
src/Data/Terminfo/Parse.hs+61−61
@@ -1,22 +1,22 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE BangPatterns #-}
3−{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE CPP #-}
43{-# LANGUAGE NoMonomorphismRestriction #-}
5−{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
65{-# OPTIONS_GHC -funbox-strict-fields -O #-}
6+{-# OPTIONS_HADDOCK hide #-}
77
8−#ifndef MIN_VERSION_base
9−#defined MIN_VERSION_base(x,y,z) 1
10−#endif
11−
12−module Data.Terminfo.Parse ( module Data.Terminfo.Parse
13− , Text.Parsec.ParseError
14− )
15− where
8+module Data.Terminfo.Parse
9+ ( module Data.Terminfo.Parse
10+ , Text.Parsec.ParseError
11+ )
12+where
1613
1714import Control.Monad ( liftM )
1815import Control.DeepSeq
1916
17+#if !(MIN_VERSION_base(4,11,0))
18+import Data.Semigroup (Semigroup(..))
19+#endif
2020import Data.Word
2121import qualified Data.Vector.Unboxed as Vector
2222
@@ -24,10 +24,6 @@ import Numeric (showHex)
2424
2525import Text.Parsec
2626
27−#if !(MIN_VERSION_base(4,8,0))
28−import Data.Monoid
29−#endif
30−
3127data CapExpression = CapExpression
3228 { capOps :: !CapOps
3329 , capBytes :: !(Vector.Vector Word8)
@@ -43,24 +39,24 @@ instance Show CapExpression where
4339 ++ " <= " ++ show (sourceString c)
4440 where
4541 hexDump :: [Word8] -> String
46− hexDump = foldr (\b s -> showHex b s) ""
42+ hexDump = foldr showHex ""
4743
4844instance NFData CapExpression where
49− rnf (CapExpression ops !_bytes !str !c !pOps)
45+ rnf (CapExpression ops !_bytes !str !c !pOps)
5046 = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps
5147
5248type CapParam = Word
5349
5450type CapOps = [CapOp]
55−data CapOp =
51+data CapOp =
5652 Bytes !Int !Int -- offset count
5753 | DecOut | CharOut
58− -- This stores a 0-based index to the parameter. However the operation that implies this op is
59− -- 1-based
54+ -- This stores a 0-based index to the parameter. However the
55+ -- operation that implies this op is 1-based
6056 | PushParam !Word | PushValue !Word
61− -- The conditional parts are the sequence of (%t expression, %e expression) pairs.
62− -- The %e expression may be NOP
63− | Conditional
57+ -- The conditional parts are the sequence of (%t expression, %e
58+ -- The expression) pairs. %e expression may be NOP
59+ | Conditional
6460 { conditionalExpr :: !CapOps
6561 , conditionalParts :: ![(CapOps, CapOps)]
6662 }
@@ -72,8 +68,8 @@ data CapOp =
7268instance NFData CapOp where
7369 rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount
7470 rnf (PushParam pn) = rnf pn
75− rnf (PushValue v) = rnf v
76− rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts
71+ rnf (PushValue v) = rnf v
72+ rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts
7773 rnf BitwiseOr = ()
7874 rnf BitwiseXOr = ()
7975 rnf BitwiseAnd = ()
@@ -94,51 +90,51 @@ instance NFData ParamOp where
9490 rnf IncFirstTwo = ()
9591
9692parseCapExpression :: String -> Either ParseError CapExpression
97−parseCapExpression capString =
93+parseCapExpression capString =
9894 let v = runParser capExpressionParser
9995 initialBuildState
100− "terminfo cap"
101− capString
96+ "terminfo cap"
97+ capString
10298 in case v of
10399 Left e -> Left e
104100 Right buildResults -> Right $ constructCapExpression capString buildResults
105101
106−constructCapExpression :: [Char] -> BuildResults -> CapExpression
102+constructCapExpression :: String -> BuildResults -> CapExpression
107103constructCapExpression capString buildResults =
108104 let expr = CapExpression
109105 { capOps = outCapOps buildResults
110− -- The cap bytes are the lower 8 bits of the input string's characters.
111− -- \todo Verify the input string actually contains an 8bit byte per character.
106+ -- The cap bytes are the lower 8 bits of the input
107+ -- string's characters.
112108 , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
113109 , sourceString = capString
114110 , paramCount = outParamCount buildResults
115111 , paramOps = outParamOps buildResults
116− }
112+ }
117113 in rnf expr `seq` expr
118114
119−type CapParser a = Parsec String BuildState a
115+type CapParser a = Parsec String BuildState a
120116
121117capExpressionParser :: CapParser BuildResults
122118capExpressionParser = do
123− rs <- many $ paramEscapeParser <|> bytesOpParser
119+ rs <- many $ paramEscapeParser <|> bytesOpParser
124120 return $ mconcat rs
125121
126122paramEscapeParser :: CapParser BuildResults
127123paramEscapeParser = do
128124 _ <- char '%'
129125 incOffset 1
130− literalPercentParser <|> paramOpParser
126+ literalPercentParser <|> paramOpParser
131127
132128literalPercentParser :: CapParser BuildResults
133129literalPercentParser = do
134130 _ <- char '%'
135− startOffset <- getState >>= return . nextOffset
131+ startOffset <- nextOffset <$> getState
136132 incOffset 1
137133 return $ BuildResults 0 [Bytes startOffset 1] []
138134
139135paramOpParser :: CapParser BuildResults
140136paramOpParser
141− = incrementOpParser
137+ = incrementOpParser
142138 <|> pushOpParser
143139 <|> decOutParser
144140 <|> charOutParser
@@ -158,7 +154,7 @@ incrementOpParser = do
158154pushOpParser :: CapParser BuildResults
159155pushOpParser = do
160156 _ <- char 'p'
161− paramN <- digit >>= return . (\d -> read [d])
157+ paramN <- read . pure <$> digit
162158 incOffset 2
163159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
164160
@@ -179,16 +175,16 @@ conditionalOpParser = do
179175 _ <- char '?'
180176 incOffset 1
181177 condPart <- manyExpr conditionalTrueParser
182− parts <- manyP
178+ parts <- manyP
183179 ( do
184180 truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
185− , conditionalFalseParser
181+ , conditionalFalseParser
186182 ]
187183 falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
188184 , conditionalTrueParser
189185 ]
190186 return ( truePart, falsePart )
191− )
187+ )
192188 conditionalEndParser
193189
194190 let trueParts = map fst parts
@@ -208,10 +204,10 @@ conditionalOpParser = do
208204
209205 return $ BuildResults n'' [ Conditional cond condParts ] pOps
210206
211− where
212− manyP !p !end = choice
207+ where
208+ manyP !p !end = choice
213209 [ try end >> return []
214− , do !v <- p
210+ , do !v <- p
215211 !vs <- manyP p end
216212 return $! v : vs
217213 ]
@@ -233,7 +229,7 @@ conditionalEndParser = do
233229 incOffset 2
234230
235231bitwiseOpParser :: CapParser BuildResults
236−bitwiseOpParser
232+bitwiseOpParser
237233 = bitwiseOrParser
238234 <|> bitwiseAndParser
239235 <|> bitwiseXorParser
@@ -257,9 +253,9 @@ bitwiseXorParser = do
257253 return $ BuildResults 0 [ BitwiseXOr ] [ ]
258254
259255arithOpParser :: CapParser BuildResults
260−arithOpParser
261− = plusOp
262− <|> minusOp
256+arithOpParser
257+ = plusOp
258+ <|> minusOp
263259 where
264260 plusOp = do
265261 _ <- char '+'
@@ -282,10 +278,10 @@ literalIntOpParser = do
282278 return $ BuildResults 0 [ PushValue n ] [ ]
283279
284280compareOpParser :: CapParser BuildResults
285−compareOpParser
281+compareOpParser
286282 = compareEqOp
287− <|> compareLtOp
288− <|> compareGtOp
283+ <|> compareLtOp
284+ <|> compareGtOp
289285 where
290286 compareEqOp = do
291287 _ <- char '='
@@ -303,7 +299,7 @@ compareOpParser
303299bytesOpParser :: CapParser BuildResults
304300bytesOpParser = do
305301 bytes <- many1 $ satisfy (/= '%')
306− startOffset <- getState >>= return . nextOffset
302+ startOffset <- nextOffset <$> getState
307303 let !c = length bytes
308304 !s <- getState
309305 let s' = s { nextOffset = startOffset + c }
@@ -313,14 +309,14 @@ bytesOpParser = do
313309charConstParser :: CapParser BuildResults
314310charConstParser = do
315311 _ <- char '\''
316− charValue <- liftM (toEnum . fromEnum) anyChar
312+ charValue <- liftM (toEnum . fromEnum) anyChar
317313 _ <- char '\''
318314 incOffset 3
319315 return $ BuildResults 0 [ PushValue charValue ] [ ]
320316
321−data BuildState = BuildState
317+data BuildState = BuildState
322318 { nextOffset :: Int
323− }
319+ }
324320
325321incOffset :: Int -> CapParser ()
326322incOffset n = do
@@ -337,12 +333,16 @@ data BuildResults = BuildResults
337333 , outParamOps :: !ParamOps
338334 }
339335
340−instance Monoid BuildResults where
341− mempty = BuildResults 0 [] []
342− v0 `mappend` v1
336+instance Semigroup BuildResults where
337+ v0 <> v1
343338 = BuildResults
344− { outParamCount = (outParamCount v0) `max` (outParamCount v1)
345− , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
346− , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
339+ { outParamCount = outParamCount v0 `max` outParamCount v1
340+ , outCapOps = outCapOps v0 <> outCapOps v1
341+ , outParamOps = outParamOps v0 <> outParamOps v1
347342 }
348343
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+51−21
@@ -1,34 +1,64 @@
11-- Copyright 2009 Corey O'Connor
22{-# OPTIONS_GHC -D_XOPEN_SOURCE #-}
33{-# LANGUAGE ForeignFunctionInterface #-}
4−module Graphics.Text.Width ( wcwidth
5− , wcswidth
6− , safeWcwidth
7− , safeWcswidth
8− )
9− where
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
14+ ( wcwidth
15+ , wcswidth
16+ , wctwidth
17+ , wctlwidth
18+ , safeWcwidth
19+ , safeWcswidth
20+ , safeWctwidth
21+ , safeWctlwidth
22+ )
23+where
24+
25+import Data.List (foldl')
26+import qualified Data.Text as T
27+import qualified Data.Text.Lazy as TL
1028
1129foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
1230
1331wcswidth :: String -> Int
14−wcswidth = sum . map wcwidth
32+wcswidth = foldl' (\l c -> wcwidth c + l) 0
33+{-# INLINE [1] wcswidth #-}
34+
35+wctwidth :: T.Text -> Int
36+wctwidth = T.foldl' (\l c -> wcwidth c + l) 0
1537
16−-- XXX: Characters with unknown widths occupy 1 column?
17−--
18−-- Not sure if this is actually correct. I presume there is a replacement character that is output
19−-- by the terminal instead of the character and this replacement character is 1 column wide. If this
20−-- is not true for all terminals then a per-terminal replacement character width needs to be
21−-- implemented.
38+wctlwidth :: TL.Text -> Int
39+wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0
2240
23−-- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width
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
47+-- with unknown widths are 0 width.
2448safeWcwidth :: Char -> Int
25−safeWcwidth c = case wcwidth c of
26− i | i < 0 -> 0
27− | otherwise -> i
49+safeWcwidth = max 0 . wcwidth
2850
29−-- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width
51+-- | Returns the display width of a string. Assumes all characters with
52+-- unknown widths are 0 width.
3053safeWcswidth :: String -> Int
31−safeWcswidth str = case wcswidth str of
32− i | i < 0 -> 0
33− | otherwise -> i
54+safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0
55+
56+-- | Returns the display width of a text. Assumes all characters with
57+-- unknown widths are 0 width.
58+safeWctwidth :: T.Text -> Int
59+safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0
3460
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+186−113
@@ -1,17 +1,20 @@
1−-- | Vty supports input and output to terminal devices.
2−--
3−-- - Input to the terminal is provided to the app as a sequence of 'Event's.
4−--
5−-- - The output is defined by a 'Picture'. Which is one or more layers of 'Image's.
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+-- | Vty provides interfaces for both terminal input and terminal
5+-- output.
66--
7−-- - The module "Graphics.Vty.Image" provides a number of constructor equations that will build
8−-- correct 'Image' values. See 'string', '<|>', and '<->' for starters.
7+-- - Input to the terminal is provided to the Vty application as a
8+-- sequence of 'Event's.
99--
10−-- - The constructors in "Graphics.Vty.Image.Internal" should not be used.
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.
1115--
12−-- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
13−--
14−-- See the vty-examples package for a number of examples.
16+-- Vty uses threads internally, so programs made with Vty need to be
17+-- compiled with the threaded runtime using the GHC @-threaded@ option.
1518--
1619-- @
1720-- import "Graphics.Vty"
@@ -28,155 +31,225 @@
2831-- 'shutdown' vty
2932-- 'print' (\"Last event was: \" '++' 'show' e)
3033-- @
31−--
32−-- Good sources of documentation for terminal programming are:
33−--
34−-- - <https://github.com/b4winckler/vim/blob/master/src/term.c>
35−--
36−-- - <http://invisible-island.net/xterm/ctlseqs/ctlseqs.html>
37−--
38−-- - <http://ulisse.elettra.trieste.it/services/doc/serial/config.html>
39−--
40−-- - <http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html>
41−--
42−-- - <http://www.unixwiz.net/techtips/termios-vmin-vtime.html>
43−--
44−-- - <http://vt100.net/docs/vt100-ug/chapter3.html vt100 control sequences>
45−module Graphics.Vty ( Vty(..)
46− , mkVty
47− , module Graphics.Vty.Config
48− , module Graphics.Vty.Input
49− , module Graphics.Vty.Output
50− , module Graphics.Vty.Picture
51− , DisplayRegion
52− )
53− where
54−
55−import Graphics.Vty.Prelude
34+module Graphics.Vty
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
5648
5749import Graphics.Vty.Config
5850import Graphics.Vty.Input
51+import Graphics.Vty.Input.Events
5952import Graphics.Vty.Output
53+import Graphics.Vty.Output.Interface
6054import 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
6159
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)
6265import Control.Concurrent.STM
6366
6467import Data.IORef
65−import Data.Monoid
68+#if !(MIN_VERSION_base(4,11,0))
69+import Data.Semigroup ((<>))
70+#endif
6671
67−-- | The main object. At most one should be created.
72+-- | A Vty value represents a handle to the Vty library that the
73+-- application must create in order to use Vty.
6874--
6975-- The use of Vty typically follows this process:
7076--
71−-- 0. initialize vty
72−--
73−-- 1. use the update equation of Vty to display a picture
74−--
75−-- 2. repeat
76−--
77−-- 3. shutdown vty.
78−--
79−-- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe".
80−--
81−-- This does not assure any thread safety. In theory, as long as an update action is not executed
82−-- when another update action is already then it's safe to call this on multiple threads.
83−--
84−-- \todo Remove explicit `shutdown` requirement.
85−data Vty = Vty
86− { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context
87− -- implicitly managed by Vty. The managed display context is reset on resize.
88− update :: Picture -> IO ()
89− -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event
90− -- is a 'EvResize'.
91− , nextEvent :: IO Event
92− -- | The input interface. See 'Input'
93− , inputIface :: Input
94− -- | The output interface. See 'Output'
95− , outputIface :: Output
96− -- | Refresh the display. 'nextEvent' will refresh the display if a resize occurs.
97− -- If other programs output to the terminal and mess up the display then the application might
98− -- want to force a refresh.
99− , refresh :: IO ()
100− -- | Clean up after vty.
101− -- The above methods will throw an exception if executed after this is executed.
102− , shutdown :: IO ()
103− }
77+-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).
78+--
79+-- 2. Use 'update' to display a picture.
80+--
81+-- 3. Use 'nextEvent' to get the next input event.
82+--
83+-- 4. Depending on the event, go to 2 or 5.
84+--
85+-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At
86+-- this point the 'Vty' handle cannot be used again.
87+--
88+-- Operations on Vty handles are not thread-safe.
89+data Vty =
90+ Vty { update :: Picture -> IO ()
91+ -- ^ Outputs the given 'Picture'.
92+ , nextEvent :: IO Event
93+ -- ^ Return the next 'Event' or block until one becomes
94+ -- available.
95+ , nextEventNonblocking :: IO (Maybe Event)
96+ -- ^ Non-blocking version of 'nextEvent'.
97+ , inputIface :: Input
98+ -- ^ The input interface. See 'Input'.
99+ , outputIface :: Output
100+ -- ^ The output interface. See 'Output'.
101+ , refresh :: IO ()
102+ -- ^ Refresh the display. If other programs output to the
103+ -- terminal and mess up the display then the application might
104+ -- want to force a refresh using this function.
105+ , shutdown :: IO ()
106+ -- ^ Clean up after vty. A call to this function is necessary to
107+ -- cleanly restore the terminal state before application exit.
108+ -- The above methods will throw an exception if executed after
109+ -- this is executed. Idempotent.
110+ , isShutdown :: IO Bool
111+ }
104112
105−-- | Set up the state object for using vty. At most one state object should be
106−-- created at a time for a given terminal device.
113+-- | Create a Vty handle. At most one handle should be created at a time
114+-- for a given terminal device.
107115--
108−-- The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence.
109−-- See "Graphics.Vty.Config"
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".
110119--
111−-- For most applications @mkVty def@ is sufficient.
120+-- For most applications @mkVty defaultConfig@ is sufficient.
112121mkVty :: Config -> IO Vty
113122mkVty appConfig = do
114123 config <- (<> appConfig) <$> userConfig
115− input <- inputForConfig config
116− out <- outputForConfig config
117− intMkVty input out
118124
119−intMkVty :: Input -> Output -> IO Vty
120−intMkVty input out = do
125+ when (allowCustomUnicodeWidthTables config /= Just False) $
126+ installCustomWidthTable config
127+
128+ input <- inputForConfig config
129+ out <- outputForConfig config
130+ internalMkVty input out
131+
132+installCustomWidthTable :: Config -> IO ()
133+installCustomWidthTable c = do
134+ let doLog s = case debugLog c of
135+ Nothing -> return ()
136+ Just path -> appendFile path $ "installWidthTable: " <> s <> "\n"
137+
138+ customInstalled <- isCustomTableReady
139+ when (not customInstalled) $ do
140+ mTerm <- currentTerminalName
141+ case mTerm of
142+ Nothing ->
143+ doLog "No current terminal name available"
144+ Just currentTerm ->
145+ case lookup currentTerm (termWidthMaps c) of
146+ Nothing ->
147+ doLog "Current terminal not found in custom character width mapping list"
148+ Just path -> do
149+ tableResult <- E.try $ readUnicodeWidthTable path
150+ case tableResult of
151+ Left (e::E.SomeException) ->
152+ doLog $ "Error reading custom character width table " <>
153+ "at " <> show path <> ": " <> show e
154+ Right (Left msg) ->
155+ doLog $ "Error reading custom character width table " <>
156+ "at " <> show path <> ": " <> msg
157+ Right (Right table) -> do
158+ installResult <- E.try $ installUnicodeWidthTable table
159+ case installResult of
160+ Left (e::E.SomeException) ->
161+ doLog $ "Error installing unicode table (" <>
162+ show path <> ": " <> show e
163+ Right () ->
164+ doLog $ "Successfully installed Unicode width table " <>
165+ " from " <> show path
166+
167+internalMkVty :: Input -> Output -> IO Vty
168+internalMkVty input out = do
121169 reserveDisplay out
170+
171+ shutdownVar <- newTVarIO False
122172 let shutdownIo = do
123− shutdownInput input
124− releaseDisplay out
125− releaseTerminal out
173+ alreadyShutdown <- atomically $ swapTVar shutdownVar True
174+ when (not alreadyShutdown) $ do
175+ shutdownInput input
176+ releaseDisplay out
177+ releaseTerminal out
178+
179+ let shutdownStatus = readTVarIO shutdownVar
180+
126181 lastPicRef <- newIORef Nothing
127182 lastUpdateRef <- newIORef Nothing
128183
129184 let innerUpdate inPic = do
130− b@(w,h) <- displayBounds out
131− let cursor = picCursor inPic
132− inPic' = case cursor of
133− Cursor x y ->
134− let
135− x' = case x of
136− _ | x < 0 -> 0
137− | x >= w -> w - 1
138− | otherwise -> x
139− y' = case y of
140− _ | y < 0 -> 0
141− | y >= h -> h - 1
142− | otherwise -> y
143− in inPic { picCursor = Cursor x' y' }
144− _ -> inPic
185+ b <- displayBounds out
145186 mlastUpdate <- readIORef lastUpdateRef
146187 updateData <- case mlastUpdate of
147188 Nothing -> do
148189 dc <- displayContext out b
149− outputPicture dc inPic'
190+ outputPicture dc inPic
150191 return (b, dc)
151192 Just (lastBounds, lastContext) -> do
152193 if b /= lastBounds
153194 then do
154195 dc <- displayContext out b
155− outputPicture dc inPic'
196+ outputPicture dc inPic
156197 return (b, dc)
157198 else do
158− outputPicture lastContext inPic'
199+ outputPicture lastContext inPic
159200 return (b, lastContext)
160201 writeIORef lastUpdateRef $ Just updateData
161− writeIORef lastPicRef $ Just inPic'
202+ writeIORef lastPicRef $ Just inPic
203+
204+ let innerRefresh = do
205+ writeIORef lastUpdateRef Nothing
206+ bounds <- displayBounds out
207+ dc <- displayContext out bounds
208+ writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState
209+ mPic <- readIORef lastPicRef
210+ maybe (return ()) innerUpdate mPic
211+
212+ let mkResize = uncurry EvResize <$> displayBounds out
162213
163− let innerRefresh
164− = writeIORef lastUpdateRef Nothing
165− >> readIORef lastPicRef
166− >>= maybe ( return () ) ( \pic -> innerUpdate pic )
214+ translateInternalEvent ResumeAfterSignal = mkResize
215+ translateInternalEvent (InputEvent e) = return e
167216
168− let gkey = do k <- atomically $ readTChan $ _eventChannel input
169− case k of
170− (EvResize _ _) -> innerRefresh
171− >> displayBounds out
172− >>= return . (\(w,h)-> EvResize w h)
173− _ -> return k
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
223+ Just e -> Just <$> translateInternalEvent e
224+ Nothing -> return Nothing
174225
175226 return $ Vty { update = innerUpdate
176227 , nextEvent = gkey
228+ , nextEventNonblocking = gkey'
177229 , inputIface = input
178230 , outputIface = out
179231 , refresh = innerRefresh
180232 , shutdown = shutdownIo
233+ , isShutdown = shutdownStatus
181234 }
182235
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+121−120
@@ -1,68 +1,89 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE RankNTypes #-}
5−
6−#ifndef MIN_VERSION_base
7−#defined MIN_VERSION_base(x,y,z) 1
8−#endif
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveAnyClass #-}
94
105-- | Display attributes
116--
12−-- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes:
7+-- Attributes have three components: a foreground color, a background
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.,
1311--
1412-- @
15−-- defAttr `withForeColor` red
13+-- defAttr \`withForeColor\` red
1614-- @
1715--
18−-- Is the attribute that will set the foreground color to red and the background color to the
19−-- default.
20−--
21−-- This can then be used to build an image wiht a red foreground like so:
16+-- 'Image' constructors often require an 'Attr' to indicate the
17+-- attributes used in the image, e.g.,
2218--
2319-- @
24−-- string (defAttr `withForeColor` red) "this text will be red"
20+-- string (defAttr \`withForeColor\` red) "this text will be red"
2521-- @
2622--
27−-- The default attributes set by 'defAttr' have a presentation determined by the terminal. This is
28−-- not something VTY can control. The user is free to define the color scheme of the terminal as
29−-- they see fit. Up to the limits of the terminal anyways.
30−--
31−-- The value 'currentAttr' will keep the attributes of whatever was output previously.
32−--
33−-- \todo This API is very verbose IMO. I'd like something more succinct.
34−module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes
35− , module Graphics.Vty.Attributes.Color
36− , module Graphics.Vty.Attributes.Color240
37− )
38− where
39−
23+-- The appearance of 'Image's using 'defAttr' is determined by the The
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.
26+--
27+-- The value 'currentAttr' will keep the attributes of whatever was
28+-- output previously.
29+module Graphics.Vty.Attributes
30+ ( module Graphics.Vty.Attributes.Color
31+
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+ )
60+where
61+
62+import Control.DeepSeq
4063import Data.Bits
41−import Data.Default
64+import Data.Text (Text)
4265import Data.Word
66+import GHC.Generics
4367
4468import Graphics.Vty.Attributes.Color
45−import Graphics.Vty.Attributes.Color240
46−
47−#if !(MIN_VERSION_base(4,8,0))
48−import Data.Monoid
49−#endif
5069
51−-- | A display attribute defines the Color and Style of all the characters rendered after the
52−-- attribute is applied.
70+-- | A display attribute defines the Color and Style of all the
71+-- characters rendered after the attribute is applied.
5372--
54−-- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and
55−-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more
56−-- information.
73+-- At most 256 colors, picked from a 240 and 16 color palette, are
74+-- possible for the background and foreground. The 240 colors and
75+-- 16 colors are points in different palettes. See Color for more
76+-- information.
5777data Attr = Attr
5878 { attrStyle :: !(MaybeDefault Style)
5979 , attrForeColor :: !(MaybeDefault Color)
6080 , attrBackColor :: !(MaybeDefault Color)
61− } deriving ( Eq, Show, Read )
81+ , attrURL :: !(MaybeDefault Text)
82+ } deriving ( Eq, Show, Read, Generic, NFData )
6283
63−-- This could be encoded into a single 32 bit word. The 32 bit word is first divided
64−-- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to
65−-- the other groups.
84+-- This could be encoded into a single 32 bit word. The 32 bit word is
85+-- first divided into 4 groups of 8 bits where: The first group codes
86+-- what action should be taken with regards to the other groups.
6687-- XXYYZZ__
6788-- XX - style action
6889-- 00 => reset to default
@@ -79,85 +100,47 @@ data Attr = Attr
79100-- __ - unused
80101--
81102-- Next is the style flags
82−-- SURBDO__
103+-- SURBDOI_
83104-- S - standout
84105-- U - underline
85106-- R - reverse video
86107-- B - blink
87108-- D - dim
88109-- O - bold
89−-- __ - unused
110+-- I - italic
111+-- _ - unused
90112--
91113-- Then the foreground color encoded into 8 bits.
92114-- Then the background color encoded into 8 bits.
93115
94−instance Monoid Attr where
95− mempty = Attr mempty mempty mempty
96− mappend attr0 attr1 =
97− Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
98− ( attrForeColor attr0 `mappend` attrForeColor attr1 )
99− ( attrBackColor attr0 `mappend` attrBackColor attr1 )
100−
101−-- | Specifies the display attributes such that the final style and color values do not depend on
102−-- the previously applied display attribute. The display attributes can still depend on the
103−-- terminal's default colors (unfortunately).
116+-- | Specifies the display attributes such that the final style and
117+-- color values do not depend on the previously applied display
118+-- attribute. The display attributes can still depend on the terminal's
119+-- default colors (unfortunately).
104120data FixedAttr = FixedAttr
105121 { fixedStyle :: !Style
106122 , fixedForeColor :: !(Maybe Color)
107123 , fixedBackColor :: !(Maybe Color)
124+ , fixedURL :: !(Maybe Text)
108125 } deriving ( Eq, Show )
109126
110−-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the
111−-- previously applied style. Or be a specific value.
112−data MaybeDefault v where
113− Default :: MaybeDefault v
114− KeepCurrent :: MaybeDefault v
115− SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
116−
117−deriving instance Eq v => Eq (MaybeDefault v)
118−deriving instance Eq v => Show (MaybeDefault v)
119−deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
120−
121−instance Eq v => Monoid ( MaybeDefault v ) where
122− mempty = KeepCurrent
123− mappend Default Default = Default
124− mappend Default KeepCurrent = Default
125− mappend Default ( SetTo v ) = SetTo v
126− mappend KeepCurrent Default = Default
127− mappend KeepCurrent KeepCurrent = KeepCurrent
128− mappend KeepCurrent ( SetTo v ) = SetTo v
129− mappend ( SetTo _v ) Default = Default
130− mappend ( SetTo v ) KeepCurrent = SetTo v
131− mappend ( SetTo _ ) ( SetTo v ) = SetTo v
132−
133−-- | Standard 8-color ANSI terminal color codes.
134−black, red, green, yellow, blue, magenta, cyan, white :: Color
135−black = ISOColor 0
136−red = ISOColor 1
137−green = ISOColor 2
138−yellow = ISOColor 3
139−blue = ISOColor 4
140−magenta= ISOColor 5
141−cyan = ISOColor 6
142−white = ISOColor 7
143−
144−-- | Bright/Vivid variants of the standard 8-color ANSI
145−brightBlack, brightRed, brightGreen, brightYellow :: Color
146−brightBlue, brightMagenta, brightCyan, brightWhite :: Color
147−brightBlack = ISOColor 8
148−brightRed = ISOColor 9
149−brightGreen = ISOColor 10
150−brightYellow = ISOColor 11
151−brightBlue = ISOColor 12
152−brightMagenta= ISOColor 13
153−brightCyan = ISOColor 14
154−brightWhite = ISOColor 15
155−
156−-- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute
157−-- assigned to that bit should be applied and 0 if the style attribute should not be applied.
127+-- | The style and color attributes can either be the terminal defaults.
128+-- Or be equivalent to the previously applied style. Or be a specific
129+-- value.
130+data MaybeDefault v = Default | KeepCurrent | SetTo !v
131+ deriving (Eq, Read, Show)
132+
133+instance (NFData v) => NFData (MaybeDefault v) where
134+ rnf Default = ()
135+ rnf KeepCurrent = ()
136+ rnf (SetTo v) = rnf v
137+
138+-- | Styles are represented as an 8 bit word. Each bit in the word is 1
139+-- if the style attribute assigned to that bit should be applied and 0
140+-- if the style attribute should not be applied.
158141type Style = Word8
159142
160−-- | The 6 possible style attributes:
143+-- | Valid style attributes include:
161144--
162145-- * standout
163146--
@@ -171,21 +154,27 @@ type Style = Word8
171154--
172155-- * bold/bright
173156--
174−-- ( The invisible, protect, and altcharset display attributes some terminals support are not
175−-- supported via VTY.)
176−standout, underline, reverseVideo, blink, dim, bold :: Style
157+-- * italic
158+--
159+-- * strikethrough (via the smxx/rmxx terminfo capabilities)
160+--
161+-- (The invisible, protect, and altcharset display attributes some
162+-- terminals support are not supported via VTY.)
163+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
177164standout = 0x01
178165underline = 0x02
179−reverseVideo = 0x04
166+reverseVideo = 0x04
180167blink = 0x08
181168dim = 0x10
182169bold = 0x20
170+italic = 0x40
171+strikethrough = 0x80
183172
184173defaultStyleMask :: Style
185174defaultStyleMask = 0x00
186175
187176styleMask :: Attr -> Word8
188−styleMask attr
177+styleMask attr
189178 = case attrStyle attr of
190179 Default -> 0
191180 KeepCurrent -> 0
@@ -205,23 +194,35 @@ withBackColor attr c = attr { attrBackColor = SetTo c }
205194
206195-- | Add the given style attribute
207196withStyle :: Attr -> Style -> Attr
197+withStyle attr 0 = attr
208198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
209199
210−-- | Sets the style, background color and foreground color to the default values for the terminal.
211−-- There is no easy way to determine what the default background and foreground colors are.
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
215+-- default values for the terminal. There is no easy way to determine
216+-- what the default background and foreground colors are.
212217defAttr :: Attr
213−defAttr = Attr Default Default Default
214−
215−instance Default Attr where
216− def = defAttr
218+defAttr = Attr Default Default Default Default
217219
218−-- | Keeps the style, background color and foreground color that was previously set. Used to
219−-- override some part of the previous style.
220+-- | Keeps the style, background color and foreground color that was
221+-- previously set. Used to override some part of the previous style.
220222--
221223-- EG: current_style `withForeColor` brightMagenta
222224--
223−-- Would be the currently applied style (be it underline, bold, etc) but with the foreground color
224−-- set to brightMagenta.
225+-- Would be the currently applied style (be it underline, bold, etc) but
226+-- with the foreground color set to brightMagenta.
225227currentAttr :: Attr
226−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
227−
228+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs+162−22
@@ -1,16 +1,75 @@
1−module Graphics.Vty.Attributes.Color where
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE MultiWayIf #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+
6+module Graphics.Vty.Attributes.Color
7+ ( Color(..)
8+ , ColorMode(..)
9+
10+ -- * Detecting Terminal Color Support
11+ , detectColorMode
12+
13+ -- ** Fixed Colors
14+ -- | Standard 8-color ANSI terminal color codes.
15+ --
16+ -- Note that these map to colors in the terminal's custom palette. For
17+ -- instance, `white` maps to whatever the terminal color theme uses for
18+ -- white.
19+ --
20+ -- Use these functions if you want to make apps that fit the terminal theme.
21+ -- If you want access to more/stronger colors use `rgbColor`
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+
249import 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
359
460-- | Abstract data type representing a color.
5−--
6−-- Currently the foreground and background color are specified as points in either a:
761--
8−-- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8
9−-- color palette and the second 8 colors are bright/vivid versions of the first 8 colors.
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
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.
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.
1072--
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−--
1473-- The 8 ISO 6429 (ANSI) colors are as follows:
1574--
1675-- 0. black
@@ -29,23 +88,104 @@ import Data.Word
2988--
3089-- 7. white
3190--
32−-- The mapping from points in the 240 color palette to colors actually displayable by the terminal
33−-- depends on the number of colors the terminal claims to support. Which is usually determined by
34−-- the terminfo "colors" property. If this property is not being accurately reported then the color
35−-- reproduction will be incorrect.
91+-- The mapping from points in the 240 color palette to colors actually
92+-- displayable by the terminal depends on the number of colors the
93+-- terminal claims to support. Which is usually determined by the
94+-- terminfo "colors" property. If this property is not being accurately
95+-- reported then the color reproduction will be incorrect.
3696--
37−-- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8
38−-- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not
39−-- addressable via the 240 color palette.
97+-- If the terminal reports <= 16 colors then the 240 color palette
98+-- points are only mapped to the 8 color palette. I'm not sure of
99+-- the RGB points for the "bright" colors which is why they are not
100+-- addressable via the 240 color palette.
40101--
41−-- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest
42−-- points in a ("color count" - 16) subsampling of the 240 color palette.
102+-- If the terminal reports > 16 colors then the 240 color palette
103+-- points are mapped to the nearest points in a ("color count" - 16)
104+-- subsampling of the 240 color palette.
43105--
44−-- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors.
45−-- And that the individual colors have not been remapped by the user. There may be a way to verify
46−-- this through terminfo but I don't know it.
106+-- All of this assumes the terminals are behaving similarly to xterm and
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
109+-- terminfo but I don't know it.
47110--
48111-- Seriously, terminal color support is INSANE.
49−data Color = ISOColor !Word8 | Color240 !Word8
50− deriving ( Eq, Show, Read )
112+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !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 )
122+
123+detectColorMode :: String -> IO ColorMode
124+detectColorMode termName' = do
125+ term <- catch (Just <$> Terminfo.setupTerm termName')
126+ (\(_ :: Terminfo.SetupTermError) -> return Nothing)
127+ let getCap cap = term >>= \t -> Terminfo.getCapability t cap
128+ termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")
129+ colorterm <- lookupEnv "COLORTERM"
130+ return $ if
131+ | termColors < 8 -> NoColor
132+ | termColors < 16 -> ColorMode8
133+ | termColors == 16 -> ColorMode16
134+ | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)
135+ | colorterm == Just "truecolor" -> FullColor
136+ | colorterm == Just "24bit" -> FullColor
137+ | otherwise -> ColorMode240 240
138+
139+black, red, green, yellow, blue, magenta, cyan, white :: Color
140+black = ISOColor 0
141+red = ISOColor 1
142+green = ISOColor 2
143+yellow = ISOColor 3
144+blue = ISOColor 4
145+magenta= ISOColor 5
146+cyan = ISOColor 6
147+white = ISOColor 7
148+
149+brightBlack, brightRed, brightGreen, brightYellow :: Color
150+brightBlue, brightMagenta, brightCyan, brightWhite :: Color
151+brightBlack = ISOColor 8
152+brightRed = ISOColor 9
153+brightGreen = ISOColor 10
154+brightYellow = ISOColor 11
155+brightBlue = ISOColor 12
156+brightMagenta= ISOColor 13
157+brightCyan = ISOColor 14
158+brightWhite = ISOColor 15
159+
160+linearColor :: Integral i => i -> i -> i -> Color
161+linearColor r g b = RGBColor r' g' b'
162+ where
163+ r' = fromIntegral (clamp r) :: Word8
164+ g' = fromIntegral (clamp g) :: Word8
165+ b' = fromIntegral (clamp b) :: Word8
166+ clamp = min 255 . max 0
167+
168+srgbColor :: Integral i => i -> i -> i -> Color
169+srgbColor r g b =
170+ -- srgb to rgb transformation as described at
171+ -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation
172+ --
173+ -- TODO: it may be worth translating this to a lookup table, as with color240
174+ let shrink n = fromIntegral n / 255 :: Double
175+ -- called gamma^-1 in wiki
176+ gamma u
177+ | u <= 0.04045 = u/12.92
178+ | otherwise = ((u + 0.055) / 1.055) ** 2.4
179+ -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?
180+ expand n = round (255 * n)
181+ convert = expand . gamma . shrink
182+ in RGBColor (convert r) (convert g) (convert b)
183+
184+color240 :: Integral i => i -> i -> i -> Color
185+color240 r g b = Color240 (rgbColorToColor240 r g b)
51186
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+291−254
@@ -1,261 +1,298 @@
1−{-
2− - This header file was generated by ./256colres.pl
3− -}
4−module Graphics.Vty.Attributes.Color240 where
5−
6−import Graphics.Vty.Attributes.Color
1+-- This header file was generated by ./256colres.pl
2+module Graphics.Vty.Attributes.Color240
3+ ( rgbColorToColor240
4+ , color240CodeToRGB
5+ )
6+where
77
8+import Data.Word (Word8)
89import Text.Printf
910
10−-- | RGB color to 240 color palette.
11−--
12−-- generated from 256colres.pl which is forked from xterm 256colres.pl
13−-- todo: all values get clamped high.
14−rgbColor :: Integral i => i -> i -> i -> Color
15−rgbColor r g b
11+-- Note: rgbColor's mapping from RGB to 240 colors was generated from
12+-- 256colres.pl which is forked from xterm 256colres.pl.
13+
14+-- | Create a value in the Color240 set from an RGB triple
15+rgbColorToColor240 :: Integral i => i -> i -> i -> Word8
16+rgbColorToColor240 r g b
1617 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
17− | r == 8 && g == 8 && b == 8 = Color240 216
18− | r == 18 && g == 18 && b == 18 = Color240 217
19− | r == 28 && g == 28 && b == 28 = Color240 218
20− | r == 38 && g == 38 && b == 38 = Color240 219
21− | r == 48 && g == 48 && b == 48 = Color240 220
22− | r == 58 && g == 58 && b == 58 = Color240 221
23− | r == 68 && g == 68 && b == 68 = Color240 222
24− | r == 78 && g == 78 && b == 78 = Color240 223
25− | r == 88 && g == 88 && b == 88 = Color240 224
26− | r == 98 && g == 98 && b == 98 = Color240 225
27− | r == 108 && g == 108 && b == 108 = Color240 226
28− | r == 118 && g == 118 && b == 118 = Color240 227
29− | r == 128 && g == 128 && b == 128 = Color240 228
30− | r == 138 && g == 138 && b == 138 = Color240 229
31− | r == 148 && g == 148 && b == 148 = Color240 230
32− | r == 158 && g == 158 && b == 158 = Color240 231
33− | r == 168 && g == 168 && b == 168 = Color240 232
34− | r == 178 && g == 178 && b == 178 = Color240 233
35− | r == 188 && g == 188 && b == 188 = Color240 234
36− | r == 198 && g == 198 && b == 198 = Color240 235
37− | r == 208 && g == 208 && b == 208 = Color240 236
38− | r == 218 && g == 218 && b == 218 = Color240 237
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."
18+ | r == 8 && g == 8 && b == 8 = 216
19+ | r == 18 && g == 18 && b == 18 = 217
20+ | r == 28 && g == 28 && b == 28 = 218
21+ | r == 38 && g == 38 && b == 38 = 219
22+ | r == 48 && g == 48 && b == 48 = 220
23+ | r == 58 && g == 58 && b == 58 = 221
24+ | r == 68 && g == 68 && b == 68 = 222
25+ | r == 78 && g == 78 && b == 78 = 223
26+ | r == 88 && g == 88 && b == 88 = 224
27+ | r == 98 && g == 98 && b == 98 = 225
28+ | r == 108 && g == 108 && b == 108 = 226
29+ | r == 118 && g == 118 && b == 118 = 227
30+ | r == 128 && g == 128 && b == 128 = 228
31+ | r == 138 && g == 138 && b == 138 = 229
32+ | r == 148 && g == 148 && b == 148 = 230
33+ | r == 158 && g == 158 && b == 158 = 231
34+ | r == 168 && g == 168 && b == 168 = 232
35+ | r == 178 && g == 178 && b == 178 = 233
36+ | r == 188 && g == 188 && b == 188 = 234
37+ | r == 198 && g == 198 && b == 198 = 235
38+ | r == 208 && g == 208 && b == 208 = 236
39+ | r == 218 && g == 218 && b == 218 = 237
40+ | r == 228 && g == 228 && b == 228 = 238
41+ | r == 238 && g == 238 && b == 238 = 239
42+ | otherwise = 36 * go r + 6 * go g + go b
43+ where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."
25844 (fromIntegral r :: Int)
25945 (fromIntegral g :: Int)
260− (fromIntegral b :: Int))
46+ (fromIntegral b :: Int)))
47+
48+simpleColor_ :: Integral i => Word8 -> i -> Word8
49+simpleColor_ e c
50+ | c <= 0 = 0
51+ | c <= 95 = 1
52+ | c <= 255 = fromIntegral ((c-16) `div` 40)
53+ | otherwise = e
26154
55+-- | Create a RGB triple from a value in the Color240 set.
56+color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)
57+color240CodeToRGB n = case n of
58+ 0 -> Just (0, 0, 0)
59+ 1 -> Just (0, 0, 95)
60+ 2 -> Just (0, 0, 135)
61+ 3 -> Just (0, 0, 175)
62+ 4 -> Just (0, 0, 215)
63+ 5 -> Just (0, 0, 255)
64+ 6 -> Just (0, 95, 0)
65+ 7 -> Just (0, 95, 95)
66+ 8 -> Just (0, 95, 135)
67+ 9 -> Just (0, 95, 175)
68+ 10 -> Just (0, 95, 215)
69+ 11 -> Just (0, 95, 255)
70+ 12 -> Just (0, 135, 0)
71+ 13 -> Just (0, 135, 95)
72+ 14 -> Just (0, 135, 135)
73+ 15 -> Just (0, 135, 175)
74+ 16 -> Just (0, 135, 215)
75+ 17 -> Just (0, 135, 255)
76+ 18 -> Just (0, 175, 0)
77+ 19 -> Just (0, 175, 95)
78+ 20 -> Just (0, 175, 135)
79+ 21 -> Just (0, 175, 175)
80+ 22 -> Just (0, 175, 215)
81+ 23 -> Just (0, 175, 255)
82+ 24 -> Just (0, 215, 0)
83+ 25 -> Just (0, 215, 95)
84+ 26 -> Just (0, 215, 135)
85+ 27 -> Just (0, 215, 175)
86+ 28 -> Just (0, 215, 215)
87+ 29 -> Just (0, 215, 255)
88+ 30 -> Just (0, 255, 0)
89+ 31 -> Just (0, 255, 95)
90+ 32 -> Just (0, 255, 135)
91+ 33 -> Just (0, 255, 175)
92+ 34 -> Just (0, 255, 215)
93+ 35 -> Just (0, 255, 255)
94+ 36 -> Just (95, 0, 0)
95+ 37 -> Just (95, 0, 95)
96+ 38 -> Just (95, 0, 135)
97+ 39 -> Just (95, 0, 175)
98+ 40 -> Just (95, 0, 215)
99+ 41 -> Just (95, 0, 255)
100+ 42 -> Just (95, 95, 0)
101+ 43 -> Just (95, 95, 95)
102+ 44 -> Just (95, 95, 135)
103+ 45 -> Just (95, 95, 175)
104+ 46 -> Just (95, 95, 215)
105+ 47 -> Just (95, 95, 255)
106+ 48 -> Just (95, 135, 0)
107+ 49 -> Just (95, 135, 95)
108+ 50 -> Just (95, 135, 135)
109+ 51 -> Just (95, 135, 175)
110+ 52 -> Just (95, 135, 215)
111+ 53 -> Just (95, 135, 255)
112+ 54 -> Just (95, 175, 0)
113+ 55 -> Just (95, 175, 95)
114+ 56 -> Just (95, 175, 135)
115+ 57 -> Just (95, 175, 175)
116+ 58 -> Just (95, 175, 215)
117+ 59 -> Just (95, 175, 255)
118+ 60 -> Just (95, 215, 0)
119+ 61 -> Just (95, 215, 95)
120+ 62 -> Just (95, 215, 135)
121+ 63 -> Just (95, 215, 175)
122+ 64 -> Just (95, 215, 215)
123+ 65 -> Just (95, 215, 255)
124+ 66 -> Just (95, 255, 0)
125+ 67 -> Just (95, 255, 95)
126+ 68 -> Just (95, 255, 135)
127+ 69 -> Just (95, 255, 175)
128+ 70 -> Just (95, 255, 215)
129+ 71 -> Just (95, 255, 255)
130+ 72 -> Just (135, 0, 0)
131+ 73 -> Just (135, 0, 95)
132+ 74 -> Just (135, 0, 135)
133+ 75 -> Just (135, 0, 175)
134+ 76 -> Just (135, 0, 215)
135+ 77 -> Just (135, 0, 255)
136+ 78 -> Just (135, 95, 0)
137+ 79 -> Just (135, 95, 95)
138+ 80 -> Just (135, 95, 135)
139+ 81 -> Just (135, 95, 175)
140+ 82 -> Just (135, 95, 215)
141+ 83 -> Just (135, 95, 255)
142+ 84 -> Just (135, 135, 0)
143+ 85 -> Just (135, 135, 95)
144+ 86 -> Just (135, 135, 135)
145+ 87 -> Just (135, 135, 175)
146+ 88 -> Just (135, 135, 215)
147+ 89 -> Just (135, 135, 255)
148+ 90 -> Just (135, 175, 0)
149+ 91 -> Just (135, 175, 95)
150+ 92 -> Just (135, 175, 135)
151+ 93 -> Just (135, 175, 175)
152+ 94 -> Just (135, 175, 215)
153+ 95 -> Just (135, 175, 255)
154+ 96 -> Just (135, 215, 0)
155+ 97 -> Just (135, 215, 95)
156+ 98 -> Just (135, 215, 135)
157+ 99 -> Just (135, 215, 175)
158+ 100 -> Just (135, 215, 215)
159+ 101 -> Just (135, 215, 255)
160+ 102 -> Just (135, 255, 0)
161+ 103 -> Just (135, 255, 95)
162+ 104 -> Just (135, 255, 135)
163+ 105 -> Just (135, 255, 175)
164+ 106 -> Just (135, 255, 215)
165+ 107 -> Just (135, 255, 255)
166+ 108 -> Just (175, 0, 0)
167+ 109 -> Just (175, 0, 95)
168+ 110 -> Just (175, 0, 135)
169+ 111 -> Just (175, 0, 175)
170+ 112 -> Just (175, 0, 215)
171+ 113 -> Just (175, 0, 255)
172+ 114 -> Just (175, 95, 0)
173+ 115 -> Just (175, 95, 95)
174+ 116 -> Just (175, 95, 135)
175+ 117 -> Just (175, 95, 175)
176+ 118 -> Just (175, 95, 215)
177+ 119 -> Just (175, 95, 255)
178+ 120 -> Just (175, 135, 0)
179+ 121 -> Just (175, 135, 95)
180+ 122 -> Just (175, 135, 135)
181+ 123 -> Just (175, 135, 175)
182+ 124 -> Just (175, 135, 215)
183+ 125 -> Just (175, 135, 255)
184+ 126 -> Just (175, 175, 0)
185+ 127 -> Just (175, 175, 95)
186+ 128 -> Just (175, 175, 135)
187+ 129 -> Just (175, 175, 175)
188+ 130 -> Just (175, 175, 215)
189+ 131 -> Just (175, 175, 255)
190+ 132 -> Just (175, 215, 0)
191+ 133 -> Just (175, 215, 95)
192+ 134 -> Just (175, 215, 135)
193+ 135 -> Just (175, 215, 175)
194+ 136 -> Just (175, 215, 215)
195+ 137 -> Just (175, 215, 255)
196+ 138 -> Just (175, 255, 0)
197+ 139 -> Just (175, 255, 95)
198+ 140 -> Just (175, 255, 135)
199+ 141 -> Just (175, 255, 175)
200+ 142 -> Just (175, 255, 215)
201+ 143 -> Just (175, 255, 255)
202+ 144 -> Just (215, 0, 0)
203+ 145 -> Just (215, 0, 95)
204+ 146 -> Just (215, 0, 135)
205+ 147 -> Just (215, 0, 175)
206+ 148 -> Just (215, 0, 215)
207+ 149 -> Just (215, 0, 255)
208+ 150 -> Just (215, 95, 0)
209+ 151 -> Just (215, 95, 95)
210+ 152 -> Just (215, 95, 135)
211+ 153 -> Just (215, 95, 175)
212+ 154 -> Just (215, 95, 215)
213+ 155 -> Just (215, 95, 255)
214+ 156 -> Just (215, 135, 0)
215+ 157 -> Just (215, 135, 95)
216+ 158 -> Just (215, 135, 135)
217+ 159 -> Just (215, 135, 175)
218+ 160 -> Just (215, 135, 215)
219+ 161 -> Just (215, 135, 255)
220+ 162 -> Just (215, 175, 0)
221+ 163 -> Just (215, 175, 95)
222+ 164 -> Just (215, 175, 135)
223+ 165 -> Just (215, 175, 175)
224+ 166 -> Just (215, 175, 215)
225+ 167 -> Just (215, 175, 255)
226+ 168 -> Just (215, 215, 0)
227+ 169 -> Just (215, 215, 95)
228+ 170 -> Just (215, 215, 135)
229+ 171 -> Just (215, 215, 175)
230+ 172 -> Just (215, 215, 215)
231+ 173 -> Just (215, 215, 255)
232+ 174 -> Just (215, 255, 0)
233+ 175 -> Just (215, 255, 95)
234+ 176 -> Just (215, 255, 135)
235+ 177 -> Just (215, 255, 175)
236+ 178 -> Just (215, 255, 215)
237+ 179 -> Just (215, 255, 255)
238+ 180 -> Just (255, 0, 0)
239+ 181 -> Just (255, 0, 95)
240+ 182 -> Just (255, 0, 135)
241+ 183 -> Just (255, 0, 175)
242+ 184 -> Just (255, 0, 215)
243+ 185 -> Just (255, 0, 255)
244+ 186 -> Just (255, 95, 0)
245+ 187 -> Just (255, 95, 95)
246+ 188 -> Just (255, 95, 135)
247+ 189 -> Just (255, 95, 175)
248+ 190 -> Just (255, 95, 215)
249+ 191 -> Just (255, 95, 255)
250+ 192 -> Just (255, 135, 0)
251+ 193 -> Just (255, 135, 95)
252+ 194 -> Just (255, 135, 135)
253+ 195 -> Just (255, 135, 175)
254+ 196 -> Just (255, 135, 215)
255+ 197 -> Just (255, 135, 255)
256+ 198 -> Just (255, 175, 0)
257+ 199 -> Just (255, 175, 95)
258+ 200 -> Just (255, 175, 135)
259+ 201 -> Just (255, 175, 175)
260+ 202 -> Just (255, 175, 215)
261+ 203 -> Just (255, 175, 255)
262+ 204 -> Just (255, 215, 0)
263+ 205 -> Just (255, 215, 95)
264+ 206 -> Just (255, 215, 135)
265+ 207 -> Just (255, 215, 175)
266+ 208 -> Just (255, 215, 215)
267+ 209 -> Just (255, 215, 255)
268+ 210 -> Just (255, 255, 0)
269+ 211 -> Just (255, 255, 95)
270+ 212 -> Just (255, 255, 135)
271+ 213 -> Just (255, 255, 175)
272+ 214 -> Just (255, 255, 215)
273+ 215 -> Just (255, 255, 255)
274+ 216 -> Just (8, 8, 8)
275+ 217 -> Just (18, 18, 18)
276+ 218 -> Just (28, 28, 28)
277+ 219 -> Just (38, 38, 38)
278+ 220 -> Just (48, 48, 48)
279+ 221 -> Just (58, 58, 58)
280+ 222 -> Just (68, 68, 68)
281+ 223 -> Just (78, 78, 78)
282+ 224 -> Just (88, 88, 88)
283+ 225 -> Just (98, 98, 98)
284+ 226 -> Just (108, 108, 108)
285+ 227 -> Just (118, 118, 118)
286+ 228 -> Just (128, 128, 128)
287+ 229 -> Just (138, 138, 138)
288+ 230 -> Just (148, 148, 148)
289+ 231 -> Just (158, 158, 158)
290+ 232 -> Just (168, 168, 168)
291+ 233 -> Just (178, 178, 178)
292+ 234 -> Just (188, 188, 188)
293+ 235 -> Just (198, 198, 198)
294+ 236 -> Just (208, 208, 208)
295+ 237 -> Just (218, 218, 218)
296+ 238 -> Just (228, 228, 228)
297+ 239 -> Just (238, 238, 238)
298+ _ -> Nothing
src/Graphics/Vty/Config.hs+398−194
@@ -1,22 +1,15 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE KindSignatures #-}
5−-- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can
6−-- be used to customize vty for a user's system.
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.
710--
8−-- The 'Config' provided is mappend'd to 'Config's loaded from @'getAppUserDataDirectory'/config@
9−-- and @$VTY_CONFIG_FILE@. The @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the
10−-- application provided 'Config'.
11−--
12−-- Lines in config files that fail to parse are ignored. Later entries take precedence over
13−-- earlier.
14−--
15−-- For all directives:
16−--
17−-- @
18−-- string := \"\\\"\" chars+ \"\\\"\"
19−-- @
11+-- Lines in config files that fail to parse are ignored. Later entries
12+-- take precedence over earlier ones.
2013--
2114-- = Debug
2215--
@@ -28,8 +21,8 @@
2821-- \"debugLog\" string
2922-- @
3023--
31−-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent to a debugLog entry at the
32−-- end of the last config file.
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.
3326--
3427-- = Input Processing
3528--
@@ -39,14 +32,14 @@
3932--
4033-- @
4134-- \"map\" term string key modifier_list
42−-- where
35+-- where
4336-- key := KEsc | KChar Char | KBS ... (same as 'Key')
4437-- modifier_list := \"[\" modifier+ \"]\"
4538-- modifier := MShift | MCtrl | MMeta | MAlt
4639-- term := "_" | string
4740-- @
4841--
49−-- EG: If the contents are
42+-- E.g., if the contents are
5043--
5144-- @
5245-- map _ \"\\ESC[B\" KUp []
@@ -54,231 +47,442 @@
5447-- map \"xterm\" \"\\ESC[D\" KLeft []
5548-- @
5649--
57−-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all terminals. The bytes
58−-- @\"\\ESC[1;3B\"@ will result in the event KDown with the MAlt modifier on all terminals.
59−-- The bytes @\"\\ESC[D\"@ will result in the KLeft event when @TERM@ is @xterm@.
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+-- @
6069--
61−-- If a debug log is requested then vty will output the current input table to the log in the above
62−-- format.
70+-- E.g.,
6371--
64−-- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings. Add corrected mappings to
65−-- .vty/config
72+-- @
73+-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"
74+-- @
6675--
67−module Graphics.Vty.Config where
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
68108
69−#if __GLASGOW_HASKELL__ > 704
70109import Prelude
71−#else
72−import Prelude hiding (catch)
73−#endif
74110
75111import Control.Applicative hiding (many)
76112
77−import Control.Exception (catch, IOException)
78−import Control.Monad (void)
79−import Control.Monad.Trans.Class
80−import Control.Monad.Trans.Writer
113+import Control.Exception (catch, IOException, Exception(..), throwIO)
114+import Control.Monad (liftM, guard, void)
81115
82116import qualified Data.ByteString as BS
83−import Data.Default
84−import Data.Monoid
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)
85124
86125import Graphics.Vty.Input.Events
126+import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)
127+
128+import GHC.Generics
87129
88−import System.Directory (getAppUserDataDirectory)
89−import System.Posix.Env (getEnv)
130+import System.Directory ( getAppUserDataDirectory, doesFileExist
131+ , createDirectoryIfMissing
132+ )
133+import System.Environment (lookupEnv)
134+import System.FilePath ((</>), takeDirectory)
90135import System.Posix.IO (stdInput, stdOutput)
91136import System.Posix.Types (Fd(..))
137+import Foreign.C.Types (CInt(..), CChar(..))
92138
93139import Text.Parsec hiding ((<|>))
94140import Text.Parsec.Token ( GenLanguageDef(..) )
95141import qualified Text.Parsec.Token as P
96142
97−-- | Mappings from input bytes to event in the order specified. Later entries take precedence over
98−-- earlier in the case multiple entries have the same byte string.
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.
99155type InputMap = [(Maybe String, String, Event)]
100156
101−data Config = Config
102− {
103− -- | The default is 1 character.
104− vmin :: Maybe Int
105− -- | The default is 100 milliseconds, 0.1 seconds.
106− , vtime :: Maybe Int
107− -- | Debug information is appended to this file if not Nothing.
108− , debugLog :: Maybe FilePath
109− -- | The (input byte, output event) pairs extend the internal input table of VTY and the table
110− -- from terminfo.
111− --
112− -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive.
113− , inputMap :: InputMap
114− -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput'
115− , inputFd :: Maybe Fd
116− -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput'
117− , outputFd :: Maybe Fd
118− -- | The terminal name used to look up terminfo capabilities.
119− -- The default is the value of the TERM environment variable.
120− , termName :: Maybe String
121− } deriving (Show, Eq)
122−
123−instance Default Config where
124− def = mempty
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)
125203
126−instance Monoid Config where
127− mempty = Config
128− { vmin = Nothing
129− , vtime = Nothing
130− , debugLog = mempty
131− , inputMap = mempty
132− , inputFd = Nothing
133− , outputFd = Nothing
134− , termName = Nothing
135− }
136− mappend c0 c1 = Config
204+defaultConfig :: Config
205+defaultConfig = mempty
206+
207+instance Semigroup Config where
208+ c0 <> c1 =
137209 -- latter config takes priority for everything but inputMap
138− { vmin = vmin c1 <|> vmin c0
139− , vtime = vtime c1 <|> vtime c0
140− , debugLog = debugLog c1 <|> debugLog c0
141− , inputMap = inputMap c0 <> inputMap c1
142− , inputFd = inputFd c1 <|> inputFd c0
143− , outputFd = outputFd c1 <|> outputFd c0
144− , termName = termName c1 <|> termName c0
145− }
146−
147−type ConfigParser s a = ParsecT s () (Writer Config) a
148−
149−-- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@
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@.
150256userConfig :: IO Config
151257userConfig = do
152− configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
153− overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
258+ configFile <- vtyConfigPath >>= parseConfigFile
259+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
260+ lookupEnv vtyConfigFileEnvName
154261 let base = configFile <> overrideConfig
155262 mappend base <$> overrideEnvConfig
156263
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+
157282overrideEnvConfig :: IO Config
158283overrideEnvConfig = do
159− d <- getEnv "VTY_DEBUG_LOG"
160− return $ def { debugLog = d }
284+ d <- lookupEnv "VTY_DEBUG_LOG"
285+ return $ defaultConfig { debugLog = d }
161286
287+-- | Configures VTY using defaults suitable for terminals. This function
288+-- can raise 'VtyConfigurationError'.
162289standardIOConfig :: IO Config
163290standardIOConfig = do
164− Just t <- getEnv "TERM"
165− return $ def { vmin = Just 1
166− , vtime = Just 100
167− , inputFd = Just stdInput
168− , outputFd = Just stdOutput
169− , termName = Just t
170− }
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+ }
171306
172307parseConfigFile :: FilePath -> IO Config
173308parseConfigFile path = do
174309 catch (runParseConfig path <$> BS.readFile path)
175− (\(_ :: IOException) -> return def)
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
176317
177−runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config
178−runParseConfig name = execWriter . runParserT parseConfig () name
318+------------------------------------------------------------------------
179319
180−-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the
181−-- String stream type.
182−configLanguage :: Stream s m Char => P.GenLanguageDef s u m
320+type Parser = Parsec BS.ByteString ()
321+
322+configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
183323configLanguage = LanguageDef
184− { commentStart = "{-"
185− , commentEnd = "-}"
186− , commentLine = "--"
187− , nestedComments = True
188− , identStart = letter <|> char '_'
189− , identLetter = alphaNum <|> oneOf "_'"
190− , opStart = opLetter configLanguage
191− , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
324+ { commentStart = "{-"
325+ , commentEnd = "-}"
326+ , commentLine = "--"
327+ , nestedComments = True
328+ , identStart = letter <|> char '_'
329+ , identLetter = alphaNum <|> oneOf "_'"
330+ , opStart = opLetter configLanguage
331+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
192332 , reservedOpNames = []
193− , reservedNames = []
194− , caseSensitive = True
333+ , reservedNames = []
334+ , caseSensitive = True
195335 }
196336
197−configLexer :: Stream s m Char => P.GenTokenParser s u m
337+configLexer :: Monad m => P.GenTokenParser BS.ByteString () m
198338configLexer = P.makeTokenParser configLanguage
199339
200−mapDecl :: forall s u (m :: * -> *).
201− (Monad m, Stream s (WriterT Config m) Char) =>
202− ParsecT s u (WriterT Config m) ()
340+mapDecl :: Parser Config
203341mapDecl = do
204− void $ string "map"
205− P.whiteSpace configLexer
342+ "map" <- P.identifier configLexer
206343 termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)
207344 <|> (Just <$> P.stringLiteral configLexer)
208− bytes <- P.stringLiteral configLexer
209− key <- parseKey
210− modifiers <- parseModifiers
211− lift $ tell $ def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
212−
213−-- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read
214−-- instance? Generics?
215−parseKey :: forall s u (m :: * -> *).
216− Stream s m Char =>
217− ParsecT s u m Key
218−parseKey = do
219− key <- P.identifier configLexer
220− case key of
221− "KChar" -> KChar <$> P.charLiteral configLexer
222− "KFun" -> KFun . fromInteger <$> P.natural configLexer
223− "KEsc" -> return KEsc
224− "KBS" -> return KBS
225− "KEnter" -> return KEnter
226− "KLeft" -> return KLeft
227− "KRight" -> return KRight
228− "KUp" -> return KUp
229− "KDown" -> return KDown
230− "KUpLeft" -> return KUpLeft
231− "KUpRight" -> return KUpRight
232− "KDownLeft" -> return KDownLeft
233− "KDownRight" -> return KDownRight
234− "KCenter" -> return KCenter
235− "KBackTab" -> return KBackTab
236− "KPrtScr" -> return KPrtScr
237− "KPause" -> return KPause
238− "KIns" -> return KIns
239− "KHome" -> return KHome
240− "KPageUp" -> return KPageUp
241− "KDel" -> return KDel
242− "KEnd" -> return KEnd
243− "KPageDown" -> return KPageDown
244− "KBegin" -> return KBegin
245− "KMenu" -> return KMenu
246− _ -> fail $ key ++ " is not a valid key identifier"
247−
248−parseModifiers :: forall s u (m :: * -> *).
249− Stream s m Char =>
250− ParsecT s u m [Modifier]
251−parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",")
252−
253−parseModifier :: forall s u (m :: * -> *).
254− Stream s m Char =>
255− ParsecT s u m Modifier
256−parseModifier = do
257− m <- P.identifier configLexer
258− case m of
259− "KMenu" -> return MShift
260− "MCtrl" -> return MCtrl
261− "MMeta" -> return MMeta
262− "MAlt" -> return MAlt
263− _ -> fail $ m ++ " is not a valid modifier identifier"
264−
265−debugLogDecl :: forall s u (m :: * -> *).
266− (Monad m, Stream s (WriterT Config m) Char) =>
267− ParsecT s u (WriterT Config m) ()
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
268351debugLogDecl = do
269− void $ string "debugLog"
270− P.whiteSpace configLexer
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
271360 path <- P.stringLiteral configLexer
272− lift $ tell $ def { debugLog = Just path }
361+ return defaultConfig { termWidthMaps = [(tName, path)] }
273362
274−ignoreLine :: forall s u (m :: * -> *).
275− Stream s m Char => ParsecT s u m ()
363+ignoreLine :: Parser ()
276364ignoreLine = void $ manyTill anyChar newline
277365
278−parseConfig :: forall s u (m :: * -> *).
279− (Monad m, Stream s (WriterT Config m) Char) =>
280− ParsecT s u (WriterT Config m) ()
281−parseConfig = void $ many $ do
366+parseConfig :: Parser Config
367+parseConfig = liftM mconcat $ many $ do
282368 P.whiteSpace configLexer
283− let directives = [mapDecl, debugLogDecl]
284− try (choice directives) <|> ignoreLine
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+13−14
@@ -1,29 +1,29 @@
11-- Copyright 2009-2010 Corey O'Connor
2−module Graphics.Vty.Debug ( module Graphics.Vty.Debug
3− , module Graphics.Vty.Debug.Image
4− )
2+module Graphics.Vty.Debug
3+ ( module Graphics.Vty.Debug
4+ , module Graphics.Vty.Debug.Image
5+ )
56where
67
7−import Graphics.Vty.Prelude
8−
98import Graphics.Vty.Attributes
9+import Graphics.Vty.Image (DisplayRegion)
1010import Graphics.Vty.Debug.Image
1111import Graphics.Vty.Span
1212
13−import qualified Data.Vector as Vector
13+import qualified Data.Vector as Vector
1414
15−rowOpsEffectedColumns :: DisplayOps -> [Int]
16−rowOpsEffectedColumns ops
17− = Vector.toList $ Vector.map spanOpsEffectedColumns ops
15+rowOpsAffectedColumns :: DisplayOps -> [Int]
16+rowOpsAffectedColumns ops
17+ = Vector.toList $ Vector.map spanOpsAffectedColumns ops
1818
1919allSpansHaveWidth :: DisplayOps -> Int -> Bool
2020allSpansHaveWidth ops expected
21− = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops
21+ = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops
2222
23−spanOpsEffectedRows :: DisplayOps -> Int
24−spanOpsEffectedRows ops
23+spanOpsAffectedRows :: DisplayOps -> Int
24+spanOpsAffectedRows ops
2525 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
26−
26+
2727type SpanConstructLog = [SpanConstructEvent]
2828data SpanConstructEvent = SpanSetAttr Attr
2929
@@ -37,4 +37,3 @@ data MockWindow = MockWindow Int Int
3737
3838regionForWindow :: MockWindow -> DisplayRegion
3939regionForWindow (MockWindow w h) = (w,h)
40−
src/Graphics/Vty/Debug/Image.hs+1−1
@@ -19,7 +19,7 @@ data ImageOp = ImageOp ImageEndo ImageEndo
1919type ImageEndo = Image -> Image
2020
2121debugImageOps :: [ImageOp]
22−debugImageOps =
22+debugImageOps =
2323 [ idImageOp
2424 -- , renderSingleColumnCharOp
2525 -- , renderDoubleColumnCharOp
src/Graphics/Vty/DisplayAttributes.hs+64−33
@@ -1,31 +1,30 @@
11-- Copyright 2009-2010 Corey O'Connor
2−{-# LANGUAGE CPP #-}
32{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE CPP #-}
44
5−#ifndef MIN_VERSION_base
6−#defined MIN_VERSION_base(x,y,z) 1
7−#endif
8−
9−module Graphics.Vty.DisplayAttributes
10− where
5+module Graphics.Vty.DisplayAttributes where
116
127import Graphics.Vty.Attributes
138
149import Data.Bits ((.&.))
15−
16−#if !(MIN_VERSION_base(4,8,0))
17−import Data.Monoid (Monoid(..), mconcat)
10+import Data.ByteString (ByteString)
11+#if !(MIN_VERSION_base(4,11,0))
12+import Data.Semigroup (Semigroup(..))
1813#endif
14+import Data.Text (Text)
15+import Data.Text.Encoding (encodeUtf8)
1916
20−-- | Given the previously applied display attributes as a FixedAttr and the current display
21−-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This
22−-- is done by using the previously applied display attributes to remove the "KeepCurrent"
17+-- | Given the previously applied display attributes as a FixedAttr and
18+-- the current display attributes as an Attr produces a FixedAttr that
19+-- represents the current display attributes. This is done by using the
20+-- previously applied display attributes to remove the "KeepCurrent"
2321-- abstraction.
2422fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr
2523fixDisplayAttr fattr attr
2624 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))
2725 (fixColor (fixedForeColor fattr) (attrForeColor attr))
2826 (fixColor (fixedBackColor fattr) (attrBackColor attr))
27+ (fixURL (fixedURL fattr) (attrURL attr))
2928 where
3029 fixStyle _s Default = defaultStyleMask
3130 fixStyle s KeepCurrent = s
@@ -33,43 +32,56 @@ fixDisplayAttr fattr attr
3332 fixColor _c Default = Nothing
3433 fixColor c KeepCurrent = c
3534 fixColor _c (SetTo c) = Just c
35+ fixURL c KeepCurrent = c
36+ fixURL _c (SetTo n) = Just n
37+ fixURL _c Default = Nothing
3638
37−-- | difference between two display attributes. Used in the calculation of the operations required
38−-- to go from one display attribute to the next.
39+-- | difference between two display attributes. Used in the calculation
40+-- of the operations required to go from one display attribute to the
41+-- next.
3942--
40−-- Previously, vty would reset display attributes to default then apply the new display attributes.
41−-- This turned out to be very expensive: A *lot* more data would be sent to the terminal than
42−-- required.
43+-- Previously, vty would reset display attributes to default then apply
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.
4346data DisplayAttrDiff = DisplayAttrDiff
4447 { styleDiffs :: [StyleStateChange]
4548 , foreColorDiff :: DisplayColorDiff
4649 , backColorDiff :: DisplayColorDiff
50+ , urlDiff :: URLDiff
4751 }
4852 deriving (Show)
4953
50−instance Monoid DisplayAttrDiff where
51− mempty = DisplayAttrDiff [] NoColorChange NoColorChange
52− mappend d0 d1 =
54+instance Semigroup DisplayAttrDiff where
55+ d0 <> d1 =
5356 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)
5457 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
5558 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
56− in DisplayAttrDiff ds fcd bcd
59+ ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
60+ in DisplayAttrDiff ds fcd bcd ud
61+
62+instance Monoid DisplayAttrDiff where
63+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
64+#if !(MIN_VERSION_base(4,11,0))
65+ mappend = (<>)
66+#endif
5767
5868-- | Used in the computation of a final style attribute change.
59−--
60−-- TODO(corey): not really a simplify but a monoid instance.
6169simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
6270simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
6371
64−-- | Consider two display color attributes diffs. What display color attribute diff are these
65−-- equivalent to?
66−--
67−-- TODO(corey): not really a simplify but a monoid instance.
72+-- | Consider two display color attributes diffs. What display color
73+-- attribute diff are these equivalent to?
6874simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
6975simplifyColorDiffs _cd ColorToDefault = ColorToDefault
7076simplifyColorDiffs cd NoColorChange = cd
7177simplifyColorDiffs _cd (SetColor !c) = SetColor c
7278
79+-- | Consider two URL changes, which are mostly going to be the latter
80+-- unless the latter specifies no change.
81+simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
82+simplifyUrlDiffs ud NoLinkChange = ud
83+simplifyUrlDiffs _ ud = ud
84+
7385-- | Difference between two display color attribute changes.
7486data DisplayColorDiff
7587 = ColorToDefault
@@ -77,11 +89,15 @@ data DisplayColorDiff
7789 | SetColor !Color
7890 deriving (Show, Eq)
7991
80−-- | Style attribute changes are transformed into a sequence of apply/removes of the individual
81−-- attributes.
82−data StyleStateChange
92+-- | Style attribute changes are transformed into a sequence of
93+-- apply/removes of the individual attributes.
94+data StyleStateChange
8395 = ApplyStandout
8496 | RemoveStandout
97+ | ApplyItalic
98+ | RemoveItalic
99+ | ApplyStrikethrough
100+ | RemoveStrikethrough
85101 | ApplyUnderline
86102 | RemoveUnderline
87103 | ApplyReverseVideo
@@ -94,15 +110,28 @@ data StyleStateChange
94110 | RemoveBold
95111 deriving (Show, Eq)
96112
97−-- | Determines the diff between two display&color attributes. This diff determines the operations
98−-- that actually get output to the terminal.
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
121+-- determines the operations that actually get output to the terminal.
99122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
100123displayAttrDiffs attr attr' = DisplayAttrDiff
101124 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')
102125 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')
103126 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')
127+ , urlDiff = diffURL (fixedURL attr) (fixedURL attr')
104128 }
105129
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+
106135diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
107136diffColor Nothing (Just c') = SetColor c'
108137diffColor (Just c) (Just c')
@@ -116,6 +145,8 @@ diffStyles prev cur
116145 = mconcat
117146 [ styleDiff standout ApplyStandout RemoveStandout
118147 , styleDiff underline ApplyUnderline RemoveUnderline
148+ , styleDiff italic ApplyItalic RemoveItalic
149+ , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
119150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
120151 , styleDiff blink ApplyBlink RemoveBlink
121152 , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Error.hs+3−3
@@ -1,8 +1,8 @@
1−module Graphics.Vty.Error
2− where
1+module Graphics.Vty.Error where
32
43-- | The type of exceptions specific to vty.
54--
6−-- These have fully qualified names by default since, IMO, exception handling requires this.
5+-- These have fully qualified names by default since, IMO, exception
6+-- handling requires this.
77data VtyException
88 = VtyFailure String -- ^ Uncategorized failure specific to vty.
src/Graphics/Vty/Image.hs+200−126
@@ -1,48 +1,63 @@
11-- Copyright 2009-2010 Corey O'Connor
2−{-# LANGUAGE BangPatterns #-}
32{-# LANGUAGE NamedFieldPuns #-}
43{-# LANGUAGE DisambiguateRecordFields #-}
5−module Graphics.Vty.Image ( DisplayText
6− , Image
7− , imageWidth
8− , imageHeight
9− , horizJoin
10− , (<|>)
11− , vertJoin
12− , (<->)
13− , horizCat
14− , vertCat
15− , backgroundFill
16− , text
17− , text'
18− , char
19− , string
20− , iso10646String
21− , utf8String
22− , utf8Bytestring
23− , utf8Bytestring'
24− , charFill
25− , emptyImage
26− , safeWcwidth
27− , safeWcswidth
28− , wcwidth
29− , wcswidth
30− , crop
31− , cropRight
32− , cropLeft
33− , cropBottom
34− , cropTop
35− , pad
36− , resize
37− , resizeWidth
38− , resizeHeight
39− , translate
40− , translateX
41− , translateY
42− -- | The possible display attributes used in constructing an `Image`.
43− , module Graphics.Vty.Attributes
44− )
45− where
4+-- | A Vty program makes 'Picture's from 'Image's. This module provides
5+-- the core constructors for creating, combining, and modifying
6+-- 'Image's.
7+module Graphics.Vty.Image
8+ (
9+ -- * Images
10+ Image
11+ , imageWidth
12+ , imageHeight
13+ -- * Image constructors
14+ , emptyImage
15+ , char
16+ , string
17+ , iso10646String
18+ , utf8String
19+ , text
20+ , text'
21+ , backgroundFill
22+ , utf8Bytestring
23+ , utf8Bytestring'
24+ , charFill
25+ -- * Combinators
26+ , horizJoin
27+ , (<|>)
28+ , vertJoin
29+ , (<->)
30+ , horizCat
31+ , vertCat
32+ -- * Image modifications
33+ , crop
34+ , cropRight
35+ , cropLeft
36+ , cropBottom
37+ , cropTop
38+ , pad
39+ , resize
40+ , resizeWidth
41+ , resizeHeight
42+ , translate
43+ , translateX
44+ , translateY
45+ -- * Character width functions
46+ , safeWcwidth
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+ )
60+where
4661
4762import Graphics.Vty.Attributes
4863import Graphics.Vty.Image.Internal
@@ -56,120 +71,163 @@ import qualified Data.Text.Lazy as TL
5671import qualified Data.Text.Lazy.Encoding as TL
5772import Data.Word
5873
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+
5983infixr 5 <|>
6084infixr 4 <->
6185
62−-- | An area of the picture's bacground (See Background) of w columns and h rows.
63−backgroundFill :: Int -> Int -> Image
64−backgroundFill w h
86+-- | An area of the picture's background (See 'Background').
87+backgroundFill :: Int
88+ -- ^ Fill width in columns
89+ -> Int
90+ -- ^ Fill height in rows
91+ -> Image
92+backgroundFill w h
6593 | w == 0 = EmptyImage
6694 | h == 0 = EmptyImage
6795 | otherwise = BGFill w h
6896
69−-- | Combines two images horizontally. Alias for horizJoin
97+-- | Combines two images horizontally. This is an alias for 'horizJoin'.
7098--
7199-- infixr 5
72100(<|>) :: Image -> Image -> Image
73101(<|>) = horizJoin
74102
75−-- | Combines two images vertically. Alias for vertJoin
103+-- | Combines two images vertically. This is an alias for 'vertJoin'.
76104--
77105-- infixr 4
78106(<->) :: Image -> Image -> Image
79107(<->) = vertJoin
80108
81−-- | Compose any number of images horizontally.
109+-- | Compose any number of images together horizontally, with the first
110+-- in the list being leftmost.
82111horizCat :: [Image] -> Image
83112horizCat = foldr horizJoin EmptyImage
84113
85−-- | Compose any number of images vertically.
114+-- | Compose any number of images vertically, with the first in the list
115+-- being topmost.
86116vertCat :: [Image] -> Image
87117vertCat = foldr vertJoin EmptyImage
88118
89−-- | A Data.Text.Lazy value
119+-- | Make an 'Image' from a lazy text value. The text value should be
120+-- sanitized of escape sequences (ASCII 27) and carriage returns;
121+-- otherwise layout and attribute problems may result.
90122text :: Attr -> TL.Text -> Image
91−text a txt
92− | TL.length txt == 0 = EmptyImage
93− | otherwise = let displayWidth = safeWcswidth (TL.unpack txt)
94− in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
123+text a txt = let displayWidth = safeWctlwidth txt
124+ in HorizText a txt displayWidth (fromIntegral $! TL.length txt)
95125
96−-- | A Data.Text value
126+-- | Make an 'Image' from a text value. The text value should be
127+-- sanitized of escape sequences (ASCII 27) and carriage returns;
128+-- otherwise layout and attribute problems may result.
97129text' :: Attr -> T.Text -> Image
98−text' a txt
99− | T.length txt == 0 = EmptyImage
100− | otherwise = let displayWidth = safeWcswidth (T.unpack txt)
101− in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
130+text' a txt = let displayWidth = safeWctwidth txt
131+ in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)
102132
103−-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in
104−-- the ISO-10646 encoding.
133+-- | Make an image from a single character. This is a standard Haskell
134+-- 31-bit character assumed to be in the ISO-10646 encoding.
105135char :: Attr -> Char -> Image
106136char a c =
107137 let displayWidth = safeWcwidth c
108138 in HorizText a (TL.singleton c) displayWidth 1
109139
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.
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.
112145--
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 iso10646String or string.
118−--
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.
119152iso10646String :: Attr -> String -> Image
120−iso10646String _ [] = EmptyImage
121153iso10646String a str =
122154 let displayWidth = safeWcswidth str
123155 in HorizText a (TL.pack str) displayWidth (length str)
124156
125−-- | Alias for iso10646String. Since the usual case is that a literal string like "foo" is
126−-- represented internally as a list of ISO 10646 31 bit characters.
157+-- | Make an 'Image' from a 'String'.
127158--
128−-- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while
129−-- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime
130−-- representation.
159+-- This is an alias for iso10646String since the usual case is that a
160+-- literal string like "foo" is represented internally as a list of ISO
161+-- 10646 31 bit characters.
162+--
163+-- Note: Keep in mind that GHC will compile source encoded as UTF-8
164+-- but the literal strings, while UTF-8 encoded in the source, will be
165+-- transcoded to a ISO 10646 31 bit characters runtime representation.
131166string :: Attr -> String -> Image
132167string = iso10646String
133168
134−-- | A string of characters layed out on a single row. The input is assumed to be the bytes for
135−-- UTF-8 encoded text.
169+-- | Make an 'Image' from a string of characters layed out on a single
170+-- row. The input is assumed to be the bytes for UTF-8 encoded text.
136171utf8String :: Attr -> [Word8] -> Image
137172utf8String a bytes = utf8Bytestring a (BL.pack bytes)
138173
139−-- | Renders a UTF-8 encoded lazy bytestring.
174+-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.
140175utf8Bytestring :: Attr -> BL.ByteString -> Image
141176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
142177
143−-- | Renders a UTF-8 encoded strict bytestring.
178+-- | Make an 'Image' from a UTF-8 encoded strict bytestring.
144179utf8Bytestring' :: Attr -> B.ByteString -> Image
145180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
146181
147−-- | creates a fill of the specified character. The dimensions are in number of characters wide and
148−-- number of rows high.
149−charFill :: Integral d => Attr -> Char -> d -> d -> Image
150−charFill _a _c 0 _h = EmptyImage
151−charFill _a _c _w 0 = EmptyImage
152−charFill a c w h =
153− vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth
154− where
155− txt = TL.replicate (fromIntegral w) (TL.singleton c)
156− displayWidth = safeWcwidth c * (fromIntegral w)
157− charWidth = fromIntegral w
158−
159−-- | The empty image. Useful for fold combinators. These occupy no space nor define any display
160−-- attributes.
161−emptyImage :: Image
182+-- | Make an image filling a region with the specified character.
183+--
184+-- If either the width or height are less than or equal to 0, then
185+-- the result is the empty image.
186+charFill :: Integral d
187+ => Attr
188+ -- ^ The attribute to use.
189+ -> Char
190+ -- ^ The character to use in filling the region.
191+ -> d
192+ -- ^ The region width.
193+ -> d
194+ -- ^ The region height.
195+ -> Image
196+charFill a c w h
197+ | w <= 0 || h <= 0 = EmptyImage
198+ | otherwise = vertCat
199+ $ replicate (fromIntegral h)
200+ $ HorizText a txt displayWidth charWidth
201+ where
202+ txt = TL.replicate charWidth (TL.singleton c)
203+ displayWidth = safeWcwidth c * charWidth
204+
205+ charWidth :: Num a => a
206+ charWidth = fromIntegral w
207+
208+-- | The empty image. Useful for fold combinators. These occupy no space
209+-- and do not affect display attributes.
210+emptyImage :: Image
162211emptyImage = EmptyImage
163212
164−-- | pad the given image. This adds background character fills to the left, top, right, bottom.
165−-- The pad values are how many display columns or rows to add.
166−pad :: Int -> Int -> Int -> Int -> Image -> Image
213+-- | Pad the given image. This adds background character fills to the
214+-- left, top, right, bottom.
215+pad :: Int
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
167226pad 0 0 0 0 i = i
168227pad inL inT inR inB inImage
169228 | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
170229 | otherwise = go inL inT inR inB inImage
171− where
172− -- TODO: uh.
230+ where
173231 go 0 0 0 0 i = i
174232 go 0 0 0 b i = VertJoin i (BGFill w b) w h
175233 where w = imageWidth i
@@ -184,40 +242,53 @@ pad inL inT inR inB inImage
184242 where w = imageWidth i + l
185243 h = imageHeight i
186244
187−-- | translates an image by padding or cropping the left and top. First param is amount to translate
188−-- left. Second param is amount to translate top.
245+-- | Translates an image by padding or cropping the left and top.
189246--
190−-- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than
191−-- (0,0) will crop the image.
192−translate :: Int -> Int -> Image -> Image
247+-- If translation offsets are negative then the image is cropped.
248+translate :: Int
249+ -- ^ The horizontal translation offset (can be negative)
250+ -> Int
251+ -- ^ The vertical translation offset (can be negative)
252+ -> Image
253+ -- ^ The image to translate.
254+ -> Image
193255translate x y i = translateX x (translateY y i)
194256
195−-- | translates an image by padding or cropping the left
257+-- | Translates an image by padding or cropping its left side.
196258translateX :: Int -> Image -> Image
197259translateX x i
260+ | x < 0 && (abs x > imageWidth i) = emptyImage
198261 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)
199262 | x == 0 = i
200263 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h
201264
202−-- | translates an image by padding or cropping the top
265+-- | Translates an image by padding or cropping its top.
203266translateY :: Int -> Image -> Image
204267translateY y i
268+ | y < 0 && (abs y > imageHeight i) = emptyImage
205269 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)
206270 | y == 0 = i
207271 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)
208272
209−-- | Ensure an image is no larger than the provided size. If the image is larger then crop the right
210−-- or bottom.
273+-- | Ensure an image is no larger than the provided size. If the image
274+-- is larger then crop the right or bottom.
211275--
212−-- This is transformed to a vertical crop from the bottom followed by horizontal crop from the
213−-- right.
214−crop :: Int -> Int -> Image -> Image
276+-- This is equivalent to a vertical crop from the bottom followed by
277+-- horizontal crop from the right.
278+crop :: Int
279+ -- ^ Cropping width
280+ -> Int
281+ -- ^ Cropping height
282+ -> Image
283+ -- ^ The image to crop
284+ -> Image
215285crop 0 _ _ = EmptyImage
216286crop _ 0 _ = EmptyImage
217287crop w h i = cropBottom h (cropRight w i)
218288
219−-- | crop the display height. If the image is less than or equal in height then this operation has
220−-- no effect. Otherwise the image is cropped from the bottom.
289+-- | Crop an image's height. If the image's height is less than or equal
290+-- to the specified height then this operation has no effect. Otherwise
291+-- the image is cropped from the bottom.
221292cropBottom :: Int -> Image -> Image
222293cropBottom 0 _ = EmptyImage
223294cropBottom h inI
@@ -232,8 +303,9 @@ cropBottom h inI
232303 | h >= imageHeight i = i
233304 | otherwise = CropBottom i (imageWidth i) h
234305
235−-- | ensure the image is no wider than the given width. If the image is wider then crop the right
236−-- side.
306+-- | Crop an image's width. If the image's width is less than or equal
307+-- to the specified width then this operation has no effect. Otherwise
308+-- the image is cropped from the right.
237309cropRight :: Int -> Image -> Image
238310cropRight 0 _ = EmptyImage
239311cropRight w inI
@@ -248,8 +320,9 @@ cropRight w inI
248320 | w >= imageWidth i = i
249321 | otherwise = CropRight i w (imageHeight i)
250322
251−-- | ensure the image is no wider than the given width. If the image is wider then crop the left
252−-- side.
323+-- | Crop an image's width. If the image's width is less than or equal
324+-- to the specified width then this operation has no effect. Otherwise
325+-- the image is cropped from the left.
253326cropLeft :: Int -> Image -> Image
254327cropLeft 0 _ = EmptyImage
255328cropLeft w inI
@@ -266,8 +339,9 @@ cropLeft w inI
266339 | imageWidth i <= w = i
267340 | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)
268341
269−-- | crop the display height. If the image is less than or equal in height then this operation has
270−-- no effect. Otherwise the image is cropped from the top.
342+-- | Crop an image's height. If the image's height is less than or equal
343+-- to the specified height then this operation has no effect. Otherwise
344+-- the image is cropped from the top.
271345cropTop :: Int -> Image -> Image
272346cropTop 0 _ = EmptyImage
273347cropTop h inI
@@ -284,24 +358,24 @@ cropTop h inI
284358 | imageHeight i <= h = i
285359 | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h
286360
287−-- | Generic resize. Pads and crops as required to assure the given display width and height.
288−-- This is biased to pad/crop the right and bottom.
361+-- | Generic resize. Pads and crops are added to ensure that the
362+-- resulting image matches the specified dimensions. This is biased to
363+-- pad/crop the right and bottom.
289364resize :: Int -> Int -> Image -> Image
290365resize w h i = resizeHeight h (resizeWidth w i)
291366
292−-- | Resize the width. Pads and crops as required to assure the given display width.
293−-- This is biased to pad/crop the right.
367+-- | Resize the width. Pads and crops as required to assure the given
368+-- display width. This is biased to pad/crop on the right.
294369resizeWidth :: Int -> Image -> Image
295370resizeWidth w i = case w `compare` imageWidth i of
296371 LT -> cropRight w i
297372 EQ -> i
298373 GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)
299374
300−-- | Resize the height. Pads and crops as required to assure the given display height.
301−-- This is biased to pad/crop the bottom.
375+-- | Resize the height. Pads and crops as required to assure the given
376+-- display height. This is biased to pad/crop on the bottom.
302377resizeHeight :: Int -> Image -> Image
303378resizeHeight h i = case h `compare` imageHeight i of
304379 LT -> cropBottom h i
305380 EQ -> i
306381 GT -> i <-> BGFill (imageWidth i) (h - imageHeight i)
307−
src/Graphics/Vty/Image/Internal.hs+81−98
@@ -1,36 +1,25 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE NamedFieldPuns #-}
3+{-# LANGUAGE DeriveGeneric #-}
34{-# OPTIONS_HADDOCK hide #-}
45
5−#ifndef MIN_VERSION_base
6−#defined MIN_VERSION_base(x,y,z) 1
7−#endif
8−
96module Graphics.Vty.Image.Internal where
107
118import Graphics.Vty.Attributes
129import Graphics.Text.Width
1310
14−import Control.DeepSeq
11+import GHC.Generics
1512
16−import qualified Data.Text.Lazy as TL
13+import Control.DeepSeq
1714
18−#if !(MIN_VERSION_base(4,8,0))
19−import Data.Monoid
15+#if !(MIN_VERSION_base(4,11,0))
16+import Data.Semigroup (Semigroup(..))
2017#endif
18+import qualified Data.Text.Lazy as TL
2119
2220-- | A display text is a Data.Text.Lazy
23−--
24−-- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each
25−-- application probably uses a single type. Perhaps parameterize the entire vty interface by the
26−-- input text type?
27−-- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance
28−-- for the usual case of appending a bunch of characters with the same attribute together.
2921type DisplayText = TL.Text
3022
31−-- TODO: store a skip list in HorizText(?)
32−-- TODO: represent display strings containing chars that are not 1 column chars as a separate
33−-- display string value?
3423clipText :: DisplayText -> Int -> Int -> DisplayText
3524clipText txt leftSkip rightClip =
3625 -- CPS would clarify this I think
@@ -38,18 +27,18 @@ clipText txt leftSkip rightClip =
3827 txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt
3928 (toTake,padSuffix) = clipForCharWidth rightClip txt' 0
4029 txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)
41− clipForCharWidth 0 _ n = (n, False)
30+ -- Note: some characters and zero-width and combining characters
31+ -- combine to the left, so keep taking characters even if the
32+ -- width is zero.
4233 clipForCharWidth w t n
4334 | TL.null t = (n, False)
44− | w < cw = (n, True)
45− | w == cw = (n+1, False)
46− | w > cw = clipForCharWidth (w - cw) (TL.tail t) (n + 1)
35+ | w < cw = (n, w /= 0)
36+ | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1)
4737 where cw = safeWcwidth (TL.head t)
48− clipForCharWidth _ _ _ = error "clipForCharWidth applied to undefined"
4938 in txt''
5039
51−-- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to
52−-- create instances.
40+-- | This is the internal representation of Images. Use the constructors
41+-- in "Graphics.Vty.Image" to create instances.
5342--
5443-- Images are:
5544--
@@ -62,49 +51,61 @@ clipText txt leftSkip rightClip =
6251-- * a cropped image
6352--
6453-- * an empty image of no size or content.
65−data Image =
66− -- | A horizontal text span is always >= 1 column and has a row height of 1.
54+data Image =
55+ -- | A horizontal text span has a row height of 1.
6756 HorizText
6857 { attr :: Attr
69− -- | The text to display. The display width of the text is always outputWidth.
58+ -- | The text to display. The display width of the text is always
59+ -- outputWidth.
7060 , displayText :: DisplayText
71− -- | The number of display columns for the text. Always > 0.
61+ -- | The number of display columns for the text.
7262 , outputWidth :: Int
73− -- | the number of characters in the text. Always > 0.
63+ -- | the number of characters in the text.
7464 , charWidth :: Int
7565 }
76− -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is
77− -- required to be between two images of equal height. The horizJoin constructor adds background
78− -- fills to the provided images that assure this is true for the HorizJoin value produced.
66+ -- | A horizontal join can be constructed between any two images.
67+ -- However a HorizJoin instance is required to be between two images
68+ -- of equal height. The horizJoin constructor adds background fills
69+ -- to the provided images that assure this is true for the HorizJoin
70+ -- value produced.
7971 | HorizJoin
80− { partLeft :: Image
72+ { partLeft :: Image
8173 , partRight :: Image
82− , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 1
83− , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0
74+ , outputWidth :: Int
75+ -- ^ imageWidth partLeft == imageWidth partRight. Always > 0
76+ , outputHeight :: Int
77+ -- ^ imageHeight partLeft == imageHeight partRight. Always > 0
8478 }
85− -- | A veritical join can be constructed between any two images. However a VertJoin instance is
86− -- required to be between two images of equal width. The vertJoin constructor adds background
87− -- fills to the provides images that assure this is true for the VertJoin value produced.
79+ -- | A veritical join can be constructed between any two images.
80+ -- However a VertJoin instance is required to be between two images
81+ -- of equal width. The vertJoin constructor adds background fills
82+ -- to the provides images that assure this is true for the VertJoin
83+ -- value produced.
8884 | VertJoin
8985 { partTop :: Image
9086 , partBottom :: Image
91− , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0
92− , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1
87+ , outputWidth :: Int
88+ -- ^ imageWidth partTop == imageWidth partBottom. always > 0
89+ , outputHeight :: Int
90+ -- ^ imageHeight partTop == imageHeight partBottom. always > 1
9391 }
94− -- | A background fill will be filled with the background char. The background char is
95− -- defined as a property of the Picture this Image is used to form.
92+ -- | A background fill will be filled with the background char. The
93+ -- background char is defined as a property of the Picture this
94+ -- Image is used to form.
9695 | BGFill
9796 { outputWidth :: Int -- ^ always > 0
9897 , outputHeight :: Int -- ^ always > 0
9998 }
100− -- | Crop an image horizontally to a size by reducing the size from the right.
99+ -- | Crop an image horizontally to a size by reducing the size from
100+ -- the right.
101101 | CropRight
102102 { croppedImage :: Image
103103 -- | Always < imageWidth croppedImage > 0
104104 , outputWidth :: Int
105105 , outputHeight :: Int -- ^ imageHeight croppedImage
106106 }
107− -- | Crop an image horizontally to a size by reducing the size from the left.
107+ -- | Crop an image horizontally to a size by reducing the size from
108+ -- the left.
108109 | CropLeft
109110 { croppedImage :: Image
110111 -- | Always < imageWidth croppedImage > 0
@@ -113,7 +114,8 @@ data Image =
113114 , outputWidth :: Int
114115 , outputHeight :: Int
115116 }
116− -- | Crop an image vertically to a size by reducing the size from the bottom
117+ -- | Crop an image vertically to a size by reducing the size from
118+ -- the bottom
117119 | CropBottom
118120 { croppedImage :: Image
119121 -- | imageWidth croppedImage
@@ -121,7 +123,8 @@ data Image =
121123 -- | height image is cropped to. Always < imageHeight croppedImage > 0
122124 , outputHeight :: Int
123125 }
124− -- | Crop an image vertically to a size by reducing the size from the top
126+ -- | Crop an image vertically to a size by reducing the size from
127+ -- the top
125128 | CropTop
126129 { croppedImage :: Image
127130 -- | Always < imageHeight croppedImage > 0
@@ -133,43 +136,17 @@ data Image =
133136 }
134137 -- | The empty image
135138 --
136− -- The combining operators identity constant.
139+ -- The combining operators identity constant.
137140 -- EmptyImage <|> a = a
138141 -- EmptyImage <-> a = a
139− --
142+ --
140143 -- Any image of zero size equals the empty image.
141144 | EmptyImage
142− deriving Eq
143−
144−instance Show Image where
145− show ( HorizText { attr, displayText, outputWidth, charWidth } )
146− = "HorizText " ++ show displayText
147− ++ "@(" ++ show attr ++ ","
148− ++ show outputWidth ++ ","
149− ++ show charWidth ++ ")"
150− show ( BGFill { outputWidth, outputHeight } )
151− = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"
152− show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )
153− = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
154− show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )
155− = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
156− show ( CropRight { croppedImage, outputWidth, outputHeight } )
157− = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
158− ++ " (" ++ show croppedImage ++ ")"
159− show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )
160− = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
161− ++ " (" ++ show croppedImage ++ ")"
162− show ( CropBottom { croppedImage, outputWidth, outputHeight } )
163− = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
164− ++ " (" ++ show croppedImage ++ ")"
165− show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )
166− = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"
167− ++ " (" ++ show croppedImage ++ ")"
168− show ( EmptyImage ) = "EmptyImage"
145+ deriving (Eq, Generic, Show, Read)
169146
170147-- | pretty print just the structure of an image.
171148ppImageStructure :: Image -> String
172−ppImageStructure inImg = go 0 inImg
149+ppImageStructure = go 0
173150 where
174151 go indent img = tab indent ++ pp indent img
175152 tab indent = concat $ replicate indent " "
@@ -195,7 +172,7 @@ ppImageStructure inImg = go 0 inImg
195172 = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n"
196173 ++ go (i+1) croppedImage
197174 pp _ EmptyImage = "EmptyImage"
198−
175+
199176instance NFData Image where
200177 rnf EmptyImage = ()
201178 rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()
@@ -207,7 +184,8 @@ instance NFData Image where
207184 rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()
208185 rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()
209186
210−-- | The width of an Image. This is the number display columns the image will occupy.
187+-- | The width of an Image. This is the number display columns the image
188+-- will occupy.
211189imageWidth :: Image -> Int
212190imageWidth HorizText { outputWidth = w } = w
213191imageWidth HorizJoin { outputWidth = w } = w
@@ -219,7 +197,8 @@ imageWidth CropBottom { outputWidth = w } = w
219197imageWidth CropTop { outputWidth = w } = w
220198imageWidth EmptyImage = 0
221199
222−-- | The height of an Image. This is the number of display rows the image will occupy.
200+-- | The height of an Image. This is the number of display rows the
201+-- image will occupy.
223202imageHeight :: Image -> Int
224203imageHeight HorizText {} = 1
225204imageHeight HorizJoin { outputHeight = h } = h
@@ -231,27 +210,32 @@ imageHeight CropBottom { outputHeight = h } = h
231210imageHeight CropTop { outputHeight = h } = h
232211imageHeight EmptyImage = 0
233212
234−-- | Append in the Monoid instance is equivalent to <->.
213+-- | Append in the 'Semigroup' instance is equivalent to '<->'.
214+instance Semigroup Image where
215+ (<>) = vertJoin
216+
217+-- | Append in the 'Monoid' instance is equivalent to '<->'.
235218instance Monoid Image where
236219 mempty = EmptyImage
237− mappend = vertJoin
220+#if !(MIN_VERSION_base(4,11,0))
221+ mappend = (<>)
222+#endif
238223
239224-- | combines two images side by side
240225--
241−-- Combines text chunks where possible. Assures outputWidth and outputHeight properties are not
242−-- violated.
243−--
244−-- The result image will have a width equal to the sum of the two images width. And the height will
245−-- equal the largest height of the two images. The area not defined in one image due to a height
246−-- missmatch will be filled with the background pattern.
226+-- Combines text chunks where possible. Assures outputWidth and
227+-- outputHeight properties are not violated.
247228--
248−-- TODO: the bg fill is biased towards top to bottom languages(?)
229+-- The result image will have a width equal to the sum of the two images
230+-- width. And the height will equal the largest height of the two
231+-- images. The area not defined in one image due to a height mismatch
232+-- will be filled with the background pattern.
249233horizJoin :: Image -> Image -> Image
250234horizJoin EmptyImage i = i
251235horizJoin i EmptyImage = i
252236horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)
253237 | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)
254− -- TODO: assumes horiz text height is always 1
238+ -- assumes horiz text height is always 1
255239 | otherwise = HorizJoin i0 i1 (w0 + w1) 1
256240horizJoin i0 i1
257241 -- If the images are of the same height then no padding is required
@@ -273,19 +257,19 @@ horizJoin _ _ = error "horizJoin applied to undefined values."
273257
274258-- | combines two images vertically
275259--
276−-- The result image will have a height equal to the sum of the heights of both images.
277−-- The width will equal the largest width of the two images.
278−-- The area not defined in one image due to a width missmatch will be filled with the background
279−-- pattern.
280−--
281−-- TODO: the bg fill is biased towards right to left languages(?)
260+-- The result image will have a height equal to the sum of the heights
261+-- of both images. The width will equal the largest width of the two
262+-- images. The area not defined in one image due to a width mismatch
263+-- will be filled with the background pattern.
282264vertJoin :: Image -> Image -> Image
283265vertJoin EmptyImage i = i
284266vertJoin i EmptyImage = i
285267vertJoin i0 i1
286− -- If the images are of the same width then no background padding is required
268+ -- If the images are of the same width then no background padding is
269+ -- required
287270 | w0 == w1 = VertJoin i0 i1 w0 h
288− -- Otherwise one of the images needs to be padded to the size of the other image.
271+ -- Otherwise one of the images needs to be padded to the size of the
272+ -- other image.
289273 | w0 < w1
290274 = let padAmount = w1 - w0
291275 in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h
@@ -299,4 +283,3 @@ vertJoin i0 i1
299283 h1 = imageHeight i1
300284 h = h0 + h1
301285vertJoin _ _ = error "vertJoin applied to undefined values."
302−
src/Graphics/Vty/Inline.hs+62−55
@@ -1,45 +1,41 @@
1−-- | The inline module provides a limited interface to changing the style of terminal output. The
2−-- intention is for this interface to be used inline with other output systems.
1+-- | The inline module provides a limited interface to changing the
2+-- style of terminal output. The intention is for this interface to be
3+-- used inline with other output systems.
34--
4−-- The changes specified by the InlineM monad are applied to the terminals display attributes. These
5−-- display attributes effect the display of all following text output to the terminal file
6−-- descriptor.
5+-- The changes specified by the InlineM monad are applied to the
6+-- terminal's display attributes. These display attributes affect the
7+-- display of all following text output to the terminal file descriptor.
78--
8−-- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the
9−-- text \" Styled! \" drawn over a red background and underlined.
9+-- For example, in an IO monad the following code will print the text
10+-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
11+-- background and underlined.
1012--
1113-- @
1214-- putStr \"Not styled. \"
1315-- putAttrChange_ $ do
14−-- backColor red
16+-- backColor red
1517-- applyStyle underline
1618-- putStr \" Styled! \"
1719-- putAttrChange_ $ defaultAll
1820-- putStrLn \"Not styled.\"
1921-- @
2022--
21−-- 'putAttrChange' outputs the control codes to the terminal device 'Handle'. This is a duplicate
22−-- of the 'stdout' handle when the 'terminalHandle' was (first) acquired. If 'stdout' has since been
23−-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than
24−-- 'putAttrChange'
23+-- 'putAttrChange' emits the control codes to the terminal device
24+-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when
25+-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been
26+-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a
27+-- different 'Handle' than 'putAttrChange'.
2528--
2629-- Copyright 2009-2010 Corey O'Connor
27−{-# LANGUAGE CPP #-}
28−{-# LANGUAGE BangPatterns #-}
29−
30−#ifndef MIN_VERSION_base
31−#defined MIN_VERSION_base(x,y,z) 1
32−#endif
33−
34−module Graphics.Vty.Inline ( module Graphics.Vty.Inline
35− , withVty
36− )
37− where
30+module Graphics.Vty.Inline
31+ ( module Graphics.Vty.Inline
32+ , withVty
33+ )
34+where
3835
3936import Graphics.Vty
4037import Graphics.Vty.DisplayAttributes
4138import Graphics.Vty.Inline.Unsafe
42−import Graphics.Vty.Output.Interface
4339
4440import Blaze.ByteString.Builder (writeToByteString)
4541
@@ -50,44 +46,55 @@ import Data.IORef
5046
5147import System.IO
5248
53−#if !(MIN_VERSION_base(4,8,0))
54−import Control.Applicative
55−import Data.Monoid ( mappend )
56−#endif
49+type InlineM v = State InlineState v
5750
58−type InlineM v = State Attr v
51+data InlineState =
52+ InlineState { inlineAttr :: Attr
53+ , inlineUrlsEnabled :: Bool
54+ }
5955
60−-- | Set the background color to the provided 'Color'
56+-- | Set the background color to the provided 'Color'.
6157backColor :: Color -> InlineM ()
62−backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )
58+backColor c = modify $ \s ->
59+ s { inlineAttr = inlineAttr s `withBackColor` c
60+ }
6361
64−-- | Set the foreground color to the provided 'Color'
62+-- | Set the foreground color to the provided 'Color'.
6563foreColor :: Color -> InlineM ()
66−foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )
64+foreColor c = modify $ \s ->
65+ s { inlineAttr = inlineAttr s `withForeColor` c
66+ }
6767
68−-- | Attempt to change the 'Style' of the following text.
68+-- | Attempt to change the 'Style' of the following text..
6969--
70−-- If the terminal does not support the style change no error is produced. The style can still be
71−-- removed.
70+-- If the terminal does not support the style change then no error is
71+-- produced. The style can still be removed.
7272applyStyle :: Style -> InlineM ()
73−applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
73+applyStyle st = modify $ \s ->
74+ s { inlineAttr = inlineAttr s `withStyle` st
75+ }
7476
75−-- | Attempt to remove the specified 'Style' from the display of the following text.
77+-- | Attempt to remove the specified 'Style' from the display of the
78+-- following text.
7679--
77−-- This will fail if applyStyle for the given style has not been previously called.
80+-- This will fail if 'applyStyle' for the given style has not been
81+-- previously called.
7882removeStyle :: Style -> InlineM ()
79−removeStyle sMask = modify $ \attr ->
80− let style' = case attrStyle attr of
81− Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
82− KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
83− SetTo s -> s .&. complement sMask
84− in attr { attrStyle = SetTo style' }
85−
86−-- | Reset the display attributes
83+removeStyle sMask = modify $ \s ->
84+ s { inlineAttr =
85+ let style' = case attrStyle (inlineAttr s) of
86+ Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
87+ KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
88+ SetTo st -> st .&. complement sMask
89+ in (inlineAttr s) { attrStyle = SetTo style' }
90+ }
91+
92+-- | Reset the display attributes.
8793defaultAll :: InlineM ()
88−defaultAll = put defAttr
94+defaultAll = modify $ \s -> s { inlineAttr = defAttr }
8995
90−-- | Apply the provided display attribute changes to the given terminal output device.
96+-- | Apply the provided display attribute changes to the given terminal
97+-- output device.
9198--
9299-- This does not flush the terminal.
93100putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()
@@ -97,19 +104,19 @@ putAttrChange out c = liftIO $ do
97104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
98105 fattr <- case mfattr of
99106 Nothing -> do
100− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
101− return $ FixedAttr defaultStyleMask Nothing Nothing
107+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
108+ return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
102109 Just v -> return v
103− let attr = execState c currentAttr
110+ let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
104111 attr' = limitAttrForDisplay out attr
105112 fattr' = fixDisplayAttr fattr attr'
106113 diffs = displayAttrDiffs fattr fattr'
107− outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
114+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
108115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
109116 inlineHack dc
110117
111−-- | Apply the provided display attributes changes to the terminal output device that was current at
112−-- the time this was first used. Which, for most use cases, is the current terminal.
118+-- | Apply the provided display attributes changes to the terminal
119+-- output device.
113120--
114121-- This will flush the terminal output.
115122putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
src/Graphics/Vty/Inline/Unsafe.hs+4−14
@@ -1,16 +1,9 @@
1−{-# LANGUAGE CPP #-}
21{-# OPTIONS_HADDOCK hide #-}
32
4−#ifndef MIN_VERSION_base
5−#defined MIN_VERSION_base(x,y,z) 1
6−#endif
7−
83module Graphics.Vty.Inline.Unsafe where
94
105import Graphics.Vty
116
12−import Data.Default
13−import Data.Monoid
147import Data.IORef
158
169import GHC.IO.Handle (hDuplicate)
@@ -21,10 +14,6 @@ import System.IO.Unsafe
2114
2215import System.Posix.IO (handleToFd)
2316
24−#if !(MIN_VERSION_base(4,8,0))
25−import Control.Applicative
26−#endif
27−
2817globalVty :: IORef (Maybe Vty)
2918{-# NOINLINE globalVty #-}
3019globalVty = unsafePerformIO $ newIORef Nothing
@@ -39,10 +28,11 @@ mkDupeConfig = do
3928 hSetBuffering stdin NoBuffering
4029 stdinDupe <- hDuplicate stdin >>= handleToFd
4130 stdoutDupe <- hDuplicate stdout >>= handleToFd
42− return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
31+ return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }
4332
44−-- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.
45−-- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'.
33+-- | This will create a Vty instance using 'mkVty' and execute an IO
34+-- action provided that instance. The created Vty instance will be
35+-- stored to the unsafe 'IORef' 'globalVty'.
4636--
4737-- This instance will use duplicates of the stdin and stdout Handles.
4838withVty :: (Vty -> IO b) -> IO b
src/Graphics/Vty/Input.hs+97−127
@@ -1,135 +1,125 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, CPP #-}
32
4−#ifndef MIN_VERSION_base
5−#defined MIN_VERSION_base(x,y,z) 1
6−#endif
7−
8−-- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can
9−-- then be used to read 'Event's from the terminal.
10−--
11−-- The history of terminals has resulted in a broken input process. Some keys and combinations will
12−-- not reliably map to the expected events by any terminal program. Even those not using vty. There
13−-- is no 1:1 mapping from key events to bytes read from the terminal input device. In very limited
14−-- cases the terminal and vty's input process can be customized to resolve these issues.
15−--
16−-- See "Graphics.Vty.Config" for how to configure vty's input processing. Customizing terminfo and
17−-- the terminal is beyond the scope of this documentation.
3+-- | This module provides the input layer for Vty, including methods
4+-- for initializing an 'Input' structure and reading 'Event's from the
5+-- 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.
1814--
1915-- = VTY's Implementation
2016--
21−-- One can get the brain rot trying to understand all this. So, as far as I can care...
22−--
2317-- There are two input modes:
2418--
25−-- 1. 7 bit
19+-- 1. 7-bit
2620--
27−-- 2. 8 bit
21+-- 2. 8-bit
2822--
29−-- 7 bit input is the default and the expected in most use cases. This is what vty uses.
23+-- The 7-bit input mode is the default and the expected mode in most use
24+-- cases. This is what Vty uses.
3025--
31−-- == 7 bit input encoding
26+-- == 7-bit input encoding
3227--
33−-- Control key combinations are represented by masking the two high bits of the 7bit input. Back in
34−-- the day the control key actually grounded the two high bit wires: 6 and 7. This is why
35−-- control key combos map to single character events: The input bytes are identical. The input byte
36−-- is the bit encoding of the character with bits 6 and 7 masked. Bit 6 is set by shift. Bit 6 and
37−-- 7 are masked by control. EG:
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,
3835--
39−-- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become `00001001`. Which is the ASCII
40−-- and UTF-8 encoding of the tab key.
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.
4138--
42−-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero which makes `0000011` and
43−-- is the "End of Text" code.
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.
4441--
45−-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This is the value 1 with bit 7
46−-- set and 6 unset.
42+-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this
43+-- is the value 1 with bit 7 set and 6 unset.
4744--
48−-- * Hypothesis: Bit 6 is unset by upper case letters because, initially, there were only upper case
49−-- letters used and a 5 bit encoding.
45+-- * Hypothesis: Bit 6 is unset by upper case letters because,
46+-- initially, there were only upper case letters used and a 5 bit
47+-- encoding.
5048--
51−-- == 8 bit encoding
49+-- == 8-bit encoding
5250--
53−-- The 8th bit was originally used for parity checking. Useless for emulators. Some terminal
54−-- emulators support a 8 bit input encoding. While this provides some advantages the actual usage is
55−-- low. Most systems use 7bit mode but recognize 8bit control characters when escaped. This is what
56−-- vty does.
51+-- The 8th bit was originally used for parity checking which is useless
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.
5756--
5857-- == Escaped Control Keys
5958--
60−-- Using 7 bit input encoding the @ESC@ byte can signal the start of an encoded control key. To
61−-- differentiate a single @ESC@ eventfrom a control key the timing of the input is used.
59+-- Using 7-bit input encoding, the @ESC@ byte can signal the start of
60+-- an encoded control key. To differentiate a single @ESC@ event from a
61+-- control key, the timing of the input is used.
6262--
63−-- 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'.
63+-- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of
64+-- 'VMIN' milliseconds.
6465--
65−-- 2. control keys that contain @ESC@ in their encoding: The @ESC byte; followed by more bytes read
66−-- within 'singleEscPeriod'. All bytes up until the next valid input block are passed to the
67−-- classifier.
66+-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte
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.
6869--
69−-- If the current runtime is the threaded runtime then the terminal's @VMIN@ and @VTIME@ behavior
70−-- reliably implement the above rules. If the current runtime does not support forkOS then there is
71−-- currently no implementation.
72−--
73−-- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop which did tricky things with
74−-- non-blocking reads and timers. The implementation was not reliable. A reliable implementation is
75−-- possible, but there are no plans to implement this.
70+-- If the current runtime is the threaded runtime then the terminal's
71+-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
72+-- the current runtime does not support 'forkOS' then there is currently
73+-- no implementation.
7674--
7775-- == Unicode Input and Escaped Control Key Sequences
7876--
79−-- The input encoding determines how UTF-8 encoded characters are recognize.
77+-- The input encoding determines how UTF-8 encoded characters are
78+-- recognized.
8079--
81−-- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is a superset of ASCII. UTF-8 does
82−-- not overlap escaped control key sequences. However, the escape key must be differentiated from
80+-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
81+-- a superset of ASCII. UTF-8 does not overlap escaped control key
82+-- sequences. However, the escape key must be differentiated from
8383-- escaped control key sequences by the timing of the input bytes.
8484--
85−-- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not require using the timing of
86−-- input bytes to differentiate the escape key. Many terminals do not support 8 bit mode.
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.
8788--
8889-- == Terminfo
8990--
90−-- The terminfo system is used to determine how some keys are encoded. Terminfo is incomplete. In
91−-- some cases terminfo is incorrect. Vty assumes terminfo is correct but provides a mechanism to
92−-- override terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'.
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'.
9395--
9496-- == Terminal Input is Broken
9597--
96−-- Clearly terminal input has fundemental issues. There is no easy way to reliably resolve these
97−-- issues.
98−--
99−-- One resolution would be to ditch standard terminal interfaces entirely and just go directly to
100−-- scancodes. A reasonable option for vty if everybody used the linux kernel console. I hear GUIs
101−-- are popular these days. Sadly, GUI terminal emulators don't provide access to scancodes AFAIK.
102−--
103−-- All is lost? Not really. "Graphics.Vty.Config" supports customizing the input byte to event
104−-- mapping and xterm supports customizing the scancode to input byte mapping. With a lot of work a
105−-- user's system can be set up to encode all the key combos in an almost-sane manner.
106−--
107−-- There are other tricky work arounds that can be done. I have no interest in implementing most of
108−-- these. They are not really worth the time.
98+-- Clearly terminal input has fundamental issues. There is no easy way
99+-- to reliably resolve these issues.
109100--
110−-- == Terminal Output is Also Broken
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.
111105--
112−-- This isn't the only odd aspect of terminals due to historical aspects that no longer apply. EG:
113−-- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes
114−-- the control sequence to output red, for instance) This is to account for the slow speed of
115−-- hardcopy teletype interfaces. Cause, uh, we totally still use those.
116−--
117−-- The output encoding of colors and attributes are also rife with issues.
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.
118110--
119111-- == See also
120112--
121113-- * http://www.leonerd.org.uk/hacks/fixterms/
122−--
123−-- In my experience this cannot resolve the issues without changes to the terminal emulator and
124−-- device.
125−module Graphics.Vty.Input ( Key(..)
126− , Modifier(..)
127− , Button(..)
128− , Event(..)
129− , Input(..)
130− , inputForConfig
131− )
132− where
114+module Graphics.Vty.Input
115+ ( Key(..)
116+ , Modifier(..)
117+ , Button(..)
118+ , Event(..)
119+ , Input(..)
120+ , inputForConfig
121+ )
122+where
133123
134124import Graphics.Vty.Config
135125import Graphics.Vty.Input.Events
@@ -142,42 +132,19 @@ import Lens.Micro
142132import qualified System.Console.Terminfo as Terminfo
143133import System.Posix.Signals.Exts
144134
145−#if !(MIN_VERSION_base(4,8,0))
146−import Data.Functor ((<$>))
147−import Data.Monoid
148−#else
135+#if !MIN_VERSION_base(4,11,0)
149136import Data.Monoid ((<>))
150137#endif
151138
152−-- | Set up the terminal with file descriptor `inputFd` for input. Returns a 'Input'.
153−--
154−-- The table used to determine the 'Events' to produce for the input bytes comes from
155−-- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from
156−-- 'inputMap'.
157−--
158−-- The terminal device is configured with the attributes:
159−--
160−-- * IXON disabled
161−-- - disables software flow control on outgoing data. This stops the process from being
162−-- suspended if the output terminal cannot keep up. I presume this has little effect these
163−-- days. I hope this means that output will be buffered if the terminal cannot keep up. In the
164−-- old days the output might of been dropped?
165−--
166−-- "raw" mode is used for input.
167−--
168−-- * ISIG disabled
169−-- - enables keyboard combinations that result in signals. TODO: should probably be a dynamic
170−-- option.
139+-- | Set up the terminal with file descriptor `inputFd` for input.
140+-- Returns an 'Input'.
171141--
172−-- * ECHO disabled
173−-- - input is not echod to the output. TODO: should be a dynamic option.
174−--
175−-- * ICANON disabled
176−-- - canonical mode (line mode) input is not used. TODO: should be a dynamic option.
177−--
178−-- * IEXTEN disabled
179−-- - extended functions are disabled. TODO: I don't know what those are.
142+-- The table used to determine the 'Events' to produce for the input
143+-- bytes comes from 'classifyMapForTerm' which is then overridden by
144+-- the the applicable entries from the configuration's 'inputMap'.
180145--
146+-- The terminal device's mode flags are configured by the
147+-- 'attributeControl' function.
181148inputForConfig :: Config -> IO Input
182149inputForConfig config@Config{ termName = Just termName
183150 , inputFd = Just termFd
@@ -187,20 +154,23 @@ inputForConfig config@Config{ termName = Just termName
187154 terminal <- Terminfo.setupTerm termName
188155 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]
189156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides
190− (setAttrs,unsetAttrs) <- attributeControl termFd
157+ (setAttrs, unsetAttrs) <- attributeControl termFd
191158 setAttrs
192159 input <- initInput config activeInputMap
193160 let pokeIO = Catch $ do
194− let e = error "vty internal failure: this value should not propagate to users"
195161 setAttrs
196− atomically $ writeTChan (input^.eventChannel) (EvResize e e)
162+ atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
197163 _ <- installHandler windowChange pokeIO Nothing
198164 _ <- installHandler continueProcess pokeIO Nothing
165+
166+ let restore = unsetAttrs
167+
199168 return $ input
200169 { shutdownInput = do
201170 shutdownInput input
202171 _ <- installHandler windowChange Ignore Nothing
203172 _ <- installHandler continueProcess Ignore Nothing
204− unsetAttrs
173+ restore
174+ , restoreInputState = restoreInputState input >> restore
205175 }
206176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Classify.hs+70−73
@@ -1,113 +1,110 @@
11{-# OPTIONS_HADDOCK hide #-}
2−-- This makes a kind of tri. Has space efficiency issues with large input blocks.
3−-- Likely building a parser and just applying that would be better.
4−-- I did not write this so I might just rewrite it for better understanding. Which is not the best
5−-- of reasons.
6−-- TODO: measure and rewrite if required.
7−-- TODO: The ClassifyMap interface requires this code to always assure later entries override
8−-- earlier.
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.
95module Graphics.Vty.Input.Classify
10− ( classify
11− , KClass(..)
12− ) where
6+ ( classify
7+ , KClass(..)
8+ , ClassifierState(..)
9+ )
10+where
1311
1412import Graphics.Vty.Input.Events
1513import Graphics.Vty.Input.Mouse
14+import Graphics.Vty.Input.Focus
15+import Graphics.Vty.Input.Paste
1616import Graphics.Vty.Input.Classify.Types
1717
1818import Codec.Binary.UTF8.Generic (decode)
1919
20−import Data.List (inits, isPrefixOf, isInfixOf)
20+import Control.Arrow (first)
2121import qualified Data.Map as M( fromList, lookup )
2222import Data.Maybe ( mapMaybe )
2323import qualified Data.Set as S( fromList, member )
2424
25−import Data.Char
2625import Data.Word
2726
28−compile :: ClassifyMap -> [Char] -> KClass
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
2943compile table = cl' where
3044 -- take all prefixes and create a set of these
31− prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
45+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
3246 maxValidInputLength = maximum (map (length . fst) table)
33− eventForInput = M.fromList table
34− cl' [] = Prefix
47+ eventForInput = M.fromList $ map (first BS8.pack) table
48+ cl' inputBlock | BS8.null inputBlock = Prefix
3549 cl' inputBlock = case M.lookup inputBlock eventForInput of
36− -- if the inputBlock is exactly what is expected for an event then consume the whole
37− -- block and return the event
38− Just e -> Valid e []
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
3953 Nothing -> case S.member inputBlock prefixSet of
4054 True -> Prefix
41− -- look up progressively smaller tails of the input block until an event is found
42− -- The assumption is that the event that consumes the most input bytes should be
43− -- produced.
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.
4459 -- The test verifyFullSynInputToEvent2x verifies this.
45− -- H: There will always be one match. The prefixSet contains, by definition, all
46− -- prefixes of an event.
60+ -- H: There will always be one match. The prefixSet
61+ -- contains, by definition, all prefixes of an event.
4762 False ->
48− let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
63+ let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
4964 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
50− (s,e) : _ -> Valid e (drop (length s) inputBlock)
65+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
5166 -- neither a prefix or a full event.
52− -- TODO: debug log
5367 [] -> Invalid
5468
55−classify :: ClassifyMap -> [Char] -> KClass
56−classify table =
57− let standardClassifier = compile table
58− in \s -> case s of
59− _ | bracketedPasteStarted s ->
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 =
6086 if bracketedPasteFinished s
61− then parseBracketedPaste s
62− else Prefix
63− _ | isMouseEvent s -> classifyMouseEvent s
64− c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
65− _ -> standardClassifier s
87+ then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
88+ else Chunk
89+ process ClassifierInChunk{} _ = Invalid
6690
67−classifyUtf8 :: Char -> [Char] -> KClass
91+classifyUtf8 :: Word8 -> ByteString -> KClass
6892classifyUtf8 c cs =
69− let n = utf8Length (ord c)
70− (codepoint,rest) = splitAt n (c:cs)
93+ let n = utf8Length c
94+ (codepoint,rest) = BS8.splitAt (n - 1) cs
7195
7296 codepoint8 :: [Word8]
73− codepoint8 = map (fromIntegral . ord) codepoint
97+ codepoint8 = c:BS.unpack codepoint
7498
7599 in case decode codepoint8 of
76− _ | n < length codepoint -> Prefix
77− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
78− Nothing -> Invalid -- something bad happened; just ignore and continue.
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
79104
80−utf8Length :: (Num t, Ord a, Num a) => a -> t
105+utf8Length :: Word8 -> Int
81106utf8Length c
82107 | c < 0x80 = 1
83108 | c < 0xE0 = 2
84109 | c < 0xF0 = 3
85110 | otherwise = 4
86−
87−bracketedPasteStart :: String
88−bracketedPasteStart = "\ESC[200~"
89−
90−bracketedPasteEnd :: String
91−bracketedPasteEnd = "\ESC[201~"
92−
93−bracketedPasteStarted :: String -> Bool
94−bracketedPasteStarted = isPrefixOf bracketedPasteStart
95−
96−bracketedPasteFinished :: String -> Bool
97−bracketedPasteFinished = isInfixOf bracketedPasteEnd
98−
99−takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])
100−takeUntil [] _ = ([], [])
101−takeUntil cs sub
102− | length cs < length sub = (cs, [])
103− | take (length sub) cs == sub = ([], drop (length sub) cs)
104− | otherwise = let (pre, suf) = takeUntil (tail cs) sub
105− in (head cs:pre, suf)
106−
107−parseBracketedPaste :: String -> KClass
108−parseBracketedPaste s =
109− let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd
110− rest' = if bracketedPasteEnd `isPrefixOf` rest
111− then drop (length bracketedPasteEnd) rest
112− else rest
113− in Valid (EvPaste p) rest'
src/Graphics/Vty/Input/Classify/Parse.hs+18−14
@@ -1,13 +1,14 @@
11-- | This module provides a simple parser for parsing input event
22-- control sequences.
33module Graphics.Vty.Input.Classify.Parse
4− ( Parser
5− , runParser
6− , failParse
7− , readInt
8− , readChar
9− , expectChar
10− ) where
4+ ( Parser
5+ , runParser
6+ , failParse
7+ , readInt
8+ , readChar
9+ , expectChar
10+ )
11+where
1112
1213import Graphics.Vty.Input.Events
1314import Graphics.Vty.Input.Classify.Types
@@ -15,12 +16,15 @@ import Graphics.Vty.Input.Classify.Types
1516import Control.Monad.Trans.Maybe
1617import Control.Monad.State
1718
18−type Parser a = MaybeT (State String) a
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+
22+type Parser a = MaybeT (State ByteString) a
1923
2024-- | Run a parser on a given input string. If the parser fails, return
2125-- 'Invalid'. Otherwise return the valid event ('Valid') and the
2226-- remaining unparsed characters.
23−runParser :: String -> Parser Event -> KClass
27+runParser :: ByteString -> Parser Event -> KClass
2428runParser s parser =
2529 case runState (runMaybeT parser) s of
2630 (Nothing, _) -> Invalid
@@ -35,9 +39,9 @@ failParse = fail "invalid parse"
3539-- return '123' and consume those characters.
3640readInt :: Parser Int
3741readInt = do
38− s <- get
42+ s <- BS8.unpack <$> get
3943 case (reads :: ReadS Int) s of
40− [(i, rest)] -> put rest >> return i
44+ [(i, rest)] -> put (BS8.pack rest) >> return i
4145 _ -> failParse
4246
4347-- | Read a character from the input stream. If one cannot be read (e.g.
@@ -45,9 +49,9 @@ readInt = do
4549readChar :: Parser Char
4650readChar = do
4751 s <- get
48− case s of
49− c:rest -> put rest >> return c
50− _ -> failParse
52+ case BS8.uncons s of
53+ Just (c,rest) -> put rest >> return c
54+ Nothing -> failParse
5155
5256-- | Read a character from the input stream and fail parsing if it is
5357-- not the specified character.
src/Graphics/Vty/Input/Classify/Types.hs+10−3
@@ -1,13 +1,17 @@
11-- | This module exports the input classification type to avoid import
22-- cycles between other modules that need this.
3+{-# LANGUAGE StrictData #-}
34module Graphics.Vty.Input.Classify.Types
4− ( KClass(..)
5− ) where
5+ ( KClass(..)
6+ )
7+where
68
79import Graphics.Vty.Input.Events
810
11+import Data.ByteString.Char8 (ByteString)
12+
913data KClass
10− = Valid Event [Char]
14+ = Valid Event ByteString
1115 -- ^ A valid event was parsed. Any unused characters from the input
1216 -- stream are also provided.
1317 | Invalid
@@ -15,4 +19,7 @@ data KClass
1519 | Prefix
1620 -- ^ The input characters form the prefix of a valid event character
1721 -- 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.
1825 deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs+50−20
@@ -1,29 +1,43 @@
1+{-# Language DeriveGeneric #-}
2+{-# Language StrictData #-}
13module Graphics.Vty.Input.Events where
24
5+import Control.DeepSeq
6+import Data.ByteString
7+import GHC.Generics
8+
39-- | Representations of non-modifier keys.
410--
5−-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by terminal and keyboard.
11+-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by
12+-- terminal and keyboard.
613--
7−-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by terminal and keyboard.
14+-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by
15+-- terminal and keyboard.
816--
9−-- * Actually, support for most of these but KEsc, KChar, KBS, and KEnter vary by terminal and
10−-- keyboard.
11−data Key = KEsc | KChar Char | KBS | KEnter
17+-- * Actually, support for most of these but KEsc, KChar, KBS, and
18+-- KEnter vary by terminal and keyboard.
19+data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter
1220 | KLeft | KRight | KUp | KDown
1321 | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
14− | KFun Int | KBackTab | KPrtScr | KPause | KIns
22+ | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns
1523 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
16− deriving (Eq,Show,Read,Ord)
24+ deriving (Eq,Show,Read,Ord,Generic)
25+
26+instance NFData Key
1727
18−-- | Modifier keys. Key codes are interpreted such that users are more likely to
19−-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
20−-- generally correspond to the physical Alt key.
28+-- | Modifier keys. Key codes are interpreted such that users are more
29+-- likely to have Meta than Alt; for instance on the PC Linux console,
30+-- 'MMeta' will generally correspond to the physical Alt key.
2131data Modifier = MShift | MCtrl | MMeta | MAlt
22− deriving (Eq,Show,Read,Ord)
32+ deriving (Eq,Show,Read,Ord,Generic)
33+
34+instance NFData Modifier
2335
2436-- | Mouse buttons.
25−data Button = BLeft | BMiddle | BRight
26− deriving (Eq,Show,Read,Ord)
37+data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown
38+ deriving (Eq,Show,Read,Ord,Generic)
39+
40+instance NFData Button
2741
2842-- | Events.
2943data Event
@@ -38,16 +52,32 @@ data Event
3852 -- without specifying which one; in that case, Nothing is provided.
3953 -- Otherwise Just the button released is included in the event.
4054 | EvResize Int Int
41− -- ^ If read from 'eventChannel' this is the size at the time of the
42− -- signal. If read from 'nextEvent' this is the size at the time the
43− -- event was processed by Vty. Typically these are the same, but if
44− -- somebody is resizing the terminal quickly they can be different.
45− | EvPaste String
55+ -- The terminal window was resized and the size is provided in the
56+ -- integer fields (width, height).
57+ | EvPaste ByteString
4658 -- ^ A paste event occurs when a bracketed paste input sequence is
4759 -- received. For terminals that support bracketed paste mode, these
4860 -- events will be triggered on a paste event. Terminals that do not
4961 -- support bracketed pastes will send the paste contents as ordinary
50− -- input (which is probably bad, so beware!)
51− deriving (Eq,Show,Read,Ord)
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)
70+
71+instance NFData Event
5272
5373type ClassifyMap = [(String,Event)]
74+
75+-- | The type of internal events that drive the internal Vty event
76+-- dispatching to the application.
77+data InternalEvent =
78+ ResumeAfterSignal
79+ -- ^ Vty resumed operation after the process was interrupted with a
80+ -- signal. In practice this translates into a screen redraw in the
81+ -- input event loop.
82+ | InputEvent Event
83+ -- ^ An input event was received.
src/Graphics/Vty/Input/Focus.hsnew file+49
@@ -0,0 +1,49 @@
1+module Graphics.Vty.Input.Focus
2+ ( requestFocusEvents
3+ , disableFocusEvents
4+ , isFocusEvent
5+ , classifyFocusEvent
6+ )
7+where
8+
9+import Graphics.Vty.Input.Events
10+import Graphics.Vty.Input.Classify.Types
11+import Graphics.Vty.Input.Classify.Parse
12+
13+import Control.Monad.State
14+
15+import qualified Data.ByteString.Char8 as BS8
16+import Data.ByteString.Char8 (ByteString)
17+
18+-- | These sequences set xterm-based terminals to send focus event
19+-- sequences.
20+requestFocusEvents :: ByteString
21+requestFocusEvents = BS8.pack "\ESC[?1004h"
22+
23+-- | These sequences disable focus events.
24+disableFocusEvents :: ByteString
25+disableFocusEvents = BS8.pack "\ESC[?1004l"
26+
27+-- | Does the specified string begin with a focus event?
28+isFocusEvent :: ByteString -> Bool
29+isFocusEvent s = BS8.isPrefixOf focusIn s ||
30+ BS8.isPrefixOf focusOut s
31+
32+focusIn :: ByteString
33+focusIn = BS8.pack "\ESC[I"
34+
35+focusOut :: ByteString
36+focusOut = BS8.pack "\ESC[O"
37+
38+-- | Attempt to classify an input string as a focus event.
39+classifyFocusEvent :: ByteString -> KClass
40+classifyFocusEvent s = runParser s $ do
41+ when (not $ isFocusEvent s) failParse
42+
43+ expectChar '\ESC'
44+ expectChar '['
45+ ty <- readChar
46+ case ty of
47+ 'I' -> return EvGainedFocus
48+ 'O' -> return EvLostFocus
49+ _ -> failParse
src/Graphics/Vty/Input/Loop.hs+109−47
@@ -1,14 +1,18 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# OPTIONS_HADDOCK hide #-}
1+{-# LANGUAGE CPP #-}
32{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
45{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE CPP #-}
6−-- | The input layer used to be a single function that correctly accounted for the non-threaded
7−-- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with
8−-- a more straightforward parser. The non-threaded runtime is no longer supported.
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.
912--
10−-- This is an example of an algorithm where code coverage could be high, even 100%, but the
11−-- behavior is still under tested. I should collect more of these examples...
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...
1216--
1317-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
1418module Graphics.Vty.Input.Loop where
@@ -21,8 +25,7 @@ import Control.Applicative
2125import Control.Concurrent
2226import Control.Concurrent.STM
2327import Control.Exception (mask, try, SomeException)
24−import Data.Monoid
25−import Lens.Micro
28+import Lens.Micro hiding ((<>~))
2629import Lens.Micro.Mtl
2730import Lens.Micro.TH
2831import Control.Monad (when, mzero, forM_)
@@ -31,12 +34,15 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)
3134import Control.Monad.State.Class (MonadState, modify)
3235import Control.Monad.Trans.Reader (ReaderT(..))
3336
34−import Data.Char
37+import qualified Data.ByteString.Char8 as BS8
38+import qualified Data.ByteString as BS
39+import Data.ByteString.Char8 (ByteString)
3540import Data.IORef
3641import Data.Word (Word8)
3742
38−import Foreign ( allocaArray, peekArray, Ptr )
43+import Foreign (allocaArray)
3944import Foreign.C.Types (CInt(..))
45+import Foreign.Ptr (Ptr, castPtr)
4046
4147import System.IO
4248import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
@@ -46,12 +52,18 @@ import System.Posix.Types (Fd(..))
4652import Text.Printf (hPrintf)
4753
4854data Input = Input
49− { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
50− -- the display if the next event is an 'EvResize'.
51− _eventChannel :: TChan Event
52− -- | Shuts down the input processing. This should return the terminal input state to before
53− -- the input initialized.
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.
5461 , 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 ()
5567 -- | Changes to this value are reflected after the next event.
5668 , _configRef :: IORef Config
5769 -- | input debug log
@@ -68,10 +80,11 @@ data InputBuffer = InputBuffer
6880makeLenses ''InputBuffer
6981
7082data InputState = InputState
71− { _unprocessedBytes :: String
83+ { _unprocessedBytes :: ByteString
84+ , _classifierState :: ClassifierState
7285 , _appliedConfig :: Config
7386 , _inputBuffer :: InputBuffer
74− , _classifier :: String -> KClass
87+ , _classifier :: ClassifierState -> ByteString -> KClass
7588 }
7689
7790makeLenses ''InputState
@@ -86,7 +99,8 @@ logMsg msg = do
8699 Just h -> liftIO $ hPutStrLn h msg >> hFlush h
87100
88101-- this must be run on an OS thread dedicated to this input handling.
89−-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
102+-- otherwise the terminal timing read behavior will block the execution
103+-- of the lightweight threads.
90104loopInputProcessor :: InputM ()
91105loopInputProcessor = do
92106 readFromDevice >>= addBytesToProcess
@@ -95,20 +109,20 @@ loopInputProcessor = do
95109 dropInvalid
96110 loopInputProcessor
97111
98−addBytesToProcess :: String -> InputM ()
112+addBytesToProcess :: ByteString -> InputM ()
99113addBytesToProcess block = unprocessedBytes <>= block
100114
101115emit :: Event -> InputM ()
102116emit event = do
103117 logMsg $ "parsed event: " ++ show event
104− view eventChannel >>= liftIO . atomically . flip writeTChan event
118+ view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
105119
106−-- The timing requirements are assured by the VMIN and VTIME set for the device.
120+-- The timing requirements are assured by the VMIN and VTIME set for the
121+-- device.
107122--
108−-- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case
109−-- satisfies precondition.
110−-- TODO: When under the non-threaded runtime emulate VMIN and VTIME
111−readFromDevice :: InputM String
123+-- Precondition: Under the threaded runtime. Only current use is from a
124+-- forkOS thread. That case satisfies precondition.
125+readFromDevice :: InputM ByteString
112126readFromDevice = do
113127 newConfig <- view configRef >>= liftIO . readIORef
114128 oldConfig <- use appliedConfig
@@ -120,16 +134,18 @@ readFromDevice = do
120134 bufferPtr <- use $ inputBuffer.ptr
121135 maxBytes <- use $ inputBuffer.size
122136 stringRep <- liftIO $ do
123− -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses
124− -- this provides a location to be interrupted prior to the foreign call. If there is input
125− -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime
126− -- terminal setting.
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.
127142 threadWaitRead fd
128143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
129144 if bytesRead > 0
130− then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
131− else return []
132− when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
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)
133149 return stringRep
134150
135151applyConfig :: Fd -> Config -> IO ()
@@ -140,41 +156,86 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat
140156parseEvent :: InputM Event
141157parseEvent = do
142158 c <- use classifier
159+ s <- use classifierState
143160 b <- use unprocessedBytes
144− case c b of
161+ case c s b of
145162 Valid e remaining -> do
146163 logMsg $ "valid parse: " ++ show e
147164 logMsg $ "remaining: " ++ show remaining
165+ classifierState .= ClassifierStart
148166 unprocessedBytes .= remaining
149167 return e
150− _ -> mzero
168+ _ -> mzero
151169
152170dropInvalid :: InputM ()
153171dropInvalid = do
154172 c <- use classifier
173+ s <- use classifierState
155174 b <- use unprocessedBytes
156− when (c b == Invalid) $ do
157− logMsg "dropping input bytes"
158− 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 ()
159187
160188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
161189runInputProcessorLoop classifyTable input = do
162190 let bufferSize = 1024
163191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
164− s0 <- InputState [] <$> readIORef (_configRef input)
165− <*> pure (InputBuffer bufferPtr bufferSize)
166− <*> pure (classify classifyTable)
192+ s0 <- InputState BS8.empty ClassifierStart
193+ <$> readIORef (_configRef input)
194+ <*> pure (InputBuffer bufferPtr bufferSize)
195+ <*> pure (classify classifyTable)
167196 runReaderT (evalStateT loopInputProcessor s0) input
168197
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)
169223attributeControl :: Fd -> IO (IO (), IO ())
170224attributeControl fd = do
171225 original <- getTerminalAttributes fd
172− let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
173− , EnableEcho, ProcessInput, ExtendedFunctions
174− ]
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+ ]
175236 let setAttrs = setTerminalAttributes fd vtyMode Immediately
176237 unsetAttrs = setTerminalAttributes fd original Immediately
177− return (setAttrs,unsetAttrs)
238+ return (setAttrs, unsetAttrs)
178239
179240logInitialInputState :: Input -> ClassifyMap -> IO()
180241logInitialInputState input classifyTable = case _inputDebug input of
@@ -182,7 +243,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
182243 Just h -> do
183244 Config{ vmin = Just theVmin
184245 , vtime = Just theVtime
185− , termName = Just theTerm, .. } <- readIORef $ _configRef input
246+ , termName = Just theTerm } <- readIORef $ _configRef input
186247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
187248 forM_ classifyTable $ \i -> case i of
188249 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
@@ -198,6 +259,7 @@ initInput config classifyTable = do
198259 applyConfig fd config
199260 stopSync <- newEmptyMVar
200261 input <- Input <$> atomically newTChan
262+ <*> pure (return ())
201263 <*> pure (return ())
202264 <*> newIORef config
203265 <*> maybe (return Nothing)
src/Graphics/Vty/Input/Mouse.hs+38−28
@@ -3,22 +3,24 @@
33--
44-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
55module Graphics.Vty.Input.Mouse
6− ( requestMouseEvents
7− , disableMouseEvents
8− , isMouseEvent
9− , classifyMouseEvent
10− ) where
6+ ( requestMouseEvents
7+ , disableMouseEvents
8+ , isMouseEvent
9+ , classifyMouseEvent
10+ )
11+where
1112
1213import Graphics.Vty.Input.Events
1314import Graphics.Vty.Input.Classify.Types
1415import Graphics.Vty.Input.Classify.Parse
1516
16−import Control.Monad.Trans.Maybe
1717import Control.Monad.State
18−import Data.List (isPrefixOf)
1918import Data.Maybe (catMaybes)
2019import Data.Bits ((.&.))
2120
21+import qualified Data.ByteString.Char8 as BS8
22+import Data.ByteString.Char8 (ByteString)
23+
2224-- A mouse event in SGR extended mode is
2325--
2426-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
@@ -32,28 +34,28 @@ import Data.Bits ((.&.))
3234
3335-- | These sequences set xterm-based terminals to send mouse event
3436-- sequences.
35−requestMouseEvents :: String
36−requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h\ESC[?1005h"
37+requestMouseEvents :: ByteString
38+requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
3739
3840-- | These sequences disable mouse events.
39−disableMouseEvents :: String
40−disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l\ESC[?1005l"
41+disableMouseEvents :: ByteString
42+disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
4143
4244-- | Does the specified string begin with a mouse event?
43−isMouseEvent :: String -> Bool
45+isMouseEvent :: ByteString -> Bool
4446isMouseEvent s = isSGREvent s || isNormalEvent s
4547
46−isSGREvent :: String -> Bool
47−isSGREvent = isPrefixOf sgrPrefix
48+isSGREvent :: ByteString -> Bool
49+isSGREvent = BS8.isPrefixOf sgrPrefix
4850
49−sgrPrefix :: String
50−sgrPrefix = "\ESC[M"
51+sgrPrefix :: ByteString
52+sgrPrefix = BS8.pack "\ESC[M"
5153
52−isNormalEvent :: String -> Bool
53−isNormalEvent = isPrefixOf normalPrefix
54+isNormalEvent :: ByteString -> Bool
55+isNormalEvent = BS8.isPrefixOf normalPrefix
5456
55−normalPrefix :: String
56−normalPrefix = "\ESC[<"
57+normalPrefix :: ByteString
58+normalPrefix = BS8.pack "\ESC[<"
5759
5860-- Modifier bits:
5961shiftBit :: Int
@@ -67,7 +69,7 @@ ctrlBit = 16
6769
6870-- These bits indicate the buttons involved:
6971buttonMask :: Int
70−buttonMask = 3
72+buttonMask = 67
7173
7274leftButton :: Int
7375leftButton = 0
@@ -78,11 +80,17 @@ middleButton = 1
7880rightButton :: Int
7981rightButton = 2
8082
83+scrollUp :: Int
84+scrollUp = 64
85+
86+scrollDown :: Int
87+scrollDown = 65
88+
8189hasBitSet :: Int -> Int -> Bool
8290hasBitSet val bit = val .&. bit > 0
8391
84−-- | Attempt to lassify an input string as a mouse event.
85−classifyMouseEvent :: String -> KClass
92+-- | Attempt to classify an input string as a mouse event.
93+classifyMouseEvent :: ByteString -> KClass
8694classifyMouseEvent s = runParser s $ do
8795 when (not $ isMouseEvent s) failParse
8896
@@ -94,12 +102,14 @@ classifyMouseEvent s = runParser s $ do
94102 'M' -> classifyNormalMouseEvent
95103 _ -> failParse
96104
97−-- Given a modifer/button value, determine which button was indicated
105+-- Given a modifier/button value, determine which button was indicated
98106getSGRButton :: Int -> Parser Button
99107getSGRButton mods =
100108 let buttonMap = [ (leftButton, BLeft)
101109 , (middleButton, BMiddle)
102110 , (rightButton, BRight)
111+ , (scrollUp, BScrollUp)
112+ , (scrollDown, BScrollDown)
103113 ]
104114 in case lookup (mods .&. buttonMask) buttonMap of
105115 Nothing -> failParse
@@ -130,8 +140,8 @@ classifyNormalMouseEvent = do
130140 case press of
131141 True -> do
132142 button <- getSGRButton status
133− return $ EvMouseDown xCoord yCoord button modifiers
134− False -> return $ EvMouseUp xCoord yCoord Nothing
143+ return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers
144+ False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing
135145
136146-- Attempt to classify a control sequence as an SGR mouse event. To
137147-- get here we should have already read "\ESC[<" so that will not be
@@ -148,6 +158,6 @@ classifySGRMouseEvent = do
148158 let modifiers = getModifiers mods
149159 button <- getSGRButton mods
150160 case final of
151− 'M' -> return $ EvMouseDown xCoord yCoord button modifiers
152− 'm' -> return $ EvMouseUp xCoord yCoord (Just button)
161+ 'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers
162+ 'm' -> return $ EvMouseUp (xCoord-1) (yCoord-1) (Just button)
153163 _ -> failParse
src/Graphics/Vty/Input/Paste.hsnew file+41
@@ -0,0 +1,41 @@
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+34−33
@@ -7,8 +7,8 @@ import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT
77import Control.Arrow
88import System.Console.Terminfo
99
10−-- | queries the terminal for all capability based input sequences then adds on a terminal dependent
11−-- input sequence mapping.
10+-- | Queries the terminal for all capability-based input sequences and
11+-- then adds on a terminal-dependent input sequence mapping.
1212--
1313-- For reference see:
1414--
@@ -20,29 +20,29 @@ import System.Console.Terminfo
2020--
2121-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
2222--
23−-- This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect.
24−-- Vty assumes that the an internal terminfo table added to the system provided terminfo table is
25−-- correct.
23+-- Terminfo is incomplete. The vim source implies that terminfo is also
24+-- incorrect. Vty assumes that the internal terminfo table added to the
25+-- system-provided terminfo table is correct.
2626--
27−-- 1. build terminfo table for all caps. Missing caps are not added.
27+-- The procedure used here is:
2828--
29−-- 2. add tables for visible chars, esc, del plus ctrl and meta
29+-- 1. Build terminfo table for all caps. Missing caps are not added.
3030--
31−-- 3. add internally defined table for given terminal type.
31+-- 2. Add tables for visible chars, esc, del, ctrl, and meta.
3232--
33−-- Precedence is currently implicit in the 'compile' algorithm. Which is a bit odd.
33+-- 3. Add internally-defined table for given terminal type.
3434--
35−-- \todo terminfo meta is not supported.
36−-- \todo no 8bit
35+-- Precedence is currently implicit in the 'compile' algorithm.
3736classifyMapForTerm :: String -> Terminal -> ClassifyMap
3837classifyMapForTerm termName term =
3938 concat $ capsClassifyMap term keysFromCapsTable
4039 : universalTable
4140 : termSpecificTables termName
4241
43−-- | key table applicable to all terminals.
42+-- | The key table applicable to all terminals.
4443--
45−-- TODO: some probably only applicable to ANSI/VT100 terminals.
44+-- Note that some of these entries are probably only applicable to
45+-- ANSI/VT100 terminals.
4646universalTable :: ClassifyMap
4747universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
4848
@@ -50,31 +50,31 @@ capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap
5050capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]
5151 where extractCap = first (getCapability terminal . tiGetStr)
5252
53−-- | tables specific to a given terminal that are not derivable from terminfo.
53+-- | Tables specific to a given terminal that are not derivable from
54+-- terminfo.
5455--
55−-- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier.
56+-- Note that this adds the ANSI/VT100/VT50 tables regardless of term
57+-- identifier.
5658termSpecificTables :: String -> [ClassifyMap]
5759termSpecificTables _termName = ANSIVT.classifyTable
5860
5961-- | Visible characters in the ISO-8859-1 and UTF-8 common set.
6062--
61−-- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this
62−-- classify table is reached.
63−--
64−-- TODO: resolve
65−-- 1. start at ' '. The earlier characters are all 'ctrlChar'
63+-- We limit to < 0xC1. The UTF8 sequence detector will catch all values
64+-- 0xC2 and above before this classify table is reached.
6665visibleChars :: ClassifyMap
6766visibleChars = [ ([x], EvKey (KChar x) [])
6867 | x <- [' ' .. toEnum 0xC1]
6968 ]
7069
71−-- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.
70+-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set
71+-- translated to ctrl + char.
7272--
73−-- \todo resolve CTRL-i is the same as tab
73+-- This treats CTRL-i the same as tab.
7474ctrlChars :: ClassifyMap
7575ctrlChars =
7676 [ ([toEnum x],EvKey (KChar y) [MCtrl])
77− | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
77+ | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
7878 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
7979 , y /= 'h' -- CTRL-h should not hide BS
8080 ]
@@ -83,22 +83,23 @@ ctrlChars =
8383ctrlMetaChars :: ClassifyMap
8484ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
8585
86−-- | esc, meta esc, delete, meta delete, enter, meta enter
86+-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
8787specialSupportKeys :: ClassifyMap
8888specialSupportKeys =
89− [ -- special support for ESC
90− ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
89+ [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
90+ , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
91+ -- special support for ESC
92+ , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
9193 -- Special support for backspace
92− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
94+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])
9395 -- Special support for Enter
9496 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
9597 -- explicit support for tab
9698 , ("\t", EvKey (KChar '\t') [])
9799 ]
98100
99−-- | classify table directly generated from terminfo cap strings
100−--
101−-- these are:
101+-- | A classification table directly generated from terminfo cap
102+-- strings. These are:
102103--
103104-- * ka1 - keypad up-left
104105--
@@ -113,7 +114,7 @@ specialSupportKeys =
113114-- * kcbt - back tab
114115--
115116-- * kc1 - keypad left-down
116−--
117+--
117118-- * kc3 - keypad right-down
118119--
119120-- * kdch1 - delete
@@ -121,7 +122,7 @@ specialSupportKeys =
121122-- * kcud1 - down
122123--
123124-- * kend - end
124−--
125+--
125126-- * kent - enter
126127--
127128-- * kf0 - kf63 - function keys
@@ -180,6 +181,6 @@ keysFromCapsTable =
180181 , ("kcuu1", EvKey KUp [])
181182 ] ++ functionKeyCapsTable
182183
183−-- | cap names for function keys
184+-- | Cap names for function keys.
184185functionKeyCapsTable :: ClassifyMap
185186functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+21−20
@@ -1,15 +1,15 @@
1−-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo.
2−--
3−-- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often
4−-- use VT50 input bytes regardless of declared terminal type. This provides compatibility with
5−-- programs that don't follow terminfo.
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.
68module Graphics.Vty.Input.Terminfo.ANSIVT where
79
810import Graphics.Vty.Input.Events
911
1012-- | Encoding for navigation keys.
11−--
12−-- TODO: This is not the same as the input bytes pulled from teh caps table.
1313navKeys0 :: ClassifyMap
1414navKeys0 =
1515 [ k "G" KCenter
@@ -30,8 +30,10 @@ navKeys1 =
3030 [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
3131 | charCnt <- ["1;", ""], -- we can have a count or not
3232 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
33− ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
34− (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes
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)]
3537 ]
3638
3739-- | encoding for ins, del, pageup, pagedown, home, end
@@ -49,26 +51,26 @@ navKeys3 =
4951 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
5052
5153-- | encoding for shift plus function keys
52−--
53−-- According to
54+--
55+-- According to
5456--
5557-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
5658--
5759-- This encoding depends on the terminal.
5860functionKeys1 :: ClassifyMap
5961functionKeys1 =
60− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
62+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in
6163 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
6264
6365-- | encoding for meta plus char
6466--
65−-- TODO: resolve -
66−--
67−-- 1. removed 'ESC' from second list due to duplication with "special_support_keys".
68−-- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is
69−-- the same as ESC should examine km and current encoding.
70−-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by
71−-- special_support_keys.
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.
7274functionKeys2 :: ClassifyMap
7375functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
7476 | x <- '\t':[' ' .. '~']
@@ -84,4 +86,3 @@ classifyTable =
8486 , functionKeys1
8587 , functionKeys2
8688 ]
87−
src/Graphics/Vty/Output.hs+62−52
@@ -1,97 +1,107 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE NamedFieldPuns #-}
3−-- | Output interface.
1+{-# LANGUAGE RecordWildCards, CPP #-}
2+-- | This module provides functions for accessing the current terminal
3+-- or a specific terminal device.
44--
5−-- Access to the current terminal or a specific terminal device.
5+-- See also:
66--
7−-- See also:
7+-- 1. "Graphics.Vty.Output": This instantiates an abtract interface
8+-- to the terminal based on the @TERM@ and @COLORTERM@ environment
9+-- variables.
810--
9−-- 1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based
10−-- on the TERM and COLORTERM environment variables.
11+-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all
12+-- terminal modules need to implement.
1113--
12−-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement.
14+-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance
15+-- that uses terminfo for all control strings. No attempt is made to
16+-- change the character set to UTF-8 for these terminals.
1317--
14−-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance that uses terminfo for all
15−-- control strings. No attempt is made to change the character set to UTF-8 for these terminals.
16−-- I don't know a way to reliably determine if that is required or how to do so.
17−--
18−-- 4. "Graphics.Vty.Output.XTermColor": This module contains an interface suitable for xterm-like
19−-- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many
20−-- control codes as possible.
21−module Graphics.Vty.Output ( module Graphics.Vty.Output
22− , Output(..) -- \todo hide constructors
23− , AssumedState(..)
24− , DisplayContext(..) -- \todo hide constructors
25− , outputPicture
26− , displayContext
27− )
28− where
18+-- 4. "Graphics.Vty.Output.XTermColor": This module contains an
19+-- interface suitable for xterm-like terminals. These are the terminals
20+-- where @TERM@ begins with @xterm@. This does use terminfo for as many
21+-- control codes as possible.
22+module Graphics.Vty.Output
23+ ( outputForConfig
24+ , setCursorPos
25+ , hideCursor
26+ , showCursor
27+ )
28+where
2929
30−import Graphics.Vty.Prelude
30+import Control.Monad (when)
3131
3232import Graphics.Vty.Config
33−
33+import Graphics.Vty.Image (regionWidth, regionHeight)
3434import Graphics.Vty.Output.Interface
3535import Graphics.Vty.Output.XTermColor as XTermColor
3636import Graphics.Vty.Output.TerminfoBased as TerminfoBased
3737
3838import Blaze.ByteString.Builder (writeToByteString)
3939
40−import Control.Monad.Trans
41−
4240import Data.List (isPrefixOf)
41+
42+#if !MIN_VERSION_base(4,11,0)
4343import Data.Monoid ((<>))
44+#endif
4445
45−-- | Returns a `Output` for the terminal specified in `Config`
46+-- | Returns an `Output` for the terminal specified in `Config`.
4647--
47−-- The specific Output implementation used is hidden from the API user. All terminal implementations
48−-- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at
49−-- least some terminal specific information.
48+-- The specific Output implementation used is hidden from the API user.
49+-- All terminal implementations are assumed to perform more, or less,
50+-- the same. Currently, all implementations use terminfo for at least
51+-- some terminal specific information.
5052--
51−-- Specifics about it being based on terminfo are hidden from the API user. If a terminal
52−-- implementation is developed for a terminal without terminfo support then Vty should work as
53−-- expected on that terminal.
53+-- If a terminal implementation is developed for a terminal without
54+-- terminfo support then Vty should work as expected on that terminal.
5455--
5556-- Selection of a terminal is done as follows:
5657--
5758-- * If TERM contains "xterm" or "screen", use XTermColor.
5859-- * otherwise use the TerminfoBased driver.
59−--
60−-- \todo add an implementation for windows that does not depend on terminfo. Should be installable
61−-- with only what is provided in the haskell platform. Use ansi-terminal
6260outputForConfig :: Config -> IO Output
63−outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do
61+outputForConfig Config{ outputFd = Just fd, termName = Just termName
62+ , colorMode = Just colorMode, .. } = do
6463 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName
65− then XTermColor.reserveTerminal termName fd
64+ then XTermColor.reserveTerminal termName fd colorMode
6665 -- Not an xterm-like terminal. try for generic terminfo.
67− else TerminfoBased.reserveTerminal termName fd
66+ else TerminfoBased.reserveTerminal termName fd colorMode
67+
68+ case mouseMode of
69+ Just s -> setMode t Mouse s
70+ Nothing -> return ()
71+
72+ case bracketedPasteMode of
73+ Just s -> setMode t BracketedPaste s
74+ Nothing -> return ()
75+
6876 return t
6977outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig
7078
7179-- | Sets the cursor position to the given output column and row.
7280--
73−-- This is not necessarially the same as the character position with the same coordinates.
74−-- Characters can be a variable number of columns in width.
81+-- This is not necessarily the same as the character position with the
82+-- same coordinates. Characters can be a variable number of columns in
83+-- width.
7584--
76−-- Currently, the only way to set the cursor position to a given character coordinate is to specify
77−-- the coordinate in the Picture instance provided to outputPicture or refresh.
78−setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()
85+-- Currently, the only way to set the cursor position to a given
86+-- character coordinate is to specify the coordinate in the Picture
87+-- instance provided to 'outputPicture' or 'refresh'.
88+setCursorPos :: Output -> Int -> Int -> IO ()
7989setCursorPos t x y = do
8090 bounds <- displayBounds t
8191 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
8292 dc <- displayContext t bounds
83− liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
93+ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
8494
85−-- | Hides the cursor
86−hideCursor :: MonadIO m => Output -> m ()
95+-- | Hides the cursor.
96+hideCursor :: Output -> IO ()
8797hideCursor t = do
8898 bounds <- displayBounds t
8999 dc <- displayContext t bounds
90− liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
100+ outputByteBuffer t $ writeToByteString $ writeHideCursor dc
91101
92−-- | Shows the cursor
93−showCursor :: MonadIO m => Output -> m ()
102+-- | Shows the cursor.
103+showCursor :: Output -> IO ()
94104showCursor t = do
95105 bounds <- displayBounds t
96106 dc <- displayContext t bounds
97− liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
107+ outputByteBuffer t $ writeToByteString $ writeShowCursor dc
src/Graphics/Vty/Output/Interface.hs+191−125
@@ -1,21 +1,25 @@
11-- Copyright Corey O'Connor
2−-- General philosophy is: MonadIO is for equations exposed to clients.
3−{-# LANGUAGE CPP #-}
4−{-# LANGUAGE BangPatterns #-}
52{-# LANGUAGE RankNTypes #-}
63{-# LANGUAGE ExistentialQuantification #-}
74{-# LANGUAGE GADTs #-}
85{-# LANGUAGE FlexibleContexts #-}
9−
10−#ifndef MIN_VERSION_base
11−#defined MIN_VERSION_base(x,y,z) 1
12−#endif
13−
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'.
149module Graphics.Vty.Output.Interface
10+ ( Output(..)
11+ , AssumedState(..)
12+ , DisplayContext(..)
13+ , Mode(..)
14+ , displayContext
15+ , outputPicture
16+ , initialAssumedState
17+ , limitAttrForDisplay
18+ )
1519where
1620
17−import Graphics.Vty.Prelude
18−
21+import Graphics.Vty.Attributes
22+import Graphics.Vty.Image (DisplayRegion, regionHeight)
1923import Graphics.Vty.Picture
2024import Graphics.Vty.PictureToSpans
2125import Graphics.Vty.Span
@@ -25,57 +29,97 @@ import Graphics.Vty.DisplayAttributes
2529import Blaze.ByteString.Builder (Write, writeToByteString)
2630import Blaze.ByteString.Builder.ByteString (writeByteString)
2731
28−import Control.Monad.Trans
29−
3032import qualified Data.ByteString as BS
3133import Data.IORef
3234import qualified Data.Text.Encoding as T
3335import qualified Data.Text.Lazy as TL
3436import qualified Data.Vector as Vector
3537
36−#if !(MIN_VERSION_base(4,8,0))
37−import Data.Monoid (mempty, mappend)
38−#endif
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)
3955
56+-- | The Vty terminal output interface.
4057data Output = Output
41− { -- | Text identifier for the output device. Used for debugging.
58+ { -- | Text identifier for the output device. Used for debugging.
4259 terminalID :: String
43− , releaseTerminal :: forall m. MonadIO m => m ()
44− -- | Clear the display and initialize the terminal to some initial display state.
45− --
46− -- The expectation of a program is that the display starts in some initial state.
47− -- The initial state would consist of fixed values:
48− --
49− -- - cursor at top left
50− -- - UTF-8 character encoding
51− -- - drawing characteristics are the default
52− --
53− -- The abstract operation I think all these behaviors are instances of is reserving exclusive
54− -- access to a display such that:
55− --
56− -- - The previous state cannot be determined
57− -- - When exclusive access to a display is released the display returns to the previous state.
58− , reserveDisplay :: forall m. MonadIO m => m ()
59− -- | Return the display to the state before `reserveDisplay`
60− -- If no previous state then set the display state to the initial state.
61− , releaseDisplay :: forall m. MonadIO m => m ()
62− -- | Returns the current display bounds.
63− , displayBounds :: forall m. MonadIO m => m DisplayRegion
64− -- | Output the byte string to the terminal device.
60+ -- | Release the terminal just prior to application exit and reset
61+ -- it to its state prior to application startup.
62+ , releaseTerminal :: IO ()
63+ -- | Clear the display and initialize the terminal to some initial
64+ -- display state.
65+ --
66+ -- The expectation of a program is that the display starts in some
67+ -- The initial state. initial state would consist of fixed values:
68+ --
69+ -- - cursor at top left
70+ -- - UTF-8 character encoding
71+ -- - drawing characteristics are the default
72+ , reserveDisplay :: IO ()
73+ -- | Return the display to the state before `reserveDisplay` If no
74+ -- previous state then set the display state to the initial state.
75+ , releaseDisplay :: IO ()
76+ -- | Sets the current display bounds (width, height).
77+ , setDisplayBounds :: (Int, Int) -> IO ()
78+ -- | Returns the current display bounds.
79+ , displayBounds :: IO DisplayRegion
80+ -- | Output the bytestring to the terminal device.
6581 , outputByteBuffer :: BS.ByteString -> IO ()
66− -- | Maximum number of colors supported by the context.
67− , contextColorCount :: Int
68− -- | if the cursor can be shown / hidden
82+ -- | Specifies whether the cursor can be shown / hidden.
6983 , supportsCursorVisibility :: 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
7091 , assumedStateRef :: IORef AssumedState
71− -- | Acquire display access to the given region of the display.
72− -- Currently all regions have the upper left corner of (0,0) and the lower right corner at
73− -- (max displayWidth providedWidth, max displayHeight providedHeight)
74− , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
92+ -- | Acquire display access to the given region of the display.
93+ -- Currently all regions have the upper left corner of (0,0) and
94+ -- the lower right corner at (max displayWidth providedWidth, max
95+ -- displayHeight providedHeight)
96+ , mkDisplayContext :: Output -> DisplayRegion -> IO 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
75119 }
76120
77−displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
78−displayContext t = liftIO . mkDisplayContext t t
121+displayContext :: Output -> DisplayRegion -> IO DisplayContext
122+displayContext t = mkDisplayContext t t
79123
80124data AssumedState = AssumedState
81125 { prevFattr :: Maybe FixedAttr
@@ -87,77 +131,92 @@ initialAssumedState = AssumedState Nothing Nothing
87131
88132data DisplayContext = DisplayContext
89133 { contextDevice :: Output
90− -- | Provide the bounds of the display context.
134+ -- | Provide the bounds of the display context.
91135 , contextRegion :: DisplayRegion
92− -- | sets the output position to the specified row and column. Where the number of bytes
93− -- required for the control codes can be specified seperate from the actual byte sequence.
136+ -- | Sets the output position to the specified row and column
137+ -- where the number of bytes required for the control codes can be
138+ -- specified seperate from the actual byte sequence.
94139 , writeMoveCursor :: Int -> Int -> Write
95140 , writeShowCursor :: Write
96141 , writeHideCursor :: Write
97− -- | Assure the specified output attributes will be applied to all the following text until the
98− -- next output attribute change. Where the number of bytes required for the control codes can
99− -- be specified seperate from the actual byte sequence. The required number of bytes must be
100− -- at least the maximum number of bytes required by any attribute changes. The serialization
101− -- equations must provide the ptr to the next byte to be specified in the output buffer.
142+ -- Ensure that the specified output attributes will be applied to
143+ -- all the following text until the next output attribute change
144+ -- where the number of bytes required for the control codes can be
145+ -- specified seperately from the actual byte sequence. The required
146+ -- number of bytes must be at least the maximum number of bytes
147+ -- required by any attribute changes. The serialization equations
148+ -- must provide the ptr to the next byte to be specified in the
149+ -- output buffer.
102150 --
103− -- The currently applied display attributes are provided as well. The Attr data type can
104− -- specify the style or color should not be changed from the currently applied display
105− -- attributes. In order to support this the currently applied display attributes are required.
106− -- In addition it may be possible to optimize the state changes based off the currently applied
107− -- display attributes.
108− , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
109− -- | Reset the display attributes to the default display attributes
110− , writeDefaultAttr :: Write
151+ -- The currently applied display attributes are provided as well.
152+ -- The Attr data type can specify the style or color should not be
153+ -- changed from the currently applied display attributes. In order
154+ -- to support this the currently applied display attributes are
155+ -- required. In addition it may be possible to optimize the state
156+ -- changes based off the currently applied display attributes.
157+ , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
158+ -- | Reset the display attributes to the default display attributes.
159+ , writeDefaultAttr :: Bool -> Write
111160 , writeRowEnd :: Write
112161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
113162 , inlineHack :: IO ()
114163 }
115164
116−-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
165+-- | All terminals serialize UTF8 text to the terminal device exactly as
166+-- serialized in memory.
117167writeUtf8Text :: BS.ByteString -> Write
118168writeUtf8Text = writeByteString
119169
120170-- | Displays the given `Picture`.
121171--
122−-- 0. The image is cropped to the display size.
172+-- 1. The image is cropped to the display size.
173+--
174+-- 2. Converted into a sequence of attribute changes and text spans.
123175--
124−-- 1. Converted into a sequence of attribute changes and text spans.
125−--
126−-- 2. The cursor is hidden.
176+-- 3. The cursor is hidden.
127177--
128−-- 3. Serialized to the display.
178+-- 4. Serialized to the display.
129179--
130−-- 4. The cursor is then shown and positioned or kept hidden.
131−--
132−-- todo: specify possible IO exceptions.
133−-- abstract from IO monad to a MonadIO instance.
134−outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
135−outputPicture dc pic = liftIO $ do
180+-- 5. The cursor is then shown and positioned or kept hidden.
181+outputPicture :: DisplayContext -> Picture -> IO ()
182+outputPicture dc pic = do
183+ urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
136184 as <- readIORef (assumedStateRef $ contextDevice dc)
137185 let manipCursor = supportsCursorVisibility (contextDevice dc)
138186 r = contextRegion dc
139187 ops = displayOpsForPic pic r
140− initialAttr = FixedAttr defaultStyleMask Nothing Nothing
141− -- Diff the previous output against the requested output. Differences are currently on a per-row
142− -- basis.
143− -- \todo handle resizes that crop the dominate directions better.
188+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
189+ -- Diff the previous output against the requested output.
190+ -- Differences are currently on a per-row basis.
144191 diffs :: [Bool] = case prevOutputOps as of
145− Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True
146− Just previousOps -> if effectedRegion previousOps /= effectedRegion ops
192+ Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
193+ Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
147194 then replicate (displayOpsRows ops) True
148− else zipWith (/=) (Vector.toList previousOps)
149− (Vector.toList ops)
195+ else Vector.toList $ Vector.zipWith (/=) previousOps ops
150196 -- build the Write corresponding to the output image
151197 out = (if manipCursor then writeHideCursor dc else mempty)
152− `mappend` writeOutputOps dc initialAttr diffs ops
198+ `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
153199 `mappend`
154− (case picCursor pic of
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
155204 _ | not manipCursor -> mempty
156− NoCursor -> mempty
205+ 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)
157215 Cursor x y ->
158216 let m = cursorOutputMap ops $ picCursor pic
159− (ox, oy) = charToOutputPos m (x,y)
160− in writeShowCursor dc `mappend` writeMoveCursor dc ox oy
217+ (ox, oy) = charToOutputPos m (clampX x, clampY y)
218+ in writeShowCursor dc `mappend`
219+ writeMoveCursor dc (clampX ox) (clampY oy)
161220 )
162221 -- ... then serialize
163222 outputByteBuffer (contextDevice dc) (writeToByteString out)
@@ -165,15 +224,15 @@ outputPicture dc pic = liftIO $ do
165224 let as' = as { prevOutputOps = Just ops }
166225 writeIORef (assumedStateRef $ contextDevice dc) as'
167226
168−writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
169−writeOutputOps dc initialAttr diffs ops =
227+writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
228+writeOutputOps urlsEnabled dc initialAttr diffs ops =
170229 let (_, out, _) = Vector.foldl' writeOutputOps'
171230 (0, mempty, diffs)
172231 ops
173232 in out
174− where
233+ where
175234 writeOutputOps' (y, out, True : diffs') spanOps
176− = let spanOut = writeSpanOps dc y initialAttr spanOps
235+ = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
177236 out' = out `mappend` spanOut
178237 in (y+1, out', diffs')
179238 writeOutputOps' (y, out, False : diffs') _spanOps
@@ -181,33 +240,34 @@ writeOutputOps dc initialAttr diffs ops =
181240 writeOutputOps' (_y, _out, []) _spanOps
182241 = error "vty - output spans without a corresponding diff."
183242
184−writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
185−writeSpanOps dc y initialAttr spanOps =
243+writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
244+writeSpanOps urlsEnabled dc y initialAttr spanOps =
186245 -- The first operation is to set the cursor to the start of the row
187− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
246+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
188247 -- then the span ops are serialized in the order specified
189− in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
248+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of
190249 (opOut, fattr') -> (out `mappend` opOut, fattr')
191250 )
192251 (start, initialAttr)
193252 spanOps
194253
195−writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
196−writeSpanOp dc (TextSpan attr _ _ str) fattr =
254+writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
255+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
197256 let attr' = limitAttrForDisplay (contextDevice dc) attr
198257 fattr' = fixDisplayAttr fattr attr'
199258 diffs = displayAttrDiffs fattr fattr'
200− out = writeSetAttr dc fattr attr' diffs
259+ out = writeSetAttr dc urlsEnabled fattr attr' diffs
201260 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
202261 in (out, fattr')
203−writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
204−writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
262+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
263+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
205264
206−-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
207−-- needs to be translated to column, row positions.
265+-- | The cursor position is given in X,Y character offsets. Due to
266+-- multi-column characters this needs to be translated to column, row
267+-- positions.
208268data CursorOutputMap = CursorOutputMap
209269 { charToOutputPos :: (Int, Int) -> (Int, Int)
210− }
270+ }
211271
212272cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
213273cursorOutputMap spanOps _cursor = CursorOutputMap
@@ -217,18 +277,18 @@ cursorOutputMap spanOps _cursor = CursorOutputMap
217277cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
218278cursorColumnOffset ops cx cy =
219279 let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
220− (outOffset, _, _)
221− = Vector.foldl' ( \(d, currentCx, done) op ->
280+ (outOffset, _, _)
281+ = Vector.foldl' ( \(d, currentCx, done) op ->
222282 if done then (d, currentCx, done) else case spanOpHasWidth op of
223283 Nothing -> (d, currentCx, False)
224284 Just (cw, ow) -> case compare cx (currentCx + cw) of
225285 GT -> ( d + ow
226286 , currentCx + cw
227− , False
287+ , False
228288 )
229289 EQ -> ( d + ow
230290 , currentCx + cw
231− , True
291+ , True
232292 )
233293 LT -> ( d + columnsToCharOffset (cx - currentCx) op
234294 , currentCx + cw
@@ -239,27 +299,33 @@ cursorColumnOffset ops cx cy =
239299 cursorRowOps
240300 in outOffset
241301
242−-- | Not all terminals support all display attributes. This filters a display attribute to what the
243−-- given terminal can display.
302+-- | Not all terminals support all display attributes. This filters a
303+-- display attribute to what the given terminal can display.
244304limitAttrForDisplay :: Output -> Attr -> Attr
245−limitAttrForDisplay t attr
305+limitAttrForDisplay t attr
246306 = attr { attrForeColor = clampColor $ attrForeColor attr
247307 , attrBackColor = clampColor $ attrBackColor attr
248308 }
249309 where
250310 clampColor Default = Default
251311 clampColor KeepCurrent = KeepCurrent
252− clampColor (SetTo c) = clampColor' c
253− clampColor' (ISOColor v)
254− | contextColorCount t < 8 = Default
255− | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
256− | otherwise = SetTo $ ISOColor v
257− clampColor' (Color240 v)
258− -- TODO: Choose closes ISO color?
259− | contextColorCount t < 8 = Default
260− | contextColorCount t < 16 = Default
261− | contextColorCount t <= 256 = SetTo $ Color240 v
262− | otherwise
263− = let p :: Double = fromIntegral v / 240.0
264− v' = floor $ p * (fromIntegral $ contextColorCount t)
265− in SetTo $ Color240 v'
312+ clampColor (SetTo c) = clampColor' (outputColorMode t) c
313+
314+ clampColor' NoColor _ = Default
315+
316+ clampColor' ColorMode8 (ISOColor v)
317+ | v >= 8 = SetTo $ ISOColor (v - 8)
318+ | otherwise = SetTo $ ISOColor v
319+ clampColor' ColorMode8 _ = Default
320+
321+ clampColor' ColorMode16 c@(ISOColor _) = SetTo c
322+ clampColor' ColorMode16 _ = Default
323+
324+ clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c
325+ clampColor' (ColorMode240 colorCount) c@(Color240 n)
326+ | n <= colorCount = SetTo c
327+ | otherwise = Default
328+ clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
329+ clampColor' colorMode (color240 r g b)
330+
331+ clampColor' FullColor c = SetTo c
src/Graphics/Vty/Output/Mock.hs+45−25
@@ -1,13 +1,17 @@
11-- Copyright Corey O'Connor
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE TypeFamilies #-}
4−-- | This provides a mock terminal implementation that is nice for testing. This transforms the
5−-- output operations to visible characters. Which is nice for some tests.
6−module Graphics.Vty.Output.Mock ( MockData, mockTerminal )
7− where
8−
9−import Graphics.Vty.Prelude
4+-- | This provides a mock terminal implementation that is nice for
5+-- testing. This transforms the output operations to visible characters
6+-- which is useful for testing.
7+module Graphics.Vty.Output.Mock
8+ ( MockData
9+ , mockTerminal
10+ )
11+where
1012
13+import Graphics.Vty.Image (DisplayRegion)
14+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
1115import Graphics.Vty.Output.Interface
1216
1317import Blaze.ByteString.Builder.Word (writeWord8)
@@ -20,18 +24,20 @@ import qualified Data.String.UTF8 as UTF8
2024
2125type MockData = IORef (UTF8.UTF8 BS.ByteString)
2226
23−-- | The mock display terminal produces a string representation of the requested picture. There is
24−-- *not* an isomorphism between the string representation and the picture. The string
25−-- representation is a simplification of the picture that is only useful in debugging VTY without
26−-- considering terminal specific issues.
27+-- | The mock display terminal produces a string representation of
28+-- the requested picture. There is *not* an isomorphism between the
29+-- string representation and the picture. The string representation is
30+-- a simplification of the picture that is only useful in debugging VTY
31+-- without considering terminal specific issues.
2732--
28−-- The mock implementation is useful in manually determining if the sequence of terminal operations
29−-- matches the expected sequence. So requirement of the produced representation is simplicity in
30−-- parsing the text representation and determining how the picture was mapped to terminal
31−-- operations.
33+-- The mock implementation is useful in manually determining if the
34+-- sequence of terminal operations matches the expected sequence. The
35+-- requirement of the produced representation is simplicity in parsing
36+-- the text representation and determining how the picture was mapped to
37+-- terminal operations.
3238--
33−-- The string representation is a sequence of identifiers where each identifier is the name of an
34−-- operation in the algebra.
39+-- The string representation is a sequence of identifiers where each
40+-- identifier is the name of an operation in the algebra.
3541mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)
3642mockTerminal r = liftIO $ do
3743 outRef <- newIORef undefined
@@ -41,27 +47,41 @@ mockTerminal r = liftIO $ do
4147 , releaseTerminal = return ()
4248 , reserveDisplay = return ()
4349 , releaseDisplay = return ()
50+ , ringTerminalBell = return ()
51+ , supportsBell = return False
52+ , supportsItalics = return False
53+ , supportsStrikethrough = return False
54+ , setDisplayBounds = const $ return ()
4455 , displayBounds = return r
4556 , outputByteBuffer = \bytes -> do
4657 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"
4758 writeIORef outRef $ UTF8.fromRep bytes
48− , contextColorCount = 16
4959 , supportsCursorVisibility = True
60+ , supportsMode = const False
61+ , setMode = const $ const $ return ()
62+ , getModeStatus = const $ return False
5063 , assumedStateRef = newAssumedStateRef
64+ , outputColorMode = ColorMode16
5165 , mkDisplayContext = \tActual rActual -> return $ DisplayContext
5266 { contextRegion = rActual
5367 , contextDevice = tActual
54− -- A cursor move is always visualized as the single character 'M'
68+ -- A cursor move is always visualized as the single
69+ -- character 'M'
5570 , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'
56− -- Show cursor is always visualized as the single character 'S'
71+ -- Show cursor is always visualized as the single
72+ -- character 'S'
5773 , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S'
58− -- Hide cursor is always visualized as the single character 'H'
74+ -- Hide cursor is always visualized as the single
75+ -- character 'H'
5976 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
60− -- An attr change is always visualized as the single character 'A'
61− , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
62− -- default attr is always visualized as the single character 'D'
63− , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'
64− -- row end is always visualized as the single character 'E'
77+ -- An attr change is always visualized as the single
78+ -- character 'A'
79+ , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
80+ -- default attr is always visualized as the single
81+ -- character 'D'
82+ , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
83+ -- row end is always visualized as the single character
84+ -- 'E'
6585 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
6686 , inlineHack = return ()
6787 }
src/Graphics/Vty/Output/TerminfoBased.hs+293−157
@@ -1,42 +1,40 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE CPP #-}
31{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
44{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
55{-# CFILES gwinsz.c #-}
66
7−#ifndef MIN_VERSION_base
8−#defined MIN_VERSION_base(x,y,z) 1
9−#endif
10−
11−-- | Terminfo based terminal handling.
12−--
13−-- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I
14−-- have easy access to then color support is entirely based of the docs. Probably with some
15−-- assumptions mixed in.
7+-- | Terminfo-based terminal output driver.
168--
179-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
18−module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )
19− where
20−
21−import Graphics.Vty.Prelude
22−
10+module Graphics.Vty.Output.TerminfoBased
11+ ( reserveTerminal
12+ , setWindowSize
13+ )
14+where
15+
16+import Control.Monad (when)
17+import Data.Bits (shiftL, (.&.))
18+import qualified Data.ByteString as BS
2319import Data.ByteString.Internal (toForeignPtr)
2420import Data.Terminfo.Parse
2521import Data.Terminfo.Eval
2622
2723import Graphics.Vty.Attributes
24+import Graphics.Vty.Image (DisplayRegion)
2825import Graphics.Vty.DisplayAttributes
2926import Graphics.Vty.Output.Interface
3027
31−import Blaze.ByteString.Builder (Write, writeToByteString)
32−
33−import Control.Monad.Trans
28+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
3429
35−import Data.Bits ((.&.))
3630import Data.IORef
3731import Data.Maybe (isJust, isNothing, fromJust)
3832import Data.Word
3933
34+#if !MIN_VERSION_base(4,8,0)
35+import Data.Foldable (foldMap)
36+#endif
37+
4038import Foreign.C.Types ( CInt(..), CLong(..) )
4139import Foreign.ForeignPtr (withForeignPtr)
4240import Foreign.Ptr (Ptr, plusPtr)
@@ -45,18 +43,12 @@ import qualified System.Console.Terminfo as Terminfo
4543import System.Posix.IO (fdWriteBuf)
4644import System.Posix.Types (Fd(..))
4745
48−#if !(MIN_VERSION_base(4,8,0))
49−import Data.Foldable (foldMap)
50−import Data.Monoid
51−#endif
52−
53−data TerminfoCaps = TerminfoCaps
46+data TerminfoCaps = TerminfoCaps
5447 { smcup :: Maybe CapExpression
5548 , rmcup :: Maybe CapExpression
5649 , cup :: CapExpression
5750 , cnorm :: Maybe CapExpression
5851 , civis :: Maybe CapExpression
59− , supportsNoColors :: Bool
6052 , useAltColorMap :: Bool
6153 , setForeColor :: CapExpression
6254 , setBackColor :: CapExpression
@@ -64,21 +56,28 @@ data TerminfoCaps = TerminfoCaps
6456 , clearScreen :: CapExpression
6557 , clearEol :: CapExpression
6658 , displayAttrCaps :: DisplayAttrCaps
59+ , ringBellAudio :: Maybe CapExpression
6760 }
6861
6962data DisplayAttrCaps = DisplayAttrCaps
7063 { setAttrStates :: Maybe CapExpression
7164 , enterStandout :: Maybe CapExpression
7265 , exitStandout :: Maybe CapExpression
66+ , enterItalic :: Maybe CapExpression
67+ , exitItalic :: Maybe CapExpression
68+ , enterStrikethrough :: Maybe CapExpression
69+ , exitStrikethrough :: Maybe CapExpression
7370 , enterUnderline :: Maybe CapExpression
7471 , exitUnderline :: Maybe CapExpression
7572 , enterReverseVideo :: Maybe CapExpression
7673 , enterDimMode :: Maybe CapExpression
7774 , enterBoldMode :: Maybe CapExpression
7875 }
79−
80−-- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422
81−-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried.
76+
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.
8281fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
8382fdWriteAll outFd ptr len count
8483 | len < 0 = fail "fdWriteAll: len is less than 0"
@@ -94,68 +93,95 @@ sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
9493sendCapToTerminal t cap capParams = do
9594 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
9695
97−{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
98− - terminfo does not support some features that would increase efficiency and improve compatibility:
99− -
100− - * determine the character encoding supported by the terminal. Should this be taken from the LANG
101− - environment variable?
102− -
103− - * Provide independent string capabilities for all display attributes.
104− -
105− - todo: Some display attributes like underline and bold have independent string capabilities that
106− - should be used instead of the generic "sgr" string capability.
107− -}
108−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
109−reserveTerminal termName outFd = liftIO $ do
96+-- | Constructs an output driver that uses terminfo for all control
97+-- codes. While this should provide the most compatible terminal,
98+-- terminfo does not support some features that would increase
99+-- efficiency and improve compatibility:
100+--
101+-- * determining the character encoding supported by the terminal.
102+-- Should this be taken from the LANG environment variable?
103+--
104+-- * Providing independent string capabilities for all display
105+-- attributes.
106+reserveTerminal :: String -> Fd -> ColorMode -> IO Output
107+reserveTerminal termName outFd colorMode = do
110108 ti <- Terminfo.setupTerm termName
111109 -- assumes set foreground always implies set background exists.
112− -- if set foreground is not set then all color changing style attributes are filtered.
110+ -- if set foreground is not set then all color changing style
111+ -- attributes are filtered.
113112 msetaf <- probeCap ti "setaf"
114113 msetf <- probeCap ti "setf"
115− let (noColors, useAlt, setForeCap)
114+ let (useAlt, setForeCap)
116115 = case msetaf of
117− Just setaf -> (False, False, setaf)
116+ Just setaf -> (False, setaf)
118117 Nothing -> case msetf of
119− Just setf -> (False, True, setf)
120− Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
118+ Just setf -> (True, setf)
119+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
121120 msetab <- probeCap ti "setab"
122121 msetb <- probeCap ti "setb"
123− let set_back_cap
122+ let setBackCap
124123 = case msetab of
124+ Just setab -> setab
125125 Nothing -> case msetb of
126126 Just setb -> setb
127127 Nothing -> error $ "no back color support for terminal " ++ termName
128− Just setab -> setab
128+
129+ hyperlinkModeStatus <- newIORef False
130+ newAssumedStateRef <- newIORef initialAssumedState
131+
132+ let terminfoSetMode m newStatus = do
133+ curStatus <- terminfoModeStatus m
134+ when (newStatus /= curStatus) $
135+ case m of
136+ Hyperlink -> do
137+ writeIORef hyperlinkModeStatus newStatus
138+ writeIORef newAssumedStateRef initialAssumedState
139+ _ -> return ()
140+ terminfoModeStatus m =
141+ case m of
142+ Hyperlink -> readIORef hyperlinkModeStatus
143+ _ -> return False
144+ terminfoModeSupported Hyperlink = True
145+ terminfoModeSupported _ = False
146+
129147 terminfoCaps <- pure TerminfoCaps
130148 <*> probeCap ti "smcup"
131149 <*> probeCap ti "rmcup"
132150 <*> requireCap ti "cup"
133151 <*> probeCap ti "cnorm"
134152 <*> probeCap ti "civis"
135− <*> pure noColors
136153 <*> pure useAlt
137154 <*> pure setForeCap
138− <*> pure set_back_cap
155+ <*> pure setBackCap
139156 <*> requireCap ti "sgr0"
140157 <*> requireCap ti "clear"
141158 <*> requireCap ti "el"
142159 <*> currentDisplayAttrCaps ti
143− newAssumedStateRef <- newIORef initialAssumedState
160+ <*> probeCap ti "bel"
144161 let t = Output
145162 { terminalID = termName
146− , releaseTerminal = liftIO $ do
163+ , releaseTerminal = do
147164 sendCap setDefaultAttr []
148165 maybeSendCap cnorm []
149− , reserveDisplay = liftIO $ do
150− -- If there is no support for smcup: Clear the screen and then move the mouse to the
151− -- home position to approximate the behavior.
166+ , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
167+ , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) &&
168+ (isJust $ exitItalic (displayAttrCaps terminfoCaps))
169+ , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
170+ (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
171+ , ringTerminalBell = maybeSendCap ringBellAudio []
172+ , reserveDisplay = do
173+ -- If there is no support for smcup: Clear the screen
174+ -- and then move the mouse to the home position to
175+ -- approximate the behavior.
152176 maybeSendCap smcup []
153177 sendCap clearScreen []
154− , releaseDisplay = liftIO $ do
178+ , releaseDisplay = do
155179 maybeSendCap rmcup []
156180 maybeSendCap cnorm []
181+ , setDisplayBounds = \(w, h) ->
182+ setWindowSize outFd (w, h)
157183 , displayBounds = do
158− rawSize <- liftIO $ getWindowSize outFd
184+ rawSize <- getWindowSize outFd
159185 case rawSize of
160186 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
161187 | otherwise -> return (w,h)
@@ -166,48 +192,48 @@ reserveTerminal termName outFd = liftIO $ do
166192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
167193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
168194 ++ " Please report this bug to vty project."
169− , contextColorCount
170− = case supportsNoColors terminfoCaps of
171− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
172− Nothing -> 8
173− Just v -> toEnum v
174− True -> 1
175195 , supportsCursorVisibility = isJust $ civis terminfoCaps
196+ , supportsMode = terminfoModeSupported
197+ , setMode = terminfoSetMode
198+ , getModeStatus = terminfoModeStatus
176199 , assumedStateRef = newAssumedStateRef
177− -- I think fix would help assure tActual is the only reference. I was having issues
178− -- tho.
179− , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
200+ , outputColorMode = colorMode
201+ -- I think fix would help assure tActual is the only
202+ -- reference. I was having issues tho.
203+ , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
180204 }
181205 sendCap s = sendCapToTerminal t (s terminfoCaps)
182206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
183207 return t
184208
185−requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
186−requireCap ti capName
209+requireCap :: Terminfo.Terminal -> String -> IO CapExpression
210+requireCap ti capName
187211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
188212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
189213 Just capStr -> parseCap capStr
190214
191−probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
192−probeCap ti capName
215+probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
216+probeCap ti capName
193217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
194218 Nothing -> return Nothing
195219 Just capStr -> Just <$> parseCap capStr
196220
197−parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
221+parseCap :: String -> IO CapExpression
198222parseCap capStr = do
199223 case parseCapExpression capStr of
200224 Left e -> fail $ show e
201225 Right cap -> return cap
202226
203−currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
204− => Terminfo.Terminal
205− -> m DisplayAttrCaps
206−currentDisplayAttrCaps ti
207− = pure DisplayAttrCaps
227+currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
228+currentDisplayAttrCaps ti
229+ = pure DisplayAttrCaps
208230 <*> probeCap ti "sgr"
209231 <*> probeCap ti "smso"
210232 <*> probeCap ti "rmso"
233+ <*> probeCap ti "sitm"
234+ <*> probeCap ti "ritm"
235+ <*> probeCap ti "smxx"
236+ <*> probeCap ti "rmxx"
211237 <*> probeCap ti "smul"
212238 <*> probeCap ti "rmul"
213239 <*> probeCap ti "rev"
@@ -217,10 +243,17 @@ currentDisplayAttrCaps ti
217243foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
218244
219245getWindowSize :: Fd -> IO (Int,Int)
220−getWindowSize fd = do
246+getWindowSize fd = do
221247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
222248 return (fromIntegral b, fromIntegral a)
223249
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+
224257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
225258terminfoDisplayContext tActual terminfoCaps r = return dc
226259 where dc = DisplayContext
@@ -234,123 +267,204 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
234267 Nothing -> error "this terminal does not support hide cursor"
235268 Just c -> writeCapExpr c []
236269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
237− , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
270+ , writeDefaultAttr = \urlsEnabled ->
271+ writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
272+ (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
273+ (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274+ Just cap -> writeCapExpr cap []
275+ Nothing -> mempty
276+ )
238277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
239278 , inlineHack = return ()
240279 }
241280
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+
242295-- | Portably setting the display attributes is a giant pain in the ass.
243296--
244−-- If the terminal supports the sgr capability (which sets the on/off state of each style
245−-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
297+-- If the terminal supports the sgr capability (which sets the on/off
298+-- state of each style directly; and, for no good reason, resets the
299+-- colors to the default) this procedure is used:
246300--
247301-- 0. set the style attributes. This resets the fore and back color.
248302--
249303-- 1, If a foreground color is to be set then set the foreground color
250304--
251305-- 2. likewise with the background color
252−--
253−-- If the terminal does not support the sgr cap then:
254−-- if there is a change from an applied color to the default (in either the fore or back color)
255−-- then:
256306--
257−-- 0. reset all display attributes (sgr0)
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:
258310--
259−-- 1. enter required style modes
311+-- 0. reset all display attributes (sgr0)
260312--
261−-- 2. set the fore color if required
313+-- 1. enter required style modes
262314--
263−-- 3. set the back color if required
315+-- 2. set the fore color if required
264316--
265−-- Entering the required style modes could require a reset of the display attributes. If this is
266−-- the case then the back and fore colors always need to be set if not default.
317+-- 3. set the back color if required
318+--
319+-- Entering the required style modes could require a reset of the
320+-- display attributes. If this is the case then the back and fore colors
321+-- always need to be set if not default.
267322--
268323-- This equation implements the above logic.
269324--
270−-- \todo This assumes the removal of color changes in the display attributes is done as expected
271−-- with noColors == True. See `limitAttrForDisplay`
325+-- Note that this assumes the removal of color changes in the
326+-- display attributes is done as expected with noColors == True. See
327+-- `limitAttrForDisplay`.
272328--
273−-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
274−-- haven't measured this or even examined terminal implementations. *shrug*
275−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
276−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
277− case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
278− -- The only way to reset either color, portably, to the default is to use either the set
279− -- state capability or the set default capability.
280− True -> do
329+-- Note that this optimizes for fewer state changes followed by fewer
330+-- bytes.
331+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
332+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
333+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
334+ -- The only way to reset either color, portably, to the default
335+ -- is to use either the set state capability or the set default
336+ -- capability.
337+ True -> do
281338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
282− (fixedStyle attr )
339+ (fixedStyle attr)
283340 (styleToApplySeq $ fixedStyle attr) of
284341 -- only way to reset a color to the defaults
285− EnterExitSeq caps -> writeDefaultAttr dc
286− `mappend`
342+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
343+ `mappend`
287344 foldMap (\cap -> writeCapExpr cap []) caps
288345 `mappend`
289346 setColors
290347 -- implicitly resets the colors to the defaults
291− SetState state -> writeCapExpr (fromJust $ setAttrStates
292− $ displayAttrCaps
293− $ terminfoCaps
348+ SetState state -> writeCapExpr (fromJust $ setAttrStates
349+ $ displayAttrCaps terminfoCaps
294350 )
295351 (sgrArgsForState state)
296− `mappend`
297− setColors
298− -- Otherwise the display colors are not changing or changing between two non-default
299− -- points.
352+ `mappend` setItalics
353+ `mappend` setStrikethrough
354+ `mappend` setColors
355+ -- Otherwise the display colors are not changing or changing
356+ -- between two non-default points.
300357 False -> do
301− -- Still, it could be the case that the change in display attributes requires the
302− -- colors to be reset because the required capability was not available.
358+ -- Still, it could be the case that the change in display
359+ -- attributes requires the colors to be reset because the
360+ -- required capability was not available.
303361 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
304362 (fixedStyle attr)
305363 (styleDiffs diffs) of
306− -- Really, if terminals were re-implemented with modern concepts instead of bowing
307− -- down to 40 yr old dumb terminal requirements this would be the only case ever
308− -- reached! Changes the style and color states according to the differences with
309− -- the currently applied states.
364+ -- Really, if terminals were re-implemented with modern
365+ -- concepts instead of bowing down to 40 yr old dumb
366+ -- terminal requirements this would be the only case
367+ -- ever reached! Changes the style and color states
368+ -- according to the differences with the currently
369+ -- applied states.
310370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
311371 `mappend`
312− writeColorDiff setForeColor (foreColorDiff diffs)
372+ writeColorDiff Foreground (foreColorDiff diffs)
313373 `mappend`
314− writeColorDiff setBackColor (backColorDiff diffs)
374+ writeColorDiff Background (backColorDiff diffs)
315375 -- implicitly resets the colors to the defaults
316− SetState state -> writeCapExpr (fromJust $ setAttrStates
376+ SetState state -> writeCapExpr (fromJust $ setAttrStates
317377 $ displayAttrCaps terminfoCaps
318378 )
319379 (sgrArgsForState state)
380+ `mappend` setItalics
381+ `mappend` setStrikethrough
320382 `mappend` setColors
321− where
383+ where
384+ urlAttrs True = writeURLEscapes (urlDiff diffs)
385+ urlAttrs False = mempty
322386 colorMap = case useAltColorMap terminfoCaps of
323387 False -> ansiColorIndex
324388 True -> altColorIndex
325389 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
326404 setColors =
327405 (case fixedForeColor attr of
328− Just c -> writeCapExpr (setForeColor terminfoCaps)
329− [toEnum $ colorMap c]
406+ Just c -> writeColor Foreground c
330407 Nothing -> mempty)
331408 `mappend`
332409 (case fixedBackColor attr of
333− Just c -> writeCapExpr (setBackColor terminfoCaps)
334− [toEnum $ colorMap c]
410+ Just c -> writeColor Background c
335411 Nothing -> mempty)
336− writeColorDiff _f NoColorChange
412+ writeColorDiff _side NoColorChange
337413 = mempty
338− writeColorDiff _f ColorToDefault
414+ writeColorDiff _side ColorToDefault
339415 = error "ColorToDefault is not a possible case for applyColorDiffs"
340− writeColorDiff f (SetColor c)
341− = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
342−
343−-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
344−-- be supported by the terminal.
416+ writeColorDiff side (SetColor c)
417+ = writeColor side c
418+
419+ writeColor side (RGBColor r g b) =
420+ case outputColorMode (contextDevice dc) of
421+ FullColor ->
422+ hardcodeColor side (r, g, b)
423+ _ ->
424+ error "clampColor should remove rgb colors in standard mode"
425+ writeColor side c =
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
454+-- 240 color set that might not be supported by the terminal.
345455--
346−-- This takes a Color which clearly identifies which pallete to use and computes the index
347−-- into the full 256 color pallete.
456+-- This takes a Color which clearly identifies which palette to use and
457+-- computes the index into the full 256 color palette.
348458ansiColorIndex :: Color -> Int
349459ansiColorIndex (ISOColor v) = fromEnum v
350460ansiColorIndex (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+ ]
351465
352466-- | For terminals without setaf/setab
353−--
467+--
354468-- See table in `man terminfo`
355469-- Will error if not in table.
356470altColorIndex :: Color -> Int
@@ -364,21 +478,28 @@ altColorIndex (ISOColor 6) = 3
364478altColorIndex (ISOColor 7) = 7
365479altColorIndex (ISOColor v) = fromEnum v
366480altColorIndex (Color240 v) = 16 + fromEnum v
481+altColorIndex (RGBColor _ _ _) =
482+ error $ unlines [ "Attempted to create color index from rgb color."
483+ , "This is currently unsupported, and shouldn't ever happen"
484+ ]
367485
368−{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
369− -
370− - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
371− - the full set display attribute state capability.
486+{- | The sequence of terminfo caps to apply a given style are determined
487+ - according to these rules.
372488 -
373− - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
374− - display attributes are reset to defaults then the display attribute state is set.
489+ - 1. The assumption is that it's preferable to use the simpler
490+ - enter/exit mode capabilities than the full set display attribute
491+ - state capability.
375492 -
376− - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
377− - display attribute state is set if possible. Otherwise the mode is not applied.
493+ - 2. If a mode is supposed to be removed but there is not an exit
494+ - capability defined then the display attributes are reset to defaults
495+ - then the display attribute state is set.
378496 -
379− - 4. If the display attribute state is being set then just update the arguments to that for any
380− - apply/remove.
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
499+ - possible. Otherwise the mode is not applied.
381500 -
501+ - 4. If the display attribute state is being set then just update the
502+ - arguments to that for any apply/remove.
382503 -}
383504data DisplayAttrSeq
384505 = EnterExitSeq [CapExpression]
@@ -387,6 +508,8 @@ data DisplayAttrSeq
387508data DisplayAttrState = DisplayAttrState
388509 { applyStandout :: Bool
389510 , applyUnderline :: Bool
511+ , applyItalic :: Bool
512+ , applyStrikethrough :: Bool
390513 , applyReverseVideo :: Bool
391514 , applyBlink :: Bool
392515 , applyDim :: Bool
@@ -408,19 +531,25 @@ sgrArgsForState attrState = map (\b -> if b then 1 else 0)
408531
409532reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
410533reqDisplayCapSeqFor caps s diffs
411− -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
412− -- then either the state needs to be set or the attribute change ignored.
534+ -- if the state transition implied by any diff cannot be supported
535+ -- with an enter/exit mode cap then either the state needs to be set
536+ -- or the attribute change ignored.
413537 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
414538 -- If all the diffs have an enter-exit cap then just use those
415539 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
416− -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
417− -- all unsupported diffs and just apply the rest
418− ( True, False ) -> EnterExitSeq $ map enterExitCap
540+ -- If not all the diffs have an enter-exit cap and there is no
541+ -- set state cap then filter out all unsupported diffs and just
542+ -- apply the rest
543+ ( True, False ) -> EnterExitSeq $ map enterExitCap
419544 $ filter (not . noEnterExitCap) diffs
420− -- if not all the diffs have an enter-exit can and there is a set state cap then just use
421− -- the set state cap.
545+ -- if not all the diffs have an enter-exit can and there is a
546+ -- set state cap then just use the set state cap.
422547 ( True, True ) -> SetState $ stateForStyle s
423548 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
424553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
425554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
426555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -433,6 +562,10 @@ reqDisplayCapSeqFor caps s diffs
433562 noEnterExitCap RemoveDim = True
434563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
435564 noEnterExitCap RemoveBold = True
565+ enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps
566+ enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps
567+ enterExitCap ApplyItalic = fromJust $ enterItalic caps
568+ enterExitCap RemoveItalic = fromJust $ exitItalic caps
436569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
437570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
438571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -446,6 +579,8 @@ stateForStyle :: Style -> DisplayAttrState
446579stateForStyle s = DisplayAttrState
447580 { applyStandout = isStyleSet standout
448581 , applyUnderline = isStyleSet underline
582+ , applyItalic = isStyleSet italic
583+ , applyStrikethrough = isStyleSet strikethrough
449584 , applyReverseVideo = isStyleSet reverseVideo
450585 , applyBlink = isStyleSet blink
451586 , applyDim = isStyleSet dim
@@ -457,14 +592,15 @@ styleToApplySeq :: Style -> [StyleStateChange]
457592styleToApplySeq s = concat
458593 [ applyIfRequired ApplyStandout standout
459594 , applyIfRequired ApplyUnderline underline
595+ , applyIfRequired ApplyItalic italic
596+ , applyIfRequired ApplyStrikethrough strikethrough
460597 , applyIfRequired ApplyReverseVideo reverseVideo
461598 , applyIfRequired ApplyBlink blink
462599 , applyIfRequired ApplyDim dim
463− , applyIfRequired ApplyBlink bold
600+ , applyIfRequired ApplyBold bold
464601 ]
465− where
466− applyIfRequired op flag
602+ where
603+ applyIfRequired op flag
467604 = if 0 == (flag .&. s)
468605 then []
469606 else [op]
470−
src/Graphics/Vty/Output/XTermColor.hs+94−39
@@ -1,76 +1,131 @@
1−{-# LANGUAGE CPP #-}
2−
3−#ifndef MIN_VERSION_base
4−#defined MIN_VERSION_base(x,y,z) 1
5−#endif
6−
1+{-# Language CPP #-}
72-- Copyright 2009-2010 Corey O'Connor
8−module Graphics.Vty.Output.XTermColor ( reserveTerminal )
9− where
3+-- | Xterm output driver. This uses the Terminfo driver with some
4+-- extensions for Xterm.
5+module Graphics.Vty.Output.XTermColor
6+ ( reserveTerminal
7+ )
8+where
109
1110import Graphics.Vty.Output.Interface
1211import Graphics.Vty.Input.Mouse
12+import Graphics.Vty.Input.Focus
13+import Graphics.Vty.Attributes.Color (ColorMode)
1314import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
1415
1516import Blaze.ByteString.Builder (writeToByteString)
1617import Blaze.ByteString.Builder.Word (writeWord8)
1718
18−import Control.Monad (void)
19+import qualified Data.ByteString.Char8 as BS8
20+import Data.ByteString.Char8 (ByteString)
21+import Foreign.Ptr (castPtr)
22+
23+import Control.Monad (void, when)
1924import Control.Monad.Trans
25+import Data.Char (toLower)
26+import Data.IORef
2027
21−import System.Posix.IO (fdWrite)
22−import System.Posix.Types (Fd)
28+import System.Posix.IO (fdWriteBuf)
29+import System.Posix.Types (ByteCount, Fd)
30+import System.Posix.Env (getEnv)
2331
24−#if !(MIN_VERSION_base(4,8,0))
25−import Control.Applicative
26−import Data.Foldable (foldMap)
32+import Data.List (isInfixOf)
33+import Data.Maybe (catMaybes)
34+
35+#if !MIN_VERSION_base(4,11,0)
36+import Data.Monoid ((<>))
2737#endif
2838
29−-- | Initialize the display to UTF-8.
30−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
31−reserveTerminal variant outFd = liftIO $ do
39+-- | Write a 'ByteString' to an 'Fd'.
40+fdWrite :: Fd -> ByteString -> IO ByteCount
41+fdWrite fd s =
42+ BS8.useAsCStringLen s $ \(buf,len) -> do
43+ fdWriteBuf fd (castPtr buf) (fromIntegral len)
44+
45+-- | Construct an Xterm output driver. Initialize the display to UTF-8.
46+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
47+reserveTerminal variant outFd colorMode = liftIO $ do
3248 let flushedPut = void . fdWrite outFd
33− -- If the terminal variant is xterm-color use xterm instead since, more often than not,
34− -- xterm-color is broken.
49+ -- If the terminal variant is xterm-color use xterm instead since,
50+ -- more often than not, xterm-color is broken.
3551 let variant' = if variant == "xterm-color" then "xterm" else variant
36− flushedPut setUtf8CharSet
37− flushedPut enableBracketedPastes
38− flushedPut requestMouseEvents
39− t <- TerminfoBased.reserveTerminal variant' outFd
52+
53+ utf8a <- utf8Active
54+ when (not utf8a) $ flushedPut setUtf8CharSet
55+ t <- TerminfoBased.reserveTerminal variant' outFd colorMode
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+
4087 let t' = t
4188 { terminalID = terminalID t ++ " (xterm-color)"
4289 , releaseTerminal = do
43− liftIO $ flushedPut setDefaultCharSet
44− liftIO $ flushedPut disableBracketedPastes
45− liftIO $ flushedPut disableMouseEvents
90+ when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
91+ setMode t' BracketedPaste False
92+ setMode t' Mouse False
93+ setMode t' Focus False
4694 releaseTerminal t
4795 , mkDisplayContext = \tActual r -> do
4896 dc <- mkDisplayContext t tActual r
4997 return $ dc { inlineHack = xtermInlineHack t' }
98+ , supportsMode = const True
99+ , getModeStatus = xtermGetMode
100+ , setMode = xtermSetMode t'
50101 }
51102 return t'
52103
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+
53112-- | Enable bracketed paste mode:
54113-- http://cirw.in/blog/bracketed-paste
55−enableBracketedPastes :: String
56−enableBracketedPastes = "\ESC[?2004h"
114+enableBracketedPastes :: ByteString
115+enableBracketedPastes = BS8.pack "\ESC[?2004h"
57116
58117-- | Disable bracketed paste mode:
59−disableBracketedPastes :: String
60−disableBracketedPastes = "\ESC[?2004l"
118+disableBracketedPastes :: ByteString
119+disableBracketedPastes = BS8.pack "\ESC[?2004l"
61120
62121-- | These sequences set xterm based terminals to UTF-8 output.
63122--
64−-- \todo I don't know of a terminfo cap that is equivalent to this.
65−setUtf8CharSet, setDefaultCharSet :: String
66−setUtf8CharSet = "\ESC%G"
67−setDefaultCharSet = "\ESC%@"
68−
69−-- | I think xterm is broken: Reseting the background color as the first bytes serialized on a
70−-- new line does not effect the background color xterm uses to clear the line. Which is used
71−-- *after* the next newline.
123+-- There is no known terminfo capability equivalent to this.
124+setUtf8CharSet, setDefaultCharSet :: ByteString
125+setUtf8CharSet = BS8.pack "\ESC%G"
126+setDefaultCharSet = BS8.pack "\ESC%@"
127+
72128xtermInlineHack :: Output -> IO ()
73129xtermInlineHack t = do
74130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
75131 outputByteBuffer t $ writeToByteString writeReset
76−
src/Graphics/Vty/Picture.hs+71−45
@@ -1,25 +1,36 @@
1−{-# LANGUAGE BangPatterns #-}
2−-- | The 'Picture' data structure is representative of the final terminal view.
3−--
4−-- A 'Picture' is a background paired with a layer of 'Image's.
5−module Graphics.Vty.Picture ( module Graphics.Vty.Picture
6− , module Graphics.Vty.Image
7− )
8− where
1+-- A 'Picture' is a background paired with a set of 'Image' layers. The
2+-- 'Picture' data structure is representative of the final terminal
3+-- view.
4+module Graphics.Vty.Picture
5+ ( Picture(..)
6+ , Cursor(..)
7+ , Background(..)
8+ , emptyPicture
9+ , addToTop
10+ , addToBottom
11+ , picForImage
12+ , picForLayers
13+ , picImage
14+ )
15+where
916
1017import Graphics.Vty.Image
18+import Graphics.Vty.Attributes
1119
1220import Control.DeepSeq
1321
14−-- | The type of images to be displayed using 'update'.
22+-- | A Vty picture.
1523--
16−-- Can be constructed directly or using `picForImage`. Which provides an initial instance with
17−-- reasonable defaults for picCursor and picBackground.
24+-- These can be constructed directly or using `picForImage`.
1825data Picture = Picture
1926 { picCursor :: Cursor
27+ -- ^ The picture's cursor.
2028 , picLayers :: [Image]
29+ -- ^ The picture's image layers (top-most first).
2130 , picBackground :: Background
22− }
31+ -- ^ The picture's background to be displayed in locations with no
32+ -- Image data.
33+ } deriving Eq
2334
2435instance Show Picture where
2536 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"
@@ -27,79 +38,94 @@ instance Show Picture where
2738instance NFData Picture where
2839 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()
2940
30−-- | a picture with no cursor, background or image layers
41+-- | A picture with no cursor, background or image layers.
3142emptyPicture :: Picture
3243emptyPicture = Picture NoCursor [] ClearBackground
3344
34−-- | The given 'Image' is added as the top layer of the 'Picture'
45+-- | Add an 'Image' as the top-most layer of a 'Picture'.
3546addToTop :: Picture -> Image -> Picture
3647addToTop p i = p {picLayers = i : picLayers p}
3748
38−-- | The given 'Image' is added as the bottom layer of the 'Picture'
49+-- | Add an 'Image' as the bottom-most layer of a 'Picture'.
3950addToBottom :: Picture -> Image -> Picture
4051addToBottom p i = p {picLayers = picLayers p ++ [i]}
4152
42−-- | Create a picture for display for the given image. The picture will not have a displayed cursor
43−-- and no background pattern (ClearBackground) will be used.
53+-- | Create a picture from the given image. The picture will not have a
54+-- displayed cursor and no background pattern (ClearBackground) will be
55+-- used.
4456picForImage :: Image -> Picture
45−picForImage i = Picture
57+picForImage i = Picture
4658 { picCursor = NoCursor
4759 , picLayers = [i]
4860 , picBackground = ClearBackground
4961 }
5062
51−-- | Create a picture for display with the given layers. Ordered top to bottom.
63+-- | Create a picture with the given layers, top-most first.
5264--
53−-- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be
54−-- used.
55−--
56−-- The first 'Image' is the top layer.
65+-- The picture will not have a displayed cursor and no background
66+-- pattern (ClearBackgroun) will be used.
5767picForLayers :: [Image] -> Picture
58−picForLayers is = Picture
68+picForLayers is = Picture
5969 { picCursor = NoCursor
6070 , picLayers = is
6171 , picBackground = ClearBackground
6272 }
6373
64−-- | A picture can be configured either to not show the cursor or show the cursor at the specified
65−-- character position.
74+-- | A picture can be configured to hide the cursor or to show the
75+-- cursor at the specified character position.
6676--
67−-- There is not a 1 to 1 map from character positions to a row and column on the screen due to
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.
72−data Cursor =
73− NoCursor
74− | Cursor Int Int
77+-- There is not a 1:1 map from character positions to a row and column
78+-- on the screen due to characters that take more than 1 column.
79+data Cursor =
80+ -- | Hide the cursor
81+ NoCursor
82+ -- | Set the terminal's cursor position without displaying a cursor
83+ -- character. This is important for accessibility with screen
84+ -- readers where a cursor position needs to be reported but we may
85+ -- not want to show a block cursor in that location for cosmetic
86+ -- reasons. The boolean argument indicates whether the positioning
87+ -- should be absolute as with 'AbsoluteCursor' ('True') or logical
88+ -- as with 'Cursor' ('False').
89+ | PositionOnly !Bool !Int !Int
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
93+ -- | Show the cursor at the given absolute terminal column and row
94+ | AbsoluteCursor !Int !Int
95+ deriving Eq
7596
7697instance NFData Cursor where
77− rnf NoCursor = ()
78− rnf (Cursor w h) = w `seq` h `seq` ()
98+ rnf c = c `seq` ()
7999
80−-- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the
81−-- layer below or is blank if the bottom layer. Or the background pattern is a character and a
82−-- display attribute. If the display attribute used previously should be used for a background fill
83−-- then use `currentAttr` for the background attribute.
100+-- | A 'Picture' has a background pattern. The background is either:
101+--
102+-- * ClearBackground, which shows the layer below or is blank if the
103+-- bottom layer
104+-- * A character and a display attribute
84105--
85−-- \todo The current attribute is always set to the default attributes at the start of updating the
86−-- screen to a picture.
106+-- If the display attribute used previously should be used for a
107+-- background fill then use `currentAttr` for the background attribute.
87108data Background
88− = Background
109+ = Background
89110 { backgroundChar :: Char
90111 , backgroundAttr :: Attr
91112 }
92− -- | A ClearBackground is:
113+ -- | A ClearBackground is:
93114 --
94115 -- * the space character if there are remaining non-skip ops
95116 --
96117 -- * End of line if there are no remaining non-skip ops.
97118 | ClearBackground
119+ deriving Eq
98120
99121instance NFData Background where
100122 rnf (Background c a) = c `seq` a `seq` ()
101123 rnf ClearBackground = ()
102124
103−-- | Compatibility with applications that do not use more than a single layer.
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.
104130picImage :: Picture -> Image
105131picImage = head . picLayers
src/Graphics/Vty/PictureToSpans.hs+80−97
@@ -1,21 +1,14 @@
11-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
22{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE CPP #-}
43{-# LANGUAGE ExistentialQuantification #-}
54{-# LANGUAGE NamedFieldPuns #-}
65{-# LANGUAGE RankNTypes #-}
76{-# LANGUAGE TemplateHaskell #-}
87
9−#ifndef MIN_VERSION_base
10−#defined MIN_VERSION_base(x,y,z) 1
11−#endif
12−
13−{- | Transforms an image into rows of operations.
14− -}
8+-- | Transforms an image into rows of operations.
159module Graphics.Vty.PictureToSpans where
1610
17−import Graphics.Vty.Prelude
18−
11+import Graphics.Vty.Attributes (Attr, currentAttr)
1912import Graphics.Vty.Image
2013import Graphics.Vty.Image.Internal
2114import Graphics.Vty.Picture
@@ -26,12 +19,7 @@ import Lens.Micro.Mtl
2619import Lens.Micro.TH
2720import Control.Monad.Reader
2821import Control.Monad.State.Strict hiding ( state )
29−
30−#if __GLASGOW_HASKELL__ < 708
31−import Control.Monad.ST.Strict hiding ( unsafeIOToST )
32−#else
3322import Control.Monad.ST.Strict
34−#endif
3523
3624import qualified Data.Vector as Vector hiding ( take, replicate )
3725import Data.Vector.Mutable ( MVector(..))
@@ -39,29 +27,27 @@ import qualified Data.Vector.Mutable as MVector
3927
4028import qualified Data.Text.Lazy as TL
4129
42−#if !(MIN_VERSION_base(4,8,0))
43−import Data.Monoid (mappend)
44−#endif
45−
4630type MRowOps s = MVector s SpanOps
4731
4832type MSpanOps s = MVector s SpanOp
4933
5034-- transform plus clip. More or less.
5135data BlitState = BlitState
52− -- we always snoc to the operation vectors. Thus the columnOffset = length of row at rowOffset
53− -- although, one possibility is to merge layers right in snocOp (naming it something else, of
54− -- course). In which case columnnOffset would be applicable.
55− -- Right now we need it to exist.
36+ -- we always snoc to the operation vectors. Thus the columnOffset =
37+ -- length of row at rowOffset although, one possibility is to merge
38+ -- layers right in snocOp (naming it something else, of course). In
39+ -- which case columnnOffset would be applicable. Right now we need
40+ -- it to exist.
5641 { _columnOffset :: Int
5742 , _rowOffset :: Int
58− -- clip coordinate space is in image space. Which means it's >= 0 and < imageWidth.
43+ -- clip coordinate space is in image space. Which means it's >= 0
44+ -- and < imageWidth.
5945 , _skipColumns :: Int
6046 -- >= 0 and < imageHeight
6147 , _skipRows :: Int
62− -- includes consideration of skipColumns. In display space.
63− -- The number of columns from the next column to be defined to the end of the display for the
64− -- row.
48+ -- includes consideration of skipColumns. In display space. The
49+ -- number of columns from the next column to be defined to the end
50+ -- of the display for the row.
6551 , _remainingColumns :: Int
6652 -- includes consideration of skipRows. In display space.
6753 , _remainingRows :: Int
@@ -78,31 +64,29 @@ makeLenses ''BlitEnv
7864
7965type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
8066
81−-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
82−-- specified region.
67+-- | Produces the span ops that will render the given picture, possibly
68+-- cropped or padded, into the specified region.
8369displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
8470displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)
8571
86−-- | Returns the DisplayOps for an image rendered to a window the size of the image.
72+-- | Returns the DisplayOps for an image rendered to a window the size
73+-- of the image.
8774--
88−-- largerly used only for debugging.
75+-- largely used only for debugging.
8976displayOpsForImage :: Image -> DisplayOps
9077displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)
9178
9279-- | Produces the span ops for each layer then combines them.
93−--
94−-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
95−-- region.
9680combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
9781combinedOpsForLayers pic r
9882 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
9983 | otherwise = do
100− layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)
84+ layerOps <- mapM (`buildSpans` r) (picLayers pic)
10185 case layerOps of
10286 [] -> fail "empty picture"
10387 [ops] -> substituteSkips (picBackground pic) ops
104− -- instead of merging ops after generation the merging can be performed as part of
105− -- snocOp.
88+ -- instead of merging ops after generation the merging can
89+ -- be performed as part of snocOp.
10690 topOps : lowerOps -> do
10791 ops <- foldM mergeUnder topOps lowerOps
10892 substituteSkips (picBackground pic) ops
@@ -111,21 +95,23 @@ substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)
11195substituteSkips ClearBackground ops = do
11296 forM_ [0 .. MVector.length ops - 1] $ \row -> do
11397 rowOps <- MVector.read ops row
114− -- the image operations assure that background fills are combined.
115− -- clipping a background fill does not split the background fill.
116− -- merging of image layers can split a skip, but only by the insertion of a non skip.
117− -- all this combines to mean we can check the last operation and remove it if it's a skip
118− -- todo: or does it?
98+ -- the image operations assure that background fills are
99+ -- combined. clipping a background fill does not split the
100+ -- background fill. merging of image layers can split a 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
103+ -- skip
119104 let rowOps' = case Vector.last rowOps of
120105 Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w
121106 _ -> rowOps
122− -- now all the skips can be replaced by replications of ' ' of the required width.
107+ -- now all the skips can be replaced by replications of ' ' of
108+ -- the required width.
123109 let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'
124110 MVector.write ops row rowOps''
125111 return ops
126112substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do
127− -- At this point we decide if the background character is single column or not.
128− -- obviously, single column is easier.
113+ -- At this point we decide if the background character is single
114+ -- column or not. obviously, single column is easier.
129115 case safeWcwidth backgroundChar of
130116 w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar
131117 | w == 1 -> do
@@ -149,12 +135,12 @@ mergeUnder upper lower = do
149135 MVector.write upper row rowOps
150136 return upper
151137
152−-- fugly
153138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
154−mergeRowUnder upperRowOps lowerRowOps =
155− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps
139+mergeRowUnder upperRowOps =
140+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)
156141 where
157− -- H: it will never be the case that we are out of upper ops before lower ops.
142+ -- H: it will never be the case that we are out of upper ops
143+ -- before lower ops.
158144 onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
159145 onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =
160146 let lowerOps' = dropOps w lowerOps
@@ -189,30 +175,32 @@ swapSkipsForCharSpan w c a = Vector.map f
189175 in TextSpan a ow cw txt
190176 f v = v
191177
192−-- | Builds a vector of row operations that will output the given picture to the terminal.
178+-- | Builds a vector of row operations that will output the given
179+-- picture to the terminal.
193180--
194181-- Crops to the given display region.
195−--
196−-- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer.
197182buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
198183buildSpans image outRegion = do
199184 -- First we create a mutable vector for each rows output operations.
200185 outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
201− -- \todo I think building the span operations in display order would provide better performance.
202− -- However, I got stuck trying to implement an algorithm that did this. This will be considered
203− -- as a possible future optimization.
186+ -- It's possible that building the span operations in display order
187+ -- would provide better performance.
204188 --
205− -- A depth first traversal of the image is performed. ordered according to the column range
206− -- defined by the image from least to greatest. The output row ops will at least have the
207− -- region of the image specified. Iterate over all output rows and output background fills for
208− -- all unspecified columns.
189+ -- A depth first traversal of the image is performed. ordered
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
192+ -- of the image specified. Iterate over all output rows and output
193+ -- background fills for all unspecified columns.
209194 --
210− -- The images are made into span operations from left to right. It's possible that this could
211− -- easily be made to assure top to bottom output as well.
195+ -- The images are made into span operations from left to right. It's
196+ -- possible that this could easily be made to assure top to bottom
197+ -- output as well.
212198 when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do
213− -- The ops builder recursively descends the image and outputs span ops that would
214− -- display that image. The number of columns remaining in this row before exceeding the
215− -- bounds is also provided. This is used to clip the span ops produced to the display.
199+ -- The ops builder recursively descends the image and outputs
200+ -- span ops that would display that image. The number of columns
201+ -- remaining in this row before exceeding the bounds is also
202+ -- provided. This is used to clip the span ops produced to the
203+ -- display.
216204 let fullBuild = do
217205 startImageBuild image
218206 -- Fill in any unspecified columns with a skip.
@@ -223,7 +211,8 @@ buildSpans image outRegion = do
223211 return ()
224212 return outOps
225213
226−-- | Add the operations required to build a given image to the current set of row operations.
214+-- | Add the operations required to build a given image to the current
215+-- set of row operations.
227216startImageBuild :: Image -> BlitM s ()
228217startImageBuild image = do
229218 outOfBounds <- isOutOfBounds image <$> get
@@ -237,17 +226,16 @@ isOutOfBounds i s
237226 | s ^. skipRows >= imageHeight i = True
238227 | otherwise = False
239228
240−-- | This adds an image that might be partially clipped to the output ops.
241−--
242−-- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom
243−-- implementations are odd. They pass the current tests but something seems terribly wrong about all
244−-- this.
229+-- | This adds an image that might be partially clipped to the output
230+-- ops.
245231--
246−-- \todo prove this cannot be called in an out of bounds case.
232+-- This is a very touchy algorithm. Too touchy. For instance, the
233+-- CropRight and CropBottom implementations are odd. They pass the
234+-- current tests but something seems terribly wrong about all this.
247235addMaybeClipped :: forall s . Image -> BlitM s ()
248236addMaybeClipped EmptyImage = return ()
249237addMaybeClipped (HorizText a textStr ow _cw) = do
250− -- TODO: assumption that text spans are only 1 row high.
238+ -- This assumes that text spans are only 1 row high.
251239 s <- use skipRows
252240 when (s < 1) $ do
253241 leftClip <- use skipColumns
@@ -259,17 +247,19 @@ addMaybeClipped (HorizText a textStr ow _cw) = do
259247 in addUnclippedText a textStr'
260248 else addUnclippedText a textStr
261249addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do
262− addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset
263− (imageHeight topImage)
264− topImage
265− bottomImage
266− oh
250+ when (imageHeight topImage + imageHeight bottomImage > 0) $
251+ addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset
252+ (imageHeight topImage)
253+ topImage
254+ bottomImage
255+ oh
267256addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do
268− addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset
269− (imageWidth leftImage)
270− leftImage
271− rightImage
272− ow
257+ when (imageWidth leftImage + imageWidth rightImage > 0) $
258+ addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset
259+ (imageWidth leftImage)
260+ leftImage
261+ rightImage
262+ ow
273263addMaybeClipped BGFill {outputWidth, outputHeight} = do
274264 s <- get
275265 let outputWidth' = min (outputWidth - s^.skipColumns) (s^.remainingColumns)
@@ -295,7 +285,7 @@ addMaybeClipped CropTop {croppedImage, topSkip} = do
295285 skipRows += topSkip
296286 addMaybeClipped croppedImage
297287
298−addMaybeClippedJoin :: forall s . String
288+addMaybeClippedJoin :: forall s . String
299289 -> Lens BlitState BlitState Int Int
300290 -> Lens BlitState BlitState Int Int
301291 -> Lens BlitState BlitState Int Int
@@ -308,12 +298,11 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
308298 state <- get
309299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"
310300 case state^.skip of
311− s -- TODO: check if clipped in other dim. if not use addUnclipped
312− | s >= size -> fail $ name ++ " on fully clipped"
313− | s == 0 -> if state^.remaining > i0Dim
301+ s | s > size -> put $ state & skip %~ subtract size
302+ | s == 0 -> if state^.remaining > i0Dim
314303 then do
315304 addMaybeClipped i0
316− put $ state & offset +~ i0Dim & remaining -~ i0Dim
305+ put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim
317306 addMaybeClipped i1
318307 else addMaybeClipped i0
319308 | s < i0Dim ->
@@ -322,10 +311,10 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
322311 then addMaybeClipped i0
323312 else do
324313 addMaybeClipped i0
325− put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0
314+ put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0
326315 addMaybeClipped i1
327316 | s >= i0Dim -> do
328− put $ state & skip -~ i0Dim
317+ put $ state & skip %~ subtract i0Dim
329318 addMaybeClipped i1
330319 _ -> fail $ name ++ " has unhandled skip class"
331320
@@ -334,14 +323,14 @@ addUnclippedText a txt = do
334323 let op = TextSpan a usedDisplayColumns
335324 (fromIntegral $ TL.length txt)
336325 txt
337− usedDisplayColumns = wcswidth $ TL.unpack txt
326+ usedDisplayColumns = wctlwidth txt
338327 use rowOffset >>= snocOp op
339328
340329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
341330addRowCompletion displayRegion row = do
342331 allRowOps <- view mrowOps
343332 rowOps <- lift $ lift $ MVector.read allRowOps row
344− let endX = spanOpsEffectedColumns rowOps
333+ let endX = spanOpsAffectedColumns rowOps
345334 when (endX < regionWidth displayRegion) $ do
346335 let ow = regionWidth displayRegion - endX
347336 snocOp (Skip ow) row
@@ -354,12 +343,6 @@ snocOp !op !row = do
354343 lift $ lift $ do
355344 ops <- MVector.read theMrowOps row
356345 let ops' = Vector.snoc ops op
357− when (spanOpsEffectedColumns ops' > regionWidth theRegion)
346+ when (spanOpsAffectedColumns ops' > regionWidth theRegion)
358347 $ fail $ "row " ++ show row ++ " now exceeds region width"
359348 MVector.write theMrowOps row ops'
360−
361−(-~) :: Num a => ASetter s t a a -> a -> s -> t
362−l -~ n = over l (subtract n)
363−
364−(+~) :: Num a => ASetter s t a a -> a -> s -> t
365−l +~ n = over l (n +)
src/Graphics/Vty/Prelude.hsdeleted−18
@@ -1,18 +0,0 @@
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−regionWidth :: DisplayRegion -> Int
15−regionWidth = fst
16−
17−regionHeight :: DisplayRegion -> Int
18−regionHeight = snd
src/Graphics/Vty/Span.hs+46−55
@@ -1,23 +1,15 @@
11-- Copyright Corey O'Connor
2−{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE NamedFieldPuns #-}
42{-# LANGUAGE GADTs #-}
5−{- | A picture is translated into a sequences of state changes and character spans.
6− - State changes are currently limited to new attribute values. The attribute is applied to all
7− - following spans. Including spans of the next row. The nth element of the sequence represents the
8− - nth row (from top to bottom) of the picture to render.
9− -
10− - A span op sequence will be defined for all rows and columns (and no more) of the region provided
11− - with the picture to `spansForPic`.
12− -
13− - todo: Partition attribute changes into multiple categories according to the serialized
14− - representation of the various attributes.
15− -}
16−module Graphics.Vty.Span
17− where
18−
19−import Graphics.Vty.Prelude
3+-- | A picture is translated into a sequences of state changes and
4+-- character spans. The attribute is applied to all following spans,
5+-- including spans of the next row. The nth element of the sequence
6+-- represents the nth row (from top to bottom) of the picture to render.
7+--
8+-- A span op sequence will be defined for all rows and columns (and no
9+-- more) of the region provided with the picture to 'spansForPic'.
10+module Graphics.Vty.Span where
2011
12+import Graphics.Vty.Attributes (Attr)
2113import Graphics.Vty.Image
2214import Graphics.Vty.Image.Internal ( clipText )
2315
@@ -25,40 +17,40 @@ import qualified Data.Text.Lazy as TL
2517import Data.Vector (Vector)
2618import qualified Data.Vector as Vector
2719
28−-- | This represents an operation on the terminal. Either an attribute change or the output of a
29−-- text string.
20+-- | This represents an operation on the terminal: either an attribute
21+-- change or the output of a text string.
3022data SpanOp =
31− -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
32− -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width
33− -- TextSpan [Attr] [output width in columns] [number of characters] [data]
34− TextSpan
23+ -- | A span of UTF-8 text occupies a specific number of screen space
24+ -- columns. A single UTF character does not necessarily represent 1
25+ -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width
26+ -- in columns] [number of characters] [data]
27+ TextSpan
3528 { textSpanAttr :: !Attr
3629 , textSpanOutputWidth :: !Int
3730 , textSpanCharWidth :: !Int
3831 , textSpanText :: DisplayText
3932 }
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.
33+ -- | Skips the given number of columns.
4334 | Skip !Int
44− -- | Marks the end of a row. specifies how many columns are remaining. These columns will not be
45− -- explicitly overwritten with the span ops. The terminal is require to assure the remaining
35+ -- | Marks the end of a row. Specifies how many columns are
36+ -- remaining. These columns will not be explicitly overwritten with
37+ -- the span ops. The terminal is require to assure the remaining
4638 -- columns are clear.
47− -- todo: separate from this type.
4839 | RowEnd !Int
4940 deriving Eq
5041
51−-- | vector of span operations. executed in succession. This represents the operations required to
52−-- render a row of the terminal. The operations in one row may effect subsequent rows.
53−-- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground
54−-- color is changed.
42+-- | A vector of span operations executed in succession. This represents
43+-- the operations required to render a row of the terminal. The
44+-- operations in one row may affect subsequent rows. For example,
45+-- setting the foreground color in one row will affect all subsequent
46+-- rows until the foreground color is changed.
5547type SpanOps = Vector SpanOp
5648
5749dropOps :: Int -> SpanOps -> SpanOps
5850dropOps w = snd . splitOpsAt w
5951
6052splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)
61−splitOpsAt inW inOps = splitOpsAt' inW inOps
53+splitOpsAt = splitOpsAt'
6254 where
6355 splitOpsAt' 0 ops = (Vector.empty, ops)
6456 splitOpsAt' remainingColumns ops = case Vector.head ops of
@@ -89,9 +81,9 @@ splitOpsAt inW inOps = splitOpsAt' inW inOps
8981 , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops)
9082 )
9183 RowEnd _ -> error "cannot split ops containing a row end"
92−
9384
94−-- | vector of span operation vectors for display. One per row of the output region.
85+-- | A vector of span operation vectors for display, one per row of the
86+-- output region.
9587type DisplayOps = Vector SpanOps
9688
9789instance Show SpanOp where
@@ -99,40 +91,39 @@ instance Show SpanOp where
9991 show (Skip ow) = "Skip(" ++ show ow ++ ")"
10092 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
10193
102−-- | Number of columns the DisplayOps are defined for
94+-- | The number of columns the DisplayOps are defined for.
10395--
104−-- All spans are verified to define same number of columns. See: VerifySpanOps
96+-- All spans are verified to define same number of columns.
10597displayOpsColumns :: DisplayOps -> Int
106−displayOpsColumns ops
98+displayOpsColumns ops
10799 | Vector.length ops == 0 = 0
108100 | otherwise = Vector.length $ Vector.head ops
109101
110−-- | Number of rows the DisplayOps are defined for
102+-- | The number of rows the DisplayOps are defined for.
111103displayOpsRows :: DisplayOps -> Int
112−displayOpsRows ops = Vector.length ops
104+displayOpsRows = Vector.length
113105
114−effectedRegion :: DisplayOps -> DisplayRegion
115−effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
106+affectedRegion :: DisplayOps -> DisplayRegion
107+affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
116108
117−-- | The number of columns a SpanOps effects.
118−spanOpsEffectedColumns :: SpanOps -> Int
119−spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
120− where
121− spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
122− spanOpsEffectedColumns' t (Skip w) = t + w
123− spanOpsEffectedColumns' t (RowEnd w) = t + w
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
124116
125−-- | The width of a single SpanOp in columns
117+-- | The width of a single SpanOp in columns.
126118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)
127119spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)
128120spanOpHasWidth (Skip ow) = Just (ow,ow)
129121spanOpHasWidth (RowEnd ow) = Just (ow,ow)
130122
131−-- | returns the number of columns to the character at the given position in the span op
123+-- | The number of columns to the character at the given position in the
124+-- span op.
132125columnsToCharOffset :: Int -> SpanOp -> Int
133126columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
134− let str = TL.unpack utf8Str
135− in wcswidth (take cx str)
127+ wctlwidth (TL.take (fromIntegral cx) utf8Str)
136128columnsToCharOffset cx (Skip _) = cx
137129columnsToCharOffset cx (RowEnd _) = cx
138−
src/Graphics/Vty/UnicodeWidthTable/IO.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# LANGUAGE CPP #-}
2+module Graphics.Vty.UnicodeWidthTable.IO
3+ ( readUnicodeWidthTable
4+ , parseUnicodeWidthTable
5+ , writeUnicodeWidthTable
6+ )
7+where
8+
9+import Control.Monad (when, forM)
10+import Data.Binary
11+import Data.Binary.Get
12+import Data.Binary.Put
13+import qualified Data.ByteString.Lazy as BSL
14+#if !(MIN_VERSION_base(4,11,0))
15+import Data.Semigroup ((<>))
16+#endif
17+
18+import Graphics.Vty.UnicodeWidthTable.Types
19+
20+-- | Load a binary unicode width table from the specified file.
21+--
22+-- This either returns a successfully parsed table or a table parsing
23+-- error message. This does not handle I/O exceptions.
24+readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)
25+readUnicodeWidthTable path = parseUnicodeWidthTable <$> BSL.readFile path
26+
27+-- | Parse a binary unicode width table.
28+parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable
29+parseUnicodeWidthTable bs =
30+ case runGetOrFail tableParser bs of
31+ Left (_, _, msg) ->
32+ Left msg
33+
34+ -- Even if we parsed a table, leftover bytes indicate something
35+ -- could be wrong.
36+ Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->
37+ Left $ "Error: " <> show (BSL.length remainingBytes) <>
38+ " byte(s) left unconsumed"
39+
40+ Right (_, _, table) ->
41+ Right table
42+
43+-- | Write the unicode width table to the specified path.
44+--
45+-- This does not handle I/O exceptions.
46+writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
47+writeUnicodeWidthTable path table = do
48+ let body = runPut (tableV1Writer table)
49+ BSL.writeFile path body
50+
51+-- | Width table magic bytes for use in the binary format.
52+widthTableMagic :: Word32
53+widthTableMagic = 0xc1a9f7e0
54+
55+tableParser :: Get UnicodeWidthTable
56+tableParser = do
57+ magic <- getWord32le
58+
59+ when (magic /= widthTableMagic) $
60+ fail "Table magic number invalid"
61+
62+ version <- getWord8
63+
64+ case version of
65+ 1 -> tableV1Parser
66+ _ -> fail "Table version invalid"
67+
68+tableV1Parser :: Get UnicodeWidthTable
69+tableV1Parser = do
70+ numRanges <- getWord32le
71+
72+ let parseRange = do
73+ start <- getWord32le
74+ size <- getWord32le
75+ cols <- getWord8
76+ return WidthTableRange { rangeStart = start
77+ , rangeSize = size
78+ , rangeColumns = cols
79+ }
80+
81+ ranges <- forM [1..numRanges] $ const parseRange
82+
83+ return UnicodeWidthTable { unicodeWidthTableRanges = ranges
84+ }
85+
86+tableV1Writer :: UnicodeWidthTable -> Put
87+tableV1Writer table = do
88+ -- Magic bytes
89+ putWord32le widthTableMagic
90+
91+ -- Version
92+ putWord8 1
93+
94+ -- Number of ranges
95+ let ranges = unicodeWidthTableRanges table
96+ let numRanges = length ranges
97+ putWord32le (fromIntegral numRanges)
98+
99+ -- Ranges
100+ let putRange r = do
101+ putWord32le $ rangeStart r
102+ putWord32le $ rangeSize r
103+ putWord8 $ rangeColumns r
104+
105+ mapM_ putRange ranges
src/Graphics/Vty/UnicodeWidthTable/Install.hsnew file+129
@@ -0,0 +1,129 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+module Graphics.Vty.UnicodeWidthTable.Install
4+ ( TableInstallException(..)
5+ , installUnicodeWidthTable
6+ , isCustomTableReady
7+ )
8+where
9+
10+import Control.Monad (when, forM_)
11+import qualified Control.Exception as E
12+import GHC.Conc.Sync (withMVar)
13+import Control.Concurrent.MVar (MVar, newMVar)
14+import Data.Word (Word8, Word32)
15+#if !(MIN_VERSION_base(4,11,0))
16+import Data.Semigroup ((<>))
17+#endif
18+import System.IO.Unsafe (unsafePerformIO)
19+
20+import Graphics.Vty.UnicodeWidthTable.Types
21+
22+-- | The lock used to make functions in this module thread-safe.
23+installLock :: MVar ()
24+{-# NOINLINE installLock #-}
25+installLock = unsafePerformIO $ newMVar ()
26+
27+-- | Returns True if and only if a custom table has been allocated and
28+-- marked as ready for use.
29+--
30+-- This function is thread-safe.
31+isCustomTableReady :: IO Bool
32+isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady
33+
34+withInstallLock :: IO a -> IO a
35+withInstallLock act = withMVar installLock $ const act
36+
37+-- This is the size of the allocated custom character width table, in
38+-- character slots. It's important that this be large enough to hold all
39+-- possible Unicode character values. At the time of this writing, the
40+-- valid Unicode range is 0 - 0x10ffff, hence this value.
41+tableSize :: Int
42+tableSize = 0x110000
43+
44+-- | Exception type raised by 'installUnicodeWidthTable'.
45+data TableInstallException =
46+ TableInitFailure Int Int
47+ -- ^ The width table could not be initialized. Args: failure status,
48+ -- requested table size.
49+ | TableRangeFailure Int WidthTableRange
50+ -- ^ A code point range could not be configured. Args: failure
51+ -- status, offending range.
52+ | TableActivationFailure Int
53+ -- ^ The table could not be activated. Args: failure status.
54+ deriving (Eq, Show)
55+
56+instance E.Exception TableInstallException
57+
58+-- | Install a custom unicode character width
59+-- table. Such tables are obtained with
60+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and
61+-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.
62+--
63+-- ALERT! This function is probably not what you want to use because
64+-- it is automatically called by 'Graphics.Vty.mkVty'. You will only
65+-- ever need to call this function if you want to use functions
66+-- in 'Graphics.Text.Width' without controlling the terminal with
67+-- 'Graphics.Vty.mkVty'.
68+--
69+-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'
70+-- function and functions that call it. It does so by
71+-- changing global state available to the C implementation
72+-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your
73+-- program gets consistent results from evaluating calls to
74+-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table
75+-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in
76+-- your program.
77+--
78+-- This is best done at Vty startup, and if you use
79+-- 'Graphics.Vty.mkVty', that function calls this automatically based on
80+-- the Vty configuration's declared width tables. It is exposed as part
81+-- of the public API so that applications can call this as needed if
82+-- they don't want to control the terminal with 'mkVty' but do want to
83+-- make calls to 'Graphics.Vty.Image.wcwidth'.
84+--
85+-- It's also important to note that once a custom table has been
86+-- installed, it is permanent for the life of the process. No new table
87+-- can be installed, and the new custom table cannot be removed.
88+--
89+-- If this function fails for any reason -- if the table cannot be
90+-- installed or is invalid, or if a custom table already exists -- this
91+-- will raise a 'TableInstallException' exception.
92+--
93+-- This function is thread-safe.
94+installUnicodeWidthTable :: UnicodeWidthTable -> IO ()
95+installUnicodeWidthTable table = withInstallLock $ do
96+ initResult <- initCustomTable tableSize
97+ when (initResult /= 0) $
98+ E.throwIO $ TableInitFailure initResult tableSize
99+
100+ forM_ (unicodeWidthTableRanges table) $ \r -> do
101+ result <- setCustomTableRange (rangeStart r)
102+ (rangeSize r)
103+ (rangeColumns r)
104+
105+ when (result /= 0) $ do
106+ deallocateCustomTable
107+ E.throwIO $ TableRangeFailure result r
108+
109+ actResult <- activateCustomTable
110+ when (actResult /= 0) $
111+ E.throwIO $ TableActivationFailure actResult
112+
113+------------------------------------------------------------------------
114+-- C imports
115+
116+foreign import ccall unsafe "vty_init_custom_table"
117+ initCustomTable :: Int -> IO Int
118+
119+foreign import ccall unsafe "vty_set_custom_table_range"
120+ setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int
121+
122+foreign import ccall unsafe "vty_activate_custom_table"
123+ activateCustomTable :: IO Int
124+
125+foreign import ccall unsafe "vty_custom_table_ready"
126+ c_isCustomTableReady :: IO Int
127+
128+foreign import ccall unsafe "vty_deallocate_custom_table"
129+ deallocateCustomTable :: IO ()
src/Graphics/Vty/UnicodeWidthTable/Query.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# LANGUAGE TupleSections #-}
2+module Graphics.Vty.UnicodeWidthTable.Query
3+ ( buildUnicodeWidthTable
4+ , defaultUnicodeTableUpperBound
5+ )
6+where
7+
8+import Control.Monad (forM)
9+import Data.Char (generalCategory, GeneralCategory(..))
10+import System.Console.ANSI (getCursorPosition)
11+import Text.Printf (printf)
12+
13+import Graphics.Vty.UnicodeWidthTable.Types
14+
15+shouldConsider :: Char -> Bool
16+shouldConsider c =
17+ case generalCategory c of
18+ Control -> False
19+ NotAssigned -> False
20+ Surrogate -> False
21+ _ -> True
22+
23+charWidth :: Char -> IO Int
24+charWidth c = do
25+ printf "\r"
26+ putChar c
27+ Just (_, col) <- getCursorPosition
28+ return col
29+
30+-- | Convert a sequence of character/width pairs into a list of
31+-- run-length encoded ranges. This function assumes the pairs come
32+-- sorted by character ordinal value. It does not require that the
33+-- character range is fully covered by the sequence.
34+--
35+-- The result of this function is a list of ranges in reverse order
36+-- relative to the input sequence.
37+mkRanges :: [(Char, Int)] -> [WidthTableRange]
38+mkRanges pairs =
39+ let convertedPairs = convert <$> pairs
40+ convert (c, i) = (fromIntegral $ fromEnum c, fromIntegral i)
41+
42+ go Nothing finishedRanges [] = finishedRanges
43+ go (Just r) finishedRanges [] = r:finishedRanges
44+
45+ go Nothing finishedRanges ((c, width):rest) =
46+ go (Just $ WidthTableRange c 1 width) finishedRanges rest
47+
48+ go (Just r@(WidthTableRange prevCh sz prevWidth)) finishedRanges ((c, width):rest) =
49+ if c == prevCh + sz && prevWidth == width
50+ then go (Just (WidthTableRange prevCh (sz + 1) prevWidth)) finishedRanges rest
51+ else go (Just (WidthTableRange c 1 width)) (r:finishedRanges) rest
52+
53+ in go Nothing [] convertedPairs
54+
55+-- The uppermost code point to consider when building Unicode width
56+-- tables.
57+defaultUnicodeTableUpperBound :: Char
58+defaultUnicodeTableUpperBound = '\xe0000'
59+
60+-- | Construct a unicode character width table by querying the terminal
61+-- connected to stdout. This works by emitting characters to stdout
62+-- and then querying the terminal to determine the resulting cursor
63+-- position in order to measure character widths. Consequently this will
64+-- generate a lot of output and may take a while, depending on your
65+-- system performance. This should not be run in a terminal while it is
66+-- controlled by Vty.
67+--
68+-- The argument specifies the upper bound code point to test when
69+-- building the table. This allows callers to decide how much of the
70+-- Unicode code point space to scan when building the table.
71+--
72+-- This does not handle exceptions.
73+buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
74+buildUnicodeWidthTable tableUpperBound = do
75+ pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i ->
76+ (i,) <$> charWidth i
77+
78+ return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs
79+ }
src/Graphics/Vty/UnicodeWidthTable/Types.hsnew file+29
@@ -0,0 +1,29 @@
1+module Graphics.Vty.UnicodeWidthTable.Types
2+ ( UnicodeWidthTable(..)
3+ , WidthTableRange(..)
4+ )
5+where
6+
7+import Data.Word (Word8, Word32)
8+
9+-- | A range of code points in a width table.
10+data WidthTableRange =
11+ WidthTableRange { rangeStart :: Word32
12+ -- ^ The range's starting code point.
13+ , rangeSize :: Word32
14+ -- ^ The number of code points in the contiguous
15+ -- range, beginning with the starting code point
16+ -- ('rangeStart').
17+ , rangeColumns :: Word8
18+ -- ^ The terminal width, in columns, of all of the
19+ -- characters corresponding to the code points in
20+ -- this range.
21+ }
22+ deriving (Eq, Show)
23+
24+-- | A run-length-encoded table of Unicode character widths.
25+data UnicodeWidthTable =
26+ UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
27+ -- ^ The ranges in the table.
28+ }
29+ deriving (Show)
stack.yamldeleted−40
@@ -1,40 +0,0 @@
1−# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html
2−
3−# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
4−resolver: lts-5.11
5−
6−# Local packages, usually specified by relative directory name
7−packages:
8−- '.'
9−- test/
10−
11−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
12−extra-deps: []
13−
14−# Override default flag values for local packages and extra-deps
15−flags: {}
16−
17−# Extra package databases containing global packages
18−extra-package-dbs: []
19−
20−nix:
21− enable: true
22− packages: [ncurses]
23−
24−# Control whether we use the GHC we find on the path
25−# system-ghc: true
26−
27−# Require a specific version of stack, using version ranges
28−# require-stack-version: -any # Default
29−# require-stack-version: >= 1.0.0
30−
31−# Override the architecture used by stack, especially useful on Windows
32−# arch: i386
33−# arch: x86_64
34−
35−# Extra directories used by stack for building
36−# extra-include-dirs: [/path/to/dir]
37−# extra-lib-dirs: [/path/to/dir]
38−
39−# Allow a newer minor version of GHC than the snapshot specifies
40−# compiler-check: newer-minor
test/BenchImageFuzz.hs+1−3
@@ -8,8 +8,6 @@ import Verify
88import Control.Applicative
99import Control.Monad
1010
11−import Data.Default (def)
12−
1311import System.Random
1412
1513rand :: Arbitrary a => IO a
@@ -21,7 +19,7 @@ randomImage = rand
2119randomPicture = picForImage <$> randomImage
2220
2321bench0 = do
24− vty <- mkVty def
22+ vty <- mkVty defaultConfig
2523 (w,h) <- displayBounds $ outputIface vty
2624 let pictures = replicateM 3000 randomPicture
2725 bench ps = do
test/BenchNoDiffOpt.hs+3−4
@@ -9,17 +9,16 @@ import Control.Concurrent( threadDelay )
99import Control.Monad( liftM2 )
1010
1111import qualified Data.ByteString.Char8 as B
12−import Data.Default (def)
1312import Data.List
1413
1514import System.Environment( getArgs )
1615import System.IO
1716import System.Random
1817
19−bench0 = do
18+bench0 = do
2019 let fixedGen = mkStdGen 0
2120 setStdGen fixedGen
22− vty <- mkVty def
21+ vty <- mkVty defaultConfig
2322 (w,h) <- displayBounds $ outputIface vty
2423 let images = return $ (image0, image1)
2524 image0 = charFill defAttr 'X' w h
@@ -29,7 +28,7 @@ bench0 = do
2928 shutdown vty
3029 return $ Bench images bench
3130
32−flipOut vty n image0 image1 =
31+flipOut vty n image0 image1 =
3332 let !pLeft = picForImage image0
3433 !pRight = picForImage image1
3534 wLeft 0 = return ()
test/BenchRenderChar.hs+7−9
@@ -1,7 +1,7 @@
1−{- benchmarks composing images using the renderChar operation.
2− - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally
3− - composed should provide no worse performance than a fill render op.
4− -}
1+-- benchmarks composing images using the renderChar operation. This is
2+-- what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar
3+-- images horizontally composed should provide no worse performance than
4+-- a fill render op.
55module BenchRenderChar where
66
77import Graphics.Vty
@@ -9,10 +9,8 @@ import Verify
99
1010import Control.Monad ( forM_ )
1111
12−import Data.Default (def)
13−
1412bench0 = do
15− vty <- mkVty def
13+ vty <- mkVty defaultConfig
1614 (w,h) <- displayBounds $ outputIface vty
1715 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
1816 bench d = do
@@ -23,12 +21,12 @@ bench0 = do
2321 shutdown vty
2422 return $ Bench testChars bench
2523
26−testImageUsingChar c w h
24+testImageUsingChar c w h
2725 = vertCat $ replicate (fromIntegral h)
2826 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
2927
3028bench1 = do
31− vty <- mkVty def
29+ vty <- mkVty defaultConfig
3230 (w,h) <- displayBounds $ outputIface vty
3331 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
3432 bench d = do
test/BenchVerticalScroll.hs+4−6
@@ -6,7 +6,6 @@ import Verify
66import Control.Concurrent( threadDelay )
77import Control.Monad( liftM2 )
88
9−import Data.Default (def)
109import Data.List
1110import Data.Word
1211
@@ -14,10 +13,10 @@ import System.Environment( getArgs )
1413import System.IO
1514import System.Random
1615
17−bench0 = do
16+bench0 = do
1817 let fixedGen = mkStdGen 0
1918 setStdGen fixedGen
20− return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)
19+ return $ Bench (return ()) (\() -> mkVty defaultConfig >>= liftM2 (>>) run shutdown)
2120
2221run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)
2322
@@ -49,13 +48,12 @@ pad :: Int -> Image -> Image
4948pad ml img = img <|> charFill defAttr ' ' (ml - imageWidth img) 1
5049
5150clines :: StdGen -> Int -> [Image]
52−clines g maxll = map (pad maxll . horizCat . map (uncurry string))
51+clines g maxll = map (pad maxll . horizCat . map (uncurry string))
5352 $ fold (length . snd) (lengths maxll g1) (nums g2)
5453 where (g1,g2) = split g
5554
5655benchgen :: DisplayRegion -> [Picture]
57−benchgen (w,h)
56+benchgen (w,h)
5857 = take 2000 $ map ((\i -> picForImage i) . vertCat . take (fromEnum h))
5958 $ tails
6059 $ clines (mkStdGen 80) w
61−
test/ControlTable.hs+1−1
@@ -5,7 +5,7 @@ import Graphics.Vty.ControlStrings
55import System.Console.Terminfo
66
77main = do
8− terminal <- setupTermFromEnv
8+ terminal <- setupTermFromEnv
99 controlTable <- init_controlTable terminal
1010 putStrLn $ "ANSI terminal show cursor string: " ++ show cvis
1111 putStrLn $ "Current terminal show cursor string: " ++ show (showCursorStr controlTable)
test/EventEcho.hs+1−2
@@ -6,7 +6,6 @@ import Control.Applicative
66import Control.Arrow
77import Control.Monad.RWS
88
9−import Data.Default (def)
109import Data.Sequence (Seq, (<|) )
1110import qualified Data.Sequence as Seq
1211import Data.Foldable
@@ -16,7 +15,7 @@ eventBufferSize = 1000
1615type App = RWST Vty () (Seq String) IO
1716
1817main = do
19− vty <- mkVty def
18+ vty <- mkVty defaultConfig
2019 _ <- execRWST (vtyInteract False) vty Seq.empty
2120 shutdown vty
2221
test/HereDoc.hs+2−4
@@ -1,8 +1,7 @@
11{-# LANGUAGE QuasiQuotes #-}
22{-# LANGUAGE TemplateHaskell #-}
3−{- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/
4− - copyright unknown?
5− -}
3+-- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/
4+-- copyright unknown?
65module HereDoc (heredoc) where
76
87import Language.Haskell.TH.Quote
@@ -11,4 +10,3 @@ import Language.Haskell.TH.Lib
1110
1211heredoc :: QuasiQuoter
1312heredoc = QuasiQuoter (litE . stringL) (litP . stringL) undefined undefined
14−
test/Issue18.hs+4−6
@@ -1,5 +1,4 @@
1−module Main
2− where
1+module Main where
32
43import Graphics.Vty
54import Graphics.Vty.Debug
@@ -13,8 +12,8 @@ main = do
1312 play vty sx sy
1413
1514play :: Vty -> Int -> Int -> IO ()
16−play vty sx sy =
17− let
15+play vty sx sy =
16+ let
1817 testScreen = pic {
1918 pCursor = NoCursor
2019 , pImage = box 10 10 }
@@ -31,6 +30,5 @@ box w h =
3130 vertLine = renderFill attr '|' 1 (h - 2)
3231 horizLine = corner <|> renderHFill attr '-' (w - 2) <|> corner
3332 centerArea = vertLine <|> renderFill attr 'X' (w - 2) (h - 2) <|> vertLine
34− in
33+ in
3534 horizLine <-> centerArea <-> horizLine
36−
test/Makefile+2−2
@@ -45,7 +45,7 @@ all : $(VERIF_TESTS)
4545
4646.PHONY: $(TESTS)
4747.SECONDEXPANSION:
48−$(TESTS) :
48+$(TESTS) :
4949 @echo running test $@
5050 @mkdir -p results/$@
5151 ( ghc $(GHC_PROF_ARGS) $@ \
@@ -54,7 +54,7 @@ $(TESTS) :
5454 )
5555
5656.PHONY: interactive_terminal_test
57−interactive_terminal_test :
57+interactive_terminal_test :
5858 ghc $(GHC_ARGS) $@ && ./$@
5959
6060.PHONY: core
test/MinimalExample.hs+1−3
@@ -2,10 +2,8 @@ module Main where
22
33import Graphics.Vty
44
5−import Data.Default
6−
75main = do
8− vty <- mkVty def
6+ vty <- mkVty defaultConfig
97 let line0 = string (def `withForeColor` green) "first line"
108 line1 = string (def `withBackColor` blue) "second line"
119 img = line0 <-> line1
test/Rogue.hs+1−3
@@ -1,10 +1,8 @@
1−{-# LANGUAGE TemplateHaskell #-}
21module Main where
32
43import Graphics.Vty
54
65import Data.Array
7−import Data.Default (def)
86
97import Control.Applicative
108import Control.Monad
@@ -43,7 +41,7 @@ type Coord = (Int, Int)
4341
4442main :: IO ()
4543main = do
46− vty <- mkVty def
44+ vty <- mkVty defaultConfig
4745 level0 <- mkLevel 1
4846 let world0 = World (Player (levelStart level0)) level0
4947 (_finalWorld, ()) <- execRWST play vty world0
test/Test2.hs+1
@@ -1,4 +1,5 @@
11module Main where
2+
23import Graphics.Vty
34
45main = do
test/Verify.hs+20−31
@@ -1,29 +1,29 @@
11{-# LANGUAGE RankNTypes #-}
22{-# LANGUAGE GADTs #-}
33{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE CPP #-}
54{-# LANGUAGE TypeSynonymInstances #-}
65{-# LANGUAGE FlexibleInstances #-}
76{-# LANGUAGE StandaloneDeriving #-}
87{-# LANGUAGE DisambiguateRecordFields #-}
98{-# LANGUAGE NamedFieldPuns #-}
10−module Verify ( module Verify
11− , module Control.Applicative
12− , module Control.DeepSeq
13− , module Control.Exception
14− , module Control.Monad
15− , module Test.QuickCheck
16− , module Test.QuickCheck.Modifiers
17− , module Text.Printf
18− , succeeded
19− , failed
20− , monadicIO
21− , liftIO
22− , liftBool
23− , Test(..)
24− , Prop.Result(..)
25− )
26− where
9+module Verify
10+ ( module Verify
11+ , module Control.Applicative
12+ , module Control.DeepSeq
13+ , module Control.Exception
14+ , module Control.Monad
15+ , module Test.QuickCheck
16+ , module Test.QuickCheck.Modifiers
17+ , module Text.Printf
18+ , succeeded
19+ , failed
20+ , monadicIO
21+ , liftIO
22+ , liftBool
23+ , Test(..)
24+ , Prop.Result(..)
25+ )
26+where
2727
2828import Control.Exception ( bracket, try, SomeException(..) )
2929
@@ -35,7 +35,7 @@ import qualified Test.QuickCheck as QC
3535import Test.QuickCheck.Modifiers
3636import Test.QuickCheck.Property hiding ( Result(..) )
3737import qualified Test.QuickCheck.Property as Prop
38−import Test.QuickCheck.Monadic ( monadicIO )
38+import Test.QuickCheck.Monadic ( monadicIO )
3939
4040import Text.Printf
4141
@@ -56,7 +56,7 @@ verify testName p = Test $ TestInstance
5656 case qcResult of
5757 QC.Success {..} -> return $ Finished TS.Pass
5858 QC.Failure {numShrinks,reason} -> return $ Finished
59− $ TS.Fail $ "After "
59+ $ TS.Fail $ "After "
6060 ++ show numShrinks ++ " shrinks determined failure to be: "
6161 ++ show reason
6262 _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"
@@ -85,16 +85,5 @@ instance Arbitrary DoubleColumnChar where
8585liftIOResult :: Testable prop => IO prop -> Property
8686liftIOResult = ioProperty
8787
88−#if __GLASGOW_HASKELL__ <= 701
89−instance Random Word where
90− random g =
91− let (i :: Int, g') = random g
92− in (toEnum i, g')
93− randomR (l,h) g =
94− let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g
95− in (toEnum i, g')
96−#endif
97−
9888data Bench where
9989 Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
100−
test/Verify/Data/Terminfo/Parse.hs+17−17
@@ -1,7 +1,8 @@
1−module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse
2− , module Data.Terminfo.Parse
3− )
4− where
1+module Verify.Data.Terminfo.Parse
2+ ( module Verify.Data.Terminfo.Parse
3+ , module Data.Terminfo.Parse
4+ )
5+where
56
67import Data.Terminfo.Parse
78import Data.Terminfo.Eval
@@ -19,22 +20,22 @@ data NonParamCapString = NonParamCapString String
1920 deriving Show
2021
2122instance Arbitrary NonParamCapString where
22− arbitrary
23+ arbitrary
2324 = ( do
2425 s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')
2526 return $ NonParamCapString s
26− ) `suchThat` ( \(NonParamCapString str) -> length str < 255 )
27+ ) `suchThat` ( \(NonParamCapString str) -> length str < 255 )
2728
2829data LiteralPercentCap = LiteralPercentCap String [Word8]
2930 deriving ( Show )
3031
3132instance Arbitrary LiteralPercentCap where
32− arbitrary
33+ arbitrary
3334 = ( do
3435 NonParamCapString s <- arbitrary
3536 (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s
3637 return $ LiteralPercentCap s' bytes
37− ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )
38+ ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )
3839
3940data IncFirstTwoCap = IncFirstTwoCap String [Word8]
4041 deriving ( Show )
@@ -45,7 +46,7 @@ instance Arbitrary IncFirstTwoCap where
4546 NonParamCapString s <- arbitrary
4647 (s', bytes) <- insertEscapeOp "i" [] s
4748 return $ IncFirstTwoCap s' bytes
48− ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )
49+ ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )
4950
5051data PushParamCap = PushParamCap String Int [Word8]
5152 deriving ( Show )
@@ -57,7 +58,7 @@ instance Arbitrary PushParamCap where
5758 n <- choose (1,9)
5859 (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s
5960 return $ PushParamCap s' n bytes
60− ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )
61+ ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )
6162
6263data DecPrintCap = DecPrintCap String Int [Word8]
6364 deriving ( Show )
@@ -69,7 +70,7 @@ instance Arbitrary DecPrintCap where
6970 n <- choose (1,9)
7071 (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s
7172 return $ DecPrintCap s' n bytes
72− ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )
73+ ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )
7374
7475insertEscapeOp opStr replBytes s = do
7576 insertPoints <- listOf1 $ elements [0 .. length s - 1]
@@ -92,21 +93,20 @@ bytesForRange cap offset count
9293 = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap
9394
9495collectBytes :: CapExpression -> [Word8]
95−collectBytes e = concat [ bytes
96+collectBytes e = concat [ bytes
9697 | Bytes offset count <- capOps e
9798 , let bytes = bytesForRange e offset count
9899 ]
99−
100+
100101
101102verifyBytesEqual :: [Word8] -> [Word8] -> Result
102−verifyBytesEqual outBytes expectedBytes
103+verifyBytesEqual outBytes expectedBytes
103104 = if outBytes == expectedBytes
104105 then succeeded
105− else failed
106− { reason = "outBytes ["
106+ else failed
107+ { reason = "outBytes ["
107108 ++ hexDump outBytes
108109 ++ "] /= expectedBytes ["
109110 ++ hexDump expectedBytes
110111 ++ "]"
111112 }
112−
test/Verify/Graphics/Vty/Attributes.hs+7−7
@@ -1,7 +1,8 @@
1−module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes
2− , module Graphics.Vty.Attributes
3− )
4− where
1+module Verify.Graphics.Vty.Attributes
2+ ( module Verify.Graphics.Vty.Attributes
3+ , module Graphics.Vty.Attributes
4+ )
5+where
56
67import Graphics.Vty.Attributes
78import Verify
@@ -40,8 +41,8 @@ allStyles =
4041
4142-- Limit the possible attributes to just a few for now.
4243possibleAttrMods :: [ AttrOp ]
43−possibleAttrMods =
44− [ idOp
44+possibleAttrMods =
45+ [ idOp
4546 ] ++ map setForeColorOp allColors
4647 ++ map setBackColorOp allColors
4748 ++ map setStyleOp allStyles
@@ -70,4 +71,3 @@ idOp = AttrOp "id" id
7071
7172applyOp :: AttrOp -> Attr -> Attr
7273applyOp (AttrOp _ f) a = f a
73−
test/Verify/Graphics/Vty/DisplayAttributes.hs+5−5
@@ -1,8 +1,8 @@
1−module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes
2− , module Graphics.Vty.DisplayAttributes
3− )
4− where
1+module Verify.Graphics.Vty.DisplayAttributes
2+ ( module Verify.Graphics.Vty.DisplayAttributes
3+ , module Graphics.Vty.DisplayAttributes
4+ )
5+where
56
67import Graphics.Vty.DisplayAttributes
78import Verify
8−
test/Verify/Graphics/Vty/Image.hs+18−18
@@ -1,10 +1,11 @@
11{-# LANGUAGE BangPatterns #-}
22{-# LANGUAGE NamedFieldPuns #-}
33{-# LANGUAGE DisambiguateRecordFields #-}
4−module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image
5− , module Graphics.Vty.Image
6− )
7− where
4+module Verify.Graphics.Vty.Image
5+ ( module Verify.Graphics.Vty.Image
6+ , module Graphics.Vty.Image
7+ )
8+where
89
910import Verify.Graphics.Vty.Attributes
1011import Graphics.Vty.Image
@@ -26,7 +27,7 @@ instance Show UnitImage where
2627data DefaultImage = DefaultImage Image
2728
2829instance Show DefaultImage where
29− show (DefaultImage i)
30+ show (DefaultImage i)
3031 = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i)
3132
3233instance Arbitrary DefaultImage where
@@ -34,15 +35,15 @@ instance Arbitrary DefaultImage where
3435 i <- return $ char defAttr 'X'
3536 return $ DefaultImage i
3637
37−data SingleRowSingleAttrImage
38− = SingleRowSingleAttrImage
38+data SingleRowSingleAttrImage
39+ = SingleRowSingleAttrImage
3940 { expectedAttr :: Attr
4041 , expectedColumns :: Int
4142 , rowImage :: Image
4243 }
4344
4445instance Show SingleRowSingleAttrImage where
45− show (SingleRowSingleAttrImage attr columns image)
46+ show (SingleRowSingleAttrImage attr columns image)
4647 = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"
4748
4849newtype WidthResize = WidthResize (Image -> (Image, Int))
@@ -84,14 +85,14 @@ instance Arbitrary ImageResize where
8485 , do
8586 ImageResize f <- arbitrary
8687 WidthResize g <- arbitrary
87− return $! ImageResize $! \i ->
88+ return $! ImageResize $! \i ->
8889 let (i0, (_, outHeight)) = f i
8990 gI = g i0
9091 in (fst gI, (snd gI, outHeight))
9192 , do
9293 ImageResize f <- arbitrary
9394 HeightResize g <- arbitrary
94− return $! ImageResize $! \i ->
95+ return $! ImageResize $! \i ->
9596 let (i0, (outWidth, _)) = f i
9697 gI = g i0
9798 in (fst gI, (outWidth, snd gI))
@@ -100,17 +101,17 @@ instance Arbitrary ImageResize where
100101
101102instance Arbitrary SingleRowSingleAttrImage where
102103 arbitrary = do
103− -- The text must contain at least one character. Otherwise the image simplifies to the
104− -- IdImage which has a height of 0. If this is to represent a single row then the height
105− -- must be 1
104+ -- The text must contain at least one character. Otherwise the
105+ -- image simplifies to the IdImage which has a height of 0. If
106+ -- this is to represent a single row then the height must be 1
106107 singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)
107108 a <- arbitrary
108109 let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]
109110 outWidth = length singleColumnRowText
110111 return $ SingleRowSingleAttrImage a outWidth outImage
111112
112−data SingleRowTwoAttrImage
113− = SingleRowTwoAttrImage
113+data SingleRowTwoAttrImage
114+ = SingleRowTwoAttrImage
114115 { part0 :: SingleRowSingleAttrImage
115116 , part1 :: SingleRowSingleAttrImage
116117 , joinImage :: Image
@@ -122,8 +123,8 @@ instance Arbitrary SingleRowTwoAttrImage where
122123 p1 <- arbitrary
123124 return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1)
124125
125−data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
126− { stackImage :: Image
126+data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
127+ { stackImage :: Image
127128 , stackSourceImages :: [SingleRowSingleAttrImage]
128129 , stackWidth :: Int
129130 , stackHeight :: Int
@@ -215,4 +216,3 @@ instance Arbitrary Translation where
215216 y <- arbitrary `suchThat` (> 0)
216217 let i' = translate x y i
217218 return $ Translation i (x,y) i'
218−
test/Verify/Graphics/Vty/Output.hs+5−7
@@ -4,18 +4,17 @@ import Control.Applicative ((<$>))
44
55import Graphics.Vty.Output.Mock
66
7−import qualified Data.ByteString as BS
87import Data.IORef
98import qualified Data.String.UTF8 as UTF8
109
1110import Test.QuickCheck.Property
1211
13−-- A list of terminals that should be supported.
14−-- This started with a list of terminals ubuntu supported. Then those terminals that really could
15−-- not be supported were removed. Then a few more were pruned until a reasonable looking set was
16−-- made.
12+-- A list of terminals that should be supported. This started with a
13+-- list of terminals ubuntu supported. Then those terminals that really
14+-- could not be supported were removed. Then a few more were pruned
15+-- until a reasonable looking set was made.
1716terminalsOfInterest :: [String]
18−terminalsOfInterest =
17+terminalsOfInterest =
1918 [ "vt100"
2019 , "vt220"
2120 , "vt102"
@@ -58,4 +57,3 @@ compareMockOutput mockData expectedStr = do
5857 ++ expectedStr
5958 }
6059 else return succeeded
61−
test/Verify/Graphics/Vty/Picture.hs+13−13
@@ -1,8 +1,9 @@
11{-# LANGUAGE DisambiguateRecordFields #-}
2−module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture
3− , module Graphics.Vty.Picture
4− )
5− where
2+module Verify.Graphics.Vty.Picture
3+ ( module Verify.Graphics.Vty.Picture
4+ , module Graphics.Vty.Picture
5+ )
6+where
67
78import Verify.Graphics.Vty.Prelude
89
@@ -14,9 +15,9 @@ import Verify.Graphics.Vty.Image
1415
1516import Verify
1617
17−data DefaultPic = DefaultPic
18+data DefaultPic = DefaultPic
1819 { defaultPic :: Picture
19− , defaultWin :: MockWindow
20+ , defaultWin :: MockWindow
2021 }
2122
2223instance Show DefaultPic where
@@ -27,10 +28,10 @@ instance Arbitrary DefaultPic where
2728 arbitrary = do
2829 DefaultImage image <- arbitrary
2930 let win = MockWindow (imageWidth image) (imageHeight image)
30− return $ DefaultPic (picForImage image)
31− win
31+ return $ DefaultPic (picForImage image)
32+ win
3233
33−data PicWithBGAttr = PicWithBGAttr
34+data PicWithBGAttr = PicWithBGAttr
3435 { withAttrPic :: Picture
3536 , withAttrWin :: MockWindow
3637 , withAttrSpecifiedAttr :: Attr
@@ -41,12 +42,11 @@ instance Arbitrary PicWithBGAttr where
4142 DefaultImage image <- arbitrary
4243 let win = MockWindow (imageWidth image) (imageHeight image)
4344 attr <- arbitrary
44− return $ PicWithBGAttr (picForImage image)
45− win
45+ return $ PicWithBGAttr (picForImage image)
46+ win
4647 attr
47−
48+
4849instance Arbitrary Picture where
4950 arbitrary = do
5051 layers <- Verify.resize 20 (listOf1 arbitrary)
5152 return $ picForLayers layers
52−
test/Verify/Graphics/Vty/Prelude.hs+5−7
@@ -1,10 +1,8 @@
1−module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude
2− , module Graphics.Vty.Prelude
3− , MockWindow(..)
4− )
5− where
6−
7−import Graphics.Vty.Prelude
1+module Verify.Graphics.Vty.Prelude
2+ ( module Verify.Graphics.Vty.Prelude
3+ , MockWindow(..)
4+ )
5+where
86
97import Graphics.Vty.Debug
108
test/Verify/Graphics/Vty/Span.hs+7−7
@@ -1,8 +1,9 @@
11{-# LANGUAGE FlexibleInstances #-}
2−module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span
3− , module Graphics.Vty.Span
4− )
5− where
2+module Verify.Graphics.Vty.Span
3+ ( module Verify.Graphics.Vty.Span
4+ , module Graphics.Vty.Span
5+ )
6+where
67
78import Graphics.Vty.Debug
89import Graphics.Vty.Span
@@ -19,10 +20,10 @@ isAttrSpanOp TextSpan {} = True
1920isAttrSpanOp _ = False
2021
2122verifyAllSpansHaveWidth i spans w
22− = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)
23+ = let v = map (\s -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)
2324 in case any ((== True) . fst) v of
2425 False -> succeeded
25− True -> failed { reason = "Not all spans contained operations defining exactly "
26+ True -> failed { reason = "Not all spans contained operations defining exactly "
2627 ++ show w
2728 ++ " columns of output - \n"
2829 ++ (concatMap ((++ "\n") . show)) v
@@ -34,4 +35,3 @@ verifyOpsEquality i_ops i_alt_ops =
3435 else failed { reason = "ops for alternate image " ++ show i_alt_ops
3536 ++ " are not the same as " ++ show i_ops
3637 }
37−
test/VerifyAttributeOps.hsdeleted−9
@@ -1,9 +0,0 @@
1−module VerifyAttributeOps where
2−
3−import Verify.Graphics.Vty.Attributes
4−
5−import Verify
6−
7−tests :: IO [Test]
8−tests = return []
9−
test/VerifyColor240.hsnew file+269
@@ -0,0 +1,269 @@
1+module VerifyColor240 where
2+
3+import Data.Word(Word8)
4+import Verify
5+
6+import Graphics.Vty.Attributes.Color240(rgbColorToColor240)
7+
8+oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8
9+oldRgbColorToColor240 r g b
10+ | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"
11+ | r == 8 && g == 8 && b == 8 = 216
12+ | r == 18 && g == 18 && b == 18 = 217
13+ | r == 28 && g == 28 && b == 28 = 218
14+ | r == 38 && g == 38 && b == 38 = 219
15+ | r == 48 && g == 48 && b == 48 = 220
16+ | r == 58 && g == 58 && b == 58 = 221
17+ | r == 68 && g == 68 && b == 68 = 222
18+ | r == 78 && g == 78 && b == 78 = 223
19+ | r == 88 && g == 88 && b == 88 = 224
20+ | r == 98 && g == 98 && b == 98 = 225
21+ | r == 108 && g == 108 && b == 108 = 226
22+ | r == 118 && g == 118 && b == 118 = 227
23+ | r == 128 && g == 128 && b == 128 = 228
24+ | r == 138 && g == 138 && b == 138 = 229
25+ | r == 148 && g == 148 && b == 148 = 230
26+ | r == 158 && g == 158 && b == 158 = 231
27+ | r == 168 && g == 168 && b == 168 = 232
28+ | r == 178 && g == 178 && b == 178 = 233
29+ | r == 188 && g == 188 && b == 188 = 234
30+ | r == 198 && g == 198 && b == 198 = 235
31+ | r == 208 && g == 208 && b == 208 = 236
32+ | r == 218 && g == 218 && b == 218 = 237
33+ | r == 228 && g == 228 && b == 228 = 238
34+ | r == 238 && g == 238 && b == 238 = 239
35+ | r <= 0 && g <= 0 && b <= 0 = 0
36+ | r <= 0 && g <= 0 && b <= 95 = 1
37+ | r <= 0 && g <= 0 && b <= 135 = 2
38+ | r <= 0 && g <= 0 && b <= 175 = 3
39+ | r <= 0 && g <= 0 && b <= 215 = 4
40+ | r <= 0 && g <= 0 && b <= 255 = 5
41+ | r <= 0 && g <= 95 && b <= 0 = 6
42+ | r <= 0 && g <= 95 && b <= 95 = 7
43+ | r <= 0 && g <= 95 && b <= 135 = 8
44+ | r <= 0 && g <= 95 && b <= 175 = 9
45+ | r <= 0 && g <= 95 && b <= 215 = 10
46+ | r <= 0 && g <= 95 && b <= 255 = 11
47+ | r <= 0 && g <= 135 && b <= 0 = 12
48+ | r <= 0 && g <= 135 && b <= 95 = 13
49+ | r <= 0 && g <= 135 && b <= 135 = 14
50+ | r <= 0 && g <= 135 && b <= 175 = 15
51+ | r <= 0 && g <= 135 && b <= 215 = 16
52+ | r <= 0 && g <= 135 && b <= 255 = 17
53+ | r <= 0 && g <= 175 && b <= 0 = 18
54+ | r <= 0 && g <= 175 && b <= 95 = 19
55+ | r <= 0 && g <= 175 && b <= 135 = 20
56+ | r <= 0 && g <= 175 && b <= 175 = 21
57+ | r <= 0 && g <= 175 && b <= 215 = 22
58+ | r <= 0 && g <= 175 && b <= 255 = 23
59+ | r <= 0 && g <= 215 && b <= 0 = 24
60+ | r <= 0 && g <= 215 && b <= 95 = 25
61+ | r <= 0 && g <= 215 && b <= 135 = 26
62+ | r <= 0 && g <= 215 && b <= 175 = 27
63+ | r <= 0 && g <= 215 && b <= 215 = 28
64+ | r <= 0 && g <= 215 && b <= 255 = 29
65+ | r <= 0 && g <= 255 && b <= 0 = 30
66+ | r <= 0 && g <= 255 && b <= 95 = 31
67+ | r <= 0 && g <= 255 && b <= 135 = 32
68+ | r <= 0 && g <= 255 && b <= 175 = 33
69+ | r <= 0 && g <= 255 && b <= 215 = 34
70+ | r <= 0 && g <= 255 && b <= 255 = 35
71+ | r <= 95 && g <= 0 && b <= 0 = 36
72+ | r <= 95 && g <= 0 && b <= 95 = 37
73+ | r <= 95 && g <= 0 && b <= 135 = 38
74+ | r <= 95 && g <= 0 && b <= 175 = 39
75+ | r <= 95 && g <= 0 && b <= 215 = 40
76+ | r <= 95 && g <= 0 && b <= 255 = 41
77+ | r <= 95 && g <= 95 && b <= 0 = 42
78+ | r <= 95 && g <= 95 && b <= 95 = 43
79+ | r <= 95 && g <= 95 && b <= 135 = 44
80+ | r <= 95 && g <= 95 && b <= 175 = 45
81+ | r <= 95 && g <= 95 && b <= 215 = 46
82+ | r <= 95 && g <= 95 && b <= 255 = 47
83+ | r <= 95 && g <= 135 && b <= 0 = 48
84+ | r <= 95 && g <= 135 && b <= 95 = 49
85+ | r <= 95 && g <= 135 && b <= 135 = 50
86+ | r <= 95 && g <= 135 && b <= 175 = 51
87+ | r <= 95 && g <= 135 && b <= 215 = 52
88+ | r <= 95 && g <= 135 && b <= 255 = 53
89+ | r <= 95 && g <= 175 && b <= 0 = 54
90+ | r <= 95 && g <= 175 && b <= 95 = 55
91+ | r <= 95 && g <= 175 && b <= 135 = 56
92+ | r <= 95 && g <= 175 && b <= 175 = 57
93+ | r <= 95 && g <= 175 && b <= 215 = 58
94+ | r <= 95 && g <= 175 && b <= 255 = 59
95+ | r <= 95 && g <= 215 && b <= 0 = 60
96+ | r <= 95 && g <= 215 && b <= 95 = 61
97+ | r <= 95 && g <= 215 && b <= 135 = 62
98+ | r <= 95 && g <= 215 && b <= 175 = 63
99+ | r <= 95 && g <= 215 && b <= 215 = 64
100+ | r <= 95 && g <= 215 && b <= 255 = 65
101+ | r <= 95 && g <= 255 && b <= 0 = 66
102+ | r <= 95 && g <= 255 && b <= 95 = 67
103+ | r <= 95 && g <= 255 && b <= 135 = 68
104+ | r <= 95 && g <= 255 && b <= 175 = 69
105+ | r <= 95 && g <= 255 && b <= 215 = 70
106+ | r <= 95 && g <= 255 && b <= 255 = 71
107+ | r <= 135 && g <= 0 && b <= 0 = 72
108+ | r <= 135 && g <= 0 && b <= 95 = 73
109+ | r <= 135 && g <= 0 && b <= 135 = 74
110+ | r <= 135 && g <= 0 && b <= 175 = 75
111+ | r <= 135 && g <= 0 && b <= 215 = 76
112+ | r <= 135 && g <= 0 && b <= 255 = 77
113+ | r <= 135 && g <= 95 && b <= 0 = 78
114+ | r <= 135 && g <= 95 && b <= 95 = 79
115+ | r <= 135 && g <= 95 && b <= 135 = 80
116+ | r <= 135 && g <= 95 && b <= 175 = 81
117+ | r <= 135 && g <= 95 && b <= 215 = 82
118+ | r <= 135 && g <= 95 && b <= 255 = 83
119+ | r <= 135 && g <= 135 && b <= 0 = 84
120+ | r <= 135 && g <= 135 && b <= 95 = 85
121+ | r <= 135 && g <= 135 && b <= 135 = 86
122+ | r <= 135 && g <= 135 && b <= 175 = 87
123+ | r <= 135 && g <= 135 && b <= 215 = 88
124+ | r <= 135 && g <= 135 && b <= 255 = 89
125+ | r <= 135 && g <= 175 && b <= 0 = 90
126+ | r <= 135 && g <= 175 && b <= 95 = 91
127+ | r <= 135 && g <= 175 && b <= 135 = 92
128+ | r <= 135 && g <= 175 && b <= 175 = 93
129+ | r <= 135 && g <= 175 && b <= 215 = 94
130+ | r <= 135 && g <= 175 && b <= 255 = 95
131+ | r <= 135 && g <= 215 && b <= 0 = 96
132+ | r <= 135 && g <= 215 && b <= 95 = 97
133+ | r <= 135 && g <= 215 && b <= 135 = 98
134+ | r <= 135 && g <= 215 && b <= 175 = 99
135+ | r <= 135 && g <= 215 && b <= 215 = 100
136+ | r <= 135 && g <= 215 && b <= 255 = 101
137+ | r <= 135 && g <= 255 && b <= 0 = 102
138+ | r <= 135 && g <= 255 && b <= 95 = 103
139+ | r <= 135 && g <= 255 && b <= 135 = 104
140+ | r <= 135 && g <= 255 && b <= 175 = 105
141+ | r <= 135 && g <= 255 && b <= 215 = 106
142+ | r <= 135 && g <= 255 && b <= 255 = 107
143+ | r <= 175 && g <= 0 && b <= 0 = 108
144+ | r <= 175 && g <= 0 && b <= 95 = 109
145+ | r <= 175 && g <= 0 && b <= 135 = 110
146+ | r <= 175 && g <= 0 && b <= 175 = 111
147+ | r <= 175 && g <= 0 && b <= 215 = 112
148+ | r <= 175 && g <= 0 && b <= 255 = 113
149+ | r <= 175 && g <= 95 && b <= 0 = 114
150+ | r <= 175 && g <= 95 && b <= 95 = 115
151+ | r <= 175 && g <= 95 && b <= 135 = 116
152+ | r <= 175 && g <= 95 && b <= 175 = 117
153+ | r <= 175 && g <= 95 && b <= 215 = 118
154+ | r <= 175 && g <= 95 && b <= 255 = 119
155+ | r <= 175 && g <= 135 && b <= 0 = 120
156+ | r <= 175 && g <= 135 && b <= 95 = 121
157+ | r <= 175 && g <= 135 && b <= 135 = 122
158+ | r <= 175 && g <= 135 && b <= 175 = 123
159+ | r <= 175 && g <= 135 && b <= 215 = 124
160+ | r <= 175 && g <= 135 && b <= 255 = 125
161+ | r <= 175 && g <= 175 && b <= 0 = 126
162+ | r <= 175 && g <= 175 && b <= 95 = 127
163+ | r <= 175 && g <= 175 && b <= 135 = 128
164+ | r <= 175 && g <= 175 && b <= 175 = 129
165+ | r <= 175 && g <= 175 && b <= 215 = 130
166+ | r <= 175 && g <= 175 && b <= 255 = 131
167+ | r <= 175 && g <= 215 && b <= 0 = 132
168+ | r <= 175 && g <= 215 && b <= 95 = 133
169+ | r <= 175 && g <= 215 && b <= 135 = 134
170+ | r <= 175 && g <= 215 && b <= 175 = 135
171+ | r <= 175 && g <= 215 && b <= 215 = 136
172+ | r <= 175 && g <= 215 && b <= 255 = 137
173+ | r <= 175 && g <= 255 && b <= 0 = 138
174+ | r <= 175 && g <= 255 && b <= 95 = 139
175+ | r <= 175 && g <= 255 && b <= 135 = 140
176+ | r <= 175 && g <= 255 && b <= 175 = 141
177+ | r <= 175 && g <= 255 && b <= 215 = 142
178+ | r <= 175 && g <= 255 && b <= 255 = 143
179+ | r <= 215 && g <= 0 && b <= 0 = 144
180+ | r <= 215 && g <= 0 && b <= 95 = 145
181+ | r <= 215 && g <= 0 && b <= 135 = 146
182+ | r <= 215 && g <= 0 && b <= 175 = 147
183+ | r <= 215 && g <= 0 && b <= 215 = 148
184+ | r <= 215 && g <= 0 && b <= 255 = 149
185+ | r <= 215 && g <= 95 && b <= 0 = 150
186+ | r <= 215 && g <= 95 && b <= 95 = 151
187+ | r <= 215 && g <= 95 && b <= 135 = 152
188+ | r <= 215 && g <= 95 && b <= 175 = 153
189+ | r <= 215 && g <= 95 && b <= 215 = 154
190+ | r <= 215 && g <= 95 && b <= 255 = 155
191+ | r <= 215 && g <= 135 && b <= 0 = 156
192+ | r <= 215 && g <= 135 && b <= 95 = 157
193+ | r <= 215 && g <= 135 && b <= 135 = 158
194+ | r <= 215 && g <= 135 && b <= 175 = 159
195+ | r <= 215 && g <= 135 && b <= 215 = 160
196+ | r <= 215 && g <= 135 && b <= 255 = 161
197+ | r <= 215 && g <= 175 && b <= 0 = 162
198+ | r <= 215 && g <= 175 && b <= 95 = 163
199+ | r <= 215 && g <= 175 && b <= 135 = 164
200+ | r <= 215 && g <= 175 && b <= 175 = 165
201+ | r <= 215 && g <= 175 && b <= 215 = 166
202+ | r <= 215 && g <= 175 && b <= 255 = 167
203+ | r <= 215 && g <= 215 && b <= 0 = 168
204+ | r <= 215 && g <= 215 && b <= 95 = 169
205+ | r <= 215 && g <= 215 && b <= 135 = 170
206+ | r <= 215 && g <= 215 && b <= 175 = 171
207+ | r <= 215 && g <= 215 && b <= 215 = 172
208+ | r <= 215 && g <= 215 && b <= 255 = 173
209+ | r <= 215 && g <= 255 && b <= 0 = 174
210+ | r <= 215 && g <= 255 && b <= 95 = 175
211+ | r <= 215 && g <= 255 && b <= 135 = 176
212+ | r <= 215 && g <= 255 && b <= 175 = 177
213+ | r <= 215 && g <= 255 && b <= 215 = 178
214+ | r <= 215 && g <= 255 && b <= 255 = 179
215+ | r <= 255 && g <= 0 && b <= 0 = 180
216+ | r <= 255 && g <= 0 && b <= 95 = 181
217+ | r <= 255 && g <= 0 && b <= 135 = 182
218+ | r <= 255 && g <= 0 && b <= 175 = 183
219+ | r <= 255 && g <= 0 && b <= 215 = 184
220+ | r <= 255 && g <= 0 && b <= 255 = 185
221+ | r <= 255 && g <= 95 && b <= 0 = 186
222+ | r <= 255 && g <= 95 && b <= 95 = 187
223+ | r <= 255 && g <= 95 && b <= 135 = 188
224+ | r <= 255 && g <= 95 && b <= 175 = 189
225+ | r <= 255 && g <= 95 && b <= 215 = 190
226+ | r <= 255 && g <= 95 && b <= 255 = 191
227+ | r <= 255 && g <= 135 && b <= 0 = 192
228+ | r <= 255 && g <= 135 && b <= 95 = 193
229+ | r <= 255 && g <= 135 && b <= 135 = 194
230+ | r <= 255 && g <= 135 && b <= 175 = 195
231+ | r <= 255 && g <= 135 && b <= 215 = 196
232+ | r <= 255 && g <= 135 && b <= 255 = 197
233+ | r <= 255 && g <= 175 && b <= 0 = 198
234+ | r <= 255 && g <= 175 && b <= 95 = 199
235+ | r <= 255 && g <= 175 && b <= 135 = 200
236+ | r <= 255 && g <= 175 && b <= 175 = 201
237+ | r <= 255 && g <= 175 && b <= 215 = 202
238+ | r <= 255 && g <= 175 && b <= 255 = 203
239+ | r <= 255 && g <= 215 && b <= 0 = 204
240+ | r <= 255 && g <= 215 && b <= 95 = 205
241+ | r <= 255 && g <= 215 && b <= 135 = 206
242+ | r <= 255 && g <= 215 && b <= 175 = 207
243+ | r <= 255 && g <= 215 && b <= 215 = 208
244+ | r <= 255 && g <= 215 && b <= 255 = 209
245+ | r <= 255 && g <= 255 && b <= 0 = 210
246+ | r <= 255 && g <= 255 && b <= 95 = 211
247+ | r <= 255 && g <= 255 && b <= 135 = 212
248+ | r <= 255 && g <= 255 && b <= 175 = 213
249+ | r <= 255 && g <= 255 && b <= 215 = 214
250+ | r <= 255 && g <= 255 && b <= 255 = 215
251+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
252+ (fromIntegral r :: Int)
253+ (fromIntegral g :: Int)
254+ (fromIntegral b :: Int))
255+
256+sameColor :: Int -> Int -> Int -> Bool
257+sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b
258+
259+genVal :: Gen Int
260+genVal = chooseInt (0, 255)
261+
262+sameColorCheck :: Property
263+sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g)))
264+
265+tests :: IO [Test]
266+tests = return
267+ [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck
268+ ]
269+
test/VerifyConfig.hs+8−8
@@ -4,15 +4,15 @@ module Main where
44import Graphics.Vty.Config
55import Graphics.Vty.Input.Events
66
7−import Data.Default
87import Data.String.QQ
8+import qualified Data.ByteString.Char8 as B
99
1010import Test.Framework
1111import Test.Framework.Providers.HUnit
1212import Test.HUnit hiding (Test)
1313
14−exampleConfig :: String
15−exampleConfig = [s|
14+exampleConfig :: B.ByteString
15+exampleConfig = B.pack [s|
1616-- comments should be ignored.
1717map _ "\ESC[B" KUp []
1818askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored
@@ -23,7 +23,7 @@ debugLog "/tmp/vty-debug.txt"
2323|]
2424
2525exampleConfigConfig :: Config
26−exampleConfigConfig = def
26+exampleConfigConfig = defaultConfig
2727 { debugLog = Just "/tmp/vty-debug.txt"
2828 , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])
2929 , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])
@@ -33,12 +33,12 @@ exampleConfigConfig = def
3333 }
3434
3535exampleConfigParses :: IO ()
36−exampleConfigParses = assertEqual "example config parses as expected"
37− exampleConfigConfig
38− (runParseConfig "exampleConfig" exampleConfig)
36+exampleConfigParses =
37+ assertEqual "example config parses as expected"
38+ exampleConfigConfig
39+ (runParseConfig "exampleConfig" exampleConfig)
3940
4041main :: IO ()
4142main = defaultMain
4243 [ testCase "example config parses" $ exampleConfigParses
4344 ]
44−
test/VerifyCropSpanGeneration.hs+2−3
@@ -13,7 +13,7 @@ import Graphics.Vty.PictureToSpans
1313
1414import Verify
1515
16−import qualified Data.Vector as Vector
16+import qualified Data.Vector as Vector
1717
1818cropOpDisplayOps :: (Int -> Image -> Image) ->
1919 Int -> Image -> (DisplayOps, Image)
@@ -75,7 +75,7 @@ cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod`
7575 in displayOpsForImage i == displayOpsForImage iAlt
7676
7777tests :: IO [Test]
78−tests = return
78+tests = return
7979 [ verify "cropping from the bottom produces display operations covering the expected rows"
8080 cropBottomOutputRows
8181 , verify "cropping from the top produces display operations covering the expected rows"
@@ -90,4 +90,3 @@ tests = return
9090 , verify "the output of a stack is the same as that stack cropped top & bottom and joined together"
9191 cropTopAndBottomRejoinedEquivalence
9292 ]
93−
test/VerifyEmptyImageProps.hs+2−1
@@ -1,9 +1,10 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
12module VerifyEmptyImageProps where
23
34import Verify
45
56-- should be exported by Graphics.Vty.Picture
6−import Graphics.Vty.Picture ( Image, emptyImage )
7+import Graphics.Vty.Image ( Image, emptyImage )
78
89tests :: IO [Test]
910tests = do
test/VerifyEvalTerminfoCaps.hs+14−12
@@ -1,9 +1,10 @@
11{-# LANGUAGE BangPatterns #-}
22{-# LANGUAGE NamedFieldPuns #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
34module VerifyEvalTerminfoCaps where
45
56import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
6−import Data.Terminfo.Eval
7+import Data.Terminfo.Eval
78import Data.Terminfo.Parse
89import Control.DeepSeq
910
@@ -24,8 +25,9 @@ import Foreign.Marshal.Alloc (mallocBytes)
2425import Foreign.Ptr (Ptr, minusPtr)
2526import Numeric
2627
27−-- If a terminal defines one of the caps then it's expected to be parsable.
28−capsOfInterest =
28+-- If a terminal defines one of the caps then it's expected to be
29+-- parsable.
30+capsOfInterest =
2931 [ "cup"
3032 , "sc"
3133 , "rc"
@@ -49,12 +51,13 @@ fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr na
4951
5052tests :: IO [Test]
5153tests = do
52− evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)
54+ -- 1 MB should be big enough for any termcaps ;-)
55+ evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024)
5356 fmap concat $ forM terminalsOfInterest $ \termName -> do
5457 putStrLn $ "adding tests for terminal: " ++ termName
5558 mti <- try $ Terminfo.setupTerm termName
5659 case mti of
57− Left (_e :: SomeException)
60+ Left (_e :: SomeException)
5861 -> return []
5962 Right ti -> do
6063 fmap concat $ forM capsOfInterest $ \capName -> do
@@ -71,7 +74,7 @@ tests = do
7174{-# NOINLINE verifyEvalCap #-}
7275verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property
7376verifyEvalCap evalBuffer expr !junkInt = do
74− forAll (vector 9) $ \inputValues ->
77+ forAll (vector 9) $ \inputValues ->
7578 let write = writeCapExpr expr inputValues
7679 !byteCount = getBound write
7780 in liftIOResult $ do
@@ -79,12 +82,11 @@ verifyEvalCap evalBuffer expr !junkInt = do
7982 forM_ [0..100] $ \i -> runWrite write startPtr
8083 endPtr <- runWrite write startPtr
8184 case endPtr `minusPtr` startPtr of
82− count | count < 0 ->
85+ count | count < 0 ->
8386 return $ failed { reason = "End pointer before start pointer." }
84− | toEnum count > byteCount ->
85− return $ failed { reason = "End pointer past end of buffer by "
86− ++ show (toEnum count - byteCount)
87+ | toEnum count > byteCount ->
88+ return $ failed { reason = "End pointer past end of buffer by "
89+ ++ show (toEnum count - byteCount)
8790 }
88− | otherwise ->
91+ | otherwise ->
8992 return succeeded
90−
test/VerifyImageOps.hs+27−27
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
12module VerifyImageOps where
23
34import Graphics.Vty.Attributes
@@ -9,43 +10,43 @@ import Verify
910import Control.DeepSeq
1011
1112twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool
12−twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =
13+twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =
1314 imageWidth (char defAttr c1 <|> char defAttr c2) == 2
1415
1516manySwHorizConcat :: [SingleColumnChar] -> Bool
16−manySwHorizConcat cs =
17+manySwHorizConcat cs =
1718 let chars = [ char | SingleColumnChar char <- cs ]
1819 l = fromIntegral $ length cs
1920 in imageWidth ( horizCat $ map (char defAttr) chars ) == l
2021
2122twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool
22−twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =
23+twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =
2324 imageHeight (char defAttr c1 <-> char defAttr c2) == 2
2425
2526horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool
26−horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
27− (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
28− ==
27+horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
28+ (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
29+ ==
2930 char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)
3031
3132twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
32−twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
33+twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
3334 imageWidth (char defAttr c1 <|> char defAttr c2) == 4
3435
3536manyDwHorizConcat :: [DoubleColumnChar] -> Bool
36−manyDwHorizConcat cs =
37+manyDwHorizConcat cs =
3738 let chars = [ char | DoubleColumnChar char <- cs ]
3839 l = fromIntegral $ length cs
3940 in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2
4041
4142twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
42−twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
43+twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
4344 imageHeight (char defAttr c1 <-> char defAttr c2) == 2
4445
4546horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool
46−horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
47− (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
48− ==
47+horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
48+ (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
49+ ==
4950 char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)
5051
5152vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool
@@ -54,9 +55,9 @@ vertContatSingleRow (NonEmpty stack) =
5455 stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]
5556 in imageHeight stackImage == expectedHeight
5657
57−disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage
58− -> NonEmptyList SingleRowSingleAttrImage
59− -> Bool
58+disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage
59+ -> NonEmptyList SingleRowSingleAttrImage
60+ -> Bool
6061disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =
6162 let expectedHeight :: Int = max (length stack0) (length stack1)
6263 stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
@@ -64,9 +65,9 @@ disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =
6465 in imageHeight (stackImage0 <|> stackImage1) == expectedHeight
6566
6667
67−disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
68− -> NonEmptyList SingleRowSingleAttrImage
69− -> Bool
68+disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
69+ -> NonEmptyList SingleRowSingleAttrImage
70+ -> Bool
7071disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
7172 let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
7273 stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
@@ -74,31 +75,31 @@ disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
7475 expectedHeight = imageHeight image
7576 in case image of
7677 HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) )
77− &&
78+ &&
7879 ( expectedHeight == (imageHeight $ partRight image) )
7980 _ -> True
8081
81−disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage
82+disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage
8283 -> NonEmptyList SingleRowSingleAttrImage
8384 -> Bool
8485disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) =
8586 let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
8687 stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
8788 stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
88− stack0Image = vertCat stack0Images
89− stack1Image = vertCat stack1Images
89+ stack0Image = vertCat stack0Images
90+ stack1Image = vertCat stack1Images
9091 image = stack0Image <-> stack1Image
9192 in imageWidth image == expectedWidth
9293
93−disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
94+disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
9495 -> NonEmptyList SingleRowSingleAttrImage
9596 -> Bool
9697disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
9798 let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
9899 stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
99100 stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
100− stack0Image = vertCat stack0Images
101− stack1Image = vertCat stack1Images
101+ stack0Image = vertCat stack0Images
102+ stack1Image = vertCat stack1Images
102103 image = stack0Image <-> stack1Image
103104 in case image of
104105 VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )
@@ -136,7 +137,7 @@ cropBottomLimitsHeight :: Image -> Int -> Property
136137cropBottomLimitsHeight i v = v >= 0 ==>
137138 v >= imageHeight (cropBottom v i)
138139
139−-- rediculous tests just to satisfy my desire for nice code coverage :-P
140+-- ridiculous tests just to satisfy my desire for nice code coverage :-P
140141canShowImage :: Image -> Bool
141142canShowImage i = length (show i) > 0
142143
@@ -171,4 +172,3 @@ tests = return
171172 , verify "can rnf image" canRnfImage
172173 , verify "can pp image" canPpImage
173174 ]
174−
test/VerifyImageTrans.hs+1−1
@@ -22,7 +22,7 @@ verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool
2222verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0)
2323 (SingleRowSingleAttrImage attr1 charCount1 _image1)
2424 i
25− )
25+ )
2626 | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1)
2727 | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1)
2828
test/VerifyLayersSpanGeneration.hs+9−7
@@ -4,6 +4,7 @@ module VerifyLayersSpanGeneration where
44
55import Verify.Graphics.Vty.Prelude
66
7+import Verify.Graphics.Vty.Attributes
78import Verify.Graphics.Vty.Image
89import Verify.Graphics.Vty.Picture
910import Verify.Graphics.Vty.Span
@@ -13,7 +14,7 @@ import Graphics.Vty.PictureToSpans
1314
1415import Verify
1516
16−import qualified Data.Vector as Vector
17+import qualified Data.Vector as Vector
1718
1819largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
1920largerHorizSpanOcclusion row0 row1 =
@@ -25,8 +26,9 @@ largerHorizSpanOcclusion row0 row1 =
2526 ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)
2627 in verifyOpsEquality expectedOps ops
2728
28−-- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the
29−-- second row rendered as a bottom layer with a background fill where the first row would be.
29+-- | Two rows stacked vertical is equivalent to the first row rendered
30+-- as the top layer and the second row rendered as a bottom layer with a
31+-- background fill where the first row would be.
3032vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
3133vertStackLayerEquivalence0 row0 row1 =
3234 let i0 = rowImage row0
@@ -52,8 +54,9 @@ vertStackLayerEquivalence1 row0 row1 =
5254 opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)
5355 in verifyOpsEquality expectedOps opsLayered
5456
55−-- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the
56−-- second row rendered as a bottom layer with a background fill where the first row would be.
57+-- | Two rows horiz joined is equivalent to the first row rendered as
58+-- the top layer and the second row rendered as a bottom layer with a
59+-- background fill where the first row would be.
5760horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
5861horizJoinLayerEquivalence0 row0 row1 =
5962 let i0 = rowImage row0
@@ -109,7 +112,7 @@ horizJoinAlternate1 =
109112 in verifyOpsEquality expectedOps opsLayered
110113
111114tests :: IO [Test]
112−tests = return
115+tests = return
113116 [ verify "a larger horiz span occludes a smaller span on a lower layer"
114117 largerHorizSpanOcclusion
115118 , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"
@@ -125,4 +128,3 @@ tests = return
125128 -- , verify "alternating images using joins is the same as alternating images using layers (1)"
126129 -- horizJoinAlternate1
127130 ]
128−
test/VerifyOutput.hs+12−9
@@ -1,8 +1,9 @@
1−{- We setup the environment to envoke certain terminals of interest.
2− - This assumes appropriate definitions exist in the current environment for the terminals of
3− - interest.
4− -}
1+-- We setup the environment to invoke certain terminals of interest.
2+-- This assumes appropriate definitions exist in the current environment
3+-- for the terminals of interest.
4+{-# LANGUAGE ScopedTypeVariables #-}
55module VerifyOutput where
6+
67import Verify
78
89import Graphics.Vty
@@ -12,10 +13,7 @@ import Verify.Graphics.Vty.Output
1213
1314import Control.Monad
1415
15−import Data.Default
16−
1716import qualified System.Console.Terminfo as Terminfo
18−import System.Posix.Env
1917import System.Posix.IO
2018
2119tests :: IO [Test]
@@ -37,11 +35,16 @@ smokeTestTermNonMac termName i = liftIOResult $ do
3735smokeTestTerm :: String -> Image -> IO Result
3836smokeTestTerm termName i = do
3937 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
40− t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName }
38+ t <- outputForConfig $ defaultConfig
39+ { outputFd = Just nullOut
40+ , termName = Just termName
41+ , colorMode = Just NoColor
42+ }
4143 -- putStrLn $ "context color count: " ++ show (contextColorCount t)
4244 reserveDisplay t
4345 dc <- displayContext t (100,100)
44− -- always show the cursor to produce tests for terminals with no cursor support.
46+ -- always show the cursor to produce tests for terminals with no
47+ -- cursor support.
4548 let pic = (picForImage i) { picCursor = Cursor 0 0 }
4649 outputPicture dc pic
4750 setCursorPos t 0 0
test/VerifyParseTerminfoCaps.hs+4−4
@@ -1,4 +1,5 @@
11{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
23module VerifyParseTerminfoCaps where
34
45import Prelude hiding ( catch )
@@ -16,7 +17,7 @@ import Numeric
1617
1718-- If a terminal defines one of the caps then it's expected to be parsable.
1819-- TODO: reduce duplication with terminfo terminal implementation.
19−capsOfInterest =
20+capsOfInterest =
2021 [ "cup"
2122 , "sc"
2223 , "rc"
@@ -65,7 +66,7 @@ verifyParseCap capString onParse =
6566 Right e -> onParse e
6667
6768nonParamaterizedCaps (NonParamCapString cap) = do
68− verifyParseCap cap $ \e ->
69+ verifyParseCap cap $ \e ->
6970 let expectedBytes = map (toEnum . fromEnum) cap
7071 outBytes = bytesForRange e 0 (length cap)
7172 in verifyBytesEqual outBytes expectedBytes
@@ -75,7 +76,7 @@ literalPercentCaps (LiteralPercentCap capString expectedBytes) = do
7576
7677incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do
7778 verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes
78−
79+
7980pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do
8081 verifyParseCap capString $ \e ->
8182 let outBytes = collectBytes e
@@ -98,4 +99,3 @@ printCap ti capName = do
9899printExpression ti capName = do
99100 let parseResult = parseCapExpression $ fromCapname ti capName
100101 putStrLn $ capName ++ ": " ++ show parseResult
101−
test/VerifySimpleSpanGeneration.hs+16−16
@@ -13,31 +13,31 @@ import Graphics.Vty.PictureToSpans
1313
1414import Verify
1515
16−import qualified Data.Vector as Vector
16+import qualified Data.Vector as Vector
1717
1818unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool
19−unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =
19+unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =
2020 let p = picForImage i
2121 ops = displayOpsForPic p (regionForWindow w)
2222 in displayOpsColumns ops == 0 && displayOpsRows ops == 0
2323
2424unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool
25−unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
25+unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
2626 let p = picForImage i
2727 ops = displayOpsForPic p (regionForWindow w)
28− in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
28+ in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
2929
3030horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
31−horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
31+horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
3232 let p = picForImage i
3333 ops = displayOpsForPic p (regionForWindow w)
3434 in displayOpsColumns ops == 0 && displayOpsRows ops == 0
3535
3636horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
37−horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
37+horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
3838 let p = picForImage i
3939 ops = displayOpsForPic p (regionForWindow w)
40− in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
40+ in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
4141
4242horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result
4343horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
@@ -51,7 +51,7 @@ horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expected
5151 let p = picForImage i
5252 w = MockWindow c 1
5353 ops = displayOpsForPic p (regionForWindow w)
54− in spanOpsEffectedRows ops == 1
54+ in spanOpsAffectedRows ops == 1
5555
5656horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result
5757horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =
@@ -74,7 +74,7 @@ singleAttrSingleSpanStackCropped1 stack =
7474 expectedRowCount = stackHeight stack `div` 2
7575 w = MockWindow (stackWidth stack) expectedRowCount
7676 ops = displayOpsForPic p (regionForWindow w)
77− actualRowCount = spanOpsEffectedRows ops
77+ actualRowCount = spanOpsAffectedRows ops
7878 in expectedRowCount == actualRowCount
7979
8080singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
@@ -90,7 +90,7 @@ singleAttrSingleSpanStackCropped3 stack0 stack1 =
9090 w = MockWindow (imageWidth (picImage p)) expectedRowCount
9191 ops = displayOpsForPic p (regionForWindow w)
9292 expectedRowCount = imageHeight (picImage p) `div` 2
93− actualRowCount = spanOpsEffectedRows ops
93+ actualRowCount = spanOpsAffectedRows ops
9494 in expectedRowCount == actualRowCount
9595
9696singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result
@@ -107,7 +107,7 @@ singleAttrSingleSpanStackCropped5 stack0 stack1 =
107107 w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)
108108 ops = displayOpsForPic p (regionForWindow w)
109109 expectedRowCount = stackHeight stack0
110− actualRowCount = spanOpsEffectedRows ops
110+ actualRowCount = spanOpsAffectedRows ops
111111 in expectedRowCount == actualRowCount
112112
113113horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result
@@ -123,13 +123,13 @@ arbImageIsCropped :: DefaultImage -> MockWindow -> Bool
123123arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =
124124 let pic = picForImage image
125125 ops = displayOpsForPic pic (regionForWindow win)
126− in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w )
126+ in ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w )
127127
128128spanOpsActuallyFillRows :: DefaultPic -> Bool
129129spanOpsActuallyFillRows (DefaultPic pic win) =
130130 let ops = displayOpsForPic pic (regionForWindow win)
131131 expectedRowCount = regionHeight (regionForWindow win)
132− actualRowCount = spanOpsEffectedRows ops
132+ actualRowCount = spanOpsAffectedRows ops
133133 in expectedRowCount == actualRowCount
134134
135135spanOpsActuallyFillColumns :: DefaultPic -> Bool
@@ -139,7 +139,7 @@ spanOpsActuallyFillColumns (DefaultPic pic win) =
139139 in allSpansHaveWidth ops expectedColumnCount
140140
141141firstSpanOpSetsAttr :: DefaultPic -> Bool
142−firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =
142+firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =
143143 let ops = displayOpsForPic pic (regionForWindow win)
144144 in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops )
145145
@@ -158,7 +158,7 @@ imageCoverageMatchesBounds i =
158158 in verifyAllSpansHaveWidth i ops (imageWidth i)
159159
160160tests :: IO [Test]
161−tests = return
161+tests = return
162162 [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0
163163 , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1
164164 , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0
@@ -171,7 +171,7 @@ tests = return
171171 , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"
172172 singleAttrSingleSpanStackOpCoverage
173173 , verify "a single attr text span is cropped when window size < size of stack image [width]"
174− singleAttrSingleSpanStackCropped0
174+ singleAttrSingleSpanStackCropped0
175175 , verify "a single attr text span is cropped when window size < size of stack image [height]"
176176 singleAttrSingleSpanStackCropped1
177177 , verify "single attr text span <|> single attr text span display cropped. [width]"
test/VerifyUsingMockInput.hs+26−22
@@ -1,8 +1,8 @@
11{-# LANGUAGE MultiParamTypeClasses #-}
22{-# LANGUAGE FlexibleInstances #-}
3−{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced
4− - are as expected.
5− -}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+-- Generate some input bytes and delays between blocks of input bytes.
5+-- Verify the events produced are as expected.
66module Main where
77
88import Verify.Graphics.Vty.Output
@@ -12,14 +12,12 @@ import Graphics.Vty.Input.Events
1212import Graphics.Vty.Input.Loop
1313import Graphics.Vty.Input.Terminfo
1414
15−import Control.Applicative
1615import Control.Concurrent
1716import Control.Concurrent.STM
1817import Control.Exception
1918import Lens.Micro ((^.))
2019import Control.Monad
2120
22−import Data.Default
2321import Data.IORef
2422import Data.List (intersperse, reverse, nubBy)
2523
@@ -36,7 +34,8 @@ import Test.SmallCheck.Series
3634
3735import Text.Printf
3836
39−-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
37+-- processing a block of 16 chars is the largest I can do without taking
38+-- too long to run the test.
4039maxBlockSize :: Int
4140maxBlockSize = 16
4241
@@ -47,8 +46,11 @@ forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
4746forEachOf l = over (generate (\n -> take n l))
4847
4948data InputEvent
50− = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
51− | Delay Int -- | microsecond delay
49+ = Bytes String
50+ -- ^ Input sequence encoded as a string. Regardless, the input is
51+ -- read a byte at a time.
52+ | Delay Int
53+ -- ^ Microsecond delay
5254 deriving Show
5355
5456type InputSpec = [InputEvent]
@@ -111,11 +113,11 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
111113 (writeFd, readFd) <- openPseudoTerminal
112114 (setTermAttr,_) <- attributeControl readFd
113115 setTermAttr
114− let testConfig = def { inputFd = Just readFd
115− , termName = Just "dummy"
116− , vmin = Just 1
117− , vtime = Just 100
118− }
116+ let testConfig = defaultConfig { inputFd = Just readFd
117+ , termName = Just "dummy"
118+ , vmin = Just 1
119+ , vtime = Just 100
120+ }
119121 input <- initInput testConfig table
120122 eventsRef <- newIORef []
121123 let writeWaitClose = do
@@ -130,7 +132,9 @@ assertEventsFromSynInput table inputSpec expectedEvents = do
130132 readLoop 0 = return ()
131133 readLoop n = do
132134 e <- atomically $ readTChan $ input^.eventChannel
133− modifyIORef eventsRef ((:) e)
135+ case e of
136+ InputEvent ev -> modifyIORef eventsRef ((:) ev)
137+ ResumeAfterSignal -> return ()
134138 readLoop (n - 1)
135139 genEventsUsingIoActions maxDuration writeWaitClose readEvents
136140 outEvents <- reverse <$> readIORef eventsRef
@@ -163,8 +167,8 @@ verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
163167
164168verifyCapsSynInputToEvent :: Property IO
165169verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
166− forEachOf terminalsOfInterest $ \termName -> monadic $ do
167− term <- setupTerm termName
170+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
171+ term <- setupTerm terminalName
168172 let table = capsClassifyMap term keysFromCapsTable
169173 inputSeq = gen table
170174 events = map snd inputSeq
@@ -183,9 +187,9 @@ verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic
183187
184188verifyFullSynInputToEvent :: Property IO
185189verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
186− forEachOf terminalsOfInterest $ \termName -> monadic $ do
187− term <- setupTerm termName
188− let table = classifyMapForTerm termName term
190+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
191+ term <- setupTerm terminalName
192+ let table = classifyMapForTerm terminalName term
189193 inputSeq = gen table
190194 events = map snd inputSeq
191195 keydowns = map (Bytes . fst) inputSeq
@@ -194,9 +198,9 @@ verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
194198
195199verifyFullSynInputToEvent_2x :: Property IO
196200verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
197− forEachOf terminalsOfInterest $ \termName -> monadic $ do
198− term <- setupTerm termName
199− let table = classifyMapForTerm termName term
201+ forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
202+ term <- setupTerm terminalName
203+ let table = classifyMapForTerm terminalName term
200204 inputSeq = gen table
201205 events = concatMap ((\s -> [s,s]) . snd) inputSeq
202206 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
test/VerifyUsingMockTerminal.hs+23−15
@@ -4,9 +4,11 @@ import Verify.Graphics.Vty.Prelude
44
55import Verify.Graphics.Vty.Picture
66import Verify.Graphics.Vty.Image
7+import Verify.Graphics.Vty.Attributes
78import Verify.Graphics.Vty.Span
89import Verify.Graphics.Vty.Output
910import Graphics.Vty.Output
11+import Graphics.Vty.Output.Interface
1012import Graphics.Vty.Output.Mock
1113
1214import Graphics.Vty.Debug
@@ -39,27 +41,30 @@ singleTRow :: MockWindow -> Property
3941singleTRow (MockWindow w h) = liftIOResult $ do
4042 (mockData,t) <- mockTerminal (w,h)
4143 dc <- displayBounds t >>= displayContext t
42− -- create an image that contains just the character T repeated for a single row
44+ -- create an image that contains just the character T repeated for a
45+ -- single row
4346 let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')
4447 pic = (picForImage i) { picBackground = Background 'B' defAttr }
4548 outputPicture dc pic
46− -- The mock output string that represents the output bytes a single line containing the T
47− -- string: Followed by h - 1 lines of a change to the background attribute and then the
48− -- background character
49+ -- The mock output string that represents the output bytes a single
50+ -- line containing the T string: Followed by h - 1 lines of a change
51+ -- to the background attribute and then the background character
4952 let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'
5053 ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')
5154 compareMockOutput mockData expected
52−
55+
5356manyTRows :: MockWindow -> Property
5457manyTRows (MockWindow w h) = liftIOResult $ do
5558 (mockData, t) <- mockTerminal (w,h)
5659 dc <- displayBounds t >>= displayContext t
57− -- create an image that contains the character 'T' repeated for all the rows
60+ -- create an image that contains the character 'T' repeated for all
61+ -- the rows
5862 let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
5963 pic = (picForImage i) { picBackground = Background 'B' defAttr }
6064 outputPicture 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
65+ -- The UTF8 string that represents the output bytes is h repeats of
66+ -- a move, 'M', followed by an attribute change. 'A', followed by w
67+ -- 'T's
6368 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
6469 compareMockOutput mockData expected
6570
@@ -67,12 +72,14 @@ manyTRowsCroppedWidth :: MockWindow -> Property
6772manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do
6873 (mockData,t) <- mockTerminal (w,h)
6974 dc <- displayBounds t >>= displayContext t
70− -- create an image that contains the character 'T' repeated for all the rows
75+ -- create an image that contains the character 'T' repeated for all
76+ -- the rows
7177 let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')
7278 pic = (picForImage i) { picBackground = Background 'B' defAttr }
7379 outputPicture dc pic
74− -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
75− -- attribute change. 'A', followed by w 'T's
80+ -- The UTF8 string that represents the output bytes is h repeats of
81+ -- a move, 'M', followed by an attribute change. 'A', followed by w
82+ -- 'T's
7683 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
7784 compareMockOutput mockData expected
7885
@@ -80,12 +87,14 @@ manyTRowsCroppedHeight :: MockWindow -> Property
8087manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do
8188 (mockData,t) <- mockTerminal (w,h)
8289 dc <- displayBounds t >>= displayContext t
83− -- create an image that contains the character 'T' repeated for all the rows
90+ -- create an image that contains the character 'T' repeated for all
91+ -- the rows
8492 let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')
8593 pic = (picForImage i) { picBackground = Background 'B' defAttr }
8694 outputPicture dc pic
87− -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an
88− -- attribute change. 'A', followed by w count 'T's
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
8998 let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')
9099 compareMockOutput mockData expected
91100
@@ -97,4 +106,3 @@ tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds
97106 , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth
98107 , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight
99108 ]
100−
test/VerifyUtf8Width.hs+2
@@ -1,9 +1,11 @@
11module VerifyUtf8Width where
2+
23import Verify
34
45import Graphics.Text.Width
56import Graphics.Vty.Attributes
67import Graphics.Vty.Picture
8+import Graphics.Vty.Image
79
810swIs1Column :: SingleColumnChar -> Bool
911swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1
test/YiIssue264.hs+1
@@ -1,4 +1,5 @@
11module Main where
2+
23import Graphics.Vty
34import Control.Exception
45
test/interactive_terminal_test.hs+51−52
@@ -12,14 +12,13 @@ import Control.Concurrent (threadDelay)
1212import Control.Exception
1313import Control.Monad
1414
15−import Data.Default (def)
1615import Data.List ( lookup )
1716import Data.Maybe ( isJust, fromJust )
1817import Data.Monoid
1918import Data.String.QQ
2019import Data.Word
2120
22−import Foreign.Marshal.Array
21+import Foreign.Marshal.Array
2322
2423import qualified System.Environment as Env
2524
@@ -74,12 +73,12 @@ with the test_results.list file pasted into the issue. A suitable summary is:
7473|]
7574 waitForReturn
7675 results <- doTestMenu 1
77− envAttributes <- mapM ( \envName -> Control.Exception.catch ( Env.getEnv envName >>= return . (,) envName )
78− ( \ (_ :: SomeException) -> return (envName, "") )
79− )
76+ envAttributes <- mapM ( \envName -> Control.Exception.catch ( Env.getEnv envName >>= return . (,) envName )
77+ ( \ (_ :: SomeException) -> return (envName, "") )
78+ )
8079 [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
8180 t <- standardIOConfig >>= outputForConfig
82− let resultsTxt = show envAttributes ++ "\n"
81+ let resultsTxt = show envAttributes ++ "\n"
8382 ++ terminalID t ++ "\n"
8483 ++ show results ++ "\n"
8584 releaseTerminal t
@@ -94,7 +93,7 @@ testMenu :: [(String, Test)]
9493testMenu = zip (map show [1..]) allTests
9594
9695doTestMenu :: Int -> IO [(String, Bool)]
97−doTestMenu nextID
96+doTestMenu nextID
9897 | nextID > length allTests = do
9998 putStrLn $ "Done! Please email the " ++ outputFilePath ++ " file to coreyoconnor@gmail.com"
10099 return []
@@ -108,26 +107,26 @@ doTestMenu nextID
108107 s <- getLine >>= return . filter (/= '\n')
109108 case s of
110109 "q" -> return mempty
111− "" -> do
112− r <- runTest $ show nextID
110+ "" -> do
111+ r <- runTest $ show nextID
113112 rs <- doTestMenu ( nextID + 1 )
114113 return $ r : rs
115114 i | isJust ( lookup i testMenu ) -> do
116− r <- runTest i
115+ r <- runTest i
117116 rs <- doTestMenu ( read i + 1 )
118117 return $ r : rs
119118 where
120− displayTestMenu
119+ displayTestMenu
121120 = mapM_ displayTestMenu' testMenu
122− displayTestMenu' ( i, t )
123− = putStrLn $ ( if i == show nextID
124− then "> "
121+ displayTestMenu' ( i, t )
122+ = putStrLn $ ( if i == show nextID
123+ then "> "
125124 else " "
126125 ) ++ i ++ ". " ++ testName t
127126
128127runTest :: String -> IO (String, Bool)
129128runTest i = do
130− let t = fromJust $ lookup i testMenu
129+ let t = fromJust $ lookup i testMenu
131130 printSummary t
132131 waitForReturn
133132 testAction t
@@ -153,8 +152,8 @@ data Test = Test
153152 , confirmResults :: IO Bool
154153 }
155154
156−allTests
157− = [ reserveOutputTest
155+allTests
156+ = [ reserveOutputTest
158157 , displayBoundsTest0
159158 , displayBoundsTest1
160159 , displayBoundsTest2
@@ -185,7 +184,7 @@ allTests
185184 , layer1
186185 ]
187186
188−reserveOutputTest = Test
187+reserveOutputTest = Test
189188 { testName = "Initialize and reserve terminal output then restore previous state."
190189 , testID = "reserveOutputTest"
191190 , testAction = do
@@ -203,7 +202,7 @@ reserveOutputTest = Test
203202 , printSummary = do
204203 putStr $ [s|
205204Once return is pressed:
206− 0. The screen will be cleared.
205+ 0. The screen will be cleared.
207206 1. Four lines of text should be visible.
208207 1. The cursor should be visible and at the start of the fifth line.
209208
@@ -365,7 +364,7 @@ Did the test output match the description?
365364|]
366365 defaultSuccessConfirmResults
367366
368−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
369368-- This avoids any issues with how the compiler represents string literals.
370369--
371370-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -391,7 +390,7 @@ utf8Txt0 = [ [ 0xe2 , 0x86 , 0x91 ]
391390
392391iso10646Txt0 :: String
393392iso10646Txt0 = map toEnum
394− [ 8593
393+ [ 8593
395394 , 8593
396395 , 8595
397396 , 8595
@@ -554,11 +553,11 @@ After return is pressed for the second time:
554553allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
555554 [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
556555
557−allBrightColors
556+allBrightColors
558557 = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]
559558 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
560559
561−attributesTest0 = Test
560+attributesTest0 = Test
562561 { testName = "Character attributes: foreground colors."
563562 , testID = "attributesTest0"
564563 , testAction = do
@@ -604,7 +603,7 @@ Did the test output match the description?
604603 defaultSuccessConfirmResults
605604 }
606605
607−attributesTest1 = Test
606+attributesTest1 = Test
608607 { testName = "Character attributes: background colors."
609608 , testID = "attributesTest1"
610609 , testAction = do
@@ -659,7 +658,7 @@ Did the test output match the description?
659658 defaultSuccessConfirmResults
660659 }
661660
662−attributesTest2 = Test
661+attributesTest2 = Test
663662 { testName = "Character attributes: Vivid foreground colors."
664663 , testID = "attributesTest2"
665664 , testAction = do
@@ -686,23 +685,23 @@ Once return is pressed:
686685 1. The cursor will be hidden.
687686 2. 9 lines of text in three columns will be drawn:
688687 a. The first column will be a name of a standard color (for an 8 color
689− terminal) rendered with that color as the foreground color.
688+ terminal) rendered with that color as the foreground color.
690689 b. The next column will be also be the name of a standard color rendered
691690 with that color as the foreground color but the shade used should be
692− more vivid than the shade used in the first column.
691+ more vivid than the shade used in the first column.
693692 c. The final column will be the name of a color rendered with the
694693 default attributes.
695694
696695For instance, one line will be the word "magenta" and that word should be
697−rendered in the magenta color.
696+rendered in the magenta color.
698697
699698I'm not actually sure exactly what "vivid" means in this context. For xterm the
700−vivid colors are brighter.
699+vivid colors are brighter.
701700
702−Verify:
701+Verify:
703702 * The first column: The foreground color matches the named color.
704703 * The second column: The foreground color matches the named color but is
705− more vivid than the color used in the first column.
704+ more vivid than the color used in the first column.
706705 * The third column: All text is rendered with the default attributes.
707706 * The vertical bars used in each line to mark the border of a column are
708707 lined up.
@@ -718,7 +717,7 @@ Did the test output match the description?
718717 defaultSuccessConfirmResults
719718 }
720719
721−attributesTest3 = Test
720+attributesTest3 = Test
722721 { testName = "Character attributes: Vivid background colors."
723722 , testID = "attributesTest3"
724723 , testAction = do
@@ -746,23 +745,23 @@ Once return is pressed:
746745 2. 9 lines of text in three columns will be drawn:
747746 a. The first column will contain be a name of a standard color for an 8
748747 color terminal rendered with the default foreground color with a
749− background the named color.
748+ background the named color.
750749 b. The first column will contain be a name of a standard color for an 8
751750 color terminal rendered with the default foreground color with the
752− background a vivid version of the named color.
751+ background a vivid version of the named color.
753752 c. The third column will be the name of a standard color rendered with
754753 the default attributes.
755−
754+
756755For instance, one line will contain be the word "magenta" and the word should
757−be rendered in the default foreground color over a magenta background.
756+be rendered in the default foreground color over a magenta background.
758757
759758I'm not actually sure exactly what "vivid" means in this context. For xterm the
760759vivid colors are brighter.
761760
762−Verify:
761+Verify:
763762 * The first column: The background color matches the named color.
764763 * The second column: The background color matches the named color and is
765− more vivid than the color used in the first column.
764+ more vivid than the color used in the first column.
766765 * The third column column: All text is rendered with the default attributes.
767766 * The vertical bars used in each line to mark the border of a column are
768767 lined up.
@@ -785,7 +784,7 @@ Did the test output match the description?
785784 defaultSuccessConfirmResults
786785 }
787786
788−attrCombos =
787+attrCombos =
789788 [ ( "default", id )
790789 , ( "bold", flip withStyle bold )
791790 , ( "blink", flip withStyle blink )
@@ -796,7 +795,7 @@ attrCombos =
796795 , ( "bold + blink + underline", flip withStyle (bold + blink + underline) )
797796 ]
798797
799−attributesTest4 = Test
798+attributesTest4 = Test
800799 { testName = "Character attributes: Bold; Blink; Underline."
801800 , testID = "attributesTest4"
802801 , testAction = do
@@ -819,10 +818,10 @@ attributesTest4 = Test
819818Once return is pressed:
820819 0. The screen will be cleared.
821820 1. The cursor will be hidden.
822− 2. 8 rows of text in two columns.
821+ 2. 8 rows of text in two columns.
823822 The rows will contain the following text:
824823 default
825− bold
824+ bold
826825 blink
827826 underline
828827 bold + blink
@@ -831,8 +830,8 @@ Once return is pressed:
831830 bold + blink + underline
832831 The first column will be rendered with the described attributes. The second
833832 column will be rendered with the default attributes.
834−
835−Verify:
833+
834+Verify:
836835 * The vertical bars used in each line to mark the border of a column are
837836 lined up.
838837 * The text in the first column is rendered as described.
@@ -848,7 +847,7 @@ Did the test output match the description?
848847 defaultSuccessConfirmResults
849848 }
850849
851−attributesTest5 = Test
850+attributesTest5 = Test
852851 { testName = "Character attributes: 240 color palette"
853852 , testID = "attributesTest5"
854853 , testAction = do
@@ -873,7 +872,7 @@ Once return is pressed:
873872 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
874873 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
875874
876−Verify:
875+Verify:
877876
878877After return is pressed for the second time:
879878 0. The screen containing the test summary should be restored.
@@ -938,7 +937,7 @@ cursorHideTest0 = Test
938937 { testName = "Verify the cursor is hid and re-shown. issue #7"
939938 , testID = "cursorHideTest0"
940939 , testAction = do
941− vty <- mkVty def
940+ vty <- mkVty defaultConfig
942941 showCursor $ outputIface vty
943942 setCursorPos (outputIface vty) 5 5
944943 nextEvent vty
@@ -971,7 +970,7 @@ outputPicAndWait pic = do
971970 releaseDisplay t
972971 releaseTerminal t
973972 return ()
974−
973+
975974vertCropTest0 :: Test
976975vertCropTest0 = Test
977976 { testName = "Verify bottom cropping works as expected with single column chars"
@@ -1046,7 +1045,7 @@ horizCropTest0 = Test
10461045 , testID = "cropTest0"
10471046 , testAction = do
10481047 let baseImage = vertCat $ map (string defAttr) lorumIpsum
1049− croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1048+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
10501049 image = baseImage <-> backgroundFill 10 2 <-> croppedImage
10511050 outputImageAndWait image
10521051 , printSummary = putStr $ [s|
@@ -1063,7 +1062,7 @@ horizCropTest1 = Test
10631062 , testID = "cropTest0"
10641063 , testAction = do
10651064 let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
1066− croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1065+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
10671066 image = baseImage <-> backgroundFill 10 2 <-> croppedImage
10681067 outputImageAndWait image
10691068 , printSummary = putStr $ [s|
@@ -1080,7 +1079,7 @@ horizCropTest2 = Test
10801079 , testID = "cropTest0"
10811080 , testAction = do
10821081 let baseImage = vertCat $ map (string defAttr) lorumIpsum
1083− croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
1082+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
10841083 image = baseImage <-> backgroundFill 10 2 <-> croppedImage
10851084 outputImageAndWait image
10861085 , printSummary = putStr $ [s|
@@ -1097,7 +1096,7 @@ horizCropTest3 = Test
10971096 , testID = "cropTest0"
10981097 , testAction = do
10991098 let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
1100− croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
1099+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
11011100 image = baseImage <-> backgroundFill 10 2 <-> croppedImage
11021101 outputImageAndWait image
11031102 , printSummary = putStr $ [s|
test/vty-examples.cabal+24−14
@@ -1,28 +1,38 @@
11name: vty-examples
2−version: 5.5.1
2+version: 5.7
33license: BSD3
44license-file: LICENSE
55author: AUTHORS
6−maintainer: Corey O'Connor (coreyoconnor@gmail.com)
7−homepage: https://github.com/coreyoconnor/vty
6+maintainer: Jonathan Daugherty (cygnus@foobox.com)
7+homepage: https://github.com/jtdaugherty/vty
88category: User Interfaces
99synopsis: Examples programs using the vty library.
1010description:
11− vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, have no
12− confusing corner cases, and good support for common terminal types.
11+ vty is terminal GUI library in the niche of ncurses. It is intended to
12+ be easy to use, have no confusing corner cases, and good support for
13+ common terminal types.
1314 .
14− vty-interactive-terminal-test - interactive test. Useful for building a bug report for vtys author.
15− vty-event-echo - view a input event log for vty. Example of interacting with user.
16− vty-rogue - A bad rogue-like game. Go from the entrance to exit. Example of layers
17− vty-benchmark - benchmarks vty. A series of tests that push random pictures to the terminal.
15+ vty-interactive-terminal-test - interactive test. Useful for building
16+ a bug report for vtys author.
17+ .
18+ vty-event-echo - view a input event log for vty. Example of
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.
1826 .
1927 &#169; Corey O'Connor; BSD3 license.
28+ .
29+ &#169; Jonathan Daugherty; BSD3 license.
2030cabal-version: >= 1.18.0
2131build-type: Simple
2232
2333source-repository head
2434 type: git
25− location: https://github.com/coreyoconnor/vty.git
35+ location: https://github.com/jtdaugherty/vty.git
2636
2737executable vty-interactive-terminal-test
2838 main-is: interactive_terminal_test.hs
@@ -31,7 +41,7 @@ executable vty-interactive-terminal-test
3141 default-extensions: ScopedTypeVariables
3242 ghc-options: -threaded
3343
34− build-depends: vty >= 5.2.11,
44+ build-depends: vty >= 5.15,
3545 base >= 4 && < 5,
3646 bytestring,
3747 containers,
@@ -59,7 +69,7 @@ executable vty-event-echo
5969 FlexibleContexts
6070 ghc-options: -threaded
6171
62− build-depends: vty >= 5.2.11,
72+ build-depends: vty >= 5.15,
6373 base >= 4 && < 5,
6474 array,
6575 bytestring,
@@ -79,7 +89,7 @@ executable vty-rogue
7989 default-extensions: ScopedTypeVariables
8090 ghc-options: -threaded
8191
82− build-depends: vty >= 5.2.11,
92+ build-depends: vty >= 5.15,
8393 base >= 4 && < 5,
8494 array,
8595 bytestring,
@@ -100,7 +110,7 @@ executable vty-benchmark
100110 default-extensions: ScopedTypeVariables
101111 ghc-options: -threaded
102112
103− build-depends: vty >= 5.2.11,
113+ build-depends: vty >= 5.15,
104114 base >= 4 && < 5,
105115 bytestring,
106116 Cabal,
tools/BuildWidthTable.hsnew file+144
@@ -0,0 +1,144 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE CPP #-}
3+module Main where
4+
5+import qualified Control.Exception as E
6+import Control.Monad (when)
7+import Data.Maybe (fromMaybe)
8+#if !(MIN_VERSION_base(4,11,0))
9+import Data.Semigroup ((<>))
10+#endif
11+import System.Directory (createDirectoryIfMissing)
12+import System.Environment (getArgs, getProgName)
13+import System.FilePath (takeDirectory)
14+import System.Exit (exitFailure)
15+import System.Console.GetOpt
16+import Text.Read (readMaybe)
17+
18+import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName
19+ , vtyConfigPath, addConfigWidthMap
20+ , ConfigUpdateResult(..)
21+ )
22+import Graphics.Vty.UnicodeWidthTable.IO
23+import Graphics.Vty.UnicodeWidthTable.Query
24+
25+data Arg = Help
26+ | OutputPath String
27+ | TableUpperBound String
28+ | UpdateConfig
29+ | VtyConfigPath String
30+ deriving (Eq, Show)
31+
32+options :: Config -> [OptDescr Arg]
33+options config =
34+ [ Option "h" ["help"] (NoArg Help)
35+ "This help output"
36+ , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")
37+ ("The maximum Unicode code point to test when building the table " <>
38+ "(default: " <> (show $ fromEnum $ configBound config) <> ")")
39+ , Option "p" ["path"] (ReqArg OutputPath "PATH")
40+ ("The output path to write to (default: " <>
41+ fromMaybe "<none>" (configOutputPath config) <> ")")
42+ , Option "u" ["update-config"] (NoArg UpdateConfig)
43+ "Create or update the Vty configuration file to use the new table (default: no)"
44+ , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")
45+ ("Update the specified Vty configuration file path when -u is set (default: " <>
46+ configPath config <> ")")
47+ ]
48+
49+data Config =
50+ Config { configOutputPath :: Maybe FilePath
51+ , configBound :: Char
52+ , configUpdate :: Bool
53+ , configPath :: FilePath
54+ }
55+ deriving (Show)
56+
57+mkDefaultConfig :: IO Config
58+mkDefaultConfig = do
59+ Config <$> terminalWidthTablePath
60+ <*> pure defaultUnicodeTableUpperBound
61+ <*> pure False
62+ <*> vtyConfigPath
63+
64+usage :: IO ()
65+usage = do
66+ config <- mkDefaultConfig
67+ pn <- getProgName
68+ putStrLn $ "Usage: " <> pn <> " [options]"
69+ putStrLn ""
70+ putStrLn "This tool queries the terminal on stdout to determine the widths"
71+ putStrLn "of Unicode characters rendered to the terminal. The resulting data"
72+ putStrLn "is written to a table at the specified output path for later"
73+ putStrLn "loading by Vty-based applications."
74+ putStrLn ""
75+
76+ putStrLn $ usageInfo pn (options config)
77+
78+updateConfigFromArg :: Arg -> Config -> Config
79+updateConfigFromArg Help c =
80+ c
81+updateConfigFromArg UpdateConfig c =
82+ c { configUpdate = True }
83+updateConfigFromArg (VtyConfigPath p) c =
84+ c { configPath = p }
85+updateConfigFromArg (TableUpperBound s) c =
86+ case readMaybe s of
87+ Nothing -> error $ "Invalid table upper bound: " <> show s
88+ Just v -> c { configBound = toEnum v }
89+updateConfigFromArg (OutputPath p) c =
90+ c { configOutputPath = Just p }
91+
92+main :: IO ()
93+main = do
94+ defConfig <- mkDefaultConfig
95+ strArgs <- getArgs
96+ let (args, unused, errors) = getOpt Permute (options defConfig) strArgs
97+
98+ when (not $ null errors) $ do
99+ mapM_ putStrLn errors
100+ exitFailure
101+
102+ when ((not $ null unused) || (Help `elem` args)) $ do
103+ usage
104+ exitFailure
105+
106+ let config = foldr updateConfigFromArg defConfig args
107+
108+ outputPath <- case configOutputPath config of
109+ Nothing -> do
110+ putStrLn "Error: could not obtain terminal width table path"
111+ exitFailure
112+ Just path -> return path
113+
114+ putStrLn "Querying terminal:"
115+ builtTable <- buildUnicodeWidthTable $ configBound config
116+
117+ let dir = takeDirectory outputPath
118+ createDirectoryIfMissing True dir
119+ writeUnicodeWidthTable outputPath builtTable
120+
121+ putStrLn $ "\nOutput table written to " <> outputPath
122+
123+ when (configUpdate config) $ do
124+ let cPath = configPath config
125+ Just tName <- currentTerminalName
126+
127+ result <- E.try $ addConfigWidthMap cPath tName outputPath
128+
129+ case result of
130+ Left (e::E.SomeException) -> do
131+ putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>
132+ show e
133+ exitFailure
134+ Right ConfigurationCreated -> do
135+ putStrLn $ "Configuration file created: " <> cPath
136+ Right ConfigurationModified -> do
137+ putStrLn $ "Configuration file updated: " <> cPath
138+ Right (ConfigurationConflict other) -> do
139+ putStrLn $ "Configuration file not updated: uses a different table " <>
140+ "for TERM=" <> tName <> ": " <> other
141+ Right ConfigurationRedundant -> do
142+ putStrLn $ "Configuration file not updated: configuration " <>
143+ cPath <> " already uses table " <> outputPath <>
144+ " for TERM=" <> tName
view-benchmark-coredeleted−4
@@ -1,4 +0,0 @@
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+119−109
@@ -1,10 +1,10 @@
11name: vty
2−version: 5.5.1
2+version: 5.35.1
33license: BSD3
44license-file: LICENSE
55author: AUTHORS
6−maintainer: Corey O'Connor (coreyoconnor@gmail.com)
7−homepage: https://github.com/coreyoconnor/vty
6+maintainer: Jonathan Daugherty (cygnus@foobox.com)
7+homepage: https://github.com/jtdaugherty/vty
88category: User Interfaces
99synopsis: A simple terminal UI library
1010description:
@@ -12,55 +12,42 @@ description:
1212 be easy to use, have no confusing corner cases, and good support for
1313 common terminal types.
1414 .
15− Included in the source distribution is a program
16− test/interactive_terminal_test.hs that demonstrates the various
17− features.
15+ See the @vty-examples@ package as well as the program
16+ @test/interactive_terminal_test.hs@ included in the @vty@ package for
17+ examples on how to use the library.
1818 .
19− Developers: See the "Graphics.Vty" module.
20− .
21− Users: See the "Graphics.Vty.Config" module.
22− .
23− If your terminal is not behaving as expected the results of the
24− vty-interactive-terminal-test executable should be sent to the Vty
25− maintainter to aid in debugging the issue.
26− .
27− Notable infelicities: Assumes UTF-8 character encoding support by the
28− terminal; Poor signal handling; Requires terminfo.
29− .
30− This project is hosted on github.com: <https://github.com/coreyoconnor/vty>
31− .
32− > git clone git://github.com/coreyoconnor/vty.git
19+ Import the "Graphics.Vty" convenience module to get access to the core
20+ parts of the library.
3321 .
3422 &#169; 2006-2007 Stefan O'Rear; BSD3 license.
3523 .
3624 &#169; Corey O'Connor; BSD3 license.
37−cabal-version: >= 1.18
25+ .
26+ &#169; Jonathan Daugherty; BSD3 license.
27+cabal-version: 1.18
3828build-type: Simple
39−data-files: README.md,
40− TODO,
29+extra-doc-files: README.md,
4130 AUTHORS,
42− CHANGELOG,
31+ CHANGELOG.md,
4332 LICENSE
44−tested-with: GHC >= 7.6.2
33+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5
4534
4635source-repository head
4736 type: git
48− location: https://github.com/coreyoconnor/vty.git
37+ location: https://github.com/jtdaugherty/vty.git
4938
5039library
5140 default-language: Haskell2010
52− build-depends: base >= 4 && < 5,
41+ build-depends: base >= 4.8 && < 5,
5342 blaze-builder >= 0.3.3.2 && < 0.5,
5443 bytestring,
5544 containers,
56− data-default >= 0.5.3,
5745 deepseq >= 1.1 && < 1.5,
5846 directory,
5947 filepath >= 1.0 && < 2.0,
60− microlens,
48+ microlens < 0.4.13,
6149 microlens-mtl,
6250 microlens-th,
63− -- required for nice installation with yi
6451 hashable >= 1.2,
6552 mtl >= 1.1.1.0 && < 2.3,
6653 parallel >= 2.2 && < 3.3,
@@ -71,10 +58,18 @@ library
7158 text >= 0.11.3,
7259 unix,
7360 utf8-string >= 0.3 && < 1.1,
74− vector >= 0.7
61+ vector >= 0.7,
62+ binary,
63+ ansi-terminal >= 0.10.3
64+
65+ if !impl(ghc >= 8.0)
66+ build-depends: semigroups >= 0.16,
67+ fail
7568
7669 exposed-modules: Graphics.Vty
7770 Graphics.Vty.Attributes
71+ Graphics.Vty.Attributes.Color
72+ Graphics.Vty.Attributes.Color240
7873 Graphics.Vty.Config
7974 Graphics.Vty.Error
8075 Graphics.Vty.Image
@@ -83,10 +78,8 @@ library
8378 Graphics.Vty.Input
8479 Graphics.Vty.Input.Events
8580 Graphics.Vty.Picture
86− Graphics.Vty.Prelude
8781 Graphics.Vty.Output
8882 Graphics.Text.Width
89− -- the modules below are only meant to be used by the tests.
9083 Codec.Binary.UTF8.Debug
9184 Data.Terminfo.Parse
9285 Data.Terminfo.Eval
@@ -98,6 +91,8 @@ library
9891 Graphics.Vty.Input.Classify.Parse
9992 Graphics.Vty.Input.Loop
10093 Graphics.Vty.Input.Mouse
94+ Graphics.Vty.Input.Focus
95+ Graphics.Vty.Input.Paste
10196 Graphics.Vty.Input.Terminfo
10297 Graphics.Vty.PictureToSpans
10398 Graphics.Vty.Span
@@ -105,67 +100,72 @@ library
105100 Graphics.Vty.Output.Interface
106101 Graphics.Vty.Output.XTermColor
107102 Graphics.Vty.Output.TerminfoBased
103+ Graphics.Vty.UnicodeWidthTable.Types
104+ Graphics.Vty.UnicodeWidthTable.IO
105+ Graphics.Vty.UnicodeWidthTable.Query
106+ Graphics.Vty.UnicodeWidthTable.Install
108107
109− other-modules: Graphics.Vty.Attributes.Color
110− Graphics.Vty.Attributes.Color240
111− Graphics.Vty.Debug.Image
108+ other-modules: Graphics.Vty.Debug.Image
112109 Graphics.Vty.Input.Terminfo.ANSIVT
113110
114111 c-sources: cbits/gwinsz.c
115112 cbits/set_term_timing.c
113+ cbits/get_tty_erase.c
116114 cbits/mk_wcwidth.c
117115
118116 include-dirs: cbits
119117
120118 hs-source-dirs: src
121119
122− default-extensions: ScopedTypeVariables
123− ForeignFunctionInterface
124−
125120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10
126121
127122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10
128123
129− cc-options: -O2
124+executable vty-build-width-table
125+ main-is: BuildWidthTable.hs
126+ hs-source-dirs: tools
130127
131−executable vty-demo
132− main-is: Demo.hs
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
133142
134143 default-language: Haskell2010
135− default-extensions: ScopedTypeVariables
136144 ghc-options: -threaded
137145
138146 build-depends: vty,
139− base >= 4 && < 5,
147+ base >= 4.8 && < 5,
140148 containers,
141− data-default >= 0.5.3,
142149 microlens,
143150 microlens-mtl,
144151 mtl >= 1.1.1.0 && < 2.3
145152
146−test-suite verify-attribute-ops
153+executable vty-demo
154+ main-is: Demo.hs
155+ hs-source-dirs: demos
156+
147157 default-language: Haskell2010
148− default-extensions: ScopedTypeVariables
149− type: detailed-0.9
150− hs-source-dirs: test
151− test-module: VerifyAttributeOps
158+ ghc-options: -threaded
159+
152160 build-depends: vty,
153− Cabal >= 1.20,
154− QuickCheck >= 2.7,
155− random >= 1.0 && < 1.2,
156− base >= 4 && < 5,
157− bytestring,
161+ base >= 4.8 && < 5,
158162 containers,
159− deepseq >= 1.1 && < 1.5,
160− mtl >= 1.1.1.0 && < 2.3,
161− text >= 0.11.3,
162− unix,
163− utf8-string >= 0.3 && < 1.1,
164− vector >= 0.7
163+ microlens,
164+ microlens-mtl,
165+ mtl >= 1.1.1.0 && < 2.3
165166
166167test-suite verify-using-mock-terminal
167168 default-language: Haskell2010
168− default-extensions: ScopedTypeVariables
169169
170170 type: detailed-0.9
171171
@@ -184,8 +184,8 @@ test-suite verify-using-mock-terminal
184184 build-depends: vty,
185185 Cabal >= 1.20,
186186 QuickCheck >= 2.7,
187− random >= 1.0 && < 1.2,
188− base >= 4 && < 5,
187+ random >= 1.0 && < 1.3,
188+ base >= 4.8 && < 5,
189189 bytestring,
190190 containers,
191191 deepseq >= 1.1 && < 1.5,
@@ -198,7 +198,6 @@ test-suite verify-using-mock-terminal
198198
199199test-suite verify-terminal
200200 default-language: Haskell2010
201− default-extensions: ScopedTypeVariables
202201
203202 type: detailed-0.9
204203
@@ -217,11 +216,10 @@ test-suite verify-terminal
217216 build-depends: vty,
218217 Cabal >= 1.20,
219218 QuickCheck >= 2.7,
220− random >= 1.0 && < 1.2,
221− base >= 4 && < 5,
219+ random >= 1.0 && < 1.3,
220+ base >= 4.8 && < 5,
222221 bytestring,
223222 containers,
224− data-default >= 0.5.3,
225223 deepseq >= 1.1 && < 1.5,
226224 mtl >= 1.1.1.0 && < 2.3,
227225 terminfo >= 0.3 && < 0.5,
@@ -232,7 +230,6 @@ test-suite verify-terminal
232230
233231test-suite verify-display-attributes
234232 default-language: Haskell2010
235− default-extensions: ScopedTypeVariables
236233
237234 type: detailed-0.9
238235
@@ -251,8 +248,8 @@ test-suite verify-display-attributes
251248 build-depends: vty,
252249 Cabal >= 1.20,
253250 QuickCheck >= 2.7,
254− random >= 1.0 && < 1.2,
255− base >= 4 && < 5,
251+ random >= 1.0 && < 1.3,
252+ base >= 4.8 && < 5,
256253 bytestring,
257254 containers,
258255 deepseq >= 1.1 && < 1.5,
@@ -264,7 +261,6 @@ test-suite verify-display-attributes
264261
265262test-suite verify-empty-image-props
266263 default-language: Haskell2010
267− default-extensions: ScopedTypeVariables
268264
269265 type: detailed-0.9
270266
@@ -277,8 +273,8 @@ test-suite verify-empty-image-props
277273 build-depends: vty,
278274 Cabal >= 1.20,
279275 QuickCheck >= 2.7,
280− random >= 1.0 && < 1.2,
281− base >= 4 && < 5,
276+ random >= 1.0 && < 1.3,
277+ base >= 4.8 && < 5,
282278 bytestring,
283279 containers,
284280 deepseq >= 1.1 && < 1.5,
@@ -290,7 +286,6 @@ test-suite verify-empty-image-props
290286
291287test-suite verify-eval-terminfo-caps
292288 default-language: Haskell2010
293− default-extensions: ScopedTypeVariables
294289
295290 type: detailed-0.9
296291
@@ -304,8 +299,8 @@ test-suite verify-eval-terminfo-caps
304299 build-depends: vty,
305300 Cabal >= 1.20,
306301 QuickCheck >= 2.7,
307− random >= 1.0 && < 1.2,
308− base >= 4 && < 5,
302+ random >= 1.0 && < 1.3,
303+ base >= 4.8 && < 5,
309304 blaze-builder >= 0.3.3.2 && < 0.5,
310305 bytestring,
311306 containers,
@@ -319,7 +314,6 @@ test-suite verify-eval-terminfo-caps
319314
320315test-suite verify-image-ops
321316 default-language: Haskell2010
322− default-extensions: ScopedTypeVariables
323317
324318 type: detailed-0.9
325319
@@ -334,8 +328,8 @@ test-suite verify-image-ops
334328 build-depends: vty,
335329 Cabal >= 1.20,
336330 QuickCheck >= 2.7,
337− random >= 1.0 && < 1.2,
338− base >= 4 && < 5,
331+ random >= 1.0 && < 1.3,
332+ base >= 4.8 && < 5,
339333 bytestring,
340334 containers,
341335 deepseq >= 1.1 && < 1.5,
@@ -347,7 +341,6 @@ test-suite verify-image-ops
347341
348342test-suite verify-image-trans
349343 default-language: Haskell2010
350− default-extensions: ScopedTypeVariables
351344
352345 type: detailed-0.9
353346
@@ -362,8 +355,8 @@ test-suite verify-image-trans
362355 build-depends: vty,
363356 Cabal >= 1.20,
364357 QuickCheck >= 2.7,
365− random >= 1.0 && < 1.2,
366− base >= 4 && < 5,
358+ random >= 1.0 && < 1.3,
359+ base >= 4.8 && < 5,
367360 bytestring,
368361 containers,
369362 deepseq >= 1.1 && < 1.5,
@@ -375,7 +368,6 @@ test-suite verify-image-trans
375368
376369test-suite verify-inline
377370 default-language: Haskell2010
378− default-extensions: ScopedTypeVariables
379371
380372 type: detailed-0.9
381373
@@ -389,8 +381,8 @@ test-suite verify-inline
389381 build-depends: vty,
390382 Cabal >= 1.20,
391383 QuickCheck >= 2.7,
392− random >= 1.0 && < 1.2,
393− base >= 4 && < 5,
384+ random >= 1.0 && < 1.3,
385+ base >= 4.8 && < 5,
394386 bytestring,
395387 containers,
396388 deepseq >= 1.1 && < 1.5,
@@ -402,7 +394,6 @@ test-suite verify-inline
402394
403395test-suite verify-parse-terminfo-caps
404396 default-language: Haskell2010
405− default-extensions: ScopedTypeVariables
406397
407398 type: detailed-0.9
408399
@@ -417,8 +408,8 @@ test-suite verify-parse-terminfo-caps
417408 build-depends: vty,
418409 Cabal >= 1.20,
419410 QuickCheck >= 2.7,
420− random >= 1.0 && < 1.2,
421− base >= 4 && < 5,
411+ random >= 1.0 && < 1.3,
412+ base >= 4.8 && < 5,
422413 bytestring,
423414 containers,
424415 deepseq >= 1.1 && < 1.5,
@@ -431,7 +422,6 @@ test-suite verify-parse-terminfo-caps
431422
432423test-suite verify-simple-span-generation
433424 default-language: Haskell2010
434− default-extensions: ScopedTypeVariables
435425
436426 type: detailed-0.9
437427
@@ -449,8 +439,8 @@ test-suite verify-simple-span-generation
449439 build-depends: vty,
450440 Cabal >= 1.20,
451441 QuickCheck >= 2.7,
452− random >= 1.0 && < 1.2,
453− base >= 4 && < 5,
442+ random >= 1.0 && < 1.3,
443+ base >= 4.8 && < 5,
454444 bytestring,
455445 containers,
456446 deepseq >= 1.1 && < 1.5,
@@ -463,7 +453,6 @@ test-suite verify-simple-span-generation
463453
464454test-suite verify-crop-span-generation
465455 default-language: Haskell2010
466− default-extensions: ScopedTypeVariables
467456
468457 type: detailed-0.9
469458
@@ -481,8 +470,8 @@ test-suite verify-crop-span-generation
481470 build-depends: vty,
482471 Cabal >= 1.20,
483472 QuickCheck >= 2.7,
484− random >= 1.0 && < 1.2,
485− base >= 4 && < 5,
473+ random >= 1.0 && < 1.3,
474+ base >= 4.8 && < 5,
486475 bytestring,
487476 containers,
488477 deepseq >= 1.1 && < 1.5,
@@ -495,7 +484,6 @@ test-suite verify-crop-span-generation
495484
496485test-suite verify-layers-span-generation
497486 default-language: Haskell2010
498− default-extensions: ScopedTypeVariables
499487
500488 type: detailed-0.9
501489
@@ -513,8 +501,33 @@ test-suite verify-layers-span-generation
513501 build-depends: vty,
514502 Cabal >= 1.20,
515503 QuickCheck >= 2.7,
516− random >= 1.0 && < 1.2,
517− base >= 4 && < 5,
504+ random >= 1.0 && < 1.3,
505+ base >= 4.8 && < 5,
506+ bytestring,
507+ containers,
508+ deepseq >= 1.1 && < 1.5,
509+ mtl >= 1.1.1.0 && < 2.3,
510+ text >= 0.11.3,
511+ unix,
512+ utf8-string >= 0.3 && < 1.1,
513+ vector >= 0.7
514+
515+test-suite verify-color-mapping
516+ default-language: Haskell2010
517+
518+ type: detailed-0.9
519+
520+ hs-source-dirs: test
521+
522+ test-module: VerifyColor240
523+
524+ other-modules: Verify
525+
526+ build-depends: vty,
527+ Cabal >= 1.20,
528+ QuickCheck >= 2.7,
529+ random >= 1.0 && < 1.3,
530+ base >= 4.8 && < 5,
518531 bytestring,
519532 containers,
520533 deepseq >= 1.1 && < 1.5,
@@ -526,7 +539,6 @@ test-suite verify-layers-span-generation
526539
527540test-suite verify-utf8-width
528541 default-language: Haskell2010
529− default-extensions: ScopedTypeVariables
530542
531543 type: detailed-0.9
532544
@@ -539,8 +551,8 @@ test-suite verify-utf8-width
539551 build-depends: vty,
540552 Cabal >= 1.20,
541553 QuickCheck >= 2.7,
542− random >= 1.0 && < 1.2,
543− base >= 4 && < 5,
554+ random >= 1.0 && < 1.3,
555+ base >= 4.8 && < 5,
544556 bytestring,
545557 containers,
546558 deepseq >= 1.1 && < 1.5,
@@ -552,7 +564,6 @@ test-suite verify-utf8-width
552564
553565test-suite verify-using-mock-input
554566 default-language: Haskell2010
555− default-extensions: ScopedTypeVariables
556567
557568 type: exitcode-stdio-1.0
558569
@@ -560,16 +571,17 @@ test-suite verify-using-mock-input
560571
561572 main-is: VerifyUsingMockInput.hs
562573
574+ other-modules: Verify.Graphics.Vty.Output
575+
563576 build-depends: vty,
564577 Cabal >= 1.20,
565− data-default >= 0.5.3,
566578 QuickCheck >= 2.7,
567579 smallcheck == 1.*,
568580 quickcheck-assertions >= 0.1.1,
569581 test-framework == 0.8.*,
570582 test-framework-smallcheck == 0.2.*,
571− random >= 1.0 && < 1.2,
572− base >= 4 && < 5,
583+ random >= 1.0 && < 1.3,
584+ base >= 4.8 && < 5,
573585 bytestring,
574586 containers,
575587 deepseq >= 1.1 && < 1.5,
@@ -587,7 +599,6 @@ test-suite verify-using-mock-input
587599
588600test-suite verify-config
589601 default-language: Haskell2010
590− default-extensions: ScopedTypeVariables
591602
592603 type: exitcode-stdio-1.0
593604
@@ -597,7 +608,6 @@ test-suite verify-config
597608
598609 build-depends: vty,
599610 Cabal >= 1.20,
600− data-default >= 0.5.3,
601611 HUnit,
602612 QuickCheck >= 2.7,
603613 smallcheck == 1.*,
@@ -605,8 +615,8 @@ test-suite verify-config
605615 test-framework == 0.8.*,
606616 test-framework-smallcheck == 0.2.*,
607617 test-framework-hunit,
608− random >= 1.0 && < 1.2,
609− base >= 4 && < 5,
618+ random >= 1.0 && < 1.3,
619+ base >= 4.8 && < 5,
610620 bytestring,
611621 containers,
612622 deepseq >= 1.1 && < 1.5,