diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,4 +1,6 @@ -The following people should be thanked for contributing to the vty library: +The following people should be thanked for contributing to the vty +library: + * Andrea Vezzosi * Corey O'Connor * Emily Backes @@ -17,4 +19,4 @@ * Yoshikuni Jujo * Dmitry Ivanov -Plus others.. Check the git log for a full list. +Plus others.. Check the git log and CHANGELOG.md for a full list. diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,367 +0,0 @@ -5.14 - - addMaybeClippedJoin: instead of raising an exception when the join - is totally clipped, just reduce the clip amount and continue - - addMaybeClipped: skip blit of joins when their primary dimension is - zero - - 'string' and related text functions no longer treat an empty string - as an empty image (thanks Chris Penner). This means that now it is - possible to use 'str ""' as a non-empty image with height 1. - -5.13 - - Reverted changes in 5.12 due to disagreements between terminal emulators - and utf8proc; for more details, please see the ticket discussion at - https://github.com/coreyoconnor/vty/issues/115 - -5.12 - - Replaced 'wcwidth' with a call to the utf8proc library's character - width function, which is much more up to date (by several Unicode - versions) and returns the right width for a much larger set of - characters. - - Added a bundled version of the utf8proc C library. - -5.11.3 - - Fix mouse event offsets in mouse-up events - -5.11.2 - - Mouse events were modified so that the upper-left corner of the window is - (0,0) rather than (1,1). - -5.11.1 - - Add Generic instance for Image - - nextEvent: stop trying to refresh on a resize event (fixes segfault - on refresh with normal cursor positioning mode) - - Remove redundant clause from clipForCharWidth (thanks Eric Mertens) - - Update maintainer - -5.11 - - Vty now raises a VtyConfigurationError exception when the TERM - evironment variable is missing (thanks Eric Mertens) - - Graphics.Vty.Config got an explicit export list to avoid accidentally - exporting internal types (thanks Eric Mertens) - -5.10 - - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This - mode provides greater control over cursor positioning by bypassing - the logical positioning provided by default. Rather than positioning - the cursor by looking at the widths of characters involved, this - constructor lets you provide a physical row and column instead. This - is useful in more sophisticated programs. (thanks Eric Mertens) - - Added a new Generic-derived config parser (thanks Eric Mertens) - - Fixed the MShift case in the configuration file parser (thanks Eric - Mertens) - - Fixed wcwidth import and matched safeWcswidth to its documented - behavior. Previously vty_mk_wcwidth was being imported with - the wrong type causing the -1 return value to be mapped to the - wrong Int value. Additionally safeWcswidth was using the unsafe - character width function and only ensuring that the final result was - non-negative. (thanks Eric Mertens) - -5.9.1 - - Vty now only emits UTF8 charset sequences in terminals without a - preexisting UTF8 declaration to avoid emitting garbage sequences - (fixes #89) - -5.9 - - Added new Output methods supportsBell and ringTerminalBell to find out - whether the output device has an audio bell and to ring it (see #102) - -5.8.1 - - Fixed "refresh" to work as advertised (see #104) - -5.8 - - API change: EvPaste input event now provides paste data as a raw - ByteString rather than a String to allow the application to decode - how best to decode it - -5.7.1 - - ModeDemo: added an explicit Control.Applicative import for older GHCs - -5.7 - - Mouse and paste modes are now off by default. - - The Config type got new fields: mouseMode and bracketedPasteMode. These - determine whether these modes are enabled initially (for terminals - that support them). - - Added a Mode type for modal terminal features (mouse events, bracketed - paste mode) that is used with new Output interface functions: - * supportsMode :: Mode -> Bool tells whether the device supports a - mode - * setMode :: Mode -> Bool -> IO () turns a mode on or off - * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or - off - - Added a new demo program, ModeDemo.hs, to demonstrate usage of modes - -5.6 - - Added support for normal and extended mouse modes in Xterm-like - terminals via the MouseDown and MouseUp Event constructors - - Added support for bracketed paste mode in Xterm-like terminals via - the EvPaste event constructor - - Added derived Show instances for Event and Button (thanks Felix - Hirn) - - Now TERM values containing "screen" will automatically use the - XtermColor driver rather than just TerminfoBased - -5.5.0 - - Replaced lens dependency with microlens, microlens-mtl, microlens-th dependencies. Issue #90 - - Thanks Jonathan Daugherty - - Cabal corrections. - - Thanks Lennart Spitzner - -5.4.0 - - Changed eventChannel of Graphics.Vty.Input from Chan to TChan. This enables clients to query if - there are no pending events. The Graphics.Vty interface nextEvent is unchanged. Clients that use - eventChannel directly will require updating. - https://github.com/coreyoconnor/vty/issues/60 -5.3.1 - - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due - to possibly breaking this on reasonable GHC versions - -5.3 - - Upgraded QuickCheck dependency to 2.7 - - The standard IO Config (standardIOConfig) was overriding any provided application config. - In addition, the inputFd and outputFd could not be changed if mkVty was used. - Fixed. - - Correct handling of display attributes at end of line. The output attributes are set to default - at the end of content for the line and at the start of a new line. Previously the current - attribute would extend to the next start of content. This was odd to reason about and was the - cause of https://github.com/coreyoconnor/vty/issues/76 - IIRC Yi requires the old behavior to display the selection region correctly. - - shutdown of the input thread is now performed using killThread and synchronization on an MVar. - For correct handling of the terminal read vmin and vtime the read must be a blocking read on an - OS thread. This places a threadWaitRead, which will be interrupted by the killThread, prior to - the uninterruptable read. An alternative would be to re-import the read foreign call as - interruptable. - -5.2.11 - - deepseq bounds increased for tests. - - Clean up warnings when compiling on 7.10 - - Thanks Eric Mertens - - Avoid discarding input bytes after multi-byte encoded codepoint - - Thanks Eric Mertens - -5.2.10 - - "str" now returns EmptyImage for empty strings to match behavior of other string-like Image constructors (fixes #74) - - Thanks Jonathan Daugherty - -5.2.9 - - dependency version bumps - - https://github.com/coreyoconnor/vty/pull/71 - - https://github.com/coreyoconnor/vty/pull/70 - - Correct/Simplify the example code - - Thanks glguy - - https://github.com/coreyoconnor/vty/pull/69 - -5.2.8 - - blaze-builder, lens, utf8-string version constraint bump - - Thanks glguy - - https://github.com/coreyoconnor/vty/pull/67 - - Do not differentiate based on TERM_PROGRAM - - https://github.com/coreyoconnor/vty/issues/68 - -5.2.7 - - lens and deepseq constraint bump + misc - - Thanks ethercrow - - https://github.com/coreyoconnor/vty/pull/66 - -5.2.6 - - lens constraint bump - - Thanks alexander-b! - - https://github.com/coreyoconnor/vty/pull/64 - -5.2.5 - - lens and random version constraint bump. - - Thanks RyanGlScott! - - https://github.com/coreyoconnor/vty/pull/62 - -5.2.4 - - removed -fpic from cc-options. No longer required. - - https://github.com/coreyoconnor/vty/issues/61 - - https://ghc.haskell.org/trac/ghc/ticket/9657 - - Thanks Fuuzetsu! - -5.2.3 - - evaluate/compile the input parsing table once instead of each keystroke. - - https://github.com/coreyoconnor/vty/pull/59 - - Thanks ethercrow! - -5.2.2 - - When looking at input for an event, don't look too deep. - - https://github.com/coreyoconnor/vty/pull/57 - - Thanks ethercrow! - -5.2.1 - - Bump upper version bound for lens to 4.5. Thanks markus1189! - -5.2.0 - - Config structure now specifies file descriptor to use. The default is stdInput and stdOutput - file descriptors. Previously Vty used stdInput for input and the follow code for output: - - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` NoBuffering) - - the difference was required by Vty.Inline. Now, Vty.Inline uses the Config structure options - to acheive the same effect. - - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, inputForNameAndIO, - outputForCurrentTerminal, outputForNameAndIO - - added: inputForConfig, outputForConfig - - updates to vty-rogue from jtdaugherty. Thanks! - - the oldest version of GHC tested to support vty is 7.6.2. - - the oldest version of GHC that vty compiles under is 7.4.2 - -5.1.4 - - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi! - -5.1.1 - - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke! - - jtdaugherty resolved a number of compiler warnings. Thanks! - -5.1.0 - - vmin and vtime can be specified however the application requires. See Graphics.Vty.Config. - - fixed the processing of input when vmin is set > 1. - -5.0.0 - - The naming convention now matches: - - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions - - all projects using vty for input must be compiled with -threaded. Please notify vty author if - this is not acceptable. - - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default - configuration. - - input handling changes - - KASCII is now KChar - - KPN5 is now KCenter - - tests exist. - - Applications can add to the input tables by setting inputMap of the Config. - See Graphics.Vty.Config - - Users can define input table extensions that will apply to all vty applications. - See Graphics.Vty.Config - - terminal timing is now handled by selecting an appropriate VTIME. Previously this was - implemented within Vty itself. This reduced complexity in vty but provides a different meta - key behavior and implies a requirement on -threaded. - - The time vty will wait to verify an ESC byte means a single ESC key is the - singleEscPeriod of the Input Config structure. - - removed the typeclass based terminal and display context interface in favor of a data - structure of properties interface. - - renamed the Terminal interface to Output - - The default picture for an image now uses the "clear" background. This background fills - background spans with spaces or just ends the line. - - Previously the background defaulted to the space character. This causes issues copying - text from a text editor. The text would end up with extra spaces at the end of the line. - - Layer support - - Each layer is an image. - - The layers for a picture are a list of images. - - The first image is the top-most layer. The images are ordered from top to bottom. - - The transparent areas for a layer are the backgroundFill areas. backgroundFill is - added to pad images when images of different sizes are joined. - - If the background is clear there is no background layer. - - If there is a background character then the bottom layer is the background layer. - - emptyPicture is a Picture with no layers and no cursor - - addToTop and addToBottom add a layer to the top and bottom of the given Picture. - - compatibility improvements: - - terminfo based terminals with no cursor support are silently accepted. The cursor - visibility changes in the Picture will have no effect. - - alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a - guess. - - added "rgbColor" for easy support of RGB specified colors. - - Both applications and users can add to the mapping used to translate from input bytes to - events. - - Additional information about input and output process can be appended to a debug log - - Set environment variable VTY_DEBUG_LOG to path of debug log - - Or use "debugLog " config directive - - Or set 'debugLog' property of the Config provided to mkVty. - - examples moved to vty-examples package. See test directory for cabal file. - - vty-interactive-terminal-test - - interactive test. Useful for building a bug report for vty's author. - - test/interactive_terminal_test.hs - - vty-event-echo - - view a input event log for vty. Example of interacting with user. - - test/EventEcho.hs - - vty-rogue - - The start of a rogue-like game. Example of layers and image build operations. - - test/Rogue.hs - - vty-benchmark - - benchmarks vty. A series of tests that push random pictures to the terminal. The - random pictures are generated using QuickCheck. The same generators used in the - automated tests. - - test/benchmark.hs - -4.7.0.0 - - API changes: - - Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size. - - Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size. - - Added Graphics.Vty.Image.translate: Offset an image. - - Thanks Ben Boeckel for these features. - -4.3.0.0 - -4.2.1.0 - - API changes: - - Attr record accessor fore_color changed to attr_fore_color - - Attr record accessor back_color changed to attr_back_color - - Attr record accessor style changed to attr_style - - Added an "inline" display attribute changing DSL: - - put_attr_change applies a display attribute change immediately to a terminal - - For instance, can be used to change the display attrbiutes of text output via putStrLn - and putStr. EX: "put_attr_change $ back_color red" will set the - background color to red. - - Changes do not apply to a Picture output via output_picture. - - See Graphics.Vty.Inline - - Moved all IO actions into any monad an instance of MonadIO - -4.0.0.1 - - binding for mk_wcswidth was incorrect. Most platforms just magically worked due to - coincidence. - -4.0.0 - - API changes: - - "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an - instance of the Vty data structure. - - added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated - with the Vty instance. - - Graphics.Vty.Types has undergone a number of changes. Summary: - - Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for - image combinators. Graphics.Vty.Picture for final picture construction. - - Graphics.Vty.Attributes: - - "setFG" and "setBG" are now "with_fore_color" and "with_back_color" - - All other "set.." equations similarly replaced. - - "attr" is now "def_attr", short for "default display attributes" Also added a - "current_attr" for "currently applied display attributes" - - Graphics.Vty.Image: - - "horzcat" is now "horiz_cat" - - "vertcat" is now "vert_cat" - - "renderBS" is now "utf8_bytestring" - - "renderChar" is now "char" - - "renderFill" is now "char_fill" - - added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings - and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime - representation. - - Graphics.Vty.Picture: - - exports Graphics.Vty.Image - - "pic" is now "pic_for_image" - - added API for setting background fill pattern. - - Completely rewritten output backend. - - Efficient, scanline style output span generator. Has not been fully optimized, but good - enough. - - The details required to display the desired picture on a terminal are well encapsulated. - - Terminfo based display terminal implementation. With specialized derivitives for xterm, - Terminal.app, and iTerm.app. - - Attempts to robustly handle even terminals that don't support all display attributes. - - I've tested the following terminals with success: iTerm.app, Terminal.app, xterm, - rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be - as successfull. - - Improved unicode support. Double wide characters will display as expected. - - 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted - according to the number of colors the terminal supports. - - The Graphics.Vty.Image combinators no longer require matching dimensions to arguments. - Unspecified areas are filled in with a user-customizable background pattern. See - Graphics.Vty.Picture. - - output images are always cropped to display size. - - Significant code coverage by QuickCheck tests. An interactive test for those final properties - that couldn't be automatically verified. - - issues resolved: - - "gnome terminal displays non-basic attributes as strikethrough" - - http://trac.haskell.org/vty/ticket/14 - - "Multi-byte characters are not displayed correctly on update" - - http://trac.haskell.org/vty/ticket/10 - - "Redraw does not handle rendering a line that extends beyond screen width characters" - - http://trac.haskell.org/vty/ticket/13 - - "The <|> and <-> combinators should be more forgiving of mismatched dimensions" - - http://trac.haskell.org/vty/ticket/9 - - "256-color support" - - http://trac.haskell.org/vty/ticket/19 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,428 @@ +5.15 +Package changes: + - Discontinued support for GHC versions prior to 7.10.1. + - Removed instructions and configuration for Stack builds since they + are no longer supported. + - Clarified README mention of (lack of) Windows support (contributors + wanted, though!) + - Removed dependency on data-default (see below). + +API changes: + - Moved color definitions from Attributes to Color module. + - In lieu of data-default (Default) instances for Attr and Config, use + 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'. + - Graphics.Vty.Output no longer re-exports + Graphics.Vty.Output.Interface. + - Removed Graphics.Vty.Prelude module and moved DisplayRegion and its + accessors to Graphics.Vty.Image. + - Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes. + - Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image. + +5.14 + - addMaybeClippedJoin: instead of raising an exception when the join + is totally clipped, just reduce the clip amount and continue + - addMaybeClipped: skip blit of joins when their primary dimension is + zero + - 'string' and related text functions no longer treat an empty string + as an empty image (thanks Chris Penner). This means that now it is + possible to use 'str ""' as a non-empty image with height 1. + +5.13 + - Reverted changes in 5.12 due to disagreements between terminal + emulators and utf8proc; for more details, please see the ticket + discussion at + https://github.com/coreyoconnor/vty/issues/115 + +5.12 + - Replaced 'wcwidth' with a call to the utf8proc library's character + width function, which is much more up to date (by several Unicode + versions) and returns the right width for a much larger set of + characters. + - Added a bundled version of the utf8proc C library. + +5.11.3 + - Fix mouse event offsets in mouse-up events + +5.11.2 + - Mouse events were modified so that the upper-left corner of the + window is (0,0) rather than (1,1). + +5.11.1 + - Add Generic instance for Image + - nextEvent: stop trying to refresh on a resize event (fixes segfault + on refresh with normal cursor positioning mode) + - Remove redundant clause from clipForCharWidth (thanks Eric Mertens) + - Update maintainer + +5.11 + - Vty now raises a VtyConfigurationError exception when the TERM + evironment variable is missing (thanks Eric Mertens) + - Graphics.Vty.Config got an explicit export list to avoid accidentally + exporting internal types (thanks Eric Mertens) + +5.10 + - Add absolute cursor positioning mode AbsoluteCursor to Cursor. This + mode provides greater control over cursor positioning by bypassing + the logical positioning provided by default. Rather than positioning + the cursor by looking at the widths of characters involved, this + constructor lets you provide a physical row and column instead. This + is useful in more sophisticated programs. (thanks Eric Mertens) + - Added a new Generic-derived config parser (thanks Eric Mertens) + - Fixed the MShift case in the configuration file parser (thanks Eric + Mertens) + - Fixed wcwidth import and matched safeWcswidth to its documented + behavior. Previously vty_mk_wcwidth was being imported with + the wrong type causing the -1 return value to be mapped to the + wrong Int value. Additionally safeWcswidth was using the unsafe + character width function and only ensuring that the final result was + non-negative. (thanks Eric Mertens) + +5.9.1 + - Vty now only emits UTF8 charset sequences in terminals without a + preexisting UTF8 declaration to avoid emitting garbage sequences + (fixes #89) + +5.9 + - Added new Output methods supportsBell and ringTerminalBell to find + out whether the output device has an audio bell and to ring it (see + #102) + +5.8.1 + - Fixed "refresh" to work as advertised (see #104) + +5.8 + - API change: EvPaste input event now provides paste data as a raw + ByteString rather than a String to allow the application to decode + how best to decode it + +5.7.1 + - ModeDemo: added an explicit Control.Applicative import for older + GHCs + +5.7 + - Mouse and paste modes are now off by default. + - The Config type got new fields: mouseMode and bracketedPasteMode. + These determine whether these modes are enabled initially (for + terminals that support them). + - Added a Mode type for modal terminal features (mouse events, + bracketed paste mode) that is used with new Output interface + functions: + * supportsMode :: Mode -> Bool tells whether the device supports a + mode + * setMode :: Mode -> Bool -> IO () turns a mode on or off + * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or + off + - Added a new demo program, ModeDemo.hs, to demonstrate usage of modes + +5.6 + - Added support for normal and extended mouse modes in Xterm-like + terminals via the MouseDown and MouseUp Event constructors + - Added support for bracketed paste mode in Xterm-like terminals via + the EvPaste event constructor + - Added derived Show instances for Event and Button (thanks Felix + Hirn) + - Now TERM values containing "screen" will automatically use the + XtermColor driver rather than just TerminfoBased + +5.5.0 + - Replaced lens dependency with microlens, microlens-mtl, microlens-th + dependencies. Issue #90 + - Thanks Jonathan Daugherty + - Cabal corrections. + - Thanks Lennart Spitzner + +5.4.0 + - Changed eventChannel of Graphics.Vty.Input from Chan to TChan. + This enables clients to query if there are no pending events. The + Graphics.Vty interface nextEvent is unchanged. Clients that use + eventChannel directly will require updating. + https://github.com/coreyoconnor/vty/issues/60 +5.3.1 + - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due + to possibly breaking this on reasonable GHC versions + +5.3 + - Upgraded QuickCheck dependency to 2.7 + - The standard IO Config (standardIOConfig) was overriding any + provided application config. In addition, the inputFd and outputFd + could not be changed if mkVty was used. Fixed. + - Correct handling of display attributes at end of line. The output + attributes are set to default at the end of content for the line and + at the start of a new line. Previously the current attribute would + extend to the next start of content. This was odd to reason about + and was the cause of https://github.com/coreyoconnor/vty/issues/76 + IIRC Yi requires the old behavior to display the selection region + correctly. + - shutdown of the input thread is now performed using killThread and + synchronization on an MVar. For correct handling of the terminal + read vmin and vtime the read must be a blocking read on an OS + thread. This places a threadWaitRead, which will be interrupted by + the killThread, prior to the uninterruptable read. An alternative + would be to re-import the read foreign call as interruptable. + +5.2.11 + - deepseq bounds increased for tests. + - Clean up warnings when compiling on 7.10 + - Thanks Eric Mertens + - Avoid discarding input bytes after multi-byte encoded codepoint + - Thanks Eric Mertens + +5.2.10 + - "str" now returns EmptyImage for empty strings to match behavior of + other string-like Image constructors (fixes #74) + - Thanks Jonathan Daugherty + +5.2.9 + - dependency version bumps + - https://github.com/coreyoconnor/vty/pull/71 + - https://github.com/coreyoconnor/vty/pull/70 + - Correct/Simplify the example code + - Thanks glguy + - https://github.com/coreyoconnor/vty/pull/69 + +5.2.8 + - blaze-builder, lens, utf8-string version constraint bump + - Thanks glguy + - https://github.com/coreyoconnor/vty/pull/67 + - Do not differentiate based on TERM_PROGRAM + - https://github.com/coreyoconnor/vty/issues/68 + +5.2.7 + - lens and deepseq constraint bump + misc + - Thanks ethercrow + - https://github.com/coreyoconnor/vty/pull/66 + +5.2.6 + - lens constraint bump + - Thanks alexander-b! + - https://github.com/coreyoconnor/vty/pull/64 + +5.2.5 + - lens and random version constraint bump. + - Thanks RyanGlScott! + - https://github.com/coreyoconnor/vty/pull/62 + +5.2.4 + - removed -fpic from cc-options. No longer required. + - https://github.com/coreyoconnor/vty/issues/61 + - https://ghc.haskell.org/trac/ghc/ticket/9657 + - Thanks Fuuzetsu! + +5.2.3 + - evaluate/compile the input parsing table once instead of each + keystroke. + - https://github.com/coreyoconnor/vty/pull/59 + - Thanks ethercrow! + +5.2.2 + - When looking at input for an event, don't look too deep. + - https://github.com/coreyoconnor/vty/pull/57 + - Thanks ethercrow! + +5.2.1 + - Bump upper version bound for lens to 4.5. Thanks markus1189! + +5.2.0 + - Config structure now specifies file descriptor to use. The default + is stdInput and stdOutput file descriptors. Previously Vty used + stdInput for input and the follow code for output: + - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` + NoBuffering) + - the difference was required by Vty.Inline. Now, Vty.Inline uses + the Config structure options to acheive the same effect. + - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, + inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO + - added: inputForConfig, outputForConfig + - updates to vty-rogue from jtdaugherty. Thanks! + - the oldest version of GHC tested to support vty is 7.6.2. + - the oldest version of GHC that vty compiles under is 7.4.2 + +5.1.4 + - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi! + +5.1.1 + - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke! + - jtdaugherty resolved a number of compiler warnings. Thanks! + +5.1.0 + - vmin and vtime can be specified however the application requires. + See Graphics.Vty.Config. + - fixed the processing of input when vmin is set > 1. + +5.0.0 + - The naming convention now matches: + - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions + - all projects using vty for input must be compiled with -threaded. + Please notify vty author if this is not acceptable. + - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized + vty with the default configuration. + - input handling changes + - KASCII is now KChar + - KPN5 is now KCenter + - tests exist. + - Applications can add to the input tables by setting inputMap of + the Config. See Graphics.Vty.Config + - Users can define input table extensions that will apply to all vty + applications. See Graphics.Vty.Config + - terminal timing is now handled by selecting an appropriate VTIME. + Previously this was implemented within Vty itself. This reduced + complexity in vty but provides a different meta key behavior and + implies a requirement on -threaded. + - The time vty will wait to verify an ESC byte means a single ESC + key is the singleEscPeriod of the Input Config structure. + - removed the typeclass based terminal and display context interface + in favor of a data structure of properties interface. + - renamed the Terminal interface to Output + - The default picture for an image now uses the "clear" background. + This background fills background spans with spaces or just ends the + line. + - Previously the background defaulted to the space character. This + causes issues copying text from a text editor. The text would end + up with extra spaces at the end of the line. + - Layer support + - Each layer is an image. + - The layers for a picture are a list of images. + - The first image is the top-most layer. The images are ordered from + top to bottom. + - The transparent areas for a layer are the backgroundFill areas. + backgroundFill is added to pad images when images of different + sizes are joined. + - If the background is clear there is no background layer. + - If there is a background character then the bottom layer is the + background layer. + - emptyPicture is a Picture with no layers and no cursor + - addToTop and addToBottom add a layer to the top and bottom of the + given Picture. + - compatibility improvements: + - terminfo based terminals with no cursor support are silently + accepted. The cursor visibility changes in the Picture will have + no effect. + - alternate (setf/setb) color maps supported. Though colors beyond + the first 8 are just a guess. + - added "rgbColor" for easy support of RGB specified colors. + - Both applications and users can add to the mapping used to + translate from input bytes to events. + - Additional information about input and output process can be + appended to a debug log + - Set environment variable VTY_DEBUG_LOG to path of debug log + - Or use "debugLog " config directive + - Or set 'debugLog' property of the Config provided to mkVty. + - examples moved to vty-examples package. See test directory for cabal + file. + - vty-interactive-terminal-test + - interactive test. Useful for building a bug report for vty's + author. + - test/interactive_terminal_test.hs + - vty-event-echo + - view a input event log for vty. Example of interacting with + user. + - test/EventEcho.hs + - vty-rogue + - The start of a rogue-like game. Example of layers and image + build operations. + - test/Rogue.hs + - vty-benchmark + - benchmarks vty. A series of tests that push random pictures to + the terminal. The random pictures are generated using + QuickCheck. The same generators used in the automated tests. + - test/benchmark.hs + +4.7.0.0 + - API changes: + - Added Graphics.Vty.Image.crop: Ensure an image is no larger + than the specified size. + - Added Graphics.Vty.Image.pad: Ensure an image is no smaller + than the specified size. + - Added Graphics.Vty.Image.translate: Offset an image. + - Thanks Ben Boeckel for these features. + +4.3.0.0 + +4.2.1.0 + - API changes: + - Attr record accessor fore_color changed to attr_fore_color + - Attr record accessor back_color changed to attr_back_color + - Attr record accessor style changed to attr_style + - Added an "inline" display attribute changing DSL: + - put_attr_change applies a display attribute change + immediately to a terminal + - For instance, can be used to change the display attrbiutes + of text output via putStrLn and putStr. EX: + "put_attr_change $ back_color red" will set the background + color to red. + - Changes do not apply to a Picture output via output_picture. + - See Graphics.Vty.Inline + - Moved all IO actions into any monad an instance of MonadIO + +4.0.0.1 + - binding for mk_wcswidth was incorrect. Most platforms just + magically worked due to coincidence. + +4.0.0 + - API changes: + - "getSize" has been removed. Use "terminal vty >>= display_bounds" + where "vty" is an instance of the Vty data structure. + - added a "terminal" field to the Vty data structure. Accesses the + TerminalHandle associated with the Vty instance. + - Graphics.Vty.Types has undergone a number of changes. Summary: + - Partitioned into Graphics.Vty.Attributes for display attributes. + Graphics.Vty.Image for image combinators. Graphics.Vty.Picture + for final picture construction. + - Graphics.Vty.Attributes: + - "setFG" and "setBG" are now "with_fore_color" and + "with_back_color" + - All other "set.." equations similarly replaced. + - "attr" is now "def_attr", short for "default display attributes" + Also added a "current_attr" for "currently applied display + attributes" + - Graphics.Vty.Image: + - "horzcat" is now "horiz_cat" + - "vertcat" is now "vert_cat" + - "renderBS" is now "utf8_bytestring" + - "renderChar" is now "char" + - "renderFill" is now "char_fill" + - added a "utf8_string" and "string" (AKA "iso_10464_string") for + UTF-8 encoded Strings and ISO-10464 encoded Strings. String + literals in GHC have an ISO-10464 runtime representation. + - Graphics.Vty.Picture: + - exports Graphics.Vty.Image + - "pic" is now "pic_for_image" + - added API for setting background fill pattern. + - Completely rewritten output backend. + - Efficient, scanline style output span generator. Has not been + fully optimized, but good enough. + - The details required to display the desired picture on a + terminal are well encapsulated. + - Terminfo based display terminal implementation. With specialized + derivitives for xterm, Terminal.app, and iTerm.app. + - Attempts to robustly handle even terminals that don't + support all display attributes. + - I've tested the following terminals with success: iTerm.app, + Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal, + konsole, screen, linux vty. Hopefully you will be as + successfull. + - Improved unicode support. Double wide characters will display as + expected. + - 256 color support. See Graphics.Vty.Attributes.Color240. The actual + output color is adjusted according to the number of colors the + terminal supports. + - The Graphics.Vty.Image combinators no longer require matching + dimensions to arguments. Unspecified areas are filled in with a + user-customizable background pattern. See Graphics.Vty.Picture. + - output images are always cropped to display size. + - Significant code coverage by QuickCheck tests. An interactive test + for those final properties that couldn't be automatically verified. + +Issues resolved: + - "gnome terminal displays non-basic attributes as strikethrough" + - http://trac.haskell.org/vty/ticket/14 + - "Multi-byte characters are not displayed correctly on update" + - http://trac.haskell.org/vty/ticket/10 + - "Redraw does not handle rendering a line that extends beyond screen + width characters" + - http://trac.haskell.org/vty/ticket/13 + - "The <|> and <-> combinators should be more forgiving of mismatched + dimensions" + - http://trac.haskell.org/vty/ticket/9 + - "256-color support" + - http://trac.haskell.org/vty/ticket/19 diff --git a/Demo.hs b/Demo.hs deleted file mode 100644 --- a/Demo.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Main where - -import Graphics.Vty - -import Control.Applicative hiding ((<|>)) -import Control.Arrow -import Control.Monad.RWS - -import Data.Default (def) -import Data.Sequence (Seq, (<|) ) -import qualified Data.Sequence as Seq -import Data.Foldable - -eventBufferSize = 1000 - -type App = RWST Vty () (Seq String) IO - -main = do - vty <- if True -- change to false for emacs-like input processing - then mkVty def - else mkVty (def { vmin = Just 2, vtime = Just 300 } ) - _ <- execRWST (vtyInteract False) vty Seq.empty - shutdown vty - -vtyInteract :: Bool -> App () -vtyInteract shouldExit = do - updateDisplay - unless shouldExit $ handleNextEvent >>= vtyInteract - -introText = vertCat $ map (string defAttr) - [ "this line is hidden by the top layer" - , "The vty demo program will echo the events generated by the pressed keys." - , "Below there is a 240 color box." - , "Followed by a description of the 16 color pallete." - , "If the 240 color box is not visible then the terminal" - , "claims 240 colors are not supported." - , "Try setting TERM to xterm-256color" - , "This text is on a lower layer than the event list." - , "Which means it'll be hidden soon." - , "Bye!" - , "Great Faith in the ¯\\_(ツ)_/¯" - , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" - ] - -colorbox_240 :: Image -colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages - where - colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239] - splitColorImages [] = [] - splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) - -colorbox_16 :: Image -colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border - where - column0 = vertCat $ map lineWithColor normal - column1 = vertCat $ map lineWithColor bright - border = vertCat $ replicate (length normal) $ string defAttr " | " - column2 = vertCat $ map (string defAttr . snd) normal - lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName - normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ] - [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ] - bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue - , brightMagenta, brightCyan, brightWhite ] - [ "bright black", "bright red", "bright green", "bright yellow" - , "bright blue", "bright magenta", "bright cyan", "bright white" ] - -updateDisplay :: App () -updateDisplay = do - let info = string (defAttr `withForeColor` black `withBackColor` green) - "Press ESC to exit. Events for keys below." - eventLog <- foldMap (string defAttr) <$> get - let pic = picForImage (info <-> eventLog) - `addToBottom` (introText <-> colorbox_240 <|> colorbox_16) - vty <- ask - liftIO $ update vty pic - -handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent - where - handleEvent e = do - modify $ (<|) (show e) >>> Seq.take eventBufferSize - return $ e == EvKey KEsc [] - diff --git a/ModeDemo.hs b/ModeDemo.hs deleted file mode 100644 --- a/ModeDemo.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Main where - -import Control.Applicative -import Data.Monoid - -import Graphics.Vty - -mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image -mkUI (m, ms, p, ps) e = - vertCat [ string defAttr $ "Mouse mode supported: " <> show m - , string defAttr $ "Mouse mode status: " <> show ms - , string defAttr " " - , string defAttr $ "Paste mode supported: " <> show p - , string defAttr $ "Paste mode status: " <> show ps - , string defAttr " " - , string defAttr $ "Last event: " <> show e - , string defAttr " " - , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit." - ] - -main :: IO () -main = do - cfg <- standardIOConfig - vty <- mkVty cfg - - let renderUI lastE = do - let output = outputIface vty - info <- (,,,) <$> (pure $ supportsMode output Mouse) - <*> getModeStatus output Mouse - <*> (pure $ supportsMode output BracketedPaste) - <*> getModeStatus output BracketedPaste - return $ picForImage $ mkUI info lastE - - let go lastE = do - pic <- renderUI lastE - update vty pic - e <- nextEvent vty - case e of - EvKey (KChar 'q') [] -> return () - EvKey (KChar 'm') [] -> do - let output = outputIface vty - enabled <- getModeStatus output Mouse - setMode output Mouse (not enabled) - go (Just e) - EvKey (KChar 'p') [] -> do - let output = outputIface vty - enabled <- getModeStatus output BracketedPaste - setMode output BracketedPaste (not enabled) - go (Just e) - _ -> go (Just e) - - go Nothing - shutdown vty diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ -[![Build Status](https://travis-ci.org/coreyoconnor/vty.png)](https://travis-ci.org/coreyoconnor/vty) - -`vty` is a terminal interface library. +[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty) -This project is hosted on github.com: https://github.com/coreyoconnor/vty +`vty` is a terminal interface library. It provides a high-level +interface for doing terminal I/O. Vty is supported on GHC versions +7.10.1 and up. Install via `git` with: @@ -18,55 +18,41 @@ # Features -* Support for a large number of terminals. vt100, ansi, hurd, linux, screen etc - etc. Anything with a sufficient terminfo entry. +* Supports a large number of terminals. vt100, ansi, hurd, linux, + screen, etc., or anything with a sufficient terminfo entry. * Automatic handling of window resizes. -* If the terminal support UTF-8 then vty supports Unicode output. +* Unicode output on terminals with UTF-8 support. -* Handles multi-column glyphs. (Requires user to properly configure terminal.) +* Handles multi-column glyphs. (Requires user to properly configure + terminal.) -* Efficient output. Output buffering and terminal state changes are minimized. +* Efficient output. Output buffering and terminal state changes are + minimized. -* Minimizes repaint area. Virtually eliminating the flicker problems that - plagues ncurses programs. +* Minimizes repaint area, which virtually eliminates the flicker + problems that plague ncurses programs. -* A pure, compositional interface for efficiently constructing display images. +* A pure, compositional interface for efficiently constructing display + images. * Automatically decodes keyboard keys into (key,[modifier]) tuples. * Automatically supports refresh on Ctrl-L. -* Automatically supports timeout after for lone ESC. The timeout is +* Supports a keypress timeout after for lone ESC. The timeout is customizable. -* Interface is designed for easy compatible extension. - -* Supports ANSI graphics modes (SGR as defined in console_codes(4)) with a - type-safe interface. Gracefull fallback for terminals that do not support, or - partially support the standard ANSI graphics modes. - -* Properly handles cleanup, but not due to signals. - -* Comprehensive test suite. - -# Known Issues - -* Terminals have numerous quirks and bugs. vty picks what works best for the - author in ambigious, or buggy situations. - -* Signal handling of STOP, TERM and INT are non existent. +* The interface is designed for easy extension. -* The character encoding of the terminal is assumed to be UTF-8 if - unicode is used. +* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`) + with a type-safe interface and graceful fallback for terminals + with limited or nonexistent support for such modes. -* Terminfo is assumed to be correct unless there is an override configured. - Some terminals will not have correct special key support (shifted F10 etc). - See Config for customizing vty's behavior for a particular terminal. +* Properly handles cleanup (but not due to signals). -* Uses the TIOCGWINSZ ioctl to find the current window size, which appears to be - limited to Linux and BSD. +* Provides a comprehensive test suite. * Supports "normal" and "extended" (SGR) mouse modes as described at http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking @@ -78,20 +64,32 @@ ## Posix Terminals -Uses terminfo to determine terminal protocol. With some special rules to handle -some omissions from terminfo. +Uses terminfo to determine terminal protocol. With some special rules to +handle some omissions from terminfo. ## Windows -cygwin only. +Unsupported (but contributions and testing here are very welcome!) +# Contributing + +If you decide to contribute, that's great! Here are some guidelines you +should consider to make submitting patches easier for all concerned: + + - If you want to take on big things, talk to me first; let's have a + design/vision discussion before you start coding. Create a GitHub + issue and we can use that as the place to hash things out. + - If you make changes, make them consistent with the syntactic + conventions already used in the codebase. + - Please provide Haddock documentation for any changes you make. + # Development Notes ## Under NixOS ### Using cabal -After installing ncurses to user env. +After installing `ncurses` to the user environment: ~~~ LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib @@ -99,18 +97,10 @@ LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test ~~~ -### Using stack - -~~~ -stack build -stack test -stack install -~~~ - -## Coverage +## Code Coverage -As of last testing, profiling causes issues with coverage when enabled. To -evaluate coverage configure as follows: +As of last testing, profiling causes issues with coverage when enabled. +To evaluate coverage, configure as follows: ~~~ rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \ @@ -120,9 +110,37 @@ ## Profiling - ~~~ rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \ --enable-library-profiling \ --enable-executable-profiling ~~~ + +# Known Issues + +* Terminals have numerous quirks and bugs. Vty picks what works best for + the author in ambiguous or buggy situations. + +* Signal handling of STOP, TERM and INT are nonexistent. + +* The character encoding of the terminal is assumed to be UTF-8 if + unicode is used. + +* Terminfo is assumed to be correct unless there is an override + configured. Some terminals will not have correct special key support + (shifted F10 etc). See `Config` for customizing vty's behavior for a + particular terminal. + +* Uses the `TIOCGWINSZ` ioctl to find the current window size, which + appears to be limited to Linux and BSD. + +# Sources + +Good sources of documentation for terminal programming are: + +* https://github.com/b4winckler/vim/blob/master/src/term.c +* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html +* http://ulisse.elettra.trieste.it/services/doc/serial/config.html +* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html +* http://www.unixwiz.net/techtips/termios-vmin-vtime.html +* http://vt100.net/docs/vt100-ug/chapter3.html diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,15 +0,0 @@ -- Improve input handling - - base off of haskeline input system. The haskeline input system appears to be excellent and - satisfy all of Vty's input requirements. The current haskeline distribution does not appear to - export the required modules. Either: - 0. Add the required exports to the haskeline distribution. - - fine for development but complicates the UI for production clients. Though, exposing - the modules would only complicate the appearance of haskeline's interface. - 1. Partition the backend of haskeline into a separate package usable by both vty and - haskeline. -- use compact-string for character encoding handling -- Custom cursor appearance handling? - - specific color? - - reverse video? - - auto? - diff --git a/demos/Demo.hs b/demos/Demo.hs new file mode 100644 --- /dev/null +++ b/demos/Demo.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Graphics.Vty + +import Control.Applicative hiding ((<|>)) +import Control.Arrow +import Control.Monad.RWS + +import Data.Sequence (Seq, (<|) ) +import qualified Data.Sequence as Seq +import Data.Foldable + +eventBufferSize = 1000 + +type App = RWST Vty () (Seq String) IO + +main = do + vty <- if True -- change to false for emacs-like input processing + then mkVty defaultConfig + else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } ) + _ <- execRWST (vtyInteract False) vty Seq.empty + shutdown vty + +vtyInteract :: Bool -> App () +vtyInteract shouldExit = do + updateDisplay + unless shouldExit $ handleNextEvent >>= vtyInteract + +introText = vertCat $ map (string defAttr) + [ "this line is hidden by the top layer" + , "The vty demo program will echo the events generated by the pressed keys." + , "Below there is a 240 color box." + , "Followed by a description of the 16 color pallete." + , "If the 240 color box is not visible then the terminal" + , "claims 240 colors are not supported." + , "Try setting TERM to xterm-256color" + , "This text is on a lower layer than the event list." + , "Which means it'll be hidden soon." + , "Bye!" + , "Great Faith in the ¯\\_(ツ)_/¯" + , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" + ] + +colorbox_240 :: Image +colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages + where + colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239] + splitColorImages [] = [] + splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) + +colorbox_16 :: Image +colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border + where + column0 = vertCat $ map lineWithColor normal + column1 = vertCat $ map lineWithColor bright + border = vertCat $ replicate (length normal) $ string defAttr " | " + column2 = vertCat $ map (string defAttr . snd) normal + lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName + normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ] + [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ] + bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue + , brightMagenta, brightCyan, brightWhite ] + [ "bright black", "bright red", "bright green", "bright yellow" + , "bright blue", "bright magenta", "bright cyan", "bright white" ] + +updateDisplay :: App () +updateDisplay = do + let info = string (defAttr `withForeColor` black `withBackColor` green) + "Press ESC to exit. Events for keys below." + eventLog <- foldMap (string defAttr) <$> get + let pic = picForImage (info <-> eventLog) + `addToBottom` (introText <-> colorbox_240 <|> colorbox_16) + vty <- ask + liftIO $ update vty pic + +handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent + where + handleEvent e = do + modify $ (<|) (show e) >>> Seq.take eventBufferSize + return $ e == EvKey KEsc [] + diff --git a/demos/ModeDemo.hs b/demos/ModeDemo.hs new file mode 100644 --- /dev/null +++ b/demos/ModeDemo.hs @@ -0,0 +1,53 @@ +module Main where + +import Control.Applicative +import Data.Monoid + +import Graphics.Vty + +mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image +mkUI (m, ms, p, ps) e = + vertCat [ string defAttr $ "Mouse mode supported: " <> show m + , string defAttr $ "Mouse mode status: " <> show ms + , string defAttr " " + , string defAttr $ "Paste mode supported: " <> show p + , string defAttr $ "Paste mode status: " <> show ps + , string defAttr " " + , string defAttr $ "Last event: " <> show e + , string defAttr " " + , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit." + ] + +main :: IO () +main = do + cfg <- standardIOConfig + vty <- mkVty cfg + + let renderUI lastE = do + let output = outputIface vty + info <- (,,,) <$> (pure $ supportsMode output Mouse) + <*> getModeStatus output Mouse + <*> (pure $ supportsMode output BracketedPaste) + <*> getModeStatus output BracketedPaste + return $ picForImage $ mkUI info lastE + + let go lastE = do + pic <- renderUI lastE + update vty pic + e <- nextEvent vty + case e of + EvKey (KChar 'q') [] -> return () + EvKey (KChar 'm') [] -> do + let output = outputIface vty + enabled <- getModeStatus output Mouse + setMode output Mouse (not enabled) + go (Just e) + EvKey (KChar 'p') [] -> do + let output = outputIface vty + enabled <- getModeStatus output BracketedPaste + setMode output BracketedPaste (not enabled) + go (Just e) + _ -> go (Just e) + + go Nothing + shutdown vty diff --git a/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs b/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs deleted file mode 100644 --- a/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyAttributeOps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs b/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs deleted file mode 100644 --- a/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyCropSpanGeneration ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs b/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs deleted file mode 100644 --- a/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyDisplayAttributes ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs b/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs deleted file mode 100644 --- a/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyEmptyImageProps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs b/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs deleted file mode 100644 --- a/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyEvalTerminfoCaps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs b/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs deleted file mode 100644 --- a/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyImageOps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs b/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs deleted file mode 100644 --- a/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyImageTrans ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs b/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs deleted file mode 100644 --- a/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyInline ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs b/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs deleted file mode 100644 --- a/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyLayersSpanGeneration ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs b/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs deleted file mode 100644 --- a/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyParseTerminfoCaps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs b/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs deleted file mode 100644 --- a/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifySimpleSpanGeneration ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs b/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs deleted file mode 100644 --- a/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyOutput ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs b/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs deleted file mode 100644 --- a/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyUsingMockTerminal ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs b/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs deleted file mode 100644 --- a/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyUtf8Width ( tests ) -main :: IO () -main = stubMain tests diff --git a/src/Codec/Binary/UTF8/Debug.hs b/src/Codec/Binary/UTF8/Debug.hs --- a/src/Codec/Binary/UTF8/Debug.hs +++ b/src/Codec/Binary/UTF8/Debug.hs @@ -1,7 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} -- Copyright 2009 Corey O'Connor -module Codec.Binary.UTF8.Debug - where +module Codec.Binary.UTF8.Debug where import Codec.Binary.UTF8.String ( encode ) @@ -9,8 +8,8 @@ import Numeric --- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the --- corresponding UTF8 byte sequence +-- | Converts an array of ISO-10646 characters (Char type) to an array +-- of Word8 bytes that is the corresponding UTF8 byte sequence utf8FromIso :: [Int] -> [Word8] utf8FromIso = encode . map toEnum diff --git a/src/Data/Terminfo/Eval.hs b/src/Data/Terminfo/Eval.hs --- a/src/Data/Terminfo/Eval.hs +++ b/src/Data/Terminfo/Eval.hs @@ -1,18 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -{- Evaluates the paramaterized terminfo string capability with the given parameters. - - - -} -module Data.Terminfo.Eval (writeCapExpr) - where +-- | Evaluates the paramaterized terminfo string capability with the +-- given parameters. +module Data.Terminfo.Eval + ( writeCapExpr + ) +where import Blaze.ByteString.Builder.Word import Blaze.ByteString.Builder @@ -27,10 +23,6 @@ import qualified Data.Vector.Unboxed as Vector -#if !(MIN_VERSION_base(4,8,0)) -import Data.Word -#endif - -- | capability evaluator state data EvalState = EvalState { evalStack :: ![CapParam] @@ -83,7 +75,7 @@ p <- pop forM_ (show p) $ tell.writeWord8.toEnum.fromEnum writeCapOp CharOut = do - pop >>= tell.writeWord8.toEnum.fromEnum + pop >>= tell.writeWord8.toEnum.fromEnum writeCapOp (PushParam pn) = do readParam pn >>= push writeCapOp (PushValue v) = do @@ -91,13 +83,14 @@ writeCapOp (Conditional expr parts) = do writeCapOps expr writeContitionalParts parts - where + where writeContitionalParts [] = return () writeContitionalParts ((trueOps, falseOps) : falseParts) = do -- (man 5 terminfo) - -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the - -- stack, testing if it is nonzero (true). If it is zero (false), control - -- passes to the %e (else) part. + -- Usually the %? expr part pushes a value onto the stack, + -- and %t pops it from the stack, testing if it is nonzero + -- (true). If it is zero (false), control passes to the %e + -- (else) part. v <- pop if v /= 0 then writeCapOps trueOps @@ -137,4 +130,3 @@ v1 <- pop v0 <- pop push $ if v0 > v1 then 1 else 0 - diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs --- a/src/Data/Terminfo/Parse.hs +++ b/src/Data/Terminfo/Parse.hs @@ -1,18 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -funbox-strict-fields -O #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Data.Terminfo.Parse ( module Data.Terminfo.Parse - , Text.Parsec.ParseError - ) - where +module Data.Terminfo.Parse + ( module Data.Terminfo.Parse + , Text.Parsec.ParseError + ) +where import Control.Monad ( liftM ) import Control.DeepSeq @@ -24,10 +20,6 @@ import Text.Parsec -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - data CapExpression = CapExpression { capOps :: !CapOps , capBytes :: !(Vector.Vector Word8) @@ -46,21 +38,21 @@ hexDump = foldr (\b s -> showHex b s) "" instance NFData CapExpression where - rnf (CapExpression ops !_bytes !str !c !pOps) + rnf (CapExpression ops !_bytes !str !c !pOps) = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps type CapParam = Word type CapOps = [CapOp] -data CapOp = +data CapOp = Bytes !Int !Int -- offset count | DecOut | CharOut - -- This stores a 0-based index to the parameter. However the operation that implies this op is - -- 1-based + -- This stores a 0-based index to the parameter. However the + -- operation that implies this op is 1-based | PushParam !Word | PushValue !Word - -- The conditional parts are the sequence of (%t expression, %e expression) pairs. - -- The %e expression may be NOP - | Conditional + -- The conditional parts are the sequence of (%t expression, %e + -- The expression) pairs. %e expression may be NOP + | Conditional { conditionalExpr :: !CapOps , conditionalParts :: ![(CapOps, CapOps)] } @@ -72,8 +64,8 @@ instance NFData CapOp where rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount rnf (PushParam pn) = rnf pn - rnf (PushValue v) = rnf v - rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts + rnf (PushValue v) = rnf v + rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts rnf BitwiseOr = () rnf BitwiseXOr = () rnf BitwiseAnd = () @@ -94,11 +86,11 @@ rnf IncFirstTwo = () parseCapExpression :: String -> Either ParseError CapExpression -parseCapExpression capString = +parseCapExpression capString = let v = runParser capExpressionParser initialBuildState - "terminfo cap" - capString + "terminfo cap" + capString in case v of Left e -> Left e Right buildResults -> Right $ constructCapExpression capString buildResults @@ -107,27 +99,27 @@ constructCapExpression capString buildResults = let expr = CapExpression { capOps = outCapOps buildResults - -- The cap bytes are the lower 8 bits of the input string's characters. - -- \todo Verify the input string actually contains an 8bit byte per character. + -- The cap bytes are the lower 8 bits of the input + -- string's characters. , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString , sourceString = capString , paramCount = outParamCount buildResults , paramOps = outParamOps buildResults - } + } in rnf expr `seq` expr -type CapParser a = Parsec String BuildState a +type CapParser a = Parsec String BuildState a capExpressionParser :: CapParser BuildResults capExpressionParser = do - rs <- many $ paramEscapeParser <|> bytesOpParser + rs <- many $ paramEscapeParser <|> bytesOpParser return $ mconcat rs paramEscapeParser :: CapParser BuildResults paramEscapeParser = do _ <- char '%' incOffset 1 - literalPercentParser <|> paramOpParser + literalPercentParser <|> paramOpParser literalPercentParser :: CapParser BuildResults literalPercentParser = do @@ -138,7 +130,7 @@ paramOpParser :: CapParser BuildResults paramOpParser - = incrementOpParser + = incrementOpParser <|> pushOpParser <|> decOutParser <|> charOutParser @@ -179,16 +171,16 @@ _ <- char '?' incOffset 1 condPart <- manyExpr conditionalTrueParser - parts <- manyP + parts <- manyP ( do truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser - , conditionalFalseParser + , conditionalFalseParser ] falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser , conditionalTrueParser ] return ( truePart, falsePart ) - ) + ) conditionalEndParser let trueParts = map fst parts @@ -208,10 +200,10 @@ return $ BuildResults n'' [ Conditional cond condParts ] pOps - where - manyP !p !end = choice + where + manyP !p !end = choice [ try end >> return [] - , do !v <- p + , do !v <- p !vs <- manyP p end return $! v : vs ] @@ -233,7 +225,7 @@ incOffset 2 bitwiseOpParser :: CapParser BuildResults -bitwiseOpParser +bitwiseOpParser = bitwiseOrParser <|> bitwiseAndParser <|> bitwiseXorParser @@ -257,9 +249,9 @@ return $ BuildResults 0 [ BitwiseXOr ] [ ] arithOpParser :: CapParser BuildResults -arithOpParser - = plusOp - <|> minusOp +arithOpParser + = plusOp + <|> minusOp where plusOp = do _ <- char '+' @@ -282,10 +274,10 @@ return $ BuildResults 0 [ PushValue n ] [ ] compareOpParser :: CapParser BuildResults -compareOpParser +compareOpParser = compareEqOp - <|> compareLtOp - <|> compareGtOp + <|> compareLtOp + <|> compareGtOp where compareEqOp = do _ <- char '=' @@ -313,14 +305,14 @@ charConstParser :: CapParser BuildResults charConstParser = do _ <- char '\'' - charValue <- liftM (toEnum . fromEnum) anyChar + charValue <- liftM (toEnum . fromEnum) anyChar _ <- char '\'' incOffset 3 return $ BuildResults 0 [ PushValue charValue ] [ ] -data BuildState = BuildState +data BuildState = BuildState { nextOffset :: Int - } + } incOffset :: Int -> CapParser () incOffset n = do @@ -339,10 +331,9 @@ instance Monoid BuildResults where mempty = BuildResults 0 [] [] - v0 `mappend` v1 + v0 `mappend` v1 = BuildResults { outParamCount = (outParamCount v0) `max` (outParamCount v1) , outCapOps = (outCapOps v0) `mappend` (outCapOps v1) , outParamOps = (outParamOps v0) `mappend` (outParamOps v1) } - diff --git a/src/Graphics/Text/Width.hs b/src/Graphics/Text/Width.hs --- a/src/Graphics/Text/Width.hs +++ b/src/Graphics/Text/Width.hs @@ -1,12 +1,13 @@ -- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE #-} {-# LANGUAGE ForeignFunctionInterface #-} -module Graphics.Text.Width ( wcwidth - , wcswidth - , safeWcwidth - , safeWcswidth - ) - where +module Graphics.Text.Width + ( wcwidth + , wcswidth + , safeWcwidth + , safeWcswidth + ) +where foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int @@ -14,16 +15,19 @@ wcswidth = sum . map wcwidth -- XXX: Characters with unknown widths occupy 1 column? --- --- Not sure if this is actually correct. I presume there is a replacement character that is output --- by the terminal instead of the character and this replacement character is 1 column wide. If this --- is not true for all terminals then a per-terminal replacement character width needs to be --- implemented. +-- +-- Not sure if this is actually correct. I presume there is a +-- replacement character that is output by the terminal instead of the +-- character and this replacement character is 1 column wide. If this is +-- not true for all terminals then a per-terminal replacement character +-- width needs to be implemented. --- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width +-- | Returns the display width of a character. Assumes all characters +-- with unknown widths are 0 width. safeWcwidth :: Char -> Int safeWcwidth = max 0 . wcwidth --- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width +-- | Returns the display width of a string. Assumes all characters with +-- unknown widths are 0 width. safeWcswidth :: String -> Int safeWcswidth = sum . map safeWcwidth diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs --- a/src/Graphics/Vty.hs +++ b/src/Graphics/Vty.hs @@ -1,17 +1,14 @@ --- | Vty supports input and output to terminal devices. --- --- - Input to the terminal is provided to the app as a sequence of 'Event's. --- --- - The output is defined by a 'Picture'. Which is one or more layers of 'Image's. --- --- - The module "Graphics.Vty.Image" provides a number of constructor equations that will build --- correct 'Image' values. See 'string', '<|>', and '<->' for starters. +-- | Vty provides interfaces for both terminal input and terminal +-- output. -- --- - The constructors in "Graphics.Vty.Image.Internal" should not be used. +-- - Input to the terminal is provided to the Vty application as a +-- sequence of 'Event's. -- --- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes". --- --- See the vty-examples package for a number of examples. +-- - Output is provided to Vty by the application in the form of a +-- 'Picture'. A 'Picture' is one or more layers of 'Image's. +-- 'Image' values can be built by the various constructors in +-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute) +-- values in the "Graphics.Vty.Attributes" module. -- -- @ -- import "Graphics.Vty" @@ -28,89 +25,80 @@ -- 'shutdown' vty -- 'print' (\"Last event was: \" '++' 'show' e) -- @ --- --- Good sources of documentation for terminal programming are: --- --- - --- --- - --- --- - --- --- - --- --- - --- --- - -module Graphics.Vty ( Vty(..) - , mkVty - , module Graphics.Vty.Config - , module Graphics.Vty.Input - , module Graphics.Vty.Output - , module Graphics.Vty.Picture - , DisplayRegion - , Mode(..) - ) - where - -import Graphics.Vty.Prelude +module Graphics.Vty + ( Vty(..) + , mkVty + , Mode(..) + , module Graphics.Vty.Config + , module Graphics.Vty.Input + , module Graphics.Vty.Output + , module Graphics.Vty.Output.Interface + , module Graphics.Vty.Picture + , module Graphics.Vty.Image + , module Graphics.Vty.Attributes + ) +where import Graphics.Vty.Config import Graphics.Vty.Input import Graphics.Vty.Output import Graphics.Vty.Output.Interface import Graphics.Vty.Picture +import Graphics.Vty.Image +import Graphics.Vty.Attributes import Control.Concurrent.STM import Data.IORef import Data.Monoid --- | The main object. At most one should be created. +-- | A Vty value represents a handle to the Vty library that the +-- application must create in order to use Vty. -- -- The use of Vty typically follows this process: -- --- 0. initialize vty --- --- 1. use the update equation of Vty to display a picture +-- 1. Initialize vty -- --- 2. repeat +-- 2. Use 'update' to display a picture. -- --- 3. shutdown vty. +-- 3. Use 'nextEvent' to get the next input event. -- --- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe". +-- 4. Depending on the event, go to 2 or 5. -- --- This does not assure any thread safety. In theory, as long as an update action is not executed --- when another update action is already then it's safe to call this on multiple threads. +-- 5. Shutdown vty. -- --- \todo Remove explicit `shutdown` requirement. -data Vty = Vty - { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context - -- implicitly managed by Vty. The managed display context is reset on resize. +-- Operations on Vty handles are not thread-safe. +data Vty = Vty + { -- | Outputs the given 'Picture'. update :: Picture -> IO () - -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event - -- is a 'EvResize'. + -- | Get one 'Event' object, blocking if none are available. This + -- will refresh the terminal if the event is a 'EvResize'. , nextEvent :: IO Event - -- | The input interface. See 'Input' + -- | The input interface. See 'Input'. , inputIface :: Input - -- | The output interface. See 'Output' + -- | The output interface. See 'Output'. , outputIface :: Output - -- | Refresh the display. 'nextEvent' will refresh the display if a resize occurs. - -- If other programs output to the terminal and mess up the display then the application might - -- want to force a refresh. + -- | Refresh the display. 'nextEvent' will refresh the display if + -- a resize occurs, but this can be used to refresh the display + -- explicitly. If other programs output to the terminal and mess + -- up the display then the application might want to force a + -- refresh using this function. , refresh :: IO () - -- | Clean up after vty. - -- The above methods will throw an exception if executed after this is executed. - , shutdown :: IO () + -- | Clean up after vty. A call to this function is necessary to + -- cleanly restore the terminal state before application exit. The + -- above methods will throw an exception if executed after this is + -- executed. + , shutdown :: IO () } --- | Set up the state object for using vty. At most one state object should be --- created at a time for a given terminal device. +-- | Create a Vty handle. At most one handle should be created at a time +-- for a given terminal device. -- --- The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence. --- See "Graphics.Vty.Config" +-- The specified configuration is added to the the configuration +-- loaded by 'userConfig' with the 'userConfig' configuration taking +-- precedence. See "Graphics.Vty.Config". -- --- For most applications @mkVty def@ is sufficient. +-- For most applications @mkVty defaultConfig@ is sufficient. mkVty :: Config -> IO Vty mkVty appConfig = do config <- (<> appConfig) <$> userConfig @@ -157,7 +145,7 @@ maybe (return ()) innerUpdate mPic let gkey = do k <- atomically $ readTChan $ _eventChannel input - case k of + case k of (EvResize _ _) -> displayBounds out >>= return . (\(w,h)-> EvResize w h) _ -> return k @@ -169,4 +157,3 @@ , refresh = innerRefresh , shutdown = shutdownIo } - diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs --- a/src/Graphics/Vty/Attributes.hs +++ b/src/Graphics/Vty/Attributes.hs @@ -1,68 +1,83 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -- | Display attributes -- --- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes: +-- Attributes have three components: a foreground color, a background +-- color, and a style mask. The simplest attribute is the default +-- attribute, or 'defAttr'. Attributes can be modified with +-- 'withForeColor', 'withBackColor', and 'withStyle', e.g., -- -- @ -- defAttr `withForeColor` red -- @ -- --- Is the attribute that will set the foreground color to red and the background color to the --- default. --- --- This can then be used to build an image wiht a red foreground like so: +-- 'Image' constructors often require an 'Attr' to indicate the +-- attributes used in the image, e.g., -- -- @ --- string (defAttr `withForeColor` red) "this text will be red" +-- string (defAttr `withForeColor` red) "this text will be red" -- @ -- --- The default attributes set by 'defAttr' have a presentation determined by the terminal. This is --- not something VTY can control. The user is free to define the color scheme of the terminal as --- they see fit. Up to the limits of the terminal anyways. --- --- The value 'currentAttr' will keep the attributes of whatever was output previously. +-- The appearance of 'Image's using 'defAttr' is determined by the The +-- terminal, so this is not something VTY can control. The user is free +-- to The define the color scheme of the terminal as they see fit. -- --- \todo This API is very verbose IMO. I'd like something more succinct. -module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes - , module Graphics.Vty.Attributes.Color - , module Graphics.Vty.Attributes.Color240 - ) - where +-- The value 'currentAttr' will keep the attributes of whatever was +-- output previously. +module Graphics.Vty.Attributes + ( Attr(..) + , FixedAttr(..) + , MaybeDefault(..) + , defAttr + , currentAttr + -- * Styles + , Style + , withStyle + , standout + , underline + , reverseVideo + , blink + , dim + , bold + , defaultStyleMask + , styleMask + , hasStyle + + -- * Setting attribute colors + , withForeColor + , withBackColor + + -- * Colors + , module Graphics.Vty.Attributes.Color + , module Graphics.Vty.Attributes.Color240 + ) +where + import Data.Bits -import Data.Default import Data.Word import Graphics.Vty.Attributes.Color import Graphics.Vty.Attributes.Color240 -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - --- | A display attribute defines the Color and Style of all the characters rendered after the --- attribute is applied. +-- | A display attribute defines the Color and Style of all the +-- characters rendered after the attribute is applied. -- --- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and --- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more --- information. +-- At most 256 colors, picked from a 240 and 16 color palette, are +-- possible for the background and foreground. The 240 colors and +-- 16 colors are points in different palettes. See Color for more +-- information. data Attr = Attr { attrStyle :: !(MaybeDefault Style) , attrForeColor :: !(MaybeDefault Color) , attrBackColor :: !(MaybeDefault Color) } deriving ( Eq, Show, Read ) --- This could be encoded into a single 32 bit word. The 32 bit word is first divided --- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to --- the other groups. +-- This could be encoded into a single 32 bit word. The 32 bit word is +-- first divided into 4 groups of 8 bits where: The first group codes +-- what action should be taken with regards to the other groups. -- XXYYZZ__ -- XX - style action -- 00 => reset to default @@ -93,22 +108,24 @@ instance Monoid Attr where mempty = Attr mempty mempty mempty - mappend attr0 attr1 = + mappend attr0 attr1 = Attr ( attrStyle attr0 `mappend` attrStyle attr1 ) ( attrForeColor attr0 `mappend` attrForeColor attr1 ) ( attrBackColor attr0 `mappend` attrBackColor attr1 ) --- | Specifies the display attributes such that the final style and color values do not depend on --- the previously applied display attribute. The display attributes can still depend on the --- terminal's default colors (unfortunately). +-- | Specifies the display attributes such that the final style and +-- color values do not depend on the previously applied display +-- attribute. The display attributes can still depend on the terminal's +-- default colors (unfortunately). data FixedAttr = FixedAttr { fixedStyle :: !Style , fixedForeColor :: !(Maybe Color) , fixedBackColor :: !(Maybe Color) } deriving ( Eq, Show ) --- | The style and color attributes can either be the terminal defaults. Or be equivalent to the --- previously applied style. Or be a specific value. +-- | The style and color attributes can either be the terminal defaults. +-- Or be equivalent to the previously applied style. Or be a specific +-- value. data MaybeDefault v where Default :: MaybeDefault v KeepCurrent :: MaybeDefault v @@ -130,31 +147,9 @@ mappend ( SetTo v ) KeepCurrent = SetTo v mappend ( SetTo _ ) ( SetTo v ) = SetTo v --- | Standard 8-color ANSI terminal color codes. -black, red, green, yellow, blue, magenta, cyan, white :: Color -black = ISOColor 0 -red = ISOColor 1 -green = ISOColor 2 -yellow = ISOColor 3 -blue = ISOColor 4 -magenta= ISOColor 5 -cyan = ISOColor 6 -white = ISOColor 7 - --- | Bright/Vivid variants of the standard 8-color ANSI -brightBlack, brightRed, brightGreen, brightYellow :: Color -brightBlue, brightMagenta, brightCyan, brightWhite :: Color -brightBlack = ISOColor 8 -brightRed = ISOColor 9 -brightGreen = ISOColor 10 -brightYellow = ISOColor 11 -brightBlue = ISOColor 12 -brightMagenta= ISOColor 13 -brightCyan = ISOColor 14 -brightWhite = ISOColor 15 - --- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute --- assigned to that bit should be applied and 0 if the style attribute should not be applied. +-- | Styles are represented as an 8 bit word. Each bit in the word is 1 +-- if the style attribute assigned to that bit should be applied and 0 +-- if the style attribute should not be applied. type Style = Word8 -- | The 6 possible style attributes: @@ -171,8 +166,8 @@ -- -- * bold/bright -- --- ( The invisible, protect, and altcharset display attributes some terminals support are not --- supported via VTY.) +-- (The invisible, protect, and altcharset display attributes some +-- terminals support are not supported via VTY.) standout, underline, reverseVideo, blink, dim, bold :: Style standout = 0x01 underline = 0x02 @@ -185,7 +180,7 @@ defaultStyleMask = 0x00 styleMask :: Attr -> Word8 -styleMask attr +styleMask attr = case attrStyle attr of Default -> 0 KeepCurrent -> 0 @@ -207,21 +202,18 @@ withStyle :: Attr -> Style -> Attr withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } --- | Sets the style, background color and foreground color to the default values for the terminal. --- There is no easy way to determine what the default background and foreground colors are. +-- | Sets the style, background color and foreground color to the +-- default values for the terminal. There is no easy way to determine +-- what the default background and foreground colors are. defAttr :: Attr defAttr = Attr Default Default Default -instance Default Attr where - def = defAttr - --- | Keeps the style, background color and foreground color that was previously set. Used to --- override some part of the previous style. +-- | Keeps the style, background color and foreground color that was +-- previously set. Used to override some part of the previous style. -- -- EG: current_style `withForeColor` brightMagenta -- --- Would be the currently applied style (be it underline, bold, etc) but with the foreground color --- set to brightMagenta. +-- Would be the currently applied style (be it underline, bold, etc) but +-- with the foreground color set to brightMagenta. currentAttr :: Attr currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent - diff --git a/src/Graphics/Vty/Attributes/Color.hs b/src/Graphics/Vty/Attributes/Color.hs --- a/src/Graphics/Vty/Attributes/Color.hs +++ b/src/Graphics/Vty/Attributes/Color.hs @@ -1,16 +1,39 @@ -module Graphics.Vty.Attributes.Color where +module Graphics.Vty.Attributes.Color + ( Color(..) + , black + , red + , green + , yellow + , blue + , magenta + , cyan + , white + , brightBlack + , brightRed + , brightGreen + , brightYellow + , brightBlue + , brightMagenta + , brightCyan + , brightWhite + ) +where + import Data.Word -- | Abstract data type representing a color. --- --- Currently the foreground and background color are specified as points in either a: -- --- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8 --- color palette and the second 8 colors are bright/vivid versions of the first 8 colors. +-- Currently the foreground and background color are specified as points +-- in either a: -- --- * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first --- 224 colors. The remaining 16 colors is a greyscale palette. --- +-- * 16 color palette. Where the first 8 colors are equal to the 8 +-- colors of the ISO 6429 (ANSI) 8 color palette and the second 8 +-- colors are bright/vivid versions of the first 8 colors. +-- +-- * 240 color palette. This palette is a regular sampling of the full +-- RGB colorspace for the first 224 colors. The remaining 16 colors is +-- a greyscale palette. +-- -- The 8 ISO 6429 (ANSI) colors are as follows: -- -- 0. black @@ -29,23 +52,49 @@ -- -- 7. white -- --- The mapping from points in the 240 color palette to colors actually displayable by the terminal --- depends on the number of colors the terminal claims to support. Which is usually determined by --- the terminfo "colors" property. If this property is not being accurately reported then the color --- reproduction will be incorrect. +-- The mapping from points in the 240 color palette to colors actually +-- displayable by the terminal depends on the number of colors the +-- terminal claims to support. Which is usually determined by the +-- terminfo "colors" property. If this property is not being accurately +-- reported then the color reproduction will be incorrect. -- --- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8 --- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not --- addressable via the 240 color palette. +-- If the terminal reports <= 16 colors then the 240 color palette +-- points are only mapped to the 8 color pallete. I'm not sure of +-- the RGB points for the "bright" colors which is why they are not +-- addressable via the 240 color palette. -- --- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest --- points in a ("color count" - 16) subsampling of the 240 color palette. +-- If the terminal reports > 16 colors then the 240 color palette +-- points are mapped to the nearest points in a ("color count" - 16) +-- subsampling of the 240 color palette. -- --- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors. --- And that the individual colors have not been remapped by the user. There may be a way to verify --- this through terminfo but I don't know it. +-- All of this assumes the terminals are behaving similarly to xterm and +-- rxvt when handling colors. And that the individual colors have not +-- been remapped by the user. There may be a way to verify this through +-- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE. data Color = ISOColor !Word8 | Color240 !Word8 deriving ( Eq, Show, Read ) +-- | Standard 8-color ANSI terminal color codes. +black, red, green, yellow, blue, magenta, cyan, white :: Color +black = ISOColor 0 +red = ISOColor 1 +green = ISOColor 2 +yellow = ISOColor 3 +blue = ISOColor 4 +magenta= ISOColor 5 +cyan = ISOColor 6 +white = ISOColor 7 + +-- | Bright/Vivid variants of the standard 8-color ANSI +brightBlack, brightRed, brightGreen, brightYellow :: Color +brightBlue, brightMagenta, brightCyan, brightWhite :: Color +brightBlack = ISOColor 8 +brightRed = ISOColor 9 +brightGreen = ISOColor 10 +brightYellow = ISOColor 11 +brightBlue = ISOColor 12 +brightMagenta= ISOColor 13 +brightCyan = ISOColor 14 +brightWhite = ISOColor 15 diff --git a/src/Graphics/Vty/Attributes/Color240.hs b/src/Graphics/Vty/Attributes/Color240.hs --- a/src/Graphics/Vty/Attributes/Color240.hs +++ b/src/Graphics/Vty/Attributes/Color240.hs @@ -1,16 +1,17 @@ -{- - - This header file was generated by ./256colres.pl - -} -module Graphics.Vty.Attributes.Color240 where +-- This header file was generated by ./256colres.pl +module Graphics.Vty.Attributes.Color240 + ( rgbColor + ) +where import Graphics.Vty.Attributes.Color import Text.Printf --- | RGB color to 240 color palette. --- --- generated from 256colres.pl which is forked from xterm 256colres.pl --- todo: all values get clamped high. +-- Note: rgbColor's mapping from RGB to 240 colors was generated from +-- 256colres.pl which is forked from xterm 256colres.pl. + +-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple. rgbColor :: Integral i => i -> i -> i -> Color rgbColor r g b | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" @@ -254,8 +255,7 @@ | r <= 255 && g <= 255 && b <= 175 = Color240 213 | r <= 255 && g <= 255 && b <= 215 = Color240 214 | r <= 255 && g <= 255 && b <= 255 = Color240 215 - | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." + | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." (fromIntegral r :: Int) (fromIntegral g :: Int) (fromIntegral b :: Int)) - diff --git a/src/Graphics/Vty/Config.hs b/src/Graphics/Vty/Config.hs --- a/src/Graphics/Vty/Config.hs +++ b/src/Graphics/Vty/Config.hs @@ -1,23 +1,13 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} --- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can --- be used to customize vty for a user's system. --- --- The 'Config' provided is mappend'd to 'Config's loaded from @'getAppUserDataDirectory'/config@ --- and @$VTY_CONFIG_FILE@. The @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the --- application provided 'Config'. --- --- Lines in config files that fail to parse are ignored. Later entries take precedence over --- earlier. +-- | Vty supports a configuration file format and associated 'Config' +-- data type. The 'Config' can be provided to 'mkVty' to customize the +-- application's use of Vty. -- --- For all directives: --- --- @ --- string := \"\\\"\" chars+ \"\\\"\" --- @ +-- Lines in config files that fail to parse are ignored. Later entries +-- take precedence over earlier ones. -- -- = Debug -- @@ -29,8 +19,8 @@ -- \"debugLog\" string -- @ -- --- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent to a debugLog entry at the --- end of the last config file. +-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent +-- to a debugLog entry at the end of the last config file. -- -- = Input Processing -- @@ -40,14 +30,14 @@ -- -- @ -- \"map\" term string key modifier_list --- where +-- where -- key := KEsc | KChar Char | KBS ... (same as 'Key') -- modifier_list := \"[\" modifier+ \"]\" -- modifier := MShift | MCtrl | MMeta | MAlt -- term := "_" | string -- @ -- --- EG: If the contents are +-- E.g., if the contents are -- -- @ -- map _ \"\\ESC[B\" KUp [] @@ -55,16 +45,15 @@ -- map \"xterm\" \"\\ESC[D\" KLeft [] -- @ -- --- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all terminals. The bytes --- @\"\\ESC[1;3B\"@ will result in the event KDown with the MAlt modifier on all terminals. --- The bytes @\"\\ESC[D\"@ will result in the KLeft event when @TERM@ is @xterm@. --- --- If a debug log is requested then vty will output the current input table to the log in the above --- format. --- --- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings. Add corrected mappings to --- .vty/config +-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all +-- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown +-- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will +-- result in the KLeft event when @TERM@ is @xterm@. -- +-- If a debug log is requested then vty will output the current input +-- table to the log in the above format. A workflow for using this is +-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for +-- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@. module Graphics.Vty.Config ( InputMap , Config(..) @@ -74,13 +63,11 @@ , standardIOConfig , runParseConfig , parseConfigFile - ) where + , defaultConfig + ) +where -#if __GLASGOW_HASKELL__ > 704 import Prelude -#else -import Prelude hiding (catch) -#endif import Control.Applicative hiding (many) @@ -88,7 +75,6 @@ import Control.Monad (liftM, guard, void) import qualified Data.ByteString as BS -import Data.Default import Data.Monoid import Data.Typeable (Typeable) @@ -111,14 +97,14 @@ deriving (Show, Eq, Typeable) instance Exception VtyConfigurationError where -#if MIN_VERSION_base(4,8,0) displayException VtyMissingTermEnvVar = "TERM environment variable not set" -#endif --- | Mappings from input bytes to event in the order specified. Later entries take precedence over --- earlier in the case multiple entries have the same byte string. +-- | Mappings from input bytes to event in the order specified. Later +-- entries take precedence over earlier in the case multiple entries +-- have the same byte string. type InputMap = [(Maybe String, String, Event)] +-- | A Vty configuration. data Config = Config { -- | The default is 1 character. @@ -131,22 +117,25 @@ , bracketedPasteMode :: Maybe Bool -- | Debug information is appended to this file if not Nothing. , debugLog :: Maybe FilePath - -- | The (input byte, output event) pairs extend the internal input table of VTY and the table - -- from terminfo. + -- | The (input byte, output event) pairs extend the internal input + -- table of VTY and the table from terminfo. -- - -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive. + -- See "Graphics.Vty.Config" module documentation for documentation + -- of the @map@ directive. , inputMap :: InputMap - -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput' + -- | The input file descriptor to use. The default is + -- 'System.Posix.IO.stdInput' , inputFd :: Maybe Fd - -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput' + -- | The output file descriptor to use. The default is + -- 'System.Posix.IO.stdOutput' , outputFd :: Maybe Fd -- | The terminal name used to look up terminfo capabilities. -- The default is the value of the TERM environment variable. , termName :: Maybe String } deriving (Show, Eq) -instance Default Config where - def = mempty +defaultConfig :: Config +defaultConfig = mempty instance Monoid Config where mempty = Config @@ -173,20 +162,21 @@ , termName = termName c1 <|> termName c0 } --- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@ +-- | Load a configuration from @'getAppUserDataDirectory'/config@ and +-- @$VTY_CONFIG_FILE@. userConfig :: IO Config userConfig = do configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile - overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE" + overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< getEnv "VTY_CONFIG_FILE" let base = configFile <> overrideConfig mappend base <$> overrideEnvConfig overrideEnvConfig :: IO Config overrideEnvConfig = do d <- getEnv "VTY_DEBUG_LOG" - return $ def { debugLog = d } + return $ defaultConfig { debugLog = d } --- | Configures VTY using defaults suitable for terminals. This action +-- | Configures VTY using defaults suitable for terminals. This function -- can raise 'VtyConfigurationError'. standardIOConfig :: IO Config standardIOConfig = do @@ -194,7 +184,7 @@ case mb of Nothing -> throwIO VtyMissingTermEnvVar Just t -> - return def + return defaultConfig { vmin = Just 1 , mouseMode = Just False , bracketedPasteMode = Just False @@ -207,20 +197,18 @@ parseConfigFile :: FilePath -> IO Config parseConfigFile path = do catch (runParseConfig path <$> BS.readFile path) - (\(_ :: IOException) -> return def) + (\(_ :: IOException) -> return defaultConfig) runParseConfig :: String -> BS.ByteString -> Config runParseConfig name cfgTxt = case runParser parseConfig () name cfgTxt of Right cfg -> cfg - Left{} -> def + Left{} -> defaultConfig ------------------------------------------------------------------------ type Parser = Parsec BS.ByteString () --- I tried to use the haskellStyle here but that was specialized (without requirement?) to the --- String stream type. configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m configLanguage = LanguageDef { commentStart = "{-" @@ -247,13 +235,13 @@ bytes <- P.stringLiteral configLexer key <- parseValue modifiers <- parseValue - return def { inputMap = [(termIdent, bytes, EvKey key modifiers)] } + return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] } debugLogDecl :: Parser Config debugLogDecl = do "debugLog" <- P.identifier configLexer path <- P.stringLiteral configLexer - return def { debugLog = Just path } + return defaultConfig { debugLog = Just path } ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline @@ -262,7 +250,7 @@ parseConfig = liftM mconcat $ many $ do P.whiteSpace configLexer let directives = [try mapDecl, try debugLogDecl] - choice directives <|> (ignoreLine >> return def) + choice directives <|> (ignoreLine >> return defaultConfig) class Parse a where parseValue :: Parser a instance Parse Char where parseValue = P.charLiteral configLexer diff --git a/src/Graphics/Vty/Debug.hs b/src/Graphics/Vty/Debug.hs --- a/src/Graphics/Vty/Debug.hs +++ b/src/Graphics/Vty/Debug.hs @@ -1,19 +1,19 @@ -- Copyright 2009-2010 Corey O'Connor -module Graphics.Vty.Debug ( module Graphics.Vty.Debug - , module Graphics.Vty.Debug.Image - ) +module Graphics.Vty.Debug + ( module Graphics.Vty.Debug + , module Graphics.Vty.Debug.Image + ) where -import Graphics.Vty.Prelude - import Graphics.Vty.Attributes +import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Debug.Image import Graphics.Vty.Span -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector rowOpsEffectedColumns :: DisplayOps -> [Int] -rowOpsEffectedColumns ops +rowOpsEffectedColumns ops = Vector.toList $ Vector.map spanOpsEffectedColumns ops allSpansHaveWidth :: DisplayOps -> Int -> Bool @@ -23,7 +23,7 @@ spanOpsEffectedRows :: DisplayOps -> Int spanOpsEffectedRows ops = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops)) - + type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr @@ -37,4 +37,3 @@ regionForWindow :: MockWindow -> DisplayRegion regionForWindow (MockWindow w h) = (w,h) - diff --git a/src/Graphics/Vty/Debug/Image.hs b/src/Graphics/Vty/Debug/Image.hs --- a/src/Graphics/Vty/Debug/Image.hs +++ b/src/Graphics/Vty/Debug/Image.hs @@ -19,7 +19,7 @@ type ImageEndo = Image -> Image debugImageOps :: [ImageOp] -debugImageOps = +debugImageOps = [ idImageOp -- , renderSingleColumnCharOp -- , renderDoubleColumnCharOp diff --git a/src/Graphics/Vty/DisplayAttributes.hs b/src/Graphics/Vty/DisplayAttributes.hs --- a/src/Graphics/Vty/DisplayAttributes.hs +++ b/src/Graphics/Vty/DisplayAttributes.hs @@ -1,25 +1,16 @@ -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Graphics.Vty.DisplayAttributes - where +module Graphics.Vty.DisplayAttributes where import Graphics.Vty.Attributes import Data.Bits ((.&.)) -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..), mconcat) -#endif - --- | Given the previously applied display attributes as a FixedAttr and the current display --- attributes as an Attr produces a FixedAttr that represents the current display attributes. This --- is done by using the previously applied display attributes to remove the "KeepCurrent" +-- | Given the previously applied display attributes as a FixedAttr and +-- the current display attributes as an Attr produces a FixedAttr that +-- represents the current display attributes. This is done by using the +-- previously applied display attributes to remove the "KeepCurrent" -- abstraction. fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr fixDisplayAttr fattr attr @@ -34,12 +25,13 @@ fixColor c KeepCurrent = c fixColor _c (SetTo c) = Just c --- | difference between two display attributes. Used in the calculation of the operations required --- to go from one display attribute to the next. +-- | difference between two display attributes. Used in the calculation +-- of the operations required to go from one display attribute to the +-- next. -- --- Previously, vty would reset display attributes to default then apply the new display attributes. --- This turned out to be very expensive: A *lot* more data would be sent to the terminal than --- required. +-- Previously, vty would reset display attributes to default then apply +-- the new display attributes. This turned out to be very expensive: A +-- *lot* more data would be sent to the terminal than required. data DisplayAttrDiff = DisplayAttrDiff { styleDiffs :: [StyleStateChange] , foreColorDiff :: DisplayColorDiff @@ -56,15 +48,11 @@ in DisplayAttrDiff ds fcd bcd -- | Used in the computation of a final style attribute change. --- --- TODO(corey): not really a simplify but a monoid instance. simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange] simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1 --- | Consider two display color attributes diffs. What display color attribute diff are these --- equivalent to? --- --- TODO(corey): not really a simplify but a monoid instance. +-- | Consider two display color attributes diffs. What display color +-- attribute diff are these equivalent to? simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplifyColorDiffs _cd ColorToDefault = ColorToDefault simplifyColorDiffs cd NoColorChange = cd @@ -77,9 +65,9 @@ | SetColor !Color deriving (Show, Eq) --- | Style attribute changes are transformed into a sequence of apply/removes of the individual --- attributes. -data StyleStateChange +-- | Style attribute changes are transformed into a sequence of +-- apply/removes of the individual attributes. +data StyleStateChange = ApplyStandout | RemoveStandout | ApplyUnderline @@ -94,8 +82,8 @@ | RemoveBold deriving (Show, Eq) --- | Determines the diff between two display&color attributes. This diff determines the operations --- that actually get output to the terminal. +-- | Determines the diff between two display&color attributes. This diff +-- determines the operations that actually get output to the terminal. displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff displayAttrDiffs attr attr' = DisplayAttrDiff { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr') diff --git a/src/Graphics/Vty/Error.hs b/src/Graphics/Vty/Error.hs --- a/src/Graphics/Vty/Error.hs +++ b/src/Graphics/Vty/Error.hs @@ -1,8 +1,8 @@ -module Graphics.Vty.Error - where +module Graphics.Vty.Error where -- | The type of exceptions specific to vty. -- --- These have fully qualified names by default since, IMO, exception handling requires this. +-- These have fully qualified names by default since, IMO, exception +-- handling requires this. data VtyException = VtyFailure String -- ^ Uncategorized failure specific to vty. diff --git a/src/Graphics/Vty/Image.hs b/src/Graphics/Vty/Image.hs --- a/src/Graphics/Vty/Image.hs +++ b/src/Graphics/Vty/Image.hs @@ -2,47 +2,59 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -module Graphics.Vty.Image ( DisplayText - , Image - , imageWidth - , imageHeight - , horizJoin - , (<|>) - , vertJoin - , (<->) - , horizCat - , vertCat - , backgroundFill - , text - , text' - , char - , string - , iso10646String - , utf8String - , utf8Bytestring - , utf8Bytestring' - , charFill - , emptyImage - , safeWcwidth - , safeWcswidth - , wcwidth - , wcswidth - , crop - , cropRight - , cropLeft - , cropBottom - , cropTop - , pad - , resize - , resizeWidth - , resizeHeight - , translate - , translateX - , translateY - -- | The possible display attributes used in constructing an `Image`. - , module Graphics.Vty.Attributes - ) - where +-- | A Vty program makes 'Picture's from 'Image's. This module provides +-- the core constructors for creating, combining, and modifying +-- 'Image's. +module Graphics.Vty.Image + ( + -- * Images + Image + , imageWidth + , imageHeight + -- * Image constructors + , emptyImage + , char + , string + , iso10646String + , utf8String + , text + , text' + , backgroundFill + , utf8Bytestring + , utf8Bytestring' + , charFill + -- * Combinators + , horizJoin + , (<|>) + , vertJoin + , (<->) + , horizCat + , vertCat + -- * Image modifications + , crop + , cropRight + , cropLeft + , cropBottom + , cropTop + , pad + , resize + , resizeWidth + , resizeHeight + , translate + , translateX + , translateY + -- * Character width functions + , safeWcwidth + , safeWcswidth + , wcwidth + , wcswidth + -- * Display Regions + , DisplayText + , DisplayRegion + , regionWidth + , regionHeight + ) +where import Graphics.Vty.Attributes import Graphics.Vty.Image.Internal @@ -56,115 +68,151 @@ import qualified Data.Text.Lazy.Encoding as TL import Data.Word +-- | A region of the display (first width, then height) +type DisplayRegion = (Int,Int) + +regionWidth :: DisplayRegion -> Int +regionWidth = fst + +regionHeight :: DisplayRegion -> Int +regionHeight = snd + infixr 5 <|> infixr 4 <-> --- | An area of the picture's bacground (See Background) of w columns and h rows. -backgroundFill :: Int -> Int -> Image -backgroundFill w h +-- | An area of the picture's background (See 'Background'). +backgroundFill :: Int + -- ^ Fill width in columns + -> Int + -- ^ Fill height in rows + -> Image +backgroundFill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h --- | Combines two images horizontally. Alias for horizJoin +-- | Combines two images horizontally. This is an alias for 'horizJoin'. -- -- infixr 5 (<|>) :: Image -> Image -> Image (<|>) = horizJoin --- | Combines two images vertically. Alias for vertJoin +-- | Combines two images vertically. This is an alias for 'vertJoin'. -- -- infixr 4 (<->) :: Image -> Image -> Image (<->) = vertJoin --- | Compose any number of images horizontally. +-- | Compose any number of images together horizontally, with the first +-- in the list being leftmost. horizCat :: [Image] -> Image horizCat = foldr horizJoin EmptyImage --- | Compose any number of images vertically. +-- | Compose any number of images vertically, with the first in the list +-- being topmost. vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage --- | A Data.Text.Lazy value +-- | Make an 'Image' from a lazy text value. text :: Attr -> TL.Text -> Image text a txt = let displayWidth = safeWcswidth (TL.unpack txt) in HorizText a txt displayWidth (fromIntegral $! TL.length txt) --- | A Data.Text value +-- | Make an 'Image' from a text value. text' :: Attr -> T.Text -> Image text' a txt = let displayWidth = safeWcswidth (T.unpack txt) in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) --- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in --- the ISO-10646 encoding. +-- | Make an image from a single character. This is a standard Haskell +-- 31-bit character assumed to be in the ISO-10646 encoding. char :: Attr -> Char -> Image char a c = let displayWidth = safeWcwidth c in HorizText a (TL.singleton c) displayWidth 1 --- | A string of characters layed out on a single row with the same display attribute. The string is --- assumed to be a sequence of ISO-10646 characters. +-- | Make an image from a string of characters layed out on a single +-- row with the same display attribute. The string is assumed to be a +-- sequence of ISO-10646 characters. -- --- Note: depending on how the Haskell compiler represents string literals a string literal in a --- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string. --- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry --- about the encoding format when outputting string literals. Just provide the string literal --- directly to iso10646String or string. --- +-- Note: depending on how the Haskell compiler represents string +-- literals, a string literal in a UTF-8 encoded source file, for +-- example, may be represented as a ISO-10646 string. That is, I think, +-- the case with GHC 6.10. This means, for the most part, you don't need +-- to worry about the encoding format when outputting string literals. +-- Just provide the string literal directly to iso10646String or string. iso10646String :: Attr -> String -> Image iso10646String a str = let displayWidth = safeWcswidth str in HorizText a (TL.pack str) displayWidth (length str) --- | Alias for iso10646String. Since the usual case is that a literal string like "foo" is --- represented internally as a list of ISO 10646 31 bit characters. +-- | Make an 'Image' from a 'String'. -- --- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while --- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime --- representation. +-- This is an alias for iso10646String since the usual case is that a +-- literal string like "foo" is represented internally as a list of ISO +-- 10646 31 bit characters. +-- +-- Note: Keep in mind that GHC will compile source encoded as UTF-8 +-- but the literal strings, while UTF-8 encoded in the source, will be +-- transcoded to a ISO 10646 31 bit characters runtime representation. string :: Attr -> String -> Image string = iso10646String --- | A string of characters layed out on a single row. The input is assumed to be the bytes for --- UTF-8 encoded text. +-- | Make an 'Image' from a string of characters layed out on a single +-- row. The input is assumed to be the bytes for UTF-8 encoded text. utf8String :: Attr -> [Word8] -> Image utf8String a bytes = utf8Bytestring a (BL.pack bytes) --- | Renders a UTF-8 encoded lazy bytestring. +-- | Make an 'Image' from a UTF-8 encoded lazy bytestring. utf8Bytestring :: Attr -> BL.ByteString -> Image utf8Bytestring a bs = text a (TL.decodeUtf8 bs) --- | Renders a UTF-8 encoded strict bytestring. +-- | Make an 'Image' from a UTF-8 encoded lazy bytestring. utf8Bytestring' :: Attr -> B.ByteString -> Image utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) --- | creates a fill of the specified character. The dimensions are in number of characters wide and --- number of rows high. -charFill :: Integral d => Attr -> Char -> d -> d -> Image +-- | Make an image filling a region with the specified character. +charFill :: Integral d + => Attr + -- ^ The attribute to use. + -> Char + -- ^ The character to use in filling the region. + -> d + -- ^ The region width. + -> d + -- ^ The region height. + -> Image charFill _a _c 0 _h = EmptyImage charFill _a _c _w 0 = EmptyImage charFill a c w h = vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth - where + where txt = TL.replicate (fromIntegral w) (TL.singleton c) displayWidth = safeWcwidth c * (fromIntegral w) charWidth = fromIntegral w --- | The empty image. Useful for fold combinators. These occupy no space nor define any display --- attributes. -emptyImage :: Image +-- | The empty image. Useful for fold combinators. These occupy no space +-- and do not affect display attributes. +emptyImage :: Image emptyImage = EmptyImage --- | pad the given image. This adds background character fills to the left, top, right, bottom. --- The pad values are how many display columns or rows to add. -pad :: Int -> Int -> Int -> Int -> Image -> Image +-- | Pad the given image. This adds background character fills to the +-- left, top, right, bottom. +pad :: Int + -- ^ How much padding to add to the left side of the image. + -> Int + -- ^ How much padding to add to the top of the image. + -> Int + -- ^ How much padding to add to the right side of the image. + -> Int + -- ^ How much padding to add to the bottom of the image. + -> Image + -- ^ The image to pad. + -> Image pad 0 0 0 0 i = i pad inL inT inR inB inImage | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount" | otherwise = go inL inT inR inB inImage - where - -- TODO: uh. + where go 0 0 0 0 i = i go 0 0 0 b i = VertJoin i (BGFill w b) w h where w = imageWidth i @@ -179,40 +227,51 @@ where w = imageWidth i + l h = imageHeight i --- | translates an image by padding or cropping the left and top. First param is amount to translate --- left. Second param is amount to translate top. +-- | Translates an image by padding or cropping the left and top. -- --- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than --- (0,0) will crop the image. -translate :: Int -> Int -> Image -> Image +-- If translation offsets are negative then the image is cropped. +translate :: Int + -- ^ The horizontal translation offset (can be negative) + -> Int + -- ^ The vertical translation offset (can be negative) + -> Image + -- ^ The image to translate. + -> Image translate x y i = translateX x (translateY y i) --- | translates an image by padding or cropping the left +-- | Translates an image by padding or cropping its left side. translateX :: Int -> Image -> Image translateX x i | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i) | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h --- | translates an image by padding or cropping the top +-- | Translates an image by padding or cropping its top. translateY :: Int -> Image -> Image translateY y i | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s) | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) --- | Ensure an image is no larger than the provided size. If the image is larger then crop the right --- or bottom. +-- | Ensure an image is no larger than the provided size. If the image +-- is larger then crop the right or bottom. -- --- This is transformed to a vertical crop from the bottom followed by horizontal crop from the --- right. -crop :: Int -> Int -> Image -> Image +-- This is equivalent to a vertical crop from the bottom followed by +-- horizontal crop from the right. +crop :: Int + -- ^ Cropping width + -> Int + -- ^ Cropping height + -> Image + -- ^ The image to crop + -> Image crop 0 _ _ = EmptyImage crop _ 0 _ = EmptyImage crop w h i = cropBottom h (cropRight w i) --- | crop the display height. If the image is less than or equal in height then this operation has --- no effect. Otherwise the image is cropped from the bottom. +-- | Crop an image's height. If the image's height is less than or equal +-- to the specified height then this operation has no effect. Otherwise +-- the image is cropped from the bottom. cropBottom :: Int -> Image -> Image cropBottom 0 _ = EmptyImage cropBottom h inI @@ -227,8 +286,9 @@ | h >= imageHeight i = i | otherwise = CropBottom i (imageWidth i) h --- | ensure the image is no wider than the given width. If the image is wider then crop the right --- side. +-- | Crop an image's width. If the image's width is less than or equal +-- to the specified width then this operation has no effect. Otherwise +-- the image is cropped from the right. cropRight :: Int -> Image -> Image cropRight 0 _ = EmptyImage cropRight w inI @@ -243,8 +303,9 @@ | w >= imageWidth i = i | otherwise = CropRight i w (imageHeight i) --- | ensure the image is no wider than the given width. If the image is wider then crop the left --- side. +-- | Crop an image's width. If the image's width is less than or equal +-- to the specified width then this operation has no effect. Otherwise +-- the image is cropped from the left. cropLeft :: Int -> Image -> Image cropLeft 0 _ = EmptyImage cropLeft w inI @@ -261,8 +322,9 @@ | imageWidth i <= w = i | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i) --- | crop the display height. If the image is less than or equal in height then this operation has --- no effect. Otherwise the image is cropped from the top. +-- | Crop an image's height. If the image's height is less than or equal +-- to the specified height then this operation has no effect. Otherwise +-- the image is cropped from the top. cropTop :: Int -> Image -> Image cropTop 0 _ = EmptyImage cropTop h inI @@ -279,24 +341,24 @@ | imageHeight i <= h = i | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h --- | Generic resize. Pads and crops as required to assure the given display width and height. --- This is biased to pad/crop the right and bottom. +-- | Generic resize. Pads and crops are added to ensure that the +-- resulting image matches the specified dimensions. This is biased to +-- pad/crop the right and bottom. resize :: Int -> Int -> Image -> Image resize w h i = resizeHeight h (resizeWidth w i) --- | Resize the width. Pads and crops as required to assure the given display width. --- This is biased to pad/crop the right. +-- | Resize the width. Pads and crops as required to assure the given +-- display width. This is biased to pad/crop on the right. resizeWidth :: Int -> Image -> Image resizeWidth w i = case w `compare` imageWidth i of LT -> cropRight w i EQ -> i GT -> i <|> BGFill (w - imageWidth i) (imageHeight i) --- | Resize the height. Pads and crops as required to assure the given display height. --- This is biased to pad/crop the bottom. +-- | Resize the height. Pads and crops as required to assure the given +-- display height. This is biased to pad/crop on the bottom. resizeHeight :: Int -> Image -> Image resizeHeight h i = case h `compare` imageHeight i of LT -> cropBottom h i EQ -> i GT -> i <-> BGFill (imageWidth i) (h - imageHeight i) - diff --git a/src/Graphics/Vty/Image/Internal.hs b/src/Graphics/Vty/Image/Internal.hs --- a/src/Graphics/Vty/Image/Internal.hs +++ b/src/Graphics/Vty/Image/Internal.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - module Graphics.Vty.Image.Internal where import Graphics.Vty.Attributes @@ -18,22 +13,9 @@ import qualified Data.Text.Lazy as TL -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -- | A display text is a Data.Text.Lazy --- --- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each --- application probably uses a single type. Perhaps parameterize the entire vty interface by the --- input text type? --- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance --- for the usual case of appending a bunch of characters with the same attribute together. type DisplayText = TL.Text --- TODO: store a skip list in HorizText(?) --- TODO: represent display strings containing chars that are not 1 column chars as a separate --- display string value? clipText :: DisplayText -> Int -> Int -> DisplayText clipText txt leftSkip rightClip = -- CPS would clarify this I think @@ -42,8 +24,8 @@ (toTake,padSuffix) = clipForCharWidth rightClip txt' 0 txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty) -- Note: some characters and zero-width and combining characters - -- combine to the left, so keep taking characters even if the width - -- is zero. + -- combine to the left, so keep taking characters even if the + -- width is zero. clipForCharWidth w t n | TL.null t = (n, False) | w < cw = (n, w /= 0) @@ -51,8 +33,8 @@ where cw = safeWcwidth (TL.head t) in txt'' --- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to --- create instances. +-- | This is the internal representation of Images. Use the constructors +-- in "Graphics.Vty.Image" to create instances. -- -- Images are: -- @@ -65,49 +47,61 @@ -- * a cropped image -- -- * an empty image of no size or content. -data Image = +data Image = -- | A horizontal text span has a row height of 1. HorizText { attr :: Attr - -- | The text to display. The display width of the text is always outputWidth. + -- | The text to display. The display width of the text is always + -- outputWidth. , displayText :: DisplayText -- | The number of display columns for the text. , outputWidth :: Int -- | the number of characters in the text. , charWidth :: Int } - -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is - -- required to be between two images of equal height. The horizJoin constructor adds background - -- fills to the provided images that assure this is true for the HorizJoin value produced. + -- | A horizontal join can be constructed between any two images. + -- However a HorizJoin instance is required to be between two images + -- of equal height. The horizJoin constructor adds background fills + -- to the provided images that assure this is true for the HorizJoin + -- value produced. | HorizJoin - { partLeft :: Image + { partLeft :: Image , partRight :: Image - , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 0 - , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0 + , outputWidth :: Int + -- ^ imageWidth partLeft == imageWidth partRight. Always > 0 + , outputHeight :: Int + -- ^ imageHeight partLeft == imageHeight partRight. Always > 0 } - -- | A veritical join can be constructed between any two images. However a VertJoin instance is - -- required to be between two images of equal width. The vertJoin constructor adds background - -- fills to the provides images that assure this is true for the VertJoin value produced. + -- | A veritical join can be constructed between any two images. + -- However a VertJoin instance is required to be between two images + -- of equal width. The vertJoin constructor adds background fills + -- to the provides images that assure this is true for the VertJoin + -- value produced. | VertJoin { partTop :: Image , partBottom :: Image - , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0 - , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1 + , outputWidth :: Int + -- ^ imageWidth partTop == imageWidth partBottom. always > 0 + , outputHeight :: Int + -- ^ imageHeight partTop == imageHeight partBottom. always > 1 } - -- | A background fill will be filled with the background char. The background char is - -- defined as a property of the Picture this Image is used to form. + -- | A background fill will be filled with the background char. The + -- background char is defined as a property of the Picture this + -- Image is used to form. | BGFill { outputWidth :: Int -- ^ always > 0 , outputHeight :: Int -- ^ always > 0 } - -- | Crop an image horizontally to a size by reducing the size from the right. + -- | Crop an image horizontally to a size by reducing the size from + -- the right. | CropRight { croppedImage :: Image -- | Always < imageWidth croppedImage > 0 , outputWidth :: Int , outputHeight :: Int -- ^ imageHeight croppedImage } - -- | Crop an image horizontally to a size by reducing the size from the left. + -- | Crop an image horizontally to a size by reducing the size from + -- the left. | CropLeft { croppedImage :: Image -- | Always < imageWidth croppedImage > 0 @@ -116,7 +110,8 @@ , outputWidth :: Int , outputHeight :: Int } - -- | Crop an image vertically to a size by reducing the size from the bottom + -- | Crop an image vertically to a size by reducing the size from + -- the bottom | CropBottom { croppedImage :: Image -- | imageWidth croppedImage @@ -124,7 +119,8 @@ -- | height image is cropped to. Always < imageHeight croppedImage > 0 , outputHeight :: Int } - -- | Crop an image vertically to a size by reducing the size from the top + -- | Crop an image vertically to a size by reducing the size from + -- the top | CropTop { croppedImage :: Image -- | Always < imageHeight croppedImage > 0 @@ -136,10 +132,10 @@ } -- | The empty image -- - -- The combining operators identity constant. + -- The combining operators identity constant. -- EmptyImage <|> a = a -- EmptyImage <-> a = a - -- + -- -- Any image of zero size equals the empty image. | EmptyImage deriving (Eq, Generic) @@ -198,7 +194,7 @@ = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp _ EmptyImage = "EmptyImage" - + instance NFData Image where rnf EmptyImage = () rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` () @@ -210,7 +206,8 @@ rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` () rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` () --- | The width of an Image. This is the number display columns the image will occupy. +-- | The width of an Image. This is the number display columns the image +-- will occupy. imageWidth :: Image -> Int imageWidth HorizText { outputWidth = w } = w imageWidth HorizJoin { outputWidth = w } = w @@ -222,7 +219,8 @@ imageWidth CropTop { outputWidth = w } = w imageWidth EmptyImage = 0 --- | The height of an Image. This is the number of display rows the image will occupy. +-- | The height of an Image. This is the number of display rows the +-- image will occupy. imageHeight :: Image -> Int imageHeight HorizText {} = 1 imageHeight HorizJoin { outputHeight = h } = h @@ -234,27 +232,26 @@ imageHeight CropTop { outputHeight = h } = h imageHeight EmptyImage = 0 --- | Append in the Monoid instance is equivalent to <->. +-- | Append in the Monoid instance is equivalent to <->. instance Monoid Image where mempty = EmptyImage mappend = vertJoin -- | combines two images side by side -- --- Combines text chunks where possible. Assures outputWidth and outputHeight properties are not --- violated. --- --- The result image will have a width equal to the sum of the two images width. And the height will --- equal the largest height of the two images. The area not defined in one image due to a height --- missmatch will be filled with the background pattern. +-- Combines text chunks where possible. Assures outputWidth and +-- outputHeight properties are not violated. -- --- TODO: the bg fill is biased towards top to bottom languages(?) +-- The result image will have a width equal to the sum of the two images +-- width. And the height will equal the largest height of the two +-- images. The area not defined in one image due to a height missmatch +-- will be filled with the background pattern. horizJoin :: Image -> Image -> Image horizJoin EmptyImage i = i horizJoin i EmptyImage = i horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1) | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1) - -- TODO: assumes horiz text height is always 1 + -- assumes horiz text height is always 1 | otherwise = HorizJoin i0 i1 (w0 + w1) 1 horizJoin i0 i1 -- If the images are of the same height then no padding is required @@ -276,19 +273,19 @@ -- | combines two images vertically -- --- The result image will have a height equal to the sum of the heights of both images. --- The width will equal the largest width of the two images. --- The area not defined in one image due to a width missmatch will be filled with the background --- pattern. --- --- TODO: the bg fill is biased towards right to left languages(?) +-- The result image will have a height equal to the sum of the heights +-- of both images. The width will equal the largest width of the two +-- images. The area not defined in one image due to a width missmatch +-- will be filled with the background pattern. vertJoin :: Image -> Image -> Image vertJoin EmptyImage i = i vertJoin i EmptyImage = i vertJoin i0 i1 - -- If the images are of the same width then no background padding is required + -- If the images are of the same width then no background padding is + -- required | w0 == w1 = VertJoin i0 i1 w0 h - -- Otherwise one of the images needs to be padded to the size of the other image. + -- Otherwise one of the images needs to be padded to the size of the + -- other image. | w0 < w1 = let padAmount = w1 - w0 in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h @@ -302,4 +299,3 @@ h1 = imageHeight i1 h = h0 + h1 vertJoin _ _ = error "vertJoin applied to undefined values." - diff --git a/src/Graphics/Vty/Inline.hs b/src/Graphics/Vty/Inline.hs --- a/src/Graphics/Vty/Inline.hs +++ b/src/Graphics/Vty/Inline.hs @@ -1,45 +1,43 @@ --- | The inline module provides a limited interface to changing the style of terminal output. The --- intention is for this interface to be used inline with other output systems. +{-# LANGUAGE BangPatterns #-} + +-- | The inline module provides a limited interface to changing the +-- style of terminal output. The intention is for this interface to be +-- used inline with other output systems. -- --- The changes specified by the InlineM monad are applied to the terminals display attributes. These --- display attributes effect the display of all following text output to the terminal file --- descriptor. +-- The changes specified by the InlineM monad are applied to the +-- terminal's display attributes. These display attributes affect the +-- display of all following text output to the terminal file descriptor. -- --- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the --- text \" Styled! \" drawn over a red background and underlined. +-- For example, in an IO monad the following code will print the text +-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red +-- background and underlined. -- -- @ -- putStr \"Not styled. \" -- putAttrChange_ $ do --- backColor red +-- backColor red -- applyStyle underline -- putStr \" Styled! \" -- putAttrChange_ $ defaultAll -- putStrLn \"Not styled.\" -- @ -- --- 'putAttrChange' outputs the control codes to the terminal device 'Handle'. This is a duplicate --- of the 'stdout' handle when the 'terminalHandle' was (first) acquired. If 'stdout' has since been --- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than --- 'putAttrChange' +-- 'putAttrChange' emits the control codes to the terminal device +-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when +-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been +-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a +-- different 'Handle' than 'putAttrChange'. -- -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Graphics.Vty.Inline ( module Graphics.Vty.Inline - , withVty - ) - where +module Graphics.Vty.Inline + ( module Graphics.Vty.Inline + , withVty + ) +where import Graphics.Vty import Graphics.Vty.DisplayAttributes import Graphics.Vty.Inline.Unsafe -import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder (writeToByteString) @@ -50,44 +48,42 @@ import System.IO -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Monoid ( mappend ) -#endif - type InlineM v = State Attr v --- | Set the background color to the provided 'Color' +-- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM () backColor c = modify $ flip mappend ( currentAttr `withBackColor` c ) --- | Set the foreground color to the provided 'Color' +-- | Set the foreground color to the provided 'Color'. foreColor :: Color -> InlineM () foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c ) --- | Attempt to change the 'Style' of the following text. +-- | Attempt to change the 'Style' of the following text.. -- --- If the terminal does not support the style change no error is produced. The style can still be --- removed. +-- If the terminal does not support the style change then no error is +-- produced. The style can still be removed. applyStyle :: Style -> InlineM () applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s ) --- | Attempt to remove the specified 'Style' from the display of the following text. +-- | Attempt to remove the specified 'Style' from the display of the +-- following text. -- --- This will fail if applyStyle for the given style has not been previously called. +-- This will fail if 'applyStyle' for the given style has not been +-- previously called. removeStyle :: Style -> InlineM () -removeStyle sMask = modify $ \attr -> +removeStyle sMask = modify $ \attr -> let style' = case attrStyle attr of Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." SetTo s -> s .&. complement sMask - in attr { attrStyle = SetTo style' } + in attr { attrStyle = SetTo style' } --- | Reset the display attributes +-- | Reset the display attributes. defaultAll :: InlineM () defaultAll = put defAttr --- | Apply the provided display attribute changes to the given terminal output device. +-- | Apply the provided display attribute changes to the given terminal +-- output device. -- -- This does not flush the terminal. putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () @@ -108,8 +104,8 @@ modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' } inlineHack dc --- | Apply the provided display attributes changes to the terminal output device that was current at --- the time this was first used. Which, for most use cases, is the current terminal. +-- | Apply the provided display attributes changes to the terminal +-- output device. -- -- This will flush the terminal output. putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m () diff --git a/src/Graphics/Vty/Inline/Unsafe.hs b/src/Graphics/Vty/Inline/Unsafe.hs --- a/src/Graphics/Vty/Inline/Unsafe.hs +++ b/src/Graphics/Vty/Inline/Unsafe.hs @@ -1,16 +1,9 @@ -{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - module Graphics.Vty.Inline.Unsafe where import Graphics.Vty -import Data.Default -import Data.Monoid import Data.IORef import GHC.IO.Handle (hDuplicate) @@ -21,10 +14,6 @@ import System.Posix.IO (handleToFd) -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif - globalVty :: IORef (Maybe Vty) {-# NOINLINE globalVty #-} globalVty = unsafePerformIO $ newIORef Nothing @@ -39,10 +28,11 @@ hSetBuffering stdin NoBuffering stdinDupe <- hDuplicate stdin >>= handleToFd stdoutDupe <- hDuplicate stdout >>= handleToFd - return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe } + return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe } --- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance. --- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'. +-- | This will create a Vty instance using 'mkVty' and execute an IO +-- action provided that instance. The created Vty instance will be +-- stored to the unsafe 'IORef' 'globalVty'. -- -- This instance will use duplicates of the stdin and stdout Handles. withVty :: (Vty -> IO b) -> IO b diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs --- a/src/Graphics/Vty/Input.hs +++ b/src/Graphics/Vty/Input.hs @@ -1,135 +1,125 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - --- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can --- then be used to read 'Event's from the terminal. --- --- The history of terminals has resulted in a broken input process. Some keys and combinations will --- not reliably map to the expected events by any terminal program. Even those not using vty. There --- is no 1:1 mapping from key events to bytes read from the terminal input device. In very limited --- cases the terminal and vty's input process can be customized to resolve these issues. +-- | This module provides the input layer for Vty, including methods +-- for initializing an 'Input' structure and reading 'Event's from the +-- terminal. -- --- See "Graphics.Vty.Config" for how to configure vty's input processing. Customizing terminfo and --- the terminal is beyond the scope of this documentation. +-- Note that due to the evolution of terminal emulators, some keys +-- and combinations will not reliably map to the expected events by +-- any terminal program. There is no 1:1 mapping from key events to +-- bytes read from the terminal input device. In very limited cases the +-- terminal and vty's input process can be customized to resolve these +-- issues; see "Graphics.Vty.Config" for how to configure vty's input +-- processing. -- -- = VTY's Implementation -- --- One can get the brain rot trying to understand all this. So, as far as I can care... --- -- There are two input modes: -- --- 1. 7 bit +-- 1. 7-bit -- --- 2. 8 bit +-- 2. 8-bit -- --- 7 bit input is the default and the expected in most use cases. This is what vty uses. +-- The 7-bit input mode is the default and the expected mode in most use +-- cases. This is what Vty uses. -- --- == 7 bit input encoding +-- == 7-bit input encoding -- --- Control key combinations are represented by masking the two high bits of the 7bit input. Back in --- the day the control key actually grounded the two high bit wires: 6 and 7. This is why --- control key combos map to single character events: The input bytes are identical. The input byte --- is the bit encoding of the character with bits 6 and 7 masked. Bit 6 is set by shift. Bit 6 and --- 7 are masked by control. EG: +-- Control key combinations are represented by masking the two high bits +-- of the 7-bit input. Historically the control key actually grounded +-- the two high bit wires: 6 and 7. This is why control key combos +-- map to single character events: the input bytes are identical. The +-- input byte is the bit encoding of the character with bits 6 and 7 +-- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For +-- example, -- --- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become `00001001`. Which is the ASCII --- and UTF-8 encoding of the tab key. +-- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become +-- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key. -- --- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero which makes `0000011` and --- is the "End of Text" code. +-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero +-- which is `0000011` and is the "End of Text" code. -- --- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This is the value 1 with bit 7 --- set and 6 unset. +-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this +-- is the value 1 with bit 7 set and 6 unset. -- --- * Hypothesis: Bit 6 is unset by upper case letters because, initially, there were only upper case --- letters used and a 5 bit encoding. +-- * Hypothesis: Bit 6 is unset by upper case letters because, +-- initially, there were only upper case letters used and a 5 bit +-- encoding. -- --- == 8 bit encoding +-- == 8-bit encoding -- --- The 8th bit was originally used for parity checking. Useless for emulators. Some terminal --- emulators support a 8 bit input encoding. While this provides some advantages the actual usage is --- low. Most systems use 7bit mode but recognize 8bit control characters when escaped. This is what --- vty does. +-- The 8th bit was originally used for parity checking which is useless +-- for terminal emulators. Some terminal emulators support an 8-bit +-- input encoding. While this provides some advantages, the actual usage +-- is low. Most systems use 7-bit mode but recognize 8-bit control +-- characters when escaped. This is what Vty does. -- -- == Escaped Control Keys -- --- Using 7 bit input encoding the @ESC@ byte can signal the start of an encoded control key. To --- differentiate a single @ESC@ eventfrom a control key the timing of the input is used. --- --- 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'. +-- Using 7-bit input encoding, the @ESC@ byte can signal the start of +-- an encoded control key. To differentiate a single @ESC@ event from a +-- control key, the timing of the input is used. -- --- 2. control keys that contain @ESC@ in their encoding: The @ESC byte; followed by more bytes read --- within 'singleEscPeriod'. All bytes up until the next valid input block are passed to the --- classifier. +-- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of +-- 'VMIN' milliseconds. -- --- If the current runtime is the threaded runtime then the terminal's @VMIN@ and @VTIME@ behavior --- reliably implement the above rules. If the current runtime does not support forkOS then there is --- currently no implementation. +-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte +-- is followed by more bytes read within 'VMIN' milliseconds. All bytes +-- up until the next valid input block are passed to the classifier. -- --- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop which did tricky things with --- non-blocking reads and timers. The implementation was not reliable. A reliable implementation is --- possible, but there are no plans to implement this. +-- If the current runtime is the threaded runtime then the terminal's +-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If +-- the current runtime does not support 'forkOS' then there is currently +-- no implementation. -- -- == Unicode Input and Escaped Control Key Sequences -- --- The input encoding determines how UTF-8 encoded characters are recognize. +-- The input encoding determines how UTF-8 encoded characters are +-- recognized. -- --- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is a superset of ASCII. UTF-8 does --- not overlap escaped control key sequences. However, the escape key must be differentiated from +-- * 7-bit mode: UTF-8 can be input unambiguiously. UTF-8 input is +-- a superset of ASCII. UTF-8 does not overlap escaped control key +-- sequences. However, the escape key must be differentiated from -- escaped control key sequences by the timing of the input bytes. -- --- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not require using the timing of --- input bytes to differentiate the escape key. Many terminals do not support 8 bit mode. +-- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not +-- require using the timing of input bytes to differentiate the escape +-- key. Many terminals do not support 8-bit mode. -- -- == Terminfo -- --- The terminfo system is used to determine how some keys are encoded. Terminfo is incomplete. In --- some cases terminfo is incorrect. Vty assumes terminfo is correct but provides a mechanism to --- override terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'. +-- The terminfo system is used to determine how some keys are encoded. +-- Terminfo is incomplete and in some cases terminfo is incorrect. Vty +-- assumes terminfo is correct but provides a mechanism to override +-- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'. -- -- == Terminal Input is Broken -- --- Clearly terminal input has fundemental issues. There is no easy way to reliably resolve these --- issues. --- --- One resolution would be to ditch standard terminal interfaces entirely and just go directly to --- scancodes. A reasonable option for vty if everybody used the linux kernel console. I hear GUIs --- are popular these days. Sadly, GUI terminal emulators don't provide access to scancodes AFAIK. --- --- All is lost? Not really. "Graphics.Vty.Config" supports customizing the input byte to event --- mapping and xterm supports customizing the scancode to input byte mapping. With a lot of work a --- user's system can be set up to encode all the key combos in an almost-sane manner. --- --- There are other tricky work arounds that can be done. I have no interest in implementing most of --- these. They are not really worth the time. +-- Clearly terminal input has fundemental issues. There is no easy way +-- to reliably resolve these issues. -- --- == Terminal Output is Also Broken +-- One resolution would be to ditch standard terminal interfaces +-- entirely and just go directly to scancodes. This would be a +-- reasonable option for Vty if everybody used the linux kernel console +-- but for obvious reasons this is not possible. -- --- This isn't the only odd aspect of terminals due to historical aspects that no longer apply. EG: --- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes --- the control sequence to output red, for instance) This is to account for the slow speed of --- hardcopy teletype interfaces. Cause, uh, we totally still use those. --- --- The output encoding of colors and attributes are also rife with issues. +-- The "Graphics.Vty.Config" module supports customizing the +-- input-byte-to-event mapping and xterm supports customizing the +-- scancode-to-input-byte mapping. With a lot of work a user's system +-- can be set up to encode all the key combos in an almost-sane manner. -- -- == See also -- -- * http://www.leonerd.org.uk/hacks/fixterms/ --- --- In my experience this cannot resolve the issues without changes to the terminal emulator and --- device. -module Graphics.Vty.Input ( Key(..) - , Modifier(..) - , Button(..) - , Event(..) - , Input(..) - , inputForConfig - ) - where +module Graphics.Vty.Input + ( Key(..) + , Modifier(..) + , Button(..) + , Event(..) + , Input(..) + , inputForConfig + ) +where import Graphics.Vty.Config import Graphics.Vty.Input.Events @@ -142,42 +132,31 @@ import qualified System.Console.Terminfo as Terminfo import System.Posix.Signals.Exts -#if !(MIN_VERSION_base(4,8,0)) -import Data.Functor ((<$>)) -import Data.Monoid -#else import Data.Monoid ((<>)) -#endif --- | Set up the terminal with file descriptor `inputFd` for input. Returns a 'Input'. +-- | Set up the terminal with file descriptor `inputFd` for input. +-- Returns an 'Input'. -- --- The table used to determine the 'Events' to produce for the input bytes comes from --- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from --- 'inputMap'. +-- The table used to determine the 'Events' to produce for the input +-- bytes comes from 'classifyMapForTerm' which is then overridden by +-- the the applicable entries from the configuration's 'inputMap'. -- -- The terminal device is configured with the attributes: -- --- * IXON disabled --- - disables software flow control on outgoing data. This stops the process from being --- suspended if the output terminal cannot keep up. I presume this has little effect these --- days. I hope this means that output will be buffered if the terminal cannot keep up. In the --- old days the output might of been dropped? --- --- "raw" mode is used for input. +-- * IXON disabled: disables software flow control on outgoing data. +-- This stops the process from being suspended if the output terminal +-- cannot keep up. -- --- * ISIG disabled --- - enables keyboard combinations that result in signals. TODO: should probably be a dynamic --- option. +-- * Raw mode is used for input. -- --- * ECHO disabled --- - input is not echod to the output. TODO: should be a dynamic option. +-- * ISIG disabled (enables keyboard combinations that result in +-- signals) -- --- * ICANON disabled --- - canonical mode (line mode) input is not used. TODO: should be a dynamic option. +-- * ECHO disabled (input is not echoed to the output) -- --- * IEXTEN disabled --- - extended functions are disabled. TODO: I don't know what those are. +-- * ICANON disabled (canonical mode (line mode) input is not used) -- +-- * IEXTEN disabled (extended functions are disabled) inputForConfig :: Config -> IO Input inputForConfig config@Config{ termName = Just termName , inputFd = Just termFd diff --git a/src/Graphics/Vty/Input/Classify.hs b/src/Graphics/Vty/Input/Classify.hs --- a/src/Graphics/Vty/Input/Classify.hs +++ b/src/Graphics/Vty/Input/Classify.hs @@ -1,15 +1,12 @@ {-# OPTIONS_HADDOCK hide #-} --- This makes a kind of tri. Has space efficiency issues with large input blocks. --- Likely building a parser and just applying that would be better. --- I did not write this so I might just rewrite it for better understanding. Which is not the best --- of reasons. --- TODO: measure and rewrite if required. --- TODO: The ClassifyMap interface requires this code to always assure later entries override --- earlier. +-- This makes a kind of tri. Has space efficiency issues with large +-- input blocks. Likely building a parser and just applying that would +-- be better. module Graphics.Vty.Input.Classify - ( classify - , KClass(..) - ) where + ( classify + , KClass(..) + ) +where import Graphics.Vty.Input.Events import Graphics.Vty.Input.Mouse @@ -34,23 +31,23 @@ eventForInput = M.fromList table cl' [] = Prefix cl' inputBlock = case M.lookup inputBlock eventForInput of - -- if the inputBlock is exactly what is expected for an event then consume the whole - -- block and return the event + -- if the inputBlock is exactly what is expected for an + -- event then consume the whole block and return the event Just e -> Valid e [] Nothing -> case S.member inputBlock prefixSet of True -> Prefix - -- look up progressively smaller tails of the input block until an event is found - -- The assumption is that the event that consumes the most input bytes should be - -- produced. + -- look up progressively smaller tails of the input + -- block until an event is found The assumption is that + -- the event that consumes the most input bytes should + -- be produced. -- The test verifyFullSynInputToEvent2x verifies this. - -- H: There will always be one match. The prefixSet contains, by definition, all - -- prefixes of an event. + -- H: There will always be one match. The prefixSet + -- contains, by definition, all prefixes of an event. False -> let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of (s,e) : _ -> Valid e (drop (length s) inputBlock) -- neither a prefix or a full event. - -- TODO: debug log [] -> Invalid classify :: ClassifyMap -> [Char] -> KClass @@ -76,7 +73,8 @@ in case decode codepoint8 of _ | n < length codepoint -> Prefix Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest - Nothing -> Invalid -- something bad happened; just ignore and continue. + -- something bad happened; just ignore and continue. + Nothing -> Invalid utf8Length :: (Num t, Ord a, Num a) => a -> t utf8Length c diff --git a/src/Graphics/Vty/Input/Classify/Parse.hs b/src/Graphics/Vty/Input/Classify/Parse.hs --- a/src/Graphics/Vty/Input/Classify/Parse.hs +++ b/src/Graphics/Vty/Input/Classify/Parse.hs @@ -1,13 +1,14 @@ -- | This module provides a simple parser for parsing input event -- control sequences. module Graphics.Vty.Input.Classify.Parse - ( Parser - , runParser - , failParse - , readInt - , readChar - , expectChar - ) where + ( Parser + , runParser + , failParse + , readInt + , readChar + , expectChar + ) +where import Graphics.Vty.Input.Events import Graphics.Vty.Input.Classify.Types diff --git a/src/Graphics/Vty/Input/Classify/Types.hs b/src/Graphics/Vty/Input/Classify/Types.hs --- a/src/Graphics/Vty/Input/Classify/Types.hs +++ b/src/Graphics/Vty/Input/Classify/Types.hs @@ -1,8 +1,9 @@ -- | This module exports the input classification type to avoid import -- cycles between other modules that need this. module Graphics.Vty.Input.Classify.Types - ( KClass(..) - ) where + ( KClass(..) + ) +where import Graphics.Vty.Input.Events diff --git a/src/Graphics/Vty/Input/Events.hs b/src/Graphics/Vty/Input/Events.hs --- a/src/Graphics/Vty/Input/Events.hs +++ b/src/Graphics/Vty/Input/Events.hs @@ -6,12 +6,14 @@ -- | Representations of non-modifier keys. -- --- * KFun is indexed from 0 to 63. Range of supported FKeys varies by terminal and keyboard. +-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by +-- terminal and keyboard. -- --- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by terminal and keyboard. +-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by +-- terminal and keyboard. -- --- * Actually, support for most of these but KEsc, KChar, KBS, and KEnter vary by terminal and --- keyboard. +-- * Actually, support for most of these but KEsc, KChar, KBS, and +-- KEnter vary by terminal and keyboard. data Key = KEsc | KChar Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter @@ -19,9 +21,9 @@ | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu deriving (Eq,Show,Read,Ord,Generic) --- | Modifier keys. Key codes are interpreted such that users are more likely to --- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will --- generally correspond to the physical Alt key. +-- | Modifier keys. Key codes are interpreted such that users are more +-- likely to have Meta than Alt; for instance on the PC Linux console, +-- 'MMeta' will generally correspond to the physical Alt key. data Modifier = MShift | MCtrl | MMeta | MAlt deriving (Eq,Show,Read,Ord,Generic) diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs --- a/src/Graphics/Vty/Input/Loop.hs +++ b/src/Graphics/Vty/Input/Loop.hs @@ -3,12 +3,15 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} --- | The input layer used to be a single function that correctly accounted for the non-threaded --- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with --- a more straightforward parser. The non-threaded runtime is no longer supported. +-- | The input layer used to be a single function that correctly +-- accounted for the non-threaded runtime by emulating the terminal +-- VMIN adn VTIME handling. This has been removed and replace with a +-- more straightforward parser. The non-threaded runtime is no longer +-- supported. -- --- This is an example of an algorithm where code coverage could be high, even 100%, but the --- behavior is still under tested. I should collect more of these examples... +-- This is an example of an algorithm where code coverage could be high, +-- even 100%, but the behavior is still under tested. I should collect +-- more of these examples... -- -- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html module Graphics.Vty.Input.Loop where @@ -21,7 +24,6 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception (mask, try, SomeException) -import Data.Monoid import Lens.Micro import Lens.Micro.Mtl import Lens.Micro.TH @@ -46,11 +48,12 @@ import Text.Printf (hPrintf) data Input = Input - { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh - -- the display if the next event is an 'EvResize'. + { -- | Channel of events direct from input processing. Unlike + -- 'nextEvent' this will not refresh the display if the next event + -- is an 'EvResize'. _eventChannel :: TChan Event - -- | Shuts down the input processing. This should return the terminal input state to before - -- the input initialized. + -- | Shuts down the input processing. This should return the + -- terminal input state to before he input initialized. , shutdownInput :: IO () -- | Changes to this value are reflected after the next event. , _configRef :: IORef Config @@ -86,7 +89,8 @@ Just h -> liftIO $ hPutStrLn h msg >> hFlush h -- this must be run on an OS thread dedicated to this input handling. --- otherwise the terminal timing read behavior will block the execution of the lightweight threads. +-- otherwise the terminal timing read behavior will block the execution +-- of the lightweight threads. loopInputProcessor :: InputM () loopInputProcessor = do readFromDevice >>= addBytesToProcess @@ -103,11 +107,11 @@ logMsg $ "parsed event: " ++ show event view eventChannel >>= liftIO . atomically . flip writeTChan event --- The timing requirements are assured by the VMIN and VTIME set for the device. +-- The timing requirements are assured by the VMIN and VTIME set for the +-- device. -- --- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case --- satisfies precondition. --- TODO: When under the non-threaded runtime emulate VMIN and VTIME +-- Precondition: Under the threaded runtime. Only current use is from a +-- forkOS thread. That case satisfies precondition. readFromDevice :: InputM String readFromDevice = do newConfig <- view configRef >>= liftIO . readIORef @@ -120,10 +124,11 @@ bufferPtr <- use $ inputBuffer.ptr maxBytes <- use $ inputBuffer.size stringRep <- liftIO $ do - -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses - -- this provides a location to be interrupted prior to the foreign call. If there is input - -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime - -- terminal setting. + -- The killThread used in shutdownInput will not interrupt the + -- foreign call fdReadBuf uses this provides a location to be + -- interrupted prior to the foreign call. If there is input on + -- the FD then the fdReadBuf will return in a finite amount of + -- time due to the vtime terminal setting. threadWaitRead fd bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes) if bytesRead > 0 @@ -147,7 +152,7 @@ logMsg $ "remaining: " ++ show remaining unprocessedBytes .= remaining return e - _ -> mzero + _ -> mzero dropInvalid :: InputM () dropInvalid = do diff --git a/src/Graphics/Vty/Input/Mouse.hs b/src/Graphics/Vty/Input/Mouse.hs --- a/src/Graphics/Vty/Input/Mouse.hs +++ b/src/Graphics/Vty/Input/Mouse.hs @@ -3,11 +3,12 @@ -- -- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking module Graphics.Vty.Input.Mouse - ( requestMouseEvents - , disableMouseEvents - , isMouseEvent - , classifyMouseEvent - ) where + ( requestMouseEvents + , disableMouseEvents + , isMouseEvent + , classifyMouseEvent + ) +where import Graphics.Vty.Input.Events import Graphics.Vty.Input.Classify.Types diff --git a/src/Graphics/Vty/Input/Paste.hs b/src/Graphics/Vty/Input/Paste.hs --- a/src/Graphics/Vty/Input/Paste.hs +++ b/src/Graphics/Vty/Input/Paste.hs @@ -2,10 +2,11 @@ -- -- http://cirw.in/blog/bracketed-paste module Graphics.Vty.Input.Paste - ( parseBracketedPaste - , bracketedPasteStarted - , bracketedPasteFinished - ) where + ( parseBracketedPaste + , bracketedPasteStarted + , bracketedPasteFinished + ) +where import qualified Data.ByteString.Char8 as BS8 diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs --- a/src/Graphics/Vty/Input/Terminfo.hs +++ b/src/Graphics/Vty/Input/Terminfo.hs @@ -7,8 +7,8 @@ import Control.Arrow import System.Console.Terminfo --- | queries the terminal for all capability based input sequences then adds on a terminal dependent --- input sequence mapping. +-- | Queries the terminal for all capability-based input sequences and +-- then adds on a terminal-dependent input sequence mapping. -- -- For reference see: -- @@ -20,29 +20,29 @@ -- -- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html -- --- This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect. --- Vty assumes that the an internal terminfo table added to the system provided terminfo table is --- correct. +-- Terminfo is incomplete. The vim source implies that terminfo is also +-- incorrect. Vty assumes that the internal terminfo table added to the +-- system-provided terminfo table is correct. -- --- 1. build terminfo table for all caps. Missing caps are not added. +-- The procedure used here is: -- --- 2. add tables for visible chars, esc, del plus ctrl and meta +-- 1. Build terminfo table for all caps. Missing caps are not added. -- --- 3. add internally defined table for given terminal type. +-- 2. Add tables for visible chars, esc, del, ctrl, and meta. -- --- Precedence is currently implicit in the 'compile' algorithm. Which is a bit odd. +-- 3. Add internally-defined table for given terminal type. -- --- \todo terminfo meta is not supported. --- \todo no 8bit +-- Precedence is currently implicit in the 'compile' algorithm. classifyMapForTerm :: String -> Terminal -> ClassifyMap classifyMapForTerm termName term = concat $ capsClassifyMap term keysFromCapsTable : universalTable : termSpecificTables termName --- | key table applicable to all terminals. +-- | The key table applicable to all terminals. -- --- TODO: some probably only applicable to ANSI/VT100 terminals. +-- Note that some of these entries are probably only applicable to +-- ANSI/VT100 terminals. universalTable :: ClassifyMap universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys] @@ -50,27 +50,27 @@ capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table] where extractCap = first (getCapability terminal . tiGetStr) --- | tables specific to a given terminal that are not derivable from terminfo. +-- | Tables specific to a given terminal that are not derivable from +-- terminfo. -- --- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier. +-- Note that this adds the ANSI/VT100/VT50 tables regardless of term +-- identifier. termSpecificTables :: String -> [ClassifyMap] termSpecificTables _termName = ANSIVT.classifyTable -- | Visible characters in the ISO-8859-1 and UTF-8 common set. -- --- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this --- classify table is reached. --- --- TODO: resolve --- 1. start at ' '. The earlier characters are all 'ctrlChar' +-- We limit to < 0xC1. The UTF8 sequence detector will catch all values +-- 0xC2 and above before this classify table is reached. visibleChars :: ClassifyMap visibleChars = [ ([x], EvKey (KChar x) []) | x <- [' ' .. toEnum 0xC1] ] --- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char. +-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set +-- translated to ctrl + char. -- --- \todo resolve CTRL-i is the same as tab +-- This treats CTRL-i the same as tab. ctrlChars :: ClassifyMap ctrlChars = [ ([toEnum x],EvKey (KChar y) [MCtrl]) @@ -83,7 +83,7 @@ ctrlMetaChars :: ClassifyMap ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars --- | esc, meta esc, delete, meta delete, enter, meta enter +-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter. specialSupportKeys :: ClassifyMap specialSupportKeys = [ -- special support for ESC @@ -96,9 +96,8 @@ , ("\t", EvKey (KChar '\t') []) ] --- | classify table directly generated from terminfo cap strings --- --- these are: +-- | A classification table directly generated from terminfo cap +-- strings. These are: -- -- * ka1 - keypad up-left -- @@ -113,7 +112,7 @@ -- * kcbt - back tab -- -- * kc1 - keypad left-down --- +-- -- * kc3 - keypad right-down -- -- * kdch1 - delete @@ -121,7 +120,7 @@ -- * kcud1 - down -- -- * kend - end --- +-- -- * kent - enter -- -- * kf0 - kf63 - function keys @@ -180,6 +179,6 @@ , ("kcuu1", EvKey KUp []) ] ++ functionKeyCapsTable --- | cap names for function keys +-- | Cap names for function keys. functionKeyCapsTable :: ClassifyMap functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) []) diff --git a/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs b/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs --- a/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs +++ b/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs @@ -1,15 +1,15 @@ --- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo. --- --- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often --- use VT50 input bytes regardless of declared terminal type. This provides compatibility with --- programs that don't follow terminfo. +-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from +-- terminfo. +-- +-- Or that are sent regardless of terminfo by terminal emulators. EG: +-- Terminal emulators will often use VT50 input bytes regardless of +-- declared terminal type. This provides compatibility with programs +-- that don't follow terminfo. module Graphics.Vty.Input.Terminfo.ANSIVT where import Graphics.Vty.Input.Events -- | Encoding for navigation keys. --- --- TODO: This is not the same as the input bytes pulled from teh caps table. navKeys0 :: ClassifyMap navKeys0 = [ k "G" KCenter @@ -30,8 +30,10 @@ [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m) | charCnt <- ["1;", ""], -- we can have a count or not (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), - ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes - (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes + -- modifiers and their codes + ([MShift, MCtrl],6), ([MShift, MMeta],4)], + -- directions and their codes + (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] ] -- | encoding for ins, del, pageup, pagedown, home, end @@ -49,9 +51,9 @@ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] -- | encoding for shift plus function keys --- --- According to -- +-- According to +-- -- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html -- -- This encoding depends on the terminal. @@ -62,13 +64,13 @@ -- | encoding for meta plus char -- --- TODO: resolve - --- --- 1. removed 'ESC' from second list due to duplication with "special_support_keys". --- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is --- the same as ESC should examine km and current encoding. --- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by --- special_support_keys. +-- 1. removed 'ESC' from second list due to duplication with +-- "special_support_keys". +-- 2. removed '[' from second list due to conflict with 7-bit encoding +-- for ESC. Whether meta+[ is the same as ESC should examine km and +-- current encoding. +-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped +-- to KBS by special_support_keys. functionKeys2 :: ClassifyMap functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta]) | x <- '\t':[' ' .. '~'] @@ -84,4 +86,3 @@ , functionKeys1 , functionKeys2 ] - diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs --- a/src/Graphics/Vty/Output.hs +++ b/src/Graphics/Vty/Output.hs @@ -1,36 +1,37 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} --- | Output interface. --- --- Access to the current terminal or a specific terminal device. +-- | This module provides functions for accessing the current terminal +-- or a specific terminal device. -- --- See also: +-- See also: -- --- 1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based --- on the TERM and COLORTERM environment variables. +-- 1. "Graphics.Vty.Output": This instantiates an abtract interface +-- to the terminal based on the @TERM@ and @COLORTERM@ environment +-- variables. -- --- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement. +-- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all +-- terminal modules need to implement. -- --- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance that uses terminfo for all --- control strings. No attempt is made to change the character set to UTF-8 for these terminals. --- I don't know a way to reliably determine if that is required or how to do so. +-- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance +-- that uses terminfo for all control strings. No attempt is made to +-- change the character set to UTF-8 for these terminals. -- --- 4. "Graphics.Vty.Output.XTermColor": This module contains an interface suitable for xterm-like --- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many --- control codes as possible. -module Graphics.Vty.Output ( module Graphics.Vty.Output - , Output(..) -- \todo hide constructors - , AssumedState(..) - , DisplayContext(..) -- \todo hide constructors - , outputPicture - , displayContext - ) - where +-- 4. "Graphics.Vty.Output.XTermColor": This module contains an +-- interface suitable for xterm-like terminals. These are the terminals +-- where @TERM@ begins with @xterm@. This does use terminfo for as many +-- control codes as possible. +module Graphics.Vty.Output + ( outputForConfig + , setCursorPos + , hideCursor + , showCursor + ) +where -import Graphics.Vty.Prelude +import Control.Monad (when) import Graphics.Vty.Config - +import Graphics.Vty.Image (regionWidth, regionHeight) import Graphics.Vty.Output.Interface import Graphics.Vty.Output.XTermColor as XTermColor import Graphics.Vty.Output.TerminfoBased as TerminfoBased @@ -42,23 +43,20 @@ import Data.List (isPrefixOf) import Data.Monoid ((<>)) --- | Returns a `Output` for the terminal specified in `Config` +-- | Returns an `Output` for the terminal specified in `Config`. -- --- The specific Output implementation used is hidden from the API user. All terminal implementations --- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at --- least some terminal specific information. +-- The specific Output implementation used is hidden from the API user. +-- All terminal implementations are assumed to perform more, or less, +-- the same. Currently, all implementations use terminfo for at least +-- some terminal specific information. -- --- Specifics about it being based on terminfo are hidden from the API user. If a terminal --- implementation is developed for a terminal without terminfo support then Vty should work as --- expected on that terminal. +-- If a terminal implementation is developed for a terminal without +-- terminfo support then Vty should work as expected on that terminal. -- -- Selection of a terminal is done as follows: -- -- * If TERM contains "xterm" or "screen", use XTermColor. -- * otherwise use the TerminfoBased driver. --- --- \todo add an implementation for windows that does not depend on terminfo. Should be installable --- with only what is provided in the haskell platform. Use ansi-terminal outputForConfig :: Config -> IO Output outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName @@ -79,11 +77,13 @@ -- | Sets the cursor position to the given output column and row. -- --- This is not necessarially the same as the character position with the same coordinates. --- Characters can be a variable number of columns in width. +-- This is not necessarially the same as the character position with the +-- same coordinates. Characters can be a variable number of columns in +-- width. -- --- Currently, the only way to set the cursor position to a given character coordinate is to specify --- the coordinate in the Picture instance provided to outputPicture or refresh. +-- Currently, the only way to set the cursor position to a given +-- character coordinate is to specify the coordinate in the Picture +-- instance provided to 'outputPicture' or 'refresh'. setCursorPos :: MonadIO m => Output -> Int -> Int -> m () setCursorPos t x y = do bounds <- displayBounds t @@ -91,14 +91,14 @@ dc <- displayContext t bounds liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y --- | Hides the cursor +-- | Hides the cursor. hideCursor :: MonadIO m => Output -> m () hideCursor t = do bounds <- displayBounds t dc <- displayContext t bounds liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc --- | Shows the cursor +-- | Shows the cursor. showCursor :: MonadIO m => Output -> m () showCursor t = do bounds <- displayBounds t diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -1,21 +1,25 @@ -- Copyright Corey O'Connor --- General philosophy is: MonadIO is for equations exposed to clients. -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - +-- | This module provides an abstract interface for performing terminal +-- output. The only user-facing part of this API is 'Output'. module Graphics.Vty.Output.Interface + ( Output(..) + , AssumedState(..) + , DisplayContext(..) + , Mode(..) + , displayContext + , outputPicture + , initialAssumedState + , limitAttrForDisplay + ) where -import Graphics.Vty.Prelude - +import Graphics.Vty.Attributes +import Graphics.Vty.Image (DisplayRegion, regionHeight) import Graphics.Vty.Picture import Graphics.Vty.PictureToSpans import Graphics.Vty.Span @@ -33,59 +37,60 @@ import qualified Data.Text.Lazy as TL import qualified Data.Vector as Vector -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (mempty, mappend) -#endif - -- | Modal terminal features that can be enabled and disabled. data Mode = Mouse + -- ^ Mouse mode (whether the terminal is configured to provide + -- mouse input events) | BracketedPaste + -- ^ Paste mode (whether the terminal is configured to provide + -- events on OS pastes) deriving (Eq, Read, Show) +-- | The Vty terminal output interface. data Output = Output - { -- | Text identifier for the output device. Used for debugging. + { -- | Text identifier for the output device. Used for debugging. terminalID :: String + -- | Release the terminal just prior to application exit and reset + -- it to its state prior to application startup. , releaseTerminal :: forall m. MonadIO m => m () - -- | Clear the display and initialize the terminal to some initial display state. - -- - -- The expectation of a program is that the display starts in some initial state. - -- The initial state would consist of fixed values: - -- - -- - cursor at top left - -- - UTF-8 character encoding - -- - drawing characteristics are the default - -- - -- The abstract operation I think all these behaviors are instances of is reserving exclusive - -- access to a display such that: - -- - -- - The previous state cannot be determined - -- - When exclusive access to a display is released the display returns to the previous state. + -- | Clear the display and initialize the terminal to some initial + -- display state. + -- + -- The expectation of a program is that the display starts in some + -- The initial state. initial state would consist of fixed values: + -- + -- - cursor at top left + -- - UTF-8 character encoding + -- - drawing characteristics are the default , reserveDisplay :: forall m. MonadIO m => m () - -- | Return the display to the state before `reserveDisplay` - -- If no previous state then set the display state to the initial state. + -- | Return the display to the state before `reserveDisplay` If no + -- previous state then set the display state to the initial state. , releaseDisplay :: forall m. MonadIO m => m () - -- | Returns the current display bounds. + -- | Returns the current display bounds. , displayBounds :: forall m. MonadIO m => m DisplayRegion - -- | Output the byte string to the terminal device. + -- | Output the bytestring to the terminal device. , outputByteBuffer :: BS.ByteString -> IO () - -- | Maximum number of colors supported by the context. + -- | Specifies the maximum number of colors supported by the + -- context. , contextColorCount :: Int - -- | if the cursor can be shown / hidden + -- | Specifies whether the cursor can be shown / hidden. , supportsCursorVisibility :: Bool - -- | Indicates support for terminal modes for this output device + -- | Indicates support for terminal modes for this output device. , supportsMode :: Mode -> Bool - -- | Enables or disables a mode (does nothing if the mode is unsupported) + -- | Enables or disables a mode (does nothing if the mode is + -- unsupported). , setMode :: forall m. MonadIO m => Mode -> Bool -> m () - -- | Returns whether a mode is enabled + -- | Returns whether a mode is enabled. , getModeStatus :: forall m. MonadIO m => Mode -> m Bool , assumedStateRef :: IORef AssumedState - -- | Acquire display access to the given region of the display. - -- Currently all regions have the upper left corner of (0,0) and the lower right corner at - -- (max displayWidth providedWidth, max displayHeight providedHeight) + -- | Acquire display access to the given region of the display. + -- Currently all regions have the upper left corner of (0,0) and + -- the lower right corner at (max displayWidth providedWidth, max + -- displayHeight providedHeight) , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext - -- | Ring the terminal bell if supported. + -- | Ring the terminal bell if supported. , ringTerminalBell :: forall m. MonadIO m => m () - -- | Returns whether the terminal has an audio bell feature. + -- | Returns whether the terminal has an audio bell feature. , supportsBell :: forall m. MonadIO m => m Bool } @@ -102,50 +107,53 @@ data DisplayContext = DisplayContext { contextDevice :: Output - -- | Provide the bounds of the display context. + -- | Provide the bounds of the display context. , contextRegion :: DisplayRegion - -- | sets the output position to the specified row and column. Where the number of bytes - -- required for the control codes can be specified seperate from the actual byte sequence. + -- | Sets the output position to the specified row and column + -- where the number of bytes required for the control codes can be + -- specified seperate from the actual byte sequence. , writeMoveCursor :: Int -> Int -> Write , writeShowCursor :: Write , writeHideCursor :: Write - -- | Assure the specified output attributes will be applied to all the following text until the - -- next output attribute change. Where the number of bytes required for the control codes can - -- be specified seperate from the actual byte sequence. The required number of bytes must be - -- at least the maximum number of bytes required by any attribute changes. The serialization - -- equations must provide the ptr to the next byte to be specified in the output buffer. + -- Ensure that the specified output attributes will be applied to + -- all the following text until the next output attribute change + -- where the number of bytes required for the control codes can be + -- specified seperately from the actual byte sequence. The required + -- number of bytes must be at least the maximum number of bytes + -- required by any attribute changes. The serialization equations + -- must provide the ptr to the next byte to be specified in the + -- output buffer. -- - -- The currently applied display attributes are provided as well. The Attr data type can - -- specify the style or color should not be changed from the currently applied display - -- attributes. In order to support this the currently applied display attributes are required. - -- In addition it may be possible to optimize the state changes based off the currently applied - -- display attributes. + -- The currently applied display attributes are provided as well. + -- The Attr data type can specify the style or color should not be + -- changed from the currently applied display attributes. In order + -- to support this the currently applied display attributes are + -- required. In addition it may be possible to optimize the state + -- changes based off the currently applied display attributes. , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write - -- | Reset the display attributes to the default display attributes + -- | Reset the display attributes to the default display attributes. , writeDefaultAttr :: Write , writeRowEnd :: Write -- | See `Graphics.Vty.Output.XTermColor.inlineHack` , inlineHack :: IO () } --- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory. +-- | All terminals serialize UTF8 text to the terminal device exactly as +-- serialized in memory. writeUtf8Text :: BS.ByteString -> Write writeUtf8Text = writeByteString -- | Displays the given `Picture`. -- --- 0. The image is cropped to the display size. +-- 1. The image is cropped to the display size. -- --- 1. Converted into a sequence of attribute changes and text spans. --- --- 2. The cursor is hidden. +-- 2. Converted into a sequence of attribute changes and text spans. -- --- 3. Serialized to the display. +-- 3. The cursor is hidden. -- --- 4. The cursor is then shown and positioned or kept hidden. --- --- todo: specify possible IO exceptions. --- abstract from IO monad to a MonadIO instance. +-- 4. Serialized to the display. +-- +-- 5. The cursor is then shown and positioned or kept hidden. outputPicture :: MonadIO m => DisplayContext -> Picture -> m () outputPicture dc pic = liftIO $ do as <- readIORef (assumedStateRef $ contextDevice dc) @@ -153,12 +161,11 @@ r = contextRegion dc ops = displayOpsForPic pic r initialAttr = FixedAttr defaultStyleMask Nothing Nothing - -- Diff the previous output against the requested output. Differences are currently on a per-row - -- basis. - -- \todo handle resizes that crop the dominate directions better. + -- Diff the previous output against the requested output. + -- Differences are currently on a per-row basis. diffs :: [Bool] = case prevOutputOps as of - Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True - Just previousOps -> if effectedRegion previousOps /= effectedRegion ops + Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True + Just previousOps -> if affectedRegion previousOps /= affectedRegion ops then replicate (displayOpsRows ops) True else zipWith (/=) (Vector.toList previousOps) (Vector.toList ops) @@ -193,7 +200,7 @@ (0, mempty, diffs) ops in out - where + where writeOutputOps' (y, out, True : diffs') spanOps = let spanOut = writeSpanOps dc y initialAttr spanOps out' = out `mappend` spanOut @@ -225,11 +232,12 @@ writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip" writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr) --- | The cursor position is given in X,Y character offsets. Due to multi-column characters this --- needs to be translated to column, row positions. +-- | The cursor position is given in X,Y character offsets. Due to +-- multi-column characters this needs to be translated to column, row +-- positions. data CursorOutputMap = CursorOutputMap { charToOutputPos :: (Int, Int) -> (Int, Int) - } + } cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap cursorOutputMap spanOps _cursor = CursorOutputMap @@ -239,18 +247,18 @@ cursorColumnOffset :: DisplayOps -> Int -> Int -> Int cursorColumnOffset ops cx cy = let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy) - (outOffset, _, _) - = Vector.foldl' ( \(d, currentCx, done) op -> + (outOffset, _, _) + = Vector.foldl' ( \(d, currentCx, done) op -> if done then (d, currentCx, done) else case spanOpHasWidth op of Nothing -> (d, currentCx, False) Just (cw, ow) -> case compare cx (currentCx + cw) of GT -> ( d + ow , currentCx + cw - , False + , False ) EQ -> ( d + ow , currentCx + cw - , True + , True ) LT -> ( d + columnsToCharOffset (cx - currentCx) op , currentCx + cw @@ -261,10 +269,10 @@ cursorRowOps in outOffset --- | Not all terminals support all display attributes. This filters a display attribute to what the --- given terminal can display. +-- | Not all terminals support all display attributes. This filters a +-- display attribute to what the given terminal can display. limitAttrForDisplay :: Output -> Attr -> Attr -limitAttrForDisplay t attr +limitAttrForDisplay t attr = attr { attrForeColor = clampColor $ attrForeColor attr , attrBackColor = clampColor $ attrBackColor attr } @@ -272,16 +280,16 @@ clampColor Default = Default clampColor KeepCurrent = KeepCurrent clampColor (SetTo c) = clampColor' c - clampColor' (ISOColor v) + clampColor' (ISOColor v) | contextColorCount t < 8 = Default | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8) | otherwise = SetTo $ ISOColor v clampColor' (Color240 v) - -- TODO: Choose closes ISO color? + -- Should we choose closest ISO color? | contextColorCount t < 8 = Default | contextColorCount t < 16 = Default | contextColorCount t <= 256 = SetTo $ Color240 v - | otherwise - = let p :: Double = fromIntegral v / 240.0 + | otherwise + = let p :: Double = fromIntegral v / 240.0 v' = floor $ p * (fromIntegral $ contextColorCount t) in SetTo $ Color240 v' diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs --- a/src/Graphics/Vty/Output/Mock.hs +++ b/src/Graphics/Vty/Output/Mock.hs @@ -1,13 +1,16 @@ -- Copyright Corey O'Connor {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} --- | This provides a mock terminal implementation that is nice for testing. This transforms the --- output operations to visible characters. Which is nice for some tests. -module Graphics.Vty.Output.Mock ( MockData, mockTerminal ) - where - -import Graphics.Vty.Prelude +-- | This provides a mock terminal implementation that is nice for +-- testing. This transforms the output operations to visible characters +-- which is useful for testing. +module Graphics.Vty.Output.Mock + ( MockData + , mockTerminal + ) +where +import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder.Word (writeWord8) @@ -20,18 +23,20 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString) --- | The mock display terminal produces a string representation of the requested picture. There is --- *not* an isomorphism between the string representation and the picture. The string --- representation is a simplification of the picture that is only useful in debugging VTY without --- considering terminal specific issues. +-- | The mock display terminal produces a string representation of +-- the requested picture. There is *not* an isomorphism between the +-- string representation and the picture. The string representation is +-- a simplification of the picture that is only useful in debugging VTY +-- without considering terminal specific issues. -- --- The mock implementation is useful in manually determining if the sequence of terminal operations --- matches the expected sequence. So requirement of the produced representation is simplicity in --- parsing the text representation and determining how the picture was mapped to terminal --- operations. +-- The mock implementation is useful in manually determining if the +-- sequence of terminal operations matche the expected sequence. The +-- requirement of the produced representation is simplicity in parsing +-- the text representation and determining how the picture was mapped to +-- terminal operations. -- --- The string representation is a sequence of identifiers where each identifier is the name of an --- operation in the algebra. +-- The string representation is a sequence of identifiers where each +-- identifier is the name of an operation in the algebra. mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output) mockTerminal r = liftIO $ do outRef <- newIORef undefined @@ -56,17 +61,23 @@ , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual - -- A cursor move is always visualized as the single character 'M' + -- A cursor move is always visualized as the single + -- character 'M' , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M' - -- Show cursor is always visualized as the single character 'S' + -- Show cursor is always visualized as the single + -- character 'S' , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S' - -- Hide cursor is always visualized as the single character 'H' + -- Hide cursor is always visualized as the single + -- character 'H' , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H' - -- An attr change is always visualized as the single character 'A' + -- An attr change is always visualized as the single + -- character 'A' , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A' - -- default attr is always visualized as the single character 'D' + -- default attr is always visualized as the single + -- character 'D' , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D' - -- row end is always visualized as the single character 'E' + -- row end is always visualized as the single character + -- 'E' , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E' , inlineHack = return () } diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ b/src/Graphics/Vty/Output/TerminfoBased.hs @@ -1,30 +1,23 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} {-# CFILES gwinsz.c #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - --- | Terminfo based terminal handling. --- --- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I --- have easy access to then color support is entirely based of the docs. Probably with some --- assumptions mixed in. +-- | Terminfo-based terminal output driver. -- -- Copyright Corey O'Connor (coreyoconnor@gmail.com) -module Graphics.Vty.Output.TerminfoBased ( reserveTerminal ) - where - -import Graphics.Vty.Prelude +module Graphics.Vty.Output.TerminfoBased + ( reserveTerminal + ) +where +import Control.Monad (when) import Data.ByteString.Internal (toForeignPtr) import Data.Terminfo.Parse import Data.Terminfo.Eval import Graphics.Vty.Attributes +import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.DisplayAttributes import Graphics.Vty.Output.Interface @@ -45,12 +38,7 @@ import System.Posix.IO (fdWriteBuf) import System.Posix.Types (Fd(..)) -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable (foldMap) -import Data.Monoid -#endif - -data TerminfoCaps = TerminfoCaps +data TerminfoCaps = TerminfoCaps { smcup :: Maybe CapExpression , rmcup :: Maybe CapExpression , cup :: CapExpression @@ -77,9 +65,11 @@ , enterDimMode :: Maybe CapExpression , enterBoldMode :: Maybe CapExpression } - --- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422 --- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried. + +-- kinda like: +-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422 +-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR +-- the write will be retried. fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int fdWriteAll outFd ptr len count | len < 0 = fail "fdWriteAll: len is less than 0" @@ -95,25 +85,25 @@ sendCapToTerminal t cap capParams = do outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams -{- | Uses terminfo for all control codes. While this should provide the most compatible terminal - - terminfo does not support some features that would increase efficiency and improve compatibility: - - - - * determine the character encoding supported by the terminal. Should this be taken from the LANG - - environment variable? - - - - * Provide independent string capabilities for all display attributes. - - - - todo: Some display attributes like underline and bold have independent string capabilities that - - should be used instead of the generic "sgr" string capability. - -} +-- | Constructs an output driver that uses terminfo for all control +-- codes. While this should provide the most compatible terminal, +-- terminfo does not support some features that would increase +-- efficiency and improve compatibility: +-- +-- * determining the character encoding supported by the terminal. +-- Should this be taken from the LANG environment variable? +-- +-- * Providing independent string capabilities for all display +-- attributes. reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output reserveTerminal termName outFd = liftIO $ do ti <- Terminfo.setupTerm termName -- assumes set foreground always implies set background exists. - -- if set foreground is not set then all color changing style attributes are filtered. + -- if set foreground is not set then all color changing style + -- attributes are filtered. msetaf <- probeCap ti "setaf" msetf <- probeCap ti "setf" - let (noColors, useAlt, setForeCap) + let (noColors, useAlt, setForeCap) = case msetaf of Just setaf -> (False, False, setaf) Nothing -> case msetf of @@ -121,7 +111,7 @@ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName) msetab <- probeCap ti "setab" msetb <- probeCap ti "setb" - let set_back_cap + let set_back_cap = case msetab of Nothing -> case msetb of Just setb -> setb @@ -151,8 +141,9 @@ , supportsBell = return $ isJust $ ringBellAudio terminfoCaps , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio [] , reserveDisplay = liftIO $ do - -- If there is no support for smcup: Clear the screen and then move the mouse to the - -- home position to approximate the behavior. + -- If there is no support for smcup: Clear the screen + -- and then move the mouse to the home position to + -- approximate the behavior. maybeSendCap smcup [] sendCap clearScreen [] , releaseDisplay = liftIO $ do @@ -181,8 +172,8 @@ , setMode = const $ const $ return () , getModeStatus = const $ return False , assumedStateRef = newAssumedStateRef - -- I think fix would help assure tActual is the only reference. I was having issues - -- tho. + -- I think fix would help assure tActual is the only + -- reference. I was having issues tho. , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps } sendCap s = sendCapToTerminal t (s terminfoCaps) @@ -190,13 +181,13 @@ return t requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression -requireCap ti capName +requireCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\"" Just capStr -> parseCap capStr probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression) -probeCap ti capName +probeCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> return Nothing Just capStr -> Just <$> parseCap capStr @@ -207,11 +198,11 @@ Left e -> fail $ show e Right cap -> return cap -currentDisplayAttrCaps :: ( Applicative m, MonadIO m ) - => Terminfo.Terminal +currentDisplayAttrCaps :: ( Applicative m, MonadIO m ) + => Terminfo.Terminal -> m DisplayAttrCaps -currentDisplayAttrCaps ti - = pure DisplayAttrCaps +currentDisplayAttrCaps ti + = pure DisplayAttrCaps <*> probeCap ti "sgr" <*> probeCap ti "smso" <*> probeCap ti "rmso" @@ -224,7 +215,7 @@ foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong getWindowSize :: Fd -> IO (Int,Int) -getWindowSize fd = do +getWindowSize fd = do (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd return (fromIntegral b, fromIntegral a) @@ -248,84 +239,91 @@ -- | Portably setting the display attributes is a giant pain in the ass. -- --- If the terminal supports the sgr capability (which sets the on/off state of each style --- directly ; and, for no good reason, resets the colors to the default) this procedure is used: +-- If the terminal supports the sgr capability (which sets the on/off +-- state of each style directly ; and, for no good reason, resets the +-- colors to the default) this procedure is used: -- -- 0. set the style attributes. This resets the fore and back color. -- -- 1, If a foreground color is to be set then set the foreground color -- -- 2. likewise with the background color --- --- If the terminal does not support the sgr cap then: --- if there is a change from an applied color to the default (in either the fore or back color) --- then: -- --- 0. reset all display attributes (sgr0) +-- If the terminal does not support the sgr cap then: if there is a +-- change from an applied color to the default (in either the fore or +-- back color) then: -- --- 1. enter required style modes +-- 0. reset all display attributes (sgr0) -- --- 2. set the fore color if required +-- 1. enter required style modes -- --- 3. set the back color if required +-- 2. set the fore color if required -- --- Entering the required style modes could require a reset of the display attributes. If this is --- the case then the back and fore colors always need to be set if not default. +-- 3. set the back color if required -- +-- Entering the required style modes could require a reset of the +-- display attributes. If this is the case then the back and fore colors +-- always need to be set if not default. +-- -- This equation implements the above logic. -- --- \todo This assumes the removal of color changes in the display attributes is done as expected --- with noColors == True. See `limitAttrForDisplay` +-- Note that this assumes the removal of color changes in the +-- display attributes is done as expected with noColors == True. See +-- `limitAttrForDisplay`. -- --- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I --- haven't measured this or even examined terminal implementations. *shrug* +-- Note that this optimizes for fewer state changes followed by fewer +-- bytes. terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of - -- The only way to reset either color, portably, to the default is to use either the set - -- state capability or the set default capability. + -- The only way to reset either color, portably, to the default + -- is to use either the set state capability or the set default + -- capability. True -> do case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr ) (styleToApplySeq $ fixedStyle attr) of -- only way to reset a color to the defaults EnterExitSeq caps -> writeDefaultAttr dc - `mappend` + `mappend` foldMap (\cap -> writeCapExpr cap []) caps `mappend` setColors -- implicitly resets the colors to the defaults - SetState state -> writeCapExpr (fromJust $ setAttrStates - $ displayAttrCaps + SetState state -> writeCapExpr (fromJust $ setAttrStates + $ displayAttrCaps $ terminfoCaps ) (sgrArgsForState state) `mappend` setColors - -- Otherwise the display colors are not changing or changing between two non-default - -- points. + -- Otherwise the display colors are not changing or changing + -- between two non-default points. False -> do - -- Still, it could be the case that the change in display attributes requires the - -- colors to be reset because the required capability was not available. + -- Still, it could be the case that the change in display + -- attributes requires the colors to be reset because the + -- required capability was not available. case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr) (styleDiffs diffs) of - -- Really, if terminals were re-implemented with modern concepts instead of bowing - -- down to 40 yr old dumb terminal requirements this would be the only case ever - -- reached! Changes the style and color states according to the differences with - -- the currently applied states. + -- Really, if terminals were re-implemented with modern + -- concepts instead of bowing down to 40 yr old dumb + -- terminal requirements this would be the only case + -- ever reached! Changes the style and color states + -- according to the differences with the currently + -- applied states. EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps `mappend` writeColorDiff setForeColor (foreColorDiff diffs) `mappend` writeColorDiff setBackColor (backColorDiff diffs) -- implicitly resets the colors to the defaults - SetState state -> writeCapExpr (fromJust $ setAttrStates + SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps terminfoCaps ) (sgrArgsForState state) `mappend` setColors - where + where colorMap = case useAltColorMap terminfoCaps of False -> ansiColorIndex True -> altColorIndex @@ -347,17 +345,17 @@ writeColorDiff f (SetColor c) = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c] --- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not --- be supported by the terminal. +-- | The color table used by a terminal is a 16 color set followed by a +-- 240 color set that might not be supported by the terminal. -- --- This takes a Color which clearly identifies which pallete to use and computes the index --- into the full 256 color pallete. +-- This takes a Color which clearly identifies which pallete to use and +-- computes the index into the full 256 color pallete. ansiColorIndex :: Color -> Int ansiColorIndex (ISOColor v) = fromEnum v ansiColorIndex (Color240 v) = 16 + fromEnum v -- | For terminals without setaf/setab --- +-- -- See table in `man terminfo` -- Will error if not in table. altColorIndex :: Color -> Int @@ -372,20 +370,23 @@ altColorIndex (ISOColor v) = fromEnum v altColorIndex (Color240 v) = 16 + fromEnum v -{- | The sequence of terminfo caps to apply a given style are determined according to these rules. - - - - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than - - the full set display attribute state capability. +{- | The sequence of terminfo caps to apply a given style are determined + - according to these rules. - - - 2. If a mode is supposed to be removed but there is not an exit capability defined then the - - display attributes are reset to defaults then the display attribute state is set. + - 1. The assumption is that it's preferable to use the simpler + - enter/exit mode capabilities than the full set display attribute + - state capability. - - - 3. If a mode is supposed to be applied but there is not an enter capability defined then then - - display attribute state is set if possible. Otherwise the mode is not applied. + - 2. If a mode is supposed to be removed but there is not an exit + - capability defined then the display attributes are reset to defaults + - then the display attribute state is set. - - - 4. If the display attribute state is being set then just update the arguments to that for any - - apply/remove. + - 3. If a mode is supposed to be applied but there is not an enter + - capability defined then then display attribute state is set if + - possible. Otherwise the mode is not applied. - + - 4. If the display attribute state is being set then just update the + - arguments to that for any apply/remove. -} data DisplayAttrSeq = EnterExitSeq [CapExpression] @@ -415,17 +416,19 @@ reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq reqDisplayCapSeqFor caps s diffs - -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap - -- then either the state needs to be set or the attribute change ignored. + -- if the state transition implied by any diff cannot be supported + -- with an enter/exit mode cap then either the state needs to be set + -- or the attribute change ignored. = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of -- If all the diffs have an enter-exit cap then just use those ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs - -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out - -- all unsupported diffs and just apply the rest - ( True, False ) -> EnterExitSeq $ map enterExitCap + -- If not all the diffs have an enter-exit cap and there is no + -- set state cap then filter out all unsupported diffs and just + -- apply the rest + ( True, False ) -> EnterExitSeq $ map enterExitCap $ filter (not . noEnterExitCap) diffs - -- if not all the diffs have an enter-exit can and there is a set state cap then just use - -- the set state cap. + -- if not all the diffs have an enter-exit can and there is a + -- set state cap then just use the set state cap. ( True, True ) -> SetState $ stateForStyle s where noEnterExitCap ApplyStandout = isNothing $ enterStandout caps @@ -469,9 +472,8 @@ , applyIfRequired ApplyDim dim , applyIfRequired ApplyBlink bold ] - where - applyIfRequired op flag + where + applyIfRequired op flag = if 0 == (flag .&. s) then [] else [op] - diff --git a/src/Graphics/Vty/Output/XTermColor.hs b/src/Graphics/Vty/Output/XTermColor.hs --- a/src/Graphics/Vty/Output/XTermColor.hs +++ b/src/Graphics/Vty/Output/XTermColor.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -- Copyright 2009-2010 Corey O'Connor -module Graphics.Vty.Output.XTermColor ( reserveTerminal ) - where +-- | Xterm output driver. This uses the Terminfo driver with some +-- extensions for Xterm. +module Graphics.Vty.Output.XTermColor + ( reserveTerminal + ) +where import Graphics.Vty.Output.Interface import Graphics.Vty.Input.Mouse @@ -23,21 +21,16 @@ import System.Posix.Types (Fd) import System.Posix.Env (getEnv) -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Foldable (foldMap) -#endif - import Data.List (isInfixOf) import Data.Maybe (catMaybes) import Data.Monoid ((<>)) --- | Initialize the display to UTF-8. +-- | Construct an Xterm output driver. Initialize the display to UTF-8. reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output reserveTerminal variant outFd = liftIO $ do let flushedPut = void . fdWrite outFd - -- If the terminal variant is xterm-color use xterm instead since, more often than not, - -- xterm-color is broken. + -- If the terminal variant is xterm-color use xterm instead since, + -- more often than not, xterm-color is broken. let variant' = if variant == "xterm-color" then "xterm" else variant utf8a <- utf8Active @@ -100,16 +93,15 @@ -- | These sequences set xterm based terminals to UTF-8 output. -- --- \todo I don't know of a terminfo cap that is equivalent to this. +-- There is no known terminfo capability equivalent to this. setUtf8CharSet, setDefaultCharSet :: String setUtf8CharSet = "\ESC%G" setDefaultCharSet = "\ESC%@" --- | I think xterm is broken: Reseting the background color as the first bytes serialized on a --- new line does not effect the background color xterm uses to clear the line. Which is used --- *after* the next newline. +-- | I think xterm is broken: Reseting the background color as the first +-- bytes serialized on a new line does not effect the background color +-- xterm uses to clear the line. Which is used *after* the next newline. xtermInlineHack :: Output -> IO () xtermInlineHack t = do let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K" outputByteBuffer t $ writeToByteString writeReset - diff --git a/src/Graphics/Vty/Picture.hs b/src/Graphics/Vty/Picture.hs --- a/src/Graphics/Vty/Picture.hs +++ b/src/Graphics/Vty/Picture.hs @@ -1,24 +1,36 @@ {-# LANGUAGE BangPatterns #-} --- | The 'Picture' data structure is representative of the final terminal view. --- --- A 'Picture' is a background paired with a layer of 'Image's. -module Graphics.Vty.Picture ( module Graphics.Vty.Picture - , module Graphics.Vty.Image - ) - where +-- A 'Picture' is a background paired with a set of 'Image' layers. The +-- 'Picture' data structure is representative of the final terminal +-- view. +module Graphics.Vty.Picture + ( Picture(..) + , Cursor(..) + , Background(..) + , emptyPicture + , addToTop + , addToBottom + , picForImage + , picForLayers + , picImage + ) +where import Graphics.Vty.Image +import Graphics.Vty.Attributes import Control.DeepSeq --- | The type of images to be displayed using 'update'. +-- | A Vty picture. -- --- Can be constructed directly or using `picForImage`. Which provides an initial instance with --- reasonable defaults for picCursor and picBackground. +-- These can be constructed directly or using `picForImage`. data Picture = Picture { picCursor :: Cursor + -- ^ The picture's cursor. , picLayers :: [Image] + -- ^ The picture's image layers (top-most first). , picBackground :: Background + -- ^ The picture's background to be displayed in locations with no + -- Image data. } instance Show Picture where @@ -27,66 +39,64 @@ instance NFData Picture where rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () --- | a picture with no cursor, background or image layers +-- | A picture with no cursor, background or image layers. emptyPicture :: Picture emptyPicture = Picture NoCursor [] ClearBackground --- | The given 'Image' is added as the top layer of the 'Picture' +-- | Add an 'Image' as the top-most layer of a 'Picture'. addToTop :: Picture -> Image -> Picture addToTop p i = p {picLayers = i : picLayers p} --- | The given 'Image' is added as the bottom layer of the 'Picture' +-- | Add an 'Image' as the bottom-most layer of a 'Picture'. addToBottom :: Picture -> Image -> Picture addToBottom p i = p {picLayers = picLayers p ++ [i]} --- | Create a picture for display for the given image. The picture will not have a displayed cursor --- and no background pattern (ClearBackground) will be used. +-- | Create a picture from the given image. The picture will not have a +-- displayed cursor and no background pattern (ClearBackground) will be +-- used. picForImage :: Image -> Picture -picForImage i = Picture +picForImage i = Picture { picCursor = NoCursor , picLayers = [i] , picBackground = ClearBackground } --- | Create a picture for display with the given layers. Ordered top to bottom. +-- | Create a picture with the given layers, top-most first. -- --- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be --- used. --- --- The first 'Image' is the top layer. +-- The picture will not have a displayed cursor and no background +-- pattern (ClearBackgroun) will be used. picForLayers :: [Image] -> Picture -picForLayers is = Picture +picForLayers is = Picture { picCursor = NoCursor , picLayers = is , picBackground = ClearBackground } --- | A picture can be configured either to not show the cursor or show the cursor at the specified --- character position. --- --- There is not a 1 to 1 map from character positions to a row and column on the screen due to --- characters that take more than 1 column. +-- | A picture can be configured to hide the cursor or to show the +-- cursor at the specified character position. -- --- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the --- output region. In this case the cursor will not be shown. +-- There is not a 1:1 map from character positions to a row and column +-- on the screen due to characters that take more than 1 column. data Cursor = - -- | Hide the cursor - NoCursor - -- | Show the cursor at the given logical column accounting for char width and row + -- | Hide the cursor + NoCursor + -- | Show the cursor at the given logical column accounting for + -- character width in the presence of multi-column characters. | Cursor !Int !Int - -- | Show the cursor at the given absolute terminal column and row + -- | Show the cursor at the given absolute terminal column and row | AbsoluteCursor !Int !Int instance NFData Cursor where rnf c = c `seq` () --- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the --- layer below or is blank if the bottom layer. Or the background pattern is a character and a --- display attribute. If the display attribute used previously should be used for a background fill --- then use `currentAttr` for the background attribute. +-- | A 'Picture' has a background pattern. The background is either: -- --- \todo The current attribute is always set to the default attributes at the start of updating the --- screen to a picture. +-- * ClearBackground, which shows the layer below or is blank if the +-- bottom layer +-- * A character and a display attribute +-- +-- If the display attribute used previously should be used for a +-- background fill then use `currentAttr` for the background attribute. data Background = Background { backgroundChar :: Char @@ -103,6 +113,10 @@ rnf (Background c a) = c `seq` a `seq` () rnf ClearBackground = () --- | Compatibility with applications that do not use more than a single layer. +-- | Return the top-most 'Image' layer for a picture. This is unsafe for +-- 'Picture's without at least one layer. +-- +-- This is provided for compatibility with applications that do not use +-- more than a single layer. picImage :: Picture -> Image picImage = head . picLayers diff --git a/src/Graphics/Vty/PictureToSpans.hs b/src/Graphics/Vty/PictureToSpans.hs --- a/src/Graphics/Vty/PictureToSpans.hs +++ b/src/Graphics/Vty/PictureToSpans.hs @@ -1,21 +1,14 @@ -- Copyright Corey O'Connor {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -{- | Transforms an image into rows of operations. - -} +-- | Transforms an image into rows of operations. module Graphics.Vty.PictureToSpans where -import Graphics.Vty.Prelude - +import Graphics.Vty.Attributes (Attr, currentAttr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal import Graphics.Vty.Picture @@ -26,12 +19,7 @@ import Lens.Micro.TH import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) - -#if __GLASGOW_HASKELL__ < 708 -import Control.Monad.ST.Strict hiding ( unsafeIOToST ) -#else import Control.Monad.ST.Strict -#endif import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..)) @@ -39,29 +27,27 @@ import qualified Data.Text.Lazy as TL -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (mappend) -#endif - type MRowOps s = MVector s SpanOps type MSpanOps s = MVector s SpanOp -- transform plus clip. More or less. data BlitState = BlitState - -- we always snoc to the operation vectors. Thus the columnOffset = length of row at rowOffset - -- although, one possibility is to merge layers right in snocOp (naming it something else, of - -- course). In which case columnnOffset would be applicable. - -- Right now we need it to exist. + -- we always snoc to the operation vectors. Thus the columnOffset = + -- length of row at rowOffset although, one possibility is to merge + -- layers right in snocOp (naming it something else, of course). In + -- which case columnnOffset would be applicable. Right now we need + -- it to exist. { _columnOffset :: Int , _rowOffset :: Int - -- clip coordinate space is in image space. Which means it's >= 0 and < imageWidth. + -- clip coordinate space is in image space. Which means it's >= 0 + -- and < imageWidth. , _skipColumns :: Int -- >= 0 and < imageHeight , _skipRows :: Int - -- includes consideration of skipColumns. In display space. - -- The number of columns from the next column to be defined to the end of the display for the - -- row. + -- includes consideration of skipColumns. In display space. The + -- number of columns from the next column to be defined to the end + -- of the display for the row. , _remainingColumns :: Int -- includes consideration of skipRows. In display space. , _remainingRows :: Int @@ -78,21 +64,19 @@ type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a --- | Produces the span ops that will render the given picture, possibly cropped or padded, into the --- specified region. +-- | Produces the span ops that will render the given picture, possibly +-- cropped or padded, into the specified region. displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r) --- | Returns the DisplayOps for an image rendered to a window the size of the image. +-- | Returns the DisplayOps for an image rendered to a window the size +-- of the image. -- -- largerly used only for debugging. displayOpsForImage :: Image -> DisplayOps displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i) -- | Produces the span ops for each layer then combines them. --- --- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire --- region. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0 @@ -101,8 +85,8 @@ case layerOps of [] -> fail "empty picture" [ops] -> substituteSkips (picBackground pic) ops - -- instead of merging ops after generation the merging can be performed as part of - -- snocOp. + -- instead of merging ops after generation the merging can + -- be performed as part of snocOp. topOps : lowerOps -> do ops <- foldM mergeUnder topOps lowerOps substituteSkips (picBackground pic) ops @@ -111,21 +95,23 @@ substituteSkips ClearBackground ops = do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row - -- the image operations assure that background fills are combined. - -- clipping a background fill does not split the background fill. - -- merging of image layers can split a skip, but only by the insertion of a non skip. - -- all this combines to mean we can check the last operation and remove it if it's a skip - -- todo: or does it? + -- the image operations assure that background fills are + -- combined. clipping a background fill does not split the + -- background fill. merging of image layers can split a skip, + -- but only by the insertion of a non skip. all this combines to + -- mean we can check the last operation and remove it if it's a + -- skip let rowOps' = case Vector.last rowOps of Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w _ -> rowOps - -- now all the skips can be replaced by replications of ' ' of the required width. + -- now all the skips can be replaced by replications of ' ' of + -- the required width. let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps' MVector.write ops row rowOps'' return ops substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do - -- At this point we decide if the background character is single column or not. - -- obviously, single column is easier. + -- At this point we decide if the background character is single + -- column or not. obviously, single column is easier. case safeWcwidth backgroundChar of w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar | w == 1 -> do @@ -149,12 +135,12 @@ MVector.write upper row rowOps return upper --- fugly mergeRowUnder :: SpanOps -> SpanOps -> SpanOps mergeRowUnder upperRowOps lowerRowOps = onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps where - -- H: it will never be the case that we are out of upper ops before lower ops. + -- H: it will never be the case that we are out of upper ops + -- before lower ops. onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps = let lowerOps' = dropOps w lowerOps @@ -189,30 +175,32 @@ in TextSpan a ow cw txt f v = v --- | Builds a vector of row operations that will output the given picture to the terminal. +-- | Builds a vector of row operations that will output the given +-- picture to the terminal. -- -- Crops to the given display region. --- --- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer. buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s) buildSpans image outRegion = do -- First we create a mutable vector for each rows output operations. outOps <- MVector.replicate (regionHeight outRegion) Vector.empty - -- \todo I think building the span operations in display order would provide better performance. - -- However, I got stuck trying to implement an algorithm that did this. This will be considered - -- as a possible future optimization. + -- It's possible that building the span operations in display order + -- would provide better performance. -- - -- A depth first traversal of the image is performed. ordered according to the column range - -- defined by the image from least to greatest. The output row ops will at least have the - -- region of the image specified. Iterate over all output rows and output background fills for - -- all unspecified columns. + -- A depth first traversal of the image is performed. ordered + -- according to the column range defined by the image from least + -- to greatest. The output row ops will at least have the region + -- of the image specified. Iterate over all output rows and output + -- background fills for all unspecified columns. -- - -- The images are made into span operations from left to right. It's possible that this could - -- easily be made to assure top to bottom output as well. + -- The images are made into span operations from left to right. It's + -- possible that this could easily be made to assure top to bottom + -- output as well. when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do - -- The ops builder recursively descends the image and outputs span ops that would - -- display that image. The number of columns remaining in this row before exceeding the - -- bounds is also provided. This is used to clip the span ops produced to the display. + -- The ops builder recursively descends the image and outputs + -- span ops that would display that image. The number of columns + -- remaining in this row before exceeding the bounds is also + -- provided. This is used to clip the span ops produced to the + -- display. let fullBuild = do startImageBuild image -- Fill in any unspecified columns with a skip. @@ -223,7 +211,8 @@ return () return outOps --- | Add the operations required to build a given image to the current set of row operations. +-- | Add the operations required to build a given image to the current +-- set of row operations. startImageBuild :: Image -> BlitM s () startImageBuild image = do outOfBounds <- isOutOfBounds image <$> get @@ -237,17 +226,16 @@ | s ^. skipRows >= imageHeight i = True | otherwise = False --- | This adds an image that might be partially clipped to the output ops. --- --- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom --- implementations are odd. They pass the current tests but something seems terribly wrong about all --- this. +-- | This adds an image that might be partially clipped to the output +-- ops. -- --- \todo prove this cannot be called in an out of bounds case. +-- This is a very touchy algorithm. Too touchy. For instance, the +-- CropRight and CropBottom implementations are odd. They pass the +-- current tests but something seems terribly wrong about all this. addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do - -- TODO: assumption that text spans are only 1 row high. + -- This assumes that text spans are only 1 row high. s <- use skipRows when (s < 1) $ do leftClip <- use skipColumns @@ -297,7 +285,7 @@ skipRows += topSkip addMaybeClipped croppedImage -addMaybeClippedJoin :: forall s . String +addMaybeClippedJoin :: forall s . String -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int @@ -310,9 +298,8 @@ state <- get when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0" case state^.skip of - s -- TODO: check if clipped in other dim. if not use addUnclipped - | s > size -> put $ state & skip -~ size - | s == 0 -> if state^.remaining > i0Dim + s | s > size -> put $ state & skip -~ size + | s == 0 -> if state^.remaining > i0Dim then do addMaybeClipped i0 put $ state & offset +~ i0Dim & remaining -~ i0Dim diff --git a/src/Graphics/Vty/Prelude.hs b/src/Graphics/Vty/Prelude.hs deleted file mode 100644 --- a/src/Graphics/Vty/Prelude.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | Prelude for Vty modules. Not particularly useful outside of Vty. -module Graphics.Vty.Prelude ( module Graphics.Vty.Prelude - , module Control.Applicative - , module Control.Monad - ) -where - -import Control.Applicative hiding ((<|>)) -import Control.Monad - --- | Named alias for a Int pair -type DisplayRegion = (Int,Int) - -regionWidth :: DisplayRegion -> Int -regionWidth = fst - -regionHeight :: DisplayRegion -> Int -regionHeight = snd diff --git a/src/Graphics/Vty/Span.hs b/src/Graphics/Vty/Span.hs --- a/src/Graphics/Vty/Span.hs +++ b/src/Graphics/Vty/Span.hs @@ -2,22 +2,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} -{- | A picture is translated into a sequences of state changes and character spans. - - State changes are currently limited to new attribute values. The attribute is applied to all - - following spans. Including spans of the next row. The nth element of the sequence represents the - - nth row (from top to bottom) of the picture to render. - - - - A span op sequence will be defined for all rows and columns (and no more) of the region provided - - with the picture to `spansForPic`. - - - - todo: Partition attribute changes into multiple categories according to the serialized - - representation of the various attributes. - -} -module Graphics.Vty.Span - where - -import Graphics.Vty.Prelude +-- | A picture is translated into a sequences of state changes and +-- character spans. The attribute is applied to all following spans, +-- including spans of the next row. The nth element of the sequence +-- represents the nth row (from top to bottom) of the picture to render. +-- +-- A span op sequence will be defined for all rows and columns (and no +-- more) of the region provided with the picture to 'spansForPic'. +module Graphics.Vty.Span where +import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) @@ -25,33 +19,33 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector --- | This represents an operation on the terminal. Either an attribute change or the output of a --- text string. +-- | This represents an operation on the terminal: either an attribute +-- change or the output of a text string. data SpanOp = - -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF - -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width - -- TextSpan [Attr] [output width in columns] [number of characters] [data] - TextSpan + -- | A span of UTF-8 text occupies a specific number of screen space + -- columns. A single UTF character does not necessarily represent 1 + -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width + -- in columns] [number of characters] [data] + TextSpan { textSpanAttr :: !Attr , textSpanOutputWidth :: !Int , textSpanCharWidth :: !Int , textSpanText :: DisplayText } - -- | Skips the given number of columns - -- A skip is transparent.... maybe? I am not sure how attribute changes interact. - -- todo: separate from this type. + -- | Skips the given number of columns. | Skip !Int - -- | Marks the end of a row. specifies how many columns are remaining. These columns will not be - -- explicitly overwritten with the span ops. The terminal is require to assure the remaining + -- | Marks the end of a row. Specifies how many columns are + -- remaining. These columns will not be explicitly overwritten with + -- the span ops. The terminal is require to assure the remaining -- columns are clear. - -- todo: separate from this type. | RowEnd !Int deriving Eq --- | vector of span operations. executed in succession. This represents the operations required to --- render a row of the terminal. The operations in one row may effect subsequent rows. --- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground --- color is changed. +-- | A vector of span operations executed in succession. This represents +-- the operations required to render a row of the terminal. The +-- operations in one row may affect subsequent rows. For example, +-- setting the foreground color in one row will affect all subsequent +-- rows until the foreground color is changed. type SpanOps = Vector SpanOp dropOps :: Int -> SpanOps -> SpanOps @@ -89,9 +83,9 @@ , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops) ) RowEnd _ -> error "cannot split ops containing a row end" - --- | vector of span operation vectors for display. One per row of the output region. +-- | A vector of span operation vectors for display, one per row of the +-- output region. type DisplayOps = Vector SpanOps instance Show SpanOp where @@ -99,40 +93,40 @@ show (Skip ow) = "Skip(" ++ show ow ++ ")" show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" --- | Number of columns the DisplayOps are defined for +-- | The number of columns the DisplayOps are defined for. -- --- All spans are verified to define same number of columns. See: VerifySpanOps +-- All spans are verified to define same number of columns. displayOpsColumns :: DisplayOps -> Int -displayOpsColumns ops +displayOpsColumns ops | Vector.length ops == 0 = 0 | otherwise = Vector.length $ Vector.head ops --- | Number of rows the DisplayOps are defined for +-- | The number of rows the DisplayOps are defined for. displayOpsRows :: DisplayOps -> Int displayOpsRows ops = Vector.length ops -effectedRegion :: DisplayOps -> DisplayRegion -effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) +affectedRegion :: DisplayOps -> DisplayRegion +affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) --- | The number of columns a SpanOps effects. +-- | The number of columns a SpanOps affects. spanOpsEffectedColumns :: SpanOps -> Int spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps - where + where spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w spanOpsEffectedColumns' t (Skip w) = t + w spanOpsEffectedColumns' t (RowEnd w) = t + w --- | The width of a single SpanOp in columns +-- | The width of a single SpanOp in columns. spanOpHasWidth :: SpanOp -> Maybe (Int, Int) spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow) spanOpHasWidth (Skip ow) = Just (ow,ow) spanOpHasWidth (RowEnd ow) = Just (ow,ow) --- | returns the number of columns to the character at the given position in the span op +-- | The number of columns to the character at the given position in the +-- span op. columnsToCharOffset :: Int -> SpanOp -> Int columnsToCharOffset cx (TextSpan _ _ _ utf8Str) = let str = TL.unpack utf8Str in wcswidth (take cx str) columnsToCharOffset cx (Skip _) = cx columnsToCharOffset cx (RowEnd _) = cx - diff --git a/test/Verify.hs b/test/Verify.hs --- a/test/Verify.hs +++ b/test/Verify.hs @@ -1,29 +1,29 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -module Verify ( module Verify - , module Control.Applicative - , module Control.DeepSeq - , module Control.Exception - , module Control.Monad - , module Test.QuickCheck - , module Test.QuickCheck.Modifiers - , module Text.Printf - , succeeded - , failed - , monadicIO - , liftIO - , liftBool - , Test(..) - , Prop.Result(..) - ) - where +module Verify + ( module Verify + , module Control.Applicative + , module Control.DeepSeq + , module Control.Exception + , module Control.Monad + , module Test.QuickCheck + , module Test.QuickCheck.Modifiers + , module Text.Printf + , succeeded + , failed + , monadicIO + , liftIO + , liftBool + , Test(..) + , Prop.Result(..) + ) +where import Control.Exception ( bracket, try, SomeException(..) ) @@ -35,7 +35,7 @@ import Test.QuickCheck.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import qualified Test.QuickCheck.Property as Prop -import Test.QuickCheck.Monadic ( monadicIO ) +import Test.QuickCheck.Monadic ( monadicIO ) import Text.Printf @@ -56,7 +56,7 @@ case qcResult of QC.Success {..} -> return $ Finished TS.Pass QC.Failure {numShrinks,reason} -> return $ Finished - $ TS.Fail $ "After " + $ TS.Fail $ "After " ++ show numShrinks ++ " shrinks determined failure to be: " ++ show reason _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message" @@ -85,16 +85,5 @@ liftIOResult :: Testable prop => IO prop -> Property liftIOResult = ioProperty -#if __GLASGOW_HASKELL__ <= 701 -instance Random Word where - random g = - let (i :: Int, g') = random g - in (toEnum i, g') - randomR (l,h) g = - let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g - in (toEnum i, g') -#endif - data Bench where Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench - diff --git a/test/Verify/Data/Terminfo/Parse.hs b/test/Verify/Data/Terminfo/Parse.hs --- a/test/Verify/Data/Terminfo/Parse.hs +++ b/test/Verify/Data/Terminfo/Parse.hs @@ -1,7 +1,8 @@ -module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse - , module Data.Terminfo.Parse - ) - where +module Verify.Data.Terminfo.Parse + ( module Verify.Data.Terminfo.Parse + , module Data.Terminfo.Parse + ) +where import Data.Terminfo.Parse import Data.Terminfo.Eval @@ -19,22 +20,22 @@ deriving Show instance Arbitrary NonParamCapString where - arbitrary + arbitrary = ( do s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%') return $ NonParamCapString s - ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) + ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) data LiteralPercentCap = LiteralPercentCap String [Word8] deriving ( Show ) instance Arbitrary LiteralPercentCap where - arbitrary + arbitrary = ( do NonParamCapString s <- arbitrary (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s return $ LiteralPercentCap s' bytes - ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) + ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) data IncFirstTwoCap = IncFirstTwoCap String [Word8] deriving ( Show ) @@ -45,7 +46,7 @@ NonParamCapString s <- arbitrary (s', bytes) <- insertEscapeOp "i" [] s return $ IncFirstTwoCap s' bytes - ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) + ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) data PushParamCap = PushParamCap String Int [Word8] deriving ( Show ) @@ -57,7 +58,7 @@ n <- choose (1,9) (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s return $ PushParamCap s' n bytes - ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) + ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) data DecPrintCap = DecPrintCap String Int [Word8] deriving ( Show ) @@ -69,7 +70,7 @@ n <- choose (1,9) (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s return $ DecPrintCap s' n bytes - ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) + ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) insertEscapeOp opStr replBytes s = do insertPoints <- listOf1 $ elements [0 .. length s - 1] @@ -92,21 +93,20 @@ = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap collectBytes :: CapExpression -> [Word8] -collectBytes e = concat [ bytes +collectBytes e = concat [ bytes | Bytes offset count <- capOps e , let bytes = bytesForRange e offset count ] - + verifyBytesEqual :: [Word8] -> [Word8] -> Result -verifyBytesEqual outBytes expectedBytes +verifyBytesEqual outBytes expectedBytes = if outBytes == expectedBytes then succeeded - else failed - { reason = "outBytes [" + else failed + { reason = "outBytes [" ++ hexDump outBytes ++ "] /= expectedBytes [" ++ hexDump expectedBytes ++ "]" } - diff --git a/test/Verify/Graphics/Vty/Attributes.hs b/test/Verify/Graphics/Vty/Attributes.hs --- a/test/Verify/Graphics/Vty/Attributes.hs +++ b/test/Verify/Graphics/Vty/Attributes.hs @@ -1,7 +1,8 @@ -module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes - , module Graphics.Vty.Attributes - ) - where +module Verify.Graphics.Vty.Attributes + ( module Verify.Graphics.Vty.Attributes + , module Graphics.Vty.Attributes + ) +where import Graphics.Vty.Attributes import Verify @@ -40,8 +41,8 @@ -- Limit the possible attributes to just a few for now. possibleAttrMods :: [ AttrOp ] -possibleAttrMods = - [ idOp +possibleAttrMods = + [ idOp ] ++ map setForeColorOp allColors ++ map setBackColorOp allColors ++ map setStyleOp allStyles @@ -70,4 +71,3 @@ applyOp :: AttrOp -> Attr -> Attr applyOp (AttrOp _ f) a = f a - diff --git a/test/Verify/Graphics/Vty/DisplayAttributes.hs b/test/Verify/Graphics/Vty/DisplayAttributes.hs --- a/test/Verify/Graphics/Vty/DisplayAttributes.hs +++ b/test/Verify/Graphics/Vty/DisplayAttributes.hs @@ -1,8 +1,8 @@ -module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes - , module Graphics.Vty.DisplayAttributes - ) - where +module Verify.Graphics.Vty.DisplayAttributes + ( module Verify.Graphics.Vty.DisplayAttributes + , module Graphics.Vty.DisplayAttributes + ) +where import Graphics.Vty.DisplayAttributes import Verify - diff --git a/test/Verify/Graphics/Vty/Image.hs b/test/Verify/Graphics/Vty/Image.hs --- a/test/Verify/Graphics/Vty/Image.hs +++ b/test/Verify/Graphics/Vty/Image.hs @@ -1,10 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image - , module Graphics.Vty.Image - ) - where +module Verify.Graphics.Vty.Image + ( module Verify.Graphics.Vty.Image + , module Graphics.Vty.Image + ) +where import Verify.Graphics.Vty.Attributes import Graphics.Vty.Image @@ -26,7 +27,7 @@ data DefaultImage = DefaultImage Image instance Show DefaultImage where - show (DefaultImage i) + show (DefaultImage i) = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i) instance Arbitrary DefaultImage where @@ -34,15 +35,15 @@ i <- return $ char defAttr 'X' return $ DefaultImage i -data SingleRowSingleAttrImage - = SingleRowSingleAttrImage +data SingleRowSingleAttrImage + = SingleRowSingleAttrImage { expectedAttr :: Attr , expectedColumns :: Int , rowImage :: Image } instance Show SingleRowSingleAttrImage where - show (SingleRowSingleAttrImage attr columns image) + show (SingleRowSingleAttrImage attr columns image) = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )" newtype WidthResize = WidthResize (Image -> (Image, Int)) @@ -84,14 +85,14 @@ , do ImageResize f <- arbitrary WidthResize g <- arbitrary - return $! ImageResize $! \i -> + return $! ImageResize $! \i -> let (i0, (_, outHeight)) = f i gI = g i0 in (fst gI, (snd gI, outHeight)) , do ImageResize f <- arbitrary HeightResize g <- arbitrary - return $! ImageResize $! \i -> + return $! ImageResize $! \i -> let (i0, (outWidth, _)) = f i gI = g i0 in (fst gI, (outWidth, snd gI)) @@ -100,17 +101,17 @@ instance Arbitrary SingleRowSingleAttrImage where arbitrary = do - -- The text must contain at least one character. Otherwise the image simplifies to the - -- IdImage which has a height of 0. If this is to represent a single row then the height - -- must be 1 + -- The text must contain at least one character. Otherwise the + -- image simplifies to the IdImage which has a height of 0. If + -- this is to represent a single row then the height must be 1 singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary) a <- arbitrary let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText] outWidth = length singleColumnRowText return $ SingleRowSingleAttrImage a outWidth outImage -data SingleRowTwoAttrImage - = SingleRowTwoAttrImage +data SingleRowTwoAttrImage + = SingleRowTwoAttrImage { part0 :: SingleRowSingleAttrImage , part1 :: SingleRowSingleAttrImage , joinImage :: Image @@ -122,8 +123,8 @@ p1 <- arbitrary return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1) -data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack - { stackImage :: Image +data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack + { stackImage :: Image , stackSourceImages :: [SingleRowSingleAttrImage] , stackWidth :: Int , stackHeight :: Int @@ -215,4 +216,3 @@ y <- arbitrary `suchThat` (> 0) let i' = translate x y i return $ Translation i (x,y) i' - diff --git a/test/Verify/Graphics/Vty/Output.hs b/test/Verify/Graphics/Vty/Output.hs --- a/test/Verify/Graphics/Vty/Output.hs +++ b/test/Verify/Graphics/Vty/Output.hs @@ -4,18 +4,17 @@ import Graphics.Vty.Output.Mock -import qualified Data.ByteString as BS import Data.IORef import qualified Data.String.UTF8 as UTF8 import Test.QuickCheck.Property --- A list of terminals that should be supported. --- This started with a list of terminals ubuntu supported. Then those terminals that really could --- not be supported were removed. Then a few more were pruned until a reasonable looking set was --- made. +-- A list of terminals that should be supported. This started with a +-- list of terminals ubuntu supported. Then those terminals that really +-- could not be supported were removed. Then a few more were pruned +-- until a reasonable looking set was made. terminalsOfInterest :: [String] -terminalsOfInterest = +terminalsOfInterest = [ "vt100" , "vt220" , "vt102" @@ -58,4 +57,3 @@ ++ expectedStr } else return succeeded - diff --git a/test/Verify/Graphics/Vty/Picture.hs b/test/Verify/Graphics/Vty/Picture.hs --- a/test/Verify/Graphics/Vty/Picture.hs +++ b/test/Verify/Graphics/Vty/Picture.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DisambiguateRecordFields #-} -module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture - , module Graphics.Vty.Picture - ) - where +module Verify.Graphics.Vty.Picture + ( module Verify.Graphics.Vty.Picture + , module Graphics.Vty.Picture + ) +where import Verify.Graphics.Vty.Prelude @@ -14,9 +15,9 @@ import Verify -data DefaultPic = DefaultPic +data DefaultPic = DefaultPic { defaultPic :: Picture - , defaultWin :: MockWindow + , defaultWin :: MockWindow } instance Show DefaultPic where @@ -27,10 +28,10 @@ arbitrary = do DefaultImage image <- arbitrary let win = MockWindow (imageWidth image) (imageHeight image) - return $ DefaultPic (picForImage image) - win + return $ DefaultPic (picForImage image) + win -data PicWithBGAttr = PicWithBGAttr +data PicWithBGAttr = PicWithBGAttr { withAttrPic :: Picture , withAttrWin :: MockWindow , withAttrSpecifiedAttr :: Attr @@ -41,12 +42,11 @@ DefaultImage image <- arbitrary let win = MockWindow (imageWidth image) (imageHeight image) attr <- arbitrary - return $ PicWithBGAttr (picForImage image) - win + return $ PicWithBGAttr (picForImage image) + win attr - + instance Arbitrary Picture where arbitrary = do layers <- Verify.resize 20 (listOf1 arbitrary) return $ picForLayers layers - diff --git a/test/Verify/Graphics/Vty/Prelude.hs b/test/Verify/Graphics/Vty/Prelude.hs --- a/test/Verify/Graphics/Vty/Prelude.hs +++ b/test/Verify/Graphics/Vty/Prelude.hs @@ -1,10 +1,8 @@ -module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude - , module Graphics.Vty.Prelude - , MockWindow(..) - ) - where - -import Graphics.Vty.Prelude +module Verify.Graphics.Vty.Prelude + ( module Verify.Graphics.Vty.Prelude + , MockWindow(..) + ) +where import Graphics.Vty.Debug diff --git a/test/Verify/Graphics/Vty/Span.hs b/test/Verify/Graphics/Vty/Span.hs --- a/test/Verify/Graphics/Vty/Span.hs +++ b/test/Verify/Graphics/Vty/Span.hs @@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} -module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span - , module Graphics.Vty.Span - ) - where +module Verify.Graphics.Vty.Span + ( module Verify.Graphics.Vty.Span + , module Graphics.Vty.Span + ) +where import Graphics.Vty.Debug import Graphics.Vty.Span @@ -22,7 +23,7 @@ = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans) in case any ((== True) . fst) v of False -> succeeded - True -> failed { reason = "Not all spans contained operations defining exactly " + True -> failed { reason = "Not all spans contained operations defining exactly " ++ show w ++ " columns of output - \n" ++ (concatMap ((++ "\n") . show)) v @@ -34,4 +35,3 @@ else failed { reason = "ops for alternate image " ++ show i_alt_ops ++ " are not the same as " ++ show i_ops } - diff --git a/test/VerifyConfig.hs b/test/VerifyConfig.hs --- a/test/VerifyConfig.hs +++ b/test/VerifyConfig.hs @@ -4,7 +4,6 @@ import Graphics.Vty.Config import Graphics.Vty.Input.Events -import Data.Default import Data.String.QQ import qualified Data.ByteString.Char8 as B @@ -24,7 +23,7 @@ |] exampleConfigConfig :: Config -exampleConfigConfig = def +exampleConfigConfig = defaultConfig { debugLog = Just "/tmp/vty-debug.txt" , inputMap = [ (Nothing, "\ESC[B", EvKey KUp []) , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt]) @@ -43,4 +42,3 @@ main = defaultMain [ testCase "example config parses" $ exampleConfigParses ] - diff --git a/test/VerifyCropSpanGeneration.hs b/test/VerifyCropSpanGeneration.hs --- a/test/VerifyCropSpanGeneration.hs +++ b/test/VerifyCropSpanGeneration.hs @@ -13,7 +13,7 @@ import Verify -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector cropOpDisplayOps :: (Int -> Image -> Image) -> Int -> Image -> (DisplayOps, Image) @@ -75,7 +75,7 @@ in displayOpsForImage i == displayOpsForImage iAlt tests :: IO [Test] -tests = return +tests = return [ verify "cropping from the bottom produces display operations covering the expected rows" cropBottomOutputRows , verify "cropping from the top produces display operations covering the expected rows" @@ -90,4 +90,3 @@ , verify "the output of a stack is the same as that stack cropped top & bottom and joined together" cropTopAndBottomRejoinedEquivalence ] - diff --git a/test/VerifyEmptyImageProps.hs b/test/VerifyEmptyImageProps.hs --- a/test/VerifyEmptyImageProps.hs +++ b/test/VerifyEmptyImageProps.hs @@ -3,7 +3,7 @@ import Verify -- should be exported by Graphics.Vty.Picture -import Graphics.Vty.Picture ( Image, emptyImage ) +import Graphics.Vty.Image ( Image, emptyImage ) tests :: IO [Test] tests = do diff --git a/test/VerifyEvalTerminfoCaps.hs b/test/VerifyEvalTerminfoCaps.hs --- a/test/VerifyEvalTerminfoCaps.hs +++ b/test/VerifyEvalTerminfoCaps.hs @@ -3,7 +3,7 @@ module VerifyEvalTerminfoCaps where import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound) -import Data.Terminfo.Eval +import Data.Terminfo.Eval import Data.Terminfo.Parse import Control.DeepSeq @@ -24,8 +24,9 @@ import Foreign.Ptr (Ptr, minusPtr) import Numeric --- If a terminal defines one of the caps then it's expected to be parsable. -capsOfInterest = +-- If a terminal defines one of the caps then it's expected to be +-- parsable. +capsOfInterest = [ "cup" , "sc" , "rc" @@ -49,12 +50,13 @@ tests :: IO [Test] tests = do - evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-) + -- 1 MB should be big enough for any termcaps ;-) + evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) fmap concat $ forM terminalsOfInterest $ \termName -> do putStrLn $ "adding tests for terminal: " ++ termName mti <- try $ Terminfo.setupTerm termName case mti of - Left (_e :: SomeException) + Left (_e :: SomeException) -> return [] Right ti -> do fmap concat $ forM capsOfInterest $ \capName -> do @@ -71,7 +73,7 @@ {-# NOINLINE verifyEvalCap #-} verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property verifyEvalCap evalBuffer expr !junkInt = do - forAll (vector 9) $ \inputValues -> + forAll (vector 9) $ \inputValues -> let write = writeCapExpr expr inputValues !byteCount = getBound write in liftIOResult $ do @@ -79,12 +81,11 @@ forM_ [0..100] $ \i -> runWrite write startPtr endPtr <- runWrite write startPtr case endPtr `minusPtr` startPtr of - count | count < 0 -> + count | count < 0 -> return $ failed { reason = "End pointer before start pointer." } - | toEnum count > byteCount -> - return $ failed { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byteCount) + | toEnum count > byteCount -> + return $ failed { reason = "End pointer past end of buffer by " + ++ show (toEnum count - byteCount) } - | otherwise -> + | otherwise -> return succeeded - diff --git a/test/VerifyImageOps.hs b/test/VerifyImageOps.hs --- a/test/VerifyImageOps.hs +++ b/test/VerifyImageOps.hs @@ -9,43 +9,43 @@ import Control.DeepSeq twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool -twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) = +twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) = imageWidth (char defAttr c1 <|> char defAttr c2) == 2 manySwHorizConcat :: [SingleColumnChar] -> Bool -manySwHorizConcat cs = +manySwHorizConcat cs = let chars = [ char | SingleColumnChar char <- cs ] l = fromIntegral $ length cs in imageWidth ( horizCat $ map (char defAttr) chars ) == l twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool -twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) = +twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) = imageHeight (char defAttr c1 <-> char defAttr c2) == 2 horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool -horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = - (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 - == +horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = + (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 + == char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool -twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = +twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = imageWidth (char defAttr c1 <|> char defAttr c2) == 4 manyDwHorizConcat :: [DoubleColumnChar] -> Bool -manyDwHorizConcat cs = +manyDwHorizConcat cs = let chars = [ char | DoubleColumnChar char <- cs ] l = fromIntegral $ length cs in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2 twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool -twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = +twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = imageHeight (char defAttr c1 <-> char defAttr c2) == 2 horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool -horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = - (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 - == +horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = + (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 + == char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool @@ -54,9 +54,9 @@ stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ] in imageHeight stackImage == expectedHeight -disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool +disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage + -> NonEmptyList SingleRowSingleAttrImage + -> Bool disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) = let expectedHeight :: Int = max (length stack0) (length stack1) stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] @@ -64,9 +64,9 @@ in imageHeight (stackImage0 <|> stackImage1) == expectedHeight -disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool +disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage + -> NonEmptyList SingleRowSingleAttrImage + -> Bool disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] @@ -74,31 +74,31 @@ expectedHeight = imageHeight image in case image of HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) ) - && + && ( expectedHeight == (imageHeight $ partRight image) ) _ -> True -disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage +disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) = let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - stack0Image = vertCat stack0Images - stack1Image = vertCat stack1Images + stack0Image = vertCat stack0Images + stack1Image = vertCat stack1Images image = stack0Image <-> stack1Image in imageWidth image == expectedWidth -disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage +disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - stack0Image = vertCat stack0Images - stack1Image = vertCat stack1Images + stack0Image = vertCat stack0Images + stack1Image = vertCat stack1Images image = stack0Image <-> stack1Image in case image of VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) ) @@ -171,4 +171,3 @@ , verify "can rnf image" canRnfImage , verify "can pp image" canPpImage ] - diff --git a/test/VerifyImageTrans.hs b/test/VerifyImageTrans.hs --- a/test/VerifyImageTrans.hs +++ b/test/VerifyImageTrans.hs @@ -22,7 +22,7 @@ verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0) (SingleRowSingleAttrImage attr1 charCount1 _image1) i - ) + ) | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1) | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1) diff --git a/test/VerifyLayersSpanGeneration.hs b/test/VerifyLayersSpanGeneration.hs --- a/test/VerifyLayersSpanGeneration.hs +++ b/test/VerifyLayersSpanGeneration.hs @@ -4,6 +4,7 @@ import Verify.Graphics.Vty.Prelude +import Verify.Graphics.Vty.Attributes import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Span @@ -13,7 +14,7 @@ import Verify -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result largerHorizSpanOcclusion row0 row1 = @@ -25,8 +26,9 @@ ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger) in verifyOpsEquality expectedOps ops --- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the --- second row rendered as a bottom layer with a background fill where the first row would be. +-- | Two rows stacked vertical is equivalent to the first row rendered +-- as the top layer and the second row rendered as a bottom layer with a +-- background fill where the first row would be. vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result vertStackLayerEquivalence0 row0 row1 = let i0 = rowImage row0 @@ -52,8 +54,9 @@ opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) in verifyOpsEquality expectedOps opsLayered --- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the --- second row rendered as a bottom layer with a background fill where the first row would be. +-- | Two rows horiz joined is equivalent to the first row rendered as +-- the top layer and the second row rendered as a bottom layer with a +-- background fill where the first row would be. horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result horizJoinLayerEquivalence0 row0 row1 = let i0 = rowImage row0 @@ -109,7 +112,7 @@ in verifyOpsEquality expectedOps opsLayered tests :: IO [Test] -tests = return +tests = return [ verify "a larger horiz span occludes a smaller span on a lower layer" largerHorizSpanOcclusion , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)" @@ -125,4 +128,3 @@ -- , verify "alternating images using joins is the same as alternating images using layers (1)" -- horizJoinAlternate1 ] - diff --git a/test/VerifyOutput.hs b/test/VerifyOutput.hs --- a/test/VerifyOutput.hs +++ b/test/VerifyOutput.hs @@ -1,8 +1,8 @@ -{- We setup the environment to envoke certain terminals of interest. - - This assumes appropriate definitions exist in the current environment for the terminals of - - interest. - -} +-- We setup the environment to envoke certain terminals of interest. +-- This assumes appropriate definitions exist in the current environment +-- for the terminals of interest. module VerifyOutput where + import Verify import Graphics.Vty @@ -12,8 +12,6 @@ import Control.Monad -import Data.Default - import qualified System.Console.Terminfo as Terminfo import System.Posix.Env import System.Posix.IO @@ -37,11 +35,12 @@ smokeTestTerm :: String -> Image -> IO Result smokeTestTerm termName i = do nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags - t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName } + t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName } -- putStrLn $ "context color count: " ++ show (contextColorCount t) reserveDisplay t dc <- displayContext t (100,100) - -- always show the cursor to produce tests for terminals with no cursor support. + -- always show the cursor to produce tests for terminals with no + -- cursor support. let pic = (picForImage i) { picCursor = Cursor 0 0 } outputPicture dc pic setCursorPos t 0 0 diff --git a/test/VerifyParseTerminfoCaps.hs b/test/VerifyParseTerminfoCaps.hs --- a/test/VerifyParseTerminfoCaps.hs +++ b/test/VerifyParseTerminfoCaps.hs @@ -16,7 +16,7 @@ -- If a terminal defines one of the caps then it's expected to be parsable. -- TODO: reduce duplication with terminfo terminal implementation. -capsOfInterest = +capsOfInterest = [ "cup" , "sc" , "rc" @@ -65,7 +65,7 @@ Right e -> onParse e nonParamaterizedCaps (NonParamCapString cap) = do - verifyParseCap cap $ \e -> + verifyParseCap cap $ \e -> let expectedBytes = map (toEnum . fromEnum) cap outBytes = bytesForRange e 0 (length cap) in verifyBytesEqual outBytes expectedBytes @@ -75,7 +75,7 @@ incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes - + pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do verifyParseCap capString $ \e -> let outBytes = collectBytes e @@ -98,4 +98,3 @@ printExpression ti capName = do let parseResult = parseCapExpression $ fromCapname ti capName putStrLn $ capName ++ ": " ++ show parseResult - diff --git a/test/VerifySimpleSpanGeneration.hs b/test/VerifySimpleSpanGeneration.hs --- a/test/VerifySimpleSpanGeneration.hs +++ b/test/VerifySimpleSpanGeneration.hs @@ -13,28 +13,28 @@ import Verify -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool -unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) = +unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in displayOpsColumns ops == 0 && displayOpsRows ops == 0 unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool -unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) = +unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 ) horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool -horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = +horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in displayOpsColumns ops == 0 && displayOpsRows ops == 0 horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool -horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = +horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 ) @@ -139,7 +139,7 @@ in allSpansHaveWidth ops expectedColumnCount firstSpanOpSetsAttr :: DefaultPic -> Bool -firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } = +firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } = let ops = displayOpsForPic pic (regionForWindow win) in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops ) @@ -158,7 +158,7 @@ in verifyAllSpansHaveWidth i ops (imageWidth i) tests :: IO [Test] -tests = return +tests = return [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0 , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1 , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0 @@ -171,7 +171,7 @@ , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" singleAttrSingleSpanStackOpCoverage , verify "a single attr text span is cropped when window size < size of stack image [width]" - singleAttrSingleSpanStackCropped0 + singleAttrSingleSpanStackCropped0 , verify "a single attr text span is cropped when window size < size of stack image [height]" singleAttrSingleSpanStackCropped1 , verify "single attr text span <|> single attr text span display cropped. [width]" diff --git a/test/VerifyUsingMockInput.hs b/test/VerifyUsingMockInput.hs --- a/test/VerifyUsingMockInput.hs +++ b/test/VerifyUsingMockInput.hs @@ -1,8 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced - - are as expected. - -} +-- Generate some input bytes and delays between blocks of input bytes. +-- Verify the events produced are as expected. module Main where import Verify.Graphics.Vty.Output @@ -12,14 +11,12 @@ import Graphics.Vty.Input.Loop import Graphics.Vty.Input.Terminfo -import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Lens.Micro ((^.)) import Control.Monad -import Data.Default import Data.IORef import Data.List (intersperse, reverse, nubBy) @@ -36,7 +33,8 @@ import Text.Printf --- processing a block of 16 chars is the largest I can do without taking too long to run the test. +-- processing a block of 16 chars is the largest I can do without taking +-- too long to run the test. maxBlockSize :: Int maxBlockSize = 16 @@ -47,8 +45,11 @@ forEachOf l = over (generate (\n -> take n l)) data InputEvent - = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time. - | Delay Int -- | microsecond delay + = Bytes String + -- ^ Input sequence encoded as a string. Regardless, the input is + -- read a byte at a time. + | Delay Int + -- ^ Microsecond delay deriving Show type InputSpec = [InputEvent] @@ -111,11 +112,11 @@ (writeFd, readFd) <- openPseudoTerminal (setTermAttr,_) <- attributeControl readFd setTermAttr - let testConfig = def { inputFd = Just readFd - , termName = Just "dummy" - , vmin = Just 1 - , vtime = Just 100 - } + let testConfig = defaultConfig { inputFd = Just readFd + , termName = Just "dummy" + , vmin = Just 1 + , vtime = Just 100 + } input <- initInput testConfig table eventsRef <- newIORef [] let writeWaitClose = do @@ -163,8 +164,8 @@ verifyCapsSynInputToEvent :: Property IO verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \termName -> monadic $ do - term <- setupTerm termName + forEachOf terminalsOfInterest $ \terminalName -> monadic $ do + term <- setupTerm terminalName let table = capsClassifyMap term keysFromCapsTable inputSeq = gen table events = map snd inputSeq @@ -183,9 +184,9 @@ verifyFullSynInputToEvent :: Property IO verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \termName -> monadic $ do - term <- setupTerm termName - let table = classifyMapForTerm termName term + forEachOf terminalsOfInterest $ \terminalName -> monadic $ do + term <- setupTerm terminalName + let table = classifyMapForTerm terminalName term inputSeq = gen table events = map snd inputSeq keydowns = map (Bytes . fst) inputSeq @@ -194,9 +195,9 @@ verifyFullSynInputToEvent_2x :: Property IO verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \termName -> monadic $ do - term <- setupTerm termName - let table = classifyMapForTerm termName term + forEachOf terminalsOfInterest $ \terminalName -> monadic $ do + term <- setupTerm terminalName + let table = classifyMapForTerm terminalName term inputSeq = gen table events = concatMap ((\s -> [s,s]) . snd) inputSeq keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq diff --git a/test/VerifyUsingMockTerminal.hs b/test/VerifyUsingMockTerminal.hs --- a/test/VerifyUsingMockTerminal.hs +++ b/test/VerifyUsingMockTerminal.hs @@ -4,9 +4,11 @@ import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Image +import Verify.Graphics.Vty.Attributes import Verify.Graphics.Vty.Span import Verify.Graphics.Vty.Output import Graphics.Vty.Output +import Graphics.Vty.Output.Interface import Graphics.Vty.Output.Mock import Graphics.Vty.Debug @@ -39,27 +41,30 @@ singleTRow (MockWindow w h) = liftIOResult $ do (mockData,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t - -- create an image that contains just the character T repeated for a single row + -- create an image that contains just the character T repeated for a + -- single row let i = horizCat $ replicate (fromEnum w) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic - -- The mock output string that represents the output bytes a single line containing the T - -- string: Followed by h - 1 lines of a change to the background attribute and then the - -- background character + -- The mock output string that represents the output bytes a single + -- line containing the T string: Followed by h - 1 lines of a change + -- to the background attribute and then the background character let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T' ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B') compareMockOutput mockData expected - + manyTRows :: MockWindow -> Property manyTRows (MockWindow w h) = liftIOResult $ do (mockData, t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all the rows + -- create an image that contains the character 'T' repeated for all + -- the rows let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w 'T's + -- The UTF8 string that represents the output bytes is h repeats of + -- a move, 'M', followed by an attribute change. 'A', followed by w + -- 'T's let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') compareMockOutput mockData expected @@ -67,12 +72,14 @@ manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do (mockData,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all the rows + -- create an image that contains the character 'T' repeated for all + -- the rows let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w 'T's + -- The UTF8 string that represents the output bytes is h repeats of + -- a move, 'M', followed by an attribute change. 'A', followed by w + -- 'T's let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') compareMockOutput mockData expected @@ -80,12 +87,14 @@ manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do (mockData,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all the rows + -- create an image that contains the character 'T' repeated for all + -- the rows let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w count 'T's + -- The UTF8 string that represents the output bytes is h repeats of + -- a move, 'M', followed by an attribute change. 'A', followed by w + -- count 'T's let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') compareMockOutput mockData expected @@ -97,4 +106,3 @@ , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight ] - diff --git a/test/VerifyUtf8Width.hs b/test/VerifyUtf8Width.hs --- a/test/VerifyUtf8Width.hs +++ b/test/VerifyUtf8Width.hs @@ -1,9 +1,11 @@ module VerifyUtf8Width where + import Verify import Graphics.Text.Width import Graphics.Vty.Attributes import Graphics.Vty.Picture +import Graphics.Vty.Image swIs1Column :: SingleColumnChar -> Bool swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1 diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,10 +1,10 @@ name: vty -version: 5.14 +version: 5.15 license: BSD3 license-file: LICENSE author: AUTHORS maintainer: Jonathan Daugherty (cygnus@foobox.com) -homepage: https://github.com/coreyoconnor/vty +homepage: https://github.com/jtdaugherty/vty category: User Interfaces synopsis: A simple terminal UI library description: @@ -12,48 +12,36 @@ be easy to use, have no confusing corner cases, and good support for common terminal types. . - Included in the source distribution is a program - test/interactive_terminal_test.hs that demonstrates the various - features. - . - Developers: See the "Graphics.Vty" module. - . - Users: See the "Graphics.Vty.Config" module. - . - If your terminal is not behaving as expected the results of the - vty-interactive-terminal-test executable should be sent to the Vty - maintainter to aid in debugging the issue. - . - Notable infelicities: Assumes UTF-8 character encoding support by the - terminal; Poor signal handling; Requires terminfo. - . - This project is hosted on github.com: + See the @vty-examples@ package as well as the program + @test/interactive_terminal_test.hs@ included in the @vty@ package for + examples on how to use the library. . - > git clone git://github.com/coreyoconnor/vty.git + Import the "Graphics.Vty" convenience module to get access to the core + parts of the library. . © 2006-2007 Stefan O'Rear; BSD3 license. . © Corey O'Connor; BSD3 license. + . + © Jonathan Daugherty; BSD3 license. cabal-version: >= 1.18 build-type: Simple data-files: README.md, - TODO, AUTHORS, - CHANGELOG, + CHANGELOG.md, LICENSE tested-with: GHC >= 7.6.2 source-repository head type: git - location: https://github.com/coreyoconnor/vty.git + location: https://github.com/jtdaugherty/vty.git library default-language: Haskell2010 - build-depends: base >= 4 && < 5, + build-depends: base >= 4.6 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, containers, - data-default >= 0.5.3, deepseq >= 1.1 && < 1.5, directory, filepath >= 1.0 && < 2.0, @@ -83,7 +71,6 @@ Graphics.Vty.Input Graphics.Vty.Input.Events Graphics.Vty.Picture - Graphics.Vty.Prelude Graphics.Vty.Output Graphics.Text.Width -- the modules below are only meant to be used by the tests. @@ -131,30 +118,30 @@ executable vty-mode-demo main-is: ModeDemo.hs + hs-source-dirs: demos default-language: Haskell2010 default-extensions: ScopedTypeVariables ghc-options: -threaded build-depends: vty, - base >= 4 && < 5, + base >= 4.6 && < 5, containers, - data-default >= 0.5.3, microlens, microlens-mtl, mtl >= 1.1.1.0 && < 2.3 executable vty-demo main-is: Demo.hs + hs-source-dirs: demos default-language: Haskell2010 default-extensions: ScopedTypeVariables ghc-options: -threaded build-depends: vty, - base >= 4 && < 5, + base >= 4.6 && < 5, containers, - data-default >= 0.5.3, microlens, microlens-mtl, mtl >= 1.1.1.0 && < 2.3 @@ -169,7 +156,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -201,7 +188,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -234,10 +221,9 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, - data-default >= 0.5.3, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, terminfo >= 0.3 && < 0.5, @@ -268,7 +254,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -294,7 +280,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -321,7 +307,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, containers, @@ -351,7 +337,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -379,7 +365,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -406,7 +392,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -434,7 +420,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -466,7 +452,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -498,7 +484,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -530,7 +516,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -556,7 +542,7 @@ Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -578,14 +564,13 @@ build-depends: vty, Cabal >= 1.20, - data-default >= 0.5.3, QuickCheck >= 2.7, smallcheck == 1.*, quickcheck-assertions >= 0.1.1, test-framework == 0.8.*, test-framework-smallcheck == 0.2.*, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, @@ -613,7 +598,6 @@ build-depends: vty, Cabal >= 1.20, - data-default >= 0.5.3, HUnit, QuickCheck >= 2.7, smallcheck == 1.*, @@ -622,7 +606,7 @@ test-framework-smallcheck == 0.2.*, test-framework-hunit, random >= 1.0 && < 1.2, - base >= 4 && < 5, + base >= 4.6 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5,