master..44cc99a · vty · git.iko.soy

git.iko.soy/vty

on 44cc99a help sign in

.gitignore−1

since splitsnapshots

unifiedsplit

@@ -6,7 +6,6 @@ Setup

6dist

7dist-newstyle

8cabal.project.local

9−.ghc.environment.*

10test/benchmark

9test/benchmark

11.hpc

10.hpc

12.cabal-sandbox

11.cabal-sandbox

.travis.yml+17−100

@@ -1,109 +1,26 @@

1−# This Travis job script has been generated by a script via

2−#

3−# runghc make_travis_yml_2.hs 'vty.cabal'

4−#

5−# For more information, see https://github.com/haskell-CI/haskell-ci

6−#

7−language: c

1+language: haskell

8−sudo: false

10−git:

3+notifications:

11− submodules: false # whether to recursively clone submodules

4+ email: false

12−

13−cache:

14− directories:

15− - $HOME/.cabal/packages

16− - $HOME/.cabal/store

17−

18−before_cache:

19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

20− # remove files that are regenerated by 'cabal update'

21− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

22− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

24− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

26−

27− - rm -rfv $HOME/.cabal/packages/head.hackage

29matrix:

6matrix:

30− include:

7+ allow_failures:

31− - compiler: "ghc-8.4.3"

8+ - env: CABALVER=head GHCVER=head

32− # env: TEST=--disable-tests BENCH=--disable-benchmarks

33− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

34− - compiler: "ghc-8.2.2"

35− # env: TEST=--disable-tests BENCH=--disable-benchmarks

36− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}

37− - compiler: "ghc-8.0.2"

38− # env: TEST=--disable-tests BENCH=--disable-benchmarks

39− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}

40− - compiler: "ghc-7.10.3"

41− # env: TEST=--disable-tests BENCH=--disable-benchmarks

42− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}

44−before_install:

10+env:

45− - HC=${CC}

11+ - CABALVER=1.22 GHCVER=7.10.1

46− - HCPKG=${HC/ghc/ghc-pkg}

12+ - CABALVER=1.24 GHCVER=8.0.1

47− - unset CC

13+ - CABALVER=1.24 GHCVER=8.0.2

48− - ROOTDIR=$(pwd)

14+ - CABALVER=head GHCVER=head

49− - mkdir -p $HOME/.local/bin

50− - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"

51− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))

52− - echo $HCNUMVER

54install:

16install:

55− - cabal --version

17+ - ./ci/travis_ci_install

56− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

57− - BENCH=${BENCH---enable-benchmarks}

58− - TEST=${TEST---enable-tests}

59− - HADDOCK=${HADDOCK-true}

60− - UNCONSTRAINED=${UNCONSTRAINED-true}

61− - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

62− - GHCHEAD=${GHCHEAD-false}

63− - travis_retry cabal update -v

64− - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"

65− - rm -fv cabal.project cabal.project.local

66− - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'

67− - "printf 'packages: \".\"\\n' > cabal.project"

68− - touch cabal.project.local

69− - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- vty | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

70− - cat cabal.project || true

71− - cat cabal.project.local || true

72− - if [ -f "./configure.ac" ]; then

73− (cd "." && autoreconf -i);

74− fi

75− - rm -f cabal.project.freeze

76− - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

77− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

78− - rm -rf .ghc.environment.* "."/dist

79− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

81−# Here starts the actual work to be performed for the package under test;

82−# any command which exits with a non-zero exit code causes the build to fail.

83script:

19script:

84− # test that source-distributions can be generated

20+ - ./ci/travis_ci_script

85− - (cd "." && cabal sdist)

86− - mv "."/dist/vty-*.tar.gz ${DISTDIR}/

87− - cd ${DISTDIR} || false

88− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

89− - "printf 'packages: vty-*/*.cabal\\n' > cabal.project"

90− - touch cabal.project.local

91− - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- vty | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

92− - cat cabal.project || true

93− - cat cabal.project.local || true

94− # this builds all libraries and executables (without tests/benchmarks)

95− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all

97− # build & run tests, build benchmarks

22+before_install:

98− - cabal new-build -w ${HC} ${TEST} ${BENCH} all

23+ - sudo add-apt-repository -y ppa:hvr/ghc

99− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi

24+ - sudo apt-get update

100−

25+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER

101− # haddock

26+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH

102− - rm -rf ./dist-newstyle

103− - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi

104−

105− # Build without installed constraints for packages in global-db

106− - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi

107−

108−# REGENDATA ["vty.cabal"]

109−# EOF

CHANGELOG.md+329−782

@@ -1,861 +1,408 @@

1−

2−5.35.1

3−------

4−

5−Bug fixes:

6− * Fixed a build issue with a test program.

7−

8−5.35

9−----

10−

11−New features:

12− * Add support for 24-bit color (thanks @u-quark). This change

13− updates Vty to look at the `COLORTERM` environment variable that is

14− conventionally used to advertise support for truecolor escape

15− sequences. The change also updates the Vty demo to demonstrate

16− 24-bit colors. This change also adds a new data type, `ColorMode`,

17− to represent the color mode in use, as well as an `Output` interface

18− field, `outputColorMode`, to track the active color mode and use it

19− to clamp emitted color escape sequences to the active color range.

20−

21−API changes:

22− * All types in `Graphics.Vty.Input.Events` now have strict constructor

23− fields.

24− * Internal events are now wrapped in a new `InternalEvent` type to

25− improve how signal handling is done. This change modifies the `Input`

26− type's event channel API to produce `InternalEvents`, not `Events`.

27− The new `InternalEvent` either wraps `Event` with the `InputEvent`

28− constructor (the previous behavior) or indicates that Vty resumed

29− after handling a signal using the `ResumeAfterSignal` constructor.

30− This change avoids the previous use of `EvResize` with lazy exception

31− arguments as a sentinel value for `ResumeAfterSignal`.

32−

33−Other enhancements:

34− * Bracketed paste parsing performance has been greatly improved thanks

35− to benchmarking and optimization work by @iphydf. As part of that

36− work, Vty now uses bytestrings rather than Strings internally when

37− parsing input to look for events.

38− * The `\b` value is now interpreted as `KBS` (thanks @vglfr)

39−

40−5.34

41−----

42−

43−API changes:

44− * Added an `NFData` instance for `Event` (thanks Mario Lang)

45− * Removed `Monoid` and `Semigroup` instances for `Attr` and

46− `MaybeDefault`. This change removed the instances because they were

47− misbehaved; merging `Attr` and `MaybeDefault` values with these

48− instances resulted in field value losses. For example, before this

49− change,

50−```

51−(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)

52−```

53− would result in just

54−```

55− (defAttr `withBackColor` green)

56−```

57− because the instances were designed to favor the right-hand

58− arguments' fields even if they had not been explicitly set

59− (a consequence of the `MaybeDefault` `Semigroup` instance).

60− While that behavior was sensible specifically in the context of

61− `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made

62− for surprising instance behavior. Since there is actually no good way

63− to handle this in a `Semigroup` instance for `Attr` -- some choices

64− have to be made about how to merge two attributes' foreground colors,

65− and that won't be much better than what we had -- the instance was

66− just removed.

67−

68−

69−5.33

70−----

71−

72−API changes:

73−* The `Cursor` type got a new `PositionOnly` constructor for cursor

74− placement without visibility.

75−

76−Package changes:

77−* Relaxed upper bound for `random`

78−* Updated `microlens` bounds to allow 0.4.12

79−

80−Other improvements:

81−* Various hlint-driven improvements (thanks Willem Van Onsem)

82−* The implementation of `color240` was improved (thanks (Willem Van

83− Onsem)

84−

85−5.32

86−----

87−

88−New features:

89− * Meta-PageUp and Meta-PageDown are now supported (#193)

90− * Added `supportsItalics` and `supportsStrikethrough` functions to

91− check for feature support in terminfo

92−

93−Bug fixes:

94− * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka

95− Nkurumeh)

96−

97−5.31

98−----

99−

100−New features and API changes:

101− * Added support for strikethrough mode. This change adds a new

102− `strikethrough` `Style` value and uses the `smxx` and `rmxx`

103− Terminfo capabilities to activate and deactivate strikethrough mode,

104− respectively. If the terminfo does not report those capabilities,

105− this style is ignored.

106− * `Output`: added the `setDisplayBounds` field to set the output

107− dimensions of the output handle; added an implementation of this for

108− the `TerminfoBased` backend.

109−

110−Other changes:

111− * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.

112−

113−5.30

114−----

115−

116−New features:

117− * Added `Graphics.Vty.setWindowTitle` to emit an escape

118− sequence to set the window title, provide the terminal emulator

119− accepts Xterm-style title sequences. For details, see:

120− https://tldp.org/HOWTO/Xterm-Title-3.html

121−

122−5.29

123−----

124−

125−API changes:

126− * The Input type got a new field, 'restoreInputState'. This field

127− allows the end user to have direct access to the logic needed to

128− restore the terminal's input state flags. Prior to having this field,

129− this state restoration logic could only be invoked as part of calling

130− 'shutdownInput', but since that function does other things (like

131− killing threads) it is not advisable to call it repeatedly (which is

132− necessary in the use case this change is intended to support). This

133− can be called directly to restore the input state flags as needed,

134− although this is not required if 'shutdown' (or 'shutdownInput') is

135− called.

136−

137−Other changes:

138− * attributeControl: explicitly enable the ICRNL terminal mode flag (see

139− #187 and c572ad).

140−

141−5.28.2

142−------

143−

144−Bug fixes:

145− * Added a package dependency on `semigroups` for the

146− `vty-build-width-table` tool on older GHCs (#185)

147−

148−5.28.1

149−------

150−

151−Bug fixes:

152− * `installUnicodeWidthTable`: use `throwIO`, not `throw`

153−

154−5.28

155−----

156−

157−This release improves Vty's support for multi-column Unicode characters

158−and provides greater compatibility with a wider array of terminal

159−emulators. The following sections summarize the relevant changes, but an

160−overview of the new functionality is motivated and detailed in the new

161−"Multi-Column Character Support" README section. For

162−historical context, please also consider reading over

163−[#175](https://github.com/jtdaugherty/vty/issues/175).

164−

165−API changes:

166− * New modules were added:

167− * `Graphics.Vty.UnicodeWidthTable.Types`

168− * `Graphics.Vty.UnicodeWidthTable.IO`

169− * `Graphics.Vty.UnicodeWidthTable.Query`

170− * `Graphics.Vty.UnicodeWidthTable.Install`

171− * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,

172− that controls whether `mkVty` will attempt to load a Unicode width

173− table if specified in the configuration.

174−

175−Configuration file changes:

176− * A new syntax was added to support specifying Unicode width tables on

177− a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the

178− documentation for `Graphics.Vty.Config` for details. Since prior

179− versions of this library will silently ignore any configuration file

180− lines they cannot parse, this change to user configuration files is

181− at least non-breaking for older versions of Vty.

182−

183−Other changes:

184− * The `mkVty` function now automatically attempts to load a custom

185− Unicode width table if one is specified in the configuration,

186− provided `allowCustomUnicodeWidthTables` is not set to `Just False`.

187− See the documentation for `Graphics.Vty.mkVty` for details.

188− * Vty now includes a command line tool, `vty-build-width-table`, that

189− queries the terminal emulator to construct a custom Unicode width

190− table and optionally update the Vty configuration file to use it.

191− Programs that want to use that tool's functionality may also do so

192− via the API exposed in the various modules listed above.

193−

194−5.27

195−----

196−

197−* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the

198− kernel for the current terminal's settings to obtain the character

199− assigned by the `stty erase` command. That can then be added to the

200− Vty configuration's input map to map to `KBS` (backspace) if desired.

201−

202−5.26

203−----

204−

205−* Resolved various import warnings (thanks @glguy)

206−* Removed the `MonadIO` constraint from the Output type's fields and

207− removed `MonadFail` uses (PR #177, thanks @glguy)

208−* Clarified documentation for ANSI colors (thanks Colby Jenn)

209−* `Graphics.Vty.Attributes` no longer re-exports

210− `Graphics.Vty.Attributes.Color`

211−* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks

212− Colby Jenn)

213−* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)

214−* Changed from using `System.Posix.Env.getEnv` to

215− `System.Environment.lookupEnv` (thanks Jonathan Osser)

216−* Added `Graphics.Vty.Image` functions for dealing with character width

217− computations on `Text` values instead of `Strings`:

218− * `safeWctwidth`

219− * `safeWctlwidth`

220− * `wctwidth`

221− * `wctlwidth`

222−

223−5.25.1

224−------

225−

226−* Avoided a conflict with a Microlens 0.4.10 operator and added an

227− upper bound on Microlens of 0.4.11.

228−

229−5.25

230−----

231−

232−* The Vty type got a new field, isShutdown, that returns whether the

233− Vty handle has had its 'shutdown' function called (thanks Ian

234− Jeffries)

235−* Vty's shutdown function is now thread-safe.

236−

237−5.24.1

238−------

239−

240−* The "shutdown" method of Vty handles is now idempotent (#159)

241−

242−5.24

243−----

244−

245−* Add Generic and NFData instances for some types

246−* Image: remove custom Show instance, add derived Show and Read

247− instances

248−* Updated Travis build settings (thanks Eric Mertens)

249−

250−5.23.1

251−------

252−

253−* Fixed a bug where italics did not combine properly with other display

254− modes (#155, thanks Eric Mertens)

255−

256−5.23

257−----

258−

259−* Added support for italicized output when terminfo supports it. This

260− takes the form of a new Style, "italic". Note that most terminfo

261− descriptors do not report capabilities for italics, so support for

262− this will be very spotty.

263−* Updateed text/string function documentation to indicate that escapes

264− are not permitted in their inputs.

265−

266−5.22

267−----

268−

269−* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function

270− (thanks Brent Carmer)

271−* Added nextEventNonblocking function (field) to Vty type (#87)

272−

273−5.21

274−----

275−

276−* Picture and Background now provide Eq instances (thanks Jaro Reinders)

277−* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)

278−* #142: note requirement of threaded RTS

279−

280−5.20

281−----

282−

283−API changes:

284−* Split up Monoid instances into Monoid and Semigroup for newer GHCs

285− (thanks Ryan Scott)

286−

287−5.19.1

288−------

289−

290−API changes:

291−* Cursor now provides an Eq instance (thanks Jaro Reinders)

292−

293−5.19

294−----

295−

296−API changes:

297−* URL hyperlinking (via 'withURL') is now optional and disabled by

298− default due to poor support on some common terminals. A new 'Mode'

299− constructor, 'Hyperlink', has been added to enable this feature. To

300− change the hyperlinking mode, use 'setMode' on the 'outputIface' of a

301− Vty handle.

302−

303−5.18.1

304−------

305−

306−Bug fixes:

307−* Reset the hyperlink state on line endings to avoid run-on hyperlinks

308−

309−5.18

310−----

311−

312−API changes:

313−* Added support for hyperlinking attributes (thanks Getty Ritter). This

314− change adds a new Attr field for containing the hyperlink to apply,

315− as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda

316−

317−5.17.1

318−------

319−

320−* withStyle now ignores zero arguments, leaving attribute styles

321− untouched if the input style is the null style

322−

323−5.17

324−----

325−

326−API changes:

327−* Add support for terminal focus events. This change adds a new mode

328− usable with setMode, Focus, that requests that the terminal send

329− events on focus lose/gain. This change also adds two new Event

330− constructors, EvLostFocus and EvGainedFocus.

331−* No longer enable UTF8 mouse event encoding. This encoding was not

332− working properly with Terminal.app, and using the other modes (SGR,

333− etc.) work.

334−* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes

335− #131)

336−

337−5.16

338−----

339−

340−API changes:

341−* Added support for mouse wheel events while in mouse mode. The Button

342− type got two new constructors as a result: BScrollUp and BScrollDown.

343− Thanks to doublescale@tutanota.com for this contribution!

344−

345−Bug fixes:

346−* charFill now clamps negative arguments to zero (thanks Eric Mertens!)

347−

348−5.15.1

349−------

350−

351−Package changes:

352−* Documentation files are now marked accordingly (thanks Michal

353− Suchánek)

354−

355−Bug fixes:

356−* translateX/Y: fix negative translations

357−

358−5.15

359−----

360−

361−Package changes:

362−* Discontinued support for GHC versions prior to 7.10.1.

363−* Removed instructions and configuration for Stack builds since they

364− are no longer supported.

365−* Clarified README mention of (lack of) Windows support (contributors

366− wanted, though!)

367−* Removed dependency on data-default (see below).

368−

369−API changes:

370−* Moved color definitions from Attributes to Color module.

371−* In lieu of data-default (Default) instances for Attr and Config, use

372− 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.

373−* Graphics.Vty.Output no longer re-exports

374− Graphics.Vty.Output.Interface.

375−* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its

376− accessors to Graphics.Vty.Image.

377−* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.

378−* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.

379−

3805.14

15.14

381−----

382−

383−* addMaybeClippedJoin: instead of raising an exception when the join

2+ - addMaybeClippedJoin: instead of raising an exception when the join

384− is totally clipped, just reduce the clip amount and continue

3+ is totally clipped, just reduce the clip amount and continue

385−* addMaybeClipped: skip blit of joins when their primary dimension is

4+ - addMaybeClipped: skip blit of joins when their primary dimension is

386− zero

5+ zero

387−* 'string' and related text functions no longer treat an empty string

6+ - 'string' and related text functions no longer treat an empty string

388− as an empty image (thanks Chris Penner). This means that now it is

7+ as an empty image (thanks Chris Penner). This means that now it is

389− possible to use 'str ""' as a non-empty image with height 1.

8+ possible to use 'str ""' as a non-empty image with height 1.

390

3915.13

105.13

392−----

393−

394−* Reverted changes in 5.12 due to disagreements between terminal

11+ - Reverted changes in 5.12 due to disagreements between terminal

395− emulators and utf8proc; for more details, please see the ticket

12+ emulators and utf8proc; for more details, please see the ticket

396− discussion at

13+ discussion at

397− https://github.com/coreyoconnor/vty/issues/115

14+ https://github.com/coreyoconnor/vty/issues/115

398

3995.12

165.12

400−----

401−

402−* Replaced 'wcwidth' with a call to the utf8proc library's character

17+ - Replaced 'wcwidth' with a call to the utf8proc library's character

403− width function, which is much more up to date (by several Unicode

18+ width function, which is much more up to date (by several Unicode

404− versions) and returns the right width for a much larger set of

19+ versions) and returns the right width for a much larger set of

405− characters.

20+ characters.

406−* Added a bundled version of the utf8proc C library.

21+ - Added a bundled version of the utf8proc C library.

407

4085.11.3

235.11.3

409−------

410−

411−* Fix mouse event offsets in mouse-up events

24+ - Fix mouse event offsets in mouse-up events

412

4135.11.2

265.11.2

414−------

415−

416−* Mouse events were modified so that the upper-left corner of the window

27+ - Mouse events were modified so that the upper-left corner of the

417− is (0,0) rather than (1,1).

28+ window is (0,0) rather than (1,1).

418

4195.11.1

305.11.1

420−------

421−

422−* Add Generic instance for Image

31+ - Add Generic instance for Image

423−* nextEvent: stop trying to refresh on a resize event (fixes segfault

32+ - nextEvent: stop trying to refresh on a resize event (fixes segfault

424− on refresh with normal cursor positioning mode)

33+ on refresh with normal cursor positioning mode)

425−* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)

34+ - Remove redundant clause from clipForCharWidth (thanks Eric Mertens)

426−* Update maintainer

35+ - Update maintainer

427

4285.11

375.11

429−----

430−

431−* Vty now raises a VtyConfigurationError exception when the TERM

38+ - Vty now raises a VtyConfigurationError exception when the TERM

432− evironment variable is missing (thanks Eric Mertens)

39+ evironment variable is missing (thanks Eric Mertens)

433−* Graphics.Vty.Config got an explicit export list to avoid accidentally

40+ - Graphics.Vty.Config got an explicit export list to avoid accidentally

434− exporting internal types (thanks Eric Mertens)

41+ exporting internal types (thanks Eric Mertens)

435

4365.10

435.10

437−----

438−

439−* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This

44+ - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This

440− mode provides greater control over cursor positioning by bypassing

45+ mode provides greater control over cursor positioning by bypassing

441− the logical positioning provided by default. Rather than positioning

46+ the logical positioning provided by default. Rather than positioning

442− the cursor by looking at the widths of characters involved, this

47+ the cursor by looking at the widths of characters involved, this

443− constructor lets you provide a physical row and column instead. This

48+ constructor lets you provide a physical row and column instead. This

444− is useful in more sophisticated programs. (thanks Eric Mertens)

49+ is useful in more sophisticated programs. (thanks Eric Mertens)

445−* Added a new Generic-derived config parser (thanks Eric Mertens)

50+ - Added a new Generic-derived config parser (thanks Eric Mertens)

446−* Fixed the MShift case in the configuration file parser (thanks Eric

51+ - Fixed the MShift case in the configuration file parser (thanks Eric

447− Mertens)

52+ Mertens)

448−* Fixed wcwidth import and matched safeWcswidth to its documented

53+ - Fixed wcwidth import and matched safeWcswidth to its documented

449− behavior. Previously vty_mk_wcwidth was being imported with the

54+ behavior. Previously vty_mk_wcwidth was being imported with

450− wrong type causing the -1 return value to be mapped to the wrong Int

55+ the wrong type causing the -1 return value to be mapped to the

451− value. Additionally safeWcswidth was using the unsafe character width

56+ wrong Int value. Additionally safeWcswidth was using the unsafe

452− function and only ensuring that the final result was non-negative.

57+ character width function and only ensuring that the final result was

453− (thanks Eric Mertens)

58+ non-negative. (thanks Eric Mertens)

454

4555.9.1

605.9.1

456−-----

457−

458−* Vty now only emits UTF8 charset sequences in terminals without a

61+ - Vty now only emits UTF8 charset sequences in terminals without a

459− preexisting UTF8 declaration to avoid emitting garbage sequences

62+ preexisting UTF8 declaration to avoid emitting garbage sequences

460− (fixes #89)

63+ (fixes #89)

461

4625.9

655.9

463−---

464−

465−* Added new Output methods supportsBell and ringTerminalBell to find out

66+ - Added new Output methods supportsBell and ringTerminalBell to find

466− whether the output device has an audio bell and to ring it (see #102)

67+ out whether the output device has an audio bell and to ring it (see

68+ #102)

467

4685.8.1

705.8.1

469−-----

470−

471−* Fixed "refresh" to work as advertised (see #104)

71+ - Fixed "refresh" to work as advertised (see #104)

472

4735.8

735.8

474−---

475−

476−* API change: EvPaste input event now provides paste data as a raw

74+ - API change: EvPaste input event now provides paste data as a raw

477− ByteString rather than a String to allow the application to decode how

75+ ByteString rather than a String to allow the application to decode

478− best to decode it

76+ how best to decode it

479

4805.7.1

785.7.1

481−-----

482−

483−* ModeDemo: added an explicit Control.Applicative import for older GHCs

79+ - ModeDemo: added an explicit Control.Applicative import for older

80+ GHCs

484

4855.7

825.7

486−---

487−

488−* Mouse and paste modes are now off by default.

83+ - Mouse and paste modes are now off by default.

489−* The Config type got new fields: mouseMode and bracketedPasteMode.

84+ - The Config type got new fields: mouseMode and bracketedPasteMode.

490− These determine whether these modes are enabled initially (for

85+ These determine whether these modes are enabled initially (for

491− terminals that support them).

86+ terminals that support them).

492−* Added a Mode type for modal terminal features (mouse events,

87+ - Added a Mode type for modal terminal features (mouse events,

493− bracketed paste mode) that is used with new Output interface

88+ bracketed paste mode) that is used with new Output interface

494− functions:

89+ functions:

495− * supportsMode :: Mode -> Bool tells whether the device supports a

90+ * supportsMode :: Mode -> Bool tells whether the device supports a

496− mode

91+ mode

497− * setMode :: Mode -> Bool -> IO () turns a mode on or off

92+ * setMode :: Mode -> Bool -> IO () turns a mode on or off

498− * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or

93+ * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or

499− off

94+ off

500−* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes

95+ - Added a new demo program, ModeDemo.hs, to demonstrate usage of modes

501

5025.6

975.6

503−---

504−

505−* Added support for normal and extended mouse modes in Xterm-like

98+ - Added support for normal and extended mouse modes in Xterm-like

506− terminals via the MouseDown and MouseUp Event constructors

99+ terminals via the MouseDown and MouseUp Event constructors

507−* Added support for bracketed paste mode in Xterm-like terminals via

100+ - Added support for bracketed paste mode in Xterm-like terminals via

508− the EvPaste event constructor

101+ the EvPaste event constructor

509−* Added derived Show instances for Event and Button (thanks Felix

102+ - Added derived Show instances for Event and Button (thanks Felix

510− Hirn)

103+ Hirn)

511−* Now TERM values containing "screen" will automatically use the

104+ - Now TERM values containing "screen" will automatically use the

512− XtermColor driver rather than just TerminfoBased

105+ XtermColor driver rather than just TerminfoBased

513

106

5145.5.0

1075.5.0

515−-----

516−

517−* Replaced lens dependency with microlens, microlens-mtl, microlens-th

108+ - Replaced lens dependency with microlens, microlens-mtl, microlens-th

518− dependencies. Issue #90

109+ dependencies. Issue #90

519− * Thanks Jonathan Daugherty

110+ - Thanks Jonathan Daugherty

520−* Cabal corrections.

111+ - Cabal corrections.

521− * Thanks Lennart Spitzner

112+ - Thanks Lennart Spitzner

522

113

5235.4.0

1145.4.0

524−-----

525−

526−* Changed eventChannel of Graphics.Vty.Input from Chan to

115+ - Changed eventChannel of Graphics.Vty.Input from Chan to TChan.

527− TChan. This enables clients to query if there are no pending

116+ This enables clients to query if there are no pending events. The

528− events. The Graphics.Vty interface nextEvent is unchanged.

117+ Graphics.Vty interface nextEvent is unchanged. Clients that use

529− Clients that use eventChannel directly will require updating.

118+ eventChannel directly will require updating.

530− https://github.com/coreyoconnor/vty/issues/60

119+ https://github.com/coreyoconnor/vty/issues/60

531−

5325.3.1

1205.3.1

533−-----

534−

535−* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to

121+ - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due

536− possibly breaking this on reasonable GHC versions

122+ to possibly breaking this on reasonable GHC versions

537

123

5385.3

1245.3

539−---

540−

541−* Upgraded QuickCheck dependency to 2.7

125+ - Upgraded QuickCheck dependency to 2.7

542−* The standard IO Config (standardIOConfig) was overriding any provided

126+ - The standard IO Config (standardIOConfig) was overriding any

543− application config. In addition, the inputFd and outputFd could not be

127+ provided application config. In addition, the inputFd and outputFd

544− changed if mkVty was used. Fixed.

128+ could not be changed if mkVty was used. Fixed.

545−* Correct handling of display attributes at end of line. The output

129+ - Correct handling of display attributes at end of line. The output

546− attributes are set to default at the end of content for the line and

130+ attributes are set to default at the end of content for the line and

547− at the start of a new line. Previously the current attribute would

131+ at the start of a new line. Previously the current attribute would

548− extend to the next start of content. This was odd to reason about and

132+ extend to the next start of content. This was odd to reason about

549− was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi

133+ and was the cause of https://github.com/coreyoconnor/vty/issues/76

550− requires the old behavior to display the selection region correctly.

134+ IIRC Yi requires the old behavior to display the selection region

135+ correctly.

551−* shutdown of the input thread is now performed using killThread and

136+ - shutdown of the input thread is now performed using killThread and

552− synchronization on an MVar. For correct handling of the terminal read

137+ synchronization on an MVar. For correct handling of the terminal

553− vmin and vtime the read must be a blocking read on an OS thread.

138+ read vmin and vtime the read must be a blocking read on an OS

554− This places a threadWaitRead, which will be interrupted by the

139+ thread. This places a threadWaitRead, which will be interrupted by

555− killThread, prior to the uninterruptable read. An alternative would be

140+ the killThread, prior to the uninterruptable read. An alternative

556− to re-import the read foreign call as interruptable.

141+ would be to re-import the read foreign call as interruptable.

557

142

5585.2.11

1435.2.11

559−------

560−

561−* deepseq bounds increased for tests.

144+ - deepseq bounds increased for tests.

562−* Clean up warnings when compiling on 7.10

145+ - Clean up warnings when compiling on 7.10

563− * Thanks Eric Mertens

146+ - Thanks Eric Mertens

564−* Avoid discarding input bytes after multi-byte encoded codepoint

147+ - Avoid discarding input bytes after multi-byte encoded codepoint

565− * Thanks Eric Mertens

148+ - Thanks Eric Mertens

566

149

5675.2.10

1505.2.10

568−------

569−

570−* "str" now returns EmptyImage for empty strings to match behavior of

151+ - "str" now returns EmptyImage for empty strings to match behavior of

571− other string-like Image constructors (fixes #74)

152+ other string-like Image constructors (fixes #74)

572− * Thanks Jonathan Daugherty

153+ - Thanks Jonathan Daugherty

573

154

5745.2.9

1555.2.9

575−-----

576−

577−* dependency version bumps

156+ - dependency version bumps

578− * https://github.com/coreyoconnor/vty/pull/71

157+ - https://github.com/coreyoconnor/vty/pull/71

579− * https://github.com/coreyoconnor/vty/pull/70

158+ - https://github.com/coreyoconnor/vty/pull/70

580−* Correct/Simplify the example code

159+ - Correct/Simplify the example code

581− * Thanks glguy

160+ - Thanks glguy

582− * https://github.com/coreyoconnor/vty/pull/69

161+ - https://github.com/coreyoconnor/vty/pull/69

583

162

5845.2.8

1635.2.8

585−-----

586−

587−* blaze-builder, lens, utf8-string version constraint bump

164+ - blaze-builder, lens, utf8-string version constraint bump

588− * Thanks glguy

165+ - Thanks glguy

589− * https://github.com/coreyoconnor/vty/pull/67

166+ - https://github.com/coreyoconnor/vty/pull/67

590−* Do not differentiate based on TERM_PROGRAM

167+ - Do not differentiate based on TERM_PROGRAM

591− * https://github.com/coreyoconnor/vty/issues/68

168+ - https://github.com/coreyoconnor/vty/issues/68

592

169

5935.2.7

1705.2.7

594−-----

595−

596−* lens and deepseq constraint bump + misc

171+ - lens and deepseq constraint bump + misc

597− * Thanks ethercrow

172+ - Thanks ethercrow

598− * https://github.com/coreyoconnor/vty/pull/66

173+ - https://github.com/coreyoconnor/vty/pull/66

599

174

6005.2.6

1755.2.6

601−-----

602−

603−* lens constraint bump

176+ - lens constraint bump

604− * Thanks alexander-b!

177+ - Thanks alexander-b!

605− * https://github.com/coreyoconnor/vty/pull/64

178+ - https://github.com/coreyoconnor/vty/pull/64

606

179

6075.2.5

1805.2.5

608−-----

609−

610−* lens and random version constraint bump.

181+ - lens and random version constraint bump.

611− * Thanks RyanGlScott!

182+ - Thanks RyanGlScott!

612− * https://github.com/coreyoconnor/vty/pull/62

183+ - https://github.com/coreyoconnor/vty/pull/62

613

184

6145.2.4

1855.2.4

615−-----

616−

617−* removed -fpic from cc-options. No longer required.

186+ - removed -fpic from cc-options. No longer required.

618− * https://github.com/coreyoconnor/vty/issues/61

187+ - https://github.com/coreyoconnor/vty/issues/61

619− * https://ghc.haskell.org/trac/ghc/ticket/9657

188+ - https://ghc.haskell.org/trac/ghc/ticket/9657

620− * Thanks Fuuzetsu!

189+ - Thanks Fuuzetsu!

621

190

6225.2.3

1915.2.3

623−-----

624−

625−* evaluate/compile the input parsing table once instead of each

192+ - evaluate/compile the input parsing table once instead of each

626− keystroke.

193+ keystroke.

627− * https://github.com/coreyoconnor/vty/pull/59

194+ - https://github.com/coreyoconnor/vty/pull/59

628− * Thanks ethercrow!

195+ - Thanks ethercrow!

629

196

6305.2.2

1975.2.2

631−-----

632−

633−* When looking at input for an event, don't look too deep.

198+ - When looking at input for an event, don't look too deep.

634− * https://github.com/coreyoconnor/vty/pull/57

199+ - https://github.com/coreyoconnor/vty/pull/57

635− * Thanks ethercrow!

200+ - Thanks ethercrow!

636

201

6375.2.1

2025.2.1

638−-----

639−

640−* Bump upper version bound for lens to 4.5. Thanks markus1189!

203+ - Bump upper version bound for lens to 4.5. Thanks markus1189!

641

204

6425.2.0

2055.2.0

643−-----

644−

645−* Config structure now specifies file descriptor to use. The default

206+ - Config structure now specifies file descriptor to use. The default

646− is stdInput and stdOutput file descriptors. Previously Vty used

207+ is stdInput and stdOutput file descriptors. Previously Vty used

647− stdInput for input and the follow code for output:

208+ stdInput for input and the follow code for output:

648− * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`

209+ - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`

649− NoBuffering)

210+ NoBuffering)

650− * the difference was required by Vty.Inline. Now, Vty.Inline uses

211+ - the difference was required by Vty.Inline. Now, Vty.Inline uses

651− the Config structure options to acheive the same effect.

212+ the Config structure options to acheive the same effect.

652−* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,

213+ - removed: derivedVtime, derivedVmin, inputForCurrentTerminal,

653− inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO

214+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO

654−* added: inputForConfig, outputForConfig

215+ - added: inputForConfig, outputForConfig

655−* updates to vty-rogue from jtdaugherty. Thanks!

216+ - updates to vty-rogue from jtdaugherty. Thanks!

656−* the oldest version of GHC tested to support vty is 7.6.2.

217+ - the oldest version of GHC tested to support vty is 7.6.2.

657−* the oldest version of GHC that vty compiles under is 7.4.2

218+ - the oldest version of GHC that vty compiles under is 7.4.2

658

219

6595.1.4

2205.1.4

660−-----

661−

662−* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!

221+ - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!

663

222

6645.1.1

2235.1.1

665−-----

666−

667−* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!

224+ - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!

668−* jtdaugherty resolved a number of compiler warnings. Thanks!

225+ - jtdaugherty resolved a number of compiler warnings. Thanks!

669

226

6705.1.0

2275.1.0

671−-----

672−

673−* vmin and vtime can be specified however the application requires.

228+ - vmin and vtime can be specified however the application requires.

674− See Graphics.Vty.Config.

229+ See Graphics.Vty.Config.

675−* fixed the processing of input when vmin is set > 1.

230+ - fixed the processing of input when vmin is set > 1.

676

231

6775.0.0

2325.0.0

678−-----

679−

680−* The naming convention now matches:

233+ - The naming convention now matches:

681− * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions

234+ - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions

682−* all projects using vty for input must be compiled with -threaded.

235+ - all projects using vty for input must be compiled with -threaded.

683− Please notify vty author if this is not acceptable.

236+ Please notify vty author if this is not acceptable.

684−* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized

237+ - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized

685− vty with the default configuration.

238+ vty with the default configuration.

686−* input handling changes

239+ - input handling changes

687− * KASCII is now KChar

240+ - KASCII is now KChar

688− * KPN5 is now KCenter

241+ - KPN5 is now KCenter

689− * tests exist.

242+ - tests exist.

690− * Applications can add to the input tables by setting inputMap of

243+ - Applications can add to the input tables by setting inputMap of

691− the Config. See Graphics.Vty.Config

244+ the Config. See Graphics.Vty.Config

692− * Users can define input table extensions that will apply to all vty

245+ - Users can define input table extensions that will apply to all vty

693− applications. See Graphics.Vty.Config

246+ applications. See Graphics.Vty.Config

694− * terminal timing is now handled by selecting an appropriate VTIME.

247+ - terminal timing is now handled by selecting an appropriate VTIME.

695− Previously this was implemented within Vty itself. This reduced

248+ Previously this was implemented within Vty itself. This reduced

696− complexity in vty but provides a different meta key behavior and

249+ complexity in vty but provides a different meta key behavior and

697− implies a requirement on -threaded.

250+ implies a requirement on -threaded.

698− * The time vty will wait to verify an ESC byte means a single ESC

251+ - The time vty will wait to verify an ESC byte means a single ESC

699− key is the singleEscPeriod of the Input Config structure.

252+ key is the singleEscPeriod of the Input Config structure.

700−* removed the typeclass based terminal and display context interface

253+ - removed the typeclass based terminal and display context interface

701− in favor of a data structure of properties interface.

254+ in favor of a data structure of properties interface.

702−* renamed the Terminal interface to Output

255+ - renamed the Terminal interface to Output

703−* The default picture for an image now uses the "clear" background.

256+ - The default picture for an image now uses the "clear" background.

704− This background fills background spans with spaces or just ends the

257+ This background fills background spans with spaces or just ends the

705− line.

258+ line.

706− * Previously the background defaulted to the space character. This

259+ - Previously the background defaulted to the space character. This

707− causes issues copying text from a text editor. The text would end

260+ causes issues copying text from a text editor. The text would end

708− up with extra spaces at the end of the line.

261+ up with extra spaces at the end of the line.

709−* Layer support

262+ - Layer support

710− * Each layer is an image.

263+ - Each layer is an image.

711− * The layers for a picture are a list of images.

264+ - The layers for a picture are a list of images.

712− * The first image is the top-most layer. The images are ordered from

265+ - The first image is the top-most layer. The images are ordered from

713− top to bottom.

266+ top to bottom.

714− * The transparent areas for a layer are the backgroundFill areas.

267+ - The transparent areas for a layer are the backgroundFill areas.

715− backgroundFill is added to pad images when images of different

268+ backgroundFill is added to pad images when images of different

716− sizes are joined.

269+ sizes are joined.

717− * If the background is clear there is no background layer.

270+ - If the background is clear there is no background layer.

718− * If there is a background character then the bottom layer is the

271+ - If there is a background character then the bottom layer is the

719− background layer.

272+ background layer.

720− * emptyPicture is a Picture with no layers and no cursor

273+ - emptyPicture is a Picture with no layers and no cursor

721− * addToTop and addToBottom add a layer to the top and bottom of the

274+ - addToTop and addToBottom add a layer to the top and bottom of the

722− given Picture.

275+ given Picture.

723−* compatibility improvements:

276+ - compatibility improvements:

724− * terminfo based terminals with no cursor support are silently

277+ - terminfo based terminals with no cursor support are silently

725− accepted. The cursor visibility changes in the Picture will have

278+ accepted. The cursor visibility changes in the Picture will have

726− no effect.

279+ no effect.

727− * alternate (setf/setb) color maps supported. Though colors beyond

280+ - alternate (setf/setb) color maps supported. Though colors beyond

728− the first 8 are just a guess.

281+ the first 8 are just a guess.

729− * added "rgbColor" for easy support of RGB specified colors.

282+ - added "rgbColor" for easy support of RGB specified colors.

730− * Both applications and users can add to the mapping used to

283+ - Both applications and users can add to the mapping used to

731− translate from input bytes to events.

284+ translate from input bytes to events.

732−* Additional information about input and output process can be

285+ - Additional information about input and output process can be

733− appended to a debug log

286+ appended to a debug log

734− * Set environment variable VTY_DEBUG_LOG to path of debug log

287+ - Set environment variable VTY_DEBUG_LOG to path of debug log

735− * Or use "debugLog <path>" config directive

288+ - Or use "debugLog <path>" config directive

736− * Or set 'debugLog' property of the Config provided to mkVty.

289+ - Or set 'debugLog' property of the Config provided to mkVty.

737−* examples moved to vty-examples package. See test directory for cabal

290+ - examples moved to vty-examples package. See test directory for cabal

738− file.

291+ file.

739− * vty-interactive-terminal-test

292+ - vty-interactive-terminal-test

740− * interactive test. Useful for building a bug report for vty's

293+ - interactive test. Useful for building a bug report for vty's

741− author.

294+ author.

742− * test/interactive_terminal_test.hs

295+ - test/interactive_terminal_test.hs

743− * vty-event-echo

296+ - vty-event-echo

744− * view a input event log for vty. Example of interacting with

297+ - view a input event log for vty. Example of interacting with

745− user.

298+ user.

746− * test/EventEcho.hs

299+ - test/EventEcho.hs

747− * vty-rogue

300+ - vty-rogue

748− * The start of a rogue-like game. Example of layers and image

301+ - The start of a rogue-like game. Example of layers and image

749− build operations.

302+ build operations.

750− * test/Rogue.hs

303+ - test/Rogue.hs

751− * vty-benchmark

304+ - vty-benchmark

752− * benchmarks vty. A series of tests that push random pictures to

305+ - benchmarks vty. A series of tests that push random pictures to

753− the terminal. The random pictures are generated using

306+ the terminal. The random pictures are generated using

754− QuickCheck. The same generators used in the automated tests.

307+ QuickCheck. The same generators used in the automated tests.

755− * test/benchmark.hs

308+ - test/benchmark.hs

756

309

7574.7.0.0

3104.7.0.0

758−-------

311+ - API changes:

312+ - Added Graphics.Vty.Image.crop: Ensure an image is no larger

313+ than the specified size.

314+ - Added Graphics.Vty.Image.pad: Ensure an image is no smaller

315+ than the specified size.

316+ - Added Graphics.Vty.Image.translate: Offset an image.

317+ - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.

759

318

760−API changes:

319+4.3.0.0

761−* Added Graphics.Vty.Image.crop: Ensure an image is no larger

762− than the specified size.

763−* Added Graphics.Vty.Image.pad: Ensure an image is no smaller

764− than the specified size.

765−* Added Graphics.Vty.Image.translate: Offset an image.

766−* Thanks Ben Boeckel <MathStuf@gmail.com> for these features.

767

320

7684.2.1.0

3214.2.1.0

769−-------

770−

771−API changes:

322+ - API changes:

772−* Attr record accessor fore_color changed to attr_fore_color

323+ - Attr record accessor fore_color changed to attr_fore_color

773−* Attr record accessor back_color changed to attr_back_color

324+ - Attr record accessor back_color changed to attr_back_color

774−* Attr record accessor style changed to attr_style

325+ - Attr record accessor style changed to attr_style

775−* Added an "inline" display attribute changing DSL:

326+ - Added an "inline" display attribute changing DSL:

776− * put_attr_change applies a display attribute change

327+ - put_attr_change applies a display attribute change

777− immediately to a terminal

328+ immediately to a terminal

778− * For instance, can be used to change the display attrbiutes

329+ - For instance, can be used to change the display attrbiutes

779− of text output via putStrLn and putStr. EX:

330+ of text output via putStrLn and putStr. EX:

780− "put_attr_change $ back_color red" will set the background

331+ "put_attr_change $ back_color red" will set the background

781− color to red.

332+ color to red.

782− * Changes do not apply to a Picture output via output_picture.

333+ - Changes do not apply to a Picture output via output_picture.

783− * See Graphics.Vty.Inline

334+ - See Graphics.Vty.Inline

784−* Moved all IO actions into any monad an instance of MonadIO

335+ - Moved all IO actions into any monad an instance of MonadIO

785

336

7864.0.0.1

3374.0.0.1

787−-------

788−

789−* binding for mk_wcswidth was incorrect. Most platforms just

338+ - binding for mk_wcswidth was incorrect. Most platforms just

790− magically worked due to coincidence.

339+ magically worked due to coincidence.

791

340

7924.0.0

3414.0.0

793−-----

794−

795−API changes:

342+ - API changes:

796−* "getSize" has been removed. Use "terminal vty >>= display_bounds"

343+ - "getSize" has been removed. Use "terminal vty >>= display_bounds"

797− where "vty" is an instance of the Vty data structure.

344+ where "vty" is an instance of the Vty data structure.

798−* added a "terminal" field to the Vty data structure. Accesses the

345+ - added a "terminal" field to the Vty data structure. Accesses the

799− TerminalHandle associated with the Vty instance.

346+ TerminalHandle associated with the Vty instance.

800−* Graphics.Vty.Types has undergone a number of changes. Summary:

347+ - Graphics.Vty.Types has undergone a number of changes. Summary:

801− * Partitioned into Graphics.Vty.Attributes for display attributes.

348+ - Partitioned into Graphics.Vty.Attributes for display attributes.

802− Graphics.Vty.Image for image combinators. Graphics.Vty.Picture

349+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture

803− for final picture construction.

350+ for final picture construction.

804−* Graphics.Vty.Attributes:

351+ - Graphics.Vty.Attributes:

805− * "setFG" and "setBG" are now "with_fore_color" and

352+ - "setFG" and "setBG" are now "with_fore_color" and

806− "with_back_color"

353+ "with_back_color"

807− * All other "set.." equations similarly replaced.

354+ - All other "set.." equations similarly replaced.

808− * "attr" is now "def_attr", short for "default display attributes"

355+ - "attr" is now "def_attr", short for "default display attributes"

809− Also added a "current_attr" for "currently applied display

356+ Also added a "current_attr" for "currently applied display

810− attributes"

357+ attributes"

811−* Graphics.Vty.Image:

358+ - Graphics.Vty.Image:

812− * "horzcat" is now "horiz_cat"

359+ - "horzcat" is now "horiz_cat"

813− * "vertcat" is now "vert_cat"

360+ - "vertcat" is now "vert_cat"

814− * "renderBS" is now "utf8_bytestring"

361+ - "renderBS" is now "utf8_bytestring"

815− * "renderChar" is now "char"

362+ - "renderChar" is now "char"

816− * "renderFill" is now "char_fill"

363+ - "renderFill" is now "char_fill"

817− * added a "utf8_string" and "string" (AKA "iso_10464_string") for

364+ - added a "utf8_string" and "string" (AKA "iso_10464_string") for

818− UTF-8 encoded Strings and ISO-10464 encoded Strings. String

365+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String

819− literals in GHC have an ISO-10464 runtime representation.

366+ literals in GHC have an ISO-10464 runtime representation.

820−* Graphics.Vty.Picture:

367+ - Graphics.Vty.Picture:

821− * exports Graphics.Vty.Image

368+ - exports Graphics.Vty.Image

822− * "pic" is now "pic_for_image"

369+ - "pic" is now "pic_for_image"

823− * added API for setting background fill pattern.

370+ - added API for setting background fill pattern.

824−* Completely rewritten output backend.

371+ - Completely rewritten output backend.

825− * Efficient, scanline style output span generator. Has not been

372+ - Efficient, scanline style output span generator. Has not been

826− fully optimized, but good enough.

373+ fully optimized, but good enough.

827− * The details required to display the desired picture on a

374+ - The details required to display the desired picture on a

828− terminal are well encapsulated.

375+ terminal are well encapsulated.

829− * Terminfo based display terminal implementation. With specialized

376+ - Terminfo based display terminal implementation. With specialized

830− derivitives for xterm, Terminal.app, and iTerm.app.

377+ derivitives for xterm, Terminal.app, and iTerm.app.

831− * Attempts to robustly handle even terminals that don't

378+ - Attempts to robustly handle even terminals that don't

832− support all display attributes.

379+ support all display attributes.

833− * I've tested the following terminals with success: iTerm.app,

380+ - I've tested the following terminals with success: iTerm.app,

834− Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,

381+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,

835− konsole, screen, linux vty. Hopefully you will be as

382+ konsole, screen, linux vty. Hopefully you will be as

836− successfull.

383+ successfull.

837− * Improved unicode support. Double wide characters will display as

384+ - Improved unicode support. Double wide characters will display as

838− expected.

385+ expected.

839−* 256 color support. See Graphics.Vty.Attributes.Color240. The actual

386+ - 256 color support. See Graphics.Vty.Attributes.Color240. The actual

840− output color is adjusted according to the number of colors the

387+ output color is adjusted according to the number of colors the

841− terminal supports.

388+ terminal supports.

842−* The Graphics.Vty.Image combinators no longer require matching

389+ - The Graphics.Vty.Image combinators no longer require matching

843− dimensions to arguments. Unspecified areas are filled in with a

390+ dimensions to arguments. Unspecified areas are filled in with a

844− user-customizable background pattern. See Graphics.Vty.Picture.

391+ user-customizable background pattern. See Graphics.Vty.Picture.

845−* output images are always cropped to display size.

392+ - output images are always cropped to display size.

846−* Significant code coverage by QuickCheck tests. An interactive test

393+ - Significant code coverage by QuickCheck tests. An interactive test

847− for those final properties that couldn't be automatically verified.

394+ for those final properties that couldn't be automatically verified.

848

395

849Issues resolved:

396Issues resolved:

850−* "gnome terminal displays non-basic attributes as strikethrough"

397+ - "gnome terminal displays non-basic attributes as strikethrough"

851− * http://trac.haskell.org/vty/ticket/14

398+ - http://trac.haskell.org/vty/ticket/14

852−* "Multi-byte characters are not displayed correctly on update"

399+ - "Multi-byte characters are not displayed correctly on update"

853− * http://trac.haskell.org/vty/ticket/10

400+ - http://trac.haskell.org/vty/ticket/10

854−* "Redraw does not handle rendering a line that extends beyond screen

401+ - "Redraw does not handle rendering a line that extends beyond screen

855− width characters"

402+ width characters"

856− * http://trac.haskell.org/vty/ticket/13

403+ - http://trac.haskell.org/vty/ticket/13

857−* "The <|> and <-> combinators should be more forgiving of mismatched

404+ - "The <|> and <-> combinators should be more forgiving of mismatched

858− dimensions"

405+ dimensions"

859− * http://trac.haskell.org/vty/ticket/9

406+ - http://trac.haskell.org/vty/ticket/9

860−* "256-color support"

407+ - "256-color support"

861− * http://trac.haskell.org/vty/ticket/19

408+ - http://trac.haskell.org/vty/ticket/19

LICENSE−2

@@ -1,5 +1,3 @@

1−BSD 3-Clause License

2−

3Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009

1Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009

5All rights reserved.

3All rights reserved.

README.md+54−109

@@ -7,7 +7,7 @@ interface for doing terminal I/O. Vty is supported on GHC versions

7Install via `git` with:

9```

10−git clone git://github.com/jtdaugherty/vty.git

10+git clone git://github.com/coreyoconnor/vty.git

11```

13Install via `cabal` with:

@@ -18,21 +18,24 @@ cabal install vty

19# Features

21−* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,

21+* Supports a large number of terminals. vt100, ansi, hurd, linux,

22− `screen`, etc., or anything with a sufficient terminfo entry.

22+ screen, etc., or anything with a sufficient terminfo entry.

24−* Automatically handles window resizes.

24+* Automatic handling of window resizes.

26−* Supports Unicode output on terminals with UTF-8 support.

26+* Unicode output on terminals with UTF-8 support.

28+* Handles multi-column glyphs. (Requires user to properly configure

29+ terminal.)

30+

28−* Provides an efficient output algorithm. Output buffering and terminal

31+* Efficient output. Output buffering and terminal state changes are

29− state changes are minimized.

32+ minimized.

31* Minimizes repaint area, which virtually eliminates the flicker

34* Minimizes repaint area, which virtually eliminates the flicker

32 problems that plague ncurses programs.

35 problems that plague ncurses programs.

34−* Provides a pure, compositional interface for efficiently constructing

37+* A pure, compositional interface for efficiently constructing display

35− display images.

38+ images.

37* Automatically decodes keyboard keys into (key,[modifier]) tuples.

40* Automatically decodes keyboard keys into (key,[modifier]) tuples.

@@ -41,7 +44,7 @@ cabal install vty

41* Supports a keypress timeout after for lone ESC. The timeout is

44* Supports a keypress timeout after for lone ESC. The timeout is

42 customizable.

45 customizable.

44−* Provides extensible input and output interfaces.

47+* The interface is designed for easy extension.

46* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)

49* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)

47 with a type-safe interface and graceful fallback for terminals

50 with a type-safe interface and graceful fallback for terminals

@@ -57,106 +60,16 @@ cabal install vty

57* Supports bracketed paste mode as described at

60* Supports bracketed paste mode as described at

58 http://cirw.in/blog/bracketed-paste

61 http://cirw.in/blog/bracketed-paste

60−* Supports multi-column Unicode characters such as emoji characters. In

61− cases where Vty and your terminal emulator disagree on character

62− widths, Vty provides a tool `vty-build-width-table` and library

63− functionality to build a width table that will work for your terminal

64− and load it on application startup.

65−

66−# Development Notes

67−

68−Vty uses threads internally, so programs made with Vty need to be

69−compiled with the threaded runtime using the GHC `-threaded` option.

70−

71# Platform Support

63# Platform Support

73## Posix Terminals

65## Posix Terminals

75−For the most part, Vty uses `terminfo` to determine terminal protocol

67+Uses terminfo to determine terminal protocol. With some special rules to

76−with some special rules to handle some omissions from `terminfo`.

68+handle some omissions from terminfo.

78## Windows

70## Windows

80−Windows is not supported.

72+Unsupported (but contributions and testing here are very welcome!)

81−

82−# Multi-Column Character Support

83−

84−Vty supports rendering of multi-column characters such as two-column

85−Asian characters and Emoji characters. This section details how to

86−take advantage of this feature, since its behavior will depend on the

87−terminal emulator in use.

88−

89−Terminal emulators support Unicode to varying degrees, and each terminal

90−emulator relies on a table of column widths for each supported Unicode

91−character. Vty also needs to rely on such a table to compute the width

92−of Vty images to do image layout. Since those tables can disagree if

93−Vty and the terminal emulator support different versions of Unicode,

94−and since different terminal emulators will support different versions

95−of Unicode, it's likely that for some wide characters, Vty applications

96−will exhibit rendering problems. Those rendering problems arise from Vty

97−and the terminal emulator coming to different conclusions about how wide

98−some characters are.

99−

100−To address this, Vty supports loading custom character width tables

101−that are based on the terminal's behavior in order to eliminate these

102−disagreements. By default, though, Vty will use its built-in Unicode

103−character width table. Since the built-in table is likely to eventually

104−disagree with your terminal, Vty provides an API and a command-line tool

105−to generate and install custom tables.

106−

107−Custom Unicode width tables based on your terminal emulator can be

108−built by running Vty's built-in tool, `vty-build-width-table`. The tool

109−works by querying the current terminal emulator to obtain its width

110−measurements for the entire supported Unicode range. The

111−results are then saved to a disk file. These custom tables

112−can also be generated programmatically by using the API in

113−`Graphics.Vty.UnicodeWidthTable.Query`.

114−

115−Saved width tables can then be loaded in one of two ways:

116−

117−* Via the library API in `Graphics.Vty.UnicodeWidthTable.IO`

118−* By adding a `widthMap` directive to your Vty configuration file and

119− then invoking `mkVty` to initialize Vty

120−

121−The Vty configuration file supports the `widthMap` directive to allow

122−users to specify which custom width table should be loaded for a given

123−terminal type. This is done by specifying, e.g.,

124−

125−```

126−widthMap "xterm" "/path/to/map.dat"

127−```

128−

129−where the first argument is the value that `TERM` must have in order for

130−the table to be loaded, and the second argument is the path to the table

131−file itself as generated by the two alternatives listed above. If the

132−Vty configuration file contains multiple matching `widthMap` directives

133−for the current value of `TERM`, the last one listed in the file is

134−used.

135−

136−The tables declared in the configuration file are only ever

137−automatically loaded when applications set up Vty by calling

138−`Graphics.Vty.mkVty`.

139−

140−Before a custom table has been loaded, calls to the library's character

141−width functions (e.g. `wcwidth`) will use the default built-in table.

142−Once a custom table has been loaded, the functions will use the new

143−custom table. Only one custom table load can be performed in a Vty

144−program. Once a custom table has been loaded, it cannot be replaced or

145−removed.

146−

147−Without using a custom width table, users of Vty-based applications

148−are likely to eventually experience rendering problems with with wide

149−characters. We recommend that developers of Vty-based applications either:

150−

151−* Provide the `vty-build-width-table` tool and documentation for running

152− it and updating the Vty configuration, or

153−* Have the application invoke the Vty library's table-building

154− functionality and load the table at startup without using the Vty

155− configuration.

156−

157−The best option will depend on a number of factors: the user audience,

158−the amount of risk posed by wide character rendering, the terminal

159−emulators in use, etc.

160

161# Contributing

74# Contributing

162

@@ -170,13 +83,45 @@ should consider to make submitting patches easier for all concerned:

170 conventions already used in the codebase.

83 conventions already used in the codebase.

171 - Please provide Haddock documentation for any changes you make.

84 - Please provide Haddock documentation for any changes you make.

172

86+# Development Notes

87+

88+## Under NixOS

89+

90+### Using cabal

91+

92+After installing `ncurses` to the user environment:

93+

94+~~~

95+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib

96+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build

97+LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test

98+~~~

99+

100+## Code Coverage

101+

102+As of last testing, profiling causes issues with coverage when enabled.

103+To evaluate coverage, configure as follows:

104+

105+~~~

106+rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \

107+ --disable-library-profiling \

108+ --disable-executable-profiling

109+~~~

110+

111+## Profiling

112+

113+~~~

114+rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \

115+ --enable-library-profiling \

116+ --enable-executable-profiling

117+~~~

118+

173# Known Issues

119# Known Issues

174

120

175−* Terminals have numerous quirks and bugs, so mileage may vary. Please

121+* Terminals have numerous quirks and bugs. Vty picks what works best for

176− report issues as you encounter them and provide details on your

122+ the author in ambiguous or buggy situations.

177− terminal emulator, operating system, etc.

178

123

179−* STOP, TERM and INT signals are not handled.

124+* Signal handling of STOP, TERM and INT are nonexistent.

180

125

181* The character encoding of the terminal is assumed to be UTF-8 if

126* The character encoding of the terminal is assumed to be UTF-8 if

182 unicode is used.

127 unicode is used.

@@ -186,10 +131,10 @@ should consider to make submitting patches easier for all concerned:

186 (shifted F10 etc). See `Config` for customizing vty's behavior for a

131 (shifted F10 etc). See `Config` for customizing vty's behavior for a

187 particular terminal.

132 particular terminal.

188

133

189−* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which

134+* Uses the `TIOCGWINSZ` ioctl to find the current window size, which

190 appears to be limited to Linux and BSD.

135 appears to be limited to Linux and BSD.

191

136

192−# Further Reading

137+# Sources

193

138

194Good sources of documentation for terminal programming are:

139Good sources of documentation for terminal programming are:

195

140

cbits/get_tty_erase.cdeleted−18

@@ -1,18 +0,0 @@

1−#include <termios.h>

2−#include <stdio.h>

3−#include <unistd.h>

4−#include <stdlib.h>

5−

6−// Given a file descriptor for a terminal, get the ERASE character for

7−// the terminal. If the terminal info cannot be obtained, this returns

8−// zero.

9−char vty_get_tty_erase(int fd)

10−{

11− struct termios trm;

12−

13− if (0 == tcgetattr(fd, &trm)) {

14− return (char) trm.c_cc[VERASE];

15− } else {

16− return (char) 0;

17− }

18−}

cbits/gwinsz.c+5−14

@@ -1,18 +1,9 @@

1#include <sys/ioctl.h>

3unsigned long vty_c_get_window_size(int fd) {

4− struct winsize w;

4+ struct winsize w;

5− if (ioctl (fd, TIOCGWINSZ, &w) >= 0)

5+ if (ioctl (fd, TIOCGWINSZ, &w) >= 0)

6− return (w.ws_row << 16) + w.ws_col;

6+ return (w.ws_row << 16) + w.ws_col;

7− else

7+ else

8− return 0x190050;

8+ return 0x190050;

9−}

10−

11−void vty_c_set_window_size(int fd, unsigned long val) {

12− struct winsize w;

13− if (ioctl(fd, TIOCGWINSZ, &w) >= 0) {

14− w.ws_row = val >> 16;

15− w.ws_col = val & 0xFFFF;

16− ioctl(fd, TIOCSWINSZ, &w);

17− }

18}

cbits/gwinsz.h+1−2

@@ -1,2 +1 @@

1−unsigned long vty_c_get_window_size(int fd);

1+unsigned long vty_c_get_window_size(void);

2−unsigned long vty_c_set_window_size(int fd, unsigned long val);

cbits/mk_wcwidth.c+2−136

@@ -60,28 +60,6 @@

60 */

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;

86struct interval {

64struct interval {

87 int first;

65 int first;

@@ -141,7 +119,7 @@ static int vty_bisearch(HsChar ucs, const struct interval *table, int max) {

141 * in ISO 10646.

119 * in ISO 10646.

142 */

120 */

143

121

144−static HsInt builtin_wcwidth(HsChar ucs)

122+HsInt vty_mk_wcwidth(HsChar ucs)

145{

123{

146 /* sorted list of non-overlapping intervals of non-spacing characters */

124 /* sorted list of non-overlapping intervals of non-spacing characters */

147 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */

125 /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */

@@ -204,7 +182,7 @@ static HsInt builtin_wcwidth(HsChar ucs)

204

182

205 /* binary search in table of non-spacing characters */

183 /* binary search in table of non-spacing characters */

206 if (vty_bisearch(ucs, combining,

184 if (vty_bisearch(ucs, combining,

207− sizeof(combining) / sizeof(struct interval) - 1))

185+ sizeof(combining) / sizeof(struct interval) - 1))

208 return 0;

186 return 0;

209

187

210 /* if we arrive here, ucs is not a combining or C0/C1 control character */

188 /* if we arrive here, ucs is not a combining or C0/C1 control character */

@@ -224,115 +202,3 @@ static HsInt builtin_wcwidth(HsChar ucs)

224 (ucs >= 0x20000 && ucs <= 0x2fffd) ||

202 (ucs >= 0x20000 && ucs <= 0x2fffd) ||

225 (ucs >= 0x30000 && ucs <= 0x3fffd)));

203 (ucs >= 0x30000 && ucs <= 0x3fffd)));

226}

204}

227−

228−// Return the width, in terminal cells, of the specified character.

229−//

230−// If the global custom width table is present, that table will be

231−// consulted for the character's width. If the character is not in

232−// the table, zero will be returned. If the custom width table is not

233−// present, the built-in width table will be used.

234−HsInt vty_mk_wcwidth(HsChar ch)

235−{

236− if (custom_table_ready) {

237− if ((ch >= 0) && (ch < custom_table_size)) {

238− return custom_table[ch];

239− } else {

240− return -1;

241− }

242− } else {

243− return builtin_wcwidth(ch);

244− }

245−}

246−

247−// Initialize a custom character width table.

248−//

249−// This allocates a new character width table of the specified size

250−// (in characters). If a custom table has already been allocated, this

251−// returns 1. Otherwise it allocates a new table, initializes all of its

252−// entries to 1, and returns zero.

253−//

254−// Note that this does *not* mark the table as ready for use. Until the

255−// table is marked ready, it will not be used by vty_mk_wcwidth. To mark

256−// the table as ready, call vty_activate_custom_table() after the table

257−// has been set up with calls to vty_set_custom_table_range.

258−int vty_init_custom_table(int size)

259−{

260− if (custom_table == NULL) {

261− if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) {

262− custom_table_ready = 0;

263− custom_table = malloc(size);

264− memset(custom_table, 1, size);

265− custom_table_size = size;

266− return 0;

267− } else {

268− return 1;

269− }

270− } else {

271− return 1;

272− }

273−}

274−

275−// Set the specified character range in the custom width table to the

276−// specified width.

277−//

278−// This function sets 'width' as the character width for all entries

279−// in the custom character table starting at the 'start' entry and

280−// including all entries up to and including 'start + size - 1'.

281−//

282−// If this succeeds, it returns zero. If it fails, it returns 1. It

283−// fails if the table is not allocated, marked as ready (i.e. it is in

284−// use and has already been populated), or if the start or size values

285−// are not in bounds for the table.

286−int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width)

287−{

288− if ((custom_table == NULL) ||

289− (size >= custom_table_size) ||

290− (start >= custom_table_size) ||

291− ((start + 1) >= (custom_table_size - size)) ||

292− custom_table_ready) {

293− return 1;

294− } else {

295− memset(custom_table + start, width, size);

296− return 0;

297− }

298−}

299−

300−// Mark the allocated custom character width table as ready for use.

301−//

302−// After this call, further calls to vty_set_custom_table_range will

303−// fail.

304−//

305−// This function returns 0 if it succeeds. If it fails, it returns 1.

306−// It fails if the custom table is already ready or if it has not been

307−// allocated.

308−int vty_activate_custom_table()

309−{

310− if (custom_table_ready || (custom_table == NULL)) {

311− return 1;

312− } else {

313− custom_table_ready = 1;

314− return 0;

315− }

316−}

317−

318−// Returns whether a custom character width table has been marked ready.

319−int vty_custom_table_ready()

320−{

321− return custom_table_ready;

322−}

323−

324−// Deallocate the custom width table.

325−//

326−// This does nothing if there is no allocated custom width table, or if

327−// there is one but it is in use (marked ready). This is only useful if

328−// an initial allocation succeeds, but range population fails, after

329−// which point the application may want to deallocate the table to avoid

330−// leaving it in an intermediate state.

331−void vty_deallocate_custom_table()

332−{

333− if ((custom_table != NULL) && (!custom_table_ready)) {

334− free(custom_table);

335− custom_table = NULL;

336− custom_table_size = 0;

337− }

338−}

demos/Demo.hs+4−12

@@ -31,8 +31,7 @@ introText = vertCat $ map (string defAttr)

31 [ "this line is hidden by the top layer"

32 , "The vty demo program will echo the events generated by the pressed keys."

33 , "Below there is a 240 color box."

34− , "Followed by a description of the 16 color palette."

34+ , "Followed by a description of the 16 color pallete."

35− , "Followed by tones of red using a 24-bit palette."

36 , "If the 240 color box is not visible then the terminal"

35 , "If the 240 color box is not visible then the terminal"

37 , "claims 240 colors are not supported."

36 , "claims 240 colors are not supported."

38 , "Try setting TERM to xterm-256color"

37 , "Try setting TERM to xterm-256color"

@@ -43,19 +42,12 @@ introText = vertCat $ map (string defAttr)

43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"

42 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"

44 ]

43 ]

46−splitColorImages :: [Image] -> [[Image]]

47−splitColorImages [] = []

48−splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))

49−

50−fullcolorbox :: Image

51−fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages

52− where

53− colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255]

54−

55colorbox_240 :: Image

45colorbox_240 :: Image

56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

46colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

57 where

47 where

58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]

48 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]

49+ splitColorImages [] = []

50+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))

60colorbox_16 :: Image

52colorbox_16 :: Image

@@ -78,7 +70,7 @@ updateDisplay = do

78 "Press ESC to exit. Events for keys below."

70 "Press ESC to exit. Events for keys below."

79 eventLog <- foldMap (string defAttr) <$> get

71 eventLog <- foldMap (string defAttr) <$> get

80 let pic = picForImage (info <-> eventLog)

72 let pic = picForImage (info <-> eventLog)

81− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)

73+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)

82 vty <- ask

74 vty <- ask

83 liftIO $ update vty pic

75 liftIO $ update vty pic

demos/ModeDemo.hs−2

@@ -2,8 +2,6 @@ module Main where

3import Control.Applicative

4import Data.Monoid

5−import Foreign.C.Types (CInt(..), CChar(..))

6−import System.Posix.Types (Fd(..))

8import Graphics.Vty

6import Graphics.Vty

src/Codec/Binary/UTF8/Debug.hs+2−1

@@ -14,4 +14,5 @@ utf8FromIso :: [Int] -> [Word8]

14utf8FromIso = encode . map toEnum

16ppUtf8 :: [Int] -> IO ()

17−ppUtf8 = print . map (`showHex` "") . utf8FromIso

17+ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso

18+

src/Data/Sequence/Extra.hs+1−1

@@ -7,7 +7,7 @@ import Data.Sequence

7import Control.Parallel.Strategies

9instance NFData a => NFData (Seq a) where

10− rnf = rnf' . viewl

10+ rnf = \v -> rnf' (viewl v)

11 where

12 rnf' EmptyL = ()

13 rnf' (a :< r) = rnf a >| rnf' (viewl r)

src/Data/Terminfo/Eval.hs+3−3

@@ -42,7 +42,7 @@ pop = do

43readParam :: Word -> Eval CapParam

44readParam pn = do

45− !params <- evalParams <$> get

45+ !params <- get >>= return . evalParams

46 return $! genericIndex params pn

48push :: CapParam -> Eval ()

@@ -64,11 +64,11 @@ writeCapExpr cap params =

64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)

66writeCapOps :: CapOps -> Eval ()

67−writeCapOps = mapM_ writeCapOp

67+writeCapOps ops = mapM_ writeCapOp ops

69writeCapOp :: CapOp -> Eval ()

70writeCapOp (Bytes !offset !count) = do

71− !cap <- evalExpression <$> get

71+ !cap <- get >>= return . evalExpression

72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)

73 Vector.forM_ bytes $ tell.writeWord8

74writeCapOp DecOut = do

src/Data/Terminfo/Parse.hs+13−22

@@ -1,9 +1,8 @@

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

2+{-# OPTIONS_HADDOCK hide #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE NamedFieldPuns #-}

5{-# OPTIONS_GHC -funbox-strict-fields -O #-}

6−{-# OPTIONS_HADDOCK hide #-}

8module Data.Terminfo.Parse

7module Data.Terminfo.Parse

9 ( module Data.Terminfo.Parse

8 ( module Data.Terminfo.Parse

@@ -14,9 +13,6 @@ where

14import Control.Monad ( liftM )

13import Control.Monad ( liftM )

15import Control.DeepSeq

14import Control.DeepSeq

17−#if !(MIN_VERSION_base(4,11,0))

18−import Data.Semigroup (Semigroup(..))

19−#endif

20import Data.Word

16import Data.Word

21import qualified Data.Vector.Unboxed as Vector

17import qualified Data.Vector.Unboxed as Vector

@@ -39,7 +35,7 @@ instance Show CapExpression where

39 ++ " <= " ++ show (sourceString c)

35 ++ " <= " ++ show (sourceString c)

40 where

36 where

41 hexDump :: [Word8] -> String

37 hexDump :: [Word8] -> String

42− hexDump = foldr showHex ""

38+ hexDump = foldr (\b s -> showHex b s) ""

44instance NFData CapExpression where

40instance NFData CapExpression where

45 rnf (CapExpression ops !_bytes !str !c !pOps)

41 rnf (CapExpression ops !_bytes !str !c !pOps)

@@ -99,7 +95,7 @@ parseCapExpression capString =

99 Left e -> Left e

95 Left e -> Left e

100 Right buildResults -> Right $ constructCapExpression capString buildResults

96 Right buildResults -> Right $ constructCapExpression capString buildResults

101

102−constructCapExpression :: String -> BuildResults -> CapExpression

98+constructCapExpression :: [Char] -> BuildResults -> CapExpression

103constructCapExpression capString buildResults =

99constructCapExpression capString buildResults =

104 let expr = CapExpression

100 let expr = CapExpression

105 { capOps = outCapOps buildResults

101 { capOps = outCapOps buildResults

@@ -128,7 +124,7 @@ paramEscapeParser = do

128literalPercentParser :: CapParser BuildResults

124literalPercentParser :: CapParser BuildResults

129literalPercentParser = do

125literalPercentParser = do

130 _ <- char '%'

126 _ <- char '%'

131− startOffset <- nextOffset <$> getState

127+ startOffset <- getState >>= return . nextOffset

132 incOffset 1

128 incOffset 1

133 return $ BuildResults 0 [Bytes startOffset 1] []

129 return $ BuildResults 0 [Bytes startOffset 1] []

134

130

@@ -154,7 +150,7 @@ incrementOpParser = do

154pushOpParser :: CapParser BuildResults

150pushOpParser :: CapParser BuildResults

155pushOpParser = do

151pushOpParser = do

156 _ <- char 'p'

152 _ <- char 'p'

157− paramN <- read . pure <$> digit

153+ paramN <- digit >>= return . (\d -> read [d])

158 incOffset 2

154 incOffset 2

159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []

155 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []

160

156

@@ -299,7 +295,7 @@ compareOpParser

299bytesOpParser :: CapParser BuildResults

295bytesOpParser :: CapParser BuildResults

300bytesOpParser = do

296bytesOpParser = do

301 bytes <- many1 $ satisfy (/= '%')

297 bytes <- many1 $ satisfy (/= '%')

302− startOffset <- nextOffset <$> getState

298+ startOffset <- getState >>= return . nextOffset

303 let !c = length bytes

299 let !c = length bytes

304 !s <- getState

300 !s <- getState

305 let s' = s { nextOffset = startOffset + c }

301 let s' = s { nextOffset = startOffset + c }

@@ -333,16 +329,11 @@ data BuildResults = BuildResults

333 , outParamOps :: !ParamOps

329 , outParamOps :: !ParamOps

334 }

330 }

335

331

336−instance Semigroup BuildResults where

337− v0 <> v1

338− = BuildResults

339− { outParamCount = outParamCount v0 `max` outParamCount v1

340− , outCapOps = outCapOps v0 <> outCapOps v1

341− , outParamOps = outParamOps v0 <> outParamOps v1

342− }

343−

344instance Monoid BuildResults where

332instance Monoid BuildResults where

345 mempty = BuildResults 0 [] []

333 mempty = BuildResults 0 [] []

346−#if !(MIN_VERSION_base(4,11,0))

334+ v0 `mappend` v1

347− mappend = (<>)

335+ = BuildResults

348−#endif

336+ { outParamCount = (outParamCount v0) `max` (outParamCount v1)

337+ , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)

338+ , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)

339+ }

src/Graphics/Text/Width.hs+11−42

@@ -1,64 +1,33 @@

2{-# OPTIONS_GHC -D_XOPEN_SOURCE #-}

3{-# LANGUAGE ForeignFunctionInterface #-}

4−-- | This module provides functions to measure the terminal column width

5−-- of characters and strings.

6−--

7−-- The functions provided in this module all ultimately make calls to

8−-- the C implementation in @cbits/mk_wcwidth.c@. That code manages some

9−-- global state that carries a table of Unicode character widths. For

10−-- more details, see 'Graphics.Vty.UnicodeWidthTable.Install', the C

11−-- code, and the "Multi-Column Character Support" section of the project

12−-- @README@.

13module Graphics.Text.Width

4module Graphics.Text.Width

14 ( wcwidth

5 ( wcwidth

15 , wcswidth

6 , wcswidth

16− , wctwidth

17− , wctlwidth

18 , safeWcwidth

7 , safeWcwidth

19 , safeWcswidth

8 , safeWcswidth

20− , safeWctwidth

21− , safeWctlwidth

22 )

9 )

23where

10where

25−import Data.List (foldl')

26−import qualified Data.Text as T

27−import qualified Data.Text.Lazy as TL

28−

29foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int

12foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int

31wcswidth :: String -> Int

14wcswidth :: String -> Int

32−wcswidth = foldl' (\l c -> wcwidth c + l) 0

15+wcswidth = sum . map wcwidth

33−{-# INLINE [1] wcswidth #-}

34−

35−wctwidth :: T.Text -> Int

36−wctwidth = T.foldl' (\l c -> wcwidth c + l) 0

37−

38−wctlwidth :: TL.Text -> Int

39−wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0

41−{-# RULES

17+-- XXX: Characters with unknown widths occupy 1 column?

42−"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x

18+--

43−"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x

19+-- Not sure if this is actually correct. I presume there is a

44− #-}

20+-- replacement character that is output by the terminal instead of the

21+-- character and this replacement character is 1 column wide. If this is

22+-- not true for all terminals then a per-terminal replacement character

23+-- width needs to be implemented.

46-- | Returns the display width of a character. Assumes all characters

25-- | Returns the display width of a character. Assumes all characters

47−-- with unknown widths are 0 width.

26+-- with unknown widths are 0 width

48safeWcwidth :: Char -> Int

27safeWcwidth :: Char -> Int

49safeWcwidth = max 0 . wcwidth

28safeWcwidth = max 0 . wcwidth

51-- | Returns the display width of a string. Assumes all characters with

30-- | Returns the display width of a string. Assumes all characters with

52−-- unknown widths are 0 width.

31+-- unknown widths are 0 width

53safeWcswidth :: String -> Int

32safeWcswidth :: String -> Int

54−safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0

33+safeWcswidth = sum . map safeWcwidth

55−

56−-- | Returns the display width of a text. Assumes all characters with

57−-- unknown widths are 0 width.

58−safeWctwidth :: T.Text -> Int

59−safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0

60−

61−-- | Returns the display width of a lazy text. Assumes all characters

62−-- with unknown widths are 0 width.

63−safeWctlwidth :: TL.Text -> Int

64−safeWctlwidth = TL.foldl' (\l c -> safeWcwidth c + l) 0

src/Graphics/Vty.hs+38−134

@@ -1,6 +1,3 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−

4-- | Vty provides interfaces for both terminal input and terminal

1-- | Vty provides interfaces for both terminal input and terminal

5-- output.

2-- output.

6--

3--

@@ -13,9 +10,6 @@

13-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)

10-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)

14-- values in the "Graphics.Vty.Attributes" module.

11-- values in the "Graphics.Vty.Attributes" module.

15--

12--

16−-- Vty uses threads internally, so programs made with Vty need to be

17−-- compiled with the threaded runtime using the GHC @-threaded@ option.

18−--

19-- @

13-- @

20-- import "Graphics.Vty"

14-- import "Graphics.Vty"

21--

15--

@@ -34,7 +28,6 @@

34module Graphics.Vty

28module Graphics.Vty

35 ( Vty(..)

29 ( Vty(..)

36 , mkVty

30 , mkVty

37− , setWindowTitle

38 , Mode(..)

31 , Mode(..)

39 , module Graphics.Vty.Config

32 , module Graphics.Vty.Config

40 , module Graphics.Vty.Input

33 , module Graphics.Vty.Input

@@ -48,33 +41,23 @@ where

49import Graphics.Vty.Config

42import Graphics.Vty.Config

50import Graphics.Vty.Input

43import Graphics.Vty.Input

51−import Graphics.Vty.Input.Events

52import Graphics.Vty.Output

44import Graphics.Vty.Output

53import Graphics.Vty.Output.Interface

45import Graphics.Vty.Output.Interface

54import Graphics.Vty.Picture

46import Graphics.Vty.Picture

55import Graphics.Vty.Image

47import Graphics.Vty.Image

56import Graphics.Vty.Attributes

48import Graphics.Vty.Attributes

57−import Graphics.Vty.UnicodeWidthTable.IO

58−import Graphics.Vty.UnicodeWidthTable.Install

60−import Data.Char (isPrint, showLitChar)

61−import qualified Data.ByteString.Char8 as BS8

62−

63−import qualified Control.Exception as E

64−import Control.Monad (when)

65import Control.Concurrent.STM

50import Control.Concurrent.STM

67import Data.IORef

52import Data.IORef

68−#if !(MIN_VERSION_base(4,11,0))

69−import Data.Semigroup ((<>))

53+import Data.Monoid

70−#endif

72-- | A Vty value represents a handle to the Vty library that the

55-- | A Vty value represents a handle to the Vty library that the

73-- application must create in order to use Vty.

56-- application must create in order to use Vty.

74--

57--

75-- The use of Vty typically follows this process:

58-- The use of Vty typically follows this process:

76--

59--

77−-- 1. Initialize vty with 'mkVty' (this takes control of the terminal).

60+-- 1. Initialize vty

78--

61--

79-- 2. Use 'update' to display a picture.

62-- 2. Use 'update' to display a picture.

80--

63--

@@ -82,33 +65,31 @@ import Data.Semigroup ((<>))

82--

65--

83-- 4. Depending on the event, go to 2 or 5.

66-- 4. Depending on the event, go to 2 or 5.

84--

67--

85−-- 5. Shutdown vty and restore the terminal state with 'shutdown'. At

68+-- 5. Shutdown vty.

86−-- this point the 'Vty' handle cannot be used again.

87--

69--

88-- Operations on Vty handles are not thread-safe.

70-- Operations on Vty handles are not thread-safe.

89−data Vty =

71+data Vty = Vty

90− Vty { update :: Picture -> IO ()

91− -- ^ Outputs the given 'Picture'.

72+ { -- | Outputs the given 'Picture'.

92− , nextEvent :: IO Event

73+ update :: Picture -> IO ()

93− -- ^ Return the next 'Event' or block until one becomes

74+ -- | Get one 'Event' object, blocking if none are available. This

94− -- available.

75+ -- will refresh the terminal if the event is a 'EvResize'.

95− , nextEventNonblocking :: IO (Maybe Event)

76+ , nextEvent :: IO Event

96− -- ^ Non-blocking version of 'nextEvent'.

97− , inputIface :: Input

98− -- ^ The input interface. See 'Input'.

77+ -- | The input interface. See 'Input'.

78+ , inputIface :: Input

79+ -- | The output interface. See 'Output'.

99− , outputIface :: Output

80+ , outputIface :: Output

100− -- ^ The output interface. See 'Output'.

81+ -- | Refresh the display. 'nextEvent' will refresh the display if

101− , refresh :: IO ()

82+ -- a resize occurs, but this can be used to refresh the display

102− -- ^ Refresh the display. If other programs output to the

83+ -- explicitly. If other programs output to the terminal and mess

103− -- terminal and mess up the display then the application might

84+ -- up the display then the application might want to force a

104− -- want to force a refresh using this function.

85+ -- refresh using this function.

105− , shutdown :: IO ()

86+ , refresh :: IO ()

106− -- ^ Clean up after vty. A call to this function is necessary to

87+ -- | Clean up after vty. A call to this function is necessary to

107− -- cleanly restore the terminal state before application exit.

88+ -- cleanly restore the terminal state before application exit. The

108− -- The above methods will throw an exception if executed after

89+ -- above methods will throw an exception if executed after this is

109− -- this is executed. Idempotent.

90+ -- executed.

110− , isShutdown :: IO Bool

91+ , shutdown :: IO ()

111− }

92+ }

112

113-- | Create a Vty handle. At most one handle should be created at a time

94-- | Create a Vty handle. At most one handle should be created at a time

114-- for a given terminal device.

95-- for a given terminal device.

@@ -121,63 +102,17 @@ data Vty =

121mkVty :: Config -> IO Vty

102mkVty :: Config -> IO Vty

122mkVty appConfig = do

103mkVty appConfig = do

123 config <- (<> appConfig) <$> userConfig

104 config <- (<> appConfig) <$> userConfig

105+ input <- inputForConfig config

106+ out <- outputForConfig config

107+ intMkVty input out

124

108

125− when (allowCustomUnicodeWidthTables config /= Just False) $

126− installCustomWidthTable config

127−

128− input <- inputForConfig config

129− out <- outputForConfig config

130− internalMkVty input out

131−

132−installCustomWidthTable :: Config -> IO ()

133−installCustomWidthTable c = do

134− let doLog s = case debugLog c of

135− Nothing -> return ()

136− Just path -> appendFile path $ "installWidthTable: " <> s <> "\n"

137−

138− customInstalled <- isCustomTableReady

139− when (not customInstalled) $ do

140− mTerm <- currentTerminalName

141− case mTerm of

142− Nothing ->

143− doLog "No current terminal name available"

144− Just currentTerm ->

145− case lookup currentTerm (termWidthMaps c) of

146− Nothing ->

147− doLog "Current terminal not found in custom character width mapping list"

148− Just path -> do

149− tableResult <- E.try $ readUnicodeWidthTable path

150− case tableResult of

151− Left (e::E.SomeException) ->

152− doLog $ "Error reading custom character width table " <>

153− "at " <> show path <> ": " <> show e

154− Right (Left msg) ->

155− doLog $ "Error reading custom character width table " <>

156− "at " <> show path <> ": " <> msg

157− Right (Right table) -> do

158− installResult <- E.try $ installUnicodeWidthTable table

159− case installResult of

160− Left (e::E.SomeException) ->

161− doLog $ "Error installing unicode table (" <>

162− show path <> ": " <> show e

163− Right () ->

164− doLog $ "Successfully installed Unicode width table " <>

165− " from " <> show path

166−

167−internalMkVty :: Input -> Output -> IO Vty

109+intMkVty :: Input -> Output -> IO Vty

168−internalMkVty input out = do

110+intMkVty input out = do

169 reserveDisplay out

111 reserveDisplay out

170−

171− shutdownVar <- newTVarIO False

172 let shutdownIo = do

112 let shutdownIo = do

173− alreadyShutdown <- atomically $ swapTVar shutdownVar True

174− when (not alreadyShutdown) $ do

175− shutdownInput input

113+ shutdownInput input

176− releaseDisplay out

114+ releaseDisplay out

177− releaseTerminal out

115+ releaseTerminal out

178−

179− let shutdownStatus = readTVarIO shutdownVar

180−

181 lastPicRef <- newIORef Nothing

116 lastPicRef <- newIORef Nothing

182 lastUpdateRef <- newIORef Nothing

117 lastUpdateRef <- newIORef Nothing

183

118

@@ -209,47 +144,16 @@ internalMkVty input out = do

209 mPic <- readIORef lastPicRef

144 mPic <- readIORef lastPicRef

210 maybe (return ()) innerUpdate mPic

145 maybe (return ()) innerUpdate mPic

211

146

212− let mkResize = uncurry EvResize <$> displayBounds out

213−

214− translateInternalEvent ResumeAfterSignal = mkResize

215− translateInternalEvent (InputEvent e) = return e

216−

217− gkey = do

218− e <- atomically $ readTChan $ _eventChannel input

147+ let gkey = do k <- atomically $ readTChan $ _eventChannel input

219− translateInternalEvent e

220− gkey' = do

221− mEv <- atomically $ tryReadTChan $ _eventChannel input

222− case mEv of

148+ case k of

223− Just e -> Just <$> translateInternalEvent e

149+ (EvResize _ _) -> displayBounds out

150+ >>= return . (\(w,h)-> EvResize w h)

224− Nothing -> return Nothing

151+ _ -> return k

225

152

226 return $ Vty { update = innerUpdate

153 return $ Vty { update = innerUpdate

227 , nextEvent = gkey

154 , nextEvent = gkey

228− , nextEventNonblocking = gkey'

229 , inputIface = input

155 , inputIface = input

230 , outputIface = out

156 , outputIface = out

231 , refresh = innerRefresh

157 , refresh = innerRefresh

232 , shutdown = shutdownIo

158 , shutdown = shutdownIo

233− , isShutdown = shutdownStatus

234 }

159 }

235−

236−-- | Set the terminal window title string.

237−--

238−-- This function emits an Xterm-compatible escape sequence that we

239−-- anticipate will work for essentially all modern terminal emulators.

240−-- Ideally we'd use a terminal capability for this, but there does not

241−-- seem to exist a termcap for setting window titles. If you find that

242−-- this function does not work for a given terminal emulator, please

243−-- report the issue.

244−--

245−-- For details, see:

246−--

247−-- https://tldp.org/HOWTO/Xterm-Title-3.html

248−setWindowTitle :: Vty -> String -> IO ()

249−setWindowTitle vty title = do

250− let sanitize :: String -> String

251− sanitize = concatMap sanitizeChar

252− sanitizeChar c | not (isPrint c) = showLitChar c ""

253− | otherwise = [c]

254− let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007"

255− outputByteBuffer (outputIface vty) buf

src/Graphics/Vty/Attributes.hs+45−54

@@ -1,6 +1,6 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE StandaloneDeriving #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE DeriveAnyClass #-}

3+{-# LANGUAGE RankNTypes #-}

5-- | Display attributes

6--

@@ -10,14 +10,14 @@

10-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,

11--

12-- @

13−-- defAttr \`withForeColor\` red

13+-- defAttr `withForeColor` red

14-- @

15--

16-- 'Image' constructors often require an 'Attr' to indicate the

17-- attributes used in the image, e.g.,

18--

19-- @

20−-- string (defAttr \`withForeColor\` red) "this text will be red"

20+-- string (defAttr `withForeColor` red) "this text will be red"

21-- @

22--

23-- The appearance of 'Image's using 'defAttr' is determined by the The

@@ -27,9 +27,7 @@

27-- The value 'currentAttr' will keep the attributes of whatever was

28-- output previously.

29module Graphics.Vty.Attributes

30− ( module Graphics.Vty.Attributes.Color

31−

32− , Attr(..)

30+ ( Attr(..)

33 , FixedAttr(..)

31 , FixedAttr(..)

34 , MaybeDefault(..)

32 , MaybeDefault(..)

35 , defAttr

33 , defAttr

@@ -39,8 +37,6 @@ module Graphics.Vty.Attributes

39 , Style

37 , Style

40 , withStyle

38 , withStyle

41 , standout

39 , standout

42− , italic

43− , strikethrough

44 , underline

40 , underline

45 , reverseVideo

41 , reverseVideo

46 , blink

42 , blink

@@ -54,18 +50,17 @@ module Graphics.Vty.Attributes

54 , withForeColor

50 , withForeColor

55 , withBackColor

51 , withBackColor

57− -- * Setting hyperlinks

53+ -- * Colors

58− , withURL

54+ , module Graphics.Vty.Attributes.Color

55+ , module Graphics.Vty.Attributes.Color240

59 )

56 )

60where

57where

62−import Control.DeepSeq

63import Data.Bits

59import Data.Bits

64−import Data.Text (Text)

65import Data.Word

60import Data.Word

66−import GHC.Generics

68import Graphics.Vty.Attributes.Color

62import Graphics.Vty.Attributes.Color

63+import Graphics.Vty.Attributes.Color240

70-- | A display attribute defines the Color and Style of all the

65-- | A display attribute defines the Color and Style of all the

71-- characters rendered after the attribute is applied.

66-- characters rendered after the attribute is applied.

@@ -78,8 +73,7 @@ data Attr = Attr

78 { attrStyle :: !(MaybeDefault Style)

73 { attrStyle :: !(MaybeDefault Style)

79 , attrForeColor :: !(MaybeDefault Color)

74 , attrForeColor :: !(MaybeDefault Color)

80 , attrBackColor :: !(MaybeDefault Color)

75 , attrBackColor :: !(MaybeDefault Color)

81− , attrURL :: !(MaybeDefault Text)

82− } deriving ( Eq, Show, Read, Generic, NFData )

76+ } deriving ( Eq, Show, Read )

84-- This could be encoded into a single 32 bit word. The 32 bit word is

78-- This could be encoded into a single 32 bit word. The 32 bit word is

85-- first divided into 4 groups of 8 bits where: The first group codes

79-- first divided into 4 groups of 8 bits where: The first group codes

@@ -100,19 +94,25 @@ data Attr = Attr

100-- __ - unused

94-- __ - unused

101--

95--

102-- Next is the style flags

96-- Next is the style flags

103−-- SURBDOI_

97+-- SURBDO__

104-- S - standout

98-- S - standout

105-- U - underline

99-- U - underline

106-- R - reverse video

100-- R - reverse video

107-- B - blink

101-- B - blink

108-- D - dim

102-- D - dim

109-- O - bold

103-- O - bold

110−-- I - italic

111−-- _ - unused

104+-- __ - unused

112--

105--

113-- Then the foreground color encoded into 8 bits.

106-- Then the foreground color encoded into 8 bits.

114-- Then the background color encoded into 8 bits.

107-- Then the background color encoded into 8 bits.

115

108

109+instance Monoid Attr where

110+ mempty = Attr mempty mempty mempty

111+ mappend attr0 attr1 =

112+ Attr ( attrStyle attr0 `mappend` attrStyle attr1 )

113+ ( attrForeColor attr0 `mappend` attrForeColor attr1 )

114+ ( attrBackColor attr0 `mappend` attrBackColor attr1 )

115+

116-- | Specifies the display attributes such that the final style and

117-- color values do not depend on the previously applied display

118-- attribute. The display attributes can still depend on the terminal's

@@ -121,26 +121,38 @@ data FixedAttr = FixedAttr

121 { fixedStyle :: !Style

122 , fixedForeColor :: !(Maybe Color)

123 , fixedBackColor :: !(Maybe Color)

124− , fixedURL :: !(Maybe Text)

125 } deriving ( Eq, Show )

124 } deriving ( Eq, Show )

126

125

127-- | The style and color attributes can either be the terminal defaults.

126-- | The style and color attributes can either be the terminal defaults.

128-- Or be equivalent to the previously applied style. Or be a specific

127-- Or be equivalent to the previously applied style. Or be a specific

129-- value.

128-- value.

130−data MaybeDefault v = Default | KeepCurrent | SetTo !v

129+data MaybeDefault v where

131− deriving (Eq, Read, Show)

130+ Default :: MaybeDefault v

132−

131+ KeepCurrent :: MaybeDefault v

132+ SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v

133+

134+deriving instance Eq v => Eq (MaybeDefault v)

135+deriving instance Eq v => Show (MaybeDefault v)

133−instance (NFData v) => NFData (MaybeDefault v) where

136+deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)

134− rnf Default = ()

137+

138+instance Eq v => Monoid ( MaybeDefault v ) where

139+ mempty = KeepCurrent

140+ mappend Default Default = Default

141+ mappend Default KeepCurrent = Default

142+ mappend Default ( SetTo v ) = SetTo v

135− rnf KeepCurrent = ()

143+ mappend KeepCurrent Default = Default

136− rnf (SetTo v) = rnf v

144+ mappend KeepCurrent KeepCurrent = KeepCurrent

145+ mappend KeepCurrent ( SetTo v ) = SetTo v

146+ mappend ( SetTo _v ) Default = Default

147+ mappend ( SetTo v ) KeepCurrent = SetTo v

148+ mappend ( SetTo _ ) ( SetTo v ) = SetTo v

137

149

138-- | Styles are represented as an 8 bit word. Each bit in the word is 1

150-- | Styles are represented as an 8 bit word. Each bit in the word is 1

139-- if the style attribute assigned to that bit should be applied and 0

151-- if the style attribute assigned to that bit should be applied and 0

140-- if the style attribute should not be applied.

152-- if the style attribute should not be applied.

141type Style = Word8

153type Style = Word8

142

154

143−-- | Valid style attributes include:

155+-- | The 6 possible style attributes:

144--

156--

145-- * standout

157-- * standout

146--

158--

@@ -154,21 +166,15 @@ type Style = Word8

154--

166--

155-- * bold/bright

167-- * bold/bright

156--

168--

157−-- * italic

158−--

159−-- * strikethrough (via the smxx/rmxx terminfo capabilities)

160−--

161-- (The invisible, protect, and altcharset display attributes some

169-- (The invisible, protect, and altcharset display attributes some

162-- terminals support are not supported via VTY.)

170-- terminals support are not supported via VTY.)

163−standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style

171+standout, underline, reverseVideo, blink, dim, bold :: Style

164standout = 0x01

172standout = 0x01

165underline = 0x02

173underline = 0x02

166−reverseVideo = 0x04

174+reverseVideo = 0x04

167blink = 0x08

175blink = 0x08

168dim = 0x10

176dim = 0x10

169bold = 0x20

177bold = 0x20

170−italic = 0x40

171−strikethrough = 0x80

172

178

173defaultStyleMask :: Style

179defaultStyleMask :: Style

174defaultStyleMask = 0x00

180defaultStyleMask = 0x00

@@ -194,28 +200,13 @@ withBackColor attr c = attr { attrBackColor = SetTo c }

194

200

195-- | Add the given style attribute

201-- | Add the given style attribute

196withStyle :: Attr -> Style -> Attr

202withStyle :: Attr -> Style -> Attr

197−withStyle attr 0 = attr

198withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }

203withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }

199

204

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

205-- | Sets the style, background color and foreground color to the

215-- default values for the terminal. There is no easy way to determine

206-- default values for the terminal. There is no easy way to determine

216-- what the default background and foreground colors are.

207-- what the default background and foreground colors are.

217defAttr :: Attr

208defAttr :: Attr

218−defAttr = Attr Default Default Default Default

209+defAttr = Attr Default Default Default

219

210

220-- | Keeps the style, background color and foreground color that was

211-- | Keeps the style, background color and foreground color that was

221-- previously set. Used to override some part of the previous style.

212-- previously set. Used to override some part of the previous style.

@@ -225,4 +216,4 @@ defAttr = Attr Default Default Default Default

225-- Would be the currently applied style (be it underline, bold, etc) but

216-- Would be the currently applied style (be it underline, bold, etc) but

226-- with the foreground color set to brightMagenta.

217-- with the foreground color set to brightMagenta.

227currentAttr :: Attr

218currentAttr :: Attr

228−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent

219+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent

src/Graphics/Vty/Attributes/Color.hs+5−96

@@ -1,24 +1,5 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE DeriveAnyClass #-}

3−{-# LANGUAGE MultiWayIf #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−

6module Graphics.Vty.Attributes.Color

1module Graphics.Vty.Attributes.Color

7 ( Color(..)

2 ( Color(..)

8− , ColorMode(..)

9−

10− -- * Detecting Terminal Color Support

11− , detectColorMode

12−

13− -- ** Fixed Colors

14− -- | Standard 8-color ANSI terminal color codes.

15− --

16− -- Note that these map to colors in the terminal's custom palette. For

17− -- instance, `white` maps to whatever the terminal color theme uses for

18− -- white.

19− --

20− -- Use these functions if you want to make apps that fit the terminal theme.

21− -- If you want access to more/stronger colors use `rgbColor`

22 , black

3 , black

23 , red

4 , red

24 , green

5 , green

@@ -27,8 +8,6 @@ module Graphics.Vty.Attributes.Color

27 , magenta

8 , magenta

28 , cyan

9 , cyan

29 , white

10 , white

30−

31− -- | Bright/Vivid variants of the standard 8-color ANSI

32 , brightBlack

11 , brightBlack

33 , brightRed

12 , brightRed

34 , brightGreen

13 , brightGreen

@@ -37,25 +16,10 @@ module Graphics.Vty.Attributes.Color

37 , brightMagenta

16 , brightMagenta

38 , brightCyan

17 , brightCyan

39 , brightWhite

18 , brightWhite

40− -- ** Creating Colors From RGB

41− , linearColor

42− , srgbColor

43− , rgbColor

44− , color240

45− , module Graphics.Vty.Attributes.Color240

46 )

19 )

47where

20where

49import Data.Word

22import Data.Word

50−import GHC.Generics

51−import Control.DeepSeq

52−import System.Environment (lookupEnv)

53−

54−import qualified System.Console.Terminfo as Terminfo

55−import Control.Exception (catch)

56−import Data.Maybe

57−

58−import Graphics.Vty.Attributes.Color240

60-- | Abstract data type representing a color.

24-- | Abstract data type representing a color.

61--

25--

@@ -95,7 +59,7 @@ import Graphics.Vty.Attributes.Color240

95-- reported then the color reproduction will be incorrect.

59-- reported then the color reproduction will be incorrect.

96--

60--

97-- If the terminal reports <= 16 colors then the 240 color palette

61-- If the terminal reports <= 16 colors then the 240 color palette

98−-- points are only mapped to the 8 color palette. I'm not sure of

62+-- points are only mapped to the 8 color pallete. I'm not sure of

99-- the RGB points for the "bright" colors which is why they are not

63-- the RGB points for the "bright" colors which is why they are not

100-- addressable via the 240 color palette.

64-- addressable via the 240 color palette.

101--

65--

@@ -109,33 +73,10 @@ import Graphics.Vty.Attributes.Color240

109-- terminfo but I don't know it.

73-- terminfo but I don't know it.

110--

74--

111-- Seriously, terminal color support is INSANE.

75-- Seriously, terminal color support is INSANE.

112−data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8

76+data Color = ISOColor !Word8 | Color240 !Word8

113− deriving ( Eq, Show, Read, Generic, NFData )

77+ deriving ( Eq, Show, Read )

114−

115−data ColorMode

116− = NoColor

117− | ColorMode8

118− | ColorMode16

119− | ColorMode240 !Word8

120− | FullColor

121− deriving ( Eq, Show )

122−

123−detectColorMode :: String -> IO ColorMode

124−detectColorMode termName' = do

125− term <- catch (Just <$> Terminfo.setupTerm termName')

126− (\(_ :: Terminfo.SetupTermError) -> return Nothing)

127− let getCap cap = term >>= \t -> Terminfo.getCapability t cap

128− termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")

129− colorterm <- lookupEnv "COLORTERM"

130− return $ if

131− | termColors < 8 -> NoColor

132− | termColors < 16 -> ColorMode8

133− | termColors == 16 -> ColorMode16

134− | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)

135− | colorterm == Just "truecolor" -> FullColor

136− | colorterm == Just "24bit" -> FullColor

137− | otherwise -> ColorMode240 240

138

79+-- | Standard 8-color ANSI terminal color codes.

139black, red, green, yellow, blue, magenta, cyan, white :: Color

80black, red, green, yellow, blue, magenta, cyan, white :: Color

140black = ISOColor 0

81black = ISOColor 0

141red = ISOColor 1

82red = ISOColor 1

@@ -146,6 +87,7 @@ magenta= ISOColor 5

146cyan = ISOColor 6

87cyan = ISOColor 6

147white = ISOColor 7

88white = ISOColor 7

148

90+-- | Bright/Vivid variants of the standard 8-color ANSI

149brightBlack, brightRed, brightGreen, brightYellow :: Color

91brightBlack, brightRed, brightGreen, brightYellow :: Color

150brightBlue, brightMagenta, brightCyan, brightWhite :: Color

92brightBlue, brightMagenta, brightCyan, brightWhite :: Color

151brightBlack = ISOColor 8

93brightBlack = ISOColor 8

@@ -156,36 +98,3 @@ brightBlue = ISOColor 12

156brightMagenta= ISOColor 13

98brightMagenta= ISOColor 13

157brightCyan = ISOColor 14

99brightCyan = ISOColor 14

158brightWhite = ISOColor 15

100brightWhite = ISOColor 15

159−

160−linearColor :: Integral i => i -> i -> i -> Color

161−linearColor r g b = RGBColor r' g' b'

162− where

163− r' = fromIntegral (clamp r) :: Word8

164− g' = fromIntegral (clamp g) :: Word8

165− b' = fromIntegral (clamp b) :: Word8

166− clamp = min 255 . max 0

167−

168−srgbColor :: Integral i => i -> i -> i -> Color

169−srgbColor r g b =

170− -- srgb to rgb transformation as described at

171− -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation

172− --

173− -- TODO: it may be worth translating this to a lookup table, as with color240

174− let shrink n = fromIntegral n / 255 :: Double

175− -- called gamma^-1 in wiki

176− gamma u

177− | u <= 0.04045 = u/12.92

178− | otherwise = ((u + 0.055) / 1.055) ** 2.4

179− -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?

180− expand n = round (255 * n)

181− convert = expand . gamma . shrink

182− in RGBColor (convert r) (convert g) (convert b)

183−

184−color240 :: Integral i => i -> i -> i -> Color

185−color240 r g b = Color240 (rgbColorToColor240 r g b)

186−

187−-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.

188−-- This function is lossy in the sense that we only internally support 240 colors but the

189−-- #RRGGBB format supports 16^3 colors.

190−rgbColor :: Integral i => i -> i -> i -> Color

191−rgbColor = color240

src/Graphics/Vty/Attributes/Color240.hs+248−285

@@ -1,298 +1,261 @@

1-- This header file was generated by ./256colres.pl

2module Graphics.Vty.Attributes.Color240

3− ( rgbColorToColor240

3+ ( rgbColor

4− , color240CodeToRGB

5 )

4 )

6where

5where

8−import Data.Word (Word8)

7+import Graphics.Vty.Attributes.Color

9import Text.Printf

11-- Note: rgbColor's mapping from RGB to 240 colors was generated from

12-- 256colres.pl which is forked from xterm 256colres.pl.

14−-- | Create a value in the Color240 set from an RGB triple

14+-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.

15−rgbColorToColor240 :: Integral i => i -> i -> i -> Word8

15+rgbColor :: Integral i => i -> i -> i -> Color

16−rgbColorToColor240 r g b

16+rgbColor r g b

17 | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"

18− | r == 8 && g == 8 && b == 8 = 216

18+ | r == 8 && g == 8 && b == 8 = Color240 216

19− | r == 18 && g == 18 && b == 18 = 217

19+ | r == 18 && g == 18 && b == 18 = Color240 217

20− | r == 28 && g == 28 && b == 28 = 218

20+ | r == 28 && g == 28 && b == 28 = Color240 218

21− | r == 38 && g == 38 && b == 38 = 219

21+ | r == 38 && g == 38 && b == 38 = Color240 219

22− | r == 48 && g == 48 && b == 48 = 220

22+ | r == 48 && g == 48 && b == 48 = Color240 220

23− | r == 58 && g == 58 && b == 58 = 221

23+ | r == 58 && g == 58 && b == 58 = Color240 221

24− | r == 68 && g == 68 && b == 68 = 222

24+ | r == 68 && g == 68 && b == 68 = Color240 222

25− | r == 78 && g == 78 && b == 78 = 223

25+ | r == 78 && g == 78 && b == 78 = Color240 223

26− | r == 88 && g == 88 && b == 88 = 224

26+ | r == 88 && g == 88 && b == 88 = Color240 224

27− | r == 98 && g == 98 && b == 98 = 225

27+ | r == 98 && g == 98 && b == 98 = Color240 225

28− | r == 108 && g == 108 && b == 108 = 226

28+ | r == 108 && g == 108 && b == 108 = Color240 226

29− | r == 118 && g == 118 && b == 118 = 227

29+ | r == 118 && g == 118 && b == 118 = Color240 227

30− | r == 128 && g == 128 && b == 128 = 228

30+ | r == 128 && g == 128 && b == 128 = Color240 228

31− | r == 138 && g == 138 && b == 138 = 229

31+ | r == 138 && g == 138 && b == 138 = Color240 229

32− | r == 148 && g == 148 && b == 148 = 230

32+ | r == 148 && g == 148 && b == 148 = Color240 230

33− | r == 158 && g == 158 && b == 158 = 231

33+ | r == 158 && g == 158 && b == 158 = Color240 231

34− | r == 168 && g == 168 && b == 168 = 232

34+ | r == 168 && g == 168 && b == 168 = Color240 232

35− | r == 178 && g == 178 && b == 178 = 233

35+ | r == 178 && g == 178 && b == 178 = Color240 233

36− | r == 188 && g == 188 && b == 188 = 234

36+ | r == 188 && g == 188 && b == 188 = Color240 234

37− | r == 198 && g == 198 && b == 198 = 235

37+ | r == 198 && g == 198 && b == 198 = Color240 235

38− | r == 208 && g == 208 && b == 208 = 236

38+ | r == 208 && g == 208 && b == 208 = Color240 236

39− | r == 218 && g == 218 && b == 218 = 237

39+ | r == 218 && g == 218 && b == 218 = Color240 237

40− | r == 228 && g == 228 && b == 228 = 238

40+ | r == 228 && g == 228 && b == 228 = Color240 238

41− | r == 238 && g == 238 && b == 238 = 239

41+ | r == 238 && g == 238 && b == 238 = Color240 239

42− | otherwise = 36 * go r + 6 * go g + go b

42+ | r <= 0 && g <= 0 && b <= 0 = Color240 0

43− where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."

43+ | r <= 0 && g <= 0 && b <= 95 = Color240 1

44+ | r <= 0 && g <= 0 && b <= 135 = Color240 2

45+ | r <= 0 && g <= 0 && b <= 175 = Color240 3

46+ | r <= 0 && g <= 0 && b <= 215 = Color240 4

47+ | r <= 0 && g <= 0 && b <= 255 = Color240 5

48+ | r <= 0 && g <= 95 && b <= 0 = Color240 6

49+ | r <= 0 && g <= 95 && b <= 95 = Color240 7

50+ | r <= 0 && g <= 95 && b <= 135 = Color240 8

51+ | r <= 0 && g <= 95 && b <= 175 = Color240 9

52+ | r <= 0 && g <= 95 && b <= 215 = Color240 10

53+ | r <= 0 && g <= 95 && b <= 255 = Color240 11

54+ | r <= 0 && g <= 135 && b <= 0 = Color240 12

55+ | r <= 0 && g <= 135 && b <= 95 = Color240 13

56+ | r <= 0 && g <= 135 && b <= 135 = Color240 14

57+ | r <= 0 && g <= 135 && b <= 175 = Color240 15

58+ | r <= 0 && g <= 135 && b <= 215 = Color240 16

59+ | r <= 0 && g <= 135 && b <= 255 = Color240 17

60+ | r <= 0 && g <= 175 && b <= 0 = Color240 18

61+ | r <= 0 && g <= 175 && b <= 95 = Color240 19

62+ | r <= 0 && g <= 175 && b <= 135 = Color240 20

63+ | r <= 0 && g <= 175 && b <= 175 = Color240 21

64+ | r <= 0 && g <= 175 && b <= 215 = Color240 22

65+ | r <= 0 && g <= 175 && b <= 255 = Color240 23

66+ | r <= 0 && g <= 215 && b <= 0 = Color240 24

67+ | r <= 0 && g <= 215 && b <= 95 = Color240 25

68+ | r <= 0 && g <= 215 && b <= 135 = Color240 26

69+ | r <= 0 && g <= 215 && b <= 175 = Color240 27

70+ | r <= 0 && g <= 215 && b <= 215 = Color240 28

71+ | r <= 0 && g <= 215 && b <= 255 = Color240 29

72+ | r <= 0 && g <= 255 && b <= 0 = Color240 30

73+ | r <= 0 && g <= 255 && b <= 95 = Color240 31

74+ | r <= 0 && g <= 255 && b <= 135 = Color240 32

75+ | r <= 0 && g <= 255 && b <= 175 = Color240 33

76+ | r <= 0 && g <= 255 && b <= 215 = Color240 34

77+ | r <= 0 && g <= 255 && b <= 255 = Color240 35

78+ | r <= 95 && g <= 0 && b <= 0 = Color240 36

79+ | r <= 95 && g <= 0 && b <= 95 = Color240 37

80+ | r <= 95 && g <= 0 && b <= 135 = Color240 38

81+ | r <= 95 && g <= 0 && b <= 175 = Color240 39

82+ | r <= 95 && g <= 0 && b <= 215 = Color240 40

83+ | r <= 95 && g <= 0 && b <= 255 = Color240 41

84+ | r <= 95 && g <= 95 && b <= 0 = Color240 42

85+ | r <= 95 && g <= 95 && b <= 95 = Color240 43

86+ | r <= 95 && g <= 95 && b <= 135 = Color240 44

87+ | r <= 95 && g <= 95 && b <= 175 = Color240 45

88+ | r <= 95 && g <= 95 && b <= 215 = Color240 46

89+ | r <= 95 && g <= 95 && b <= 255 = Color240 47

90+ | r <= 95 && g <= 135 && b <= 0 = Color240 48

91+ | r <= 95 && g <= 135 && b <= 95 = Color240 49

92+ | r <= 95 && g <= 135 && b <= 135 = Color240 50

93+ | r <= 95 && g <= 135 && b <= 175 = Color240 51

94+ | r <= 95 && g <= 135 && b <= 215 = Color240 52

95+ | r <= 95 && g <= 135 && b <= 255 = Color240 53

96+ | r <= 95 && g <= 175 && b <= 0 = Color240 54

97+ | r <= 95 && g <= 175 && b <= 95 = Color240 55

98+ | r <= 95 && g <= 175 && b <= 135 = Color240 56

99+ | r <= 95 && g <= 175 && b <= 175 = Color240 57

100+ | r <= 95 && g <= 175 && b <= 215 = Color240 58

101+ | r <= 95 && g <= 175 && b <= 255 = Color240 59

102+ | r <= 95 && g <= 215 && b <= 0 = Color240 60

103+ | r <= 95 && g <= 215 && b <= 95 = Color240 61

104+ | r <= 95 && g <= 215 && b <= 135 = Color240 62

105+ | r <= 95 && g <= 215 && b <= 175 = Color240 63

106+ | r <= 95 && g <= 215 && b <= 215 = Color240 64

107+ | r <= 95 && g <= 215 && b <= 255 = Color240 65

108+ | r <= 95 && g <= 255 && b <= 0 = Color240 66

109+ | r <= 95 && g <= 255 && b <= 95 = Color240 67

110+ | r <= 95 && g <= 255 && b <= 135 = Color240 68

111+ | r <= 95 && g <= 255 && b <= 175 = Color240 69

112+ | r <= 95 && g <= 255 && b <= 215 = Color240 70

113+ | r <= 95 && g <= 255 && b <= 255 = Color240 71

114+ | r <= 135 && g <= 0 && b <= 0 = Color240 72

115+ | r <= 135 && g <= 0 && b <= 95 = Color240 73

116+ | r <= 135 && g <= 0 && b <= 135 = Color240 74

117+ | r <= 135 && g <= 0 && b <= 175 = Color240 75

118+ | r <= 135 && g <= 0 && b <= 215 = Color240 76

119+ | r <= 135 && g <= 0 && b <= 255 = Color240 77

120+ | r <= 135 && g <= 95 && b <= 0 = Color240 78

121+ | r <= 135 && g <= 95 && b <= 95 = Color240 79

122+ | r <= 135 && g <= 95 && b <= 135 = Color240 80

123+ | r <= 135 && g <= 95 && b <= 175 = Color240 81

124+ | r <= 135 && g <= 95 && b <= 215 = Color240 82

125+ | r <= 135 && g <= 95 && b <= 255 = Color240 83

126+ | r <= 135 && g <= 135 && b <= 0 = Color240 84

127+ | r <= 135 && g <= 135 && b <= 95 = Color240 85

128+ | r <= 135 && g <= 135 && b <= 135 = Color240 86

129+ | r <= 135 && g <= 135 && b <= 175 = Color240 87

130+ | r <= 135 && g <= 135 && b <= 215 = Color240 88

131+ | r <= 135 && g <= 135 && b <= 255 = Color240 89

132+ | r <= 135 && g <= 175 && b <= 0 = Color240 90

133+ | r <= 135 && g <= 175 && b <= 95 = Color240 91

134+ | r <= 135 && g <= 175 && b <= 135 = Color240 92

135+ | r <= 135 && g <= 175 && b <= 175 = Color240 93

136+ | r <= 135 && g <= 175 && b <= 215 = Color240 94

137+ | r <= 135 && g <= 175 && b <= 255 = Color240 95

138+ | r <= 135 && g <= 215 && b <= 0 = Color240 96

139+ | r <= 135 && g <= 215 && b <= 95 = Color240 97

140+ | r <= 135 && g <= 215 && b <= 135 = Color240 98

141+ | r <= 135 && g <= 215 && b <= 175 = Color240 99

142+ | r <= 135 && g <= 215 && b <= 215 = Color240 100

143+ | r <= 135 && g <= 215 && b <= 255 = Color240 101

144+ | r <= 135 && g <= 255 && b <= 0 = Color240 102

145+ | r <= 135 && g <= 255 && b <= 95 = Color240 103

146+ | r <= 135 && g <= 255 && b <= 135 = Color240 104

147+ | r <= 135 && g <= 255 && b <= 175 = Color240 105

148+ | r <= 135 && g <= 255 && b <= 215 = Color240 106

149+ | r <= 135 && g <= 255 && b <= 255 = Color240 107

150+ | r <= 175 && g <= 0 && b <= 0 = Color240 108

151+ | r <= 175 && g <= 0 && b <= 95 = Color240 109

152+ | r <= 175 && g <= 0 && b <= 135 = Color240 110

153+ | r <= 175 && g <= 0 && b <= 175 = Color240 111

154+ | r <= 175 && g <= 0 && b <= 215 = Color240 112

155+ | r <= 175 && g <= 0 && b <= 255 = Color240 113

156+ | r <= 175 && g <= 95 && b <= 0 = Color240 114

157+ | r <= 175 && g <= 95 && b <= 95 = Color240 115

158+ | r <= 175 && g <= 95 && b <= 135 = Color240 116

159+ | r <= 175 && g <= 95 && b <= 175 = Color240 117

160+ | r <= 175 && g <= 95 && b <= 215 = Color240 118

161+ | r <= 175 && g <= 95 && b <= 255 = Color240 119

162+ | r <= 175 && g <= 135 && b <= 0 = Color240 120

163+ | r <= 175 && g <= 135 && b <= 95 = Color240 121

164+ | r <= 175 && g <= 135 && b <= 135 = Color240 122

165+ | r <= 175 && g <= 135 && b <= 175 = Color240 123

166+ | r <= 175 && g <= 135 && b <= 215 = Color240 124

167+ | r <= 175 && g <= 135 && b <= 255 = Color240 125

168+ | r <= 175 && g <= 175 && b <= 0 = Color240 126

169+ | r <= 175 && g <= 175 && b <= 95 = Color240 127

170+ | r <= 175 && g <= 175 && b <= 135 = Color240 128

171+ | r <= 175 && g <= 175 && b <= 175 = Color240 129

172+ | r <= 175 && g <= 175 && b <= 215 = Color240 130

173+ | r <= 175 && g <= 175 && b <= 255 = Color240 131

174+ | r <= 175 && g <= 215 && b <= 0 = Color240 132

175+ | r <= 175 && g <= 215 && b <= 95 = Color240 133

176+ | r <= 175 && g <= 215 && b <= 135 = Color240 134

177+ | r <= 175 && g <= 215 && b <= 175 = Color240 135

178+ | r <= 175 && g <= 215 && b <= 215 = Color240 136

179+ | r <= 175 && g <= 215 && b <= 255 = Color240 137

180+ | r <= 175 && g <= 255 && b <= 0 = Color240 138

181+ | r <= 175 && g <= 255 && b <= 95 = Color240 139

182+ | r <= 175 && g <= 255 && b <= 135 = Color240 140

183+ | r <= 175 && g <= 255 && b <= 175 = Color240 141

184+ | r <= 175 && g <= 255 && b <= 215 = Color240 142

185+ | r <= 175 && g <= 255 && b <= 255 = Color240 143

186+ | r <= 215 && g <= 0 && b <= 0 = Color240 144

187+ | r <= 215 && g <= 0 && b <= 95 = Color240 145

188+ | r <= 215 && g <= 0 && b <= 135 = Color240 146

189+ | r <= 215 && g <= 0 && b <= 175 = Color240 147

190+ | r <= 215 && g <= 0 && b <= 215 = Color240 148

191+ | r <= 215 && g <= 0 && b <= 255 = Color240 149

192+ | r <= 215 && g <= 95 && b <= 0 = Color240 150

193+ | r <= 215 && g <= 95 && b <= 95 = Color240 151

194+ | r <= 215 && g <= 95 && b <= 135 = Color240 152

195+ | r <= 215 && g <= 95 && b <= 175 = Color240 153

196+ | r <= 215 && g <= 95 && b <= 215 = Color240 154

197+ | r <= 215 && g <= 95 && b <= 255 = Color240 155

198+ | r <= 215 && g <= 135 && b <= 0 = Color240 156

199+ | r <= 215 && g <= 135 && b <= 95 = Color240 157

200+ | r <= 215 && g <= 135 && b <= 135 = Color240 158

201+ | r <= 215 && g <= 135 && b <= 175 = Color240 159

202+ | r <= 215 && g <= 135 && b <= 215 = Color240 160

203+ | r <= 215 && g <= 135 && b <= 255 = Color240 161

204+ | r <= 215 && g <= 175 && b <= 0 = Color240 162

205+ | r <= 215 && g <= 175 && b <= 95 = Color240 163

206+ | r <= 215 && g <= 175 && b <= 135 = Color240 164

207+ | r <= 215 && g <= 175 && b <= 175 = Color240 165

208+ | r <= 215 && g <= 175 && b <= 215 = Color240 166

209+ | r <= 215 && g <= 175 && b <= 255 = Color240 167

210+ | r <= 215 && g <= 215 && b <= 0 = Color240 168

211+ | r <= 215 && g <= 215 && b <= 95 = Color240 169

212+ | r <= 215 && g <= 215 && b <= 135 = Color240 170

213+ | r <= 215 && g <= 215 && b <= 175 = Color240 171

214+ | r <= 215 && g <= 215 && b <= 215 = Color240 172

215+ | r <= 215 && g <= 215 && b <= 255 = Color240 173

216+ | r <= 215 && g <= 255 && b <= 0 = Color240 174

217+ | r <= 215 && g <= 255 && b <= 95 = Color240 175

218+ | r <= 215 && g <= 255 && b <= 135 = Color240 176

219+ | r <= 215 && g <= 255 && b <= 175 = Color240 177

220+ | r <= 215 && g <= 255 && b <= 215 = Color240 178

221+ | r <= 215 && g <= 255 && b <= 255 = Color240 179

222+ | r <= 255 && g <= 0 && b <= 0 = Color240 180

223+ | r <= 255 && g <= 0 && b <= 95 = Color240 181

224+ | r <= 255 && g <= 0 && b <= 135 = Color240 182

225+ | r <= 255 && g <= 0 && b <= 175 = Color240 183

226+ | r <= 255 && g <= 0 && b <= 215 = Color240 184

227+ | r <= 255 && g <= 0 && b <= 255 = Color240 185

228+ | r <= 255 && g <= 95 && b <= 0 = Color240 186

229+ | r <= 255 && g <= 95 && b <= 95 = Color240 187

230+ | r <= 255 && g <= 95 && b <= 135 = Color240 188

231+ | r <= 255 && g <= 95 && b <= 175 = Color240 189

232+ | r <= 255 && g <= 95 && b <= 215 = Color240 190

233+ | r <= 255 && g <= 95 && b <= 255 = Color240 191

234+ | r <= 255 && g <= 135 && b <= 0 = Color240 192

235+ | r <= 255 && g <= 135 && b <= 95 = Color240 193

236+ | r <= 255 && g <= 135 && b <= 135 = Color240 194

237+ | r <= 255 && g <= 135 && b <= 175 = Color240 195

238+ | r <= 255 && g <= 135 && b <= 215 = Color240 196

239+ | r <= 255 && g <= 135 && b <= 255 = Color240 197

240+ | r <= 255 && g <= 175 && b <= 0 = Color240 198

241+ | r <= 255 && g <= 175 && b <= 95 = Color240 199

242+ | r <= 255 && g <= 175 && b <= 135 = Color240 200

243+ | r <= 255 && g <= 175 && b <= 175 = Color240 201

244+ | r <= 255 && g <= 175 && b <= 215 = Color240 202

245+ | r <= 255 && g <= 175 && b <= 255 = Color240 203

246+ | r <= 255 && g <= 215 && b <= 0 = Color240 204

247+ | r <= 255 && g <= 215 && b <= 95 = Color240 205

248+ | r <= 255 && g <= 215 && b <= 135 = Color240 206

249+ | r <= 255 && g <= 215 && b <= 175 = Color240 207

250+ | r <= 255 && g <= 215 && b <= 215 = Color240 208

251+ | r <= 255 && g <= 215 && b <= 255 = Color240 209

252+ | r <= 255 && g <= 255 && b <= 0 = Color240 210

253+ | r <= 255 && g <= 255 && b <= 95 = Color240 211

254+ | r <= 255 && g <= 255 && b <= 135 = Color240 212

255+ | r <= 255 && g <= 255 && b <= 175 = Color240 213

256+ | r <= 255 && g <= 255 && b <= 215 = Color240 214

257+ | r <= 255 && g <= 255 && b <= 255 = Color240 215

258+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."

44 (fromIntegral r :: Int)

259 (fromIntegral r :: Int)

45 (fromIntegral g :: Int)

260 (fromIntegral g :: Int)

46− (fromIntegral b :: Int)))

261+ (fromIntegral b :: Int))

47−

48−simpleColor_ :: Integral i => Word8 -> i -> Word8

49−simpleColor_ e c

50− | c <= 0 = 0

51− | c <= 95 = 1

52− | c <= 255 = fromIntegral ((c-16) `div` 40)

53− | otherwise = e

54−

55−-- | Create a RGB triple from a value in the Color240 set.

56−color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)

57−color240CodeToRGB n = case n of

58− 0 -> Just (0, 0, 0)

59− 1 -> Just (0, 0, 95)

60− 2 -> Just (0, 0, 135)

61− 3 -> Just (0, 0, 175)

62− 4 -> Just (0, 0, 215)

63− 5 -> Just (0, 0, 255)

64− 6 -> Just (0, 95, 0)

65− 7 -> Just (0, 95, 95)

66− 8 -> Just (0, 95, 135)

67− 9 -> Just (0, 95, 175)

68− 10 -> Just (0, 95, 215)

69− 11 -> Just (0, 95, 255)

70− 12 -> Just (0, 135, 0)

71− 13 -> Just (0, 135, 95)

72− 14 -> Just (0, 135, 135)

73− 15 -> Just (0, 135, 175)

74− 16 -> Just (0, 135, 215)

75− 17 -> Just (0, 135, 255)

76− 18 -> Just (0, 175, 0)

77− 19 -> Just (0, 175, 95)

78− 20 -> Just (0, 175, 135)

79− 21 -> Just (0, 175, 175)

80− 22 -> Just (0, 175, 215)

81− 23 -> Just (0, 175, 255)

82− 24 -> Just (0, 215, 0)

83− 25 -> Just (0, 215, 95)

84− 26 -> Just (0, 215, 135)

85− 27 -> Just (0, 215, 175)

86− 28 -> Just (0, 215, 215)

87− 29 -> Just (0, 215, 255)

88− 30 -> Just (0, 255, 0)

89− 31 -> Just (0, 255, 95)

90− 32 -> Just (0, 255, 135)

91− 33 -> Just (0, 255, 175)

92− 34 -> Just (0, 255, 215)

93− 35 -> Just (0, 255, 255)

94− 36 -> Just (95, 0, 0)

95− 37 -> Just (95, 0, 95)

96− 38 -> Just (95, 0, 135)

97− 39 -> Just (95, 0, 175)

98− 40 -> Just (95, 0, 215)

99− 41 -> Just (95, 0, 255)

100− 42 -> Just (95, 95, 0)

101− 43 -> Just (95, 95, 95)

102− 44 -> Just (95, 95, 135)

103− 45 -> Just (95, 95, 175)

104− 46 -> Just (95, 95, 215)

105− 47 -> Just (95, 95, 255)

106− 48 -> Just (95, 135, 0)

107− 49 -> Just (95, 135, 95)

108− 50 -> Just (95, 135, 135)

109− 51 -> Just (95, 135, 175)

110− 52 -> Just (95, 135, 215)

111− 53 -> Just (95, 135, 255)

112− 54 -> Just (95, 175, 0)

113− 55 -> Just (95, 175, 95)

114− 56 -> Just (95, 175, 135)

115− 57 -> Just (95, 175, 175)

116− 58 -> Just (95, 175, 215)

117− 59 -> Just (95, 175, 255)

118− 60 -> Just (95, 215, 0)

119− 61 -> Just (95, 215, 95)

120− 62 -> Just (95, 215, 135)

121− 63 -> Just (95, 215, 175)

122− 64 -> Just (95, 215, 215)

123− 65 -> Just (95, 215, 255)

124− 66 -> Just (95, 255, 0)

125− 67 -> Just (95, 255, 95)

126− 68 -> Just (95, 255, 135)

127− 69 -> Just (95, 255, 175)

128− 70 -> Just (95, 255, 215)

129− 71 -> Just (95, 255, 255)

130− 72 -> Just (135, 0, 0)

131− 73 -> Just (135, 0, 95)

132− 74 -> Just (135, 0, 135)

133− 75 -> Just (135, 0, 175)

134− 76 -> Just (135, 0, 215)

135− 77 -> Just (135, 0, 255)

136− 78 -> Just (135, 95, 0)

137− 79 -> Just (135, 95, 95)

138− 80 -> Just (135, 95, 135)

139− 81 -> Just (135, 95, 175)

140− 82 -> Just (135, 95, 215)

141− 83 -> Just (135, 95, 255)

142− 84 -> Just (135, 135, 0)

143− 85 -> Just (135, 135, 95)

144− 86 -> Just (135, 135, 135)

145− 87 -> Just (135, 135, 175)

146− 88 -> Just (135, 135, 215)

147− 89 -> Just (135, 135, 255)

148− 90 -> Just (135, 175, 0)

149− 91 -> Just (135, 175, 95)

150− 92 -> Just (135, 175, 135)

151− 93 -> Just (135, 175, 175)

152− 94 -> Just (135, 175, 215)

153− 95 -> Just (135, 175, 255)

154− 96 -> Just (135, 215, 0)

155− 97 -> Just (135, 215, 95)

156− 98 -> Just (135, 215, 135)

157− 99 -> Just (135, 215, 175)

158− 100 -> Just (135, 215, 215)

159− 101 -> Just (135, 215, 255)

160− 102 -> Just (135, 255, 0)

161− 103 -> Just (135, 255, 95)

162− 104 -> Just (135, 255, 135)

163− 105 -> Just (135, 255, 175)

164− 106 -> Just (135, 255, 215)

165− 107 -> Just (135, 255, 255)

166− 108 -> Just (175, 0, 0)

167− 109 -> Just (175, 0, 95)

168− 110 -> Just (175, 0, 135)

169− 111 -> Just (175, 0, 175)

170− 112 -> Just (175, 0, 215)

171− 113 -> Just (175, 0, 255)

172− 114 -> Just (175, 95, 0)

173− 115 -> Just (175, 95, 95)

174− 116 -> Just (175, 95, 135)

175− 117 -> Just (175, 95, 175)

176− 118 -> Just (175, 95, 215)

177− 119 -> Just (175, 95, 255)

178− 120 -> Just (175, 135, 0)

179− 121 -> Just (175, 135, 95)

180− 122 -> Just (175, 135, 135)

181− 123 -> Just (175, 135, 175)

182− 124 -> Just (175, 135, 215)

183− 125 -> Just (175, 135, 255)

184− 126 -> Just (175, 175, 0)

185− 127 -> Just (175, 175, 95)

186− 128 -> Just (175, 175, 135)

187− 129 -> Just (175, 175, 175)

188− 130 -> Just (175, 175, 215)

189− 131 -> Just (175, 175, 255)

190− 132 -> Just (175, 215, 0)

191− 133 -> Just (175, 215, 95)

192− 134 -> Just (175, 215, 135)

193− 135 -> Just (175, 215, 175)

194− 136 -> Just (175, 215, 215)

195− 137 -> Just (175, 215, 255)

196− 138 -> Just (175, 255, 0)

197− 139 -> Just (175, 255, 95)

198− 140 -> Just (175, 255, 135)

199− 141 -> Just (175, 255, 175)

200− 142 -> Just (175, 255, 215)

201− 143 -> Just (175, 255, 255)

202− 144 -> Just (215, 0, 0)

203− 145 -> Just (215, 0, 95)

204− 146 -> Just (215, 0, 135)

205− 147 -> Just (215, 0, 175)

206− 148 -> Just (215, 0, 215)

207− 149 -> Just (215, 0, 255)

208− 150 -> Just (215, 95, 0)

209− 151 -> Just (215, 95, 95)

210− 152 -> Just (215, 95, 135)

211− 153 -> Just (215, 95, 175)

212− 154 -> Just (215, 95, 215)

213− 155 -> Just (215, 95, 255)

214− 156 -> Just (215, 135, 0)

215− 157 -> Just (215, 135, 95)

216− 158 -> Just (215, 135, 135)

217− 159 -> Just (215, 135, 175)

218− 160 -> Just (215, 135, 215)

219− 161 -> Just (215, 135, 255)

220− 162 -> Just (215, 175, 0)

221− 163 -> Just (215, 175, 95)

222− 164 -> Just (215, 175, 135)

223− 165 -> Just (215, 175, 175)

224− 166 -> Just (215, 175, 215)

225− 167 -> Just (215, 175, 255)

226− 168 -> Just (215, 215, 0)

227− 169 -> Just (215, 215, 95)

228− 170 -> Just (215, 215, 135)

229− 171 -> Just (215, 215, 175)

230− 172 -> Just (215, 215, 215)

231− 173 -> Just (215, 215, 255)

232− 174 -> Just (215, 255, 0)

233− 175 -> Just (215, 255, 95)

234− 176 -> Just (215, 255, 135)

235− 177 -> Just (215, 255, 175)

236− 178 -> Just (215, 255, 215)

237− 179 -> Just (215, 255, 255)

238− 180 -> Just (255, 0, 0)

239− 181 -> Just (255, 0, 95)

240− 182 -> Just (255, 0, 135)

241− 183 -> Just (255, 0, 175)

242− 184 -> Just (255, 0, 215)

243− 185 -> Just (255, 0, 255)

244− 186 -> Just (255, 95, 0)

245− 187 -> Just (255, 95, 95)

246− 188 -> Just (255, 95, 135)

247− 189 -> Just (255, 95, 175)

248− 190 -> Just (255, 95, 215)

249− 191 -> Just (255, 95, 255)

250− 192 -> Just (255, 135, 0)

251− 193 -> Just (255, 135, 95)

252− 194 -> Just (255, 135, 135)

253− 195 -> Just (255, 135, 175)

254− 196 -> Just (255, 135, 215)

255− 197 -> Just (255, 135, 255)

256− 198 -> Just (255, 175, 0)

257− 199 -> Just (255, 175, 95)

258− 200 -> Just (255, 175, 135)

259− 201 -> Just (255, 175, 175)

260− 202 -> Just (255, 175, 215)

261− 203 -> Just (255, 175, 255)

262− 204 -> Just (255, 215, 0)

263− 205 -> Just (255, 215, 95)

264− 206 -> Just (255, 215, 135)

265− 207 -> Just (255, 215, 175)

266− 208 -> Just (255, 215, 215)

267− 209 -> Just (255, 215, 255)

268− 210 -> Just (255, 255, 0)

269− 211 -> Just (255, 255, 95)

270− 212 -> Just (255, 255, 135)

271− 213 -> Just (255, 255, 175)

272− 214 -> Just (255, 255, 215)

273− 215 -> Just (255, 255, 255)

274− 216 -> Just (8, 8, 8)

275− 217 -> Just (18, 18, 18)

276− 218 -> Just (28, 28, 28)

277− 219 -> Just (38, 38, 38)

278− 220 -> Just (48, 48, 48)

279− 221 -> Just (58, 58, 58)

280− 222 -> Just (68, 68, 68)

281− 223 -> Just (78, 78, 78)

282− 224 -> Just (88, 88, 88)

283− 225 -> Just (98, 98, 98)

284− 226 -> Just (108, 108, 108)

285− 227 -> Just (118, 118, 118)

286− 228 -> Just (128, 128, 128)

287− 229 -> Just (138, 138, 138)

288− 230 -> Just (148, 148, 148)

289− 231 -> Just (158, 158, 158)

290− 232 -> Just (168, 168, 168)

291− 233 -> Just (178, 178, 178)

292− 234 -> Just (188, 188, 188)

293− 235 -> Just (198, 198, 198)

294− 236 -> Just (208, 208, 208)

295− 237 -> Just (218, 218, 218)

296− 238 -> Just (228, 228, 228)

297− 239 -> Just (238, 238, 238)

298− _ -> Nothing

src/Graphics/Vty/Config.hs+68−259

@@ -1,9 +1,7 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

2{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE LambdaCase, MultiWayIf #-}

7-- | Vty supports a configuration file format and associated 'Config'

5-- | Vty supports a configuration file format and associated 'Config'

8-- data type. The 'Config' can be provided to 'mkVty' to customize the

6-- data type. The 'Config' can be provided to 'mkVty' to customize the

9-- application's use of Vty.

7-- application's use of Vty.

@@ -55,33 +53,7 @@

55-- If a debug log is requested then vty will output the current input

53-- If a debug log is requested then vty will output the current input

56-- table to the log in the above format. A workflow for using this is

54-- table to the log in the above format. A workflow for using this is

57-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for

55-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for

58−-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.

56+-- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.

59−--

60−-- = Unicode Character Width Maps

61−--

62−-- == @widthMap@

63−--

64−-- Format:

65−--

66−-- @

67−-- \"widthMap\" string string

68−-- @

69−--

70−-- E.g.,

71−--

72−-- @

73−-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"

74−-- @

75−--

76−-- This directive specifies the path to a Unicode character width

77−-- map (the second argument) that should be loaded and used when

78−-- the value of TERM matches the first argument. Unicode character

79−-- width maps can be produced either by running the provided binary

80−-- @vty-build-width-table@ or by calling the library routine

81−-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The

82−-- 'Graphics.Vty.mkVty' function will use these configuration settings

83−-- to attempt to load and install the specified width map. See the

84−-- documentation for 'Graphics.Vty.mkVty' for details.

85module Graphics.Vty.Config

57module Graphics.Vty.Config

86 ( InputMap

58 ( InputMap

87 , Config(..)

59 , Config(..)

@@ -92,17 +64,6 @@ module Graphics.Vty.Config

92 , runParseConfig

64 , runParseConfig

93 , parseConfigFile

65 , parseConfigFile

94 , defaultConfig

66 , defaultConfig

95− , getTtyEraseChar

96− , currentTerminalName

97−

98− , vtyConfigPath

99− , widthTableFilename

100− , vtyDataDirectory

101− , terminalWidthTablePath

102− , vtyConfigFileEnvName

103−

104− , ConfigUpdateResult(..)

105− , addConfigWidthMap

106 )

67 )

107where

68where

108

@@ -114,40 +75,29 @@ import Control.Exception (catch, IOException, Exception(..), throwIO)

114import Control.Monad (liftM, guard, void)

75import Control.Monad (liftM, guard, void)

115

116import qualified Data.ByteString as BS

77import qualified Data.ByteString as BS

117−#if !(MIN_VERSION_base(4,8,0))

118−import Data.Monoid (Monoid(..))

78+import Data.Monoid

119−#endif

120−#if !(MIN_VERSION_base(4,11,0))

121−import Data.Semigroup (Semigroup(..))

122−#endif

123import Data.Typeable (Typeable)

79import Data.Typeable (Typeable)

124

125import Graphics.Vty.Input.Events

81import Graphics.Vty.Input.Events

126−import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)

127

128import GHC.Generics

83import GHC.Generics

129

130−import System.Directory ( getAppUserDataDirectory, doesFileExist

85+import System.Directory (getAppUserDataDirectory)

131− , createDirectoryIfMissing

132− )

133−import System.Environment (lookupEnv)

86+import System.Posix.Env (getEnv)

134−import System.FilePath ((</>), takeDirectory)

135import System.Posix.IO (stdInput, stdOutput)

87import System.Posix.IO (stdInput, stdOutput)

136import System.Posix.Types (Fd(..))

88import System.Posix.Types (Fd(..))

137−import Foreign.C.Types (CInt(..), CChar(..))

138

139import Text.Parsec hiding ((<|>))

90import Text.Parsec hiding ((<|>))

140import Text.Parsec.Token ( GenLanguageDef(..) )

91import Text.Parsec.Token ( GenLanguageDef(..) )

141import qualified Text.Parsec.Token as P

92import qualified Text.Parsec.Token as P

142

143-- | Type of errors that can be thrown when configuring VTY

94-- | Type of errors that can be thrown when configuring VTY

144−data VtyConfigurationError =

95+data VtyConfigurationError

145− VtyMissingTermEnvVar

146− -- ^ TERM environment variable not set

96+ = VtyMissingTermEnvVar -- ^ TERM environment variable not set

147− deriving (Show, Eq, Typeable)

97+ deriving (Show, Eq, Typeable)

148

149instance Exception VtyConfigurationError where

99instance Exception VtyConfigurationError where

150− displayException VtyMissingTermEnvVar = "TERM environment variable not set"

100+ displayException VtyMissingTermEnvVar = "TERM environment variable not set"

151

101

152-- | Mappings from input bytes to event in the order specified. Later

102-- | Mappings from input bytes to event in the order specified. Later

153-- entries take precedence over earlier in the case multiple entries

103-- entries take precedence over earlier in the case multiple entries

@@ -155,144 +105,85 @@ instance Exception VtyConfigurationError where

155type InputMap = [(Maybe String, String, Event)]

105type InputMap = [(Maybe String, String, Event)]

156

106

157-- | A Vty configuration.

107-- | A Vty configuration.

158−data Config =

108+data Config = Config

109+ {

110+ -- | The default is 1 character.

159− Config { vmin :: Maybe Int

111+ vmin :: Maybe Int

160− -- ^ The default is 1 character.

161− , vtime :: Maybe Int

162− -- ^ The default is 100 milliseconds, 0.1 seconds.

112+ -- | The default is 100 milliseconds, 0.1 seconds.

113+ , vtime :: Maybe Int

114+ -- | The default is False.

163− , mouseMode :: Maybe Bool

115+ , mouseMode :: Maybe Bool

164− -- ^ The default is False.

116+ -- | The default is False.

165− , bracketedPasteMode :: Maybe Bool

117+ , bracketedPasteMode :: Maybe Bool

166− -- ^ The default is False.

167− , debugLog :: Maybe FilePath

168− -- ^ Debug information is appended to this file if not

118+ -- | Debug information is appended to this file if not Nothing.

169− -- Nothing.

119+ , debugLog :: Maybe FilePath

170− , inputMap :: InputMap

171− -- ^ The (input byte, output event) pairs extend the internal

120+ -- | The (input byte, output event) pairs extend the internal input

172− -- input table of VTY and the table from terminfo.

121+ -- table of VTY and the table from terminfo.

173− --

122+ --

174− -- See "Graphics.Vty.Config" module documentation for

123+ -- See "Graphics.Vty.Config" module documentation for documentation

175− -- documentation of the @map@ directive.

124+ -- of the @map@ directive.

176− , inputFd :: Maybe Fd

125+ , inputMap :: InputMap

177− -- ^ The input file descriptor to use. The default is

126+ -- | The input file descriptor to use. The default is

178− -- 'System.Posix.IO.stdInput'

127+ -- 'System.Posix.IO.stdInput'

179− , outputFd :: Maybe Fd

128+ , inputFd :: Maybe Fd

180− -- ^ The output file descriptor to use. The default is

129+ -- | The output file descriptor to use. The default is

181− -- 'System.Posix.IO.stdOutput'

130+ -- 'System.Posix.IO.stdOutput'

182− , termName :: Maybe String

131+ , outputFd :: Maybe Fd

183− -- ^ The terminal name used to look up terminfo capabilities.

132+ -- | The terminal name used to look up terminfo capabilities.

184− -- The default is the value of the TERM environment variable.

133+ -- The default is the value of the TERM environment variable.

185− , termWidthMaps :: [(String, FilePath)]

134+ , termName :: Maybe String

186− -- ^ Terminal width map files.

187− , allowCustomUnicodeWidthTables :: Maybe Bool

188− -- ^ Whether to permit custom Unicode width table loading by

189− -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that

190− -- table loading should not be performed. Other values permit

191− -- table loading.

192− --

193− -- If a table load is attempted and fails, information

194− -- about the failure will be logged to the debug log if the

195− -- configuration specifies one. If no custom table is loaded

196− -- (or if a load fails), the built-in character width table

197− -- will be used.

198− , colorMode :: Maybe ColorMode

199− -- ^ The color mode used to know how many colors the terminal

200− -- supports.

201− }

202− deriving (Show, Eq)

135+ } deriving (Show, Eq)

203

136

204defaultConfig :: Config

137defaultConfig :: Config

205defaultConfig = mempty

138defaultConfig = mempty

206

139

207−instance Semigroup Config where

208− c0 <> c1 =

209− -- latter config takes priority for everything but inputMap

210− Config { vmin = vmin c1 <|> vmin c0

211− , vtime = vtime c1 <|> vtime c0

212− , mouseMode = mouseMode c1

213− , bracketedPasteMode = bracketedPasteMode c1

214− , debugLog = debugLog c1 <|> debugLog c0

215− , inputMap = inputMap c0 <> inputMap c1

216− , inputFd = inputFd c1 <|> inputFd c0

217− , outputFd = outputFd c1 <|> outputFd c0

218− , termName = termName c1 <|> termName c0

219− , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0

220− , allowCustomUnicodeWidthTables =

221− allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0

222− , colorMode = colorMode c1 <|> colorMode c0

223− }

224−

225instance Monoid Config where

140instance Monoid Config where

226− mempty =

141+ mempty = Config

227− Config { vmin = Nothing

142+ { vmin = Nothing

228− , vtime = Nothing

143+ , vtime = Nothing

229− , mouseMode = Nothing

144+ , mouseMode = Nothing

230− , bracketedPasteMode = Nothing

145+ , bracketedPasteMode = Nothing

231− , debugLog = mempty

146+ , debugLog = mempty

232− , inputMap = mempty

147+ , inputMap = mempty

233− , inputFd = Nothing

148+ , inputFd = Nothing

234− , outputFd = Nothing

149+ , outputFd = Nothing

235− , termName = Nothing

150+ , termName = Nothing

236− , termWidthMaps = []

237− , allowCustomUnicodeWidthTables = Nothing

238− , colorMode = Nothing

239− }

151+ }

240−#if !(MIN_VERSION_base(4,11,0))

241− mappend = (<>)

152+ mappend c0 c1 = Config

242−#endif

153+ -- latter config takes priority for everything but inputMap

243−

154+ { vmin = vmin c1 <|> vmin c0

244−vtyDataDirectory :: IO FilePath

155+ , vtime = vtime c1 <|> vtime c0

245−vtyDataDirectory = getAppUserDataDirectory "vty"

156+ , mouseMode = mouseMode c1

246−

157+ , bracketedPasteMode = bracketedPasteMode c1

247−vtyConfigPath :: IO FilePath

158+ , debugLog = debugLog c1 <|> debugLog c0

248−vtyConfigPath = do

159+ , inputMap = inputMap c0 <> inputMap c1

249− dir <- vtyDataDirectory

160+ , inputFd = inputFd c1 <|> inputFd c0

250− return $ dir </> "config"

161+ , outputFd = outputFd c1 <|> outputFd c0

251−

162+ , termName = termName c1 <|> termName c0

252−vtyConfigFileEnvName :: String

163+ }

253−vtyConfigFileEnvName = "VTY_CONFIG_FILE"

164+

254−

255−-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.

165+-- | Load a configuration from @'getAppUserDataDirectory'/config@ and

166+-- @$VTY_CONFIG_FILE@.

256userConfig :: IO Config

167userConfig :: IO Config

257userConfig = do

168userConfig = do

258− configFile <- vtyConfigPath >>= parseConfigFile

169+ configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile

259− overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<

170+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"

260− lookupEnv vtyConfigFileEnvName

261 let base = configFile <> overrideConfig

171 let base = configFile <> overrideConfig

262 mappend base <$> overrideEnvConfig

172 mappend base <$> overrideEnvConfig

263

173

264−widthTableFilename :: String -> String

265−widthTableFilename term = "width_table_" <> term <> ".dat"

266−

267−termVariable :: String

268−termVariable = "TERM"

269−

270−currentTerminalName :: IO (Maybe String)

271−currentTerminalName = lookupEnv termVariable

272−

273−terminalWidthTablePath :: IO (Maybe FilePath)

274−terminalWidthTablePath = do

275− dataDir <- vtyDataDirectory

276− result <- lookupEnv termVariable

277− case result of

278− Nothing -> return Nothing

279− Just term -> do

280− return $ Just $ dataDir </> widthTableFilename term

281−

282overrideEnvConfig :: IO Config

174overrideEnvConfig :: IO Config

283overrideEnvConfig = do

175overrideEnvConfig = do

284− d <- lookupEnv "VTY_DEBUG_LOG"

176+ d <- getEnv "VTY_DEBUG_LOG"

285 return $ defaultConfig { debugLog = d }

177 return $ defaultConfig { debugLog = d }

286

178

287-- | Configures VTY using defaults suitable for terminals. This function

179-- | Configures VTY using defaults suitable for terminals. This function

288-- can raise 'VtyConfigurationError'.

180-- can raise 'VtyConfigurationError'.

289standardIOConfig :: IO Config

181standardIOConfig :: IO Config

290standardIOConfig = do

182standardIOConfig = do

291− mb <- lookupEnv termVariable

183+ mb <- getEnv "TERM"

292 case mb of

184 case mb of

293 Nothing -> throwIO VtyMissingTermEnvVar

185 Nothing -> throwIO VtyMissingTermEnvVar

294− Just t -> do

186+ Just t ->

295− mcolorMode <- detectColorMode t

296 return defaultConfig

187 return defaultConfig

297 { vmin = Just 1

188 { vmin = Just 1

298 , mouseMode = Just False

189 , mouseMode = Just False

@@ -301,7 +192,6 @@ standardIOConfig = do

301 , inputFd = Just stdInput

192 , inputFd = Just stdInput

302 , outputFd = Just stdOutput

193 , outputFd = Just stdOutput

303 , termName = Just t

194 , termName = Just t

304− , colorMode = Just mcolorMode

305 }

195 }

306

196

307parseConfigFile :: FilePath -> IO Config

197parseConfigFile :: FilePath -> IO Config

@@ -353,20 +243,13 @@ debugLogDecl = do

353 path <- P.stringLiteral configLexer

243 path <- P.stringLiteral configLexer

354 return defaultConfig { debugLog = Just path }

244 return defaultConfig { debugLog = Just path }

355

245

356−widthMapDecl :: Parser Config

357−widthMapDecl = do

358− "widthMap" <- P.identifier configLexer

359− tName <- P.stringLiteral configLexer

360− path <- P.stringLiteral configLexer

361− return defaultConfig { termWidthMaps = [(tName, path)] }

362−

363ignoreLine :: Parser ()

246ignoreLine :: Parser ()

364ignoreLine = void $ manyTill anyChar newline

247ignoreLine = void $ manyTill anyChar newline

365

248

366parseConfig :: Parser Config

249parseConfig :: Parser Config

367parseConfig = liftM mconcat $ many $ do

250parseConfig = liftM mconcat $ many $ do

368 P.whiteSpace configLexer

251 P.whiteSpace configLexer

369− let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]

252+ let directives = [try mapDecl, try debugLogDecl]

370 choice directives <|> (ignoreLine >> return defaultConfig)

253 choice directives <|> (ignoreLine >> return defaultConfig)

371

254

372class Parse a where parseValue :: Parser a

255class Parse a where parseValue :: Parser a

@@ -412,77 +295,3 @@ instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where

412 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con

295 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con

413

296

414instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"

297instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"

415−

416−foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar

417−

418−-- | Get the "erase" character for the terminal attached to the

419−-- specified file descriptor. This is the character configured by 'stty

420−-- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'.

421−-- Otherwise it will return the character that has been configured to

422−-- indicate the canonical mode ERASE behavior. That character can then

423−-- be added to the table of strings that we interpret to mean Backspace.

424−--

425−-- For more details, see:

426−--

427−-- * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html

428−-- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty

429−-- * https://github.com/matterhorn-chat/matterhorn/issues/565

430−getTtyEraseChar :: Fd -> IO (Maybe Char)

431−getTtyEraseChar fd = do

432− c <- cGetTtyErase fd

433− if c /= 0

434− then return $ Just $ toEnum $ fromEnum c

435− else return Nothing

436−

437−data ConfigUpdateResult =

438− ConfigurationCreated

439− | ConfigurationModified

440− | ConfigurationConflict String

441− | ConfigurationRedundant

442− deriving (Eq, Show)

443−

444−-- | Add a @widthMap@ directive to the Vty configuration file at the

445−-- specified path.

446−--

447−-- If the configuration path refers to a configuration that already

448−-- contains the directive for the specified map and terminal type, the

449−-- configuration file will not be modified. If the file does not contain

450−-- the directive, it will be appended to the file.

451−--

452−-- If the configuration path does not exist, a new configuration file

453−-- will be created and any directories in the path will also be created.

454−--

455−-- This returns @True@ if the configuration was created or modified and

456−-- @False@ otherwise. This does not handle exceptions raised by file or

457−-- directory permissions issues.

458−addConfigWidthMap :: FilePath

459− -- ^ The configuration file path of the configuration

460− -- to modify or create.

461− -> String

462− -- ^ The @TERM@ value for the @widthMap@ directive.

463− -> FilePath

464− -- ^ The width table file path for the directive.

465− -> IO ConfigUpdateResult

466−addConfigWidthMap configPath term tablePath = do

467− configEx <- doesFileExist configPath

468− if configEx

469− then updateConfig

470− else createConfig >> return ConfigurationCreated

471−

472− where

473− directive = "widthMap " <> show term <> " " <> show tablePath <> "\n"

474−

475− createConfig = do

476− let dir = takeDirectory configPath

477− createDirectoryIfMissing True dir

478− writeFile configPath directive

479−

480− updateConfig = do

481− config <- parseConfigFile configPath

482− if (term, tablePath) `elem` termWidthMaps config

483− then return ConfigurationRedundant

484− else case lookup term (termWidthMaps config) of

485− Just other -> return $ ConfigurationConflict other

486− Nothing -> do

487− appendFile configPath directive

488− return ConfigurationModified

src/Graphics/Vty/Debug.hs+6−6

@@ -12,16 +12,16 @@ import Graphics.Vty.Span

13import qualified Data.Vector as Vector

15−rowOpsAffectedColumns :: DisplayOps -> [Int]

15+rowOpsEffectedColumns :: DisplayOps -> [Int]

16−rowOpsAffectedColumns ops

16+rowOpsEffectedColumns ops

17− = Vector.toList $ Vector.map spanOpsAffectedColumns ops

17+ = Vector.toList $ Vector.map spanOpsEffectedColumns ops

19allSpansHaveWidth :: DisplayOps -> Int -> Bool

20allSpansHaveWidth ops expected

21− = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops

21+ = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops

23−spanOpsAffectedRows :: DisplayOps -> Int

23+spanOpsEffectedRows :: DisplayOps -> Int

24−spanOpsAffectedRows ops

24+spanOpsEffectedRows ops

25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))

27type SpanConstructLog = [SpanConstructEvent]

src/Graphics/Vty/DisplayAttributes.hs+4−47

@@ -1,18 +1,11 @@

2{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE CPP #-}

5module Graphics.Vty.DisplayAttributes where

4module Graphics.Vty.DisplayAttributes where

7import Graphics.Vty.Attributes

6import Graphics.Vty.Attributes

9import Data.Bits ((.&.))

8import Data.Bits ((.&.))

10−import Data.ByteString (ByteString)

11−#if !(MIN_VERSION_base(4,11,0))

12−import Data.Semigroup (Semigroup(..))

13−#endif

14−import Data.Text (Text)

15−import Data.Text.Encoding (encodeUtf8)

17-- | Given the previously applied display attributes as a FixedAttr and

10-- | Given the previously applied display attributes as a FixedAttr and

18-- the current display attributes as an Attr produces a FixedAttr that

11-- the current display attributes as an Attr produces a FixedAttr that

@@ -24,7 +17,6 @@ fixDisplayAttr fattr attr

24 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))

17 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))

25 (fixColor (fixedForeColor fattr) (attrForeColor attr))

18 (fixColor (fixedForeColor fattr) (attrForeColor attr))

26 (fixColor (fixedBackColor fattr) (attrBackColor attr))

19 (fixColor (fixedBackColor fattr) (attrBackColor attr))

27− (fixURL (fixedURL fattr) (attrURL attr))

28 where

20 where

29 fixStyle _s Default = defaultStyleMask

21 fixStyle _s Default = defaultStyleMask

30 fixStyle s KeepCurrent = s

22 fixStyle s KeepCurrent = s

@@ -32,9 +24,6 @@ fixDisplayAttr fattr attr

32 fixColor _c Default = Nothing

24 fixColor _c Default = Nothing

33 fixColor c KeepCurrent = c

25 fixColor c KeepCurrent = c

34 fixColor _c (SetTo c) = Just c

26 fixColor _c (SetTo c) = Just c

35− fixURL c KeepCurrent = c

36− fixURL _c (SetTo n) = Just n

37− fixURL _c Default = Nothing

39-- | difference between two display attributes. Used in the calculation

28-- | difference between two display attributes. Used in the calculation

40-- of the operations required to go from one display attribute to the

29-- of the operations required to go from one display attribute to the

@@ -47,23 +36,16 @@ data DisplayAttrDiff = DisplayAttrDiff

47 { styleDiffs :: [StyleStateChange]

36 { styleDiffs :: [StyleStateChange]

48 , foreColorDiff :: DisplayColorDiff

37 , foreColorDiff :: DisplayColorDiff

49 , backColorDiff :: DisplayColorDiff

38 , backColorDiff :: DisplayColorDiff

50− , urlDiff :: URLDiff

51 }

39 }

52 deriving (Show)

40 deriving (Show)

54−instance Semigroup DisplayAttrDiff where

42+instance Monoid DisplayAttrDiff where

43+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange

55− d0 <> d1 =

44+ mappend d0 d1 =

56 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)

45 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)

57 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)

46 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)

58 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)

47 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)

59− ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)

60− in DisplayAttrDiff ds fcd bcd ud

48+ in DisplayAttrDiff ds fcd bcd

61−

62−instance Monoid DisplayAttrDiff where

63− mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange

64−#if !(MIN_VERSION_base(4,11,0))

65− mappend = (<>)

66−#endif

68-- | Used in the computation of a final style attribute change.

50-- | Used in the computation of a final style attribute change.

69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]

51simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]

@@ -76,12 +58,6 @@ simplifyColorDiffs _cd ColorToDefault = ColorToDefault

76simplifyColorDiffs cd NoColorChange = cd

58simplifyColorDiffs cd NoColorChange = cd

77simplifyColorDiffs _cd (SetColor !c) = SetColor c

59simplifyColorDiffs _cd (SetColor !c) = SetColor c

79−-- | Consider two URL changes, which are mostly going to be the latter

80−-- unless the latter specifies no change.

81−simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff

82−simplifyUrlDiffs ud NoLinkChange = ud

83−simplifyUrlDiffs _ ud = ud

84−

85-- | Difference between two display color attribute changes.

61-- | Difference between two display color attribute changes.

86data DisplayColorDiff

62data DisplayColorDiff

87 = ColorToDefault

63 = ColorToDefault

@@ -94,10 +70,6 @@ data DisplayColorDiff

94data StyleStateChange

70data StyleStateChange

95 = ApplyStandout

71 = ApplyStandout

96 | RemoveStandout

72 | RemoveStandout

97− | ApplyItalic

98− | RemoveItalic

99− | ApplyStrikethrough

100− | RemoveStrikethrough

101 | ApplyUnderline

73 | ApplyUnderline

102 | RemoveUnderline

74 | RemoveUnderline

103 | ApplyReverseVideo

75 | ApplyReverseVideo

@@ -110,13 +82,6 @@ data StyleStateChange

110 | RemoveBold

82 | RemoveBold

111 deriving (Show, Eq)

83 deriving (Show, Eq)

112

113−-- Setting and unsetting hyperlinks

114−data URLDiff

115− = LinkTo !ByteString

116− | NoLinkChange

117− | EndLink

118− deriving (Show, Eq)

119−

120-- | Determines the diff between two display&color attributes. This diff

85-- | Determines the diff between two display&color attributes. This diff

121-- determines the operations that actually get output to the terminal.

86-- determines the operations that actually get output to the terminal.

122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

87displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

@@ -124,14 +89,8 @@ displayAttrDiffs attr attr' = DisplayAttrDiff

124 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')

89 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')

125 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')

90 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')

126 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')

91 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')

127− , urlDiff = diffURL (fixedURL attr) (fixedURL attr')

128 }

92 }

129

130−diffURL :: Maybe Text -> Maybe Text -> URLDiff

131−diffURL Nothing Nothing = NoLinkChange

132−diffURL (Just _) Nothing = EndLink

133−diffURL _ (Just url) = LinkTo (encodeUtf8 url)

134−

135diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff

94diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff

136diffColor Nothing (Just c') = SetColor c'

95diffColor Nothing (Just c') = SetColor c'

137diffColor (Just c) (Just c')

96diffColor (Just c) (Just c')

@@ -145,8 +104,6 @@ diffStyles prev cur

145 = mconcat

104 = mconcat

146 [ styleDiff standout ApplyStandout RemoveStandout

105 [ styleDiff standout ApplyStandout RemoveStandout

147 , styleDiff underline ApplyUnderline RemoveUnderline

106 , styleDiff underline ApplyUnderline RemoveUnderline

148− , styleDiff italic ApplyItalic RemoveItalic

149− , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough

150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo

107 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo

151 , styleDiff blink ApplyBlink RemoveBlink

108 , styleDiff blink ApplyBlink RemoveBlink

152 , styleDiff dim ApplyDim RemoveDim

109 , styleDiff dim ApplyDim RemoveDim

src/Graphics/Vty/Image.hs+16−33

@@ -1,4 +1,5 @@

2+{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE DisambiguateRecordFields #-}

4{-# LANGUAGE DisambiguateRecordFields #-}

4-- | A Vty program makes 'Picture's from 'Image's. This module provides

5-- | A Vty program makes 'Picture's from 'Image's. This module provides

@@ -45,12 +46,8 @@ module Graphics.Vty.Image

45 -- * Character width functions

46 -- * Character width functions

46 , safeWcwidth

47 , safeWcwidth

47 , safeWcswidth

48 , safeWcswidth

48− , safeWctwidth

49− , safeWctlwidth

50 , wcwidth

49 , wcwidth

51 , wcswidth

50 , wcswidth

52− , wctwidth

53− , wctlwidth

54 -- * Display Regions

51 -- * Display Regions

55 , DisplayText

52 , DisplayText

56 , DisplayRegion

53 , DisplayRegion

@@ -116,18 +113,14 @@ horizCat = foldr horizJoin EmptyImage

116vertCat :: [Image] -> Image

113vertCat :: [Image] -> Image

117vertCat = foldr vertJoin EmptyImage

114vertCat = foldr vertJoin EmptyImage

118

115

119−-- | Make an 'Image' from a lazy text value. The text value should be

116+-- | Make an 'Image' from a lazy text value.

120−-- sanitized of escape sequences (ASCII 27) and carriage returns;

121−-- otherwise layout and attribute problems may result.

122text :: Attr -> TL.Text -> Image

117text :: Attr -> TL.Text -> Image

123−text a txt = let displayWidth = safeWctlwidth txt

118+text a txt = let displayWidth = safeWcswidth (TL.unpack txt)

124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)

119 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)

125

120

126−-- | Make an 'Image' from a text value. The text value should be

121+-- | Make an 'Image' from a text value.

127−-- sanitized of escape sequences (ASCII 27) and carriage returns;

128−-- otherwise layout and attribute problems may result.

129text' :: Attr -> T.Text -> Image

122text' :: Attr -> T.Text -> Image

130−text' a txt = let displayWidth = safeWctwidth txt

123+text' a txt = let displayWidth = safeWcswidth (T.unpack txt)

131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)

124 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)

132

125

133-- | Make an image from a single character. This is a standard Haskell

126-- | Make an image from a single character. This is a standard Haskell

@@ -137,11 +130,9 @@ char a c =

137 let displayWidth = safeWcwidth c

130 let displayWidth = safeWcwidth c

138 in HorizText a (TL.singleton c) displayWidth 1

131 in HorizText a (TL.singleton c) displayWidth 1

139

132

140−-- | Make an image from a string of characters laid out on a single

133+-- | Make an image from a string of characters layed out on a single

141-- row with the same display attribute. The string is assumed to be a

134-- row with the same display attribute. The string is assumed to be a

142−-- sequence of ISO-10646 characters. The input string should be

135+-- sequence of ISO-10646 characters.

143−-- sanitized of escape sequences (ASCII 27) and carriage returns;

144−-- otherwise layout and attribute problems may result.

145--

136--

146-- Note: depending on how the Haskell compiler represents string

137-- Note: depending on how the Haskell compiler represents string

147-- literals, a string literal in a UTF-8 encoded source file, for

138-- literals, a string literal in a UTF-8 encoded source file, for

@@ -175,14 +166,11 @@ utf8String a bytes = utf8Bytestring a (BL.pack bytes)

175utf8Bytestring :: Attr -> BL.ByteString -> Image

166utf8Bytestring :: Attr -> BL.ByteString -> Image

176utf8Bytestring a bs = text a (TL.decodeUtf8 bs)

167utf8Bytestring a bs = text a (TL.decodeUtf8 bs)

177

168

178−-- | Make an 'Image' from a UTF-8 encoded strict bytestring.

169+-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.

179utf8Bytestring' :: Attr -> B.ByteString -> Image

170utf8Bytestring' :: Attr -> B.ByteString -> Image

180utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)

171utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)

181

172

182-- | Make an image filling a region with the specified character.

173-- | 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.

186charFill :: Integral d

174charFill :: Integral d

187 => Attr

175 => Attr

188 -- ^ The attribute to use.

176 -- ^ The attribute to use.

@@ -193,17 +181,14 @@ charFill :: Integral d

193 -> d

181 -> d

194 -- ^ The region height.

182 -- ^ The region height.

195 -> Image

183 -> Image

196−charFill a c w h

184+charFill _a _c 0 _h = EmptyImage

197− | w <= 0 || h <= 0 = EmptyImage

185+charFill _a _c _w 0 = EmptyImage

198− | otherwise = vertCat

186+charFill a c w h =

199− $ replicate (fromIntegral h)

200− $ HorizText a txt displayWidth charWidth

187+ vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth

201− where

188+ where

202− txt = TL.replicate charWidth (TL.singleton c)

189+ txt = TL.replicate (fromIntegral w) (TL.singleton c)

203− displayWidth = safeWcwidth c * charWidth

190+ displayWidth = safeWcwidth c * (fromIntegral w)

204−

205− charWidth :: Num a => a

206− charWidth = fromIntegral w

191+ charWidth = fromIntegral w

207

192

208-- | The empty image. Useful for fold combinators. These occupy no space

193-- | The empty image. Useful for fold combinators. These occupy no space

209-- and do not affect display attributes.

194-- and do not affect display attributes.

@@ -257,7 +242,6 @@ translate x y i = translateX x (translateY y i)

257-- | Translates an image by padding or cropping its left side.

242-- | Translates an image by padding or cropping its left side.

258translateX :: Int -> Image -> Image

243translateX :: Int -> Image -> Image

259translateX x i

244translateX x i

260− | x < 0 && (abs x > imageWidth i) = emptyImage

261 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)

245 | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)

262 | x == 0 = i

246 | x == 0 = i

263 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h

247 | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h

@@ -265,7 +249,6 @@ translateX x i

265-- | Translates an image by padding or cropping its top.

249-- | Translates an image by padding or cropping its top.

266translateY :: Int -> Image -> Image

250translateY :: Int -> Image -> Image

267translateY y i

251translateY y i

268− | y < 0 && (abs y > imageHeight i) = emptyImage

269 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)

252 | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)

270 | y == 0 = i

253 | y == 0 = i

271 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)

254 | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)

src/Graphics/Vty/Image/Internal.hs+32−16

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE NamedFieldPuns #-}

1{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

4{-# OPTIONS_HADDOCK hide #-}

3{-# OPTIONS_HADDOCK hide #-}

@@ -12,9 +11,6 @@ import GHC.Generics

13import Control.DeepSeq

12import Control.DeepSeq

15−#if !(MIN_VERSION_base(4,11,0))

16−import Data.Semigroup (Semigroup(..))

17−#endif

18import qualified Data.Text.Lazy as TL

14import qualified Data.Text.Lazy as TL

20-- | A display text is a Data.Text.Lazy

16-- | A display text is a Data.Text.Lazy

@@ -142,11 +138,37 @@ data Image =

142 --

138 --

143 -- Any image of zero size equals the empty image.

139 -- Any image of zero size equals the empty image.

144 | EmptyImage

140 | EmptyImage

145− deriving (Eq, Generic, Show, Read)

141+ deriving (Eq, Generic)

142+

143+instance Show Image where

144+ show ( HorizText { attr, displayText, outputWidth, charWidth } )

145+ = "HorizText " ++ show displayText

146+ ++ "@(" ++ show attr ++ ","

147+ ++ show outputWidth ++ ","

148+ ++ show charWidth ++ ")"

149+ show ( BGFill { outputWidth, outputHeight } )

150+ = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"

151+ show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )

152+ = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"

153+ show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )

154+ = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"

155+ show ( CropRight { croppedImage, outputWidth, outputHeight } )

156+ = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

157+ ++ " (" ++ show croppedImage ++ ")"

158+ show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )

159+ = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

160+ ++ " (" ++ show croppedImage ++ ")"

161+ show ( CropBottom { croppedImage, outputWidth, outputHeight } )

162+ = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

163+ ++ " (" ++ show croppedImage ++ ")"

164+ show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )

165+ = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

166+ ++ " (" ++ show croppedImage ++ ")"

167+ show ( EmptyImage ) = "EmptyImage"

146

168

147-- | pretty print just the structure of an image.

169-- | pretty print just the structure of an image.

148ppImageStructure :: Image -> String

170ppImageStructure :: Image -> String

149−ppImageStructure = go 0

171+ppImageStructure inImg = go 0 inImg

150 where

172 where

151 go indent img = tab indent ++ pp indent img

173 go indent img = tab indent ++ pp indent img

152 tab indent = concat $ replicate indent " "

174 tab indent = concat $ replicate indent " "

@@ -210,16 +232,10 @@ imageHeight CropBottom { outputHeight = h } = h

210imageHeight CropTop { outputHeight = h } = h

232imageHeight CropTop { outputHeight = h } = h

211imageHeight EmptyImage = 0

233imageHeight EmptyImage = 0

212

234

213−-- | Append in the 'Semigroup' instance is equivalent to '<->'.

214−instance Semigroup Image where

215− (<>) = vertJoin

216−

217−-- | Append in the 'Monoid' instance is equivalent to '<->'.

235+-- | Append in the Monoid instance is equivalent to <->.

218instance Monoid Image where

236instance Monoid Image where

219 mempty = EmptyImage

237 mempty = EmptyImage

220−#if !(MIN_VERSION_base(4,11,0))

221− mappend = (<>)

238+ mappend = vertJoin

222−#endif

223

239

224-- | combines two images side by side

240-- | combines two images side by side

225--

241--

@@ -228,7 +244,7 @@ instance Monoid Image where

228--

244--

229-- The result image will have a width equal to the sum of the two images

245-- The result image will have a width equal to the sum of the two images

230-- width. And the height will equal the largest height of the two

246-- width. And the height will equal the largest height of the two

231−-- images. The area not defined in one image due to a height mismatch

247+-- images. The area not defined in one image due to a height missmatch

232-- will be filled with the background pattern.

248-- will be filled with the background pattern.

233horizJoin :: Image -> Image -> Image

249horizJoin :: Image -> Image -> Image

234horizJoin EmptyImage i = i

250horizJoin EmptyImage i = i

@@ -259,7 +275,7 @@ horizJoin _ _ = error "horizJoin applied to undefined values."

259--

275--

260-- The result image will have a height equal to the sum of the heights

276-- The result image will have a height equal to the sum of the heights

261-- of both images. The width will equal the largest width of the two

277-- of both images. The width will equal the largest width of the two

262−-- images. The area not defined in one image due to a width mismatch

278+-- images. The area not defined in one image due to a width missmatch

263-- will be filled with the background pattern.

279-- will be filled with the background pattern.

264vertJoin :: Image -> Image -> Image

280vertJoin :: Image -> Image -> Image

265vertJoin EmptyImage i = i

281vertJoin EmptyImage i = i

src/Graphics/Vty/Inline.hs+17−28

@@ -1,3 +1,5 @@

1+{-# LANGUAGE BangPatterns #-}

1-- | The inline module provides a limited interface to changing the

3-- | The inline module provides a limited interface to changing the

2-- style of terminal output. The intention is for this interface to be

4-- style of terminal output. The intention is for this interface to be

3-- used inline with other output systems.

5-- used inline with other output systems.

@@ -46,33 +48,22 @@ import Data.IORef

47import System.IO

49import System.IO

49−type InlineM v = State InlineState v

51+type InlineM v = State Attr v

50−

51−data InlineState =

52− InlineState { inlineAttr :: Attr

53− , inlineUrlsEnabled :: Bool

54− }

56-- | Set the background color to the provided 'Color'.

53-- | Set the background color to the provided 'Color'.

57backColor :: Color -> InlineM ()

54backColor :: Color -> InlineM ()

58−backColor c = modify $ \s ->

55+backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )

59− s { inlineAttr = inlineAttr s `withBackColor` c

60− }

62-- | Set the foreground color to the provided 'Color'.

57-- | Set the foreground color to the provided 'Color'.

63foreColor :: Color -> InlineM ()

58foreColor :: Color -> InlineM ()

64−foreColor c = modify $ \s ->

59+foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )

65− s { inlineAttr = inlineAttr s `withForeColor` c

66− }

68-- | Attempt to change the 'Style' of the following text..

61-- | Attempt to change the 'Style' of the following text..

69--

62--

70-- If the terminal does not support the style change then no error is

63-- If the terminal does not support the style change then no error is

71-- produced. The style can still be removed.

64-- produced. The style can still be removed.

72applyStyle :: Style -> InlineM ()

65applyStyle :: Style -> InlineM ()

73−applyStyle st = modify $ \s ->

66+applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )

74− s { inlineAttr = inlineAttr s `withStyle` st

75− }

77-- | Attempt to remove the specified 'Style' from the display of the

68-- | Attempt to remove the specified 'Style' from the display of the

78-- following text.

69-- following text.

@@ -80,18 +71,16 @@ applyStyle st = modify $ \s ->

80-- This will fail if 'applyStyle' for the given style has not been

71-- This will fail if 'applyStyle' for the given style has not been

81-- previously called.

72-- previously called.

82removeStyle :: Style -> InlineM ()

73removeStyle :: Style -> InlineM ()

83−removeStyle sMask = modify $ \s ->

74+removeStyle sMask = modify $ \attr ->

84− s { inlineAttr =

85− let style' = case attrStyle (inlineAttr s) of

75+ let style' = case attrStyle attr of

86− Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

76+ Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

87− KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

77+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

88− SetTo st -> st .&. complement sMask

78+ SetTo s -> s .&. complement sMask

89− in (inlineAttr s) { attrStyle = SetTo style' }

79+ in attr { attrStyle = SetTo style' }

90− }

92-- | Reset the display attributes.

81-- | Reset the display attributes.

93defaultAll :: InlineM ()

82defaultAll :: InlineM ()

94−defaultAll = modify $ \s -> s { inlineAttr = defAttr }

83+defaultAll = put defAttr

96-- | Apply the provided display attribute changes to the given terminal

85-- | Apply the provided display attribute changes to the given terminal

97-- output device.

86-- output device.

@@ -104,14 +93,14 @@ putAttrChange out c = liftIO $ do

104 mfattr <- prevFattr <$> readIORef (assumedStateRef out)

93 mfattr <- prevFattr <$> readIORef (assumedStateRef out)

105 fattr <- case mfattr of

94 fattr <- case mfattr of

106 Nothing -> do

95 Nothing -> do

107− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False

96+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc

108− return $ FixedAttr defaultStyleMask Nothing Nothing Nothing

97+ return $ FixedAttr defaultStyleMask Nothing Nothing

109 Just v -> return v

98 Just v -> return v

110− let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)

99+ let attr = execState c currentAttr

111 attr' = limitAttrForDisplay out attr

100 attr' = limitAttrForDisplay out attr

112 fattr' = fixDisplayAttr fattr attr'

101 fattr' = fixDisplayAttr fattr attr'

113 diffs = displayAttrDiffs fattr fattr'

102 diffs = displayAttrDiffs fattr fattr'

114− outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs

103+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs

115 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }

104 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }

116 inlineHack dc

105 inlineHack dc

117

106

src/Graphics/Vty/Input.hs+23−14

@@ -1,4 +1,4 @@

1−{-# LANGUAGE RecordWildCards, CPP #-}

1+{-# LANGUAGE RecordWildCards #-}

3-- | This module provides the input layer for Vty, including methods

4-- for initializing an 'Input' structure and reading 'Event's from the

@@ -77,7 +77,7 @@

77-- The input encoding determines how UTF-8 encoded characters are

78-- recognized.

79--

80−-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is

80+-- * 7-bit mode: UTF-8 can be input unambiguiously. UTF-8 input is

81-- a superset of ASCII. UTF-8 does not overlap escaped control key

82-- sequences. However, the escape key must be differentiated from

83-- escaped control key sequences by the timing of the input bytes.

@@ -95,7 +95,7 @@

95--

96-- == Terminal Input is Broken

97--

98−-- Clearly terminal input has fundamental issues. There is no easy way

98+-- Clearly terminal input has fundemental issues. There is no easy way

99-- to reliably resolve these issues.

100--

101-- One resolution would be to ditch standard terminal interfaces

@@ -132,9 +132,7 @@ import Lens.Micro

132import qualified System.Console.Terminfo as Terminfo

133import System.Posix.Signals.Exts

134

135−#if !MIN_VERSION_base(4,11,0)

136import Data.Monoid ((<>))

135import Data.Monoid ((<>))

137−#endif

138

136

139-- | Set up the terminal with file descriptor `inputFd` for input.

137-- | Set up the terminal with file descriptor `inputFd` for input.

140-- Returns an 'Input'.

138-- Returns an 'Input'.

@@ -143,8 +141,22 @@ import Data.Monoid ((<>))

143-- bytes comes from 'classifyMapForTerm' which is then overridden by

141-- bytes comes from 'classifyMapForTerm' which is then overridden by

144-- the the applicable entries from the configuration's 'inputMap'.

142-- the the applicable entries from the configuration's 'inputMap'.

145--

143--

146−-- The terminal device's mode flags are configured by the

144+-- The terminal device is configured with the attributes:

147−-- 'attributeControl' function.

145+--

146+-- * IXON disabled: disables software flow control on outgoing data.

147+-- This stops the process from being suspended if the output terminal

148+-- cannot keep up.

149+--

150+-- * Raw mode is used for input.

151+--

152+-- * ISIG disabled (enables keyboard combinations that result in

153+-- signals)

154+--

155+-- * ECHO disabled (input is not echoed to the output)

156+--

157+-- * ICANON disabled (canonical mode (line mode) input is not used)

158+--

159+-- * IEXTEN disabled (extended functions are disabled)

148inputForConfig :: Config -> IO Input

160inputForConfig :: Config -> IO Input

149inputForConfig config@Config{ termName = Just termName

161inputForConfig config@Config{ termName = Just termName

150 , inputFd = Just termFd

162 , inputFd = Just termFd

@@ -154,23 +166,20 @@ inputForConfig config@Config{ termName = Just termName

154 terminal <- Terminfo.setupTerm termName

166 terminal <- Terminfo.setupTerm termName

155 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]

167 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]

156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

168 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

157− (setAttrs, unsetAttrs) <- attributeControl termFd

169+ (setAttrs,unsetAttrs) <- attributeControl termFd

158 setAttrs

170 setAttrs

159 input <- initInput config activeInputMap

171 input <- initInput config activeInputMap

160 let pokeIO = Catch $ do

172 let pokeIO = Catch $ do

173+ let e = error "vty internal failure: this value should not propagate to users"

161 setAttrs

174 setAttrs

162− atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal

175+ atomically $ writeTChan (input^.eventChannel) (EvResize e e)

163 _ <- installHandler windowChange pokeIO Nothing

176 _ <- installHandler windowChange pokeIO Nothing

164 _ <- installHandler continueProcess pokeIO Nothing

177 _ <- installHandler continueProcess pokeIO Nothing

165−

166− let restore = unsetAttrs

167−

168 return $ input

178 return $ input

169 { shutdownInput = do

179 { shutdownInput = do

170 shutdownInput input

180 shutdownInput input

171 _ <- installHandler windowChange Ignore Nothing

181 _ <- installHandler windowChange Ignore Nothing

172 _ <- installHandler continueProcess Ignore Nothing

182 _ <- installHandler continueProcess Ignore Nothing

173− restore

183+ unsetAttrs

174− , restoreInputState = restoreInputState input >> restore

175 }

184 }

176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig

185inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig

src/Graphics/Vty/Input/Classify.hs+28−54

@@ -1,55 +1,39 @@

1{-# OPTIONS_HADDOCK hide #-}

2−-- This makes a kind of trie. Has space efficiency issues with large

2+-- This makes a kind of tri. Has space efficiency issues with large

3-- input blocks. Likely building a parser and just applying that would

4-- be better.

5module Graphics.Vty.Input.Classify

6 ( classify

7 , KClass(..)

8− , ClassifierState(..)

9 )

8 )

10where

9where

12import Graphics.Vty.Input.Events

11import Graphics.Vty.Input.Events

13import Graphics.Vty.Input.Mouse

12import Graphics.Vty.Input.Mouse

14−import Graphics.Vty.Input.Focus

15import Graphics.Vty.Input.Paste

13import Graphics.Vty.Input.Paste

16import Graphics.Vty.Input.Classify.Types

14import Graphics.Vty.Input.Classify.Types

18import Codec.Binary.UTF8.Generic (decode)

16import Codec.Binary.UTF8.Generic (decode)

20−import Control.Arrow (first)

18+import Data.List (inits)

21import qualified Data.Map as M( fromList, lookup )

19import qualified Data.Map as M( fromList, lookup )

22import Data.Maybe ( mapMaybe )

20import Data.Maybe ( mapMaybe )

23import qualified Data.Set as S( fromList, member )

21import qualified Data.Set as S( fromList, member )

23+import Data.Char

25import Data.Word

24import Data.Word

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

26+compile :: ClassifyMap -> [Char] -> KClass

43compile table = cl' where

27compile table = cl' where

44 -- take all prefixes and create a set of these

28 -- take all prefixes and create a set of these

45− prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table

29+ prefixSet = S.fromList $ concatMap (init . inits . fst) $ table

46 maxValidInputLength = maximum (map (length . fst) table)

30 maxValidInputLength = maximum (map (length . fst) table)

47− eventForInput = M.fromList $ map (first BS8.pack) table

31+ eventForInput = M.fromList table

48− cl' inputBlock | BS8.null inputBlock = Prefix

32+ cl' [] = Prefix

49 cl' inputBlock = case M.lookup inputBlock eventForInput of

33 cl' inputBlock = case M.lookup inputBlock eventForInput of

50 -- if the inputBlock is exactly what is expected for an

34 -- if the inputBlock is exactly what is expected for an

51 -- event then consume the whole block and return the event

35 -- event then consume the whole block and return the event

52− Just e -> Valid e BS8.empty

36+ Just e -> Valid e []

53 Nothing -> case S.member inputBlock prefixSet of

37 Nothing -> case S.member inputBlock prefixSet of

54 True -> Prefix

38 True -> Prefix

55 -- look up progressively smaller tails of the input

39 -- look up progressively smaller tails of the input

@@ -60,49 +44,39 @@ compile table = cl' where

60 -- H: There will always be one match. The prefixSet

44 -- H: There will always be one match. The prefixSet

61 -- contains, by definition, all prefixes of an event.

45 -- contains, by definition, all prefixes of an event.

62 False ->

46 False ->

63− let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock

47+ let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock

64 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of

48 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of

65− (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)

49+ (s,e) : _ -> Valid e (drop (length s) inputBlock)

66 -- neither a prefix or a full event.

50 -- neither a prefix or a full event.

67 [] -> Invalid

51 [] -> Invalid

69−classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass

53+classify :: ClassifyMap -> [Char] -> KClass

70−classify table = process

54+classify table =

71− where

72− standardClassifier = compile table

55+ let standardClassifier = compile table

73−

74− process ClassifierStart s =

75− case BS.uncons s of

56+ in \s -> case s of

76− _ | bracketedPasteStarted s ->

57+ _ | bracketedPasteStarted s ->

77− if bracketedPasteFinished s

78− then parseBracketedPaste s

79− else Chunk

80− _ | isMouseEvent s -> classifyMouseEvent s

81− _ | isFocusEvent s -> classifyFocusEvent s

82− Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs

83− _ -> standardClassifier s

84−

85− process (ClassifierInChunk p ps) s | bracketedPasteStarted p =

86 if bracketedPasteFinished s

58 if bracketedPasteFinished s

87− then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)

59+ then parseBracketedPaste s

88− else Chunk

60+ else Prefix

89− process ClassifierInChunk{} _ = Invalid

61+ _ | isMouseEvent s -> classifyMouseEvent s

62+ c:cs | ord c >= 0xC2 -> classifyUtf8 c cs

63+ _ -> standardClassifier s

91−classifyUtf8 :: Word8 -> ByteString -> KClass

65+classifyUtf8 :: Char -> [Char] -> KClass

92classifyUtf8 c cs =

66classifyUtf8 c cs =

93− let n = utf8Length c

67+ let n = utf8Length (ord c)

94− (codepoint,rest) = BS8.splitAt (n - 1) cs

68+ (codepoint,rest) = splitAt n (c:cs)

96 codepoint8 :: [Word8]

70 codepoint8 :: [Word8]

97− codepoint8 = c:BS.unpack codepoint

71+ codepoint8 = map (fromIntegral . ord) codepoint

99 in case decode codepoint8 of

73 in case decode codepoint8 of

100− _ | n < BS.length codepoint + 1 -> Prefix

74+ _ | n < length codepoint -> Prefix

101− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest

75+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest

102 -- something bad happened; just ignore and continue.

76 -- something bad happened; just ignore and continue.

103− Nothing -> Invalid

77+ Nothing -> Invalid

104

105−utf8Length :: Word8 -> Int

79+utf8Length :: (Num t, Ord a, Num a) => a -> t

106utf8Length c

80utf8Length c

107 | c < 0x80 = 1

81 | c < 0x80 = 1

108 | c < 0xE0 = 2

82 | c < 0xE0 = 2

src/Graphics/Vty/Input/Classify/Parse.hs+7−10

@@ -16,15 +16,12 @@ import Graphics.Vty.Input.Classify.Types

16import Control.Monad.Trans.Maybe

17import Control.Monad.State

19−import qualified Data.ByteString.Char8 as BS8

20−import Data.ByteString.Char8 (ByteString)

21−

22−type Parser a = MaybeT (State ByteString) a

19+type Parser a = MaybeT (State String) a

24-- | Run a parser on a given input string. If the parser fails, return

21-- | Run a parser on a given input string. If the parser fails, return

25-- 'Invalid'. Otherwise return the valid event ('Valid') and the

22-- 'Invalid'. Otherwise return the valid event ('Valid') and the

26-- remaining unparsed characters.

23-- remaining unparsed characters.

27−runParser :: ByteString -> Parser Event -> KClass

24+runParser :: String -> Parser Event -> KClass

28runParser s parser =

25runParser s parser =

29 case runState (runMaybeT parser) s of

26 case runState (runMaybeT parser) s of

30 (Nothing, _) -> Invalid

27 (Nothing, _) -> Invalid

@@ -39,9 +36,9 @@ failParse = fail "invalid parse"

39-- return '123' and consume those characters.

36-- return '123' and consume those characters.

40readInt :: Parser Int

37readInt :: Parser Int

41readInt = do

38readInt = do

42− s <- BS8.unpack <$> get

39+ s <- get

43 case (reads :: ReadS Int) s of

40 case (reads :: ReadS Int) s of

44− [(i, rest)] -> put (BS8.pack rest) >> return i

41+ [(i, rest)] -> put rest >> return i

45 _ -> failParse

42 _ -> failParse

47-- | Read a character from the input stream. If one cannot be read (e.g.

44-- | Read a character from the input stream. If one cannot be read (e.g.

@@ -49,9 +46,9 @@ readInt = do

49readChar :: Parser Char

46readChar :: Parser Char

50readChar = do

47readChar = do

51 s <- get

48 s <- get

52− case BS8.uncons s of

49+ case s of

53− Just (c,rest) -> put rest >> return c

50+ c:rest -> put rest >> return c

54− Nothing -> failParse

51+ _ -> failParse

56-- | Read a character from the input stream and fail parsing if it is

53-- | Read a character from the input stream and fail parsing if it is

57-- not the specified character.

54-- not the specified character.

src/Graphics/Vty/Input/Classify/Types.hs+1−7

@@ -1,6 +1,5 @@

1-- | This module exports the input classification type to avoid import

2-- cycles between other modules that need this.

3−{-# LANGUAGE StrictData #-}

4module Graphics.Vty.Input.Classify.Types

3module Graphics.Vty.Input.Classify.Types

5 ( KClass(..)

4 ( KClass(..)

6 )

5 )

@@ -8,10 +7,8 @@ where

9import Graphics.Vty.Input.Events

8import Graphics.Vty.Input.Events

11−import Data.ByteString.Char8 (ByteString)

12−

13data KClass

10data KClass

14− = Valid Event ByteString

11+ = Valid Event [Char]

15 -- ^ A valid event was parsed. Any unused characters from the input

12 -- ^ A valid event was parsed. Any unused characters from the input

16 -- stream are also provided.

13 -- stream are also provided.

17 | Invalid

14 | Invalid

@@ -19,7 +16,4 @@ data KClass

19 | Prefix

16 | Prefix

20 -- ^ The input characters form the prefix of a valid event character

17 -- ^ The input characters form the prefix of a valid event character

21 -- sequence.

18 -- sequence.

22− | Chunk

23− -- ^ The input characters are either start of a bracketed paste chunk

24− -- or in the middle of a bracketed paste chunk.

25 deriving(Show, Eq)

19 deriving(Show, Eq)

src/Graphics/Vty/Input/Events.hs+7−29

@@ -1,8 +1,6 @@

1{-# Language DeriveGeneric #-}

2−{-# Language StrictData #-}

3module Graphics.Vty.Input.Events where

2module Graphics.Vty.Input.Events where

5−import Control.DeepSeq

6import Data.ByteString

4import Data.ByteString

7import GHC.Generics

5import GHC.Generics

@@ -16,29 +14,23 @@ import GHC.Generics

16--

14--

17-- * Actually, support for most of these but KEsc, KChar, KBS, and

15-- * Actually, support for most of these but KEsc, KChar, KBS, and

18-- KEnter vary by terminal and keyboard.

16-- KEnter vary by terminal and keyboard.

19−data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter

17+data Key = KEsc | KChar Char | KBS | KEnter

20 | KLeft | KRight | KUp | KDown

18 | KLeft | KRight | KUp | KDown

22− | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns

24 deriving (Eq,Show,Read,Ord,Generic)

22 deriving (Eq,Show,Read,Ord,Generic)

26−instance NFData Key

27−

28-- | Modifier keys. Key codes are interpreted such that users are more

24-- | Modifier keys. Key codes are interpreted such that users are more

29-- likely to have Meta than Alt; for instance on the PC Linux console,

25-- likely to have Meta than Alt; for instance on the PC Linux console,

30-- 'MMeta' will generally correspond to the physical Alt key.

26-- 'MMeta' will generally correspond to the physical Alt key.

31data Modifier = MShift | MCtrl | MMeta | MAlt

27data Modifier = MShift | MCtrl | MMeta | MAlt

32 deriving (Eq,Show,Read,Ord,Generic)

28 deriving (Eq,Show,Read,Ord,Generic)

34−instance NFData Modifier

35−

36-- | Mouse buttons.

30-- | Mouse buttons.

37−data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown

31+data Button = BLeft | BMiddle | BRight

38 deriving (Eq,Show,Read,Ord,Generic)

32 deriving (Eq,Show,Read,Ord,Generic)

40−instance NFData Button

41−

42-- | Events.

34-- | Events.

43data Event

35data Event

44 = EvKey Key [Modifier]

36 = EvKey Key [Modifier]

@@ -52,8 +44,10 @@ data Event

52 -- without specifying which one; in that case, Nothing is provided.

44 -- without specifying which one; in that case, Nothing is provided.

53 -- Otherwise Just the button released is included in the event.

45 -- Otherwise Just the button released is included in the event.

54 | EvResize Int Int

46 | EvResize Int Int

55− -- The terminal window was resized and the size is provided in the

47+ -- ^ If read from 'eventChannel' this is the size at the time of the

56− -- integer fields (width, height).

48+ -- signal. If read from 'nextEvent' this is the size at the time the

49+ -- event was processed by Vty. Typically these are the same, but if

50+ -- somebody is resizing the terminal quickly they can be different.

57 | EvPaste ByteString

51 | EvPaste ByteString

58 -- ^ A paste event occurs when a bracketed paste input sequence is

52 -- ^ A paste event occurs when a bracketed paste input sequence is

59 -- received. For terminals that support bracketed paste mode, these

53 -- received. For terminals that support bracketed paste mode, these

@@ -62,22 +56,6 @@ data Event

62 -- input (which is probably bad, so beware!) Note that the data is

56 -- input (which is probably bad, so beware!) Note that the data is

63 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if

57 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if

64 -- that's what your application expects.

58 -- that's what your application expects.

65− | EvLostFocus

66− -- ^ The terminal running the application lost input focus.

67− | EvGainedFocus

68− -- ^ The terminal running the application gained input focus.

69 deriving (Eq,Show,Read,Ord,Generic)

59 deriving (Eq,Show,Read,Ord,Generic)

71−instance NFData Event

72−

73type ClassifyMap = [(String,Event)]

61type ClassifyMap = [(String,Event)]

74−

75−-- | The type of internal events that drive the internal Vty event

76−-- dispatching to the application.

77−data InternalEvent =

78− ResumeAfterSignal

79− -- ^ Vty resumed operation after the process was interrupted with a

80− -- signal. In practice this translates into a screen redraw in the

81− -- input event loop.

82− | InputEvent Event

83− -- ^ An input event was received.

src/Graphics/Vty/Input/Focus.hsdeleted−49

@@ -1,49 +0,0 @@

1−module Graphics.Vty.Input.Focus

2− ( requestFocusEvents

3− , disableFocusEvents

4− , isFocusEvent

5− , classifyFocusEvent

6− )

7−where

8−

9−import Graphics.Vty.Input.Events

10−import Graphics.Vty.Input.Classify.Types

11−import Graphics.Vty.Input.Classify.Parse

12−

13−import Control.Monad.State

14−

15−import qualified Data.ByteString.Char8 as BS8

16−import Data.ByteString.Char8 (ByteString)

17−

18−-- | These sequences set xterm-based terminals to send focus event

19−-- sequences.

20−requestFocusEvents :: ByteString

21−requestFocusEvents = BS8.pack "\ESC[?1004h"

22−

23−-- | These sequences disable focus events.

24−disableFocusEvents :: ByteString

25−disableFocusEvents = BS8.pack "\ESC[?1004l"

26−

27−-- | Does the specified string begin with a focus event?

28−isFocusEvent :: ByteString -> Bool

29−isFocusEvent s = BS8.isPrefixOf focusIn s ||

30− BS8.isPrefixOf focusOut s

31−

32−focusIn :: ByteString

33−focusIn = BS8.pack "\ESC[I"

34−

35−focusOut :: ByteString

36−focusOut = BS8.pack "\ESC[O"

37−

38−-- | Attempt to classify an input string as a focus event.

39−classifyFocusEvent :: ByteString -> KClass

40−classifyFocusEvent s = runParser s $ do

41− when (not $ isFocusEvent s) failParse

42−

43− expectChar '\ESC'

44− expectChar '['

45− ty <- readChar

46− case ty of

47− 'I' -> return EvGainedFocus

48− 'O' -> return EvLostFocus

49− _ -> failParse

src/Graphics/Vty/Input/Loop.hs+30−87

@@ -1,9 +1,8 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TemplateHaskell #-}

6{-# OPTIONS_HADDOCK hide #-}

2{-# OPTIONS_HADDOCK hide #-}

3+{-# LANGUAGE NoMonomorphismRestriction #-}

4+{-# LANGUAGE TemplateHaskell #-}

5+{-# LANGUAGE CPP #-}

7-- | The input layer used to be a single function that correctly

6-- | The input layer used to be a single function that correctly

8-- accounted for the non-threaded runtime by emulating the terminal

7-- accounted for the non-threaded runtime by emulating the terminal

9-- VMIN adn VTIME handling. This has been removed and replace with a

8-- VMIN adn VTIME handling. This has been removed and replace with a

@@ -25,7 +24,7 @@ import Control.Applicative

25import Control.Concurrent

24import Control.Concurrent

26import Control.Concurrent.STM

25import Control.Concurrent.STM

27import Control.Exception (mask, try, SomeException)

26import Control.Exception (mask, try, SomeException)

28−import Lens.Micro hiding ((<>~))

27+import Lens.Micro

29import Lens.Micro.Mtl

28import Lens.Micro.Mtl

30import Lens.Micro.TH

29import Lens.Micro.TH

31import Control.Monad (when, mzero, forM_)

30import Control.Monad (when, mzero, forM_)

@@ -34,15 +33,12 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)

34import Control.Monad.State.Class (MonadState, modify)

33import Control.Monad.State.Class (MonadState, modify)

35import Control.Monad.Trans.Reader (ReaderT(..))

34import Control.Monad.Trans.Reader (ReaderT(..))

37−import qualified Data.ByteString.Char8 as BS8

36+import Data.Char

38−import qualified Data.ByteString as BS

39−import Data.ByteString.Char8 (ByteString)

40import Data.IORef

37import Data.IORef

41import Data.Word (Word8)

38import Data.Word (Word8)

43−import Foreign (allocaArray)

40+import Foreign ( allocaArray, peekArray, Ptr )

44import Foreign.C.Types (CInt(..))

41import Foreign.C.Types (CInt(..))

45−import Foreign.Ptr (Ptr, castPtr)

47import System.IO

43import System.IO

48import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))

44import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))

@@ -55,15 +51,10 @@ data Input = Input

55 { -- | Channel of events direct from input processing. Unlike

51 { -- | Channel of events direct from input processing. Unlike

56 -- 'nextEvent' this will not refresh the display if the next event

52 -- 'nextEvent' this will not refresh the display if the next event

57 -- is an 'EvResize'.

53 -- is an 'EvResize'.

58− _eventChannel :: TChan InternalEvent

54+ _eventChannel :: TChan Event

59− -- | Shuts down the input processing. As part of shutting down the

55+ -- | Shuts down the input processing. This should return the

60− -- input, this should also restore the input state.

56+ -- terminal input state to before he input initialized.

61 , shutdownInput :: IO ()

57 , shutdownInput :: IO ()

62− -- | Restore the terminal's input state to what it was prior

63− -- to configuring input for Vty. This should be done as part of

64− -- 'shutdownInput' but is exposed in case you need to access it

65− -- directly.

66− , restoreInputState :: IO ()

67 -- | Changes to this value are reflected after the next event.

58 -- | Changes to this value are reflected after the next event.

68 , _configRef :: IORef Config

59 , _configRef :: IORef Config

69 -- | input debug log

60 -- | input debug log

@@ -80,11 +71,10 @@ data InputBuffer = InputBuffer

80makeLenses ''InputBuffer

71makeLenses ''InputBuffer

82data InputState = InputState

73data InputState = InputState

83− { _unprocessedBytes :: ByteString

74+ { _unprocessedBytes :: String

84− , _classifierState :: ClassifierState

85 , _appliedConfig :: Config

75 , _appliedConfig :: Config

86 , _inputBuffer :: InputBuffer

76 , _inputBuffer :: InputBuffer

87− , _classifier :: ClassifierState -> ByteString -> KClass

77+ , _classifier :: String -> KClass

88 }

78 }

90makeLenses ''InputState

80makeLenses ''InputState

@@ -109,20 +99,20 @@ loopInputProcessor = do

109 dropInvalid

99 dropInvalid

110 loopInputProcessor

100 loopInputProcessor

111

101

112−addBytesToProcess :: ByteString -> InputM ()

102+addBytesToProcess :: String -> InputM ()

113addBytesToProcess block = unprocessedBytes <>= block

103addBytesToProcess block = unprocessedBytes <>= block

114

104

115emit :: Event -> InputM ()

105emit :: Event -> InputM ()

116emit event = do

106emit event = do

117 logMsg $ "parsed event: " ++ show event

107 logMsg $ "parsed event: " ++ show event

118− view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)

108+ view eventChannel >>= liftIO . atomically . flip writeTChan event

119

109

120-- The timing requirements are assured by the VMIN and VTIME set for the

110-- The timing requirements are assured by the VMIN and VTIME set for the

121-- device.

111-- device.

122--

112--

123-- Precondition: Under the threaded runtime. Only current use is from a

113-- Precondition: Under the threaded runtime. Only current use is from a

124-- forkOS thread. That case satisfies precondition.

114-- forkOS thread. That case satisfies precondition.

125−readFromDevice :: InputM ByteString

115+readFromDevice :: InputM String

126readFromDevice = do

116readFromDevice = do

127 newConfig <- view configRef >>= liftIO . readIORef

117 newConfig <- view configRef >>= liftIO . readIORef

128 oldConfig <- use appliedConfig

118 oldConfig <- use appliedConfig

@@ -142,10 +132,9 @@ readFromDevice = do

142 threadWaitRead fd

132 threadWaitRead fd

143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

133 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

144 if bytesRead > 0

134 if bytesRead > 0

145− then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)

135+ then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr

146− else return BS.empty

136+ else return []

147− when (not $ BS.null stringRep) $

148− logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)

137+ when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep

149 return stringRep

138 return stringRep

150

139

151applyConfig :: Fd -> Config -> IO ()

140applyConfig :: Fd -> Config -> IO ()

@@ -156,86 +145,41 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat

156parseEvent :: InputM Event

145parseEvent :: InputM Event

157parseEvent = do

146parseEvent = do

158 c <- use classifier

147 c <- use classifier

159− s <- use classifierState

160 b <- use unprocessedBytes

148 b <- use unprocessedBytes

161− case c s b of

149+ case c b of

162 Valid e remaining -> do

150 Valid e remaining -> do

163 logMsg $ "valid parse: " ++ show e

151 logMsg $ "valid parse: " ++ show e

164 logMsg $ "remaining: " ++ show remaining

152 logMsg $ "remaining: " ++ show remaining

165− classifierState .= ClassifierStart

166 unprocessedBytes .= remaining

153 unprocessedBytes .= remaining

167 return e

154 return e

168− _ -> mzero

155+ _ -> mzero

169

156

170dropInvalid :: InputM ()

157dropInvalid :: InputM ()

171dropInvalid = do

158dropInvalid = do

172 c <- use classifier

159 c <- use classifier

173− s <- use classifierState

174 b <- use unprocessedBytes

160 b <- use unprocessedBytes

175− case c s b of

176− Chunk -> do

177− classifierState .=

178− case s of

179− ClassifierStart -> ClassifierInChunk b []

180− ClassifierInChunk p bs -> ClassifierInChunk p (b:bs)

181− unprocessedBytes .= BS8.empty

182− Invalid -> do

161+ when (c b == Invalid) $ do

183− logMsg "dropping input bytes"

162+ logMsg "dropping input bytes"

184− classifierState .= ClassifierStart

185− unprocessedBytes .= BS8.empty

163+ unprocessedBytes .= []

186− _ -> return ()

187

164

188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()

165runInputProcessorLoop :: ClassifyMap -> Input -> IO ()

189runInputProcessorLoop classifyTable input = do

166runInputProcessorLoop classifyTable input = do

190 let bufferSize = 1024

167 let bufferSize = 1024

191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

168 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

192− s0 <- InputState BS8.empty ClassifierStart

193− <$> readIORef (_configRef input)

169+ s0 <- InputState [] <$> readIORef (_configRef input)

194− <*> pure (InputBuffer bufferPtr bufferSize)

170+ <*> pure (InputBuffer bufferPtr bufferSize)

195− <*> pure (classify classifyTable)

171+ <*> pure (classify classifyTable)

196 runReaderT (evalStateT loopInputProcessor s0) input

172 runReaderT (evalStateT loopInputProcessor s0) input

197

173

198−-- | Construct two IO actions: one to configure the terminal for Vty and

199−-- one to restore the terminal mode flags to the values they had at the

200−-- time this function was called.

201−--

202−-- This function constructs a configuration action to clear the

203−-- following terminal mode flags:

204−--

205−-- * IXON disabled: disables software flow control on outgoing data.

206−-- This stops the process from being suspended if the output terminal

207−-- cannot keep up.

208−--

209−-- * Raw mode is used for input.

210−--

211−-- * ISIG (enables keyboard combinations that result in

212−-- signals)

213−--

214−-- * ECHO (input is not echoed to the output)

215−--

216−-- * ICANON (canonical mode (line mode) input is not used)

217−--

218−-- * IEXTEN (extended functions are disabled)

219−--

220−-- The configuration action also explicitly sets these flags:

221−--

222−-- * ICRNL (input carriage returns are mapped to newlines)

223attributeControl :: Fd -> IO (IO (), IO ())

174attributeControl :: Fd -> IO (IO (), IO ())

224attributeControl fd = do

175attributeControl fd = do

225 original <- getTerminalAttributes fd

176 original <- getTerminalAttributes fd

226− let vtyMode = foldl withMode clearedFlags flagsToSet

227− clearedFlags = foldl withoutMode original flagsToUnset

228− flagsToSet = [ MapCRtoLF -- ICRNL

229− ]

230− flagsToUnset = [ StartStopOutput -- IXON

231− , KeyboardInterrupts -- ISIG

177+ let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts

232− , EnableEcho -- ECHO

233− , ProcessInput -- ICANON

234− , ExtendedFunctions -- IEXTEN

178+ , EnableEcho, ProcessInput, ExtendedFunctions

235− ]

179+ ]

236 let setAttrs = setTerminalAttributes fd vtyMode Immediately

180 let setAttrs = setTerminalAttributes fd vtyMode Immediately

237 unsetAttrs = setTerminalAttributes fd original Immediately

181 unsetAttrs = setTerminalAttributes fd original Immediately

238− return (setAttrs, unsetAttrs)

182+ return (setAttrs,unsetAttrs)

239

183

240logInitialInputState :: Input -> ClassifyMap -> IO()

184logInitialInputState :: Input -> ClassifyMap -> IO()

241logInitialInputState input classifyTable = case _inputDebug input of

185logInitialInputState input classifyTable = case _inputDebug input of

@@ -243,7 +187,7 @@ logInitialInputState input classifyTable = case _inputDebug input of

243 Just h -> do

187 Just h -> do

244 Config{ vmin = Just theVmin

188 Config{ vmin = Just theVmin

245 , vtime = Just theVtime

189 , vtime = Just theVtime

246− , termName = Just theTerm } <- readIORef $ _configRef input

190+ , termName = Just theTerm, .. } <- readIORef $ _configRef input

247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))

191 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))

248 forM_ classifyTable $ \i -> case i of

192 forM_ classifyTable $ \i -> case i of

249 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)

193 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)

@@ -259,7 +203,6 @@ initInput config classifyTable = do

259 applyConfig fd config

203 applyConfig fd config

260 stopSync <- newEmptyMVar

204 stopSync <- newEmptyMVar

261 input <- Input <$> atomically newTChan

205 input <- Input <$> atomically newTChan

262− <*> pure (return ())

263 <*> pure (return ())

206 <*> pure (return ())

264 <*> newIORef config

207 <*> newIORef config

265 <*> maybe (return Nothing)

208 <*> maybe (return Nothing)

src/Graphics/Vty/Input/Mouse.hs+18−28

@@ -15,12 +15,10 @@ import Graphics.Vty.Input.Classify.Types

15import Graphics.Vty.Input.Classify.Parse

17import Control.Monad.State

18+import Data.List (isPrefixOf)

18import Data.Maybe (catMaybes)

19import Data.Maybe (catMaybes)

19import Data.Bits ((.&.))

20import Data.Bits ((.&.))

21−import qualified Data.ByteString.Char8 as BS8

22−import Data.ByteString.Char8 (ByteString)

23−

24-- A mouse event in SGR extended mode is

22-- A mouse event in SGR extended mode is

25--

23--

26-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')

24-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')

@@ -34,28 +32,28 @@ import Data.ByteString.Char8 (ByteString)

35-- | These sequences set xterm-based terminals to send mouse event

33-- | These sequences set xterm-based terminals to send mouse event

36-- sequences.

34-- sequences.

37−requestMouseEvents :: ByteString

35+requestMouseEvents :: String

38−requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"

36+requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h\ESC[?1005h"

40-- | These sequences disable mouse events.

38-- | These sequences disable mouse events.

41−disableMouseEvents :: ByteString

39+disableMouseEvents :: String

42−disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"

40+disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l\ESC[?1005l"

44-- | Does the specified string begin with a mouse event?

42-- | Does the specified string begin with a mouse event?

45−isMouseEvent :: ByteString -> Bool

43+isMouseEvent :: String -> Bool

46isMouseEvent s = isSGREvent s || isNormalEvent s

44isMouseEvent s = isSGREvent s || isNormalEvent s

48−isSGREvent :: ByteString -> Bool

46+isSGREvent :: String -> Bool

49−isSGREvent = BS8.isPrefixOf sgrPrefix

47+isSGREvent = isPrefixOf sgrPrefix

51−sgrPrefix :: ByteString

49+sgrPrefix :: String

52−sgrPrefix = BS8.pack "\ESC[M"

50+sgrPrefix = "\ESC[M"

54−isNormalEvent :: ByteString -> Bool

52+isNormalEvent :: String -> Bool

55−isNormalEvent = BS8.isPrefixOf normalPrefix

53+isNormalEvent = isPrefixOf normalPrefix

57−normalPrefix :: ByteString

55+normalPrefix :: String

58−normalPrefix = BS8.pack "\ESC[<"

56+normalPrefix = "\ESC[<"

60-- Modifier bits:

58-- Modifier bits:

61shiftBit :: Int

59shiftBit :: Int

@@ -69,7 +67,7 @@ ctrlBit = 16

70-- These bits indicate the buttons involved:

68-- These bits indicate the buttons involved:

71buttonMask :: Int

69buttonMask :: Int

72−buttonMask = 67

70+buttonMask = 3

74leftButton :: Int

72leftButton :: Int

75leftButton = 0

73leftButton = 0

@@ -80,17 +78,11 @@ middleButton = 1

80rightButton :: Int

78rightButton :: Int

81rightButton = 2

79rightButton = 2

83−scrollUp :: Int

84−scrollUp = 64

85−

86−scrollDown :: Int

87−scrollDown = 65

88−

89hasBitSet :: Int -> Int -> Bool

81hasBitSet :: Int -> Int -> Bool

90hasBitSet val bit = val .&. bit > 0

82hasBitSet val bit = val .&. bit > 0

92−-- | Attempt to classify an input string as a mouse event.

84+-- | Attempt to lassify an input string as a mouse event.

93−classifyMouseEvent :: ByteString -> KClass

85+classifyMouseEvent :: String -> KClass

94classifyMouseEvent s = runParser s $ do

86classifyMouseEvent s = runParser s $ do

95 when (not $ isMouseEvent s) failParse

87 when (not $ isMouseEvent s) failParse

@@ -102,14 +94,12 @@ classifyMouseEvent s = runParser s $ do

102 'M' -> classifyNormalMouseEvent

94 'M' -> classifyNormalMouseEvent

103 _ -> failParse

95 _ -> failParse

104

105−-- Given a modifier/button value, determine which button was indicated

97+-- Given a modifer/button value, determine which button was indicated

106getSGRButton :: Int -> Parser Button

98getSGRButton :: Int -> Parser Button

107getSGRButton mods =

99getSGRButton mods =

108 let buttonMap = [ (leftButton, BLeft)

100 let buttonMap = [ (leftButton, BLeft)

109 , (middleButton, BMiddle)

101 , (middleButton, BMiddle)

110 , (rightButton, BRight)

102 , (rightButton, BRight)

111− , (scrollUp, BScrollUp)

112− , (scrollDown, BScrollDown)

113 ]

103 ]

114 in case lookup (mods .&. buttonMask) buttonMap of

104 in case lookup (mods .&. buttonMask) buttonMap of

115 Nothing -> failParse

105 Nothing -> failParse

src/Graphics/Vty/Input/Paste.hs+24−16

@@ -9,33 +9,41 @@ module Graphics.Vty.Input.Paste

9where

11import qualified Data.ByteString.Char8 as BS8

12−import Data.ByteString.Char8 (ByteString)

14import Graphics.Vty.Input.Events

13import Graphics.Vty.Input.Events

15import Graphics.Vty.Input.Classify.Types

14import Graphics.Vty.Input.Classify.Types

17−bracketedPasteStart :: ByteString

16+import Data.List (isPrefixOf, isInfixOf)

18−bracketedPasteStart = BS8.pack "\ESC[200~"

18+bracketedPasteStart :: String

19+bracketedPasteStart = "\ESC[200~"

20+

20−bracketedPasteEnd :: ByteString

21+bracketedPasteEnd :: String

21−bracketedPasteEnd = BS8.pack "\ESC[201~"

22+bracketedPasteEnd = "\ESC[201~"

23-- | Does the input start a bracketed paste?

24-- | Does the input start a bracketed paste?

24−bracketedPasteStarted :: ByteString -> Bool

25+bracketedPasteStarted :: String -> Bool

25−bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart

26+bracketedPasteStarted = isPrefixOf bracketedPasteStart

27-- | Does the input contain a complete bracketed paste?

28-- | Does the input contain a complete bracketed paste?

28−bracketedPasteFinished :: ByteString -> Bool

29+bracketedPasteFinished :: String -> Bool

29−bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd

30+bracketedPasteFinished = isInfixOf bracketedPasteEnd

31-- | Parse a bracketed paste. This should only be called on a string if

32-- | Parse a bracketed paste. This should only be called on a string if

32-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return

33-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return

33-- 'True'.

34-- 'True'.

34−parseBracketedPaste :: ByteString -> KClass

35+parseBracketedPaste :: String -> KClass

35parseBracketedPaste s =

36parseBracketedPaste s =

37+ let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd

38+ rest' = if bracketedPasteEnd `isPrefixOf` rest

39+ then drop (length bracketedPasteEnd) rest

40+ else rest

36− Valid (EvPaste p) (BS8.drop endLen rest')

41+ in Valid (EvPaste $ BS8.pack p) rest'

37− where

42+

38− startLen = BS8.length bracketedPasteStart

43+takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])

39− endLen = BS8.length bracketedPasteEnd

44+takeUntil [] _ = ([], [])

40− (_, rest ) = BS8.breakSubstring bracketedPasteStart s

45+takeUntil cs sub

41− (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest

46+ | length cs < length sub = (cs, [])

47+ | take (length sub) cs == sub = ([], drop (length sub) cs)

48+ | otherwise = let (pre, suf) = takeUntil (tail cs) sub

49+ in (head cs:pre, suf)

src/Graphics/Vty/Input/Terminfo.hs+4−6

@@ -74,7 +74,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])

74ctrlChars :: ClassifyMap

75ctrlChars =

76 [ ([toEnum x],EvKey (KChar y) [MCtrl])

77− | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])

77+ | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])

78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.

79 , y /= 'h' -- CTRL-h should not hide BS

80 ]

@@ -86,12 +86,10 @@ ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars

86-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.

87specialSupportKeys :: ClassifyMap

88specialSupportKeys =

89− [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])

90− , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])

91− -- special support for ESC

89+ [ -- special support for ESC

92− , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])

90+ ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])

93 -- Special support for backspace

91 -- Special support for backspace

94− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])

92+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])

95 -- Special support for Enter

93 -- Special support for Enter

96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])

94 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])

97 -- explicit support for tab

95 -- explicit support for tab

src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+1−1

@@ -59,7 +59,7 @@ navKeys3 =

59-- This encoding depends on the terminal.

60functionKeys1 :: ClassifyMap

61functionKeys1 =

62− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in

62+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in

63 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]

65-- | encoding for meta plus char

src/Graphics/Vty/Output.hs+14−15

@@ -1,4 +1,5 @@

1−{-# LANGUAGE RecordWildCards, CPP #-}

1+{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE NamedFieldPuns #-}

2-- | This module provides functions for accessing the current terminal

3-- | This module provides functions for accessing the current terminal

3-- or a specific terminal device.

4-- or a specific terminal device.

4--

5--

@@ -37,11 +38,10 @@ import Graphics.Vty.Output.TerminfoBased as TerminfoBased

38import Blaze.ByteString.Builder (writeToByteString)

39import Blaze.ByteString.Builder (writeToByteString)

40−import Data.List (isPrefixOf)

41+import Control.Monad.Trans

42−#if !MIN_VERSION_base(4,11,0)

43+import Data.List (isPrefixOf)

43import Data.Monoid ((<>))

44import Data.Monoid ((<>))

44−#endif

46-- | Returns an `Output` for the terminal specified in `Config`.

47--

@@ -58,12 +58,11 @@ import Data.Monoid ((<>))

58-- * If TERM contains "xterm" or "screen", use XTermColor.

59-- * otherwise use the TerminfoBased driver.

60outputForConfig :: Config -> IO Output

61−outputForConfig Config{ outputFd = Just fd, termName = Just termName

61+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do

62− , colorMode = Just colorMode, .. } = do

63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName

62 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName

64− then XTermColor.reserveTerminal termName fd colorMode

63+ then XTermColor.reserveTerminal termName fd

65 -- Not an xterm-like terminal. try for generic terminfo.

64 -- Not an xterm-like terminal. try for generic terminfo.

66− else TerminfoBased.reserveTerminal termName fd colorMode

65+ else TerminfoBased.reserveTerminal termName fd

68 case mouseMode of

67 case mouseMode of

69 Just s -> setMode t Mouse s

68 Just s -> setMode t Mouse s

@@ -78,30 +77,30 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig

79-- | Sets the cursor position to the given output column and row.

78-- | Sets the cursor position to the given output column and row.

80--

79--

81−-- This is not necessarily the same as the character position with the

80+-- This is not necessarially the same as the character position with the

82-- same coordinates. Characters can be a variable number of columns in

81-- same coordinates. Characters can be a variable number of columns in

83-- width.

82-- width.

84--

83--

85-- Currently, the only way to set the cursor position to a given

84-- Currently, the only way to set the cursor position to a given

86-- character coordinate is to specify the coordinate in the Picture

85-- character coordinate is to specify the coordinate in the Picture

87-- instance provided to 'outputPicture' or 'refresh'.

86-- instance provided to 'outputPicture' or 'refresh'.

88−setCursorPos :: Output -> Int -> Int -> IO ()

87+setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()

89setCursorPos t x y = do

88setCursorPos t x y = do

90 bounds <- displayBounds t

89 bounds <- displayBounds t

91 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do

90 when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do

92 dc <- displayContext t bounds

91 dc <- displayContext t bounds

93− outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y

92+ liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y

95-- | Hides the cursor.

94-- | Hides the cursor.

96−hideCursor :: Output -> IO ()

95+hideCursor :: MonadIO m => Output -> m ()

97hideCursor t = do

96hideCursor t = do

98 bounds <- displayBounds t

97 bounds <- displayBounds t

99 dc <- displayContext t bounds

98 dc <- displayContext t bounds

100− outputByteBuffer t $ writeToByteString $ writeHideCursor dc

99+ liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc

101

100

102-- | Shows the cursor.

101-- | Shows the cursor.

103−showCursor :: Output -> IO ()

102+showCursor :: MonadIO m => Output -> m ()

104showCursor t = do

103showCursor t = do

105 bounds <- displayBounds t

104 bounds <- displayBounds t

106 dc <- displayContext t bounds

105 dc <- displayContext t bounds

107− outputByteBuffer t $ writeToByteString $ writeShowCursor dc

106+ liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc

src/Graphics/Vty/Output/Interface.hs+54−90

@@ -1,9 +1,9 @@

1-- Copyright Corey O'Connor

2+{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7-- | This module provides an abstract interface for performing terminal

8-- output. The only user-facing part of this API is 'Output'.

9module Graphics.Vty.Output.Interface

@@ -29,6 +29,8 @@ import Graphics.Vty.DisplayAttributes

29import Blaze.ByteString.Builder (Write, writeToByteString)

30import Blaze.ByteString.Builder.ByteString (writeByteString)

32+import Control.Monad.Trans

33+

32import qualified Data.ByteString as BS

34import qualified Data.ByteString as BS

33import Data.IORef

35import Data.IORef

34import qualified Data.Text.Encoding as T

36import qualified Data.Text.Encoding as T

@@ -42,15 +44,6 @@ data Mode = Mouse

42 | BracketedPaste

44 | BracketedPaste

43 -- ^ Paste mode (whether the terminal is configured to provide

45 -- ^ Paste mode (whether the terminal is configured to provide

44 -- events on OS pastes)

46 -- 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)

47 deriving (Eq, Read, Show)

56-- | The Vty terminal output interface.

49-- | The Vty terminal output interface.

@@ -59,7 +52,7 @@ data Output = Output

59 terminalID :: String

52 terminalID :: String

60 -- | Release the terminal just prior to application exit and reset

53 -- | Release the terminal just prior to application exit and reset

61 -- it to its state prior to application startup.

54 -- it to its state prior to application startup.

62− , releaseTerminal :: IO ()

55+ , releaseTerminal :: forall m. MonadIO m => m ()

63 -- | Clear the display and initialize the terminal to some initial

56 -- | Clear the display and initialize the terminal to some initial

64 -- display state.

57 -- display state.

65 --

58 --

@@ -69,57 +62,40 @@ data Output = Output

69 -- - cursor at top left

62 -- - cursor at top left

70 -- - UTF-8 character encoding

63 -- - UTF-8 character encoding

71 -- - drawing characteristics are the default

64 -- - drawing characteristics are the default

72− , reserveDisplay :: IO ()

65+ , reserveDisplay :: forall m. MonadIO m => m ()

73 -- | Return the display to the state before `reserveDisplay` If no

66 -- | Return the display to the state before `reserveDisplay` If no

74 -- previous state then set the display state to the initial state.

67 -- previous state then set the display state to the initial state.

75− , releaseDisplay :: IO ()

68+ , releaseDisplay :: forall m. MonadIO m => m ()

76− -- | Sets the current display bounds (width, height).

77− , setDisplayBounds :: (Int, Int) -> IO ()

78 -- | Returns the current display bounds.

69 -- | Returns the current display bounds.

79− , displayBounds :: IO DisplayRegion

70+ , displayBounds :: forall m. MonadIO m => m DisplayRegion

80 -- | Output the bytestring to the terminal device.

71 -- | Output the bytestring to the terminal device.

81 , outputByteBuffer :: BS.ByteString -> IO ()

72 , outputByteBuffer :: BS.ByteString -> IO ()

73+ -- | Specifies the maximum number of colors supported by the

74+ -- context.

75+ , contextColorCount :: Int

82 -- | Specifies whether the cursor can be shown / hidden.

76 -- | Specifies whether the cursor can be shown / hidden.

83 , supportsCursorVisibility :: Bool

77 , supportsCursorVisibility :: Bool

84 -- | Indicates support for terminal modes for this output device.

78 -- | Indicates support for terminal modes for this output device.

85 , supportsMode :: Mode -> Bool

79 , supportsMode :: Mode -> Bool

86 -- | Enables or disables a mode (does nothing if the mode is

80 -- | Enables or disables a mode (does nothing if the mode is

87 -- unsupported).

81 -- unsupported).

88− , setMode :: Mode -> Bool -> IO ()

82+ , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()

89 -- | Returns whether a mode is enabled.

83 -- | Returns whether a mode is enabled.

90− , getModeStatus :: Mode -> IO Bool

84+ , getModeStatus :: forall m. MonadIO m => Mode -> m Bool

91 , assumedStateRef :: IORef AssumedState

85 , assumedStateRef :: IORef AssumedState

92 -- | Acquire display access to the given region of the display.

86 -- | Acquire display access to the given region of the display.

93 -- Currently all regions have the upper left corner of (0,0) and

87 -- Currently all regions have the upper left corner of (0,0) and

94 -- the lower right corner at (max displayWidth providedWidth, max

88 -- the lower right corner at (max displayWidth providedWidth, max

95 -- displayHeight providedHeight)

89 -- displayHeight providedHeight)

96− , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext

90+ , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext

97 -- | Ring the terminal bell if supported.

91 -- | Ring the terminal bell if supported.

98− , ringTerminalBell :: IO ()

92+ , ringTerminalBell :: forall m. MonadIO m => m ()

99 -- | Returns whether the terminal has an audio bell feature.

93 -- | Returns whether the terminal has an audio bell feature.

100− , supportsBell :: IO Bool

94+ , supportsBell :: forall m. MonadIO m => m Bool

101− -- | Returns whether the terminal supports italicized text.

102− --

103− -- This is terminal-dependent and should make a best effort to

104− -- determine whether this feature is supported, but even if the

105− -- terminal advertises support (e.g. via terminfo) that might not

106− -- be a reliable indicator of whether the feature will work as

107− -- desired.

108− , supportsItalics :: IO Bool

109− -- | Returns whether the terminal supports strikethrough text.

110− --

111− -- This is terminal-dependent and should make a best effort to

112− -- determine whether this feature is supported, but even if the

113− -- terminal advertises support (e.g. via terminfo) that might not

114− -- be a reliable indicator of whether the feature will work as

115− -- desired.

116− , supportsStrikethrough :: IO Bool

117− -- | Returns how many colors the terminal supports.

118− , outputColorMode :: ColorMode

119 }

95 }

120

121−displayContext :: Output -> DisplayRegion -> IO DisplayContext

97+displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext

122−displayContext t = mkDisplayContext t t

98+displayContext t = liftIO . mkDisplayContext t t

123

124data AssumedState = AssumedState

100data AssumedState = AssumedState

125 { prevFattr :: Maybe FixedAttr

101 { prevFattr :: Maybe FixedAttr

@@ -154,9 +130,9 @@ data DisplayContext = DisplayContext

154 -- to support this the currently applied display attributes are

130 -- to support this the currently applied display attributes are

155 -- required. In addition it may be possible to optimize the state

131 -- required. In addition it may be possible to optimize the state

156 -- changes based off the currently applied display attributes.

132 -- changes based off the currently applied display attributes.

157− , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

133+ , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write

158 -- | Reset the display attributes to the default display attributes.

134 -- | Reset the display attributes to the default display attributes.

159− , writeDefaultAttr :: Bool -> Write

135+ , writeDefaultAttr :: Write

160 , writeRowEnd :: Write

136 , writeRowEnd :: Write

161 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`

137 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`

162 , inlineHack :: IO ()

138 , inlineHack :: IO ()

@@ -178,24 +154,24 @@ writeUtf8Text = writeByteString

178-- 4. Serialized to the display.

154-- 4. Serialized to the display.

179--

155--

180-- 5. The cursor is then shown and positioned or kept hidden.

156-- 5. The cursor is then shown and positioned or kept hidden.

181−outputPicture :: DisplayContext -> Picture -> IO ()

157+outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()

182−outputPicture dc pic = do

158+outputPicture dc pic = liftIO $ do

183− urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink

184 as <- readIORef (assumedStateRef $ contextDevice dc)

159 as <- readIORef (assumedStateRef $ contextDevice dc)

185 let manipCursor = supportsCursorVisibility (contextDevice dc)

160 let manipCursor = supportsCursorVisibility (contextDevice dc)

186 r = contextRegion dc

161 r = contextRegion dc

187 ops = displayOpsForPic pic r

162 ops = displayOpsForPic pic r

188− initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing

163+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing

189 -- Diff the previous output against the requested output.

164 -- Diff the previous output against the requested output.

190 -- Differences are currently on a per-row basis.

165 -- Differences are currently on a per-row basis.

191 diffs :: [Bool] = case prevOutputOps as of

166 diffs :: [Bool] = case prevOutputOps as of

192− Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True

167+ Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True

193− Just previousOps -> if affectedRegion previousOps /= affectedRegion ops

168+ Just previousOps -> if effectedRegion previousOps /= effectedRegion ops

194 then replicate (displayOpsRows ops) True

169 then replicate (displayOpsRows ops) True

195− else Vector.toList $ Vector.zipWith (/=) previousOps ops

170+ else zipWith (/=) (Vector.toList previousOps)

171+ (Vector.toList ops)

196 -- build the Write corresponding to the output image

172 -- build the Write corresponding to the output image

197 out = (if manipCursor then writeHideCursor dc else mempty)

173 out = (if manipCursor then writeHideCursor dc else mempty)

198− `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops

174+ `mappend` writeOutputOps dc initialAttr diffs ops

199 `mappend`

175 `mappend`

200 (let (w,h) = contextRegion dc

176 (let (w,h) = contextRegion dc

201 clampX = max 0 . min (w-1)

177 clampX = max 0 . min (w-1)

@@ -206,15 +182,9 @@ outputPicture dc pic = do

206 AbsoluteCursor x y ->

182 AbsoluteCursor x y ->

207 writeShowCursor dc `mappend`

183 writeShowCursor dc `mappend`

208 writeMoveCursor dc (clampX x) (clampY y)

184 writeMoveCursor dc (clampX x) (clampY y)

209− PositionOnly isAbs x y ->

210− if isAbs

211− then writeMoveCursor dc (clampX x) (clampY y)

212− else let (ox, oy) = charToOutputPos m (clampX x, clampY y)

213− m = cursorOutputMap ops $ picCursor pic

214− in writeMoveCursor dc (clampX ox) (clampY oy)

215 Cursor x y ->

185 Cursor x y ->

216 let m = cursorOutputMap ops $ picCursor pic

186 let m = cursorOutputMap ops $ picCursor pic

217− (ox, oy) = charToOutputPos m (clampX x, clampY y)

187+ (ox, oy) = charToOutputPos m (x,y)

218 in writeShowCursor dc `mappend`

188 in writeShowCursor dc `mappend`

219 writeMoveCursor dc (clampX ox) (clampY oy)

189 writeMoveCursor dc (clampX ox) (clampY oy)

220 )

190 )

@@ -224,15 +194,15 @@ outputPicture dc pic = do

224 let as' = as { prevOutputOps = Just ops }

194 let as' = as { prevOutputOps = Just ops }

225 writeIORef (assumedStateRef $ contextDevice dc) as'

195 writeIORef (assumedStateRef $ contextDevice dc) as'

226

196

227−writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write

197+writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write

228−writeOutputOps urlsEnabled dc initialAttr diffs ops =

198+writeOutputOps dc initialAttr diffs ops =

229 let (_, out, _) = Vector.foldl' writeOutputOps'

199 let (_, out, _) = Vector.foldl' writeOutputOps'

230 (0, mempty, diffs)

200 (0, mempty, diffs)

231 ops

201 ops

232 in out

202 in out

233 where

203 where

234 writeOutputOps' (y, out, True : diffs') spanOps

204 writeOutputOps' (y, out, True : diffs') spanOps

235− = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps

205+ = let spanOut = writeSpanOps dc y initialAttr spanOps

236 out' = out `mappend` spanOut

206 out' = out `mappend` spanOut

237 in (y+1, out', diffs')

207 in (y+1, out', diffs')

238 writeOutputOps' (y, out, False : diffs') _spanOps

208 writeOutputOps' (y, out, False : diffs') _spanOps

@@ -240,27 +210,27 @@ writeOutputOps urlsEnabled dc initialAttr diffs ops =

240 writeOutputOps' (_y, _out, []) _spanOps

210 writeOutputOps' (_y, _out, []) _spanOps

241 = error "vty - output spans without a corresponding diff."

211 = error "vty - output spans without a corresponding diff."

242

212

243−writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write

213+writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write

244−writeSpanOps urlsEnabled dc y initialAttr spanOps =

214+writeSpanOps dc y initialAttr spanOps =

245 -- The first operation is to set the cursor to the start of the row

215 -- The first operation is to set the cursor to the start of the row

246− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled

216+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc

247 -- then the span ops are serialized in the order specified

217 -- then the span ops are serialized in the order specified

248− in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of

218+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of

249 (opOut, fattr') -> (out `mappend` opOut, fattr')

219 (opOut, fattr') -> (out `mappend` opOut, fattr')

250 )

220 )

251 (start, initialAttr)

221 (start, initialAttr)

252 spanOps

222 spanOps

253

223

254−writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)

224+writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)

255−writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =

225+writeSpanOp dc (TextSpan attr _ _ str) fattr =

256 let attr' = limitAttrForDisplay (contextDevice dc) attr

226 let attr' = limitAttrForDisplay (contextDevice dc) attr

257 fattr' = fixDisplayAttr fattr attr'

227 fattr' = fixDisplayAttr fattr attr'

258 diffs = displayAttrDiffs fattr fattr'

228 diffs = displayAttrDiffs fattr fattr'

259− out = writeSetAttr dc urlsEnabled fattr attr' diffs

229+ out = writeSetAttr dc fattr attr' diffs

260 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)

230 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)

261 in (out, fattr')

231 in (out, fattr')

262−writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"

232+writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"

263−writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)

233+writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)

264

234

265-- | The cursor position is given in X,Y character offsets. Due to

235-- | The cursor position is given in X,Y character offsets. Due to

266-- multi-column characters this needs to be translated to column, row

236-- multi-column characters this needs to be translated to column, row

@@ -309,23 +279,17 @@ limitAttrForDisplay t attr

309 where

279 where

310 clampColor Default = Default

280 clampColor Default = Default

311 clampColor KeepCurrent = KeepCurrent

281 clampColor KeepCurrent = KeepCurrent

312− clampColor (SetTo c) = clampColor' (outputColorMode t) c

282+ clampColor (SetTo c) = clampColor' c

313−

314− clampColor' NoColor _ = Default

283+ clampColor' (ISOColor v)

315−

284+ | contextColorCount t < 8 = Default

316− clampColor' ColorMode8 (ISOColor v)

317− | v >= 8 = SetTo $ ISOColor (v - 8)

285+ | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)

318− | otherwise = SetTo $ ISOColor v

286+ | otherwise = SetTo $ ISOColor v

319− clampColor' ColorMode8 _ = Default

287+ clampColor' (Color240 v)

320−

288+ -- Should we choose closest ISO color?

321− clampColor' ColorMode16 c@(ISOColor _) = SetTo c

289+ | contextColorCount t < 8 = Default

322− clampColor' ColorMode16 _ = Default

290+ | contextColorCount t < 16 = Default

323−

291+ | contextColorCount t <= 256 = SetTo $ Color240 v

324− clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c

325− clampColor' (ColorMode240 colorCount) c@(Color240 n)

326− | n <= colorCount = SetTo c

327− | otherwise = Default

292+ | otherwise

328− clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =

293+ = let p :: Double = fromIntegral v / 240.0

329− clampColor' colorMode (color240 r g b)

294+ v' = floor $ p * (fromIntegral $ contextColorCount t)

330−

295+ in SetTo $ Color240 v'

331− clampColor' FullColor c = SetTo c

src/Graphics/Vty/Output/Mock.hs+6−10

@@ -2,8 +2,8 @@

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE TypeFamilies #-}

4-- | This provides a mock terminal implementation that is nice for

5−-- testing. This transforms the output operations to visible characters

5+-- testing. This transforms the output operations to visible characters.

6−-- which is useful for testing.

6+-- Which is nice for some tests.

7module Graphics.Vty.Output.Mock

8 ( MockData

9 , mockTerminal

@@ -11,7 +11,6 @@ module Graphics.Vty.Output.Mock

11where

13import Graphics.Vty.Image (DisplayRegion)

14−import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))

15import Graphics.Vty.Output.Interface

14import Graphics.Vty.Output.Interface

17import Blaze.ByteString.Builder.Word (writeWord8)

16import Blaze.ByteString.Builder.Word (writeWord8)

@@ -31,7 +30,7 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString)

31-- without considering terminal specific issues.

30-- without considering terminal specific issues.

32--

31--

33-- The mock implementation is useful in manually determining if the

32-- The mock implementation is useful in manually determining if the

34−-- sequence of terminal operations matches the expected sequence. The

33+-- sequence of terminal operations matches the expected sequence. So

35-- requirement of the produced representation is simplicity in parsing

34-- requirement of the produced representation is simplicity in parsing

36-- the text representation and determining how the picture was mapped to

35-- the text representation and determining how the picture was mapped to

37-- terminal operations.

36-- terminal operations.

@@ -49,19 +48,16 @@ mockTerminal r = liftIO $ do

49 , releaseDisplay = return ()

48 , releaseDisplay = return ()

50 , ringTerminalBell = return ()

49 , ringTerminalBell = return ()

51 , supportsBell = return False

50 , supportsBell = return False

52− , supportsItalics = return False

53− , supportsStrikethrough = return False

54− , setDisplayBounds = const $ return ()

55 , displayBounds = return r

51 , displayBounds = return r

56 , outputByteBuffer = \bytes -> do

52 , outputByteBuffer = \bytes -> do

57 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"

53 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"

58 writeIORef outRef $ UTF8.fromRep bytes

54 writeIORef outRef $ UTF8.fromRep bytes

55+ , contextColorCount = 16

59 , supportsCursorVisibility = True

56 , supportsCursorVisibility = True

60 , supportsMode = const False

57 , supportsMode = const False

61 , setMode = const $ const $ return ()

58 , setMode = const $ const $ return ()

62 , getModeStatus = const $ return False

59 , getModeStatus = const $ return False

63 , assumedStateRef = newAssumedStateRef

60 , assumedStateRef = newAssumedStateRef

64− , outputColorMode = ColorMode16

65 , mkDisplayContext = \tActual rActual -> return $ DisplayContext

61 , mkDisplayContext = \tActual rActual -> return $ DisplayContext

66 { contextRegion = rActual

62 { contextRegion = rActual

67 , contextDevice = tActual

63 , contextDevice = tActual

@@ -76,10 +72,10 @@ mockTerminal r = liftIO $ do

76 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'

72 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'

77 -- An attr change is always visualized as the single

73 -- An attr change is always visualized as the single

78 -- character 'A'

74 -- character 'A'

79− , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'

75+ , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'

80 -- default attr is always visualized as the single

76 -- default attr is always visualized as the single

81 -- character 'D'

77 -- character 'D'

82− , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'

78+ , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'

83 -- row end is always visualized as the single character

79 -- row end is always visualized as the single character

84 -- 'E'

80 -- 'E'

85 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'

81 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'

src/Graphics/Vty/Output/TerminfoBased.hs+74−199

@@ -1,21 +1,21 @@

1+{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE CPP #-}

4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}

3{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}

5{-# CFILES gwinsz.c #-}

4{-# CFILES gwinsz.c #-}

7−-- | Terminfo-based terminal output driver.

6+-- | Terminfo based terminal handling.

7+--

8+-- The color handling assumes tektronix like. No HP support provided. If

9+-- the terminal is not one I have easy access to then color support is

10+-- entirely based of the docs. Probably with some assumptions mixed in.

8--

11--

9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)

12-- Copyright Corey O'Connor (coreyoconnor@gmail.com)

10module Graphics.Vty.Output.TerminfoBased

13module Graphics.Vty.Output.TerminfoBased

11 ( reserveTerminal

14 ( reserveTerminal

12− , setWindowSize

13 )

15 )

14where

16where

16import Control.Monad (when)

18import Control.Monad (when)

17−import Data.Bits (shiftL, (.&.))

18−import qualified Data.ByteString as BS

19import Data.ByteString.Internal (toForeignPtr)

20import Data.Terminfo.Parse

21import Data.Terminfo.Eval

@@ -25,16 +25,15 @@ import Graphics.Vty.Image (DisplayRegion)

25import Graphics.Vty.DisplayAttributes

26import Graphics.Vty.Output.Interface

28−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)

28+import Blaze.ByteString.Builder (Write, writeToByteString)

29+

30+import Control.Monad.Trans

32+import Data.Bits ((.&.))

30import Data.IORef

33import Data.IORef

31import Data.Maybe (isJust, isNothing, fromJust)

34import Data.Maybe (isJust, isNothing, fromJust)

32import Data.Word

35import Data.Word

34−#if !MIN_VERSION_base(4,8,0)

35−import Data.Foldable (foldMap)

36−#endif

37−

38import Foreign.C.Types ( CInt(..), CLong(..) )

37import Foreign.C.Types ( CInt(..), CLong(..) )

39import Foreign.ForeignPtr (withForeignPtr)

38import Foreign.ForeignPtr (withForeignPtr)

40import Foreign.Ptr (Ptr, plusPtr)

39import Foreign.Ptr (Ptr, plusPtr)

@@ -49,6 +48,7 @@ data TerminfoCaps = TerminfoCaps

49 , cup :: CapExpression

48 , cup :: CapExpression

50 , cnorm :: Maybe CapExpression

49 , cnorm :: Maybe CapExpression

51 , civis :: Maybe CapExpression

50 , civis :: Maybe CapExpression

51+ , supportsNoColors :: Bool

52 , useAltColorMap :: Bool

53 , setForeColor :: CapExpression

54 , setBackColor :: CapExpression

@@ -63,10 +63,6 @@ data DisplayAttrCaps = DisplayAttrCaps

63 { setAttrStates :: Maybe CapExpression

64 , enterStandout :: Maybe CapExpression

65 , exitStandout :: Maybe CapExpression

66− , enterItalic :: Maybe CapExpression

67− , exitItalic :: Maybe CapExpression

68− , enterStrikethrough :: Maybe CapExpression

69− , exitStrikethrough :: Maybe CapExpression

70 , enterUnderline :: Maybe CapExpression

66 , enterUnderline :: Maybe CapExpression

71 , exitUnderline :: Maybe CapExpression

67 , exitUnderline :: Maybe CapExpression

72 , enterReverseVideo :: Maybe CapExpression

68 , enterReverseVideo :: Maybe CapExpression

@@ -93,95 +89,70 @@ sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()

93sendCapToTerminal t cap capParams = do

89sendCapToTerminal t cap capParams = do

94 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams

90 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams

96−-- | Constructs an output driver that uses terminfo for all control

97−-- codes. While this should provide the most compatible terminal,

92+-- | Uses terminfo for all control codes. While this should provide the

98−-- terminfo does not support some features that would increase

93+-- most compatible terminal terminfo does not support some features that

99−-- efficiency and improve compatibility:

94+-- would increase efficiency and improve compatibility:

100--

95--

101−-- * determining the character encoding supported by the terminal.

96+-- * determine the character encoding supported by the terminal. Should

102−-- Should this be taken from the LANG environment variable?

97+-- this be taken from the LANG environment variable?

103--

98--

104−-- * Providing independent string capabilities for all display

99+-- * Provide independent string capabilities for all display attributes.

105−-- attributes.

106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output

100+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

107−reserveTerminal termName outFd colorMode = do

101+reserveTerminal termName outFd = liftIO $ do

108 ti <- Terminfo.setupTerm termName

102 ti <- Terminfo.setupTerm termName

109 -- assumes set foreground always implies set background exists.

103 -- assumes set foreground always implies set background exists.

110 -- if set foreground is not set then all color changing style

104 -- if set foreground is not set then all color changing style

111 -- attributes are filtered.

105 -- attributes are filtered.

112 msetaf <- probeCap ti "setaf"

106 msetaf <- probeCap ti "setaf"

113 msetf <- probeCap ti "setf"

107 msetf <- probeCap ti "setf"

114− let (useAlt, setForeCap)

108+ let (noColors, useAlt, setForeCap)

115 = case msetaf of

109 = case msetaf of

116− Just setaf -> (False, setaf)

110+ Just setaf -> (False, False, setaf)

117 Nothing -> case msetf of

111 Nothing -> case msetf of

118− Just setf -> (True, setf)

112+ Just setf -> (False, True, setf)

119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)

113+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)

120 msetab <- probeCap ti "setab"

114 msetab <- probeCap ti "setab"

121 msetb <- probeCap ti "setb"

115 msetb <- probeCap ti "setb"

122− let setBackCap

116+ let set_back_cap

123 = case msetab of

117 = case msetab of

124− Just setab -> setab

125 Nothing -> case msetb of

118 Nothing -> case msetb of

126 Just setb -> setb

119 Just setb -> setb

127 Nothing -> error $ "no back color support for terminal " ++ termName

120 Nothing -> error $ "no back color support for terminal " ++ termName

128−

121+ Just setab -> setab

129− hyperlinkModeStatus <- newIORef False

130− newAssumedStateRef <- newIORef initialAssumedState

131−

132− let terminfoSetMode m newStatus = do

133− curStatus <- terminfoModeStatus m

134− when (newStatus /= curStatus) $

135− case m of

136− Hyperlink -> do

137− writeIORef hyperlinkModeStatus newStatus

138− writeIORef newAssumedStateRef initialAssumedState

139− _ -> return ()

140− terminfoModeStatus m =

141− case m of

142− Hyperlink -> readIORef hyperlinkModeStatus

143− _ -> return False

144− terminfoModeSupported Hyperlink = True

145− terminfoModeSupported _ = False

146−

147 terminfoCaps <- pure TerminfoCaps

122 terminfoCaps <- pure TerminfoCaps

148 <*> probeCap ti "smcup"

123 <*> probeCap ti "smcup"

149 <*> probeCap ti "rmcup"

124 <*> probeCap ti "rmcup"

150 <*> requireCap ti "cup"

125 <*> requireCap ti "cup"

151 <*> probeCap ti "cnorm"

126 <*> probeCap ti "cnorm"

152 <*> probeCap ti "civis"

127 <*> probeCap ti "civis"

128+ <*> pure noColors

153 <*> pure useAlt

129 <*> pure useAlt

154 <*> pure setForeCap

130 <*> pure setForeCap

155− <*> pure setBackCap

131+ <*> pure set_back_cap

156 <*> requireCap ti "sgr0"

132 <*> requireCap ti "sgr0"

157 <*> requireCap ti "clear"

133 <*> requireCap ti "clear"

158 <*> requireCap ti "el"

134 <*> requireCap ti "el"

159 <*> currentDisplayAttrCaps ti

135 <*> currentDisplayAttrCaps ti

160 <*> probeCap ti "bel"

136 <*> probeCap ti "bel"

137+ newAssumedStateRef <- newIORef initialAssumedState

161 let t = Output

138 let t = Output

162 { terminalID = termName

139 { terminalID = termName

163− , releaseTerminal = do

140+ , releaseTerminal = liftIO $ do

164 sendCap setDefaultAttr []

141 sendCap setDefaultAttr []

165 maybeSendCap cnorm []

142 maybeSendCap cnorm []

166 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps

143 , 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 []

144+ , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []

172− , reserveDisplay = do

145+ , reserveDisplay = liftIO $ do

173 -- If there is no support for smcup: Clear the screen

146 -- If there is no support for smcup: Clear the screen

174 -- and then move the mouse to the home position to

147 -- and then move the mouse to the home position to

175 -- approximate the behavior.

148 -- approximate the behavior.

176 maybeSendCap smcup []

149 maybeSendCap smcup []

177 sendCap clearScreen []

150 sendCap clearScreen []

178− , releaseDisplay = do

151+ , releaseDisplay = liftIO $ do

179 maybeSendCap rmcup []

152 maybeSendCap rmcup []

180 maybeSendCap cnorm []

153 maybeSendCap cnorm []

181− , setDisplayBounds = \(w, h) ->

182− setWindowSize outFd (w, h)

183 , displayBounds = do

154 , displayBounds = do

184− rawSize <- getWindowSize outFd

155+ rawSize <- liftIO $ getWindowSize outFd

185 case rawSize of

156 case rawSize of

186 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize

157 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize

187 | otherwise -> return (w,h)

158 | otherwise -> return (w,h)

@@ -192,48 +163,51 @@ reserveTerminal termName outFd colorMode = do

192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "

163 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "

193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen

164 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen

194 ++ " Please report this bug to vty project."

165 ++ " Please report this bug to vty project."

166+ , contextColorCount

167+ = case supportsNoColors terminfoCaps of

168+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

169+ Nothing -> 8

170+ Just v -> toEnum v

171+ True -> 1

195 , supportsCursorVisibility = isJust $ civis terminfoCaps

172 , supportsCursorVisibility = isJust $ civis terminfoCaps

196− , supportsMode = terminfoModeSupported

173+ , supportsMode = const False

197− , setMode = terminfoSetMode

174+ , setMode = const $ const $ return ()

198− , getModeStatus = terminfoModeStatus

175+ , getModeStatus = const $ return False

199 , assumedStateRef = newAssumedStateRef

176 , assumedStateRef = newAssumedStateRef

200− , outputColorMode = colorMode

201 -- I think fix would help assure tActual is the only

177 -- I think fix would help assure tActual is the only

202 -- reference. I was having issues tho.

178 -- reference. I was having issues tho.

203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

179+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps

204 }

180 }

205 sendCap s = sendCapToTerminal t (s terminfoCaps)

181 sendCap s = sendCapToTerminal t (s terminfoCaps)

206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)

182 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)

207 return t

183 return t

208

184

209−requireCap :: Terminfo.Terminal -> String -> IO CapExpression

185+requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression

210requireCap ti capName

186requireCap ti capName

211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

187 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""

188 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""

213 Just capStr -> parseCap capStr

189 Just capStr -> parseCap capStr

214

190

215−probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)

191+probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)

216probeCap ti capName

192probeCap ti capName

217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

193 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

218 Nothing -> return Nothing

194 Nothing -> return Nothing

219 Just capStr -> Just <$> parseCap capStr

195 Just capStr -> Just <$> parseCap capStr

220

196

221−parseCap :: String -> IO CapExpression

197+parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression

222parseCap capStr = do

198parseCap capStr = do

223 case parseCapExpression capStr of

199 case parseCapExpression capStr of

224 Left e -> fail $ show e

200 Left e -> fail $ show e

225 Right cap -> return cap

201 Right cap -> return cap

226

202

227−currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps

203+currentDisplayAttrCaps :: ( Applicative m, MonadIO m )

204+ => Terminfo.Terminal

205+ -> m DisplayAttrCaps

228currentDisplayAttrCaps ti

206currentDisplayAttrCaps ti

229 = pure DisplayAttrCaps

207 = pure DisplayAttrCaps

230 <*> probeCap ti "sgr"

208 <*> probeCap ti "sgr"

231 <*> probeCap ti "smso"

209 <*> probeCap ti "smso"

232 <*> probeCap ti "rmso"

210 <*> probeCap ti "rmso"

233− <*> probeCap ti "sitm"

234− <*> probeCap ti "ritm"

235− <*> probeCap ti "smxx"

236− <*> probeCap ti "rmxx"

237 <*> probeCap ti "smul"

211 <*> probeCap ti "smul"

238 <*> probeCap ti "rmul"

212 <*> probeCap ti "rmul"

239 <*> probeCap ti "rev"

213 <*> probeCap ti "rev"

@@ -247,13 +221,6 @@ getWindowSize fd = do

247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd

221 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd

248 return (fromIntegral b, fromIntegral a)

222 return (fromIntegral b, fromIntegral a)

249

223

250−foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO ()

251−

252−setWindowSize :: Fd -> (Int, Int) -> IO ()

253−setWindowSize fd (w, h) = do

254− let val = (h `shiftL` 16) + w

255− c_setWindowSize fd $ fromIntegral val

256−

257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

224terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

258terminfoDisplayContext tActual terminfoCaps r = return dc

225terminfoDisplayContext tActual terminfoCaps r = return dc

259 where dc = DisplayContext

226 where dc = DisplayContext

@@ -267,35 +234,15 @@ terminfoDisplayContext tActual terminfoCaps r = return dc

267 Nothing -> error "this terminal does not support hide cursor"

234 Nothing -> error "this terminal does not support hide cursor"

268 Just c -> writeCapExpr c []

235 Just c -> writeCapExpr c []

269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps

236 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps

270− , writeDefaultAttr = \urlsEnabled ->

271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`

237+ , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []

272− (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`

273− (case exitStrikethrough $ displayAttrCaps terminfoCaps of

274− Just cap -> writeCapExpr cap []

275− Nothing -> mempty

276− )

277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []

238 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []

278 , inlineHack = return ()

239 , inlineHack = return ()

279 }

240 }

280

241

281−-- | Write the escape sequences that are used in some terminals to

282−-- include embedded hyperlinks. As of yet, this information isn't

283−-- included in termcap or terminfo, so this writes them directly

284−-- instead of looking up the appropriate capabilities.

285−writeURLEscapes :: URLDiff -> Write

286−writeURLEscapes (LinkTo url) =

287− foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`

288− foldMap writeStorable (BS.unpack url) `mappend`

289− writeStorable (0x07 :: Word8)

290−writeURLEscapes EndLink =

291− foldMap writeStorable (BS.unpack "\x1b]8;;\a")

292−writeURLEscapes NoLinkChange =

293− mempty

294−

295-- | Portably setting the display attributes is a giant pain in the ass.

242-- | Portably setting the display attributes is a giant pain in the ass.

296--

243--

297-- If the terminal supports the sgr capability (which sets the on/off

244-- 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

245+-- state of each style directly ; and, for no good reason, resets the

299-- colors to the default) this procedure is used:

246-- colors to the default) this procedure is used:

300--

247--

301-- 0. set the style attributes. This resets the fore and back color.

248-- 0. set the style attributes. This resets the fore and back color.

@@ -328,30 +275,30 @@ writeURLEscapes NoLinkChange =

328--

275--

329-- Note that this optimizes for fewer state changes followed by fewer

276-- Note that this optimizes for fewer state changes followed by fewer

330-- bytes.

277-- bytes.

331−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

278+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

332−terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

279+terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do

333− urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of

280+ case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of

334 -- The only way to reset either color, portably, to the default

281 -- The only way to reset either color, portably, to the default

335 -- is to use either the set state capability or the set default

282 -- is to use either the set state capability or the set default

336 -- capability.

283 -- capability.

337− True -> do

284+ True -> do

338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

285 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

339− (fixedStyle attr)

286+ (fixedStyle attr )

340 (styleToApplySeq $ fixedStyle attr) of

287 (styleToApplySeq $ fixedStyle attr) of

341 -- only way to reset a color to the defaults

288 -- only way to reset a color to the defaults

342− EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

289+ EnterExitSeq caps -> writeDefaultAttr dc

343 `mappend`

290 `mappend`

344 foldMap (\cap -> writeCapExpr cap []) caps

291 foldMap (\cap -> writeCapExpr cap []) caps

345 `mappend`

292 `mappend`

346 setColors

293 setColors

347 -- implicitly resets the colors to the defaults

294 -- implicitly resets the colors to the defaults

348 SetState state -> writeCapExpr (fromJust $ setAttrStates

295 SetState state -> writeCapExpr (fromJust $ setAttrStates

349− $ displayAttrCaps terminfoCaps

296+ $ displayAttrCaps

297+ $ terminfoCaps

350 )

298 )

351 (sgrArgsForState state)

299 (sgrArgsForState state)

352− `mappend` setItalics

300+ `mappend`

353− `mappend` setStrikethrough

354− `mappend` setColors

301+ setColors

355 -- Otherwise the display colors are not changing or changing

302 -- Otherwise the display colors are not changing or changing

356 -- between two non-default points.

303 -- between two non-default points.

357 False -> do

304 False -> do

@@ -369,99 +316,45 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

369 -- applied states.

316 -- applied states.

370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps

317 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps

371 `mappend`

318 `mappend`

372− writeColorDiff Foreground (foreColorDiff diffs)

319+ writeColorDiff setForeColor (foreColorDiff diffs)

373 `mappend`

320 `mappend`

374− writeColorDiff Background (backColorDiff diffs)

321+ writeColorDiff setBackColor (backColorDiff diffs)

375 -- implicitly resets the colors to the defaults

322 -- implicitly resets the colors to the defaults

376 SetState state -> writeCapExpr (fromJust $ setAttrStates

323 SetState state -> writeCapExpr (fromJust $ setAttrStates

377 $ displayAttrCaps terminfoCaps

324 $ displayAttrCaps terminfoCaps

378 )

325 )

379 (sgrArgsForState state)

326 (sgrArgsForState state)

380− `mappend` setItalics

381− `mappend` setStrikethrough

382 `mappend` setColors

327 `mappend` setColors

383 where

328 where

384− urlAttrs True = writeURLEscapes (urlDiff diffs)

385− urlAttrs False = mempty

386 colorMap = case useAltColorMap terminfoCaps of

329 colorMap = case useAltColorMap terminfoCaps of

387 False -> ansiColorIndex

330 False -> ansiColorIndex

388 True -> altColorIndex

331 True -> altColorIndex

389 attr = fixDisplayAttr prevAttr reqAttr

332 attr = fixDisplayAttr prevAttr reqAttr

390−

391− -- italics can't be set via SGR, so here we manually

392− -- apply the enter and exit sequences as needed after

393− -- changing the SGR

394− setItalics

395− | hasStyle (fixedStyle attr) italic

396− , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)

397− = writeCapExpr sitm []

398− | otherwise = mempty

399− setStrikethrough

400− | hasStyle (fixedStyle attr) strikethrough

401− , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)

402− = writeCapExpr smxx []

403− | otherwise = mempty

404 setColors =

333 setColors =

405 (case fixedForeColor attr of

334 (case fixedForeColor attr of

406− Just c -> writeColor Foreground c

335+ Just c -> writeCapExpr (setForeColor terminfoCaps)

336+ [toEnum $ colorMap c]

407 Nothing -> mempty)

337 Nothing -> mempty)

408 `mappend`

338 `mappend`

409 (case fixedBackColor attr of

339 (case fixedBackColor attr of

410− Just c -> writeColor Background c

340+ Just c -> writeCapExpr (setBackColor terminfoCaps)

341+ [toEnum $ colorMap c]

411 Nothing -> mempty)

342 Nothing -> mempty)

412− writeColorDiff _side NoColorChange

343+ writeColorDiff _f NoColorChange

413 = mempty

344 = mempty

414− writeColorDiff _side ColorToDefault

345+ writeColorDiff _f ColorToDefault

415 = error "ColorToDefault is not a possible case for applyColorDiffs"

346 = error "ColorToDefault is not a possible case for applyColorDiffs"

416− writeColorDiff side (SetColor c)

347+ writeColorDiff f (SetColor c)

417− = writeColor side c

418−

419− writeColor side (RGBColor r g b) =

420− case outputColorMode (contextDevice dc) of

421− FullColor ->

422− hardcodeColor side (r, g, b)

423− _ ->

424− error "clampColor should remove rgb colors in standard mode"

425− writeColor side c =

426− writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]

348+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]

427−

428−-- a color can either be in the foreground or the background

429−data ColorSide = Foreground | Background

430−

431−-- get the capability for drawing a color on a specific side

432−setSideColor :: ColorSide -> TerminfoCaps -> CapExpression

433−setSideColor Foreground = setForeColor

434−setSideColor Background = setBackColor

435−

436−hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write

437−hardcodeColor side (r, g, b) =

438− -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m"

439− mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter

440− , writeColor r, delimiter, writeColor g, delimiter, writeColor b

441− , writeChar 'm']

442− where

443− writeChar = writeWord8 . fromIntegral . fromEnum

444− writeStr = mconcat . map writeChar

445− writeColor = writeStr . show

446− delimiter = writeChar ';'

447− -- 38/48 are used to set whether we should write to the

448− -- foreground/background. I really don't want to know why.

449− sideCode = case side of

450− Foreground -> writeStr "38"

451− Background -> writeStr "48"

452

349

453-- | The color table used by a terminal is a 16 color set followed by a

350-- | 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.

351-- 240 color set that might not be supported by the terminal.

455--

352--

456−-- This takes a Color which clearly identifies which palette to use and

353+-- This takes a Color which clearly identifies which pallete to use and

457−-- computes the index into the full 256 color palette.

354+-- computes the index into the full 256 color pallete.

458ansiColorIndex :: Color -> Int

355ansiColorIndex :: Color -> Int

459ansiColorIndex (ISOColor v) = fromEnum v

356ansiColorIndex (ISOColor v) = fromEnum v

460ansiColorIndex (Color240 v) = 16 + fromEnum v

357ansiColorIndex (Color240 v) = 16 + fromEnum v

461−ansiColorIndex (RGBColor _ _ _) =

462− error $ unlines [ "Attempted to create color index from rgb color."

463− , "This is currently unsupported, and shouldn't ever happen"

464− ]

465

358

466-- | For terminals without setaf/setab

359-- | For terminals without setaf/setab

467--

360--

@@ -478,10 +371,6 @@ altColorIndex (ISOColor 6) = 3

478altColorIndex (ISOColor 7) = 7

371altColorIndex (ISOColor 7) = 7

479altColorIndex (ISOColor v) = fromEnum v

372altColorIndex (ISOColor v) = fromEnum v

480altColorIndex (Color240 v) = 16 + fromEnum v

373altColorIndex (Color240 v) = 16 + fromEnum v

481−altColorIndex (RGBColor _ _ _) =

482− error $ unlines [ "Attempted to create color index from rgb color."

483− , "This is currently unsupported, and shouldn't ever happen"

484− ]

485

374

486{- | The sequence of terminfo caps to apply a given style are determined

375{- | The sequence of terminfo caps to apply a given style are determined

487 - according to these rules.

376 - according to these rules.

@@ -508,8 +397,6 @@ data DisplayAttrSeq

508data DisplayAttrState = DisplayAttrState

397data DisplayAttrState = DisplayAttrState

509 { applyStandout :: Bool

398 { applyStandout :: Bool

510 , applyUnderline :: Bool

399 , applyUnderline :: Bool

511− , applyItalic :: Bool

512− , applyStrikethrough :: Bool

513 , applyReverseVideo :: Bool

400 , applyReverseVideo :: Bool

514 , applyBlink :: Bool

401 , applyBlink :: Bool

515 , applyDim :: Bool

402 , applyDim :: Bool

@@ -546,10 +433,6 @@ reqDisplayCapSeqFor caps s diffs

546 -- set state cap then just use the set state cap.

433 -- set state cap then just use the set state cap.

547 ( True, True ) -> SetState $ stateForStyle s

434 ( True, True ) -> SetState $ stateForStyle s

548 where

435 where

549− noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps

550− noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps

551− noEnterExitCap ApplyItalic = isNothing $ enterItalic caps

552− noEnterExitCap RemoveItalic = isNothing $ exitItalic caps

553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps

436 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps

554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps

437 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps

555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps

438 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps

@@ -562,10 +445,6 @@ reqDisplayCapSeqFor caps s diffs

562 noEnterExitCap RemoveDim = True

445 noEnterExitCap RemoveDim = True

563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps

446 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps

564 noEnterExitCap RemoveBold = True

447 noEnterExitCap RemoveBold = True

565− enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps

566− enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps

567− enterExitCap ApplyItalic = fromJust $ enterItalic caps

568− enterExitCap RemoveItalic = fromJust $ exitItalic caps

569 enterExitCap ApplyStandout = fromJust $ enterStandout caps

448 enterExitCap ApplyStandout = fromJust $ enterStandout caps

570 enterExitCap RemoveStandout = fromJust $ exitStandout caps

449 enterExitCap RemoveStandout = fromJust $ exitStandout caps

571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps

450 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps

@@ -579,8 +458,6 @@ stateForStyle :: Style -> DisplayAttrState

579stateForStyle s = DisplayAttrState

458stateForStyle s = DisplayAttrState

580 { applyStandout = isStyleSet standout

459 { applyStandout = isStyleSet standout

581 , applyUnderline = isStyleSet underline

460 , applyUnderline = isStyleSet underline

582− , applyItalic = isStyleSet italic

583− , applyStrikethrough = isStyleSet strikethrough

584 , applyReverseVideo = isStyleSet reverseVideo

461 , applyReverseVideo = isStyleSet reverseVideo

585 , applyBlink = isStyleSet blink

462 , applyBlink = isStyleSet blink

586 , applyDim = isStyleSet dim

463 , applyDim = isStyleSet dim

@@ -592,12 +469,10 @@ styleToApplySeq :: Style -> [StyleStateChange]

592styleToApplySeq s = concat

469styleToApplySeq s = concat

593 [ applyIfRequired ApplyStandout standout

470 [ applyIfRequired ApplyStandout standout

594 , applyIfRequired ApplyUnderline underline

471 , applyIfRequired ApplyUnderline underline

595− , applyIfRequired ApplyItalic italic

596− , applyIfRequired ApplyStrikethrough strikethrough

597 , applyIfRequired ApplyReverseVideo reverseVideo

472 , applyIfRequired ApplyReverseVideo reverseVideo

598 , applyIfRequired ApplyBlink blink

473 , applyIfRequired ApplyBlink blink

599 , applyIfRequired ApplyDim dim

474 , applyIfRequired ApplyDim dim

600− , applyIfRequired ApplyBold bold

475+ , applyIfRequired ApplyBlink bold

601 ]

476 ]

602 where

477 where

603 applyIfRequired op flag

478 applyIfRequired op flag

src/Graphics/Vty/Output/XTermColor.hs+19−45

@@ -1,7 +1,4 @@

1−{-# Language CPP #-}

3−-- | Xterm output driver. This uses the Terminfo driver with some

4−-- extensions for Xterm.

5module Graphics.Vty.Output.XTermColor

2module Graphics.Vty.Output.XTermColor

6 ( reserveTerminal

3 ( reserveTerminal

7 )

4 )

@@ -9,42 +6,26 @@ where

10import Graphics.Vty.Output.Interface

7import Graphics.Vty.Output.Interface

11import Graphics.Vty.Input.Mouse

8import Graphics.Vty.Input.Mouse

12−import Graphics.Vty.Input.Focus

13−import Graphics.Vty.Attributes.Color (ColorMode)

14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

9import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

16import Blaze.ByteString.Builder (writeToByteString)

11import Blaze.ByteString.Builder (writeToByteString)

17import Blaze.ByteString.Builder.Word (writeWord8)

12import Blaze.ByteString.Builder.Word (writeWord8)

19−import qualified Data.ByteString.Char8 as BS8

20−import Data.ByteString.Char8 (ByteString)

21−import Foreign.Ptr (castPtr)

22−

23import Control.Monad (void, when)

14import Control.Monad (void, when)

24import Control.Monad.Trans

15import Control.Monad.Trans

25−import Data.Char (toLower)

26import Data.IORef

16import Data.IORef

28−import System.Posix.IO (fdWriteBuf)

18+import System.Posix.IO (fdWrite)

29−import System.Posix.Types (ByteCount, Fd)

19+import System.Posix.Types (Fd)

30import System.Posix.Env (getEnv)

20import System.Posix.Env (getEnv)

32import Data.List (isInfixOf)

22import Data.List (isInfixOf)

33import Data.Maybe (catMaybes)

23import Data.Maybe (catMaybes)

34−

35−#if !MIN_VERSION_base(4,11,0)

36import Data.Monoid ((<>))

24import Data.Monoid ((<>))

37−#endif

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.

26+-- | Initialize the display to UTF-8.

46−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output

27+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

47−reserveTerminal variant outFd colorMode = liftIO $ do

28+reserveTerminal variant outFd = liftIO $ do

48 let flushedPut = void . fdWrite outFd

29 let flushedPut = void . fdWrite outFd

49 -- If the terminal variant is xterm-color use xterm instead since,

30 -- If the terminal variant is xterm-color use xterm instead since,

50 -- more often than not, xterm-color is broken.

31 -- more often than not, xterm-color is broken.

@@ -52,21 +33,15 @@ reserveTerminal variant outFd colorMode = liftIO $ do

53 utf8a <- utf8Active

34 utf8a <- utf8Active

54 when (not utf8a) $ flushedPut setUtf8CharSet

35 when (not utf8a) $ flushedPut setUtf8CharSet

55− t <- TerminfoBased.reserveTerminal variant' outFd colorMode

36+ t <- TerminfoBased.reserveTerminal variant' outFd

57 mouseModeStatus <- newIORef False

38 mouseModeStatus <- newIORef False

58− focusModeStatus <- newIORef False

59 pasteModeStatus <- newIORef False

39 pasteModeStatus <- newIORef False

61 let xtermSetMode t' m newStatus = do

41 let xtermSetMode t' m newStatus = do

62 curStatus <- getModeStatus t' m

42 curStatus <- getModeStatus t' m

63 when (newStatus /= curStatus) $

43 when (newStatus /= curStatus) $

64 case m of

44 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

45 Mouse -> liftIO $ do

71 case newStatus of

46 case newStatus of

72 True -> flushedPut requestMouseEvents

47 True -> flushedPut requestMouseEvents

@@ -77,12 +52,9 @@ reserveTerminal variant outFd colorMode = liftIO $ do

77 True -> flushedPut enableBracketedPastes

52 True -> flushedPut enableBracketedPastes

78 False -> flushedPut disableBracketedPastes

53 False -> flushedPut disableBracketedPastes

79 writeIORef pasteModeStatus newStatus

54 writeIORef pasteModeStatus newStatus

80− Hyperlink -> setMode t Hyperlink newStatus

82 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus

56 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus

83− xtermGetMode Focus = liftIO $ readIORef focusModeStatus

84 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus

57 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus

85− xtermGetMode Hyperlink = getModeStatus t Hyperlink

87 let t' = t

59 let t' = t

88 { terminalID = terminalID t ++ " (xterm-color)"

60 { terminalID = terminalID t ++ " (xterm-color)"

@@ -90,7 +62,6 @@ reserveTerminal variant outFd colorMode = liftIO $ do

90 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet

62 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet

91 setMode t' BracketedPaste False

63 setMode t' BracketedPaste False

92 setMode t' Mouse False

64 setMode t' Mouse False

93− setMode t' Focus False

94 releaseTerminal t

65 releaseTerminal t

95 , mkDisplayContext = \tActual r -> do

66 , mkDisplayContext = \tActual r -> do

96 dc <- mkDisplayContext t tActual r

67 dc <- mkDisplayContext t tActual r

@@ -104,27 +75,30 @@ reserveTerminal variant outFd colorMode = liftIO $ do

104utf8Active :: IO Bool

75utf8Active :: IO Bool

105utf8Active = do

76utf8Active = do

106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]

77 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]

107− results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars

78+ results <- catMaybes <$> mapM getEnv vars

108− let matches = filter ("utf8" `isInfixOf`) results <>

79+ let matches = filter ("UTF8" `isInfixOf`) results <>

109− filter ("utf-8" `isInfixOf`) results

80+ filter ("UTF-8" `isInfixOf`) results

110 return $ not $ null matches

81 return $ not $ null matches

111

112-- | Enable bracketed paste mode:

83-- | Enable bracketed paste mode:

113-- http://cirw.in/blog/bracketed-paste

84-- http://cirw.in/blog/bracketed-paste

114−enableBracketedPastes :: ByteString

85+enableBracketedPastes :: String

115−enableBracketedPastes = BS8.pack "\ESC[?2004h"

86+enableBracketedPastes = "\ESC[?2004h"

116

117-- | Disable bracketed paste mode:

88-- | Disable bracketed paste mode:

118−disableBracketedPastes :: ByteString

89+disableBracketedPastes :: String

119−disableBracketedPastes = BS8.pack "\ESC[?2004l"

90+disableBracketedPastes = "\ESC[?2004l"

120

121-- | These sequences set xterm based terminals to UTF-8 output.

92-- | These sequences set xterm based terminals to UTF-8 output.

122--

93--

123-- There is no known terminfo capability equivalent to this.

94-- There is no known terminfo capability equivalent to this.

124−setUtf8CharSet, setDefaultCharSet :: ByteString

95+setUtf8CharSet, setDefaultCharSet :: String

125−setUtf8CharSet = BS8.pack "\ESC%G"

96+setUtf8CharSet = "\ESC%G"

126−setDefaultCharSet = BS8.pack "\ESC%@"

97+setDefaultCharSet = "\ESC%@"

127

99+-- | I think xterm is broken: Reseting the background color as the first

100+-- bytes serialized on a new line does not effect the background color

101+-- xterm uses to clear the line. Which is used *after* the next newline.

128xtermInlineHack :: Output -> IO ()

102xtermInlineHack :: Output -> IO ()

129xtermInlineHack t = do

103xtermInlineHack t = do

130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

104 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

src/Graphics/Vty/Picture.hs+38−50

@@ -1,6 +1,8 @@

1−-- A 'Picture' is a background paired with a set of 'Image' layers. The

1+{-# LANGUAGE BangPatterns #-}

2−-- 'Picture' data structure is representative of the final terminal

2+-- | The 'Picture' data structure is representative of the final

3−-- view.

3+-- terminal view.

4+--

5+-- A 'Picture' is a background paired with a layer of 'Image's.

4module Graphics.Vty.Picture

6module Graphics.Vty.Picture

5 ( Picture(..)

7 ( Picture(..)

6 , Cursor(..)

8 , Cursor(..)

@@ -19,18 +21,16 @@ import Graphics.Vty.Attributes

20import Control.DeepSeq

22import Control.DeepSeq

22−-- | A Vty picture.

24+-- | The type of images to be displayed using 'update'.

23--

25--

24−-- These can be constructed directly or using `picForImage`.

26+-- Can be constructed directly or using `picForImage`. Which provides

27+-- an initial instance with reasonable defaults for picCursor and

28+-- picBackground.

25data Picture = Picture

29data Picture = Picture

26 { picCursor :: Cursor

30 { picCursor :: Cursor

27− -- ^ The picture's cursor.

28 , picLayers :: [Image]

31 , picLayers :: [Image]

29− -- ^ The picture's image layers (top-most first).

30 , picBackground :: Background

32 , picBackground :: Background

31− -- ^ The picture's background to be displayed in locations with no

33+ }

32− -- Image data.

33− } deriving Eq

35instance Show Picture where

36 show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"

@@ -38,21 +38,21 @@ instance Show Picture where

38instance NFData Picture where

39 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()

41−-- | A picture with no cursor, background or image layers.

41+-- | a picture with no cursor, background or image layers

42emptyPicture :: Picture

43emptyPicture = Picture NoCursor [] ClearBackground

45−-- | Add an 'Image' as the top-most layer of a 'Picture'.

45+-- | The given 'Image' is added as the top layer of the 'Picture'

46addToTop :: Picture -> Image -> Picture

47addToTop p i = p {picLayers = i : picLayers p}

49−-- | Add an 'Image' as the bottom-most layer of a 'Picture'.

49+-- | The given 'Image' is added as the bottom layer of the 'Picture'

50addToBottom :: Picture -> Image -> Picture

51addToBottom p i = p {picLayers = picLayers p ++ [i]}

53−-- | Create a picture from the given image. The picture will not have a

53+-- | Create a picture for display for the given image. The picture

54−-- displayed cursor and no background pattern (ClearBackground) will be

54+-- will not have a displayed cursor and no background pattern

55−-- used.

55+-- (ClearBackground) will be used.

56picForImage :: Image -> Picture

57picForImage i = Picture

58 { picCursor = NoCursor

@@ -60,10 +60,13 @@ picForImage i = Picture

60 , picBackground = ClearBackground

61 }

63−-- | Create a picture with the given layers, top-most first.

63+-- | Create a picture for display with the given layers. Ordered top to

64+-- bottom.

64--

65--

65-- The picture will not have a displayed cursor and no background

66-- The picture will not have a displayed cursor and no background

66−-- pattern (ClearBackgroun) will be used.

67+-- apttern (ClearBackgroun) will be used.

68+--

69+-- The first 'Image' is the top layer.

67picForLayers :: [Image] -> Picture

70picForLayers :: [Image] -> Picture

68picForLayers is = Picture

71picForLayers is = Picture

69 { picCursor = NoCursor

72 { picCursor = NoCursor

@@ -71,40 +74,29 @@ picForLayers is = Picture

71 , picBackground = ClearBackground

74 , picBackground = ClearBackground

72 }

75 }

74−-- | A picture can be configured to hide the cursor or to show the

77+-- | A picture can be configured either to not show the cursor or show

75−-- cursor at the specified character position.

78+-- the cursor at the specified character position.

76--

79--

77−-- There is not a 1:1 map from character positions to a row and column

80+-- There is not a 1 to 1 map from character positions to a row and

78−-- on the screen due to characters that take more than 1 column.

81+-- column on the screen due to characters that take more than 1 column.

79data Cursor =

82data Cursor =

80− -- | Hide the cursor

83+ -- | Hide the cursor

81− NoCursor

84+ 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

85+ -- | Show the cursor at the given logical column accounting for

91− -- character width in the presence of multi-column characters.

86+ -- char width and row

92 | Cursor !Int !Int

87 | Cursor !Int !Int

93− -- | Show the cursor at the given absolute terminal column and row

88+ -- | Show the cursor at the given absolute terminal column and row

94 | AbsoluteCursor !Int !Int

89 | AbsoluteCursor !Int !Int

95− deriving Eq

97instance NFData Cursor where

91instance NFData Cursor where

98 rnf c = c `seq` ()

92 rnf c = c `seq` ()

100−-- | A 'Picture' has a background pattern. The background is either:

94+-- | A 'Picture' has a background pattern. The background is either

101−--

102−-- * ClearBackground, which shows the layer below or is blank if the

95+-- ClearBackground. Which shows the layer below or is blank if the

103−-- bottom layer

104−-- * A character and a display attribute

96+-- bottom layer. Or the background pattern is a character and a display

105−--

106−-- If the display attribute used previously should be used for a

97+-- attribute. If the display attribute used previously should be used

107−-- background fill then use `currentAttr` for the background attribute.

98+-- for a background fill then use `currentAttr` for the background

99+-- attribute.

108data Background

100data Background

109 = Background

101 = Background

110 { backgroundChar :: Char

102 { backgroundChar :: Char

@@ -116,16 +108,12 @@ data Background

116 --

108 --

117 -- * End of line if there are no remaining non-skip ops.

109 -- * End of line if there are no remaining non-skip ops.

118 | ClearBackground

110 | ClearBackground

119− deriving Eq

120

111

121instance NFData Background where

112instance NFData Background where

122 rnf (Background c a) = c `seq` a `seq` ()

113 rnf (Background c a) = c `seq` a `seq` ()

123 rnf ClearBackground = ()

114 rnf ClearBackground = ()

124

115

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

116+-- | Compatibility with applications that do not use more than a single

129−-- more than a single layer.

117+-- layer.

130picImage :: Picture -> Image

118picImage :: Picture -> Image

131picImage = head . picLayers

119picImage = head . picLayers

src/Graphics/Vty/PictureToSpans.hs+17−11

@@ -72,7 +72,7 @@ displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)

72-- | Returns the DisplayOps for an image rendered to a window the size

73-- of the image.

74--

75−-- largely used only for debugging.

75+-- largerly used only for debugging.

76displayOpsForImage :: Image -> DisplayOps

77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)

@@ -81,7 +81,7 @@ combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)

81combinedOpsForLayers pic r

82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0

83 | otherwise = do

84− layerOps <- mapM (`buildSpans` r) (picLayers pic)

84+ layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)

85 case layerOps of

86 [] -> fail "empty picture"

87 [ops] -> substituteSkips (picBackground pic) ops

@@ -136,8 +136,8 @@ mergeUnder upper lower = do

136 return upper

137

138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps

139−mergeRowUnder upperRowOps =

139+mergeRowUnder upperRowOps lowerRowOps =

140− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)

140+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps

141 where

142 -- H: it will never be the case that we are out of upper ops

143 -- before lower ops.

@@ -298,11 +298,11 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do

298 state <- get

299 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"

300 case state^.skip of

301− s | s > size -> put $ state & skip %~ subtract size

301+ s | s > size -> put $ state & skip -~ size

302 | s == 0 -> if state^.remaining > i0Dim

303 then do

304 addMaybeClipped i0

305− put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim

305+ put $ state & offset +~ i0Dim & remaining -~ i0Dim

306 addMaybeClipped i1

307 else addMaybeClipped i0

308 | s < i0Dim ->

@@ -311,10 +311,10 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do

311 then addMaybeClipped i0

312 else do

313 addMaybeClipped i0

314− put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0

314+ put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0

315 addMaybeClipped i1

316 | s >= i0Dim -> do

317− put $ state & skip %~ subtract i0Dim

317+ put $ state & skip -~ i0Dim

318 addMaybeClipped i1

319 _ -> fail $ name ++ " has unhandled skip class"

320

@@ -323,14 +323,14 @@ addUnclippedText a txt = do

323 let op = TextSpan a usedDisplayColumns

324 (fromIntegral $ TL.length txt)

325 txt

326− usedDisplayColumns = wctlwidth txt

326+ usedDisplayColumns = wcswidth $ TL.unpack txt

327 use rowOffset >>= snocOp op

328

329addRowCompletion :: DisplayRegion -> Int -> BlitM s ()

330addRowCompletion displayRegion row = do

331 allRowOps <- view mrowOps

332 rowOps <- lift $ lift $ MVector.read allRowOps row

333− let endX = spanOpsAffectedColumns rowOps

333+ let endX = spanOpsEffectedColumns rowOps

334 when (endX < regionWidth displayRegion) $ do

335 let ow = regionWidth displayRegion - endX

336 snocOp (Skip ow) row

@@ -343,6 +343,12 @@ snocOp !op !row = do

343 lift $ lift $ do

344 ops <- MVector.read theMrowOps row

345 let ops' = Vector.snoc ops op

346− when (spanOpsAffectedColumns ops' > regionWidth theRegion)

346+ when (spanOpsEffectedColumns ops' > regionWidth theRegion)

347 $ fail $ "row " ++ show row ++ " now exceeds region width"

348 MVector.write theMrowOps row ops'

349+

350+(-~) :: Num a => ASetter s t a a -> a -> s -> t

351+l -~ n = over l (subtract n)

352+

353+(+~) :: Num a => ASetter s t a a -> a -> s -> t

354+l +~ n = over l (n +)

src/Graphics/Vty/Span.hs+40−33

@@ -1,12 +1,15 @@

1-- Copyright Corey O'Connor

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

3-- | A picture is translated into a sequences of state changes and

5-- | A picture is translated into a sequences of state changes and

6+-- character spans. State changes are currently limited to new attribute

4−-- character spans. The attribute is applied to all following spans,

7+-- values. The attribute is applied to all following spans. Including

5−-- including spans of the next row. The nth element of the sequence

8+-- spans of the next row. The nth element of the sequence represents the

6−-- represents the nth row (from top to bottom) of the picture to render.

9+-- nth row (from top to bottom) of the picture to render.

7--

10--

8-- A span op sequence will be defined for all rows and columns (and no

11-- A span op sequence will be defined for all rows and columns (and no

9−-- more) of the region provided with the picture to 'spansForPic'.

12+-- more) of the region provided with the picture to `spansForPic`.

10module Graphics.Vty.Span where

13module Graphics.Vty.Span where

12import Graphics.Vty.Attributes (Attr)

15import Graphics.Vty.Attributes (Attr)

@@ -17,40 +20,42 @@ import qualified Data.Text.Lazy as TL

17import Data.Vector (Vector)

20import Data.Vector (Vector)

18import qualified Data.Vector as Vector

21import qualified Data.Vector as Vector

20−-- | This represents an operation on the terminal: either an attribute

23+-- | This represents an operation on the terminal. Either an attribute

21-- change or the output of a text string.

24-- change or the output of a text string.

22data SpanOp =

25data SpanOp =

23− -- | A span of UTF-8 text occupies a specific number of screen space

26+ -- | a span of UTF-8 text occupies a specific number of screen space

24− -- columns. A single UTF character does not necessarily represent 1

27+ -- columns. A single UTF character does not necessarially represent

25− -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width

28+ -- 1 colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output

26− -- in columns] [number of characters] [data]

29+ -- width in columns] [number of characters] [data]

27 TextSpan

30 TextSpan

28 { textSpanAttr :: !Attr

31 { textSpanAttr :: !Attr

29 , textSpanOutputWidth :: !Int

32 , textSpanOutputWidth :: !Int

30 , textSpanCharWidth :: !Int

33 , textSpanCharWidth :: !Int

31 , textSpanText :: DisplayText

34 , textSpanText :: DisplayText

32 }

35 }

33− -- | Skips the given number of columns.

36+ -- | Skips the given number of columns

37+ -- A skip is transparent.... maybe? I am not sure how attribute

38+ -- changes interact.

34 | Skip !Int

39 | Skip !Int

35− -- | Marks the end of a row. Specifies how many columns are

40+ -- | Marks the end of a row. specifies how many columns are

36 -- remaining. These columns will not be explicitly overwritten with

41 -- remaining. These columns will not be explicitly overwritten with

37 -- the span ops. The terminal is require to assure the remaining

42 -- the span ops. The terminal is require to assure the remaining

38 -- columns are clear.

43 -- columns are clear.

39 | RowEnd !Int

44 | RowEnd !Int

40 deriving Eq

45 deriving Eq

42−-- | A vector of span operations executed in succession. This represents

47+-- | vector of span operations. executed in succession. This represents

43-- the operations required to render a row of the terminal. The

48-- the operations required to render a row of the terminal. The

44−-- operations in one row may affect subsequent rows. For example,

49+-- operations in one row may effect subsequent rows.

45−-- setting the foreground color in one row will affect all subsequent

50+-- EG: Setting the foreground color in one row will effect all

46−-- rows until the foreground color is changed.

51+-- subsequent rows until the foreground color is changed.

47type SpanOps = Vector SpanOp

52type SpanOps = Vector SpanOp

49dropOps :: Int -> SpanOps -> SpanOps

54dropOps :: Int -> SpanOps -> SpanOps

50dropOps w = snd . splitOpsAt w

55dropOps w = snd . splitOpsAt w

52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)

57splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)

53−splitOpsAt = splitOpsAt'

58+splitOpsAt inW inOps = splitOpsAt' inW inOps

54 where

59 where

55 splitOpsAt' 0 ops = (Vector.empty, ops)

60 splitOpsAt' 0 ops = (Vector.empty, ops)

56 splitOpsAt' remainingColumns ops = case Vector.head ops of

61 splitOpsAt' remainingColumns ops = case Vector.head ops of

@@ -82,7 +87,7 @@ splitOpsAt = splitOpsAt'

82 )

87 )

83 RowEnd _ -> error "cannot split ops containing a row end"

88 RowEnd _ -> error "cannot split ops containing a row end"

85−-- | A vector of span operation vectors for display, one per row of the

90+-- | vector of span operation vectors for display. One per row of the

86-- output region.

91-- output region.

87type DisplayOps = Vector SpanOps

92type DisplayOps = Vector SpanOps

@@ -91,39 +96,41 @@ instance Show SpanOp where

91 show (Skip ow) = "Skip(" ++ show ow ++ ")"

96 show (Skip ow) = "Skip(" ++ show ow ++ ")"

92 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"

97 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"

94−-- | The number of columns the DisplayOps are defined for.

99+-- | Number of columns the DisplayOps are defined for

95--

100--

96−-- All spans are verified to define same number of columns.

101+-- All spans are verified to define same number of columns. See:

102+-- VerifySpanOps

97displayOpsColumns :: DisplayOps -> Int

103displayOpsColumns :: DisplayOps -> Int

98displayOpsColumns ops

104displayOpsColumns ops

99 | Vector.length ops == 0 = 0

105 | Vector.length ops == 0 = 0

100 | otherwise = Vector.length $ Vector.head ops

106 | otherwise = Vector.length $ Vector.head ops

101

107

102−-- | The number of rows the DisplayOps are defined for.

108+-- | Number of rows the DisplayOps are defined for

103displayOpsRows :: DisplayOps -> Int

109displayOpsRows :: DisplayOps -> Int

104−displayOpsRows = Vector.length

110+displayOpsRows ops = Vector.length ops

105

111

106−affectedRegion :: DisplayOps -> DisplayRegion

112+effectedRegion :: DisplayOps -> DisplayRegion

107−affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)

113+effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)

108

114

109−-- | The number of columns a SpanOps affects.

115+-- | The number of columns a SpanOps effects.

110−spanOpsAffectedColumns :: SpanOps -> Int

116+spanOpsEffectedColumns :: SpanOps -> Int

111−spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps

117+spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps

112 where

118 where

113− spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w

119+ spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w

114− spanOpsAffectedColumns' t (Skip w) = t + w

120+ spanOpsEffectedColumns' t (Skip w) = t + w

115− spanOpsAffectedColumns' t (RowEnd w) = t + w

121+ spanOpsEffectedColumns' t (RowEnd w) = t + w

116

122

117−-- | The width of a single SpanOp in columns.

123+-- | The width of a single SpanOp in columns

118spanOpHasWidth :: SpanOp -> Maybe (Int, Int)

124spanOpHasWidth :: SpanOp -> Maybe (Int, Int)

119spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)

125spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)

120spanOpHasWidth (Skip ow) = Just (ow,ow)

126spanOpHasWidth (Skip ow) = Just (ow,ow)

121spanOpHasWidth (RowEnd ow) = Just (ow,ow)

127spanOpHasWidth (RowEnd ow) = Just (ow,ow)

122

128

123−-- | The number of columns to the character at the given position in the

129+-- | returns the number of columns to the character at the given

124−-- span op.

130+-- position in the span op

125columnsToCharOffset :: Int -> SpanOp -> Int

131columnsToCharOffset :: Int -> SpanOp -> Int

126columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =

132columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =

127− wctlwidth (TL.take (fromIntegral cx) utf8Str)

133+ let str = TL.unpack utf8Str

134+ in wcswidth (take cx str)

128columnsToCharOffset cx (Skip _) = cx

135columnsToCharOffset cx (Skip _) = cx

129columnsToCharOffset cx (RowEnd _) = cx

136columnsToCharOffset cx (RowEnd _) = cx

src/Graphics/Vty/UnicodeWidthTable/IO.hsdeleted−105

@@ -1,105 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Graphics.Vty.UnicodeWidthTable.IO

3− ( readUnicodeWidthTable

4− , parseUnicodeWidthTable

5− , writeUnicodeWidthTable

6− )

7−where

8−

9−import Control.Monad (when, forM)

10−import Data.Binary

11−import Data.Binary.Get

12−import Data.Binary.Put

13−import qualified Data.ByteString.Lazy as BSL

14−#if !(MIN_VERSION_base(4,11,0))

15−import Data.Semigroup ((<>))

16−#endif

17−

18−import Graphics.Vty.UnicodeWidthTable.Types

19−

20−-- | Load a binary unicode width table from the specified file.

21−--

22−-- This either returns a successfully parsed table or a table parsing

23−-- error message. This does not handle I/O exceptions.

24−readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)

25−readUnicodeWidthTable path = parseUnicodeWidthTable <$> BSL.readFile path

26−

27−-- | Parse a binary unicode width table.

28−parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable

29−parseUnicodeWidthTable bs =

30− case runGetOrFail tableParser bs of

31− Left (_, _, msg) ->

32− Left msg

33−

34− -- Even if we parsed a table, leftover bytes indicate something

35− -- could be wrong.

36− Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->

37− Left $ "Error: " <> show (BSL.length remainingBytes) <>

38− " byte(s) left unconsumed"

39−

40− Right (_, _, table) ->

41− Right table

42−

43−-- | Write the unicode width table to the specified path.

44−--

45−-- This does not handle I/O exceptions.

46−writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()

47−writeUnicodeWidthTable path table = do

48− let body = runPut (tableV1Writer table)

49− BSL.writeFile path body

50−

51−-- | Width table magic bytes for use in the binary format.

52−widthTableMagic :: Word32

53−widthTableMagic = 0xc1a9f7e0

54−

55−tableParser :: Get UnicodeWidthTable

56−tableParser = do

57− magic <- getWord32le

58−

59− when (magic /= widthTableMagic) $

60− fail "Table magic number invalid"

61−

62− version <- getWord8

63−

64− case version of

65− 1 -> tableV1Parser

66− _ -> fail "Table version invalid"

67−

68−tableV1Parser :: Get UnicodeWidthTable

69−tableV1Parser = do

70− numRanges <- getWord32le

71−

72− let parseRange = do

73− start <- getWord32le

74− size <- getWord32le

75− cols <- getWord8

76− return WidthTableRange { rangeStart = start

77− , rangeSize = size

78− , rangeColumns = cols

79− }

80−

81− ranges <- forM [1..numRanges] $ const parseRange

82−

83− return UnicodeWidthTable { unicodeWidthTableRanges = ranges

84− }

85−

86−tableV1Writer :: UnicodeWidthTable -> Put

87−tableV1Writer table = do

88− -- Magic bytes

89− putWord32le widthTableMagic

90−

91− -- Version

92− putWord8 1

93−

94− -- Number of ranges

95− let ranges = unicodeWidthTableRanges table

96− let numRanges = length ranges

97− putWord32le (fromIntegral numRanges)

98−

99− -- Ranges

100− let putRange r = do

101− putWord32le $ rangeStart r

102− putWord32le $ rangeSize r

103− putWord8 $ rangeColumns r

104−

105− mapM_ putRange ranges

src/Graphics/Vty/UnicodeWidthTable/Install.hsdeleted−129

@@ -1,129 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ForeignFunctionInterface #-}

3−module Graphics.Vty.UnicodeWidthTable.Install

4− ( TableInstallException(..)

5− , installUnicodeWidthTable

6− , isCustomTableReady

7− )

8−where

9−

10−import Control.Monad (when, forM_)

11−import qualified Control.Exception as E

12−import GHC.Conc.Sync (withMVar)

13−import Control.Concurrent.MVar (MVar, newMVar)

14−import Data.Word (Word8, Word32)

15−#if !(MIN_VERSION_base(4,11,0))

16−import Data.Semigroup ((<>))

17−#endif

18−import System.IO.Unsafe (unsafePerformIO)

19−

20−import Graphics.Vty.UnicodeWidthTable.Types

21−

22−-- | The lock used to make functions in this module thread-safe.

23−installLock :: MVar ()

24−{-# NOINLINE installLock #-}

25−installLock = unsafePerformIO $ newMVar ()

26−

27−-- | Returns True if and only if a custom table has been allocated and

28−-- marked as ready for use.

29−--

30−-- This function is thread-safe.

31−isCustomTableReady :: IO Bool

32−isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady

33−

34−withInstallLock :: IO a -> IO a

35−withInstallLock act = withMVar installLock $ const act

36−

37−-- This is the size of the allocated custom character width table, in

38−-- character slots. It's important that this be large enough to hold all

39−-- possible Unicode character values. At the time of this writing, the

40−-- valid Unicode range is 0 - 0x10ffff, hence this value.

41−tableSize :: Int

42−tableSize = 0x110000

43−

44−-- | Exception type raised by 'installUnicodeWidthTable'.

45−data TableInstallException =

46− TableInitFailure Int Int

47− -- ^ The width table could not be initialized. Args: failure status,

48− -- requested table size.

49− | TableRangeFailure Int WidthTableRange

50− -- ^ A code point range could not be configured. Args: failure

51− -- status, offending range.

52− | TableActivationFailure Int

53− -- ^ The table could not be activated. Args: failure status.

54− deriving (Eq, Show)

55−

56−instance E.Exception TableInstallException

57−

58−-- | Install a custom unicode character width

59−-- table. Such tables are obtained with

60−-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and

61−-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.

62−--

63−-- ALERT! This function is probably not what you want to use because

64−-- it is automatically called by 'Graphics.Vty.mkVty'. You will only

65−-- ever need to call this function if you want to use functions

66−-- in 'Graphics.Text.Width' without controlling the terminal with

67−-- 'Graphics.Vty.mkVty'.

68−--

69−-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'

70−-- function and functions that call it. It does so by

71−-- changing global state available to the C implementation

72−-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your

73−-- program gets consistent results from evaluating calls to

74−-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table

75−-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in

76−-- your program.

77−--

78−-- This is best done at Vty startup, and if you use

79−-- 'Graphics.Vty.mkVty', that function calls this automatically based on

80−-- the Vty configuration's declared width tables. It is exposed as part

81−-- of the public API so that applications can call this as needed if

82−-- they don't want to control the terminal with 'mkVty' but do want to

83−-- make calls to 'Graphics.Vty.Image.wcwidth'.

84−--

85−-- It's also important to note that once a custom table has been

86−-- installed, it is permanent for the life of the process. No new table

87−-- can be installed, and the new custom table cannot be removed.

88−--

89−-- If this function fails for any reason -- if the table cannot be

90−-- installed or is invalid, or if a custom table already exists -- this

91−-- will raise a 'TableInstallException' exception.

92−--

93−-- This function is thread-safe.

94−installUnicodeWidthTable :: UnicodeWidthTable -> IO ()

95−installUnicodeWidthTable table = withInstallLock $ do

96− initResult <- initCustomTable tableSize

97− when (initResult /= 0) $

98− E.throwIO $ TableInitFailure initResult tableSize

99−

100− forM_ (unicodeWidthTableRanges table) $ \r -> do

101− result <- setCustomTableRange (rangeStart r)

102− (rangeSize r)

103− (rangeColumns r)

104−

105− when (result /= 0) $ do

106− deallocateCustomTable

107− E.throwIO $ TableRangeFailure result r

108−

109− actResult <- activateCustomTable

110− when (actResult /= 0) $

111− E.throwIO $ TableActivationFailure actResult

112−

113−------------------------------------------------------------------------

114−-- C imports

115−

116−foreign import ccall unsafe "vty_init_custom_table"

117− initCustomTable :: Int -> IO Int

118−

119−foreign import ccall unsafe "vty_set_custom_table_range"

120− setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int

121−

122−foreign import ccall unsafe "vty_activate_custom_table"

123− activateCustomTable :: IO Int

124−

125−foreign import ccall unsafe "vty_custom_table_ready"

126− c_isCustomTableReady :: IO Int

127−

128−foreign import ccall unsafe "vty_deallocate_custom_table"

129− deallocateCustomTable :: IO ()

src/Graphics/Vty/UnicodeWidthTable/Query.hsdeleted−79

@@ -1,79 +0,0 @@

1−{-# LANGUAGE TupleSections #-}

2−module Graphics.Vty.UnicodeWidthTable.Query

3− ( buildUnicodeWidthTable

4− , defaultUnicodeTableUpperBound

5− )

6−where

7−

8−import Control.Monad (forM)

9−import Data.Char (generalCategory, GeneralCategory(..))

10−import System.Console.ANSI (getCursorPosition)

11−import Text.Printf (printf)

12−

13−import Graphics.Vty.UnicodeWidthTable.Types

14−

15−shouldConsider :: Char -> Bool

16−shouldConsider c =

17− case generalCategory c of

18− Control -> False

19− NotAssigned -> False

20− Surrogate -> False

21− _ -> True

22−

23−charWidth :: Char -> IO Int

24−charWidth c = do

25− printf "\r"

26− putChar c

27− Just (_, col) <- getCursorPosition

28− return col

29−

30−-- | Convert a sequence of character/width pairs into a list of

31−-- run-length encoded ranges. This function assumes the pairs come

32−-- sorted by character ordinal value. It does not require that the

33−-- character range is fully covered by the sequence.

34−--

35−-- The result of this function is a list of ranges in reverse order

36−-- relative to the input sequence.

37−mkRanges :: [(Char, Int)] -> [WidthTableRange]

38−mkRanges pairs =

39− let convertedPairs = convert <$> pairs

40− convert (c, i) = (fromIntegral $ fromEnum c, fromIntegral i)

41−

42− go Nothing finishedRanges [] = finishedRanges

43− go (Just r) finishedRanges [] = r:finishedRanges

44−

45− go Nothing finishedRanges ((c, width):rest) =

46− go (Just $ WidthTableRange c 1 width) finishedRanges rest

47−

48− go (Just r@(WidthTableRange prevCh sz prevWidth)) finishedRanges ((c, width):rest) =

49− if c == prevCh + sz && prevWidth == width

50− then go (Just (WidthTableRange prevCh (sz + 1) prevWidth)) finishedRanges rest

51− else go (Just (WidthTableRange c 1 width)) (r:finishedRanges) rest

52−

53− in go Nothing [] convertedPairs

54−

55−-- The uppermost code point to consider when building Unicode width

56−-- tables.

57−defaultUnicodeTableUpperBound :: Char

58−defaultUnicodeTableUpperBound = '\xe0000'

59−

60−-- | Construct a unicode character width table by querying the terminal

61−-- connected to stdout. This works by emitting characters to stdout

62−-- and then querying the terminal to determine the resulting cursor

63−-- position in order to measure character widths. Consequently this will

64−-- generate a lot of output and may take a while, depending on your

65−-- system performance. This should not be run in a terminal while it is

66−-- controlled by Vty.

67−--

68−-- The argument specifies the upper bound code point to test when

69−-- building the table. This allows callers to decide how much of the

70−-- Unicode code point space to scan when building the table.

71−--

72−-- This does not handle exceptions.

73−buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable

74−buildUnicodeWidthTable tableUpperBound = do

75− pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i ->

76− (i,) <$> charWidth i

77−

78− return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs

79− }

src/Graphics/Vty/UnicodeWidthTable/Types.hsdeleted−29

@@ -1,29 +0,0 @@

1−module Graphics.Vty.UnicodeWidthTable.Types

2− ( UnicodeWidthTable(..)

3− , WidthTableRange(..)

4− )

5−where

6−

7−import Data.Word (Word8, Word32)

8−

9−-- | A range of code points in a width table.

10−data WidthTableRange =

11− WidthTableRange { rangeStart :: Word32

12− -- ^ The range's starting code point.

13− , rangeSize :: Word32

14− -- ^ The number of code points in the contiguous

15− -- range, beginning with the starting code point

16− -- ('rangeStart').

17− , rangeColumns :: Word8

18− -- ^ The terminal width, in columns, of all of the

19− -- characters corresponding to the code points in

20− -- this range.

21− }

22− deriving (Eq, Show)

23−

24−-- | A run-length-encoded table of Unicode character widths.

25−data UnicodeWidthTable =

26− UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]

27− -- ^ The ranges in the table.

28− }

29− deriving (Show)

test/BenchImageFuzz.hs+3−1

@@ -8,6 +8,8 @@ import Verify

8import Control.Applicative

9import Control.Monad

11+import Data.Default (def)

12+

11import System.Random

13import System.Random

13rand :: Arbitrary a => IO a

15rand :: Arbitrary a => IO a

@@ -19,7 +21,7 @@ randomImage = rand

19randomPicture = picForImage <$> randomImage

21randomPicture = picForImage <$> randomImage

21bench0 = do

23bench0 = do

22− vty <- mkVty defaultConfig

24+ vty <- mkVty def

23 (w,h) <- displayBounds $ outputIface vty

25 (w,h) <- displayBounds $ outputIface vty

24 let pictures = replicateM 3000 randomPicture

26 let pictures = replicateM 3000 randomPicture

25 bench ps = do

27 bench ps = do

test/BenchNoDiffOpt.hs+2−1

@@ -9,6 +9,7 @@ import Control.Concurrent( threadDelay )

9import Control.Monad( liftM2 )

11import qualified Data.ByteString.Char8 as B

12+import Data.Default (def)

12import Data.List

13import Data.List

14import System.Environment( getArgs )

15import System.Environment( getArgs )

@@ -18,7 +19,7 @@ import System.Random

18bench0 = do

19bench0 = do

19 let fixedGen = mkStdGen 0

20 let fixedGen = mkStdGen 0

20 setStdGen fixedGen

21 setStdGen fixedGen

21− vty <- mkVty defaultConfig

22+ vty <- mkVty def

22 (w,h) <- displayBounds $ outputIface vty

23 (w,h) <- displayBounds $ outputIface vty

23 let images = return $ (image0, image1)

24 let images = return $ (image0, image1)

24 image0 = charFill defAttr 'X' w h

25 image0 = charFill defAttr 'X' w h

test/BenchRenderChar.hs+4−2

@@ -9,8 +9,10 @@ import Verify

10import Control.Monad ( forM_ )

12+import Data.Default (def)

13+

12bench0 = do

14bench0 = do

13− vty <- mkVty defaultConfig

15+ vty <- mkVty def

14 (w,h) <- displayBounds $ outputIface vty

16 (w,h) <- displayBounds $ outputIface vty

15 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

17 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

16 bench d = do

18 bench d = do

@@ -26,7 +28,7 @@ testImageUsingChar c w h

26 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)

28 $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)

28bench1 = do

30bench1 = do

29− vty <- mkVty defaultConfig

31+ vty <- mkVty def

30 (w,h) <- displayBounds $ outputIface vty

32 (w,h) <- displayBounds $ outputIface vty

31 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

33 let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

32 bench d = do

34 bench d = do

test/BenchVerticalScroll.hs+2−1

@@ -6,6 +6,7 @@ import Verify

6import Control.Concurrent( threadDelay )

7import Control.Monad( liftM2 )

9+import Data.Default (def)

9import Data.List

10import Data.List

10import Data.Word

11import Data.Word

@@ -16,7 +17,7 @@ import System.Random

16bench0 = do

17bench0 = do

17 let fixedGen = mkStdGen 0

18 let fixedGen = mkStdGen 0

18 setStdGen fixedGen

19 setStdGen fixedGen

19− return $ Bench (return ()) (\() -> mkVty defaultConfig >>= liftM2 (>>) run shutdown)

20+ return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)

21run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)

22run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)

test/EventEcho.hs+2−1

@@ -6,6 +6,7 @@ import Control.Applicative

6import Control.Arrow

7import Control.Monad.RWS

9+import Data.Default (def)

9import Data.Sequence (Seq, (<|) )

10import Data.Sequence (Seq, (<|) )

10import qualified Data.Sequence as Seq

11import qualified Data.Sequence as Seq

11import Data.Foldable

12import Data.Foldable

@@ -15,7 +16,7 @@ eventBufferSize = 1000

15type App = RWST Vty () (Seq String) IO

16type App = RWST Vty () (Seq String) IO

17main = do

18main = do

18− vty <- mkVty defaultConfig

19+ vty <- mkVty def

19 _ <- execRWST (vtyInteract False) vty Seq.empty

20 _ <- execRWST (vtyInteract False) vty Seq.empty

20 shutdown vty

21 shutdown vty

test/MinimalExample.hs+3−1

@@ -2,8 +2,10 @@ module Main where

3import Graphics.Vty

5+import Data.Default

5main = do

7main = do

6− vty <- mkVty defaultConfig

8+ vty <- mkVty def

7 let line0 = string (def `withForeColor` green) "first line"

9 let line0 = string (def `withForeColor` green) "first line"

8 line1 = string (def `withBackColor` blue) "second line"

10 line1 = string (def `withBackColor` blue) "second line"

9 img = line0 <-> line1

11 img = line0 <-> line1

test/Rogue.hs+3−1

@@ -1,8 +1,10 @@

1+{-# LANGUAGE TemplateHaskell #-}

1module Main where

2module Main where

3import Graphics.Vty

4import Graphics.Vty

5import Data.Array

6import Data.Array

7+import Data.Default (def)

7import Control.Applicative

9import Control.Applicative

8import Control.Monad

10import Control.Monad

@@ -41,7 +43,7 @@ type Coord = (Int, Int)

42main :: IO ()

44main :: IO ()

43main = do

45main = do

44− vty <- mkVty defaultConfig

46+ vty <- mkVty def

45 level0 <- mkLevel 1

47 level0 <- mkLevel 1

46 let world0 = World (Player (levelStart level0)) level0

48 let world0 = World (Player (levelStart level0)) level0

47 (_finalWorld, ()) <- execRWST play vty world0

49 (_finalWorld, ()) <- execRWST play vty world0

test/Verify/Graphics/Vty/Span.hs+1−1

@@ -20,7 +20,7 @@ isAttrSpanOp TextSpan {} = True

20isAttrSpanOp _ = False

22verifyAllSpansHaveWidth i spans w

23− = let v = map (\s -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)

23+ = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)

24 in case any ((== True) . fst) v of

25 False -> succeeded

26 True -> failed { reason = "Not all spans contained operations defining exactly "

test/VerifyAttributeOps.hsnew file+9

@@ -0,0 +1,9 @@

1+module VerifyAttributeOps where

3+import Verify.Graphics.Vty.Attributes

5+import Verify

7+tests :: IO [Test]

8+tests = return []

test/VerifyColor240.hsdeleted−269

@@ -1,269 +0,0 @@

1−module VerifyColor240 where

2−

3−import Data.Word(Word8)

4−import Verify

5−

6−import Graphics.Vty.Attributes.Color240(rgbColorToColor240)

7−

8−oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8

9−oldRgbColorToColor240 r g b

10− | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"

11− | r == 8 && g == 8 && b == 8 = 216

12− | r == 18 && g == 18 && b == 18 = 217

13− | r == 28 && g == 28 && b == 28 = 218

14− | r == 38 && g == 38 && b == 38 = 219

15− | r == 48 && g == 48 && b == 48 = 220

16− | r == 58 && g == 58 && b == 58 = 221

17− | r == 68 && g == 68 && b == 68 = 222

18− | r == 78 && g == 78 && b == 78 = 223

19− | r == 88 && g == 88 && b == 88 = 224

20− | r == 98 && g == 98 && b == 98 = 225

21− | r == 108 && g == 108 && b == 108 = 226

22− | r == 118 && g == 118 && b == 118 = 227

23− | r == 128 && g == 128 && b == 128 = 228

24− | r == 138 && g == 138 && b == 138 = 229

25− | r == 148 && g == 148 && b == 148 = 230

26− | r == 158 && g == 158 && b == 158 = 231

27− | r == 168 && g == 168 && b == 168 = 232

28− | r == 178 && g == 178 && b == 178 = 233

29− | r == 188 && g == 188 && b == 188 = 234

30− | r == 198 && g == 198 && b == 198 = 235

31− | r == 208 && g == 208 && b == 208 = 236

32− | r == 218 && g == 218 && b == 218 = 237

33− | r == 228 && g == 228 && b == 228 = 238

34− | r == 238 && g == 238 && b == 238 = 239

35− | r <= 0 && g <= 0 && b <= 0 = 0

36− | r <= 0 && g <= 0 && b <= 95 = 1

37− | r <= 0 && g <= 0 && b <= 135 = 2

38− | r <= 0 && g <= 0 && b <= 175 = 3

39− | r <= 0 && g <= 0 && b <= 215 = 4

40− | r <= 0 && g <= 0 && b <= 255 = 5

41− | r <= 0 && g <= 95 && b <= 0 = 6

42− | r <= 0 && g <= 95 && b <= 95 = 7

43− | r <= 0 && g <= 95 && b <= 135 = 8

44− | r <= 0 && g <= 95 && b <= 175 = 9

45− | r <= 0 && g <= 95 && b <= 215 = 10

46− | r <= 0 && g <= 95 && b <= 255 = 11

47− | r <= 0 && g <= 135 && b <= 0 = 12

48− | r <= 0 && g <= 135 && b <= 95 = 13

49− | r <= 0 && g <= 135 && b <= 135 = 14

50− | r <= 0 && g <= 135 && b <= 175 = 15

51− | r <= 0 && g <= 135 && b <= 215 = 16

52− | r <= 0 && g <= 135 && b <= 255 = 17

53− | r <= 0 && g <= 175 && b <= 0 = 18

54− | r <= 0 && g <= 175 && b <= 95 = 19

55− | r <= 0 && g <= 175 && b <= 135 = 20

56− | r <= 0 && g <= 175 && b <= 175 = 21

57− | r <= 0 && g <= 175 && b <= 215 = 22

58− | r <= 0 && g <= 175 && b <= 255 = 23

59− | r <= 0 && g <= 215 && b <= 0 = 24

60− | r <= 0 && g <= 215 && b <= 95 = 25

61− | r <= 0 && g <= 215 && b <= 135 = 26

62− | r <= 0 && g <= 215 && b <= 175 = 27

63− | r <= 0 && g <= 215 && b <= 215 = 28

64− | r <= 0 && g <= 215 && b <= 255 = 29

65− | r <= 0 && g <= 255 && b <= 0 = 30

66− | r <= 0 && g <= 255 && b <= 95 = 31

67− | r <= 0 && g <= 255 && b <= 135 = 32

68− | r <= 0 && g <= 255 && b <= 175 = 33

69− | r <= 0 && g <= 255 && b <= 215 = 34

70− | r <= 0 && g <= 255 && b <= 255 = 35

71− | r <= 95 && g <= 0 && b <= 0 = 36

72− | r <= 95 && g <= 0 && b <= 95 = 37

73− | r <= 95 && g <= 0 && b <= 135 = 38

74− | r <= 95 && g <= 0 && b <= 175 = 39

75− | r <= 95 && g <= 0 && b <= 215 = 40

76− | r <= 95 && g <= 0 && b <= 255 = 41

77− | r <= 95 && g <= 95 && b <= 0 = 42

78− | r <= 95 && g <= 95 && b <= 95 = 43

79− | r <= 95 && g <= 95 && b <= 135 = 44

80− | r <= 95 && g <= 95 && b <= 175 = 45

81− | r <= 95 && g <= 95 && b <= 215 = 46

82− | r <= 95 && g <= 95 && b <= 255 = 47

83− | r <= 95 && g <= 135 && b <= 0 = 48

84− | r <= 95 && g <= 135 && b <= 95 = 49

85− | r <= 95 && g <= 135 && b <= 135 = 50

86− | r <= 95 && g <= 135 && b <= 175 = 51

87− | r <= 95 && g <= 135 && b <= 215 = 52

88− | r <= 95 && g <= 135 && b <= 255 = 53

89− | r <= 95 && g <= 175 && b <= 0 = 54

90− | r <= 95 && g <= 175 && b <= 95 = 55

91− | r <= 95 && g <= 175 && b <= 135 = 56

92− | r <= 95 && g <= 175 && b <= 175 = 57

93− | r <= 95 && g <= 175 && b <= 215 = 58

94− | r <= 95 && g <= 175 && b <= 255 = 59

95− | r <= 95 && g <= 215 && b <= 0 = 60

96− | r <= 95 && g <= 215 && b <= 95 = 61

97− | r <= 95 && g <= 215 && b <= 135 = 62

98− | r <= 95 && g <= 215 && b <= 175 = 63

99− | r <= 95 && g <= 215 && b <= 215 = 64

100− | r <= 95 && g <= 215 && b <= 255 = 65

101− | r <= 95 && g <= 255 && b <= 0 = 66

102− | r <= 95 && g <= 255 && b <= 95 = 67

103− | r <= 95 && g <= 255 && b <= 135 = 68

104− | r <= 95 && g <= 255 && b <= 175 = 69

105− | r <= 95 && g <= 255 && b <= 215 = 70

106− | r <= 95 && g <= 255 && b <= 255 = 71

107− | r <= 135 && g <= 0 && b <= 0 = 72

108− | r <= 135 && g <= 0 && b <= 95 = 73

109− | r <= 135 && g <= 0 && b <= 135 = 74

110− | r <= 135 && g <= 0 && b <= 175 = 75

111− | r <= 135 && g <= 0 && b <= 215 = 76

112− | r <= 135 && g <= 0 && b <= 255 = 77

113− | r <= 135 && g <= 95 && b <= 0 = 78

114− | r <= 135 && g <= 95 && b <= 95 = 79

115− | r <= 135 && g <= 95 && b <= 135 = 80

116− | r <= 135 && g <= 95 && b <= 175 = 81

117− | r <= 135 && g <= 95 && b <= 215 = 82

118− | r <= 135 && g <= 95 && b <= 255 = 83

119− | r <= 135 && g <= 135 && b <= 0 = 84

120− | r <= 135 && g <= 135 && b <= 95 = 85

121− | r <= 135 && g <= 135 && b <= 135 = 86

122− | r <= 135 && g <= 135 && b <= 175 = 87

123− | r <= 135 && g <= 135 && b <= 215 = 88

124− | r <= 135 && g <= 135 && b <= 255 = 89

125− | r <= 135 && g <= 175 && b <= 0 = 90

126− | r <= 135 && g <= 175 && b <= 95 = 91

127− | r <= 135 && g <= 175 && b <= 135 = 92

128− | r <= 135 && g <= 175 && b <= 175 = 93

129− | r <= 135 && g <= 175 && b <= 215 = 94

130− | r <= 135 && g <= 175 && b <= 255 = 95

131− | r <= 135 && g <= 215 && b <= 0 = 96

132− | r <= 135 && g <= 215 && b <= 95 = 97

133− | r <= 135 && g <= 215 && b <= 135 = 98

134− | r <= 135 && g <= 215 && b <= 175 = 99

135− | r <= 135 && g <= 215 && b <= 215 = 100

136− | r <= 135 && g <= 215 && b <= 255 = 101

137− | r <= 135 && g <= 255 && b <= 0 = 102

138− | r <= 135 && g <= 255 && b <= 95 = 103

139− | r <= 135 && g <= 255 && b <= 135 = 104

140− | r <= 135 && g <= 255 && b <= 175 = 105

141− | r <= 135 && g <= 255 && b <= 215 = 106

142− | r <= 135 && g <= 255 && b <= 255 = 107

143− | r <= 175 && g <= 0 && b <= 0 = 108

144− | r <= 175 && g <= 0 && b <= 95 = 109

145− | r <= 175 && g <= 0 && b <= 135 = 110

146− | r <= 175 && g <= 0 && b <= 175 = 111

147− | r <= 175 && g <= 0 && b <= 215 = 112

148− | r <= 175 && g <= 0 && b <= 255 = 113

149− | r <= 175 && g <= 95 && b <= 0 = 114

150− | r <= 175 && g <= 95 && b <= 95 = 115

151− | r <= 175 && g <= 95 && b <= 135 = 116

152− | r <= 175 && g <= 95 && b <= 175 = 117

153− | r <= 175 && g <= 95 && b <= 215 = 118

154− | r <= 175 && g <= 95 && b <= 255 = 119

155− | r <= 175 && g <= 135 && b <= 0 = 120

156− | r <= 175 && g <= 135 && b <= 95 = 121

157− | r <= 175 && g <= 135 && b <= 135 = 122

158− | r <= 175 && g <= 135 && b <= 175 = 123

159− | r <= 175 && g <= 135 && b <= 215 = 124

160− | r <= 175 && g <= 135 && b <= 255 = 125

161− | r <= 175 && g <= 175 && b <= 0 = 126

162− | r <= 175 && g <= 175 && b <= 95 = 127

163− | r <= 175 && g <= 175 && b <= 135 = 128

164− | r <= 175 && g <= 175 && b <= 175 = 129

165− | r <= 175 && g <= 175 && b <= 215 = 130

166− | r <= 175 && g <= 175 && b <= 255 = 131

167− | r <= 175 && g <= 215 && b <= 0 = 132

168− | r <= 175 && g <= 215 && b <= 95 = 133

169− | r <= 175 && g <= 215 && b <= 135 = 134

170− | r <= 175 && g <= 215 && b <= 175 = 135

171− | r <= 175 && g <= 215 && b <= 215 = 136

172− | r <= 175 && g <= 215 && b <= 255 = 137

173− | r <= 175 && g <= 255 && b <= 0 = 138

174− | r <= 175 && g <= 255 && b <= 95 = 139

175− | r <= 175 && g <= 255 && b <= 135 = 140

176− | r <= 175 && g <= 255 && b <= 175 = 141

177− | r <= 175 && g <= 255 && b <= 215 = 142

178− | r <= 175 && g <= 255 && b <= 255 = 143

179− | r <= 215 && g <= 0 && b <= 0 = 144

180− | r <= 215 && g <= 0 && b <= 95 = 145

181− | r <= 215 && g <= 0 && b <= 135 = 146

182− | r <= 215 && g <= 0 && b <= 175 = 147

183− | r <= 215 && g <= 0 && b <= 215 = 148

184− | r <= 215 && g <= 0 && b <= 255 = 149

185− | r <= 215 && g <= 95 && b <= 0 = 150

186− | r <= 215 && g <= 95 && b <= 95 = 151

187− | r <= 215 && g <= 95 && b <= 135 = 152

188− | r <= 215 && g <= 95 && b <= 175 = 153

189− | r <= 215 && g <= 95 && b <= 215 = 154

190− | r <= 215 && g <= 95 && b <= 255 = 155

191− | r <= 215 && g <= 135 && b <= 0 = 156

192− | r <= 215 && g <= 135 && b <= 95 = 157

193− | r <= 215 && g <= 135 && b <= 135 = 158

194− | r <= 215 && g <= 135 && b <= 175 = 159

195− | r <= 215 && g <= 135 && b <= 215 = 160

196− | r <= 215 && g <= 135 && b <= 255 = 161

197− | r <= 215 && g <= 175 && b <= 0 = 162

198− | r <= 215 && g <= 175 && b <= 95 = 163

199− | r <= 215 && g <= 175 && b <= 135 = 164

200− | r <= 215 && g <= 175 && b <= 175 = 165

201− | r <= 215 && g <= 175 && b <= 215 = 166

202− | r <= 215 && g <= 175 && b <= 255 = 167

203− | r <= 215 && g <= 215 && b <= 0 = 168

204− | r <= 215 && g <= 215 && b <= 95 = 169

205− | r <= 215 && g <= 215 && b <= 135 = 170

206− | r <= 215 && g <= 215 && b <= 175 = 171

207− | r <= 215 && g <= 215 && b <= 215 = 172

208− | r <= 215 && g <= 215 && b <= 255 = 173

209− | r <= 215 && g <= 255 && b <= 0 = 174

210− | r <= 215 && g <= 255 && b <= 95 = 175

211− | r <= 215 && g <= 255 && b <= 135 = 176

212− | r <= 215 && g <= 255 && b <= 175 = 177

213− | r <= 215 && g <= 255 && b <= 215 = 178

214− | r <= 215 && g <= 255 && b <= 255 = 179

215− | r <= 255 && g <= 0 && b <= 0 = 180

216− | r <= 255 && g <= 0 && b <= 95 = 181

217− | r <= 255 && g <= 0 && b <= 135 = 182

218− | r <= 255 && g <= 0 && b <= 175 = 183

219− | r <= 255 && g <= 0 && b <= 215 = 184

220− | r <= 255 && g <= 0 && b <= 255 = 185

221− | r <= 255 && g <= 95 && b <= 0 = 186

222− | r <= 255 && g <= 95 && b <= 95 = 187

223− | r <= 255 && g <= 95 && b <= 135 = 188

224− | r <= 255 && g <= 95 && b <= 175 = 189

225− | r <= 255 && g <= 95 && b <= 215 = 190

226− | r <= 255 && g <= 95 && b <= 255 = 191

227− | r <= 255 && g <= 135 && b <= 0 = 192

228− | r <= 255 && g <= 135 && b <= 95 = 193

229− | r <= 255 && g <= 135 && b <= 135 = 194

230− | r <= 255 && g <= 135 && b <= 175 = 195

231− | r <= 255 && g <= 135 && b <= 215 = 196

232− | r <= 255 && g <= 135 && b <= 255 = 197

233− | r <= 255 && g <= 175 && b <= 0 = 198

234− | r <= 255 && g <= 175 && b <= 95 = 199

235− | r <= 255 && g <= 175 && b <= 135 = 200

236− | r <= 255 && g <= 175 && b <= 175 = 201

237− | r <= 255 && g <= 175 && b <= 215 = 202

238− | r <= 255 && g <= 175 && b <= 255 = 203

239− | r <= 255 && g <= 215 && b <= 0 = 204

240− | r <= 255 && g <= 215 && b <= 95 = 205

241− | r <= 255 && g <= 215 && b <= 135 = 206

242− | r <= 255 && g <= 215 && b <= 175 = 207

243− | r <= 255 && g <= 215 && b <= 215 = 208

244− | r <= 255 && g <= 215 && b <= 255 = 209

245− | r <= 255 && g <= 255 && b <= 0 = 210

246− | r <= 255 && g <= 255 && b <= 95 = 211

247− | r <= 255 && g <= 255 && b <= 135 = 212

248− | r <= 255 && g <= 255 && b <= 175 = 213

249− | r <= 255 && g <= 255 && b <= 215 = 214

250− | r <= 255 && g <= 255 && b <= 255 = 215

251− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."

252− (fromIntegral r :: Int)

253− (fromIntegral g :: Int)

254− (fromIntegral b :: Int))

255−

256−sameColor :: Int -> Int -> Int -> Bool

257−sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b

258−

259−genVal :: Gen Int

260−genVal = chooseInt (0, 255)

261−

262−sameColorCheck :: Property

263−sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g)))

264−

265−tests :: IO [Test]

266−tests = return

267− [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck

268− ]

269−

test/VerifyEmptyImageProps.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyEmptyImageProps where

1module VerifyEmptyImageProps where

4import Verify

3import Verify

test/VerifyEvalTerminfoCaps.hs−1

@@ -1,6 +1,5 @@

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4module VerifyEvalTerminfoCaps where

3module VerifyEvalTerminfoCaps where

6import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)

5import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)

test/VerifyImageOps.hs+1−2

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyImageOps where

1module VerifyImageOps where

4import Graphics.Vty.Attributes

3import Graphics.Vty.Attributes

@@ -137,7 +136,7 @@ cropBottomLimitsHeight :: Image -> Int -> Property

137cropBottomLimitsHeight i v = v >= 0 ==>

136cropBottomLimitsHeight i v = v >= 0 ==>

138 v >= imageHeight (cropBottom v i)

137 v >= imageHeight (cropBottom v i)

139

138

140−-- ridiculous tests just to satisfy my desire for nice code coverage :-P

139+-- rediculous tests just to satisfy my desire for nice code coverage :-P

141canShowImage :: Image -> Bool

140canShowImage :: Image -> Bool

142canShowImage i = length (show i) > 0

141canShowImage i = length (show i) > 0

143

142

test/VerifyOutput.hs+3−7

@@ -1,7 +1,6 @@

1−-- We setup the environment to invoke certain terminals of interest.

1+-- We setup the environment to envoke certain terminals of interest.

2-- This assumes appropriate definitions exist in the current environment

3-- for the terminals of interest.

4−{-# LANGUAGE ScopedTypeVariables #-}

5module VerifyOutput where

4module VerifyOutput where

7import Verify

6import Verify

@@ -14,6 +13,7 @@ import Verify.Graphics.Vty.Output

14import Control.Monad

13import Control.Monad

16import qualified System.Console.Terminfo as Terminfo

15import qualified System.Console.Terminfo as Terminfo

16+import System.Posix.Env

17import System.Posix.IO

19tests :: IO [Test]

@@ -35,11 +35,7 @@ smokeTestTermNonMac termName i = liftIOResult $ do

35smokeTestTerm :: String -> Image -> IO Result

36smokeTestTerm termName i = do

37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags

38− t <- outputForConfig $ defaultConfig

38+ t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName }

39− { outputFd = Just nullOut

40− , termName = Just termName

41− , colorMode = Just NoColor

42− }

43 -- putStrLn $ "context color count: " ++ show (contextColorCount t)

39 -- putStrLn $ "context color count: " ++ show (contextColorCount t)

44 reserveDisplay t

40 reserveDisplay t

45 dc <- displayContext t (100,100)

41 dc <- displayContext t (100,100)

test/VerifyParseTerminfoCaps.hs−1

@@ -1,5 +1,4 @@

1{-# LANGUAGE NamedFieldPuns #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3module VerifyParseTerminfoCaps where

2module VerifyParseTerminfoCaps where

5import Prelude hiding ( catch )

4import Prelude hiding ( catch )

test/VerifySimpleSpanGeneration.hs+8−8

@@ -25,7 +25,7 @@ unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool

25unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =

26 let p = picForImage i

27 ops = displayOpsForPic p (regionForWindow w)

28− in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )

28+ in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )

30horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

31horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =

@@ -37,7 +37,7 @@ horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

37horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =

38 let p = picForImage i

39 ops = displayOpsForPic p (regionForWindow w)

40− in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )

40+ in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )

42horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result

43horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =

@@ -51,7 +51,7 @@ horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expected

51 let p = picForImage i

52 w = MockWindow c 1

53 ops = displayOpsForPic p (regionForWindow w)

54− in spanOpsAffectedRows ops == 1

54+ in spanOpsEffectedRows ops == 1

56horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result

57horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =

@@ -74,7 +74,7 @@ singleAttrSingleSpanStackCropped1 stack =

74 expectedRowCount = stackHeight stack `div` 2

75 w = MockWindow (stackWidth stack) expectedRowCount

76 ops = displayOpsForPic p (regionForWindow w)

77− actualRowCount = spanOpsAffectedRows ops

77+ actualRowCount = spanOpsEffectedRows ops

78 in expectedRowCount == actualRowCount

80singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

@@ -90,7 +90,7 @@ singleAttrSingleSpanStackCropped3 stack0 stack1 =

90 w = MockWindow (imageWidth (picImage p)) expectedRowCount

91 ops = displayOpsForPic p (regionForWindow w)

92 expectedRowCount = imageHeight (picImage p) `div` 2

93− actualRowCount = spanOpsAffectedRows ops

93+ actualRowCount = spanOpsEffectedRows ops

94 in expectedRowCount == actualRowCount

96singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

@@ -107,7 +107,7 @@ singleAttrSingleSpanStackCropped5 stack0 stack1 =

107 w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)

108 ops = displayOpsForPic p (regionForWindow w)

109 expectedRowCount = stackHeight stack0

110− actualRowCount = spanOpsAffectedRows ops

110+ actualRowCount = spanOpsEffectedRows ops

111 in expectedRowCount == actualRowCount

112

113horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result

@@ -123,13 +123,13 @@ arbImageIsCropped :: DefaultImage -> MockWindow -> Bool

123arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =

124 let pic = picForImage image

125 ops = displayOpsForPic pic (regionForWindow win)

126− in ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w )

126+ in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w )

127

128spanOpsActuallyFillRows :: DefaultPic -> Bool

129spanOpsActuallyFillRows (DefaultPic pic win) =

130 let ops = displayOpsForPic pic (regionForWindow win)

131 expectedRowCount = regionHeight (regionForWindow win)

132− actualRowCount = spanOpsAffectedRows ops

132+ actualRowCount = spanOpsEffectedRows ops

133 in expectedRowCount == actualRowCount

134

135spanOpsActuallyFillColumns :: DefaultPic -> Bool

test/VerifyUsingMockInput.hs+1−4

@@ -1,6 +1,5 @@

1{-# LANGUAGE MultiParamTypeClasses #-}

2{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4-- Generate some input bytes and delays between blocks of input bytes.

3-- Generate some input bytes and delays between blocks of input bytes.

5-- Verify the events produced are as expected.

4-- Verify the events produced are as expected.

6module Main where

5module Main where

@@ -132,9 +131,7 @@ assertEventsFromSynInput table inputSpec expectedEvents = do

132 readLoop 0 = return ()

131 readLoop 0 = return ()

133 readLoop n = do

132 readLoop n = do

134 e <- atomically $ readTChan $ input^.eventChannel

133 e <- atomically $ readTChan $ input^.eventChannel

135− case e of

136− InputEvent ev -> modifyIORef eventsRef ((:) ev)

134+ modifyIORef eventsRef ((:) e)

137− ResumeAfterSignal -> return ()

138 readLoop (n - 1)

135 readLoop (n - 1)

139 genEventsUsingIoActions maxDuration writeWaitClose readEvents

136 genEventsUsingIoActions maxDuration writeWaitClose readEvents

140 outEvents <- reverse <$> readIORef eventsRef

137 outEvents <- reverse <$> readIORef eventsRef

test/interactive_terminal_test.hs+3−2

@@ -12,6 +12,7 @@ import Control.Concurrent (threadDelay)

12import Control.Exception

13import Control.Monad

15+import Data.Default (def)

15import Data.List ( lookup )

16import Data.List ( lookup )

16import Data.Maybe ( isJust, fromJust )

17import Data.Maybe ( isJust, fromJust )

17import Data.Monoid

18import Data.Monoid

@@ -364,7 +365,7 @@ Did the test output match the description?

364|]

365|]

365 defaultSuccessConfirmResults

366 defaultSuccessConfirmResults

366

367

367−-- Explicitly define the bytes that encode each example text.

368+-- Explicitely definethe bytes that encode each example text.

368-- This avoids any issues with how the compiler represents string literals.

369-- This avoids any issues with how the compiler represents string literals.

369--

370--

370-- This document is UTF-8 encoded so the UTF-8 string is still included for

371-- This document is UTF-8 encoded so the UTF-8 string is still included for

@@ -937,7 +938,7 @@ cursorHideTest0 = Test

937 { testName = "Verify the cursor is hid and re-shown. issue #7"

938 { testName = "Verify the cursor is hid and re-shown. issue #7"

938 , testID = "cursorHideTest0"

939 , testID = "cursorHideTest0"

939 , testAction = do

940 , testAction = do

940− vty <- mkVty defaultConfig

941+ vty <- mkVty def

941 showCursor $ outputIface vty

942 showCursor $ outputIface vty

942 setCursorPos (outputIface vty) 5 5

943 setCursorPos (outputIface vty) 5 5

943 nextEvent vty

944 nextEvent vty

test/vty-examples.cabal+5−5

@@ -1,5 +1,5 @@

1name: vty-examples

2−version: 5.7

2+version: 5.6

3license: BSD3

4license-file: LICENSE

5author: AUTHORS

@@ -41,7 +41,7 @@ executable vty-interactive-terminal-test

41 default-extensions: ScopedTypeVariables

42 ghc-options: -threaded

44− build-depends: vty >= 5.15,

44+ build-depends: vty >= 5.2.11,

45 base >= 4 && < 5,

46 bytestring,

47 containers,

@@ -69,7 +69,7 @@ executable vty-event-echo

69 FlexibleContexts

70 ghc-options: -threaded

72− build-depends: vty >= 5.15,

72+ build-depends: vty >= 5.2.11,

73 base >= 4 && < 5,

74 array,

75 bytestring,

@@ -89,7 +89,7 @@ executable vty-rogue

89 default-extensions: ScopedTypeVariables

90 ghc-options: -threaded

92− build-depends: vty >= 5.15,

92+ build-depends: vty >= 5.2.11,

93 base >= 4 && < 5,

94 array,

95 bytestring,

@@ -110,7 +110,7 @@ executable vty-benchmark

110 default-extensions: ScopedTypeVariables

111 ghc-options: -threaded

112

113− build-depends: vty >= 5.15,

113+ build-depends: vty >= 5.2.11,

114 base >= 4 && < 5,

115 bytestring,

116 Cabal,

tools/BuildWidthTable.hsdeleted−144

@@ -1,144 +0,0 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2−{-# LANGUAGE CPP #-}

3−module Main where

4−

5−import qualified Control.Exception as E

6−import Control.Monad (when)

7−import Data.Maybe (fromMaybe)

8−#if !(MIN_VERSION_base(4,11,0))

9−import Data.Semigroup ((<>))

10−#endif

11−import System.Directory (createDirectoryIfMissing)

12−import System.Environment (getArgs, getProgName)

13−import System.FilePath (takeDirectory)

14−import System.Exit (exitFailure)

15−import System.Console.GetOpt

16−import Text.Read (readMaybe)

17−

18−import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName

19− , vtyConfigPath, addConfigWidthMap

20− , ConfigUpdateResult(..)

21− )

22−import Graphics.Vty.UnicodeWidthTable.IO

23−import Graphics.Vty.UnicodeWidthTable.Query

24−

25−data Arg = Help

26− | OutputPath String

27− | TableUpperBound String

28− | UpdateConfig

29− | VtyConfigPath String

30− deriving (Eq, Show)

31−

32−options :: Config -> [OptDescr Arg]

33−options config =

34− [ Option "h" ["help"] (NoArg Help)

35− "This help output"

36− , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")

37− ("The maximum Unicode code point to test when building the table " <>

38− "(default: " <> (show $ fromEnum $ configBound config) <> ")")

39− , Option "p" ["path"] (ReqArg OutputPath "PATH")

40− ("The output path to write to (default: " <>

41− fromMaybe "<none>" (configOutputPath config) <> ")")

42− , Option "u" ["update-config"] (NoArg UpdateConfig)

43− "Create or update the Vty configuration file to use the new table (default: no)"

44− , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")

45− ("Update the specified Vty configuration file path when -u is set (default: " <>

46− configPath config <> ")")

47− ]

48−

49−data Config =

50− Config { configOutputPath :: Maybe FilePath

51− , configBound :: Char

52− , configUpdate :: Bool

53− , configPath :: FilePath

54− }

55− deriving (Show)

56−

57−mkDefaultConfig :: IO Config

58−mkDefaultConfig = do

59− Config <$> terminalWidthTablePath

60− <*> pure defaultUnicodeTableUpperBound

61− <*> pure False

62− <*> vtyConfigPath

63−

64−usage :: IO ()

65−usage = do

66− config <- mkDefaultConfig

67− pn <- getProgName

68− putStrLn $ "Usage: " <> pn <> " [options]"

69− putStrLn ""

70− putStrLn "This tool queries the terminal on stdout to determine the widths"

71− putStrLn "of Unicode characters rendered to the terminal. The resulting data"

72− putStrLn "is written to a table at the specified output path for later"

73− putStrLn "loading by Vty-based applications."

74− putStrLn ""

75−

76− putStrLn $ usageInfo pn (options config)

77−

78−updateConfigFromArg :: Arg -> Config -> Config

79−updateConfigFromArg Help c =

80− c

81−updateConfigFromArg UpdateConfig c =

82− c { configUpdate = True }

83−updateConfigFromArg (VtyConfigPath p) c =

84− c { configPath = p }

85−updateConfigFromArg (TableUpperBound s) c =

86− case readMaybe s of

87− Nothing -> error $ "Invalid table upper bound: " <> show s

88− Just v -> c { configBound = toEnum v }

89−updateConfigFromArg (OutputPath p) c =

90− c { configOutputPath = Just p }

91−

92−main :: IO ()

93−main = do

94− defConfig <- mkDefaultConfig

95− strArgs <- getArgs

96− let (args, unused, errors) = getOpt Permute (options defConfig) strArgs

97−

98− when (not $ null errors) $ do

99− mapM_ putStrLn errors

100− exitFailure

101−

102− when ((not $ null unused) || (Help `elem` args)) $ do

103− usage

104− exitFailure

105−

106− let config = foldr updateConfigFromArg defConfig args

107−

108− outputPath <- case configOutputPath config of

109− Nothing -> do

110− putStrLn "Error: could not obtain terminal width table path"

111− exitFailure

112− Just path -> return path

113−

114− putStrLn "Querying terminal:"

115− builtTable <- buildUnicodeWidthTable $ configBound config

116−

117− let dir = takeDirectory outputPath

118− createDirectoryIfMissing True dir

119− writeUnicodeWidthTable outputPath builtTable

120−

121− putStrLn $ "\nOutput table written to " <> outputPath

122−

123− when (configUpdate config) $ do

124− let cPath = configPath config

125− Just tName <- currentTerminalName

126−

127− result <- E.try $ addConfigWidthMap cPath tName outputPath

128−

129− case result of

130− Left (e::E.SomeException) -> do

131− putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>

132− show e

133− exitFailure

134− Right ConfigurationCreated -> do

135− putStrLn $ "Configuration file created: " <> cPath

136− Right ConfigurationModified -> do

137− putStrLn $ "Configuration file updated: " <> cPath

138− Right (ConfigurationConflict other) -> do

139− putStrLn $ "Configuration file not updated: uses a different table " <>

140− "for TERM=" <> tName <> ": " <> other

141− Right ConfigurationRedundant -> do

142− putStrLn $ "Configuration file not updated: configuration " <>

143− cPath <> " already uses table " <> outputPath <>

144− " for TERM=" <> tName

vty.cabal+85−95

@@ -1,5 +1,5 @@

1name: vty

2−version: 5.35.1

2+version: 5.14

3license: BSD3

4license-file: LICENSE

5author: AUTHORS

@@ -24,13 +24,13 @@ description:

25 .

27−cabal-version: 1.18

27+cabal-version: >= 1.18

28build-type: Simple

29−extra-doc-files: README.md,

29+data-files: README.md,

30 AUTHORS,

31 CHANGELOG.md,

32 LICENSE

33−tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5

33+tested-with: GHC >= 7.6.2

35source-repository head

36 type: git

@@ -38,16 +38,17 @@ source-repository head

39library

40 default-language: Haskell2010

41− build-depends: base >= 4.8 && < 5,

41+ build-depends: base >= 4.6 && < 5,

42 blaze-builder >= 0.3.3.2 && < 0.5,

43 bytestring,

44 containers,

45 deepseq >= 1.1 && < 1.5,

46 directory,

47 filepath >= 1.0 && < 2.0,

48− microlens < 0.4.13,

48+ microlens,

49 microlens-mtl,

50 microlens-th,

51+ -- required for nice installation with yi

51 hashable >= 1.2,

52 hashable >= 1.2,

52 mtl >= 1.1.1.0 && < 2.3,

53 mtl >= 1.1.1.0 && < 2.3,

53 parallel >= 2.2 && < 3.3,

54 parallel >= 2.2 && < 3.3,

@@ -58,18 +59,10 @@ library

58 text >= 0.11.3,

59 text >= 0.11.3,

59 unix,

60 unix,

60 utf8-string >= 0.3 && < 1.1,

61 utf8-string >= 0.3 && < 1.1,

61− vector >= 0.7,

62+ vector >= 0.7

62− binary,

63− ansi-terminal >= 0.10.3

64−

65− if !impl(ghc >= 8.0)

66− build-depends: semigroups >= 0.16,

67− fail

69 exposed-modules: Graphics.Vty

64 exposed-modules: Graphics.Vty

70 Graphics.Vty.Attributes

65 Graphics.Vty.Attributes

71− Graphics.Vty.Attributes.Color

72− Graphics.Vty.Attributes.Color240

73 Graphics.Vty.Config

66 Graphics.Vty.Config

74 Graphics.Vty.Error

67 Graphics.Vty.Error

75 Graphics.Vty.Image

68 Graphics.Vty.Image

@@ -80,6 +73,7 @@ library

80 Graphics.Vty.Picture

73 Graphics.Vty.Picture

81 Graphics.Vty.Output

74 Graphics.Vty.Output

82 Graphics.Text.Width

75 Graphics.Text.Width

76+ -- the modules below are only meant to be used by the tests.

83 Codec.Binary.UTF8.Debug

77 Codec.Binary.UTF8.Debug

84 Data.Terminfo.Parse

78 Data.Terminfo.Parse

85 Data.Terminfo.Eval

79 Data.Terminfo.Eval

@@ -91,7 +85,6 @@ library

91 Graphics.Vty.Input.Classify.Parse

85 Graphics.Vty.Input.Classify.Parse

92 Graphics.Vty.Input.Loop

86 Graphics.Vty.Input.Loop

93 Graphics.Vty.Input.Mouse

87 Graphics.Vty.Input.Mouse

94− Graphics.Vty.Input.Focus

95 Graphics.Vty.Input.Paste

88 Graphics.Vty.Input.Paste

96 Graphics.Vty.Input.Terminfo

89 Graphics.Vty.Input.Terminfo

97 Graphics.Vty.PictureToSpans

90 Graphics.Vty.PictureToSpans

@@ -100,51 +93,39 @@ library

100 Graphics.Vty.Output.Interface

93 Graphics.Vty.Output.Interface

101 Graphics.Vty.Output.XTermColor

94 Graphics.Vty.Output.XTermColor

102 Graphics.Vty.Output.TerminfoBased

95 Graphics.Vty.Output.TerminfoBased

103− Graphics.Vty.UnicodeWidthTable.Types

104− Graphics.Vty.UnicodeWidthTable.IO

105− Graphics.Vty.UnicodeWidthTable.Query

106− Graphics.Vty.UnicodeWidthTable.Install

107

108− other-modules: Graphics.Vty.Debug.Image

97+ other-modules: Graphics.Vty.Attributes.Color

98+ Graphics.Vty.Attributes.Color240

99+ Graphics.Vty.Debug.Image

109 Graphics.Vty.Input.Terminfo.ANSIVT

100 Graphics.Vty.Input.Terminfo.ANSIVT

110

101

111 c-sources: cbits/gwinsz.c

102 c-sources: cbits/gwinsz.c

112 cbits/set_term_timing.c

103 cbits/set_term_timing.c

113− cbits/get_tty_erase.c

114 cbits/mk_wcwidth.c

104 cbits/mk_wcwidth.c

115

105

116 include-dirs: cbits

106 include-dirs: cbits

117

107

118 hs-source-dirs: src

108 hs-source-dirs: src

119

109

110+ default-extensions: ScopedTypeVariables

111+ ForeignFunctionInterface

112+

120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10

113 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10

121

114

122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10

115 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10

123

116

124−executable vty-build-width-table

125− main-is: BuildWidthTable.hs

126− hs-source-dirs: tools

127−

128− default-language: Haskell2010

129− ghc-options: -threaded -Wall

117+ cc-options: -O2

130−

131− if !impl(ghc >= 8.0)

132− build-depends: semigroups >= 0.16

133−

134− build-depends: vty,

135− directory,

136− filepath,

137− base >= 4.8 && < 5

138

118

139executable vty-mode-demo

119executable vty-mode-demo

140 main-is: ModeDemo.hs

120 main-is: ModeDemo.hs

141 hs-source-dirs: demos

121 hs-source-dirs: demos

142

122

143 default-language: Haskell2010

123 default-language: Haskell2010

124+ default-extensions: ScopedTypeVariables

144 ghc-options: -threaded

125 ghc-options: -threaded

145

126

146 build-depends: vty,

127 build-depends: vty,

147− base >= 4.8 && < 5,

128+ base >= 4.6 && < 5,

148 containers,

129 containers,

149 microlens,

130 microlens,

150 microlens-mtl,

131 microlens-mtl,

@@ -155,17 +136,39 @@ executable vty-demo

155 hs-source-dirs: demos

136 hs-source-dirs: demos

156

137

157 default-language: Haskell2010

138 default-language: Haskell2010

139+ default-extensions: ScopedTypeVariables

158 ghc-options: -threaded

140 ghc-options: -threaded

159

141

160 build-depends: vty,

142 build-depends: vty,

161− base >= 4.8 && < 5,

143+ base >= 4.6 && < 5,

162 containers,

144 containers,

163 microlens,

145 microlens,

164 microlens-mtl,

146 microlens-mtl,

165 mtl >= 1.1.1.0 && < 2.3

147 mtl >= 1.1.1.0 && < 2.3

166

148

149+test-suite verify-attribute-ops

150+ default-language: Haskell2010

151+ default-extensions: ScopedTypeVariables

152+ type: detailed-0.9

153+ hs-source-dirs: test

154+ test-module: VerifyAttributeOps

155+ build-depends: vty,

156+ Cabal >= 1.20,

157+ QuickCheck >= 2.7,

158+ random >= 1.0 && < 1.2,

159+ base >= 4.6 && < 5,

160+ bytestring,

161+ containers,

162+ deepseq >= 1.1 && < 1.5,

163+ mtl >= 1.1.1.0 && < 2.3,

164+ text >= 0.11.3,

165+ unix,

166+ utf8-string >= 0.3 && < 1.1,

167+ vector >= 0.7

168+

167test-suite verify-using-mock-terminal

169test-suite verify-using-mock-terminal

168 default-language: Haskell2010

170 default-language: Haskell2010

171+ default-extensions: ScopedTypeVariables

169

172

170 type: detailed-0.9

173 type: detailed-0.9

171

174

@@ -184,8 +187,8 @@ test-suite verify-using-mock-terminal

184 build-depends: vty,

187 build-depends: vty,

185 Cabal >= 1.20,

188 Cabal >= 1.20,

186 QuickCheck >= 2.7,

189 QuickCheck >= 2.7,

187− random >= 1.0 && < 1.3,

190+ random >= 1.0 && < 1.2,

188− base >= 4.8 && < 5,

191+ base >= 4.6 && < 5,

189 bytestring,

192 bytestring,

190 containers,

193 containers,

191 deepseq >= 1.1 && < 1.5,

194 deepseq >= 1.1 && < 1.5,

@@ -198,6 +201,7 @@ test-suite verify-using-mock-terminal

198

201

199test-suite verify-terminal

202test-suite verify-terminal

200 default-language: Haskell2010

203 default-language: Haskell2010

204+ default-extensions: ScopedTypeVariables

201

205

202 type: detailed-0.9

206 type: detailed-0.9

203

207

@@ -216,8 +220,8 @@ test-suite verify-terminal

216 build-depends: vty,

220 build-depends: vty,

217 Cabal >= 1.20,

221 Cabal >= 1.20,

218 QuickCheck >= 2.7,

222 QuickCheck >= 2.7,

219− random >= 1.0 && < 1.3,

223+ random >= 1.0 && < 1.2,

220− base >= 4.8 && < 5,

224+ base >= 4.6 && < 5,

221 bytestring,

225 bytestring,

222 containers,

226 containers,

223 deepseq >= 1.1 && < 1.5,

227 deepseq >= 1.1 && < 1.5,

@@ -230,6 +234,7 @@ test-suite verify-terminal

230

234

231test-suite verify-display-attributes

235test-suite verify-display-attributes

232 default-language: Haskell2010

236 default-language: Haskell2010

237+ default-extensions: ScopedTypeVariables

233

238

234 type: detailed-0.9

239 type: detailed-0.9

235

240

@@ -248,8 +253,8 @@ test-suite verify-display-attributes

248 build-depends: vty,

253 build-depends: vty,

249 Cabal >= 1.20,

254 Cabal >= 1.20,

250 QuickCheck >= 2.7,

255 QuickCheck >= 2.7,

251− random >= 1.0 && < 1.3,

256+ random >= 1.0 && < 1.2,

252− base >= 4.8 && < 5,

257+ base >= 4.6 && < 5,

253 bytestring,

258 bytestring,

254 containers,

259 containers,

255 deepseq >= 1.1 && < 1.5,

260 deepseq >= 1.1 && < 1.5,

@@ -261,6 +266,7 @@ test-suite verify-display-attributes

261

266

262test-suite verify-empty-image-props

267test-suite verify-empty-image-props

263 default-language: Haskell2010

268 default-language: Haskell2010

269+ default-extensions: ScopedTypeVariables

264

270

265 type: detailed-0.9

271 type: detailed-0.9

266

272

@@ -273,8 +279,8 @@ test-suite verify-empty-image-props

273 build-depends: vty,

279 build-depends: vty,

274 Cabal >= 1.20,

280 Cabal >= 1.20,

275 QuickCheck >= 2.7,

281 QuickCheck >= 2.7,

276− random >= 1.0 && < 1.3,

282+ random >= 1.0 && < 1.2,

277− base >= 4.8 && < 5,

283+ base >= 4.6 && < 5,

278 bytestring,

284 bytestring,

279 containers,

285 containers,

280 deepseq >= 1.1 && < 1.5,

286 deepseq >= 1.1 && < 1.5,

@@ -286,6 +292,7 @@ test-suite verify-empty-image-props

286

292

287test-suite verify-eval-terminfo-caps

293test-suite verify-eval-terminfo-caps

288 default-language: Haskell2010

294 default-language: Haskell2010

295+ default-extensions: ScopedTypeVariables

289

296

290 type: detailed-0.9

297 type: detailed-0.9

291

298

@@ -299,8 +306,8 @@ test-suite verify-eval-terminfo-caps

299 build-depends: vty,

306 build-depends: vty,

300 Cabal >= 1.20,

307 Cabal >= 1.20,

301 QuickCheck >= 2.7,

308 QuickCheck >= 2.7,

302− random >= 1.0 && < 1.3,

309+ random >= 1.0 && < 1.2,

303− base >= 4.8 && < 5,

310+ base >= 4.6 && < 5,

304 blaze-builder >= 0.3.3.2 && < 0.5,

311 blaze-builder >= 0.3.3.2 && < 0.5,

305 bytestring,

312 bytestring,

306 containers,

313 containers,

@@ -314,6 +321,7 @@ test-suite verify-eval-terminfo-caps

314

321

315test-suite verify-image-ops

322test-suite verify-image-ops

316 default-language: Haskell2010

323 default-language: Haskell2010

324+ default-extensions: ScopedTypeVariables

317

325

318 type: detailed-0.9

326 type: detailed-0.9

319

327

@@ -328,8 +336,8 @@ test-suite verify-image-ops

328 build-depends: vty,

336 build-depends: vty,

329 Cabal >= 1.20,

337 Cabal >= 1.20,

330 QuickCheck >= 2.7,

338 QuickCheck >= 2.7,

331− random >= 1.0 && < 1.3,

339+ random >= 1.0 && < 1.2,

332− base >= 4.8 && < 5,

340+ base >= 4.6 && < 5,

333 bytestring,

341 bytestring,

334 containers,

342 containers,

335 deepseq >= 1.1 && < 1.5,

343 deepseq >= 1.1 && < 1.5,

@@ -341,6 +349,7 @@ test-suite verify-image-ops

341

349

342test-suite verify-image-trans

350test-suite verify-image-trans

343 default-language: Haskell2010

351 default-language: Haskell2010

352+ default-extensions: ScopedTypeVariables

344

353

345 type: detailed-0.9

354 type: detailed-0.9

346

355

@@ -355,8 +364,8 @@ test-suite verify-image-trans

355 build-depends: vty,

364 build-depends: vty,

356 Cabal >= 1.20,

365 Cabal >= 1.20,

357 QuickCheck >= 2.7,

366 QuickCheck >= 2.7,

358− random >= 1.0 && < 1.3,

367+ random >= 1.0 && < 1.2,

359− base >= 4.8 && < 5,

368+ base >= 4.6 && < 5,

360 bytestring,

369 bytestring,

361 containers,

370 containers,

362 deepseq >= 1.1 && < 1.5,

371 deepseq >= 1.1 && < 1.5,

@@ -368,6 +377,7 @@ test-suite verify-image-trans

368

377

369test-suite verify-inline

378test-suite verify-inline

370 default-language: Haskell2010

379 default-language: Haskell2010

380+ default-extensions: ScopedTypeVariables

371

381

372 type: detailed-0.9

382 type: detailed-0.9

373

383

@@ -381,8 +391,8 @@ test-suite verify-inline

381 build-depends: vty,

391 build-depends: vty,

382 Cabal >= 1.20,

392 Cabal >= 1.20,

383 QuickCheck >= 2.7,

393 QuickCheck >= 2.7,

384− random >= 1.0 && < 1.3,

394+ random >= 1.0 && < 1.2,

385− base >= 4.8 && < 5,

395+ base >= 4.6 && < 5,

386 bytestring,

396 bytestring,

387 containers,

397 containers,

388 deepseq >= 1.1 && < 1.5,

398 deepseq >= 1.1 && < 1.5,

@@ -394,6 +404,7 @@ test-suite verify-inline

394

404

395test-suite verify-parse-terminfo-caps

405test-suite verify-parse-terminfo-caps

396 default-language: Haskell2010

406 default-language: Haskell2010

407+ default-extensions: ScopedTypeVariables

397

408

398 type: detailed-0.9

409 type: detailed-0.9

399

410

@@ -408,8 +419,8 @@ test-suite verify-parse-terminfo-caps

408 build-depends: vty,

419 build-depends: vty,

409 Cabal >= 1.20,

420 Cabal >= 1.20,

410 QuickCheck >= 2.7,

421 QuickCheck >= 2.7,

411− random >= 1.0 && < 1.3,

422+ random >= 1.0 && < 1.2,

412− base >= 4.8 && < 5,

423+ base >= 4.6 && < 5,

413 bytestring,

424 bytestring,

414 containers,

425 containers,

415 deepseq >= 1.1 && < 1.5,

426 deepseq >= 1.1 && < 1.5,

@@ -422,6 +433,7 @@ test-suite verify-parse-terminfo-caps

422

433

423test-suite verify-simple-span-generation

434test-suite verify-simple-span-generation

424 default-language: Haskell2010

435 default-language: Haskell2010

436+ default-extensions: ScopedTypeVariables

425

437

426 type: detailed-0.9

438 type: detailed-0.9

427

439

@@ -439,8 +451,8 @@ test-suite verify-simple-span-generation

439 build-depends: vty,

451 build-depends: vty,

440 Cabal >= 1.20,

452 Cabal >= 1.20,

441 QuickCheck >= 2.7,

453 QuickCheck >= 2.7,

442− random >= 1.0 && < 1.3,

454+ random >= 1.0 && < 1.2,

443− base >= 4.8 && < 5,

455+ base >= 4.6 && < 5,

444 bytestring,

456 bytestring,

445 containers,

457 containers,

446 deepseq >= 1.1 && < 1.5,

458 deepseq >= 1.1 && < 1.5,

@@ -453,6 +465,7 @@ test-suite verify-simple-span-generation

453

465

454test-suite verify-crop-span-generation

466test-suite verify-crop-span-generation

455 default-language: Haskell2010

467 default-language: Haskell2010

468+ default-extensions: ScopedTypeVariables

456

469

457 type: detailed-0.9

470 type: detailed-0.9

458

471

@@ -470,8 +483,8 @@ test-suite verify-crop-span-generation

470 build-depends: vty,

483 build-depends: vty,

471 Cabal >= 1.20,

484 Cabal >= 1.20,

472 QuickCheck >= 2.7,

485 QuickCheck >= 2.7,

473− random >= 1.0 && < 1.3,

486+ random >= 1.0 && < 1.2,

474− base >= 4.8 && < 5,

487+ base >= 4.6 && < 5,

475 bytestring,

488 bytestring,

476 containers,

489 containers,

477 deepseq >= 1.1 && < 1.5,

490 deepseq >= 1.1 && < 1.5,

@@ -484,6 +497,7 @@ test-suite verify-crop-span-generation

484

497

485test-suite verify-layers-span-generation

498test-suite verify-layers-span-generation

486 default-language: Haskell2010

499 default-language: Haskell2010

500+ default-extensions: ScopedTypeVariables

487

501

488 type: detailed-0.9

502 type: detailed-0.9

489

503

@@ -501,33 +515,8 @@ test-suite verify-layers-span-generation

501 build-depends: vty,

515 build-depends: vty,

502 Cabal >= 1.20,

516 Cabal >= 1.20,

503 QuickCheck >= 2.7,

517 QuickCheck >= 2.7,

504− random >= 1.0 && < 1.3,

518+ random >= 1.0 && < 1.2,

505− base >= 4.8 && < 5,

506− bytestring,

507− containers,

508− deepseq >= 1.1 && < 1.5,

509− mtl >= 1.1.1.0 && < 2.3,

510− text >= 0.11.3,

511− unix,

512− utf8-string >= 0.3 && < 1.1,

513− vector >= 0.7

514−

515−test-suite verify-color-mapping

516− default-language: Haskell2010

517−

518− type: detailed-0.9

519−

520− hs-source-dirs: test

521−

522− test-module: VerifyColor240

523−

524− other-modules: Verify

525−

526− build-depends: vty,

527− Cabal >= 1.20,

528− QuickCheck >= 2.7,

529− random >= 1.0 && < 1.3,

530− base >= 4.8 && < 5,

519+ base >= 4.6 && < 5,

531 bytestring,

520 bytestring,

532 containers,

521 containers,

533 deepseq >= 1.1 && < 1.5,

522 deepseq >= 1.1 && < 1.5,

@@ -539,6 +528,7 @@ test-suite verify-color-mapping

539

528

540test-suite verify-utf8-width

529test-suite verify-utf8-width

541 default-language: Haskell2010

530 default-language: Haskell2010

531+ default-extensions: ScopedTypeVariables

542

532

543 type: detailed-0.9

533 type: detailed-0.9

544

534

@@ -551,8 +541,8 @@ test-suite verify-utf8-width

551 build-depends: vty,

541 build-depends: vty,

552 Cabal >= 1.20,

542 Cabal >= 1.20,

553 QuickCheck >= 2.7,

543 QuickCheck >= 2.7,

554− random >= 1.0 && < 1.3,

544+ random >= 1.0 && < 1.2,

555− base >= 4.8 && < 5,

545+ base >= 4.6 && < 5,

556 bytestring,

546 bytestring,

557 containers,

547 containers,

558 deepseq >= 1.1 && < 1.5,

548 deepseq >= 1.1 && < 1.5,

@@ -564,6 +554,7 @@ test-suite verify-utf8-width

564

554

565test-suite verify-using-mock-input

555test-suite verify-using-mock-input

566 default-language: Haskell2010

556 default-language: Haskell2010

557+ default-extensions: ScopedTypeVariables

567

558

568 type: exitcode-stdio-1.0

559 type: exitcode-stdio-1.0

569

560

@@ -571,8 +562,6 @@ test-suite verify-using-mock-input

571

562

572 main-is: VerifyUsingMockInput.hs

563 main-is: VerifyUsingMockInput.hs

573

564

574− other-modules: Verify.Graphics.Vty.Output

575−

576 build-depends: vty,

565 build-depends: vty,

577 Cabal >= 1.20,

566 Cabal >= 1.20,

578 QuickCheck >= 2.7,

567 QuickCheck >= 2.7,

@@ -580,8 +569,8 @@ test-suite verify-using-mock-input

580 quickcheck-assertions >= 0.1.1,

569 quickcheck-assertions >= 0.1.1,

581 test-framework == 0.8.*,

570 test-framework == 0.8.*,

582 test-framework-smallcheck == 0.2.*,

571 test-framework-smallcheck == 0.2.*,

583− random >= 1.0 && < 1.3,

572+ random >= 1.0 && < 1.2,

584− base >= 4.8 && < 5,

573+ base >= 4.6 && < 5,

585 bytestring,

574 bytestring,

586 containers,

575 containers,

587 deepseq >= 1.1 && < 1.5,

576 deepseq >= 1.1 && < 1.5,

@@ -599,6 +588,7 @@ test-suite verify-using-mock-input

599

588

600test-suite verify-config

589test-suite verify-config

601 default-language: Haskell2010

590 default-language: Haskell2010

591+ default-extensions: ScopedTypeVariables

602

592

603 type: exitcode-stdio-1.0

593 type: exitcode-stdio-1.0

604

594

@@ -615,8 +605,8 @@ test-suite verify-config

615 test-framework == 0.8.*,

605 test-framework == 0.8.*,

616 test-framework-smallcheck == 0.2.*,

606 test-framework-smallcheck == 0.2.*,

617 test-framework-hunit,

607 test-framework-hunit,

618− random >= 1.0 && < 1.3,

608+ random >= 1.0 && < 1.2,

619− base >= 4.8 && < 5,

609+ base >= 4.6 && < 5,

620 bytestring,

610 bytestring,

621 containers,

611 containers,

622 deepseq >= 1.1 && < 1.5,

612 deepseq >= 1.1 && < 1.5,