diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,294 @@ +# Revision history for Ansiform + +> Formerly Vis. The 0.4.0 release renames the package and the module namespace. + +## Functional Versions + +### 1.0.0.1 -- 2026-10-21 +* Added Fourmolu formatting and HLint checks, a gitleaks secret scan and a manual release workflow. +* Added a macOS Intel CI job for GHC 9.2.8 and updated the GitHub Actions to Node 24 versions. +* Added `docs/quality.md` and documented the release automation. + +### 1.0.0 -- 2026-10-21 +* Forms now draw every prefilled field when they open, so all current values are visible before the first field is focused. The active field redraws the same text and starts with the cursor at the end. +* Marked the library stable at 1.0.0 after the editable form fields, the shortcut key reader, the line editing core and the multiplatform CI work. + +### 0.9.0.6 -- 2026-10-21 +* Fixed a lone Escape never timing out in `readKeyPress` and the line editor. `waitKey` called `isEOF` before `hWaitForInput`; on a terminal, `isEOF` blocks until the next key, so Esc cancellation and the 50 ms sequence timeout never fired. `waitKey` now relies on `hWaitForInput` and converts only end-of-file exceptions into `KeyEnded`. +* Verified the Linux terminal checklist in `docs/platforms.md` under a pseudo-terminal: immediate keys, arrow isolation, forms, editor navigation, Esc cancellation, horizontal scrolling, colour detection and resize all pass. + +### 0.9.0.5 -- 2026-10-21 +* Pinned the macOS CI job to `macos-15`. The `macos-latest` image ships an SDK that the GHC 9.14.1 linker cannot parse, so the build failed before the tests ran. + +### 0.9.0.4 -- 2026-10-21 +* Fixed a Windows crash when rendering to a temporary handle. `termWOn` and `termHOn` now query the terminal size only when the handle is a terminal. The `stty` fallback in `terminal-size` can close a non-console handle on Windows, which broke `renderPage`, `renderSection` and `renderPrinter` on that platform. + +### 0.9.0.3 -- 2026-10-21 +* Fixed the test suite on Windows. `captureStdout` used lazy `readFile` and tried to remove the temporary file before it was closed; Windows cannot delete an open file. It now uses strict `readFile'`. +* The first Windows CI run exposed this test-only failure. + +### 0.9.0.2 -- 2026-10-21 +* Added macOS and Windows jobs to the CI matrix for build, test, package check, Haddock and source distribution. +* The cache now uses the Cabal store reported by `haskell-actions/setup`, which works on all three operating systems. +* GHC 9.2.8 is excluded on the arm64 macOS runner, which has no aarch64-darwin bindist; macOS runs GHC 9.14.1. +* Updated the platform and release notes to describe the new matrix. + +### 0.9.0.1 -- 2026-10-21 +* Automatic colour detection now uses `hSupportsANSI`, so Windows consoles and MinTTY are recognised; `NO_COLOR` still disables styling. +* Escape-sequence timeouts use `hWaitForInput` instead of an asynchronous timeout around `getChar`, which is portable and does not interrupt a blocked read. +* Added `docs/platforms.md` with the Linux, macOS and Windows behaviour, terminal requirements and known limitations. +* The demo and tutorial enable the `winio` I/O manager on Windows, and the demo version label follows the package version. +* Added a regression test that documents the raw `readKey` output for an arrow-key sequence. + +### 0.9.0 -- 2026-10-21 +* Added `readKeyPress` to `Ansiform.Input`, a key reader for menus that consumes and ignores terminal escape sequences such as arrow keys. +* Fixed the tutorial and the demo treating arrow-key sequences as `A` or `D` shortcuts, which opened the add or edit form instead of moving the selection. +* The tutorial, the demo and the README quick start now use `readKeyPress` in their command loops. +* Updated the demo version label to follow the package version. + +### 0.8.0 -- 2026-10-21 +* Added `promptWithInitial` to `Ansiform.Input`, opening a form field with an editable initial value. +* Added a single-line editor with insertion, Backspace, Delete, arrows, Home, End, Enter to submit and Esc to cancel the whole form. +* Added `FormCancelled` to `FormError`; code that matches `FormError` exhaustively must handle the new constructor. +* Added `Ansiform.Line` with the pure `LineState`, `LineKey`, `applyLineKey` and `visibleLine` core. +* The editor scrolls horizontally and keeps Unicode widths, so wide characters and combining marks stay aligned. +* Non-terminal input still uses `readLine` and ignores the initial value. +* The tutorial gained an `E` edit mode that prefills the selected bookmark; its form page now takes the footer instruction as a parameter. +* Added docs for editable fields and updated the architecture and roadmap. + +### 0.7.10.4 -- 2026-10-21 +* Removed the obsolete URL readability comment from the tutorial example and its documentation snippet. + +### 0.7.10.3 -- 2026-10-21 +* BordersNone now renders a true borderless table with the same row and column layout as the bordered printers, without border characters, horizontal separators or column bands. +* Columns in the borderless mode are separated by two spaces. + +### 0.7.10.2 -- 2026-10-21 +* Changed defaultTheme.themeMuted from vivid black to italic white for readability on dark terminals. +* Kept defaultTheme.themeRule as bold vivid black. +* Condensed the tutorial form instruction into the footer and removed the extra body line. + +### 0.7.10.1 -- 2026-10-21 +* Changed the tutorial bookmark URL style from muted black to italic white for readability on dark terminals. +* Kept the tutorial rules on the theme rule style, which is black in the default theme. + +### 0.7.10.0 -- 2026-10-21 +* Added docs/tutorial.md, a step-by-step guide to a small bookmarks program. +* Added the ansiform-tutorial executable in examples/Tutorial.hs. + +### 0.7.9.0 -- 2026-10-21 +* Added readForm and readFormOn to Ansiform.Input, reading several page prompts with the cursor arithmetic handled by the library. +* Added Prompt, promptAt and FormError as public types for page forms. +* printerGroupsBordered and its variants now pad unequal groups with empty blocks automatically. +* Added addNumber, subtractNumber and subtractNumberMaybe to Ansiform.Number; checked subtraction reports a negative result as Nothing. +* Clarified the Haddock comments for the single-block and line solid printers, and warned that readLineAt already wraps withLineInput. +* Added docs/number.md. + +### 0.7.8.6 -- 2026-10-21 +* Fixed README links so they resolve on Hackage. +* Removed the top horizontal rule from the demo header. + +### 0.7.8.5 -- 2026-10-20 +* Added PVP upper bounds to the directory dependency of the test suite. + +### 0.7.8.4 -- 2026-10-18 +* Finalized the package metadata with the author name and the project maintainer alias. +* Documented the Hackage candidate workflow for verification before publication. + +### 0.7.8.3 -- 2026-10-17 +* Removed docs/design-notes.md; the original notes remain available in the Git history. + +### 0.7.8.2 -- 2026-10-17 +* Changed the Groups shortcut for the philosopher prompt from E to C. +* Added a blank line below the prompt and removed the choose shortcut from the prompt page. +* Removed the local secrets file path from the release guide and repository history. +* Removed personal SSH paths from the release guide and reviewed the documentation, translating the remaining design notes. + +### 0.7.8.1 -- 2026-10-17 +* Merged the Groups prompt message and input line into a single footer line. + +### 0.7.8.0 -- 2026-10-17 +* Added readLineAt and readLineAtOn to Ansiform.Input for prompts printed inside a page. +* The demo Groups prompt now lives in the footer, above the command keys, so nothing is printed below the footer. +* Fixed the demo losing immediate key input after returning from a philosopher article. +* Translated the demo prompt and the E key label to English. + +### 0.7.7.1 -- 2026-10-17 +* Updated the README dependency list and documentation index. +* Recorded the initial push and roadmap completion in the release checklist. + +### 0.7.7.0 -- 2026-10-17 +* Added withLineInput and readLine to Ansiform.Input. +* Replaced the Cicero and Locke shortcuts with an E Escolher prompt that accepts any philosopher number. +* Back from a philosopher article now returns to the Groups screen. + +### 0.7.6.0 -- 2026-10-17 +* Added dedicated demo screens and articles for Cicero and Locke. +* Added C and L shortcuts to the Groups footer. +* Added a CI matrix with GHC 9.2.8 and GHC 9.14.1. +* Documented direct command-line Hackage tokens and SSH setup for GitHub. + +### 0.7.5.2 -- 2026-10-17 +* Renamed CHANGELOG.md back to ChangeLog.md, following the Hackage convention. +* Documented the Hackage token key at the top level of ~/.cabal/config. + +### 0.7.5.1 -- 2026-10-17 +* Documented every public function and type with Haddock comments; all public modules report 100% coverage. +* Changed the default theme footer to italic white for readability. +* Documented Hackage and GitHub credential configuration in docs/releasing.md. + +### 0.7.5.0 -- 2026-10-17 +* Added Borders with ASCII, light, heavy and double styles. +* Added the printerTableBordered and printerGroupsBordered families. +* Added the GitHub repository metadata and configured the origin remote. +* The demo Rich screen now uses a light bordered table and unknown keys are ignored without a message. + +### 0.7.4.0 -- 2026-10-17 +* Added Ansiform.Theme with Theme and defaultTheme. +* Added blockMenuStyle for menu keys that use a Style instead of a Color. +* Updated the demo header, footer, menus, rules and simple table to use the theme. +* Fixed the demo Tables column width so Tchaikovsky is readable. +* Added docs/theme.md. + +### 0.7.3.0 -- 2026-10-17 +* Added Ansiform.Table with per-column alignment, maximum widths and ellipsis truncation. +* Added printerTableFormat, printerTableFormat', printerTableLimitedFormat and printerTableLimitedFormat'. +* Updated the demo Tables screen to right-align numeric columns and truncate long composer names. +* Added docs/table-format.md. + +### 0.7.2.0 -- 2026-10-17 +* Added handle-aware runners: startOn, drawOn, redrawOn, amendOn, replaceOn and their variants. +* Added runPrinterOn, runPrinterDefaultOn and runPrinterDefaultOn' for writing to a specific handle. +* Added Ansiform.Render with renderPage, renderSection and renderPrinter. +* Added docs/render.md and expanded the demo article for the Article screen. + +### 0.7.1.0 -- 2026-10-17 +* Added Ansiform.Input with withImmediateInput and readKey, making single-key interaction the standard library pattern. +* Updated the demo to use the shared input API and restore terminal state automatically. +* Added Unicode-aware display widths through Ansiform.Width, used for wrapping, alignment, lists and tables. +* Added docs/input.md and updated the README quick start, pages, architecture, content and roadmap. + +### 0.7.0 -- 2026-10-17 +* Added the ColorMode setting with Auto, Always and Never. +* Auto suppresses ANSI styles when stdout is not a terminal, when NO_COLOR is set or when TERM is dumb. +* Added the colorMode modifier and the autoColors, alwaysColors and neverColors shortcuts. +* Added regression tests for style suppression and forced styling. +* Renamed ChangeLog.md to CHANGELOG.md (reverted in 0.7.5.2). + +### 0.6.1 -- 2026-10-17 +* Added the GitHub Actions CI workflow. +* Added docs/releasing.md with the Hackage and GitHub checklist. +* Added docs/roadmap.md with prioritized feature suggestions. +* Added module-level Haddock headers to the public modules. + +### 0.6.0 -- 2026-10-17 +* Renamed the internal vis* builders to form* (formItem, formBlock, formGroup, ...). +* Renamed the low-level style helpers to descriptive names (applyStyle, resetStyle, styleCommands, colorCommands, formatCommands, setBackground, swapBackground). +* Renamed the public visNumber to formNumber. +* Updated the demo, tests and docs for the new builder names. + +### 0.5.0 -- 2026-10-17 +* Removed the Vis prefix from all public types. +* Renamed VisItem to Item, VisBlock to Block, and so on, including Color, Format, Style, Printer, Section, Page, Settings, Config, State and Sample. +* Updated the demo, tests, README and docs for the new type names. +* Kept the internal vis* builder helpers as implementation details. + +### 0.4.0 -- 2026-10-17 +* Renamed the package to ansiform and the module namespace to Ansiform. +* Changed the license from GPL-3.0-only to MIT. +* Updated the README, docs, demo and tests for the new name. +* Kept the Vis* type names for now; removing the prefix is future work. + +### 0.3.5 -- 2026-10-17 +* Modernized the Cabal setup to cabal-version 3.0. +* Added a common stanza and a cabal.project file. +* Removed the obsolete Setup.hs and switched to the SPDX license identifier. +* Documented the existing Hackage Vis package and recommended ansiform for publication. + +### 0.3.4 -- 2026-10-17 +* Documented the name rationale and its relationship to vis-network.js. +* Added a disambiguation note to the README. + +### 0.3.3 -- 2026-10-17 +* Fixed printLineCenter so blocks respect the minimum space and never overlap. +* Made the demo menu use the same shortcut presentation as the footer. +* Split the demo footer commands into two rows to keep long labels readable. + +### 0.3.2 -- 2026-10-17 +* Reflowed the README and documentation to remove hard wrapping. +* Added a blank line above the demo's main header line. +* Changed the demo to read single keys without a prompt or Enter. +* Fixed the Exit key highlight in the demo menu. +* Documented the evaluation of the proposed monadic Printer and Section interface. + +### 0.3.1 -- 2026-10-17 +* Removed the extra solid bar from the demo header, which covered part of the second line. +* Made the demo footer shortcuts functional with an interactive screen loop. +* Documented the decision to defer the Text and Seq migrations. + +### 0.3.0 -- 2026-10-17 +* Revival release: removed Example and internal modules from the public Vis module. +* Added public Vis.Number and Vis.Sample modules. +* Added the vis-demo executable and the vis-test suite. +* Made paragraph wrapping, list layout and group layout total for empty and narrow inputs. +* Fixed a division by zero in group overflow handling. +* Preserved section line counts across chained replace calls. +* Added documentation in docs/ and rewrote the README as an index. +* Enabled -Wall and cleaned compiler warnings. + +## Early Versions + +### 0.2.2.7 -- 2020-05-29 +* Implementation of Sample instance for VisNumber. +* Refining of Sample class and instances for all types. + +### 0.2.2.5 -- 2020-05-23 +* Got rid of the Result type and module. +* Reversal of Show instances to default, creation of Sample class. +* Implementation of sample functions. +* Created Printer for single Item. + +### 0.2.2.1 -- 2020-05-21 +* Implemented minimum number of lines for Sections. + +### 0.2.2.0 -- 2020-05-20 +* Finished amend functionality for VisPage and workflow. +* Made Settings update at each redraw. +* Created the new VisConfig type for internal use. +* Made VisSettings the user exposed settings type. +* Made the basic Run functions work with configs, not settings. +* Created Draw module and internal State module. + +### 0.2.1.4 -- 2020-05-19 +* Exposed the basic builders. +* Reworked type runners to deal with IO separately. +* Defined VisState type and top level functionality. +* Created VisResult type to associate printed line numbers with Sections. +* Separated VisPage internal functionality. + +### 0.2.0.9 -- 2020-05-09 +* Gave up on verbose mode. +* Moved VisPrinter type to internal module. +* Reworked Show instances for most types and VisPrinter. +* Reworked Show instance for VisSection and moved type to internal module. + +### 0.2.0.5 -- 2020-05-08 +* Made VisItem remove non-printable characters. +* Creation of Internal folder to separate internal modules. +* Creation of Show Instances to implement the Verbose mode. +* Implementation of Settings type and functions. +* Improved Section type to calculate the total printed lines. + +### 0.2.0.0 -- 2020-05-07 +* Major change so VisPrinter returns the number of lines printed. +* Major refactoring and module splits. + +### 0.1.1.0 -- 2020-04-25 +* VisPrinter functionality implemented. + +### 0.1.0.5 -- 2020-04-19 +* Restarted project. +* Implemented basic content types and styles. + +### 0.1.0.0 -- 2018-06-12 +* First version, very basic functionality, not commited to VCS. diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,289 +0,0 @@ -# Revision history for Ansiform - -> Formerly Vis. The 0.4.0 release renames the package and the module namespace. - -## Functional Versions - -### 1.0.0 -- 2026-10-21 -* Forms now draw every prefilled field when they open, so all current values are visible before the first field is focused. The active field redraws the same text and starts with the cursor at the end. -* Marked the library stable at 1.0.0 after the editable form fields, the shortcut key reader, the line editing core and the multiplatform CI work. - -### 0.9.0.6 -- 2026-10-21 -* Fixed a lone Escape never timing out in `readKeyPress` and the line editor. `waitKey` called `isEOF` before `hWaitForInput`; on a terminal, `isEOF` blocks until the next key, so Esc cancellation and the 50 ms sequence timeout never fired. `waitKey` now relies on `hWaitForInput` and converts only end-of-file exceptions into `KeyEnded`. -* Verified the Linux terminal checklist in `docs/platforms.md` under a pseudo-terminal: immediate keys, arrow isolation, forms, editor navigation, Esc cancellation, horizontal scrolling, colour detection and resize all pass. - -### 0.9.0.5 -- 2026-10-21 -* Pinned the macOS CI job to `macos-15`. The `macos-latest` image ships an SDK that the GHC 9.14.1 linker cannot parse, so the build failed before the tests ran. - -### 0.9.0.4 -- 2026-10-21 -* Fixed a Windows crash when rendering to a temporary handle. `termWOn` and `termHOn` now query the terminal size only when the handle is a terminal. The `stty` fallback in `terminal-size` can close a non-console handle on Windows, which broke `renderPage`, `renderSection` and `renderPrinter` on that platform. - -### 0.9.0.3 -- 2026-10-21 -* Fixed the test suite on Windows. `captureStdout` used lazy `readFile` and tried to remove the temporary file before it was closed; Windows cannot delete an open file. It now uses strict `readFile'`. -* The first Windows CI run exposed this test-only failure. - -### 0.9.0.2 -- 2026-10-21 -* Added macOS and Windows jobs to the CI matrix for build, test, package check, Haddock and source distribution. -* The cache now uses the Cabal store reported by `haskell-actions/setup`, which works on all three operating systems. -* GHC 9.2.8 is excluded on the arm64 macOS runner, which has no aarch64-darwin bindist; macOS runs GHC 9.14.1. -* Updated the platform and release notes to describe the new matrix. - -### 0.9.0.1 -- 2026-10-21 -* Automatic colour detection now uses `hSupportsANSI`, so Windows consoles and MinTTY are recognised; `NO_COLOR` still disables styling. -* Escape-sequence timeouts use `hWaitForInput` instead of an asynchronous timeout around `getChar`, which is portable and does not interrupt a blocked read. -* Added `docs/platforms.md` with the Linux, macOS and Windows behaviour, terminal requirements and known limitations. -* The demo and tutorial enable the `winio` I/O manager on Windows, and the demo version label follows the package version. -* Added a regression test that documents the raw `readKey` output for an arrow-key sequence. - -### 0.9.0 -- 2026-10-21 -* Added `readKeyPress` to `Ansiform.Input`, a key reader for menus that consumes and ignores terminal escape sequences such as arrow keys. -* Fixed the tutorial and the demo treating arrow-key sequences as `A` or `D` shortcuts, which opened the add or edit form instead of moving the selection. -* The tutorial, the demo and the README quick start now use `readKeyPress` in their command loops. -* Updated the demo version label to follow the package version. - -### 0.8.0 -- 2026-10-21 -* Added `promptWithInitial` to `Ansiform.Input`, opening a form field with an editable initial value. -* Added a single-line editor with insertion, Backspace, Delete, arrows, Home, End, Enter to submit and Esc to cancel the whole form. -* Added `FormCancelled` to `FormError`; code that matches `FormError` exhaustively must handle the new constructor. -* Added `Ansiform.Line` with the pure `LineState`, `LineKey`, `applyLineKey` and `visibleLine` core. -* The editor scrolls horizontally and keeps Unicode widths, so wide characters and combining marks stay aligned. -* Non-terminal input still uses `readLine` and ignores the initial value. -* The tutorial gained an `E` edit mode that prefills the selected bookmark; its form page now takes the footer instruction as a parameter. -* Added docs for editable fields and updated the architecture and roadmap. - -### 0.7.10.4 -- 2026-10-21 -* Removed the obsolete URL readability comment from the tutorial example and its documentation snippet. - -### 0.7.10.3 -- 2026-10-21 -* BordersNone now renders a true borderless table with the same row and column layout as the bordered printers, without border characters, horizontal separators or column bands. -* Columns in the borderless mode are separated by two spaces. - -### 0.7.10.2 -- 2026-10-21 -* Changed defaultTheme.themeMuted from vivid black to italic white for readability on dark terminals. -* Kept defaultTheme.themeRule as bold vivid black. -* Condensed the tutorial form instruction into the footer and removed the extra body line. - -### 0.7.10.1 -- 2026-10-21 -* Changed the tutorial bookmark URL style from muted black to italic white for readability on dark terminals. -* Kept the tutorial rules on the theme rule style, which is black in the default theme. - -### 0.7.10.0 -- 2026-10-21 -* Added docs/tutorial.md, a step-by-step guide to a small bookmarks program. -* Added the ansiform-tutorial executable in examples/Tutorial.hs. - -### 0.7.9.0 -- 2026-10-21 -* Added readForm and readFormOn to Ansiform.Input, reading several page prompts with the cursor arithmetic handled by the library. -* Added Prompt, promptAt and FormError as public types for page forms. -* printerGroupsBordered and its variants now pad unequal groups with empty blocks automatically. -* Added addNumber, subtractNumber and subtractNumberMaybe to Ansiform.Number; checked subtraction reports a negative result as Nothing. -* Clarified the Haddock comments for the single-block and line solid printers, and warned that readLineAt already wraps withLineInput. -* Added docs/number.md. - -### 0.7.8.6 -- 2026-10-21 -* Fixed README links so they resolve on Hackage. -* Removed the top horizontal rule from the demo header. - -### 0.7.8.5 -- 2026-10-20 -* Added PVP upper bounds to the directory dependency of the test suite. - -### 0.7.8.4 -- 2026-10-18 -* Finalized the package metadata with the author name and the project maintainer alias. -* Documented the Hackage candidate workflow for verification before publication. - -### 0.7.8.3 -- 2026-10-17 -* Removed docs/design-notes.md; the original notes remain available in the Git history. - -### 0.7.8.2 -- 2026-10-17 -* Changed the Groups shortcut for the philosopher prompt from E to C. -* Added a blank line below the prompt and removed the choose shortcut from the prompt page. -* Removed the local secrets file path from the release guide and repository history. -* Removed personal SSH paths from the release guide and reviewed the documentation, translating the remaining design notes. - -### 0.7.8.1 -- 2026-10-17 -* Merged the Groups prompt message and input line into a single footer line. - -### 0.7.8.0 -- 2026-10-17 -* Added readLineAt and readLineAtOn to Ansiform.Input for prompts printed inside a page. -* The demo Groups prompt now lives in the footer, above the command keys, so nothing is printed below the footer. -* Fixed the demo losing immediate key input after returning from a philosopher article. -* Translated the demo prompt and the E key label to English. - -### 0.7.7.1 -- 2026-10-17 -* Updated the README dependency list and documentation index. -* Recorded the initial push and roadmap completion in the release checklist. - -### 0.7.7.0 -- 2026-10-17 -* Added withLineInput and readLine to Ansiform.Input. -* Replaced the Cicero and Locke shortcuts with an E Escolher prompt that accepts any philosopher number. -* Back from a philosopher article now returns to the Groups screen. - -### 0.7.6.0 -- 2026-10-17 -* Added dedicated demo screens and articles for Cicero and Locke. -* Added C and L shortcuts to the Groups footer. -* Added a CI matrix with GHC 9.2.8 and GHC 9.14.1. -* Documented direct command-line Hackage tokens and SSH setup for GitHub. - -### 0.7.5.2 -- 2026-10-17 -* Renamed CHANGELOG.md back to ChangeLog.md, following the Hackage convention. -* Documented the Hackage token key at the top level of ~/.cabal/config. - -### 0.7.5.1 -- 2026-10-17 -* Documented every public function and type with Haddock comments; all public modules report 100% coverage. -* Changed the default theme footer to italic white for readability. -* Documented Hackage and GitHub credential configuration in docs/releasing.md. - -### 0.7.5.0 -- 2026-10-17 -* Added Borders with ASCII, light, heavy and double styles. -* Added the printerTableBordered and printerGroupsBordered families. -* Added the GitHub repository metadata and configured the origin remote. -* The demo Rich screen now uses a light bordered table and unknown keys are ignored without a message. - -### 0.7.4.0 -- 2026-10-17 -* Added Ansiform.Theme with Theme and defaultTheme. -* Added blockMenuStyle for menu keys that use a Style instead of a Color. -* Updated the demo header, footer, menus, rules and simple table to use the theme. -* Fixed the demo Tables column width so Tchaikovsky is readable. -* Added docs/theme.md. - -### 0.7.3.0 -- 2026-10-17 -* Added Ansiform.Table with per-column alignment, maximum widths and ellipsis truncation. -* Added printerTableFormat, printerTableFormat', printerTableLimitedFormat and printerTableLimitedFormat'. -* Updated the demo Tables screen to right-align numeric columns and truncate long composer names. -* Added docs/table-format.md. - -### 0.7.2.0 -- 2026-10-17 -* Added handle-aware runners: startOn, drawOn, redrawOn, amendOn, replaceOn and their variants. -* Added runPrinterOn, runPrinterDefaultOn and runPrinterDefaultOn' for writing to a specific handle. -* Added Ansiform.Render with renderPage, renderSection and renderPrinter. -* Added docs/render.md and expanded the demo article for the Article screen. - -### 0.7.1.0 -- 2026-10-17 -* Added Ansiform.Input with withImmediateInput and readKey, making single-key interaction the standard library pattern. -* Updated the demo to use the shared input API and restore terminal state automatically. -* Added Unicode-aware display widths through Ansiform.Width, used for wrapping, alignment, lists and tables. -* Added docs/input.md and updated the README quick start, pages, architecture, content and roadmap. - -### 0.7.0 -- 2026-10-17 -* Added the ColorMode setting with Auto, Always and Never. -* Auto suppresses ANSI styles when stdout is not a terminal, when NO_COLOR is set or when TERM is dumb. -* Added the colorMode modifier and the autoColors, alwaysColors and neverColors shortcuts. -* Added regression tests for style suppression and forced styling. -* Renamed ChangeLog.md to CHANGELOG.md (reverted in 0.7.5.2). - -### 0.6.1 -- 2026-10-17 -* Added the GitHub Actions CI workflow. -* Added docs/releasing.md with the Hackage and GitHub checklist. -* Added docs/roadmap.md with prioritized feature suggestions. -* Added module-level Haddock headers to the public modules. - -### 0.6.0 -- 2026-10-17 -* Renamed the internal vis* builders to form* (formItem, formBlock, formGroup, ...). -* Renamed the low-level style helpers to descriptive names (applyStyle, resetStyle, styleCommands, colorCommands, formatCommands, setBackground, swapBackground). -* Renamed the public visNumber to formNumber. -* Updated the demo, tests and docs for the new builder names. - -### 0.5.0 -- 2026-10-17 -* Removed the Vis prefix from all public types. -* Renamed VisItem to Item, VisBlock to Block, and so on, including Color, Format, Style, Printer, Section, Page, Settings, Config, State and Sample. -* Updated the demo, tests, README and docs for the new type names. -* Kept the internal vis* builder helpers as implementation details. - -### 0.4.0 -- 2026-10-17 -* Renamed the package to ansiform and the module namespace to Ansiform. -* Changed the license from GPL-3.0-only to MIT. -* Updated the README, docs, demo and tests for the new name. -* Kept the Vis* type names for now; removing the prefix is future work. - -### 0.3.5 -- 2026-10-17 -* Modernized the Cabal setup to cabal-version 3.0. -* Added a common stanza and a cabal.project file. -* Removed the obsolete Setup.hs and switched to the SPDX license identifier. -* Documented the existing Hackage Vis package and recommended ansiform for publication. - -### 0.3.4 -- 2026-10-17 -* Documented the name rationale and its relationship to vis-network.js. -* Added a disambiguation note to the README. - -### 0.3.3 -- 2026-10-17 -* Fixed printLineCenter so blocks respect the minimum space and never overlap. -* Made the demo menu use the same shortcut presentation as the footer. -* Split the demo footer commands into two rows to keep long labels readable. - -### 0.3.2 -- 2026-10-17 -* Reflowed the README and documentation to remove hard wrapping. -* Added a blank line above the demo's main header line. -* Changed the demo to read single keys without a prompt or Enter. -* Fixed the Exit key highlight in the demo menu. -* Documented the evaluation of the proposed monadic Printer and Section interface. - -### 0.3.1 -- 2026-10-17 -* Removed the extra solid bar from the demo header, which covered part of the second line. -* Made the demo footer shortcuts functional with an interactive screen loop. -* Documented the decision to defer the Text and Seq migrations. - -### 0.3.0 -- 2026-10-17 -* Revival release: removed Example and internal modules from the public Vis module. -* Added public Vis.Number and Vis.Sample modules. -* Added the vis-demo executable and the vis-test suite. -* Made paragraph wrapping, list layout and group layout total for empty and narrow inputs. -* Fixed a division by zero in group overflow handling. -* Preserved section line counts across chained replace calls. -* Added documentation in docs/ and rewrote the README as an index. -* Enabled -Wall and cleaned compiler warnings. - -## Early Versions - -### 0.2.2.7 -- 2020-05-29 -* Implementation of Sample instance for VisNumber. -* Refining of Sample class and instances for all types. - -### 0.2.2.5 -- 2020-05-23 -* Got rid of the Result type and module. -* Reversal of Show instances to default, creation of Sample class. -* Implementation of sample functions. -* Created Printer for single Item. - -### 0.2.2.1 -- 2020-05-21 -* Implemented minimum number of lines for Sections. - -### 0.2.2.0 -- 2020-05-20 -* Finished amend functionality for VisPage and workflow. -* Made Settings update at each redraw. -* Created the new VisConfig type for internal use. -* Made VisSettings the user exposed settings type. -* Made the basic Run functions work with configs, not settings. -* Created Draw module and internal State module. - -### 0.2.1.4 -- 2020-05-19 -* Exposed the basic builders. -* Reworked type runners to deal with IO separately. -* Defined VisState type and top level functionality. -* Created VisResult type to associate printed line numbers with Sections. -* Separated VisPage internal functionality. - -### 0.2.0.9 -- 2020-05-09 -* Gave up on verbose mode. -* Moved VisPrinter type to internal module. -* Reworked Show instances for most types and VisPrinter. -* Reworked Show instance for VisSection and moved type to internal module. - -### 0.2.0.5 -- 2020-05-08 -* Made VisItem remove non-printable characters. -* Creation of Internal folder to separate internal modules. -* Creation of Show Instances to implement the Verbose mode. -* Implementation of Settings type and functions. -* Improved Section type to calculate the total printed lines. - -### 0.2.0.0 -- 2020-05-07 -* Major change so VisPrinter returns the number of lines printed. -* Major refactoring and module splits. - -### 0.1.1.0 -- 2020-04-25 -* VisPrinter functionality implemented. - -### 0.1.0.5 -- 2020-04-19 -* Restarted project. -* Implemented basic content types and styles. - -### 0.1.0.0 -- 2018-06-12 -* First version, very basic functionality, not commited to VCS. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,17 +10,30 @@ > **Formerly known as Vis.** Ansiform is a terminal formatting library, unrelated to the JavaScript `vis-network` graph visualization library or to the Hackage package [`Vis`](https://hackage.haskell.org/package/Vis) (3D graphics). See [Naming](https://github.com/Tralen/ansiform/blob/master/docs/naming.md). -Current version: **1.0.0**. +Current version: **1.0.0.1**. Repository: . +## Stack + +Haskell with Cabal. Stack is not used. + +## Versioning + +PVP, single-sourced from the `ansiform.cabal` file. + +- Patch: fixes and minor refinements. +- Minor: new user-facing features or screens. +- Major 2: data model breaking changes. +- Major 1: major release milestones. + ## Features - ANSI colors, bold, italic and underline, with automatic suppression on non-TTY output, `NO_COLOR` and `TERM=dumb`. - Immediate single-key input: a key press changes the screen without Enter, and shortcut loops ignore arrow-key escape sequences. - Line input for prompts and numeric selection, including prompts printed inside a page and typed in place. - Forms that draw a page and read several prompts, with the cursor arithmetic handled by the library. -- Editable form fields that open with an initial value, with arrows, Home, End, Delete and Esc cancellation. +- Editable form fields that open with every initial value already visible, with arrows, Home, End, Delete and Esc cancellation. - A pure line-editing core in `Ansiform.Line` that can be tested without a terminal. - A step-by-step tutorial and a runnable bookmarks example. - Unicode-aware display widths for alignment, wrapping, lists and tables. @@ -92,6 +105,8 @@ `ansiform-tutorial` is the small bookmarks program from the [tutorial](https://github.com/Tralen/ansiform/blob/master/docs/tutorial.md). +Formatting, linting and secret scanning are described in the [quality](https://github.com/Tralen/ansiform/blob/master/docs/quality.md) guide. + ## Documentation - [Tutorial](https://github.com/Tralen/ansiform/blob/master/docs/tutorial.md): build a small bookmarks program step by step. @@ -105,6 +120,8 @@ - [Pages and drawing](https://github.com/Tralen/ansiform/blob/master/docs/pages.md): pages, state and the drawing lifecycle. - [Input](https://github.com/Tralen/ansiform/blob/master/docs/input.md): immediate and line input, forms, and the standard interaction loop. - [Platforms](https://github.com/Tralen/ansiform/blob/master/docs/platforms.md): Linux, macOS and Windows behaviour, terminal requirements and known limitations. +- [Quality](https://github.com/Tralen/ansiform/blob/master/docs/quality.md): formatting, linting and secret scanning. +- [Ports](https://github.com/Tralen/ansiform/blob/master/docs/ports.md): an assessment of porting the library to Rust. - [Render](https://github.com/Tralen/ansiform/blob/master/docs/render.md): rendering pages, sections and printers to a `Handle` or a `String`. - [Settings](https://github.com/Tralen/ansiform/blob/master/docs/settings.md): width, spacing and group overflow configuration. - [Numbers](https://github.com/Tralen/ansiform/blob/master/docs/number.md): non-negative arithmetic, saturation and checked subtraction. @@ -120,7 +137,7 @@ 3. **Errors as data.** Table builders return `Maybe Table`. There are no exceptions in the public API. 4. **Immediate interaction.** The standard interaction is a single key press, handled by `Ansiform.Input` without Enter. 5. **Reusable components.** Screens are assembled from shared builders such as `header`, `footer` and `rule`, keeping behavior and theming consistent. -6. **Explicit versioning.** The package follows the PVP and every release is recorded in [ChangeLog.md](https://hackage.haskell.org/package/ansiform/changelog). +6. **Explicit versioning.** The package follows the PVP and every release is recorded in [CHANGELOG.md](https://hackage.haskell.org/package/ansiform/changelog). ## License diff --git a/ansiform.cabal b/ansiform.cabal --- a/ansiform.cabal +++ b/ansiform.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ansiform -version: 1.0.0 +version: 1.0.0.1 synopsis: Display formatting for command line interfaces. description: Basic format DSL for building an ANSI command line interface with colors, alignment, tables, paragraphs and more. @@ -13,7 +13,7 @@ homepage: https://github.com/Tralen/ansiform bug-reports: https://github.com/Tralen/ansiform/issues tested-with: GHC == 9.2.8 || == 9.14.1 -extra-doc-files: ChangeLog.md +extra-doc-files: CHANGELOG.md README.md docs/architecture.md docs/content.md @@ -23,7 +23,9 @@ docs/number.md docs/pages.md docs/platforms.md + docs/ports.md docs/printers.md + docs/quality.md docs/releasing.md docs/render.md docs/roadmap.md @@ -33,6 +35,7 @@ docs/table-format.md docs/theme.md docs/tutorial.md +extra-source-files: fourmolu.yaml common shared default-language: Haskell2010 diff --git a/docs/architecture.md b/docs/architecture.md --- a/docs/architecture.md +++ b/docs/architecture.md @@ -73,7 +73,7 @@ ## Versioning -The package follows the Haskell Package Versioning Policy (PVP). The version lives in `ansiform.cabal` and is recorded in `ChangeLog.md`. +The package follows the Haskell Package Versioning Policy (PVP). The version lives in `ansiform.cabal` and is recorded in `CHANGELOG.md`. - Patch: fixes and small refinements. - Minor: new user-facing features or screens. diff --git a/docs/naming.md b/docs/naming.md --- a/docs/naming.md +++ b/docs/naming.md @@ -4,7 +4,7 @@ ## Origin -`ansiform` is a portmanteau of ANSI and form/format. It is not an established term. A Hackage check found no package named `ansiform` or `Ansiform`, so the name appears to be available. +`ansiform` is a portmanteau of ANSI and form/format. It is not an established term. ## Why the project was renamed @@ -23,7 +23,7 @@ - The demo executable is now `ansiform-demo` and the test suite is `ansiform-test`. - The license changed from GPL-3.0-only to MIT. -There is no compatibility module named `Vis`. The rename is a breaking change for users of the old package. +There is no compatibility module named `Vis`. The rename is a breaking change for users of the old package, introduced in the 0.4.0 release. ## Public types diff --git a/docs/platforms.md b/docs/platforms.md --- a/docs/platforms.md +++ b/docs/platforms.md @@ -63,7 +63,7 @@ ## Testing -The CI matrix builds, tests, checks, documents and packages the library on Linux, macOS and Windows. Linux and Windows use GHC 9.2.8 and GHC 9.14.1; macOS uses `macos-15` and only GHC 9.14.1, because GHC 9.2.8 has no aarch64-darwin bindist and the SDK on `macos-latest` is too new for the GHC 9.14.1 linker. CI still cannot press keys, so the interaction statements above come from the GHC, `ansi-terminal`, `terminal-size` and base documentation and the manual checklist below. +The CI matrix builds, tests, checks, documents and packages the library on Linux, macOS and Windows. Linux and Windows use GHC 9.2.8 and GHC 9.14.1. macOS uses `macos-15-intel` with GHC 9.2.8 and `macos-15` with GHC 9.14.1: the arm64 runner has no GHC 9.2.8 bindist, and the SDK on `macos-latest` is too new for the GHC 9.14.1 linker. A quality job checks formatting and linting, and a separate workflow scans for secrets. CI still cannot press keys, so the interaction statements above come from the GHC, `ansi-terminal`, `terminal-size` and base documentation and the manual checklist below. A manual checklist for each platform: diff --git a/docs/ports.md b/docs/ports.md new file mode 100644 --- /dev/null +++ b/docs/ports.md @@ -0,0 +1,55 @@ +# Ports + +This page records assessments of porting Ansiform to other languages. It is a design note, not a commitment. + +## Possible Rust Port + +A Rust port is a moderate engineering effort, not a large rewrite. The library has about 3,600 lines of Haskell in `src`, including Haddock comments, and a large part of that is builders and documentation. The main risk is not the language, it is behavioral parity for spacing, Unicode widths, borders, wrapping and cursor arithmetic. + +### What helps + +- **Pure core:** `Content`, `Style`, `Table`, `Section`, `Page` and the builders map naturally to structs, enums and pure functions. The Haskell immutability model translates well to consuming builders that return a new value, with `#[must_use]` where it fits. +- **Algebraic data types:** `Color`, `Format`, `Align`, `Ellipsis`, `Borders`, `FormError` and `LineKey` become Rust enums. +- **Errors as data:** `Maybe` and `Either` become `Option` and `Result`; `tableBlocks` returning `Nothing` becomes `Result`. +- **`Number` and `Offset`:** newtypes over `u32` or `usize` with saturating arithmetic. +- **Rendering to a string:** this is simpler than the current Haskell code. Write into a `Vec` or `String` through `impl Write`; no temporary file is needed. +- **Interactive input:** `crossterm` provides `KeyEvent` with arrows, Home, End, Delete and modifiers, plus raw mode, cursor control and terminal size. This removes almost all of `Ansiform.Internal.Input`: the escape parser, the Escape timeout, `hSetEcho`, `hSetBuffering` and the CSI/SS3 handling. +- **Unicode width:** the `unicode-width` crate covers most of `charWidth`. Emoji, combining marks and zero-width characters still need parity tests. +- **Tests:** golden tests become easier because output can be captured in memory. Property tests with `proptest` help with wrapping and width calculations. + +### What complicates + +- **Ownership and lifetimes:** choosing between `&str`, `String`, `Cow<'static, str>` and `Arc` in builders and styles. Haskell has no such friction; the Rust API must be designed to avoid unnecessary clones. +- **Representing `Printer`:** in Haskell, `Printer` stores a function. In Rust there are two options: an enum that represents the printing AST plus an interpreter, or `Box io::Result>`. An enum tends to be better for tests and composition; a trait is better for extensibility. This choice defines the API. +- **The `State` lifecycle:** pages, line counts, `amend`, `replace` and `redraw` are simple, but must be reproduced carefully. A `struct State` with `Vec` and functions that accept `&mut impl Write` works well. +- **Raw mode and restoration:** Haskell uses `bracket`. In Rust, use a guard with `Drop` to disable raw mode, show the cursor and restore the screen even after an error or panic. This is a sensitive area because a failure can leave the terminal unusable. +- **Unicode:** cursor indices. Haskell uses code-point indices; Rust must choose between `Vec`, byte indices with `char_indices`, or a string plus graphemes. The behaviour must be documented, as in the current library, where grapheme movement is a non-goal. +- **Windows:** `crossterm` covers the basics, but MinTTY, MSYS, Cygwin and legacy consoles still need real-terminal tests. The cross-platform CI work done for Ansiform would be repeated. +- **Exact parity:** column alignment, group padding, `BordersNone`, ellipsis truncation and styled wrapping have many edge cases. The Haskell golden tests can be reused as fixtures for Rust. + +### Effort by area + +| Area | Complexity | Notes | +| --- | --- | --- | +| `Style`, `Theme`, `Number` | Low | Enums, newtypes and constructors. | +| `Width` | Low to medium | `unicode-width` helps; emoji parity needs tests. | +| `Content` (Item, Block, Group, Table, Article) | Medium | Many builders and validations. | +| `Printer`, `Section`, `Page`, `Settings` | Medium | Layout, wrapping, offsets and line counts. | +| Tables and borders | Medium | Many details around alignment, maximum widths and padding. | +| `Draw`, `Terminal`, `Render` | Low to medium | `crossterm` and an in-memory `Write` simplify both. | +| `Input`, forms and line editor | Medium | `crossterm` removes the escape parser; the pure editor logic is small. | +| Tests, documentation, examples and CI | Medium | Golden tests and three operating systems. | + +### Recommendation + +A native Rust version is worthwhile. The design is small and well separated, and Rust fits the pure core well. A phased plan: + +1. Freeze the behavioral specification with golden outputs from Haskell. +2. Port `Style`, `Width`, `Number` and `Content`, with rendering to `String`. +3. Port printers, sections, pages and tables. +4. Add the terminal driver with `crossterm`. +5. Port the line editor and the forms. +6. Repeat the examples, documentation, CI and parity tests. +7. Publish as a crate, with an API reviewed for ownership and `Result`. + +Avoid building the port on `ratatui`. `ratatui` is immediate and buffer-based, while Ansiform is declarative, with pages, line counts and `amend`/`replace`. Using `crossterm` directly preserves the model and avoids friction. diff --git a/docs/quality.md b/docs/quality.md new file mode 100644 --- /dev/null +++ b/docs/quality.md @@ -0,0 +1,56 @@ +# Quality + +Ansiform checks formatting, linting and secrets in CI. The same commands run locally. + +## Formatting + +Fourmolu 0.21.0.0 formats the library, the examples and the tests. The configuration lives in `fourmolu.yaml`: four spaces, leading commas, leading import and export lists, automatic Haddock style and no Unicode syntax. + +```sh +fourmolu --mode check $(find src examples test -name '*.hs') +fourmolu --mode inplace $(find src examples test -name '*.hs') +``` + +The first command reports files that would change and fails when any file is not formatted. The second rewrites them. + +## Linting + +HLint 3.10 checks the same three directories: + +```sh +hlint src examples test +``` + +The command exits with a failure when it finds a hint. The project keeps the hint count at zero, so new code must be clean or the rule must be discussed before adding an ignore. + +## Secrets + +Gitleaks scans the working tree and the full history. The CI workflow uses `gitleaks/gitleaks-action` v3 and the local binary is v8.30.1: + +```sh +gitleaks git --redact --log-opts="--all" +gitleaks dir --redact . +``` + +The `--redact` flag prevents a finding from printing the secret itself. A finding blocks the release until the secret is rotated and the history is cleaned. + +## Continuous integration + +`.github/workflows/ci.yml` has two jobs: + +- `build` runs on Ubuntu, `macos-15-intel`, `macos-15` and Windows with GHC 9.2.8 and 9.14.1, as allowed by the available bindists. +- `quality` runs Fourmolu and HLint on Ubuntu with pinned tool versions and verified checksums. + +`.github/workflows/gitleaks.yml` runs the secret scan on pushes, pull requests and manual dispatches. + +The tool versions are pinned in the workflow. Update the version, the release URL and the checksum together. + +## Local setup + +Fourmolu has release binaries for Linux and macOS, and HLint also ships a Windows binary. Both can be installed with Cabal: + +```sh +cabal install --installdir="$HOME/.local/bin" --overwrite-policy=always fourmolu-0.21.0.0 hlint-3.10 +``` + +Gitleaks is distributed as a single binary from its GitHub releases. The release workflow does not need any of these tools; it uses the Hackage and GitHub tokens described in `docs/releasing.md`. diff --git a/docs/releasing.md b/docs/releasing.md --- a/docs/releasing.md +++ b/docs/releasing.md @@ -1,29 +1,30 @@ # Releasing -This checklist covers the Hackage and GitHub release of Ansiform. Update it as the release process evolves. +This checklist covers the Hackage and GitHub release of Ansiform. Update it as the release process evolves. The README defines the versioning scheme and the single source of the version. ## Current status - Package: `ansiform`. The name is already registered on Hackage. -- Version: 0.9.0.6. +- Version: 1.0.0.1. - License: MIT. -- `cabal sdist` produces a complete source distribution with sources, docs, examples, tests, README, ChangeLog and LICENSE. +- `cabal sdist` produces a complete source distribution with sources, docs, examples, tests, README, changelog and LICENSE. - Haddock builds with 100% coverage for the public functions and types. The remaining warnings are only about module re-exports. -- CI: `.github/workflows/ci.yml` builds, tests, checks, documents and creates the source distribution on Linux, macOS and Windows, with GHC 9.2.8 and GHC 9.14.1. macOS uses `macos-15` and only GHC 9.14.1: GHC 9.2.8 has no aarch64-darwin bindist, and the SDK on `macos-latest` is too new for the GHC 9.14.1 linker. +- CI: `.github/workflows/ci.yml` builds, tests, checks, documents and creates the source distribution on Ubuntu, `macos-15-intel`, `macos-15` and Windows with GHC 9.2.8 and GHC 9.14.1. The quality job checks Fourmolu and HLint. `.github/workflows/gitleaks.yml` scans the history for secrets. - GitHub: public at ; the local remote is `git@github.com:Tralen/ansiform.git`. - `source-repository`, `homepage` and `bug-reports` are set to the GitHub URL. - The history has been rewritten and contains no personal paths. -- Tag `0.9.0.6` and its GitHub release are published at . -- Hackage: 0.9.0.6 is published at , with documentation uploaded. -- The 0.9.0.6 release fixes the lone-Escape timeout found by the Linux terminal checklist. The 0.9.0.5 release fixed the Windows render crash and the macOS CI toolchain and was the first Hackage publication since 0.7.10.4. The 0.8.0 to 0.9.0.5 changes are recorded in `ChangeLog.md`, including editable form fields, `Ansiform.Line`, `readKeyPress` and the platform documentation. +- Tag `1.0.0` and its GitHub release are published at . +- Hackage: 1.0.0 is published at , with documentation uploaded. +- The 1.0.0 release marks the library stable and draws every prefilled field when a form opens. It includes the editable form fields, `Ansiform.Line`, `readKeyPress`, the lone-Escape fix and the platform documentation from 0.8.0 through 0.9.0.6. +- 1.0.0.1 adds Fourmolu, HLint, gitleaks, the Intel macOS CI job and the manual release workflow. ## Credentials -Publishing needs two credentials. Local builds, tests, Haddock and `cabal sdist` do not use them. +Publishing needs two credentials. Local builds, tests, Haddock, formatting, linting and `cabal sdist` do not use them. ### Hackage -Export `HACKAGE_TOKEN` with your own secret manager before running the command. Use the token directly on the command line so it is not stored: +Export `HACKAGE_TOKEN` with your own secret manager before running a local command. Use the token directly on the command line so it is not stored: ```sh cabal upload --token "$HACKAGE_TOKEN" dist-newstyle/sdist/ansiform-.tar.gz @@ -35,7 +36,7 @@ cabal upload --token "$HACKAGE_TOKEN" --documentation dist-newstyle/ansiform--docs.tar.gz ``` -Do not add the token or the location of your secret manager to the repository. If a persistent configuration is ever needed, Cabal reads the global `token` key from `~/.cabal/config` or `~/.config/cabal/config`, outside the `repository` stanza. For this project, use the command-line form. +The automated release stores the token as an environment secret named `HACKAGE_TOKEN` in the GitHub environment `release`. Do not add the token or the location of your secret manager to the repository. If a persistent local configuration is ever needed, Cabal reads the global `token` key from `~/.cabal/config` or `~/.config/cabal/config`, outside the `repository` stanza. For this project, use the command-line form. New Hackage accounts must be added to the uploaders group before the first upload. Ask two confirmed uploaders to endorse the account through the link in the account email, or email `hackage-trustees@haskell.org` with the Hackage username and a link to the repository. Uploads return HTTP 403 until the account is approved. @@ -57,17 +58,52 @@ git remote set-url origin git@github.com:Tralen/ansiform.git ``` -The repository must be public for the package links and badges to work. Pushes still require a key belonging to an account with write access. `GITHUB_TOKEN` is not used automatically by `git push`; it is only for the GitHub API or `gh`. +The repository must be public for the package links and badges to work. Pushes still require a key belonging to an account with write access. `GITHUB_TOKEN` is not used automatically by `git push`; it is only for the GitHub API or `gh`. The release workflow uses the token that GitHub provides to create the release. Never print the values of the tokens or commit the location of your secrets. -## Before the first release +## Automated release +`.github/workflows/release.yml` publishes a version through `workflow_dispatch`. It has two jobs: + +- `candidate` checks out the tag, verifies that the tag and the version in `ansiform.cabal` match, builds, tests, checks, builds the Haddock tarball and the source distribution, uploads both as Hackage candidates and stores them with a `SHA256SUMS` file as a workflow artifact. +- `publish` runs only when the `publish` input is true. It verifies the checksums, publishes the exact artifacts to Hackage and creates the GitHub release with generated notes. + +Both jobs use the `release` environment. A solo maintainer does not need required reviewers; if reviewers are enabled, both the candidate and the publish job wait for approval. + +### Configuring the release environment + +1. Open **Settings > Environments** and create an environment named `release`. +2. Under **Environment secrets**, add a secret named `HACKAGE_TOKEN`. Paste the Hackage token value as the secret value; do not paste the name or `$HACKAGE_TOKEN`, and do not create an Actions variable, because variables are plaintext. +3. Under **Deployment branches and tags**, allow `master` and the release tags. The workflow is dispatched from a branch, so the selected branch must be allowed. +4. Required reviewers are optional. If enabled, both jobs wait for approval. + +The workflow reads the secret with `secrets.HACKAGE_TOKEN` and exposes it to the upload steps as the `HACKAGE_TOKEN` environment variable. The token is never printed and never enters the repository. + +1. Push the final commit and the tag. The tag uses the version without a `v` prefix: + + ```sh + git push origin master + git tag -a -m "ansiform " + git push origin + ``` + +2. Run the workflow with `publish` disabled and inspect the candidate at `https://hackage.haskell.org/package/ansiform/candidates`. Check the rendered documentation, the dependency bounds and the build report. +3. Run the workflow again with `publish` enabled. The environment approval is the explicit authorization. +4. Check the public package page, the documentation links, the GitHub release and the attached artifacts. + +The workflow is the preferred path because it builds from the tag and keeps the token outside the local machine. The manual process below remains available and produces the same artifacts. + +## Manual release + +### Before the release + 1. Configure an SSH key for GitHub and confirm write access to the repository. -2. Verify the remote: +2. Verify the remote and start from a clean tree: ```sh git remote -v + git status git push -u origin master ``` @@ -94,18 +130,27 @@ cabal sdist ``` -6. Inspect the source distribution: +6. Run the quality checks described in `docs/quality.md`: ```sh + fourmolu --mode check $(find src examples test -name '*.hs') + hlint src examples test + gitleaks git --redact --log-opts="--all" + gitleaks dir --redact . + ``` + +7. Inspect the source distribution: + + ```sh tar -tzf dist-newstyle/sdist/ansiform-.tar.gz ``` -## Uploading to Hackage +### Uploading to Hackage -`cabal upload` uploads a **package candidate** by default. A candidate is not visible as a normal package version, so it can be inspected and even deleted before publication. +`cabal upload` uploads a package candidate by default. A candidate is not visible as a normal package version, so it can be inspected and even deleted before publication. 1. Create a Hackage account and obtain an upload token. -2. Configure the token, preferably through the interactive prompt or the Cabal config file. Avoid putting the token directly in shell history. +2. Reference the token through the environment variable, as shown above. Do not paste the token value into the command or store it in the repository. 3. Build the documentation tarball: ```sh @@ -139,7 +184,7 @@ Publishing cannot be undone easily. Never run `--publish` without explicit approval after the candidate review. Use the candidate stage to catch metadata, documentation and dependency problems before publishing. -## GitHub release +### GitHub release 1. Confirm that the repository exists and is public. Recreate it only if it is missing. 2. Push the final commit and tag the release: @@ -150,13 +195,33 @@ git push origin master --tags ``` -3. Create a GitHub release from the tag, using the relevant ChangeLog section as the description. -4. The Hackage badge is already present in the README. +3. Create a GitHub release from the tag, using the relevant changelog section as the description: + ```sh + gh release create --verify-tag --title "ansiform " --notes-file + ``` + +4. Attach the source distribution, the documentation tarball and a `SHA256SUMS` file to the release. +5. The Hackage badge is already present in the README. + +### Verification + +Install the published version in a temporary project instead of installing the executables into the user's binary directory: + +```sh +mkdir /tmp/ansiform-check +cd /tmp/ansiform-check +cabal repl --build-depends=ansiform== +``` + +Compile a small expression that imports `Ansiform` and run it. This checks that the published package resolves and that the public API is usable. + ## Notes - The old package name `vis` collided with the Hackage `Vis` package (3D graphics). Do not reuse it. - The public types no longer use the `Vis` prefix, and the internal builders use the `form` prefix. - `hie.yaml` is optional editor configuration and is not tracked. Commit it only if the team decides to share it. - Commits use the GitHub noreply address; maintainer contact uses `dev@tralen.cc`. -- The CI workflow runs GHC 9.2.8 and GHC 9.14.1 with Cabal 3.18.1.0 on Ubuntu, Windows and `macos-15`. Keep the macOS pin until a newer GHC supports the `macos-latest` SDK. +- The CI workflow runs GHC 9.2.8 and GHC 9.14.1 with Cabal 3.18.1.0. `macos-15-intel` covers GHC 9.2.8 because the arm64 runner has no bindist for that version. `macos-15` covers GHC 9.14.1 because the SDK on `macos-latest` is too new for its linker. +- The workflows use Node 24 actions. Keep the pinned versions and checksums in `ci.yml` current. +- Formatting, linting and secret scanning are documented in `docs/quality.md`. diff --git a/examples/Demo.hs b/examples/Demo.hs --- a/examples/Demo.hs +++ b/examples/Demo.hs @@ -5,10 +5,10 @@ -- > cabal run ansiform-demo module Main where -import Data.Char (isSpace, toLower) -import Data.List (elemIndex) -import Data.Maybe (listToMaybe) -import Ansiform +import Ansiform +import Data.Char (isSpace, toLower) +import Data.List (elemIndex) +import Data.Maybe (listToMaybe) -------------------------------------------------------------------------------- -- Application @@ -20,54 +20,76 @@ -- The philosophers shown in the Groups screen. data Philosopher - = Socrates | Plato | Aristotle | Diogenes | Epicurus - | Cicero | Seneca | Lucretius | MarcusAurelius | Virgil - | Hobbes | Spinoza | Descartes | Locke | Hume - deriving (Eq, Show) + = Socrates + | Plato + | Aristotle + | Diogenes + | Epicurus + | Cicero + | Seneca + | Lucretius + | MarcusAurelius + | Virgil + | Hobbes + | Spinoza + | Descartes + | Locke + | Hume + deriving (Eq, Show) -- The demo is a small screen machine. -data Screen = Menu | List | Groups | GroupsPrompt | Tables | Rich | Article - | Blocks | PhilosopherPage Philosopher - deriving (Eq, Show) +data Screen + = Menu + | List + | Groups + | GroupsPrompt + | Tables + | Rich + | Article + | Blocks + | PhilosopherPage Philosopher + deriving (Eq, Show) main :: IO () main = withImmediateInput $ do - state <- start (screenPage Menu) demoSettings - loop Menu state + state <- start (screenPage Menu) demoSettings + loop Menu state loop :: Screen -> State -> IO () loop screen state = do - key <- readKeyPress - case fmap toLower key of - Nothing -> finish - Just 'l' -> open List state - Just 'g' -> open Groups state - Just 't' -> open Tables state - Just 'h' -> open Rich state - Just 'a' -> open Article state - Just 'c' -> case screen of - Groups -> choosePhilosopher state - _ -> open Blocks state - Just 'r' -> do state' <- redraw state - loop screen state' - Just 'b' -> open (backScreen screen) state - Just 'x' -> finish - Just '\n' -> loop screen state - Just ' ' -> loop screen state - Just _ -> loop screen state + key <- readKeyPress + case fmap toLower key of + Nothing -> finish + Just 'l' -> open List state + Just 'g' -> open Groups state + Just 't' -> open Tables state + Just 'h' -> open Rich state + Just 'a' -> open Article state + Just 'c' -> case screen of + Groups -> choosePhilosopher state + _ -> open Blocks state + Just 'r' -> do + state' <- redraw state + loop screen state' + Just 'b' -> open (backScreen screen) state + Just 'x' -> finish + Just '\n' -> loop screen state + Just ' ' -> loop screen state + Just _ -> loop screen state where open next st = do - st' <- draw (screenPage next) st - loop next st' + st' <- draw (screenPage next) st + loop next st' choosePhilosopher st = do - (st', input) <- readForm (screenPage GroupsPrompt) - [promptAt 2 2 promptInputColumn] st - open (chosenScreen (either (const Nothing) listToMaybe input)) st' + (st', input) <- + readForm + (screenPage GroupsPrompt) + [promptAt 2 2 promptInputColumn] + st + open (chosenScreen (either (const Nothing) listToMaybe input)) st' - chosenScreen input = case input >>= philosopherByNumber . trim of - Just p -> PhilosopherPage p - Nothing -> Groups + chosenScreen input = maybe Groups PhilosopherPage (input >>= philosopherByNumber . trim) finish = putStrLn "\nAnsiform demo finished." @@ -87,32 +109,50 @@ demoTheme = defaultTheme header :: Section -header = sectionTop 1 - [ printerSolidLineCenter 0 1 (themeBar demoTheme) - [ blockSimple "Ansiform" (themeHeader demoTheme) - , blockSimple demoVersion (themeHeader demoTheme) ] - , printerEmpty 1 - , printerLineCenter 4 - [ blockSimple "CLI UI Library" (themeSubtitle demoTheme) - , blockSimple "Gallery" (themeMuted demoTheme) - , blockSimple "Demo" (themeAccent demoTheme) ] - ] +header = + sectionTop + 1 + [ printerSolidLineCenter + 0 + 1 + (themeBar demoTheme) + [ blockSimple "Ansiform" (themeHeader demoTheme) + , blockSimple demoVersion (themeHeader demoTheme) + ] + , printerEmpty 1 + , printerLineCenter + 4 + [ blockSimple "CLI UI Library" (themeSubtitle demoTheme) + , blockSimple "Gallery" (themeMuted demoTheme) + , blockSimple "Demo" (themeAccent demoTheme) + ] + ] bottom :: Section bottom = sectionRule ruleBottom footer :: String -> [[Block]] -> Section -footer message commandLines = sectionBodyRule 1 ruleFooter - ( [ printerLeft 2 (blockSimple message (themeFooter demoTheme)) - , printerEmpty 1 - ] ++ fmap (printerLineCenter 4) commandLines ) +footer message commandLines = + sectionBodyRule + 1 + ruleFooter + ( [ printerLeft 2 (blockSimple message (themeFooter demoTheme)) + , printerEmpty 1 + ] + ++ fmap (printerLineCenter 4) commandLines + ) -- Footer with a single prompt line above the command keys. footerPrompt :: String -> [[Block]] -> Section -footerPrompt message commandLines = sectionBodyRule 1 ruleFooter - ( [ printerLeft promptOffset (blockSimple message (themeFooter demoTheme)) - , printerEmpty 1 - ] ++ fmap (printerLineCenter 4) commandLines ) +footerPrompt message commandLines = + sectionBodyRule + 1 + ruleFooter + ( [ printerLeft promptOffset (blockSimple message (themeFooter demoTheme)) + , printerEmpty 1 + ] + ++ fmap (printerLineCenter 4) commandLines + ) promptOffset :: Offset promptOffset = 2 @@ -145,39 +185,45 @@ screenBody Article = sectionBodyRule 1 ruleBody [printerArticle 2 0 article] screenBody Blocks = blocksBody screenBody (PhilosopherPage p) = - sectionBodyRule 1 ruleBody [printerArticle 2 0 (philosopherArticle p)] + sectionBodyRule 1 ruleBody [printerArticle 2 0 (philosopherArticle p)] screenBody GroupsPrompt = screenBody Groups screenFooter :: Screen -> Section screenFooter Menu = footer "Choose an option above: " menuCommands screenFooter Groups = footer "Press C to choose a philosopher by number." groupsCommands screenFooter GroupsPrompt = - footerPrompt promptMessage pageCommands + footerPrompt promptMessage pageCommands screenFooter _ = footer "Press B to go back or R to reload." pageCommands menuCommands, pageCommands, groupsCommands :: [[Block]] menuCommands = - [ [ blockMenuStyle "L" "List" (themeAccent demoTheme) - , blockMenuStyle "G" "Groups" (themeAccent demoTheme) - , blockMenuStyle "T" "Tables" (themeAccent demoTheme) - , blockMenuStyle "H" "Rich table" (themeAccent demoTheme) ] - , [ blockMenuStyle "A" "Article" (themeAccent demoTheme) - , blockMenuStyle "C" "Content builders" (themeAccent demoTheme) - , blockMenuStyle "X" "Exit" (themeDanger demoTheme) ] - ] - + [ + [ blockMenuStyle "L" "List" (themeAccent demoTheme) + , blockMenuStyle "G" "Groups" (themeAccent demoTheme) + , blockMenuStyle "T" "Tables" (themeAccent demoTheme) + , blockMenuStyle "H" "Rich table" (themeAccent demoTheme) + ] + , + [ blockMenuStyle "A" "Article" (themeAccent demoTheme) + , blockMenuStyle "C" "Content builders" (themeAccent demoTheme) + , blockMenuStyle "X" "Exit" (themeDanger demoTheme) + ] + ] pageCommands = - [ [ blockMenuStyle "B" "Back" (themeAccent demoTheme) - , blockMenuStyle "R" "Reload" (themeAccent demoTheme) - , blockMenuStyle "X" "Exit" (themeDanger demoTheme) ] - ] - + [ + [ blockMenuStyle "B" "Back" (themeAccent demoTheme) + , blockMenuStyle "R" "Reload" (themeAccent demoTheme) + , blockMenuStyle "X" "Exit" (themeDanger demoTheme) + ] + ] groupsCommands = - [ [ blockMenuStyle "C" "Choose" (themeAccent demoTheme) - , blockMenuStyle "B" "Back" (themeAccent demoTheme) - , blockMenuStyle "R" "Reload" (themeAccent demoTheme) ] - , [ blockMenuStyle "X" "Exit" (themeDanger demoTheme) ] - ] + [ + [ blockMenuStyle "C" "Choose" (themeAccent demoTheme) + , blockMenuStyle "B" "Back" (themeAccent demoTheme) + , blockMenuStyle "R" "Reload" (themeAccent demoTheme) + ] + , [blockMenuStyle "X" "Exit" (themeDanger demoTheme)] + ] -------------------------------------------------------------------------------- -- Menu and content @@ -185,52 +231,58 @@ menuBlocks :: [Block] menuBlocks = - [ blockMenuStyle "L" "List composers" (themeAccent demoTheme) - , blockMenuStyle "G" "Group philosophers" (themeAccent demoTheme) - , blockMenuStyle "T" "Tabulate composers" (themeAccent demoTheme) - , blockMenuStyle "H" "Rich flight table" (themeAccent demoTheme) - , blockMenuStyle "A" "Article about Ansiform" (themeAccent demoTheme) - , blockMenuStyle "C" "Content builders" (themeAccent demoTheme) - , blockMenuStyle "X" "Exit" (themeDanger demoTheme) - ] + [ blockMenuStyle "L" "List composers" (themeAccent demoTheme) + , blockMenuStyle "G" "Group philosophers" (themeAccent demoTheme) + , blockMenuStyle "T" "Tabulate composers" (themeAccent demoTheme) + , blockMenuStyle "H" "Rich flight table" (themeAccent demoTheme) + , blockMenuStyle "A" "Article about Ansiform" (themeAccent demoTheme) + , blockMenuStyle "C" "Content builders" (themeAccent demoTheme) + , blockMenuStyle "X" "Exit" (themeDanger demoTheme) + ] blocksBody :: Section -blocksBody = sectionBodyRule 1 ruleBody - [ printerItem (item "A single Item" (solid cyan)) - , printerEmpty 1 - , printerColumn 4 - [ blockSimple "Content builders" (themeSubtitle demoTheme) - , blockVal "Version" demoVersion cyan - , blockBars ["Left", "Center", "Right"] styleDefault (normal magenta) - , blockSlash "Input" "Output" blue - , blockCycle [ ("Cycle", bold green) - , (" with ", styleDefault) - , ("styles", bold green) ] - , blockSeq ["A", "B", "C"] (normal blue) " -> " (normal black') - , blockAssoc' ["Third", "Second", "First"] styleDefault (normal magenta) - , blockMarked 'k' "marked letter" (bold green) - ] - , printerEmpty 1 - , printerLeft 4 (blockSimple "left aligned line" (normal green)) - , printerCenter 4 (blockSimple "center aligned line" (normal yellow)) - , printerRight 4 (blockSimple "right aligned line" (normal cyan)) - ] +blocksBody = + sectionBodyRule + 1 + ruleBody + [ printerItem (item "A single Item" (solid cyan)) + , printerEmpty 1 + , printerColumn + 4 + [ blockSimple "Content builders" (themeSubtitle demoTheme) + , blockVal "Version" demoVersion cyan + , blockBars ["Left", "Center", "Right"] styleDefault (normal magenta) + , blockSlash "Input" "Output" blue + , blockCycle + [ ("Cycle", bold green) + , (" with ", styleDefault) + , ("styles", bold green) + ] + , blockSeq ["A", "B", "C"] (normal blue) " -> " (normal black') + , blockAssoc' ["Third", "Second", "First"] styleDefault (normal magenta) + , blockMarked 'k' "marked letter" (bold green) + ] + , printerEmpty 1 + , printerLeft 4 (blockSimple "left aligned line" (normal green)) + , printerCenter 4 (blockSimple "center aligned line" (normal yellow)) + , printerRight 4 (blockSimple "right aligned line" (normal cyan)) + ] composers :: [Block] composers = - [ blockEnum "00" "Tchaikovsky" blue - , blockEnum "01" "Sibelius" blue - , blockEnum "02" "Mussorgsky" blue - , blockEnum "03" "Brahms" blue - , blockEnum "04" "Chopin" blue - , blockEnum "05" "Offenbach" blue - , blockEnum "06" "Khachaturian" blue - , blockEnum "07" "Holst" blue - , blockEnum "08" "Bruckner" blue - , blockEnum "09" "Prokofiev" blue - , blockEnum "10" "Rimsky-Korsakov" blue - , blockEnum "11" "Suppe" blue - ] + [ blockEnum "00" "Tchaikovsky" blue + , blockEnum "01" "Sibelius" blue + , blockEnum "02" "Mussorgsky" blue + , blockEnum "03" "Brahms" blue + , blockEnum "04" "Chopin" blue + , blockEnum "05" "Offenbach" blue + , blockEnum "06" "Khachaturian" blue + , blockEnum "07" "Holst" blue + , blockEnum "08" "Bruckner" blue + , blockEnum "09" "Prokofiev" blue + , blockEnum "10" "Rimsky-Korsakov" blue + , blockEnum "11" "Suppe" blue + ] -------------------------------------------------------------------------------- -- Philosophers @@ -238,65 +290,69 @@ philosopherGroups :: [(String, [Philosopher])] philosopherGroups = - [ ("Greek", [Socrates, Plato, Aristotle, Diogenes, Epicurus]) - , ("Roman", [Cicero, Seneca, Lucretius, MarcusAurelius, Virgil]) - , ("Enlightenment", [Hobbes, Spinoza, Descartes, Locke, Hume]) - ] + [ ("Greek", [Socrates, Plato, Aristotle, Diogenes, Epicurus]) + , ("Roman", [Cicero, Seneca, Lucretius, MarcusAurelius, Virgil]) + , ("Enlightenment", [Hobbes, Spinoza, Descartes, Locke, Hume]) + ] philosophers :: [Philosopher] philosophers = concatMap snd philosopherGroups groups :: [Group] groups = - [ groupSimple (blockSimple title (normal yellow)) - [ philosopherBlock p | p <- ps ] - | (title, ps) <- philosopherGroups ] + [ groupSimple + (blockSimple title (normal yellow)) + [philosopherBlock p | p <- ps] + | (title, ps) <- philosopherGroups + ] philosopherBlock :: Philosopher -> Block philosopherBlock p = - blockEnum (philosopherNumber p) (philosopherName p) (philosopherColor p) + blockEnum (philosopherNumber p) (philosopherName p) (philosopherColor p) philosopherName :: Philosopher -> String philosopherName p = case p of - Socrates -> "Socrates" - Plato -> "Plato" - Aristotle -> "Aristotle" - Diogenes -> "Diogenes" - Epicurus -> "Epicurus" - Cicero -> "Cicero" - Seneca -> "Seneca" - Lucretius -> "Lucretius" - MarcusAurelius -> "Marcus Aurelius" - Virgil -> "Virgil" - Hobbes -> "Hobbes" - Spinoza -> "Spinoza" - Descartes -> "Descartes" - Locke -> "Locke" - Hume -> "Hume" + Socrates -> "Socrates" + Plato -> "Plato" + Aristotle -> "Aristotle" + Diogenes -> "Diogenes" + Epicurus -> "Epicurus" + Cicero -> "Cicero" + Seneca -> "Seneca" + Lucretius -> "Lucretius" + MarcusAurelius -> "Marcus Aurelius" + Virgil -> "Virgil" + Hobbes -> "Hobbes" + Spinoza -> "Spinoza" + Descartes -> "Descartes" + Locke -> "Locke" + Hume -> "Hume" philosopherColor :: Philosopher -> Color philosopherColor p = case p of - Cicero -> magenta - Locke -> green - _ -> black + Cicero -> magenta + Locke -> green + _ -> black philosopherNumber :: Philosopher -> String philosopherNumber p = case elemIndex p philosophers of - Just i -> pad2 (i + 1) - Nothing -> "??" + Just i -> pad2 (i + 1) + Nothing -> "??" pad2 :: Int -> String -pad2 n | n < 10 = '0' : show n - | otherwise = show n +pad2 n + | n < 10 = '0' : show n + | otherwise = show n philosopherByNumber :: String -> Maybe Philosopher philosopherByNumber s = case reads s :: [(Int, String)] of - [(n, "")] -> lookup n [ (read (philosopherNumber p) :: Int, p) | p <- philosophers ] - _ -> Nothing + [(n, "")] -> lookup n [(read (philosopherNumber p) :: Int, p) | p <- philosophers] + _ -> Nothing trim :: String -> String trim = f . f - where f = reverse . dropWhile isSpace + where + f = reverse . dropWhile isSpace -------------------------------------------------------------------------------- -- Tables @@ -307,76 +363,89 @@ richHeader :: [Block] richHeader = - [ blockSimple "Flight" (themeTableHeader demoTheme) - , blockSimple "Company" (normal yellow) - , blockAssoc ["Origin", "Destination"] (normal yellow) (normal magenta) - , blockSimple "Departure" (normal cyan) - , blockSimple "Arrival" (normal red) - ] + [ blockSimple "Flight" (themeTableHeader demoTheme) + , blockSimple "Company" (normal yellow) + , blockAssoc ["Origin", "Destination"] (normal yellow) (normal magenta) + , blockSimple "Departure" (normal cyan) + , blockSimple "Arrival" (normal red) + ] richRows :: [[Block]] richRows = - [ [ blockSimple "1929" (bold green) - , blockSimple "American Airlines" (normal green) - , blockAssoc ["PORTLAND", "CHARLOTTE"] styleDefault (normal magenta) - , blockSimple "22:20" (normal cyan) - , blockSimple "06:09" (normal red) ] - , [ blockSimple "710" (bold green) - , blockSimple "Arik Air" (normal green) - , blockAssoc ["LAGOS", "ABUJA"] styleDefault (normal magenta) - , blockSimple "06:00" (normal cyan) - , blockSimple "07:15" (normal red) ] - , [ blockSimple "309" (bold green) - , blockSimple "British Airways" (normal green) - , blockAssoc ["PARIS", "LONDON"] styleDefault (normal magenta) - , blockSimple "12:10" (normal cyan) - , blockSimple "12:30" (normal red) ] - , [ blockSimple "3002" (bold green) - , blockSimple "EgyptAir" (normal green) - , blockAssoc ["CAIRO", "DUBAI"] styleDefault (normal magenta) - , blockSimple "19:15" (normal cyan) - , blockSimple "00:35" (normal red) ] - , [ blockSimple "5139" (bold green) - , blockSimple "AerCaribe Peru" (normal green) - , blockAssoc ["BOGOTA", "LIMA"] styleDefault (normal magenta) - , blockSimple "06:00" (normal cyan) - , blockSimple "23:00" (normal red) ] - ] + [ + [ blockSimple "1929" (bold green) + , blockSimple "American Airlines" (normal green) + , blockAssoc ["PORTLAND", "CHARLOTTE"] styleDefault (normal magenta) + , blockSimple "22:20" (normal cyan) + , blockSimple "06:09" (normal red) + ] + , + [ blockSimple "710" (bold green) + , blockSimple "Arik Air" (normal green) + , blockAssoc ["LAGOS", "ABUJA"] styleDefault (normal magenta) + , blockSimple "06:00" (normal cyan) + , blockSimple "07:15" (normal red) + ] + , + [ blockSimple "309" (bold green) + , blockSimple "British Airways" (normal green) + , blockAssoc ["PARIS", "LONDON"] styleDefault (normal magenta) + , blockSimple "12:10" (normal cyan) + , blockSimple "12:30" (normal red) + ] + , + [ blockSimple "3002" (bold green) + , blockSimple "EgyptAir" (normal green) + , blockAssoc ["CAIRO", "DUBAI"] styleDefault (normal magenta) + , blockSimple "19:15" (normal cyan) + , blockSimple "00:35" (normal red) + ] + , + [ blockSimple "5139" (bold green) + , blockSimple "AerCaribe Peru" (normal green) + , blockAssoc ["BOGOTA", "LIMA"] styleDefault (normal magenta) + , blockSimple "06:00" (normal cyan) + , blockSimple "23:00" (normal red) + ] + ] simpleTable :: Maybe Table simpleTable = tableSimple simpleHeader (themeTableBody demoTheme) simpleRows -- Right aligns the numeric columns and truncates long composer names. demoTablesFormat :: TableFormat -demoTablesFormat = tableFormat - [ defaultColumnSpec { columnMaxWidth = Just 11 - , columnEllipsis = EllipsisChar '…' } - , defaultColumnSpec - , defaultColumnSpec { columnAlign = AlignRight } - , defaultColumnSpec { columnAlign = AlignRight } - , defaultColumnSpec { columnAlign = AlignRight } - ] +demoTablesFormat = + tableFormat + [ defaultColumnSpec + { columnMaxWidth = Just 11 + , columnEllipsis = EllipsisChar '…' + } + , defaultColumnSpec + , defaultColumnSpec{columnAlign = AlignRight} + , defaultColumnSpec{columnAlign = AlignRight} + , defaultColumnSpec{columnAlign = AlignRight} + ] simpleHeader :: [Block] simpleHeader = - [ blockSimple "Composer" (bold white) - , blockSimple "Country" (bold cyan) - , blockSimple "Born" (bold green) - , blockSimple "Died" (bold green) - , blockSimple "Works" (bold yellow) - ] + [ blockSimple "Composer" (bold white) + , blockSimple "Country" (bold cyan) + , blockSimple "Born" (bold green) + , blockSimple "Died" (bold green) + , blockSimple "Works" (bold yellow) + ] simpleRows :: [[String]] simpleRows = - [ ["Tchaikovsky", "Russia", "1840", "1893", "6"] - , ["Sibelius", "Finland", "1865", "1957", "7"] - , ["Mussorgsky", "Russia", "1839", "1881", "5"] - , ["Brahms", "Germany", "1833", "1897", "4"] - , ["Chopin", "Poland", "1810", "1849", "6"] - , ["Offenbach", "Germany", "1819", "1880", "5"] - , ["Holst", "England", "1874", "1934", "5"] - , ["Prokofiev", "Russia", "1891", "1953", "7"] - ] + [ ["Tchaikovsky", "Russia", "1840", "1893", "6"] + , ["Sibelius", "Finland", "1865", "1957", "7"] + , ["Mussorgsky", "Russia", "1839", "1881", "5"] + , ["Brahms", "Germany", "1833", "1897", "4"] + , ["Chopin", "Poland", "1810", "1849", "6"] + , ["Offenbach", "Germany", "1819", "1880", "5"] + , ["Holst", "England", "1874", "1934", "5"] + , ["Prokofiev", "Russia", "1891", "1953", "7"] + ] -------------------------------------------------------------------------------- -- Article @@ -387,32 +456,30 @@ paragraph1, paragraph2, paragraph3 :: Paragraph paragraph1 = - [ blockSimple "Ansiform " textBold - , blockSimple "is a formatting DSL for command line interfaces. " textRegular - , blockSimple "Builders are pure, " textItalic - , blockSimple "pages are immutable, " textUnderline - , blockSimple "and drawing is the only layer that talks to the terminal." textRegular - ] - + [ blockSimple "Ansiform " textBold + , blockSimple "is a formatting DSL for command line interfaces. " textRegular + , blockSimple "Builders are pure, " textItalic + , blockSimple "pages are immutable, " textUnderline + , blockSimple "and drawing is the only layer that talks to the terminal." textRegular + ] paragraph2 = - [ blockSimple "Layout adapts to the terminal width. " textRegular - , blockSimple "Tables reject malformed input, " (textMark yellow) - , blockSimple "and paragraphs always make progress, " (textColor cyan) - , blockSimple "even when a single word is wider than the screen." textRegular - , blockSimple " Lists flow into columns, " textItalic - , blockSimple "groups share space evenly, " textBold - , blockSimple "and tables can mix independently styled cells." textRegular - ] - + [ blockSimple "Layout adapts to the terminal width. " textRegular + , blockSimple "Tables reject malformed input, " (textMark yellow) + , blockSimple "and paragraphs always make progress, " (textColor cyan) + , blockSimple "even when a single word is wider than the screen." textRegular + , blockSimple " Lists flow into columns, " textItalic + , blockSimple "groups share space evenly, " textBold + , blockSimple "and tables can mix independently styled cells." textRegular + ] paragraph3 = - [ blockSimple "The standard interaction is immediate: " textRegular - , blockSimple "press a key and the page changes, " textBold - , blockSimple "without a prompt and without Enter. " textRegular - , blockSimple "Styles are suppressed on redirected output, " textItalic - , blockSimple "and wide characters, combining marks and emoji " textRegular - , blockSimple "keep their alignment " (textMark cyan) - , blockSimple "because layout measures terminal columns, not code points." textRegular - ] + [ blockSimple "The standard interaction is immediate: " textRegular + , blockSimple "press a key and the page changes, " textBold + , blockSimple "without a prompt and without Enter. " textRegular + , blockSimple "Styles are suppressed on redirected output, " textItalic + , blockSimple "and wide characters, combining marks and emoji " textRegular + , blockSimple "keep their alignment " (textMark cyan) + , blockSimple "because layout measures terminal columns, not code points." textRegular + ] -------------------------------------------------------------------------------- -- Philosopher articles @@ -423,85 +490,124 @@ ciceroParagraph1, ciceroParagraph2 :: Paragraph ciceroParagraph1 = - [ blockSimple "Marcus Tullius Cicero " textBold - , blockSimple "(106-43 BC) was a Roman statesman, orator and philosopher. " textRegular - , blockSimple "He was consul in 63 BC " textItalic - , blockSimple "and is known for the Catilinarian orations and for his many speeches." textRegular - ] - + [ blockSimple "Marcus Tullius Cicero " textBold + , blockSimple "(106-43 BC) was a Roman statesman, orator and philosopher. " textRegular + , blockSimple "He was consul in 63 BC " textItalic + , blockSimple "and is known for the Catilinarian orations and for his many speeches." textRegular + ] ciceroParagraph2 = - [ blockSimple "His philosophical works, " textRegular - , blockSimple "such as De Re Publica and De Officiis, " (textMark yellow) - , blockSimple "helped bring Greek philosophy into Latin. " textRegular - , blockSimple "He was killed during the proscriptions of 43 BC." (textColor cyan) - ] + [ blockSimple "His philosophical works, " textRegular + , blockSimple "such as De Re Publica and De Officiis, " (textMark yellow) + , blockSimple "helped bring Greek philosophy into Latin. " textRegular + , blockSimple "He was killed during the proscriptions of 43 BC." (textColor cyan) + ] lockeArticle :: Article lockeArticle = [lockeParagraph1, lockeParagraph2] lockeParagraph1, lockeParagraph2 :: Paragraph lockeParagraph1 = - [ blockSimple "John Locke " textBold - , blockSimple "(1632-1704) was an English philosopher and physician. " textRegular - , blockSimple "He is a central figure of empiricism " textItalic - , blockSimple "and argued that the mind begins as a blank slate." textRegular - ] - + [ blockSimple "John Locke " textBold + , blockSimple "(1632-1704) was an English philosopher and physician. " textRegular + , blockSimple "He is a central figure of empiricism " textItalic + , blockSimple "and argued that the mind begins as a blank slate." textRegular + ] lockeParagraph2 = - [ blockSimple "His Two Treatises of Government " textRegular - , blockSimple "defended natural rights and government by consent. " (textMark yellow) - , blockSimple "The Essay Concerning Human Understanding " textItalic - , blockSimple "shaped modern epistemology and liberal thought." (textColor cyan) - ] + [ blockSimple "His Two Treatises of Government " textRegular + , blockSimple "defended natural rights and government by consent. " (textMark yellow) + , blockSimple "The Essay Concerning Human Understanding " textItalic + , blockSimple "shaped modern epistemology and liberal thought." (textColor cyan) + ] philosopherArticle :: Philosopher -> Article philosopherArticle p = case p of - Socrates -> bio "Socrates " "(c. 470-399 BC) was an Athenian philosopher. " - "He examined ethical concepts through dialogue and questioning. " - "He wrote nothing and is known mainly through Plato." - Plato -> bio "Plato " "(c. 427-347 BC) was an Athenian philosopher. " - "He developed the theory of Forms and founded the Academy. " - "His dialogues include the Republic and the Symposium." - Aristotle -> bio "Aristotle " "(384-322 BC) was a Greek philosopher and student of Plato. " - "He worked on logic, ethics, politics and natural science. " - "He also tutored Alexander the Great." - Diogenes -> bio "Diogenes " "(c. 412-323 BC) was a Cynic philosopher. " - "He rejected wealth and convention and lived with extreme simplicity. " - "His anecdotes illustrate independence and moral frankness." - Epicurus -> bio "Epicurus " "(341-270 BC) was a Greek philosopher. " - "He founded a school known as the Garden and taught that pleasure is the absence of pain. " - "His atomism influenced later materialist thought." - Cicero -> ciceroArticle - Seneca -> bio "Seneca " "(c. 4 BC-AD 65) was a Roman Stoic philosopher and statesman. " - "He wrote letters and essays on ethics and advised Nero. " - "He was forced to commit suicide in AD 65." - Lucretius -> bio "Lucretius " "(c. 99-55 BC) was a Roman poet and philosopher. " - "His poem De Rerum Natura explains Epicurean atomism. " - "It is a major source for ancient materialist ideas." - MarcusAurelius -> bio "Marcus Aurelius " "(AD 121-180) was a Roman emperor and Stoic philosopher. " - "His Meditations record private reflections on duty and self-control. " - "He is often called the philosopher emperor." - Virgil -> bio "Virgil " "(70-19 BC) was a Roman poet. " - "He wrote the Eclogues, the Georgics and the Aeneid. " - "The Aeneid became a foundational text of Roman literature." - Hobbes -> bio "Thomas Hobbes " "(1588-1679) was an English philosopher. " - "He is known for Leviathan and for social contract theory. " - "He argued for a strong sovereign to prevent civil war." - Spinoza -> bio "Baruch Spinoza " "(1632-1677) was a Dutch philosopher. " - "His Ethics presents a rationalist and monist system. " - "He defended freedom of thought and religious toleration." - Descartes -> bio "René Descartes " "(1596-1650) was a French philosopher and mathematician. " - "He is known for the cogito and for mind-body dualism. " - "He helped shape modern rationalism and the scientific method." - Locke -> lockeArticle - Hume -> bio "David Hume " "(1711-1776) was a Scottish philosopher and historian. " - "He developed empiricism and an influential analysis of causation. " - "His works include A Treatise of Human Nature and An Enquiry Concerning Human Understanding." + Socrates -> + bio + "Socrates " + "(c. 470-399 BC) was an Athenian philosopher. " + "He examined ethical concepts through dialogue and questioning. " + "He wrote nothing and is known mainly through Plato." + Plato -> + bio + "Plato " + "(c. 427-347 BC) was an Athenian philosopher. " + "He developed the theory of Forms and founded the Academy. " + "His dialogues include the Republic and the Symposium." + Aristotle -> + bio + "Aristotle " + "(384-322 BC) was a Greek philosopher and student of Plato. " + "He worked on logic, ethics, politics and natural science. " + "He also tutored Alexander the Great." + Diogenes -> + bio + "Diogenes " + "(c. 412-323 BC) was a Cynic philosopher. " + "He rejected wealth and convention and lived with extreme simplicity. " + "His anecdotes illustrate independence and moral frankness." + Epicurus -> + bio + "Epicurus " + "(341-270 BC) was a Greek philosopher. " + "He founded a school known as the Garden and taught that pleasure is the absence of pain. " + "His atomism influenced later materialist thought." + Cicero -> ciceroArticle + Seneca -> + bio + "Seneca " + "(c. 4 BC-AD 65) was a Roman Stoic philosopher and statesman. " + "He wrote letters and essays on ethics and advised Nero. " + "He was forced to commit suicide in AD 65." + Lucretius -> + bio + "Lucretius " + "(c. 99-55 BC) was a Roman poet and philosopher. " + "His poem De Rerum Natura explains Epicurean atomism. " + "It is a major source for ancient materialist ideas." + MarcusAurelius -> + bio + "Marcus Aurelius " + "(AD 121-180) was a Roman emperor and Stoic philosopher. " + "His Meditations record private reflections on duty and self-control. " + "He is often called the philosopher emperor." + Virgil -> + bio + "Virgil " + "(70-19 BC) was a Roman poet. " + "He wrote the Eclogues, the Georgics and the Aeneid. " + "The Aeneid became a foundational text of Roman literature." + Hobbes -> + bio + "Thomas Hobbes " + "(1588-1679) was an English philosopher. " + "He is known for Leviathan and for social contract theory. " + "He argued for a strong sovereign to prevent civil war." + Spinoza -> + bio + "Baruch Spinoza " + "(1632-1677) was a Dutch philosopher. " + "His Ethics presents a rationalist and monist system. " + "He defended freedom of thought and religious toleration." + Descartes -> + bio + "René Descartes " + "(1596-1650) was a French philosopher and mathematician. " + "He is known for the cogito and for mind-body dualism. " + "He helped shape modern rationalism and the scientific method." + Locke -> lockeArticle + Hume -> + bio + "David Hume " + "(1711-1776) was a Scottish philosopher and historian. " + "He developed empiricism and an influential analysis of causation. " + "His works include A Treatise of Human Nature and An Enquiry Concerning Human Understanding." bio :: String -> String -> String -> String -> Article bio name dates role detail = - [ [ blockSimple name textBold - , blockSimple dates textRegular - , blockSimple role textItalic - , blockSimple detail textRegular - ] ] + [ + [ blockSimple name textBold + , blockSimple dates textRegular + , blockSimple role textItalic + , blockSimple detail textRegular + ] + ] diff --git a/examples/Tutorial.hs b/examples/Tutorial.hs --- a/examples/Tutorial.hs +++ b/examples/Tutorial.hs @@ -5,64 +5,67 @@ -- > cabal run ansiform-tutorial module Main where -import Data.Char (toLower) -import Ansiform +import Ansiform +import Data.Char (toLower) -------------------------------------------------------------------------------- -- Data model -------------------------------------------------------------------------------- data Bookmark = Bookmark - { bookmarkTitle :: String - , bookmarkURL :: String - } deriving (Eq, Show) + { bookmarkTitle :: String + , bookmarkURL :: String + } + deriving (Eq, Show) data Model = Model - { modelBookmarks :: [Bookmark] - , modelSelected :: Int - } deriving (Eq, Show) + { modelBookmarks :: [Bookmark] + , modelSelected :: Int + } + deriving (Eq, Show) emptyModel :: Model emptyModel = Model [] 0 addBookmark :: String -> String -> Model -> Model addBookmark title url (Model bookmarks _) = - Model (bookmarks ++ [Bookmark title url]) (length bookmarks) + Model (bookmarks ++ [Bookmark title url]) (length bookmarks) deleteSelected :: Model -> Model deleteSelected (Model [] _) = emptyModel deleteSelected (Model bookmarks selected) = - Model kept (clampSelection (length kept) selected) + Model kept (clampSelection (length kept) selected) where kept = take selected bookmarks ++ drop (selected + 1) bookmarks updateSelected :: String -> String -> Model -> Model updateSelected title url model@(Model bookmarks selected) = case bookmarks of - [] -> model - _ -> let index = clampSelection (length bookmarks) selected - in Model (replaceAt index (Bookmark title url) bookmarks) index + [] -> model + _ -> + let index = clampSelection (length bookmarks) selected + in Model (replaceAt index (Bookmark title url) bookmarks) index replaceAt :: Int -> a -> [a] -> [a] replaceAt index value values = - take index values ++ [value] ++ drop (index + 1) values + take index values ++ [value] ++ drop (index + 1) values selectedBookmark :: Model -> Maybe Bookmark selectedBookmark (Model bookmarks selected) = - bookmarkAt (clampSelection (length bookmarks) selected) bookmarks + bookmarkAt (clampSelection (length bookmarks) selected) bookmarks bookmarkAt :: Int -> [Bookmark] -> Maybe Bookmark bookmarkAt index bookmarks = case drop index bookmarks of - [] -> Nothing - (bookmark:_) -> Just bookmark + [] -> Nothing + (bookmark : _) -> Just bookmark moveSelection :: Int -> Model -> Model moveSelection delta (Model bookmarks selected) = - Model bookmarks (clampSelection (length bookmarks) (selected + delta)) + Model bookmarks (clampSelection (length bookmarks) (selected + delta)) clampSelection :: Int -> Int -> Int clampSelection count index - | count <= 0 = 0 - | otherwise = max 0 (min (count - 1) index) + | count <= 0 = 0 + | otherwise = max 0 (min (count - 1) index) -------------------------------------------------------------------------------- -- Shared components @@ -78,13 +81,19 @@ bookmarkSettings = settings [minSpace 2] header :: Section -header = sectionTop 1 - [ printerSolidLineCenter 0 1 (themeBar theme) - [ blockSimple "Pocket Bookmarks" (themeHeader theme) ] - , printerEmpty 1 - , printerLineCenter 4 - [ blockSimple "A small Ansiform tutorial" (themeSubtitle theme) ] - ] +header = + sectionTop + 1 + [ printerSolidLineCenter + 0 + 1 + (themeBar theme) + [blockSimple "Pocket Bookmarks" (themeHeader theme)] + , printerEmpty 1 + , printerLineCenter + 4 + [blockSimple "A small Ansiform tutorial" (themeSubtitle theme)] + ] bottom :: Section bottom = sectionRule (ruleDefault (themeRule theme)) @@ -101,36 +110,49 @@ listPage model = page [header, listBody model, listFooter, bottom] listBody :: Model -> Section -listBody model = sectionBodyRule 1 ruleBody - [ if null (modelBookmarks model) - then printerLeft 2 - (blockSimple "No bookmarks yet. Press A to add one." (themeMuted theme)) - else printerColumn 2 - [ bookmarkBlock (index == modelSelected model) index bookmark - | (index, bookmark) <- zip [0 ..] (modelBookmarks model) ] - ] +listBody model = + sectionBodyRule + 1 + ruleBody + [ if null (modelBookmarks model) + then + printerLeft + 2 + (blockSimple "No bookmarks yet. Press A to add one." (themeMuted theme)) + else + printerColumn + 2 + [ bookmarkBlock (index == modelSelected model) index bookmark + | (index, bookmark) <- zip [0 ..] (modelBookmarks model) + ] + ] bookmarkBlock :: Bool -> Int -> Bookmark -> Block bookmarkBlock isSelected index (Bookmark title url) = - blockCycle - [ (if isSelected then "> " else " ", style) - , (show (index + 1) ++ ". ", style) - , (title, style) - , (" " ++ url, urlStyle) - ] + blockCycle + [ (if isSelected then "> " else " ", style) + , (show (index + 1) ++ ". ", style) + , (title, style) + , (" " ++ url, urlStyle) + ] where style = if isSelected then themeAccent theme else styleDefault listFooter :: Section -listFooter = sectionBodyRule 1 ruleFooter - [ printerLineCenter 4 - [ blockMenuStyle "A" "Add" (themeAccent theme) - , blockMenuStyle "J" "Down" (themeAccent theme) - , blockMenuStyle "K" "Up" (themeAccent theme) - , blockMenuStyle "D" "Delete" (themeDanger theme) - , blockMenuStyle "E" "Edit" (themeAccent theme) - , blockMenuStyle "X" "Exit" (themeDanger theme) ] - ] +listFooter = + sectionBodyRule + 1 + ruleFooter + [ printerLineCenter + 4 + [ blockMenuStyle "A" "Add" (themeAccent theme) + , blockMenuStyle "J" "Down" (themeAccent theme) + , blockMenuStyle "K" "Up" (themeAccent theme) + , blockMenuStyle "D" "Delete" (themeDanger theme) + , blockMenuStyle "E" "Edit" (themeAccent theme) + , blockMenuStyle "X" "Exit" (themeDanger theme) + ] + ] -------------------------------------------------------------------------------- -- Form page @@ -140,36 +162,45 @@ formPage instruction = page [header, formBody, formFooter instruction, bottom] formBody :: Section -formBody = sectionBodyRule 1 ruleBody - [ printerLeft 2 (blockSimple "Title: " styleDefault) - , printerEmpty 1 - , printerLeft 2 (blockSimple "URL: " styleDefault) - ] +formBody = + sectionBodyRule + 1 + ruleBody + [ printerLeft 2 (blockSimple "Title: " styleDefault) + , printerEmpty 1 + , printerLeft 2 (blockSimple "URL: " styleDefault) + ] formFooter :: String -> Section -formFooter instruction = sectionBodyRule 1 ruleFooter - [ printerLineCenter 4 - [ blockSimple instruction (themeFooter theme) ] - ] +formFooter instruction = + sectionBodyRule + 1 + ruleFooter + [ printerLineCenter + 4 + [blockSimple instruction (themeFooter theme)] + ] addInstruction, editInstruction :: String addInstruction = - "Type a value and press Enter for each field; empty fields cancel." + "Type a value and press Enter for each field; empty fields cancel." editInstruction = - "Edit the values and press Enter; Esc cancels." + "Edit the values and press Enter; Esc cancels." fieldColumn :: String -> Offset fieldColumn label = formNumber (2 + textWidth label) formPrompts :: [Prompt] formPrompts = - [ promptAt 1 2 (fieldColumn "Title: ") - , promptAt 1 4 (fieldColumn "URL: ") ] + [ promptAt 1 2 (fieldColumn "Title: ") + , promptAt 1 4 (fieldColumn "URL: ") + ] editPrompts :: Bookmark -> [Prompt] editPrompts (Bookmark title url) = - [ promptWithInitial 1 2 (fieldColumn "Title: ") title - , promptWithInitial 1 4 (fieldColumn "URL: ") url ] + [ promptWithInitial 1 2 (fieldColumn "Title: ") title + , promptWithInitial 1 4 (fieldColumn "URL: ") url + ] -------------------------------------------------------------------------------- -- Application @@ -177,43 +208,46 @@ main :: IO () main = withImmediateInput $ do - state <- start (listPage emptyModel) bookmarkSettings - loop emptyModel state + state <- start (listPage emptyModel) bookmarkSettings + loop emptyModel state loop :: Model -> State -> IO () loop model state = do - key <- readKeyPress - case fmap toLower key of - Nothing -> pure () - Just 'a' -> addFlow model state - Just 'j' -> open (moveSelection 1 model) state - Just 'k' -> open (moveSelection (-1) model) state - Just 'd' -> open (deleteSelected model) state - Just 'e' -> editFlow model state - Just 'x' -> pure () - _ -> loop model state + key <- readKeyPress + case fmap toLower key of + Nothing -> pure () + Just 'a' -> addFlow model state + Just 'j' -> open (moveSelection 1 model) state + Just 'k' -> open (moveSelection (-1) model) state + Just 'd' -> open (deleteSelected model) state + Just 'e' -> editFlow model state + Just 'x' -> pure () + _ -> loop model state where open next st = draw (listPage next) st >>= loop next addFlow :: Model -> State -> IO () addFlow model state = do - (state', result) <- readForm (formPage addInstruction) formPrompts state - let next = case result of - Right [title, url] - | not (null title) && not (null url) -> - addBookmark title url model - _ -> model - draw (listPage next) state' >>= loop next + (state', result) <- readForm (formPage addInstruction) formPrompts state + let next = case result of + Right [title, url] + | not (null title) && not (null url) -> + addBookmark title url model + _ -> model + draw (listPage next) state' >>= loop next editFlow :: Model -> State -> IO () editFlow model state = case selectedBookmark model of - Nothing -> draw (listPage model) state >>= loop model - Just bookmark -> do - (state', result) <- readForm (formPage editInstruction) - (editPrompts bookmark) state - let next = case result of - Right [title, url] - | not (null title) && not (null url) -> - updateSelected title url model - _ -> model - draw (listPage next) state' >>= loop next + Nothing -> draw (listPage model) state >>= loop model + Just bookmark -> do + (state', result) <- + readForm + (formPage editInstruction) + (editPrompts bookmark) + state + let next = case result of + Right [title, url] + | not (null title) && not (null url) -> + updateSelected title url model + _ -> model + draw (listPage next) state' >>= loop next diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,6 @@ +indentation: 4 +comma-style: leading +import-export-style: leading +haddock-style: auto +unicode: never +respectful: true diff --git a/src/Ansiform.hs b/src/Ansiform.hs --- a/src/Ansiform.hs +++ b/src/Ansiform.hs @@ -13,22 +13,21 @@ module Ansiform (module All) where -------------------------------------------------------------------------------- -import Ansiform.Content as All -import Ansiform.Draw as All -import Ansiform.Input as All -import Ansiform.Line as All -import Ansiform.Number as All -import Ansiform.Page as All -import Ansiform.Printer as All -import Ansiform.Render as All -import Ansiform.Sample as All -import Ansiform.Section as All -import Ansiform.Settings as All -import Ansiform.Style as All -import Ansiform.Table as All -import Ansiform.Theme as All -import Ansiform.Width as All - +import Ansiform.Content as All +import Ansiform.Draw as All +import Ansiform.Input as All +import Ansiform.Line as All +import Ansiform.Number as All +import Ansiform.Page as All +import Ansiform.Printer as All +import Ansiform.Render as All +import Ansiform.Sample as All +import Ansiform.Section as All +import Ansiform.Settings as All +import Ansiform.Style as All +import Ansiform.Table as All +import Ansiform.Theme as All +import Ansiform.Width as All -- TODO: -- Migration to Text. diff --git a/src/Ansiform/Content.hs b/src/Ansiform/Content.hs --- a/src/Ansiform/Content.hs +++ b/src/Ansiform/Content.hs @@ -1,15 +1,21 @@ -- | Pure builders for items, blocks, groups, tables, paragraphs and rules. -module Ansiform.Content ( module Ansiform.Content - , Internal.Item, Internal.Block, Internal.Rule - , Internal.Group, Internal.Table - , Internal.Paragraph, Internal.Article - , Internal.blockEmpty, Internal.blockSimple ) where +module Ansiform.Content + ( module Ansiform.Content + , Internal.Item + , Internal.Block + , Internal.Rule + , Internal.Group + , Internal.Table + , Internal.Paragraph + , Internal.Article + , Internal.blockEmpty + , Internal.blockSimple + ) where +import Ansiform.Internal.Content as Internal +import Ansiform.Style -------------------------------------------------------------------------------- -import Data.List -import Ansiform.Internal.Content as Internal -import Ansiform.Style - +import Data.List -- Basic builders -------------------------------------------------------------------------------- @@ -31,40 +37,51 @@ -- | Builds a block with a repeated separator between elements. blockSeq :: [String] -> Style -> String -> Style -> Block -blockSeq ss v sep va = formBlock $ intersperse sep' $ fmap (\s -> formItem s v) ss - where sep' = formItem sep va - +blockSeq ss v sep va = formBlock $ intersperse sep' $ fmap (`formItem` v) ss + where + sep' = formItem sep va + -- | Builds a block where the first occurrence of a character uses a different style. blockMark :: Char -> String -> Style -> Style -> Block blockMark e t ve vt = blockCycle testFirst - where splitted = span (/= e) t - rest = snd splitted - begin = fst splitted - build = [(take 1 rest, ve), (drop 1 rest, vt)] - testFirst | null begin = build - | otherwise = (begin, vt) : build - + where + splitted = span (/= e) t + rest = snd splitted + begin = fst splitted + build = [(take 1 rest, ve), (drop 1 rest, vt)] + testFirst + | null begin = build + | otherwise = (begin, vt) : build -- Derivative Block Builders -------------------------------------------------------------------------------- -- | Builds an index followed by text, used in groups and lists. blockEnum :: String -> String -> Color -> Block -blockEnum i t c = blockCycle [(i, normal c) - ,(" ", styleDefault) - ,(t, normal colorDefault)] +blockEnum i t c = + blockCycle + [ (i, normal c) + , (" ", styleDefault) + , (t, normal colorDefault) + ] -- | Builds a block of the form @left / right@. blockSlash :: String -> String -> Color -> Block -blockSlash t1 t2 c = blockCycle [(t1, normal c) - ,(" / ", normal black') - ,(t2, normal c)] +blockSlash t1 t2 c = + blockCycle + [ (t1, normal c) + , (" / ", normal black') + , (t2, normal c) + ] -- | Builds a menu entry of the form @index: text@ with a custom key style. blockMenuStyle :: String -> String -> Style -> Block -blockMenuStyle i t vs = blockCycle [(i, vs) - ,(": ", normal black') - ,(t, normal colorDefault)] +blockMenuStyle i t vs = + blockCycle + [ (i, vs) + , (": ", normal black') + , (t, normal colorDefault) + ] -- | Builds a menu entry of the form @index: text@ with a colored key. blockMenu :: String -> String -> Color -> Block @@ -72,28 +89,29 @@ -- | Builds a block of the form @name -> value@. blockVal :: String -> String -> Color -> Block -blockVal t v c = blockCycle [(t, styleDefault) - ,(" -> ", normal black') - ,(v, normal c)] +blockVal t v c = + blockCycle + [ (t, styleDefault) + , (" -> ", normal black') + , (v, normal c) + ] -- | Builds a chain of elements separated by @->@. blockAssoc :: [String] -> Style -> Style -> Block -blockAssoc ss v va = blockSeq ss v " -> " va +blockAssoc ss v = blockSeq ss v " -> " -- | Builds a chain of elements separated by @<-@. blockAssoc' :: [String] -> Style -> Style -> Block -blockAssoc' ss v va = blockSeq ss v " <- " va +blockAssoc' ss v = blockSeq ss v " <- " -- | Builds a chain of elements separated by @|@. blockBars :: [String] -> Style -> Style -> Block -blockBars ss v va = blockSeq ss v " | " va - +blockBars ss v = blockSeq ss v " | " -- | Builds a block where one letter uses a different style. blockMarked :: Char -> String -> Style -> Block blockMarked e t ve = blockMark e t ve styleDefault - -- Group Builders -------------------------------------------------------------------------------- @@ -101,7 +119,6 @@ groupSimple :: Block -> [Block] -> Group groupSimple = formGroup - -- Table Builders -------------------------------------------------------------------------------- @@ -117,7 +134,6 @@ tableGroups :: [Group] -> Maybe Table tableGroups = formTableGroups - -- Rule Builders -------------------------------------------------------------------------------- @@ -127,8 +143,8 @@ -- | Builds a rule that uses a dot. ruleDefault :: Style -> Rule -ruleDefault v = formRule '.' v +ruleDefault = formRule '.' -- | Builds a solid rule made of spaces with a background color. ruleSolid :: Color -> Rule -ruleSolid c = formRule ' ' (solid c) +ruleSolid c = formRule ' ' (solid c) diff --git a/src/Ansiform/Draw.hs b/src/Ansiform/Draw.hs --- a/src/Ansiform/Draw.hs +++ b/src/Ansiform/Draw.hs @@ -1,45 +1,53 @@ -- | Drawing functions and the page state lifecycle. -module Ansiform.Draw ( start, draw, redraw - , amend, amend' - , replace, replace' - , startOn, drawOn, redrawOn - , amendOn, amendOn' - , replaceOn, replaceOn' - , State - ) where +module Ansiform.Draw + ( start + , draw + , redraw + , amend + , amend' + , replace + , replace' + , startOn + , drawOn + , redrawOn + , amendOn + , amendOn' + , replaceOn + , replaceOn' + , State + ) where +import Ansiform.Internal.Number +import Ansiform.Internal.Page +import Ansiform.Internal.Section +import Ansiform.Internal.Settings +import Ansiform.Internal.State +import Ansiform.Internal.Terminal +import Ansiform.Page -------------------------------------------------------------------------------- -import System.IO (Handle, stdout) -import Ansiform.Internal.Number -import Ansiform.Internal.Page -import Ansiform.Internal.Section -import Ansiform.Internal.Settings -import Ansiform.Internal.State -import Ansiform.Internal.Terminal -import Ansiform.Page - +import System.IO (Handle, stdout) -- Drawing Functions -------------------------------------------------------------------------------- -- | Prints the first page and generates the initial state on stdout. -start :: Page -> Settings -> IO State +start :: Page -> Settings -> IO State start = startOn stdout -- | Prints the first page to a given handle. startOn :: Handle -> Page -> Settings -> IO State startOn h p s = drawOn h p $ formState s p [] - -- | Draws a new page on stdout, erasing the current printed page. draw :: Page -> State -> IO State draw = drawOn stdout -- | Draws a new page to a given handle. drawOn :: Handle -> Page -> State -> IO State -drawOn h p st = clr h 0 >> unStateSettingsOn h st >>= \cfg -> - runPageIOOn h (return cfg) p - >>= \ns -> return $ updateState st p ns +drawOn h p st = + clr h 0 >> unStateSettingsOn h st >>= \cfg -> + runPageIOOn h (return cfg) p + >>= \ns -> return $ updateState st p ns -- | Redraws the last printed page on stdout. redraw :: State -> IO State @@ -49,14 +57,13 @@ redrawOn :: Handle -> State -> IO State redrawOn h st = drawOn h (unStatePage st) st - -- | Amends a page on stdout, erasing the current page. amend :: Section -> Number -> State -> IO State amend = amendOn stdout -- | Amends a page on a given handle. amendOn :: Handle -> Section -> Number -> State -> IO State -amendOn h s n st = amendOn' h [s] n st +amendOn h s = amendOn' h [s] -- | Amends several sections on stdout. amend' :: [Section] -> Number -> State -> IO State @@ -66,14 +73,13 @@ amendOn' :: Handle -> [Section] -> Number -> State -> IO State amendOn' h ss n st = drawOn h (amendPage' (unStatePage st) ss n) st - -- | Replaces a single section on stdout, preserving what is above. replace :: Section -> Number -> State -> IO State replace = replaceOn stdout -- | Replaces a single section on a given handle. replaceOn :: Handle -> Section -> Number -> State -> IO State -replaceOn h s n st = replaceOn' h [s] n st +replaceOn h s = replaceOn' h [s] -- | Replaces a list of sections on stdout, preserving what is above. replace' :: [Section] -> Number -> State -> IO State @@ -81,15 +87,16 @@ -- | Replaces a list of sections on a given handle. replaceOn' :: Handle -> [Section] -> Number -> State -> IO State -replaceOn' h ss n st = clr h preserve - >> unStateSettingsOn h st - >>= \cfg -> runPageIOOn h (return cfg) remainder - >>= \ns -> return $ updateState st newPage (take n' oldResults ++ ns) - where n' = unn n - sections = unPage $ unStatePage st - oldResults = unStateResults st - preserve = sum $ take n' oldResults - remainder = page $ ss ++ drop (n'+length ss) sections - newPage = amendPage' (unStatePage st) ss n - - +replaceOn' h ss n st = + clr h preserve + >> unStateSettingsOn h st + >>= \cfg -> + runPageIOOn h (return cfg) remainder + >>= \ns -> return $ updateState st newPage (take n' oldResults ++ ns) + where + n' = unn n + sections = unPage $ unStatePage st + oldResults = unStateResults st + preserve = sum $ take n' oldResults + remainder = page $ ss ++ drop (n' + length ss) sections + newPage = amendPage' (unStatePage st) ss n diff --git a/src/Ansiform/Input.hs b/src/Ansiform/Input.hs --- a/src/Ansiform/Input.hs +++ b/src/Ansiform/Input.hs @@ -1,11 +1,23 @@ -- | Immediate single-key input and line input for interactive interfaces. -module Ansiform.Input ( withImmediateInput, readKey, readKeyPress - , withLineInput, readLine - , readLineAt, readLineAtOn - , Prompt, promptAt, promptWithInitial - , promptSection, promptRow, promptColumn, promptInitial - , FormError (..), readForm, readFormOn - ) where +module Ansiform.Input + ( withImmediateInput + , readKey + , readKeyPress + , withLineInput + , readLine + , readLineAt + , readLineAtOn + , Prompt + , promptAt + , promptWithInitial + , promptSection + , promptRow + , promptColumn + , promptInitial + , FormError (..) + , readForm + , readFormOn + ) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Input +import Ansiform.Internal.Input diff --git a/src/Ansiform/Internal.hs b/src/Ansiform/Internal.hs --- a/src/Ansiform/Internal.hs +++ b/src/Ansiform/Internal.hs @@ -1,20 +1,20 @@ module Ansiform.Internal (module All) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Content as All -import Ansiform.Internal.Input as All -import Ansiform.Internal.Line as All -import Ansiform.Internal.Number as All -import Ansiform.Internal.Output as All -import Ansiform.Internal.Page as All -import Ansiform.Internal.Printer as All -import Ansiform.Internal.Sample as All -import Ansiform.Internal.Section as All -import Ansiform.Internal.State as All -import Ansiform.Internal.Settings as All -import Ansiform.Internal.Style as All -import Ansiform.Internal.Table as All -import Ansiform.Internal.Terminal as All -import Ansiform.Internal.Theme as All -import Ansiform.Internal.Utils as All -import Ansiform.Internal.Width as All +import Ansiform.Internal.Content as All +import Ansiform.Internal.Input as All +import Ansiform.Internal.Line as All +import Ansiform.Internal.Number as All +import Ansiform.Internal.Output as All +import Ansiform.Internal.Page as All +import Ansiform.Internal.Printer as All +import Ansiform.Internal.Sample as All +import Ansiform.Internal.Section as All +import Ansiform.Internal.Settings as All +import Ansiform.Internal.State as All +import Ansiform.Internal.Style as All +import Ansiform.Internal.Table as All +import Ansiform.Internal.Terminal as All +import Ansiform.Internal.Theme as All +import Ansiform.Internal.Utils as All +import Ansiform.Internal.Width as All diff --git a/src/Ansiform/Internal/Content.hs b/src/Ansiform/Internal/Content.hs --- a/src/Ansiform/Internal/Content.hs +++ b/src/Ansiform/Internal/Content.hs @@ -1,37 +1,36 @@ module Ansiform.Internal.Content where +import Ansiform.Internal.Number +import Ansiform.Internal.Sample +import Ansiform.Internal.Settings +import Ansiform.Internal.Style +import Ansiform.Internal.Utils +import Ansiform.Internal.Width -------------------------------------------------------------------------------- -import Data.Char -import Data.List -import Data.List.Split -import Data.Maybe -import Ansiform.Internal.Number -import Ansiform.Internal.Sample -import Ansiform.Internal.Settings -import Ansiform.Internal.Style -import Ansiform.Internal.Utils -import Ansiform.Internal.Width - - - +import Data.Bifunctor (bimap) +import Data.Char +import Data.List +import Data.List.Split +import Data.Maybe -- Content Types -------------------------------------------------------------------------------- + -- | A piece of text with a single style. Non-printable characters are removed. -newtype Item = Item (String,Style) - deriving (Eq, Show) +newtype Item = Item (String, Style) + deriving (Eq, Show) -- | A list of items printed without breaks. It contains no empty items. newtype Block = Block [Item] - deriving (Eq, Show) + deriving (Eq, Show) -- | A header block followed by body blocks. newtype Group = Group [Block] - deriving (Eq, Show) + deriving (Eq, Show) -- | A list of groups with the same number of blocks. newtype Table = Table [Group] - deriving (Eq, Show) + deriving (Eq, Show) -- | A list of blocks wrapped as one paragraph. type Paragraph = [Block] @@ -43,17 +42,16 @@ -------------------------------------------------------------------------------- instance Sample Item where - sampleShow _ (Item (s,v)) = "Item " ++ show s ++ " " ++ sampleShow 0 v + sampleShow _ (Item (s, v)) = "Item " ++ show s ++ " " ++ sampleShow 0 v instance Sample Block where - sampleShow n (Block is) = sampleFormat "Block" n is + sampleShow n (Block is) = sampleFormat "Block" n is instance Sample Group where - sampleShow n (Group bs) = sampleFormat "Group" n bs + sampleShow n (Group bs) = sampleFormat "Group" n bs instance Sample Table where - sampleShow n (Table gs) = sampleFormat "Table" n gs - + sampleShow n (Table gs) = sampleFormat "Table" n gs -- Wrappers -------------------------------------------------------------------------------- @@ -72,7 +70,7 @@ -- Group builder, taking group header and contents separately. formGroup :: Block -> [Block] -> Group -formGroup h b = Group (h:b) +formGroup h b = Group (h : b) -- Allows to build a Group without a separate header. formGroup' :: [Block] -> Group @@ -85,16 +83,16 @@ -- Unrwappers -------------------------------------------------------------------------------- unItem :: Item -> (String, Style) -unItem (Item (s,v)) = (s,v) +unItem (Item (s, v)) = (s, v) unItemText :: Item -> String -unItemText (Item (t,_)) = t +unItemText (Item (t, _)) = t unItemStyle :: Item -> Style -unItemStyle (Item (_,v)) = v +unItemStyle (Item (_, v)) = v unBlock :: Block -> [Item] -unBlock (Block xs) = xs +unBlock (Block xs) = xs unItemList :: [Item] -> [(String, Style)] unItemList = fmap unItem @@ -109,8 +107,7 @@ unTable (Table gs) = gs unMaybeTable :: Maybe Table -> [Group] -unMaybeTable mt = maybe[groupEmpty] unTable mt - +unMaybeTable = maybe [groupEmpty] unTable -- Basic Builders -------------------------------------------------------------------------------- @@ -120,6 +117,7 @@ itemEmpty = formItem "" defaultStyle -- Trivial Block. + -- | An empty block. blockEmpty :: Block blockEmpty = formBlock [] @@ -132,7 +130,6 @@ groupEmpty :: Group groupEmpty = formGroup' [blockEmpty] - -- Utilities -------------------------------------------------------------------------------- @@ -144,24 +141,20 @@ -- Enforces the Block invariant, when used to build them. itemsEmptyFilter :: [Item] -> [Item] itemsEmptyFilter = filter (not . isItemNull) - + -- Checks if a Block is empty. isBlockNull :: Block -> Bool -isBlockNull vb - | null items = True - | otherwise = and $ fmap isItemNull items - where - items = unBlock vb +isBlockNull = all isItemNull . unBlock -- Checks if a Item is empty. isItemNull :: Item -> Bool isItemNull = null . unItemText - -- Calculates the maximum length of the text in a list of Blocks. blockTextMax :: [Block] -> Int -blockTextMax bs = maximum' 0 - $ (return . blockTextWidth . formBlock) =<< unBlockList bs +blockTextMax bs = + maximum' 0 $ + blockTextWidth . formBlock <$> unBlockList bs -- Calculates the length of a Block text, summing each Item. blockTextWidth :: Block -> Int @@ -190,31 +183,30 @@ -- Swaps the background of a Item. itemSwapBG :: Item -> Item itemSwapBG i = itemChangeStyle i $ swapBackground $ unItemStyle i - + -- Changes the visual style of a Item. itemChangeStyle :: Item -> Style -> Item -itemChangeStyle i s = formItem (unItemText i) s +itemChangeStyle i = formItem (unItemText i) -- Applies the Item prettifier to a whole block. blockPrettify :: Block -> Block blockPrettify vb = formBlock $ concatMap itemPrettify $ unBlock vb - -- Improves the styling of a Item so as to not style punctuation or spaces. itemPrettify :: Item -> [Item] itemPrettify vi - | isSpecial vs = [ formItem (fst splitHead) defaultStyle - , formItem (reverse (snd splitMiddle)) vs - , formItem (reverse (fst splitMiddle)) defaultStyle - ] - | otherwise = [vi] - where - vs = unItemStyle vi - vt = unItemText vi - isBlank c = isPunctuation c || isSpace c - splitHead = span isBlank vt - splitMiddle = span isBlank $ reverse $ snd splitHead - + | isSpecial vs = + [ formItem (fst splitHead) defaultStyle + , formItem (reverse (snd splitMiddle)) vs + , formItem (reverse (fst splitMiddle)) defaultStyle + ] + | otherwise = [vi] + where + vs = unItemStyle vi + vt = unItemText vi + isBlank c = isPunctuation c || isSpace c + splitHead = span isBlank vt + splitMiddle = span isBlank $ reverse $ snd splitHead -- Text Formatting -------------------------------------------------------------------------------- @@ -223,107 +215,103 @@ -- The first line can be indented using the padding given. -- The function always makes progress, even when a single word is wider -- than the available space, so narrow terminals cannot cause a loop. -blockPublish :: Int -> Int -> [Block] -> [Block] +blockPublish :: Int -> Int -> [Block] -> [Block] blockPublish w p vbs - | w <= 0 = vbs - | otherwise = fmap (formBlock . reverse) $ publish firstLine p items - where - firstLine = if p > 0 then [formItem (replicate p ' ') defaultStyle] else [] - items = concatMap unBlock vbs - - publish :: [Item] -> Int -> [Item] -> [[Item]] - publish line _ [] = [line] - publish line cw (item:rest) - | itemWidth <= remaining = publish (item:line) (cw + itemWidth) rest - | otherwise = case itemSplit remaining item of - (fit, remainder) - | not (isItemNull fit) -> - publish (fit:line) (cw + itemTextWidth fit) next - | null line -> - publish (item:line) (cw + itemWidth) rest - | cw == p && p > 0 -> - publish (item:line) (cw + itemWidth) rest - | otherwise -> - line : publish [] 0 (item:rest) - where - next = if isItemNull remainder then rest else remainder:rest - where - remaining = w - cw - itemWidth = itemTextWidth item + | w <= 0 = vbs + | otherwise = formBlock . reverse <$> publish firstLine p items + where + firstLine = [formItem (replicate p ' ') defaultStyle | p > 0] + items = concatMap unBlock vbs + publish :: [Item] -> Int -> [Item] -> [[Item]] + publish line _ [] = [line] + publish line cw (item : rest) + | itemWidth <= remaining = publish (item : line) (cw + itemWidth) rest + | otherwise = case itemSplit remaining item of + (fit, remainder) + | not (isItemNull fit) -> + publish (fit : line) (cw + itemTextWidth fit) next + | null line -> + publish (item : line) (cw + itemWidth) rest + | cw == p && p > 0 -> + publish (item : line) (cw + itemWidth) rest + | otherwise -> + line : publish [] 0 (item : rest) + where + next = if isItemNull remainder then rest else remainder : rest + where + remaining = w - cw + itemWidth = itemTextWidth item -- Splits a Block into two, splitting on a desired text length. blockSplit :: Int -> Block -> (Block, Block) -blockSplit w vb = ( formBlock (fst processItems) - , formBlock (snd processItems) ) +blockSplit w vb = bimap formBlock formBlock processItems + where + items = unBlock vb + processItems = go [] 0 items where - items = unBlock vb - processItems = go [] 0 items - where - go cvis cw rvis - | curWidth <= w && not (null rvis) = go (vi:cvis) curWidth (drop 1 rvis) - | otherwise = (reverse (curItem:cvis), remItems:rvis) - where - vi = fromMaybe itemEmpty $ headMaybe rvis - curWidth = itemWidth + cw - itemWidth = itemTextWidth vi - curItem = fst splitItem - remItems = snd splitItem - splitItem = itemSplit (w - cw) vi - + go cvis cw rvis + | curWidth <= w && not (null rvis) = go (vi : cvis) curWidth (drop 1 rvis) + | otherwise = (reverse (curItem : cvis), remItems : rvis) + where + vi = fromMaybe itemEmpty $ headMaybe rvis + curWidth = itemWidth + cw + itemWidth = itemTextWidth vi + curItem = fst splitItem + remItems = snd splitItem + splitItem = itemSplit (w - cw) vi -- Splits a Item into two, splitting on a desired text length, but keeping words atomic. itemSplit :: Int -> Item -> (Item, Item) -itemSplit w vi = ( formItem (fst processText) vs - , formItem (snd processText) vs ) - where - vs = unItemStyle vi - splitWords = split (keepDelimsR (whenElt isSpace)) $ unItemText vi - processText = breakLength [] 0 splitWords - where - breakLength cwds cw wds - | totalLength <= w && not (null wds) = - breakLength (wd:cwds) totalLength (drop 1 wds) - | otherwise = (concatRev cwds, concat wds) - where - wd = fromMaybe "" $ headMaybe wds - wdLength = textWidth wd - totalLength = wdLength + cw - +itemSplit w vi = + ( formItem (fst processText) vs + , formItem (snd processText) vs + ) + where + vs = unItemStyle vi + splitWords = split (keepDelimsR (whenElt isSpace)) $ unItemText vi + processText = breakLength [] 0 splitWords + where + breakLength cwds cw wds + | totalLength <= w && not (null wds) = + breakLength (wd : cwds) totalLength (drop 1 wds) + | otherwise = (concatRev cwds, concat wds) + where + wd = fromMaybe "" $ headMaybe wds + wdLength = textWidth wd + totalLength = wdLength + cw -- Group and Table Formatters -------------------------------------------------------------------------------- -- A table is simply a list of Groups of the same length. - -- Reduces the length of groups in a list of Groups so that they don't exceed -- the average length too much, based on the excess configuration constant. groupAverage :: Config -> [Group] -> [Group] groupAverage s gs = foldr groupProcess [] gs - where - gof = unGroupOverflow s - groupProcess g a - | grpLength > tgtLength = fmap formGroup' headerBlocks ++ a - | otherwise = g : a - where grpLength = length blocks - headerBlocks = take 1 splitBlocks ++ fmap (blockEmpty :) (drop 1 splitBlocks) - splitBlocks = splitPlaces (tgtLength + 1 : repeat tgtLength) blocks - blocks = unGroup g - tgtLength - | overflowRatio == 0 = avgLength - | otherwise = avgLength + div avgLength overflowRatio - overflowRatio = groupOverflowRatio gof - avgLength = average $ fmap (length . unGroup) gs - + where + gof = unGroupOverflow s + groupProcess g a + | grpLength > tgtLength = fmap formGroup' headerBlocks ++ a + | otherwise = g : a + where + grpLength = length blocks + headerBlocks = take 1 splitBlocks ++ fmap (blockEmpty :) (drop 1 splitBlocks) + splitBlocks = splitPlaces (tgtLength + 1 : repeat tgtLength) blocks + blocks = unGroup g + tgtLength + | overflowRatio == 0 = avgLength + | otherwise = avgLength + div avgLength overflowRatio + overflowRatio = groupOverflowRatio gof + avgLength = average $ fmap (length . unGroup) gs -- Builds a table where each element has its own style and composition. -- Each element is a Block so it can use composite styles. -- The header and body must follow the table invariant or the build will fail. formTableBlocks :: [Block] -> [[Block]] -> Maybe Table formTableBlocks h rs = formTable fullTable (isTableBalanced h rs) - where - fullTable = zip h (transpose rs) >>= \(h', r) -> return $ formGroup h' r - + where + fullTable = zip h (transpose rs) >>= \(h', r) -> return $ formGroup h' r -- Builds a table where every column has a single Style, given in the header. -- An additional Style is used to style the header itself. @@ -331,58 +319,52 @@ -- The header and body must follow the table invariant or the build will fail. formTableSimple :: [Block] -> Style -> [[String]] -> Maybe Table formTableSimple h v sss = formTable fullTable (isTableBalanced h sss) - where - headerList = unBlockList h - header = headerList >>= \b -> return $ blockSimple (concatMap (fst . unItem) b) v - bodyVis = fmap (maybe defaultStyle (snd . unItem) . headMaybe) headerList - body = transpose $ - fmap (\ss -> fmap (uncurry blockSimple)(zip ss bodyVis)) sss - fullTable = fmap (uncurry formGroup) (zip header body) - + where + headerList = unBlockList h + header = headerList >>= \b -> return $ blockSimple (concatMap (fst . unItem) b) v + bodyVis = fmap (maybe defaultStyle (snd . unItem) . headMaybe) headerList + body = + transpose $ + fmap (\ss -> fmap (uncurry blockSimple) (zip ss bodyVis)) sss + fullTable = fmap (uncurry formGroup) (zip header body) -- Builds a table that is already properly built, with a Group for each column, -- just lacking the invariant check. formTableGroups :: [Group] -> Maybe Table formTableGroups vgs = formTable vgs vgsLengthMatch - where - headLength = maybe 0 (length . unGroup) $ headMaybe vgs - vgsLengthMatch = and $ fmap ((==) headLength . length . unGroup) (drop 1 vgs) - + where + headLength = maybe 0 (length . unGroup) $ headMaybe vgs + vgsLengthMatch = all ((== headLength) . length . unGroup) (drop 1 vgs) --- Enforces the invariant that the header and each row +-- Enforces the invariant that the header and each row -- must have the same length. isTableBalanced :: [Block] -> [[a]] -> Bool -isTableBalanced h rs = and $ fmap (\r -> headLength == length r) rs - where headLength = length (unBlockList h) - +isTableBalanced h = all (\r -> headLength == length r) + where + headLength = length (unBlockList h) -- Rules && Solid -------------------------------------------------------------------------------- + -- | A character and a style used to draw a horizontal rule. newtype Rule = Rule (Char, Style) - deriving (Eq, Show) + deriving (Eq, Show) instance Sample Rule where - sampleShow _ (Rule (c,v)) = "Rule " ++ show c ++ " " ++ sampleShow 0 v + sampleShow _ (Rule (c, v)) = "Rule " ++ show c ++ " " ++ sampleShow 0 v unRuleChar :: Rule -> Char -unRuleChar (Rule (c,_)) = c +unRuleChar (Rule (c, _)) = c unRuleStyle :: Rule -> Style -unRuleStyle (Rule (_,s)) = s +unRuleStyle (Rule (_, s)) = s formRule :: Char -> Style -> Rule formRule c v - | isPrint c = Rule (c,v) - | otherwise = Rule ('.',v) - + | isPrint c = Rule (c, v) + | otherwise = Rule ('.', v) -- Creates a Item for rules and solid spaces from a Rule. -- Must be called direct from printing, as it calculates the width on the fly. formRuleItem :: Rule -> Number -> Item formRuleItem r n = formItem (replicate (unn n) (unRuleChar r)) (unRuleStyle r) - - - - - diff --git a/src/Ansiform/Internal/Input.hs b/src/Ansiform/Internal/Input.hs --- a/src/Ansiform/Internal/Input.hs +++ b/src/Ansiform/Internal/Input.hs @@ -1,30 +1,58 @@ -- | Immediate single-key input and line input for interactive interfaces. -module Ansiform.Internal.Input (withImmediateInput, readKey, readKeyPress, - withLineInput, readLine, - readLineAt, readLineAtOn, - Prompt, promptAt, promptWithInitial, - promptSection, promptRow, promptColumn, promptInitial, - FormError(..), readForm, readFormOn) where +module Ansiform.Internal.Input + ( withImmediateInput + , readKey + , readKeyPress + , withLineInput + , readLine + , readLineAt + , readLineAtOn + , Prompt + , promptAt + , promptWithInitial + , promptSection + , promptRow + , promptColumn + , promptInitial + , FormError (..) + , readForm + , readFormOn + ) where +import Ansiform.Draw (drawOn) +import Ansiform.Internal.Line +import Ansiform.Internal.Number +import Ansiform.Internal.Page +import Ansiform.Internal.State +import Ansiform.Internal.Terminal (termWOn) +import Ansiform.Internal.Utils -------------------------------------------------------------------------------- -import Control.Exception (bracket_, tryJust) -import Control.Monad (when) -import Data.Char (isPrint) -import Data.Maybe (isJust) -import System.Console.ANSI (hClearFromCursorToLineEnd, hCursorDown, - hCursorUp, hSetCursorColumn) -import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, - hGetEcho, hIsTerminalDevice, hPutStr, hSetBuffering, - hSetEcho, hWaitForInput, isEOF, stdin, stdout) -import System.IO.Error (isEOFError) -import Ansiform.Draw (drawOn) -import Ansiform.Internal.Line -import Ansiform.Internal.Number -import Ansiform.Internal.Page -import Ansiform.Internal.State -import Ansiform.Internal.Terminal (termWOn) -import Ansiform.Internal.Utils - +import Control.Exception (bracket_, tryJust) +import Control.Monad (when) +import Data.Char (isPrint) +import Data.Maybe (isJust) +import System.Console.ANSI + ( hClearFromCursorToLineEnd + , hCursorDown + , hCursorUp + , hSetCursorColumn + ) +import System.IO + ( BufferMode (..) + , Handle + , hFlush + , hGetBuffering + , hGetEcho + , hIsTerminalDevice + , hPutStr + , hSetBuffering + , hSetEcho + , hWaitForInput + , isEOF + , stdin + , stdout + ) +import System.IO.Error (isEOFError) -- Terminal Input -------------------------------------------------------------------------------- @@ -38,11 +66,11 @@ oldBuffering <- hGetBuffering stdin oldEcho <- if interactive then hGetEcho stdin else return True let setup = when interactive $ do - hSetBuffering stdin NoBuffering - hSetEcho stdin False + hSetBuffering stdin NoBuffering + hSetEcho stdin False restore = when interactive $ do - hSetBuffering stdin oldBuffering - hSetEcho stdin oldEcho + hSetBuffering stdin oldBuffering + hSetEcho stdin oldEcho bracket_ setup restore action -- | Reads one key without waiting for Enter. @@ -128,11 +156,11 @@ oldBuffering <- hGetBuffering stdin oldEcho <- if interactive then hGetEcho stdin else return True let setup = when interactive $ do - hSetBuffering stdin LineBuffering - hSetEcho stdin True + hSetBuffering stdin LineBuffering + hSetEcho stdin True restore = when interactive $ do - hSetBuffering stdin oldBuffering - hSetEcho stdin oldEcho + hSetBuffering stdin oldBuffering + hSetEcho stdin oldEcho bracket_ setup restore action -- | Reads one line, including the newline consumed by 'getLine'. @@ -161,21 +189,21 @@ moveCursorBy h (negate (unn up)) column withLineInput readLine - -- Page Forms -------------------------------------------------------------------------------- -- | A line prompt placed in a section of a page. data Prompt = Prompt { promptSection :: Number - -- ^ Zero-based section index. + -- ^ Zero-based section index. , promptRow :: Number - -- ^ Zero-based row inside the section. + -- ^ Zero-based row inside the section. , promptColumn :: Offset - -- ^ Absolute column where typing starts. + -- ^ Absolute column where typing starts. , promptInitial :: Maybe String - -- ^ Optional initial value read by the line editor. - } deriving (Eq, Show) + -- ^ Optional initial value read by the line editor. + } + deriving (Eq, Show) -- | Builds a prompt from a zero-based section index, a zero-based row inside -- that section and an absolute column. A prompt row is easier to keep @@ -226,13 +254,14 @@ interactive <- hIsTerminalDevice stdin let useEditor = interactive && any (isJust . promptInitial) prompts fields = zip lines' prompts - readFields = if useEditor - then do - width <- termWOn h - lastLine <- drawInitialFields h width total fields - moveCursorBy h (total - lastLine) 0 - readEditorFields h total fields - else withLineInput (readPlainFields h total fields) + readFields = + if useEditor + then do + width <- termWOn h + lastLine <- drawInitialFields h width total fields + moveCursorBy h (total - lastLine) 0 + readEditorFields h total fields + else withLineInput (readPlainFields h total fields) values <- readFields return (st', values) @@ -241,29 +270,32 @@ -- initial value is left as the page drew it. Returns the last line drawn. drawInitialFields :: Handle -> Int -> Int -> [(Int, Prompt)] -> IO Int drawInitialFields _ _ current [] = return current -drawInitialFields h width current ((line, prompt):rest) = +drawInitialFields h width current ((line, prompt) : rest) = case promptInitial prompt of Nothing -> drawInitialFields h width current rest Just initial -> do moveCursorBy h (line - current) (promptColumn prompt) - redrawLine h width (promptColumn prompt) - (LineState initial (length initial)) + redrawLine + h + width + (promptColumn prompt) + (LineState initial (length initial)) drawInitialFields h width line rest -- Reads prompts through the terminal line discipline. readPlainFields :: Handle -> Int -> [(Int, Prompt)] -> IO (Either FormError [String]) readPlainFields _ _ [] = return (Right []) -readPlainFields h current ((line,prompt):rest) = do +readPlainFields h current ((line, prompt) : rest) = do moveCursorBy h (line - current) (promptColumn prompt) value <- readLine case value of Nothing -> return (Left FormInputEnded) - Just v -> fmap (fmap (v:)) (readPlainFields h (line + 1) rest) + Just v -> fmap (fmap (v :)) (readPlainFields h (line + 1) rest) -- Reads prompts in order, choosing the line editor or the line discipline. readEditorFields :: Handle -> Int -> [(Int, Prompt)] -> IO (Either FormError [String]) readEditorFields _ _ [] = return (Right []) -readEditorFields h current ((line,prompt):rest) = do +readEditorFields h current ((line, prompt) : rest) = do moveCursorBy h (line - current) (promptColumn prompt) value <- case promptInitial prompt of Nothing -> fmap (maybe (Left FormInputEnded) Right) (withLineInput readLine) @@ -271,7 +303,7 @@ withImmediateInput (readLineEditor h (promptColumn prompt) initial) case value of Left err -> return (Left err) - Right v -> fmap (fmap (v:)) (readEditorFields h (line + 1) rest) + Right v -> fmap (fmap (v :)) (readEditorFields h (line + 1) rest) -- Converts a section and row to an absolute page line. promptLine :: [Int] -> Prompt -> Either Prompt Int @@ -293,7 +325,6 @@ when (delta < 0) $ hCursorUp h (negate delta) hSetCursorColumn h (unn column) hFlush h - -- Line Editor -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Internal/Line.hs b/src/Ansiform/Internal/Line.hs --- a/src/Ansiform/Internal/Line.hs +++ b/src/Ansiform/Internal/Line.hs @@ -1,11 +1,14 @@ -- | Pure single-line editing state, keys and width-aware windowing. -module Ansiform.Internal.Line (LineState (..), LineKey (..), applyLineKey, - visibleLine) where +module Ansiform.Internal.Line + ( LineState (..) + , LineKey (..) + , applyLineKey + , visibleLine + ) where +import Ansiform.Internal.Width (charWidth, textWidth) -------------------------------------------------------------------------------- -import Data.Char (isPrint) -import Ansiform.Internal.Width (charWidth, textWidth) - +import Data.Char (isPrint) -- Line State -------------------------------------------------------------------------------- @@ -14,30 +17,30 @@ -- The cursor is a zero-based code-point index. data LineState = LineState { lineText :: String - -- ^ Current contents of the buffer. + -- ^ Current contents of the buffer. , lineCursor :: Int - -- ^ Cursor position as a code-point index into 'lineText'. - } deriving (Eq, Show) + -- ^ Cursor position as a code-point index into 'lineText'. + } + deriving (Eq, Show) -- | Editing keys understood by the line editor. data LineKey - = LineInsert Char - -- ^ Insert a printable character at the cursor. - | LineBackspace - -- ^ Delete the character before the cursor. - | LineDelete - -- ^ Delete the character at the cursor. - | LineMoveLeft - -- ^ Move the cursor one code point to the left. - | LineMoveRight - -- ^ Move the cursor one code point to the right. - | LineMoveHome - -- ^ Move the cursor to the start of the buffer. - | LineMoveEnd - -- ^ Move the cursor to the end of the buffer. + = -- | Insert a printable character at the cursor. + LineInsert Char + | -- | Delete the character before the cursor. + LineBackspace + | -- | Delete the character at the cursor. + LineDelete + | -- | Move the cursor one code point to the left. + LineMoveLeft + | -- | Move the cursor one code point to the right. + LineMoveRight + | -- | Move the cursor to the start of the buffer. + LineMoveHome + | -- | Move the cursor to the end of the buffer. + LineMoveEnd deriving (Eq, Show) - -- Pure Editing -------------------------------------------------------------------------------- @@ -49,13 +52,13 @@ LineInsert c | isPrint c -> let (before, after) = splitAt position text - in LineState (before ++ (c : after)) (position + 1) + in LineState (before ++ (c : after)) (position + 1) | otherwise -> LineState text position LineBackspace | position <= 0 -> LineState text position | otherwise -> let (before, after) = splitAt position text - in LineState (init before ++ after) (position - 1) + in LineState (init before ++ after) (position - 1) LineDelete | position >= length text -> LineState text position | otherwise -> @@ -91,7 +94,7 @@ where go index remaining _ | remaining <= usable = index - go index remaining (c:cs) = + go index remaining (c : cs) = go (index + 1) (remaining - charWidth c) cs go index _ [] = index @@ -100,6 +103,6 @@ takeWindow usable = go 0 where go _ [] = [] - go used (c:cs) + go used (c : cs) | used + charWidth c > usable = [] | otherwise = c : go (used + charWidth c) cs diff --git a/src/Ansiform/Internal/Number.hs b/src/Ansiform/Internal/Number.hs --- a/src/Ansiform/Internal/Number.hs +++ b/src/Ansiform/Internal/Number.hs @@ -1,9 +1,7 @@ module Ansiform.Internal.Number where -------------------------------------------------------------------------------- -import Ansiform.Internal.Sample - - +import Ansiform.Internal.Sample -- | A non-negative number used for sizes, offsets and counts. -- @@ -11,8 +9,7 @@ -- Subtraction through '(-)' caps at zero; use subtractNumberMaybe when -- a negative result must be distinguished from zero. newtype Number = Number Int - deriving (Eq, Ord, Show) - + deriving (Eq, Ord, Show) -- | Number of terminal columns. type Width = Number @@ -23,7 +20,6 @@ -- | Indentation from the left edge. type Offset = Number - instance Num Number where fromInteger n = formNumber $ fromInteger n n + m = formNumber $ unn n + unn m @@ -31,12 +27,11 @@ n * m = formNumber $ unn n * unn m negate _ = 0 abs n = n - signum n | n <= 0 = 0 | otherwise = 1 + signum n | n <= 0 = 0 | otherwise = 1 instance Sample Number where sampleShow _ (Number n) = show n - -- | Adds two numbers. addNumber :: Number -> Number -> Number addNumber n m = formNumber (unn n + unn m) @@ -65,8 +60,3 @@ unn :: Number -> Int unn = unNumber - - - - - diff --git a/src/Ansiform/Internal/Output.hs b/src/Ansiform/Internal/Output.hs --- a/src/Ansiform/Internal/Output.hs +++ b/src/Ansiform/Internal/Output.hs @@ -1,10 +1,9 @@ -- | Output target for the printing layer. module Ansiform.Internal.Output where +import Ansiform.Internal.Settings -------------------------------------------------------------------------------- -import System.IO (Handle) -import Ansiform.Internal.Settings - +import System.IO (Handle) -- Output Type -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Internal/Page.hs b/src/Ansiform/Internal/Page.hs --- a/src/Ansiform/Internal/Page.hs +++ b/src/Ansiform/Internal/Page.hs @@ -1,24 +1,21 @@ module Ansiform.Internal.Page where +import Ansiform.Internal.Number +import Ansiform.Internal.Sample +import Ansiform.Internal.Section +import Ansiform.Internal.Settings -------------------------------------------------------------------------------- -import System.IO (Handle, stdout) -import Ansiform.Internal.Number -import Ansiform.Internal.Sample -import Ansiform.Internal.Section -import Ansiform.Internal.Settings - +import System.IO (Handle, stdout) -- Page Type -------------------------------------------------------------------------------- -- | An ordered list of sections. newtype Page = Page [Section] - deriving (Eq,Show) - + deriving (Eq, Show) instance Sample Page where sampleShow n (Page sns) = sampleFormat "Page" n sns - -- Wrappers formPage :: [Section] -> Page @@ -27,10 +24,10 @@ unPage :: Page -> [Section] unPage (Page ss) = ss - -- Page Runners -------------------------------------------------------------------------------- -- Functions to print the page with the user settings. + -- | Runs a page on stdout with the given settings. runPage :: Settings -> Page -> IO [Number] runPage = runPageOn stdout @@ -48,6 +45,7 @@ runPageIOOn h cfg = mapM (runSectionIOOn h cfg) . unPage -- Uses default settings. + -- | Runs a page on stdout with the default settings. runPageDefault :: Page -> IO [Number] runPageDefault = runPageDefaultOn stdout @@ -57,6 +55,7 @@ runPageDefaultOn h = mapM (runSectionDefaultOn h) . unPage -- Uses default settings, with given width and minSpace. + -- | Runs a page on stdout with default settings and explicit width and spacing. runPageDefault' :: Number -> Number -> Page -> IO [Number] runPageDefault' = runPageDefaultOn' stdout @@ -64,4 +63,3 @@ -- Version of runPageDefault' that writes to a given Handle. runPageDefaultOn' :: Handle -> Number -> Number -> Page -> IO [Number] runPageDefaultOn' h w m = mapM (runSectionDefaultOn' h w m) . unPage - diff --git a/src/Ansiform/Internal/Printer.hs b/src/Ansiform/Internal/Printer.hs --- a/src/Ansiform/Internal/Printer.hs +++ b/src/Ansiform/Internal/Printer.hs @@ -1,44 +1,41 @@ module Ansiform.Internal.Printer where +import Ansiform.Content +import Ansiform.Internal.Content +import Ansiform.Internal.Number +import Ansiform.Internal.Output +import Ansiform.Internal.Sample +import Ansiform.Internal.Settings +import Ansiform.Internal.Style +import Ansiform.Internal.Table +import Ansiform.Internal.Terminal +import Ansiform.Internal.Utils +import Ansiform.Style -------------------------------------------------------------------------------- -import Control.Monad -import Data.List (transpose, zipWith4) -import Data.List.Split -import System.IO (Handle, hPutStr, hPutStrLn, stdout) -import Ansiform.Internal.Content -import Ansiform.Internal.Number -import Ansiform.Internal.Output -import Ansiform.Internal.Sample -import Ansiform.Internal.Settings -import Ansiform.Internal.Style -import Ansiform.Internal.Table -import Ansiform.Internal.Terminal -import Ansiform.Internal.Utils -import Ansiform.Content -import Ansiform.Style - - +import Control.Monad +import Data.List (transpose, zipWith4) +import Data.List.Split +import System.IO (Handle, hPutStr, hPutStrLn, stdout) -- Printer Type -------------------------------------------------------------------------------- + -- | A printer is a function from the output target to the number of lines printed. -- The printer name is used for inspection and equality. -newtype Printer = Printer (String, (Output -> IO Number)) +newtype Printer = Printer (String, Output -> IO Number) instance Eq Printer where - Printer (n1,_) == Printer (n2,_) = n1 == n2 + Printer (n1, _) == Printer (n2, _) = n1 == n2 instance Show Printer where - show (Printer (nm,_)) = "Printer <" ++ nm ++ ">" + show (Printer (nm, _)) = "Printer <" ++ nm ++ ">" instance Sample Printer where - sampleShow _ vp = show vp - + sampleShow _ = show -- Wrapper formPrinter :: String -> (Output -> IO Number) -> Printer -formPrinter nm fio = Printer (nm,fio) - +formPrinter nm fio = Printer (nm, fio) -- | Runs a printer on stdout with the given settings. runPrinter :: Settings -> Printer -> IO Number @@ -46,7 +43,7 @@ -- | Runs a printer on a given handle. runPrinterOn :: Handle -> Settings -> Printer -> IO Number -runPrinterOn h s (Printer (_,fio)) = runSettingsOn h s >>= \cfg -> fio (formOutput h cfg) +runPrinterOn h s (Printer (_, fio)) = runSettingsOn h s >>= \cfg -> fio (formOutput h cfg) -- | Runs a printer with a configuration resolved in IO, on stdout. runPrinterIO :: IO Config -> Printer -> IO Number @@ -54,7 +51,7 @@ -- | Runs a printer with a configuration resolved in IO, on a given handle. runPrinterIOOn :: Handle -> IO Config -> Printer -> IO Number -runPrinterIOOn h cfg (Printer (_,fio)) = cfg >>= \c -> fio (formOutput h c) +runPrinterIOOn h cfg (Printer (_, fio)) = cfg >>= \c -> fio (formOutput h c) -- | Runs a printer on stdout with the default settings. runPrinterDefault :: Printer -> IO Number @@ -62,7 +59,7 @@ -- | Runs a printer on a given handle with the default settings. runPrinterDefaultOn :: Handle -> Printer -> IO Number -runPrinterDefaultOn h (Printer (_,fio)) = initialConfigOn h >>= \cfg -> fio (formOutput h cfg) +runPrinterDefaultOn h (Printer (_, fio)) = initialConfigOn h >>= \cfg -> fio (formOutput h cfg) -- | Runs a printer on stdout with the default settings and explicit width and spacing. runPrinterDefault' :: Width -> Width -> Printer -> IO Number @@ -70,29 +67,32 @@ -- | Runs a printer on a given handle with the default settings and explicit width and spacing. runPrinterDefaultOn' :: Handle -> Width -> Width -> Printer -> IO Number -runPrinterDefaultOn' h w m (Printer (_,fio)) = - initialConfigOn h >>= \dft -> fio (formOutput h (setWidth w $ setMinSpace m dft)) - +runPrinterDefaultOn' h w m (Printer (_, fio)) = + initialConfigOn h >>= \dft -> fio (formOutput h (setWidth w $ setMinSpace m dft)) -- Basic Printing -------------------------------------------------------------------------------- -- Prints a number of empty lines. printEmpty :: Output -> Number -> IO Number -printEmpty o n = resetStyle h (outputColors o) - >> sequence_ (hPutStrLn h <$> replicate (unn n) "") - >> return n - where h = outputHandle o +printEmpty o n = + resetStyle h (outputColors o) + >> replicateM_ (unn n) (hPutStrLn h "") + >> return n + where + h = outputHandle o -- Prints the end of line character. printEnd :: Output -> IO Number printEnd o = resetStyle h (outputColors o) >> hPutStr h "\n" >> return 1 - where h = outputHandle o + where + h = outputHandle o -- Prints a Item with the proper visual style. printItem :: Output -> Item -> IO () printItem o v = applyStyle h (outputColors o) (unItemStyle v) >> hPutStr h (unItemText v) - where h = outputHandle o + where + h = outputHandle o -- Prints each Item of a Block, with the proper visual style. printBlock :: Output -> Block -> IO () @@ -101,27 +101,26 @@ -- Prints a Block, left aligned, with proper indentation and line ending. printLeft :: Output -> Offset -> Block -> IO Number printLeft o off b = ind h off >> printBlock o b >> printEnd o - where h = outputHandle o + where + h = outputHandle o -- Function to execute the printing functions that sums the line counts. printCounter :: (a -> IO Number) -> [a] -> IO Number printCounter f = foldM (\ns l -> addNumber ns <$> f l) 0 - -- Rules & Solid Printing -------------------------------------------------------------------------------- -- Prints a horizontal rule with an offset on both sides. printRule :: Offset -> Rule -> Output -> IO Number printRule o r out = ind h o >> printItem out (formRuleItem r (subtractNumber w (o * 2))) >> printEnd out - where w = unWidth (outputConfig out) - h = outputHandle out + where + w = unWidth (outputConfig out) + h = outputHandle out -- Prints a line filled with spaces with the background color given. printSolid :: Offset -> Color -> Output -> IO Number -printSolid o c out = printRule o (ruleSolid c) out - - +printSolid o c = printRule o (ruleSolid c) -- Line Printing -------------------------------------------------------------------------------- @@ -130,25 +129,23 @@ printSingleItem :: Output -> Item -> IO Number printSingleItem out i = printItem out i >> printEnd out - -- Prints a line of Blocks, left aligned. printLineLeft :: Offset -> [Block] -> Output -> IO Number printLineLeft o bs out = ind h o >> mapM_ mainPrinter bs >> printEnd out - where - m = unMinSpace (outputConfig out) - h = outputHandle out - mainPrinter vb = printBlock out vb >> ind' h m + where + m = unMinSpace (outputConfig out) + h = outputHandle out + mainPrinter vb = printBlock out vb >> ind' h m -- Prints a line of Blocks, right aligned. printLineRight :: Offset -> [Block] -> Output -> IO Number printLineRight o bs out = printLineLeft finalOffset bs out - where - w = unWidth (outputConfig out) - m = unMinSpace (outputConfig out) - m' = unn m - finalOffset = addNumber (subtractNumber (subtractNumber w o) totalWidth) m - totalWidth = formNumber . sum $ fmap ((+m') . blockTextWidth) bs - + where + w = unWidth (outputConfig out) + m = unMinSpace (outputConfig out) + m' = unn m + finalOffset = addNumber (subtractNumber (subtractNumber w o) totalWidth) m + totalWidth = formNumber . sum $ fmap ((+ m') . blockTextWidth) bs -- Prints a list of Blocks in a single line, centered and spread across -- the available width. Adjacent blocks are separated by at least the @@ -157,104 +154,116 @@ printLineCenter :: Offset -> [Block] -> Output -> IO Number printLineCenter _ [] out = printEnd out printLineCenter o [b] out = indR h centered >> printBlock out b >> printEnd out - where - cfg = outputConfig out - h = outputHandle out - w' = unn (unWidth cfg) - o' = unn o - width = blockTextWidth b - centered = o' + max 0 (quot (w' - o' * 2 - width) 2) + where + cfg = outputConfig out + h = outputHandle out + w' = unn (unWidth cfg) + o' = unn o + width = blockTextWidth b + centered = o' + max 0 (quot (w' - o' * 2 - width) 2) printLineCenter o bs out = mapM_ printAt (zip positions bs) >> printEnd out - where - cfg = outputConfig out - h = outputHandle out - w' = unn (unWidth cfg) - o' = unn o - m = unn (unMinSpace cfg) - widths = fmap blockTextWidth bs - gaps = length bs - 1 - total = sum widths + m * gaps - available = w' - o' * 2 - extra = max 0 (available - total) - baseGap = m + quot extra gaps - remainder = rem extra gaps - gapsList = [ baseGap + if i < remainder then 1 else 0 - | i <- [0 .. gaps - 1] ] - positions = scanl (\x (width,gap) -> x + width + gap) o' - (zip widths gapsList) - printAt (x,b) = indR h x >> printBlock out b - + where + cfg = outputConfig out + h = outputHandle out + w' = unn (unWidth cfg) + o' = unn o + m = unn (unMinSpace cfg) + widths = fmap blockTextWidth bs + gaps = length bs - 1 + total = sum widths + m * gaps + available = w' - o' * 2 + extra = max 0 (available - total) + baseGap = m + quot extra gaps + remainder = rem extra gaps + gapsList = + [ baseGap + if i < remainder then 1 else 0 + | i <- [0 .. gaps - 1] + ] + positions = + scanl + (\x (width, gap) -> x + width + gap) + o' + (zip widths gapsList) + printAt (x, b) = indR h x >> printBlock out b type LineFunction = (Offset -> [Block] -> Output -> IO Number) - -- Solid Text Printing -------------------------------------------------------------------------------- -- Prints a list of Blocks in a single line, with a solid background. -- The padding between background and text can be given as another offset. -printSolidLine :: Offset -> Padding -> Color -> [Block] - -> LineFunction -> Output -> IO Number +printSolidLine :: + Offset -> + Padding -> + Color -> + [Block] -> + LineFunction -> + Output -> + IO Number printSolidLine o p c bs f out = printSolid o c out >> hCursorUp h 1 >> f (addNumber o p) bs' out - where bs' = fmap (blockSetBG c) bs - h = outputHandle out - + where + bs' = fmap (blockSetBG c) bs + h = outputHandle out -- List Printing -------------------------------------------------------------------------------- -- Prints a list of Blocks as a single Column, with the given offset. printColumn :: Output -> Offset -> [Block] -> IO Number -printColumn out o bs = printCounter (printLeft out o) bs - +printColumn out o = printCounter (printLeft out o) -- Prints a list of Blocks in several columns, aiming for a specified length. -- If the number of columns overflows the width, a larger length is tried. printList :: Offset -> Number -> [Block] -> Output -> IO Number printList _ _ [] _ = return 0 printList o l bs out - | maxCols <= 0 = printColumn out o bs - | otherwise = fmap (head' 0) . sequence $ mainPrinter (new (unn l)) bs - where - cfg = outputConfig out - h = outputHandle out - w' = unn (unWidth cfg) - m = unMinSpace cfg - o' = unn o ; m' = unn m - maxWidth = max 1 (blockTextMax bs + m') - maxCols = quot (w' - o' * 2 - quot maxWidth 2) maxWidth + | maxCols <= 0 = printColumn out o bs + | otherwise = fmap (head' 0) . sequence $ mainPrinter (new (unn l)) bs + where + cfg = outputConfig out + h = outputHandle out + w' = unn (unWidth cfg) + m = unMinSpace cfg + o' = unn o + m' = unn m + maxWidth = max 1 (blockTextMax bs + m') + maxCols = quot (w' - o' * 2 - quot maxWidth 2) maxWidth - new :: Int -> Int - new l' - | l' > 0 && desiredCols l' <= maxCols = l' - | otherwise = new (l' + 1) - where desiredCols l'' | l'' == 0 = numItems - | otherwise = quot numItems l'' - numItems = length bs - - mainPrinter :: Int -> [Block] -> [IO Number] - mainPrinter newL bs' = fmap printListColumn (zip splitCols [0..]) - where - splitCols = chunksOf newL bs' - - printListColumn :: ([Block], Int) -> IO Number - printListColumn (b,i) - | i == 0 = printCol - | i == length splitCols - 1 = - hCursorUp h newL >> printCol >>= \n -> hCursorDown h (newL - length b) >> return n - | otherwise = hCursorUp h newL >> printCol - where printCol = printColumn out currentOffset b - currentOffset = formNumber (i * maxWidth + o') + new :: Int -> Int + new l' + | l' > 0 && desiredCols l' <= maxCols = l' + | otherwise = new (l' + 1) + where + desiredCols l'' + | l'' == 0 = numItems + | otherwise = quot numItems l'' + numItems = length bs + mainPrinter :: Int -> [Block] -> [IO Number] + mainPrinter newL bs' = fmap printListColumn (zip splitCols [0 ..]) + where + splitCols = chunksOf newL bs' + printListColumn :: ([Block], Int) -> IO Number + printListColumn (b, i) + | i == 0 = printCol + | i == length splitCols - 1 = + hCursorUp h newL >> printCol >>= \n -> hCursorDown h (newL - length b) >> return n + | otherwise = hCursorUp h newL >> printCol + where + printCol = printColumn out currentOffset b + currentOffset = formNumber (i * maxWidth + o') + -- Version that allows to specify the number of columns. -- By nature of the List printer, it won't allow more columns than can fit. printList' :: Offset -> Number -> [Block] -> Output -> IO Number printList' o l bs out = printList o desiredLines bs out - where desiredLines = formNumber $ quot (length bs) newL + 1 - newL | l == 0 = 1 - | otherwise = unn l - + where + desiredLines = formNumber $ quot (length bs) newL + 1 + newL + | l == 0 = 1 + | otherwise = unn l -- Group & Table Printing -------------------------------------------------------------------------------- @@ -263,7 +272,6 @@ printGroup :: Output -> Offset -> Group -> IO Number printGroup out o g = printColumn out o (unGroup g) - -- Main function for printing groups and tables, used by the specialized versions. -- Configured by the arguments: -- Offset -> Offset from both sides. @@ -271,100 +279,114 @@ -- Number -> Sets the number of rows printed, rest is discarded, 0 is max. -- Bool -> Sets the alignment to be evenly spaced if True, or max per row. -- Bool -> Table mode: zebra background and repeating index column. -printGroups :: TableFormat -> Offset -> Padding -> Number -> Bool - -> Bool -> [Group] -> Output -> IO Number +printGroups :: + TableFormat -> + Offset -> + Padding -> + Number -> + Bool -> + Bool -> + [Group] -> + Output -> + IO Number printGroups fmt o p n bSpace bTable gs out = mainPrinter - where - cfg = outputConfig out - h = outputHandle out - w = unWidth cfg - m = unMinSpace cfg - w' = unn w ; m' = unn m ; n' = unn n - offset = unn o + unn p - finalWidth = w' - offset*2 + m' - - specs = fmap (columnSpecAt fmt) [0 .. length gs - 1] - cappedWidths = zipWith cappedWidth specs gs - widthList = fmap (+m') cappedWidths - maxWidth = maximum' 0 widthList - evenList = replicate (length gs) maxWidth - chosenWidthList | bSpace = evenList | otherwise = widthList - formattedGroups = zipWith4 formatOne specs cappedWidths chosenWidthList gs + where + cfg = outputConfig out + h = outputHandle out + w = unWidth cfg + m = unMinSpace cfg + w' = unn w + m' = unn m + n' = unn n + offset = unn o + unn p + finalWidth = w' - offset * 2 + m' - formatOne :: ColumnSpec -> Int -> Int -> Group -> Group - formatOne spec capped chosen g = formatGroup spec (formNumber target) g - where - chosenContent = chosen - m' - target = case columnAlign spec of - AlignLeft -> capped - _ -> chosenContent + specs = fmap (columnSpecAt fmt) [0 .. length gs - 1] + cappedWidths = zipWith cappedWidth specs gs + widthList = fmap (+ m') cappedWidths + maxWidth = maximum' 0 widthList + evenList = replicate (length gs) maxWidth + chosenWidthList | bSpace = evenList | otherwise = widthList + formattedGroups = zipWith4 formatOne specs cappedWidths chosenWidthList gs - initGroup = take 1 formattedGroups - initWidth = take 1 chosenWidthList - mainPrinter = printLoop formattedGroups chosenWidthList 0 0 - where - printLoop :: [Group] -> [Int] -> Int -> Number -> IO Number - printLoop rm wl ri nls - | null rm || (ri >= n' && n' /= 0) = return (subtractNumber (addNumber nls (formNumber ri)) 1) - | otherwise = executePrint >> restartLoop - where - restartLoop = printLoop finalRemGroups finalRemWidths (ri + 1) (addNumber nls (formNumber rowLength)) + formatOne :: ColumnSpec -> Int -> Int -> Group -> Group + formatOne spec capped chosen = formatGroup spec (formNumber target) + where + chosenContent = chosen - m' + target = case columnAlign spec of + AlignLeft -> capped + _ -> chosenContent - executePrint :: IO () - executePrint - | bTable = printZebraBG o rowLength out >> hCursorUp h rowLength - >> printContent - | otherwise = printContent - where - printContent = - mapM_ printEach (zip3 (fst splitGroups) curOffsets [0..]) + initGroup = take 1 formattedGroups + initWidth = take 1 chosenWidthList + mainPrinter = printLoop formattedGroups chosenWidthList 0 0 + where + printLoop :: [Group] -> [Int] -> Int -> Number -> IO Number + printLoop rm wl ri nls + | null rm || (ri >= n' && n' /= 0) = return (subtractNumber (addNumber nls (formNumber ri)) 1) + | otherwise = executePrint >> restartLoop + where + restartLoop = printLoop finalRemGroups finalRemWidths (ri + 1) (addNumber nls (formNumber rowLength)) - lastRow = null remWidths - validIndex = bTable && not lastRow - rowColumns = length curWidths - rowLength = maximum' 0 $ fmap (length . unGroup) curGroups + executePrint :: IO () + executePrint + | bTable = + printZebraBG o rowLength out + >> hCursorUp h rowLength + >> printContent + | otherwise = printContent + where + printContent = + mapM_ printEach (zip3 (fst splitGroups) curOffsets [0 ..]) - curOffsets = scanl (+) 0 curWidths + lastRow = null remWidths + validIndex = bTable && not lastRow + rowColumns = length curWidths + rowLength = maximum' 0 $ fmap (length . unGroup) curGroups - finalRemGroups | validIndex = initGroup ++ remGroups | otherwise = remGroups - finalRemWidths | validIndex = initWidth ++ remWidths | otherwise = remWidths + curOffsets = scanl (+) 0 curWidths - remGroups = snd splitGroups - remWidths = snd splitWidths - curGroups = fst splitGroups - curWidths = fst splitWidths + finalRemGroups | validIndex = initGroup ++ remGroups | otherwise = remGroups + finalRemWidths | validIndex = initWidth ++ remWidths | otherwise = remWidths - splitGroups = splitAt splitPointList rm - splitWidths = splitAt splitPointList wl - splitPointList = availableSplitPoint + remGroups = snd splitGroups + remWidths = snd splitWidths + curGroups = fst splitGroups + curWidths = fst splitWidths - availableSplitPoint - | null chosenWidthList = 0 - | otherwise = max 1 (splitPoint chosenWidthList finalWidth) + splitGroups = splitAt splitPointList rm + splitWidths = splitAt splitPointList wl + splitPointList = availableSplitPoint - - printEach :: (Group,Int,Int) -> IO () - printEach (g,wg,i) - | i + 1 == rowColumns = printGroupChangeBG - >> hCursorDown h (rowLength - curLength) - >> printSpacing - | otherwise = printGroupChangeBG >> hCursorUp h curLength - where - printGroupChangeBG = printGroup' $ setBG g - colOffset = wg + offset - curLength = length (unGroup g) - printGroup' g' = printGroup out (formNumber colOffset) g' - printSpacing - | lastRow = return_ | otherwise = printEmpty out 1 >> return_ + availableSplitPoint + | null chosenWidthList = 0 + | otherwise = max 1 (splitPoint chosenWidthList finalWidth) - setBG :: Group -> Group - setBG g' | bTable = formGroup' $ changeBlocks <$> zip (unGroup g') [0..] - | otherwise = g' - where changeBlocks :: (Block, Int) -> Block - changeBlocks (b,ib) - | even ib = b - | otherwise = blockSetBG black b + printEach :: (Group, Int, Int) -> IO () + printEach (g, wg, i) + | i + 1 == rowColumns = + printGroupChangeBG + >> hCursorDown h (rowLength - curLength) + >> printSpacing + | otherwise = printGroupChangeBG >> hCursorUp h curLength + where + printGroupChangeBG = printGroup' $ setBG g + colOffset = wg + offset + curLength = length (unGroup g) + printGroup' = printGroup out (formNumber colOffset) + printSpacing + | lastRow = return_ + | otherwise = printEmpty out 1 >> return_ + setBG :: Group -> Group + setBG g' + | bTable = formGroup' $ changeBlocks <$> zip (unGroup g') [0 ..] + | otherwise = g' + where + changeBlocks :: (Block, Int) -> Block + changeBlocks (b, ib) + | even ib = b + | otherwise = blockSetBG black b -- Bordered Groups & Tables -------------------------------------------------------------------------------- @@ -375,13 +397,19 @@ -- blocks, so every column reaches the bottom border. -- 'BordersNone' keeps the same row layout without border characters and -- without horizontal separators. -printBorderedGroups :: Borders -> TableFormat -> Offset -> Padding -> Number - -> Bool -> [Group] -> Output -> IO Number +printBorderedGroups :: + Borders -> + TableFormat -> + Offset -> + Padding -> + Number -> + Bool -> + [Group] -> + Output -> + IO Number printBorderedGroups brd fmt o p n bSpace gs out | null gs = return 0 - | otherwise = case borderChars brd of - Nothing -> printBorderless - Just bc -> printBordered bc + | otherwise = maybe printBorderless printBordered (borderChars brd) where h = outputHandle out p' = unn p @@ -403,11 +431,12 @@ printRows = go limitedRows where go [] = return 0 - go (row:rest) = do + go (row : rest) = do printRow row - sep <- if null rest - then return 0 - else printHorizontal (borderMidLeft bc) (borderMidMid bc) (borderMidRight bc) + sep <- + if null rest + then return 0 + else printHorizontal (borderMidLeft bc) (borderMidMid bc) (borderMidRight bc) restCount <- go rest return (1 + sep + restCount) @@ -419,12 +448,12 @@ hPutStr h "\n" where printCells _ [] = return () - printCells i ((w,cell):rest) = do + printCells i ((w, cell) : rest) = do printBlock out (formatCell fmt i w (w + 2 * p') cell) resetStyle h (outputColors out) if null rest - then hPutStr h [borderRight bc] - else hPutStr h [borderVertical bc] + then hPutStr h [borderRight bc] + else hPutStr h [borderVertical bc] printCells (i + 1) rest printHorizontal first middle lastChar = do @@ -439,7 +468,7 @@ printRows = go limitedRows where go [] = return 0 - go (row:rest) = do + go (row : rest) = do printRow row restCount <- go rest return (1 + restCount) @@ -451,7 +480,7 @@ hPutStr h "\n" where printCells _ [] = return () - printCells i ((w,cell):rest) = do + printCells i ((w, cell) : rest) = do printBlock out (formatCell fmt i w (w + 2 * p') cell) resetStyle h (outputColors out) if null rest then return () else hPutStr h " " @@ -460,8 +489,10 @@ -- Formats a cell to its content width and then centers it in the padded width. formatCell :: TableFormat -> Int -> Int -> Int -> Block -> Block formatCell fmt i contentWidth paddedWidth cell = - padBlock (formNumber paddedWidth) AlignCenter - (formatBlock (columnSpecAt fmt i) (formNumber contentWidth) cell) + padBlock + (formNumber paddedWidth) + AlignCenter + (formatBlock (columnSpecAt fmt i) (formNumber contentWidth) cell) -- Pads every group with empty blocks so all groups have the same height. padGroups :: [Group] -> [Group] @@ -469,16 +500,19 @@ where tallest = maximum' 0 (fmap (length . unGroup) gs) padGroup g = formGroup' (unGroup g ++ replicate missing blockEmpty) - where missing = max 0 (tallest - length (unGroup g)) + where + missing = max 0 (tallest - length (unGroup g)) -- Builds one horizontal line of a box border. borderLine :: Char -> Char -> Char -> [Int] -> Char -> String borderLine first middle lastChar widths horizontal = case widths of [] -> [first, lastChar] - _ -> first : concat - [ replicate w horizontal ++ [if i == length widths - 1 then lastChar else middle] - | (i,w) <- zip [0 :: Int ..] widths ] - + _ -> + first + : concat + [ replicate w horizontal ++ [if i == length widths - 1 then lastChar else middle] + | (i, w) <- zip [0 :: Int ..] widths + ] -- Text Printing -------------------------------------------------------------------------------- @@ -488,25 +522,33 @@ -- Offset -> Additional indentation for the first paragraph line. -- Padding -> Padding between text and background. -- Bool -> Sets the Background to solid grey. -printParagraph :: Offset -> Offset -> Padding -> Bool - -> Paragraph -> Output -> IO Number -printParagraph o o1 p bZebra vbs out = printCounter printEachBlock - $ blockPublish (w' - offset' * 2) (unn o1) vbs - where - cfg = outputConfig out - h = outputHandle out - w = unWidth cfg; w' = unn w - offset' = unn o + unn p - offset = formNumber offset' - printEachBlock vb - | bZebra = printSolid o black out - >> hCursorUp h 1 - >> printLeft' (blockSetBG black blockPretty) - | otherwise = printLeft' blockPretty - where - printLeft' vb' = printLeft out offset vb' - blockPretty = blockPrettify vb - +printParagraph :: + Offset -> + Offset -> + Padding -> + Bool -> + Paragraph -> + Output -> + IO Number +printParagraph o o1 p bZebra vbs out = + printCounter printEachBlock $ + blockPublish (w' - offset' * 2) (unn o1) vbs + where + cfg = outputConfig out + h = outputHandle out + w = unWidth cfg + w' = unn w + offset' = unn o + unn p + offset = formNumber offset' + printEachBlock vb + | bZebra = + printSolid o black out + >> hCursorUp h 1 + >> printLeft' (blockSetBG black blockPretty) + | otherwise = printLeft' blockPretty + where + printLeft' = printLeft out offset + blockPretty = blockPrettify vb -- Prints a list of paragraphs, separated by a single line. -- Additional configuration can be given below. @@ -515,20 +557,26 @@ -- Padding -> Padding between text and background. -- Bool -> Controls background alternation. -- Function -> Predicate to test which paragraphs should have solid background. -printSequence :: Offset -> Offset -> Padding -> Bool -> (Int -> Bool) - -> [Paragraph] -> Output -> IO Number -printSequence o o1 p bZebra fInt vbss out = printCounter printEach (zip vbss [0..]) - where - printEach (vbs,i) - | i == length vbss - 1 = printParagraph' predZebra - | otherwise = printParagraph' predZebra >>= \n -> printSeparation >>= \n' -> return (addNumber n n') - where - predZebra = bZebra && fInt i - printParagraph' bZebra' = printParagraph o o1 p bZebra' vbs out - printSeparation - | predZebra = printSolid o black out - | otherwise = printEmpty out 1 - +printSequence :: + Offset -> + Offset -> + Padding -> + Bool -> + (Int -> Bool) -> + [Paragraph] -> + Output -> + IO Number +printSequence o o1 p bZebra fInt vbss out = printCounter printEach (zip vbss [0 ..]) + where + printEach (vbs, i) + | i == length vbss - 1 = printParagraph' predZebra + | otherwise = printParagraph' predZebra >>= \n -> printSeparation >>= \n' -> return (addNumber n n') + where + predZebra = bZebra && fInt i + printParagraph' bZebra' = printParagraph o o1 p bZebra' vbs out + printSeparation + | predZebra = printSolid o black out + | otherwise = printEmpty out 1 -- Background Printing -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Internal/Render.hs b/src/Ansiform/Internal/Render.hs --- a/src/Ansiform/Internal/Render.hs +++ b/src/Ansiform/Internal/Render.hs @@ -1,22 +1,21 @@ -- | Capture page, section and printer output as a string. module Ansiform.Internal.Render (renderPage, renderSection, renderPrinter) where +import Ansiform.Internal.Page +import Ansiform.Internal.Printer +import Ansiform.Internal.Section +import Ansiform.Internal.Settings -------------------------------------------------------------------------------- -import Control.Exception (bracket) -import System.Directory (getTemporaryDirectory, removeFile) -import System.IO (Handle, hClose, hFlush, openTempFile) -import Ansiform.Internal.Page -import Ansiform.Internal.Printer -import Ansiform.Internal.Section -import Ansiform.Internal.Settings - +import Control.Exception (bracket) +import System.Directory (getTemporaryDirectory, removeFile) +import System.IO (Handle, hClose, hFlush, openTempFile) -- Rendering -------------------------------------------------------------------------------- -- | Renders a page and returns the captured output. renderPage :: Page -> Settings -> IO String -renderPage p s = snd <$> captureOutput (\h -> renderWithConfig h) +renderPage p s = snd <$> captureOutput renderWithConfig where renderWithConfig h = do cfg <- runSettingsOn h s @@ -24,7 +23,7 @@ -- | Renders a section and returns the captured output. renderSection :: Section -> Settings -> IO String -renderSection sec s = snd <$> captureOutput (\h -> renderWithConfig h) +renderSection sec s = snd <$> captureOutput renderWithConfig where renderWithConfig h = do cfg <- runSettingsOn h s @@ -32,12 +31,11 @@ -- | Renders a single printer and returns the captured output. renderPrinter :: Printer -> Settings -> IO String -renderPrinter pr s = snd <$> captureOutput (\h -> renderWithConfig h) +renderPrinter pr s = snd <$> captureOutput renderWithConfig where renderWithConfig h = do cfg <- runSettingsOn h s runPrinterIOOn h (return cfg) pr - -- Support Functions -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Internal/Sample.hs b/src/Ansiform/Internal/Sample.hs --- a/src/Ansiform/Internal/Sample.hs +++ b/src/Ansiform/Internal/Sample.hs @@ -4,32 +4,32 @@ -- | Inspection helpers for debugging values. class Sample a where - sample :: a -> IO () - sample x = putStrLn $ sampleShow 0 x + sample :: a -> IO () + sample x = putStrLn $ sampleShow 0 x - sampleShow :: Int -> a -> String + sampleShow :: Int -> a -> String -sampleFormat :: Sample a => String -> Int -> a -> String +sampleFormat :: (Sample a) => String -> Int -> a -> String sampleFormat s n c = s ++ "\n" ++ sampleShow n c - -- Basic Instances -------------------------------------------------------------------------------- instance (Sample a, Show a) => Sample (Maybe a) where - sampleShow _ Nothing = "Nothing" - sampleShow _ (Just a) = "Just " ++ sampleShow 0 a + sampleShow _ Nothing = "Nothing" + sampleShow _ (Just a) = "Just " ++ sampleShow 0 a -instance Sample a => Sample [a] where - sample xs = putStrLn $ sampleShow (-1) xs - sampleShow n xs | n < 0 = showCList 0 | otherwise = showCList (n+2) - where showCList n' = showContentList (zip xs [0..]) n' +instance (Sample a) => Sample [a] where + sample xs = putStrLn $ sampleShow (-1) xs + sampleShow n xs | n < 0 = showCList 0 | otherwise = showCList (n + 2) + where + showCList = showContentList (zip xs [0 ..]) -- Support function to assist in showing list of content types. -showContentList :: Sample a => [(a,Int)] -> Int -> String +showContentList :: (Sample a) => [(a, Int)] -> Int -> String showContentList [] _ = "" -showContentList ((i,0):is) n = showSpaces n ++ sampleShow n i ++ showContentList is n -showContentList ((i,_):is) n = "\n" ++ showSpaces n ++ sampleShow n i ++ showContentList is n +showContentList ((i, 0) : is) n = showSpaces n ++ sampleShow n i ++ showContentList is n +showContentList ((i, _) : is) n = "\n" ++ showSpaces n ++ sampleShow n i ++ showContentList is n showSpaces :: Int -> String showSpaces n = replicate n ' ' diff --git a/src/Ansiform/Internal/Section.hs b/src/Ansiform/Internal/Section.hs --- a/src/Ansiform/Internal/Section.hs +++ b/src/Ansiform/Internal/Section.hs @@ -1,45 +1,46 @@ module Ansiform.Internal.Section where +import Ansiform.Internal.Number +import Ansiform.Internal.Printer +import Ansiform.Internal.Sample +import Ansiform.Internal.Settings +import Ansiform.Printer -------------------------------------------------------------------------------- -import Control.Monad -import System.IO (Handle, stdout) -import Ansiform.Internal.Number -import Ansiform.Internal.Printer -import Ansiform.Internal.Sample -import Ansiform.Internal.Settings -import Ansiform.Printer - +import Control.Monad +import System.IO (Handle, stdout) -- Section Type -------------------------------------------------------------------------------- + -- | A list of printers and a minimum number of lines. -newtype Section = Section (Number,[Printer]) - deriving (Eq, Show) +newtype Section = Section (Number, [Printer]) + deriving (Eq, Show) instance Sample Section where - sampleShow n (Section (m,ps)) = "Section (minimum lines: " ++ sampleShow 0 m ++ ")\n" ++ sampleShow n ps + sampleShow n (Section (m, ps)) = "Section (minimum lines: " ++ sampleShow 0 m ++ ")\n" ++ sampleShow n ps -- Wrappers formSection :: Number -> [Printer] -> Section -formSection n ps = Section (n,ps) +formSection n ps = Section (n, ps) unSectionPrinters :: Section -> [Printer] -unSectionPrinters (Section (_,ps)) = ps +unSectionPrinters (Section (_, ps)) = ps unSectionNumber :: Section -> Number -unSectionNumber (Section (n,_)) = n +unSectionNumber (Section (n, _)) = n -- Section Runners -------------------------------------------------------------------------------- -- Function to run the list of Printers with the user settings. + -- | Runs a section on stdout with the given settings. runSection :: Settings -> Section -> IO Number runSection = runSectionOn stdout -- Version of runSection that writes to a given Handle. runSectionOn :: Handle -> Settings -> Section -> IO Number -runSectionOn h s = calcSection (runPrinterOn h s) +runSectionOn h s = calcSection (runPrinterOn h s) -- Version of runSection with settings in IO. runSectionIO :: IO Config -> Section -> IO Number @@ -50,6 +51,7 @@ runSectionIOOn h cfg = calcSection (runPrinterIOOn h cfg) -- Uses default settings. + -- | Runs a section on stdout with the default settings. runSectionDefault :: Section -> IO Number runSectionDefault = runSectionDefaultOn stdout @@ -59,6 +61,7 @@ runSectionDefaultOn h = calcSection (runPrinterDefaultOn h) -- Uses default settings, with given width and minSpace. + -- | Runs a section on stdout with default settings and explicit width and spacing. runSectionDefault' :: Number -> Number -> Section -> IO Number runSectionDefault' = runSectionDefaultOn' stdout @@ -67,13 +70,12 @@ runSectionDefaultOn' :: Handle -> Number -> Number -> Section -> IO Number runSectionDefaultOn' h w m = calcSection (runPrinterDefaultOn' h w m) - -- Runs the Printers and calculates the total number of lines. calcSection :: (Printer -> IO Number) -> Section -> IO Number calcSection f vs = foldM runCalc 0 (unSectionPrinters vs) >>= enforceMin - where - runCalc acc p = f p >>= \n -> return (acc + n) - minNumber = unSectionNumber vs - enforceMin n | n < minNumber = f (printerEmpty (minNumber - n)) >> return minNumber - | otherwise = return n - + where + runCalc acc p = f p >>= \n -> return (acc + n) + minNumber = unSectionNumber vs + enforceMin n + | n < minNumber = f (printerEmpty (minNumber - n)) >> return minNumber + | otherwise = return n diff --git a/src/Ansiform/Internal/Settings.hs b/src/Ansiform/Internal/Settings.hs --- a/src/Ansiform/Internal/Settings.hs +++ b/src/Ansiform/Internal/Settings.hs @@ -1,14 +1,13 @@ module Ansiform.Internal.Settings where +import Ansiform.Internal.Number +import Ansiform.Internal.Sample +import Ansiform.Internal.Terminal -------------------------------------------------------------------------------- import qualified Data.List as List -import System.Console.ANSI (hSupportsANSI) -import System.Environment (lookupEnv) -import System.IO (Handle, stdout) -import Ansiform.Internal.Number -import Ansiform.Internal.Sample -import Ansiform.Internal.Terminal - +import System.Console.ANSI (hSupportsANSI) +import System.Environment (lookupEnv) +import System.IO (Handle, stdout) -- Config type -------------------------------------------------------------------------------- @@ -26,24 +25,27 @@ unSettings :: Settings -> [Config -> Config] unSettings (Settings fs) = fs - -- Function to build the settings in a declarative style. runSettings :: Settings -> IO Config runSettings = runSettingsOn stdout -- Function to build the settings for a given output handle. runSettingsOn :: Handle -> Settings -> IO Config -runSettingsOn h stgs = initialConfigOn h >>= \dft -> - resolveColorsOn h $ List.foldl' (\sets f -> f sets) dft $ unSettings stgs +runSettingsOn h stgs = + initialConfigOn h >>= \dft -> + resolveColorsOn h $ List.foldl' (\sets f -> f sets) dft $ unSettings stgs -- Settings type -------------------------------------------------------------------------------- -- | Controls whether ANSI style sequences are written to the terminal. data ColorMode - = ColorAuto -- ^ Detect from the environment and from stdout. - | ColorAlways -- ^ Always emit ANSI styling. - | ColorNever -- ^ Never emit ANSI styling. + = -- | Detect from the environment and from stdout. + ColorAuto + | -- | Always emit ANSI styling. + ColorAlways + | -- | Never emit ANSI styling. + ColorNever deriving (Eq, Show) instance Sample ColorMode where @@ -52,47 +54,53 @@ sampleShow _ ColorNever = "Never" -- | The resolved configuration used by the printers. -newtype Config = Config - ( Width -- Current screen width - , Width -- Minimum space to be used bettwen blocks. - , Number -- Percentage that groups are allowed to overflow. - , ColorMode -- Whether ANSI styles are enabled. - ) deriving (Eq, Show) +newtype Config + = Config + ( Width -- Current screen width + , Width -- Minimum space to be used bettwen blocks. + , Number -- Percentage that groups are allowed to overflow. + , ColorMode -- Whether ANSI styles are enabled. + ) + deriving (Eq, Show) instance Sample Config where - sampleShow _ (Config (w,m,g,c)) = "Settings" - ++ "\n Screen Width: " ++ show w - ++ "\n Minimum Space: " ++ show m - ++ "\n Group Overflow: " ++ show g ++ "%" - ++ "\n Color Mode: " ++ sampleShow 0 c + sampleShow _ (Config (w, m, g, c)) = + "Settings" + ++ "\n Screen Width: " + ++ show w + ++ "\n Minimum Space: " + ++ show m + ++ "\n Group Overflow: " + ++ show g + ++ "%" + ++ "\n Color Mode: " + ++ sampleShow 0 c -- Wrapper formConfig :: Width -> Width -> Number -> ColorMode -> Config formConfig w m g c = Config (w, m, g, c) - -- Unwrappers unConfig :: Config -> (Width, Width, Number, ColorMode) unConfig (Config s) = s unWidth :: Config -> Width -unWidth (Config (w,_,_,_)) = w +unWidth (Config (w, _, _, _)) = w unMinSpace :: Config -> Width -unMinSpace (Config (_,m,_,_)) = m +unMinSpace (Config (_, m, _, _)) = m unGroupOverflow :: Config -> Number -unGroupOverflow (Config (_,_,g,_)) = g +unGroupOverflow (Config (_, _, g, _)) = g unColorMode :: Config -> ColorMode -unColorMode (Config (_,_,_,c)) = c +unColorMode (Config (_, _, _, c)) = c -- Reports whether ANSI style sequences should be emitted. -- Only an explicitly resolved 'ColorAlways' enables them. colorsEnabled :: Config -> Bool colorsEnabled v = unColorMode v == ColorAlways - -- Generates the base settings to be configured. initialConfig :: IO Config initialConfig = initialConfigOn stdout @@ -108,10 +116,10 @@ -- Replaces 'ColorAuto' with the mode supported by the given handle. resolveColorsOn :: Handle -> Config -> IO Config resolveColorsOn h v = case unColorMode v of - ColorAuto -> do - supported <- colorsSupportedOn h - return $ setColorMode (if supported then ColorAlways else ColorNever) v - _ -> return v + ColorAuto -> do + supported <- colorsSupportedOn h + return $ setColorMode (if supported then ColorAlways else ColorNever) v + _ -> return v -- Checks whether the given output can safely receive ANSI styles. colorsSupported :: IO Bool @@ -129,23 +137,19 @@ -- Support Functions -------------------------------------------------------------------------------- --- Maximum allowed for groups to exceed the average length, +-- Maximum allowed for groups to exceed the average length, -- Converts the percentage to the divisor. groupOverflowRatio :: Number -> Int groupOverflowRatio n | n <= 0 = 0 | n >= 100 = 1 | otherwise = div 100 (unn n) - setWidth :: Width -> Config -> Config -setWidth n (Config (_,m,g,c)) = formConfig n m g c +setWidth n (Config (_, m, g, c)) = formConfig n m g c setMinSpace :: Width -> Config -> Config -setMinSpace n (Config (w,_,g,c)) = formConfig w n g c +setMinSpace n (Config (w, _, g, c)) = formConfig w n g c setGroupOverflow :: Number -> Config -> Config -setGroupOverflow n (Config (w,m,_,c)) = formConfig w m n c +setGroupOverflow n (Config (w, m, _, c)) = formConfig w m n c setColorMode :: ColorMode -> Config -> Config -setColorMode n (Config (w,m,g,_)) = formConfig w m g n - - - +setColorMode n (Config (w, m, g, _)) = formConfig w m g n diff --git a/src/Ansiform/Internal/State.hs b/src/Ansiform/Internal/State.hs --- a/src/Ansiform/Internal/State.hs +++ b/src/Ansiform/Internal/State.hs @@ -1,35 +1,34 @@ module Ansiform.Internal.State where +import Ansiform.Internal.Number +import Ansiform.Internal.Page +import Ansiform.Internal.Settings -------------------------------------------------------------------------------- -import System.IO (Handle) -import Ansiform.Internal.Number -import Ansiform.Internal.Page -import Ansiform.Internal.Settings - +import System.IO (Handle) -- State Type -------------------------------------------------------------------------------- -- State carries the data needed to print each page correctly. --- | Drawing state: the settings, the page on screen and the line counts from the last draw. -newtype State = State (Settings,Page,[Number]) +-- | Drawing state: the settings, the page on screen and the line counts from the last draw. +newtype State = State (Settings, Page, [Number]) formState :: Settings -> Page -> [Number] -> State -formState s p ns = State (s,p,ns) +formState s p ns = State (s, p, ns) unStateSettings :: State -> IO Config -unStateSettings (State (s,_,_)) = runSettings s +unStateSettings (State (s, _, _)) = runSettings s -- Resolves the state settings for a given output handle. unStateSettingsOn :: Handle -> State -> IO Config -unStateSettingsOn h (State (s,_,_)) = runSettingsOn h s +unStateSettingsOn h (State (s, _, _)) = runSettingsOn h s unStatePage :: State -> Page -unStatePage (State (_,p,_)) = p +unStatePage (State (_, p, _)) = p unStateResults :: State -> [Number] -unStateResults (State (_,_,ns)) = ns +unStateResults (State (_, _, ns)) = ns updateState :: State -> Page -> [Number] -> State -updateState (State (s,_,_)) p ns = formState s p ns +updateState (State (s, _, _)) = formState s diff --git a/src/Ansiform/Internal/Style.hs b/src/Ansiform/Internal/Style.hs --- a/src/Ansiform/Internal/Style.hs +++ b/src/Ansiform/Internal/Style.hs @@ -1,17 +1,20 @@ -- | Internal style representation and ANSI SGR application. -module Ansiform.Internal.Style - ( module Ansiform.Internal.Style - , ANSI.ColorIntensity(..) - , ANSI.ConsoleIntensity(..), ANSI.Underlining(..) - , ANSI.cursorUp, ANSI.cursorDown - ) where - +module Ansiform.Internal.Style + ( module Ansiform.Internal.Style + , ANSI.ColorIntensity (..) + , ANSI.ConsoleIntensity (..) + , ANSI.Underlining (..) + , ANSI.cursorUp + , ANSI.cursorDown + ) where + +import Ansiform.Internal.Sample -------------------------------------------------------------------------------- -import Control.Monad.IO.Class -import System.Console.ANSI as ANSI hiding (Color) +import Control.Monad.IO.Class +import System.Console.ANSI as ANSI hiding (Color) import qualified System.Console.ANSI as ANSI -import System.IO (Handle) -import Ansiform.Internal.Sample +import System.IO (Handle) + -------------------------------------------------------------------------------- {- @@ -22,31 +25,31 @@ ColorIntensity Dull Vivid ConsoleIntensity BoldIntensity NormalIntensity Underlining SingleUnderline NoUnderline -BlinkSpeed SlowBlink RapidBlink NoBlink +BlinkSpeed SlowBlink RapidBlink NoBlink ANSI commands: -Reset -SetConsoleIntensity ConsoleIntensity +Reset +SetConsoleIntensity ConsoleIntensity SetItalicized Bool -SetUnderlining Underlining -SetBlinkSpeed BlinkSpeed +SetUnderlining Underlining +SetBlinkSpeed BlinkSpeed SetVisible Bool -SetSwapForegroundBackground Bool -SetColor ConsoleLayer ColorIntensity Color +SetSwapForegroundBackground Bool +SetColor ConsoleLayer ColorIntensity Color -} -- Colors -------------------------------------------------------------------------------- + -- | An ANSI color, optionally with a specific intensity. data Color = ColorDefault | Color ColorIntensity ANSI.Color - deriving (Eq, Show) + deriving (Eq, Show) instance Sample Color where sampleShow _ ColorDefault = "ColorDefault" sampleShow _ (Color Dull c) = show c - sampleShow _ (Color Vivid c) = show c ++ "'" - + sampleShow _ (Color Vivid c) = show c ++ "'" -- Wrapper and Default formColor :: ColorIntensity -> ANSI.Color -> Color @@ -58,25 +61,25 @@ -- Unwrappers unColor :: Color -> ANSI.Color unColor c = case c of - ColorDefault -> ANSI.White - Color _ c' -> c' + ColorDefault -> ANSI.White + Color _ c' -> c' -unIntensity :: Color -> ColorIntensity +unIntensity :: Color -> ColorIntensity unIntensity c = case c of - ColorDefault -> Dull - Color i' _ -> i' + ColorDefault -> Dull + Color i' _ -> i' -- Default check. isColorDefault :: Color -> Bool -isColorDefault vc = case vc of ColorDefault -> True ; _ -> False - +isColorDefault vc = case vc of ColorDefault -> True; _ -> False -- Formatting -------------------------------------------------------------------------------- -- Bold Italic Underline + -- | Bold, italic and underline attributes. -data Format = FormatDefault | Format ConsoleIntensity Bool Underlining - deriving (Eq, Show) +data Format = FormatDefault | Format ConsoleIntensity Bool Underlining + deriving (Eq, Show) instance Sample Format where sampleShow _ FormatDefault = "FormatDefault" @@ -89,9 +92,8 @@ sampleShow _ (Format BoldIntensity True SingleUnderline) = "BoldItalicUnderline" sampleShow _ _ = "Regular" - -- Wrapper and Default -formFormat :: ConsoleIntensity -> Bool -> Underlining -> Format +formFormat :: ConsoleIntensity -> Bool -> Underlining -> Format formFormat = Format defaultFormat :: Format @@ -100,22 +102,22 @@ -- Unwrappers unBold :: Format -> ConsoleIntensity unBold vf = case vf of - FormatDefault -> NormalIntensity - Format b _ _ -> b + FormatDefault -> NormalIntensity + Format b _ _ -> b unItalic :: Format -> Bool unItalic vf = case vf of - FormatDefault -> False - Format _ i _ -> i + FormatDefault -> False + Format _ i _ -> i unUnderline :: Format -> Underlining unUnderline vf = case vf of - FormatDefault -> NoUnderline - Format _ _ u -> u + FormatDefault -> NoUnderline + Format _ _ u -> u -- Format checks. isFormatDefault :: Format -> Bool -isFormatDefault vf = case vf of FormatDefault -> True ; _ -> False +isFormatDefault vf = case vf of FormatDefault -> True; _ -> False isBold :: Format -> Bool isBold vf = case unBold vf of BoldIntensity -> True; _ -> False @@ -126,20 +128,20 @@ isUnderline :: Format -> Bool isUnderline vf = case unUnderline vf of SingleUnderline -> True; _ -> False - -- Visual Styles -------------------------------------------------------------------------------- + -- | A foreground color, a background color and a format. data Style = Zero | Style Color Color Format - deriving (Eq, Show) + deriving (Eq, Show) instance Sample Style where - sampleShow _ Zero = "Reset" - sampleShow _ (Style fc bg f) = "{" ++ sampleShow 0 fc ++ " " ++ sampleShow 0 bg ++ " " ++ sampleShow 0 f ++ "}" + sampleShow _ Zero = "Reset" + sampleShow _ (Style fc bg f) = "{" ++ sampleShow 0 fc ++ " " ++ sampleShow 0 bg ++ " " ++ sampleShow 0 f ++ "}" -- Main function to apply SGR styles to a terminal handle. -- When styling is disabled, no escape sequence is emitted. -applyStyle :: MonadIO m => Handle -> Bool -> Style -> m () +applyStyle :: (MonadIO m) => Handle -> Bool -> Style -> m () applyStyle h True s = liftIO $ ANSI.hSetSGR h (Reset : styleCommands s) applyStyle _ False _ = return () @@ -148,32 +150,32 @@ resetStyle h enabled = applyStyle h enabled Zero -- Constructs the final list of SGR instructions for Ansiform. -styleCommands :: Style -> [SGR] +styleCommands :: Style -> [SGR] styleCommands s = case s of - Zero -> [] - Style fc bc f -> - colorCommands fc bc ++ formatCommands f + Zero -> [] + Style fc bc f -> + colorCommands fc bc ++ formatCommands f -- Builds the color SGR list. colorCommands :: Color -> Color -> [SGR] colorCommands fc bc | isColorDefault fc && isColorDefault bc = [] - | isColorDefault bc = [ foregroundCommand fc ] - | isColorDefault fc = [ backgroundCommand bc ] - | otherwise = [ foregroundCommand fc, backgroundCommand bc ] - where + | isColorDefault bc = [foregroundCommand fc] + | isColorDefault fc = [backgroundCommand bc] + | otherwise = [foregroundCommand fc, backgroundCommand bc] + where foregroundCommand c = SetColor Foreground (unIntensity c) (unColor c) backgroundCommand c = SetColor Background (unIntensity c) (unColor c) - -- Builds the formatting SGR list. formatCommands :: Format -> [SGR] formatCommands f - | isFormatDefault f = [] - | otherwise = [ SetConsoleIntensity (unBold f) - , SetItalicized (unItalic f) - , SetUnderlining (unUnderline f) - ] + | isFormatDefault f = [] + | otherwise = + [ SetConsoleIntensity (unBold f) + , SetItalicized (unItalic f) + , SetUnderlining (unUnderline f) + ] -- Wrapper and Defaults formStyle :: Color -> Color -> Format -> Style @@ -184,22 +186,22 @@ -- Unwrappers unStyleForeground :: Style -> Color -unStyleForeground s = case s of Zero -> defaultColor ; Style fc _ _ -> fc +unStyleForeground s = case s of Zero -> defaultColor; Style fc _ _ -> fc unStyleBackground :: Style -> Color -unStyleBackground s = case s of Zero -> defaultColor ; Style _ bc _ -> bc +unStyleBackground s = case s of Zero -> defaultColor; Style _ bc _ -> bc unStyleFormat :: Style -> Format -unStyleFormat s = case s of Zero -> defaultFormat ; Style _ _ f -> f - +unStyleFormat s = case s of Zero -> defaultFormat; Style _ _ f -> f -- Style checks isZero :: Style -> Bool -isZero v = case v of Zero -> True ; _ -> False +isZero v = case v of Zero -> True; _ -> False isSpecial :: Style -> Bool isSpecial vs = isBold vf || isItalic vf || isUnderline vf || isColored vs || isSolid vs - where vf = unStyleFormat vs + where + vf = unStyleFormat vs isSolid :: Style -> Bool isSolid vs = not . isColorDefault $ unStyleBackground vs @@ -210,17 +212,13 @@ -- Sets the background color to a given color, respects if there is already one. setBackground :: Color -> Style -> Style setBackground c v = case v of - Zero -> v - Style fc bc f -> case bc of - ColorDefault -> formStyle fc c f - _ -> v + Zero -> v + Style fc bc f -> case bc of + ColorDefault -> formStyle fc c f + _ -> v -- Swaps the foreground and background color. swapBackground :: Style -> Style swapBackground v = case v of - Zero -> v - Style fc bc f -> formStyle bc fc f - - - - + Zero -> v + Style fc bc f -> formStyle bc fc f diff --git a/src/Ansiform/Internal/Table.hs b/src/Ansiform/Internal/Table.hs --- a/src/Ansiform/Internal/Table.hs +++ b/src/Ansiform/Internal/Table.hs @@ -2,23 +2,22 @@ module Ansiform.Internal.Table where -------------------------------------------------------------------------------- -import Ansiform.Internal.Content -import Ansiform.Internal.Number -import Ansiform.Internal.Sample -import Ansiform.Internal.Style -import Ansiform.Internal.Width - +import Ansiform.Internal.Content +import Ansiform.Internal.Number +import Ansiform.Internal.Sample +import Ansiform.Internal.Style +import Ansiform.Internal.Width -- Table Format Types -------------------------------------------------------------------------------- -- | Horizontal alignment of a column. data Align = AlignLeft | AlignCenter | AlignRight - deriving (Eq, Show) + deriving (Eq, Show) -- | Box-drawing style for tables and groups. data Borders = BordersNone | BordersAscii | BordersLight | BordersHeavy | BordersDouble - deriving (Eq, Show) + deriving (Eq, Show) -- | Characters used to draw one border style. data BorderChars = BorderChars @@ -39,18 +38,19 @@ -- | Marker appended when a cell is truncated. data Ellipsis = EllipsisNone | EllipsisChar Char - deriving (Eq, Show) + deriving (Eq, Show) -- | Alignment, maximum width and truncation for one column. data ColumnSpec = ColumnSpec { columnAlign :: Align , columnMaxWidth :: Maybe Width , columnEllipsis :: Ellipsis - } deriving (Eq, Show) + } + deriving (Eq, Show) -- | Formatting options for all columns of a table. newtype TableFormat = TableFormat [ColumnSpec] - deriving (Eq, Show) + deriving (Eq, Show) instance Sample Align where sampleShow _ = show @@ -67,7 +67,6 @@ instance Sample TableFormat where sampleShow _ = show - -- Wrappers and Defaults -------------------------------------------------------------------------------- @@ -83,34 +82,74 @@ borderChars :: Borders -> Maybe BorderChars borderChars b = case b of BordersNone -> Nothing - BordersAscii -> Just BorderChars - { borderTopLeft = '+', borderTopMid = '+', borderTopRight = '+' - , borderLeft = '|', borderRight = '|' - , borderMidLeft = '+', borderMidMid = '+', borderMidRight = '+' - , borderBottomLeft = '+', borderBottomMid = '+', borderBottomRight = '+' - , borderHorizontal = '-', borderVertical = '|' - } - BordersLight -> Just BorderChars - { borderTopLeft = '┌', borderTopMid = '┬', borderTopRight = '┐' - , borderLeft = '│', borderRight = '│' - , borderMidLeft = '├', borderMidMid = '┼', borderMidRight = '┤' - , borderBottomLeft = '└', borderBottomMid = '┴', borderBottomRight = '┘' - , borderHorizontal = '─', borderVertical = '│' - } - BordersHeavy -> Just BorderChars - { borderTopLeft = '┏', borderTopMid = '┳', borderTopRight = '┓' - , borderLeft = '┃', borderRight = '┃' - , borderMidLeft = '┣', borderMidMid = '╋', borderMidRight = '┫' - , borderBottomLeft = '┗', borderBottomMid = '┻', borderBottomRight = '┛' - , borderHorizontal = '━', borderVertical = '┃' - } - BordersDouble -> Just BorderChars - { borderTopLeft = '╔', borderTopMid = '╦', borderTopRight = '╗' - , borderLeft = '║', borderRight = '║' - , borderMidLeft = '╠', borderMidMid = '╬', borderMidRight = '╣' - , borderBottomLeft = '╚', borderBottomMid = '╩', borderBottomRight = '╝' - , borderHorizontal = '═', borderVertical = '║' - } + BordersAscii -> + Just + BorderChars + { borderTopLeft = '+' + , borderTopMid = '+' + , borderTopRight = '+' + , borderLeft = '|' + , borderRight = '|' + , borderMidLeft = '+' + , borderMidMid = '+' + , borderMidRight = '+' + , borderBottomLeft = '+' + , borderBottomMid = '+' + , borderBottomRight = '+' + , borderHorizontal = '-' + , borderVertical = '|' + } + BordersLight -> + Just + BorderChars + { borderTopLeft = '┌' + , borderTopMid = '┬' + , borderTopRight = '┐' + , borderLeft = '│' + , borderRight = '│' + , borderMidLeft = '├' + , borderMidMid = '┼' + , borderMidRight = '┤' + , borderBottomLeft = '└' + , borderBottomMid = '┴' + , borderBottomRight = '┘' + , borderHorizontal = '─' + , borderVertical = '│' + } + BordersHeavy -> + Just + BorderChars + { borderTopLeft = '┏' + , borderTopMid = '┳' + , borderTopRight = '┓' + , borderLeft = '┃' + , borderRight = '┃' + , borderMidLeft = '┣' + , borderMidMid = '╋' + , borderMidRight = '┫' + , borderBottomLeft = '┗' + , borderBottomMid = '┻' + , borderBottomRight = '┛' + , borderHorizontal = '━' + , borderVertical = '┃' + } + BordersDouble -> + Just + BorderChars + { borderTopLeft = '╔' + , borderTopMid = '╦' + , borderTopRight = '╗' + , borderLeft = '║' + , borderRight = '║' + , borderMidLeft = '╠' + , borderMidMid = '╬' + , borderMidRight = '╣' + , borderBottomLeft = '╚' + , borderBottomMid = '╩' + , borderBottomRight = '╝' + , borderHorizontal = '═' + , borderVertical = '║' + } formTableFormat :: [ColumnSpec] -> TableFormat formTableFormat = TableFormat @@ -121,10 +160,9 @@ -- Returns the spec for a column, falling back to the default. columnSpecAt :: TableFormat -> Int -> ColumnSpec columnSpecAt fmt i = case drop i (unTableFormat fmt) of - (c:_) -> c + (c : _) -> c [] -> defaultColumnSpec - -- Formatting -------------------------------------------------------------------------------- @@ -133,7 +171,8 @@ cappedWidth spec g = case columnMaxWidth spec of Nothing -> natural Just cap -> min natural (unn cap) - where natural = blockTextMax (unGroup g) + where + natural = blockTextMax (unGroup g) -- Formats every block of a group to a target width. formatGroup :: ColumnSpec -> Width -> Group -> Group @@ -141,8 +180,9 @@ -- Truncates and pads a block to a target width. formatBlock :: ColumnSpec -> Width -> Block -> Block -formatBlock spec w b = padBlock w (columnAlign spec) $ - truncateBlock w (columnEllipsis spec) b +formatBlock spec w b = + padBlock w (columnAlign spec) $ + truncateBlock w (columnEllipsis spec) b -- Pads a block with spaces according to the alignment. padBlock :: Width -> Align -> Block -> Block @@ -153,8 +193,8 @@ AlignLeft -> (0, missing) AlignRight -> (missing, 0) AlignCenter -> (missing `div` 2, missing - missing `div` 2) - leftItems = if left > 0 then [formItem (replicate left ' ') defaultStyle] else [] - rightItems = if right > 0 then [formItem (replicate right ' ') defaultStyle] else [] + leftItems = [formItem (replicate left ' ') defaultStyle | left > 0] + rightItems = [formItem (replicate right ' ') defaultStyle | right > 0] -- Truncates a block to a display width, optionally appending an ellipsis. truncateBlock :: Width -> Ellipsis -> Block -> Block @@ -167,9 +207,9 @@ EllipsisNone -> (w', []) EllipsisChar c -> let cw = charWidth c - in if cw <= w' - then (w' - cw, [formItem [c] ellipsisStyle]) - else (w', []) + in if cw <= w' + then (w' - cw, [formItem [c] ellipsisStyle]) + else (w', []) ellipsisStyle = case unBlock b of [] -> defaultStyle items -> unItemStyle (last items) @@ -177,19 +217,20 @@ -- Keeps items while their display width fits. takeItems :: Int -> [Item] -> [Item] takeItems _ [] = [] -takeItems n (i:is) +takeItems n (i : is) | n <= 0 = [] | itemWidth <= n = i : takeItems (n - itemWidth) is | otherwise = case splitTextAtWidth n (unItemText i) of ("", _) -> [] (kept, _) -> [formItem kept (unItemStyle i)] - where itemWidth = textWidth (unItemText i) + where + itemWidth = textWidth (unItemText i) -- Splits a string at a display width, keeping combining marks with their base. splitTextAtWidth :: Int -> String -> (String, String) splitTextAtWidth n = go 0 [] where go _ acc [] = (reverse acc, []) - go cw acc (c:cs) - | cw + charWidth c <= n = go (cw + charWidth c) (c:acc) cs - | otherwise = (reverse acc, c:cs) + go cw acc (c : cs) + | cw + charWidth c <= n = go (cw + charWidth c) (c : acc) cs + | otherwise = (reverse acc, c : cs) diff --git a/src/Ansiform/Internal/Terminal.hs b/src/Ansiform/Internal/Terminal.hs --- a/src/Ansiform/Internal/Terminal.hs +++ b/src/Ansiform/Internal/Terminal.hs @@ -1,16 +1,17 @@ -- | Internal terminal cursor and size helpers. -module Ansiform.Internal.Terminal - ( module Ansiform.Internal.Terminal - , ANSI.cursorUp, ANSI.cursorDown - , ANSI.hCursorUp, ANSI.hCursorDown - ) where - --------------------------------------------------------------------------------- -import System.Console.ANSI as ANSI -import System.Console.Terminal.Size -import System.IO (Handle, hIsTerminalDevice, stdout) -import Ansiform.Internal.Number +module Ansiform.Internal.Terminal + ( module Ansiform.Internal.Terminal + , ANSI.cursorUp + , ANSI.cursorDown + , ANSI.hCursorUp + , ANSI.hCursorDown + ) where +import Ansiform.Internal.Number +-------------------------------------------------------------------------------- +import System.Console.ANSI as ANSI +import System.Console.Terminal.Size +import System.IO (Handle, hIsTerminalDevice, stdout) -- Indentation -------------------------------------------------------------------------------- @@ -31,7 +32,6 @@ indR' :: Handle -> Int -> IO () indR' = hCursorForward - -- Clear -------------------------------------------------------------------------------- @@ -41,7 +41,6 @@ clr0 :: Handle -> IO () clr0 h = clr h 0 - -- Terminal Size -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Internal/Theme.hs b/src/Ansiform/Internal/Theme.hs --- a/src/Ansiform/Internal/Theme.hs +++ b/src/Ansiform/Internal/Theme.hs @@ -2,9 +2,8 @@ module Ansiform.Internal.Theme where -------------------------------------------------------------------------------- -import Ansiform.Internal.Sample -import Ansiform.Internal.Style - +import Ansiform.Internal.Sample +import Ansiform.Internal.Style -- Theme Type -------------------------------------------------------------------------------- @@ -21,17 +20,29 @@ , themeBar :: Color , themeTableHeader :: Style , themeTableBody :: Style - } deriving (Eq, Show) + } + deriving (Eq, Show) instance Sample Theme where - sampleShow _ t = "Theme" - ++ "\n Header: " ++ sampleShow 0 (themeHeader t) - ++ "\n Subtitle: " ++ sampleShow 0 (themeSubtitle t) - ++ "\n Footer: " ++ sampleShow 0 (themeFooter t) - ++ "\n Accent: " ++ sampleShow 0 (themeAccent t) - ++ "\n Danger: " ++ sampleShow 0 (themeDanger t) - ++ "\n Muted: " ++ sampleShow 0 (themeMuted t) - ++ "\n Rule: " ++ sampleShow 0 (themeRule t) - ++ "\n Bar: " ++ sampleShow 0 (themeBar t) - ++ "\n Table Header: " ++ sampleShow 0 (themeTableHeader t) - ++ "\n Table Body: " ++ sampleShow 0 (themeTableBody t) + sampleShow _ t = + "Theme" + ++ "\n Header: " + ++ sampleShow 0 (themeHeader t) + ++ "\n Subtitle: " + ++ sampleShow 0 (themeSubtitle t) + ++ "\n Footer: " + ++ sampleShow 0 (themeFooter t) + ++ "\n Accent: " + ++ sampleShow 0 (themeAccent t) + ++ "\n Danger: " + ++ sampleShow 0 (themeDanger t) + ++ "\n Muted: " + ++ sampleShow 0 (themeMuted t) + ++ "\n Rule: " + ++ sampleShow 0 (themeRule t) + ++ "\n Bar: " + ++ sampleShow 0 (themeBar t) + ++ "\n Table Header: " + ++ sampleShow 0 (themeTableHeader t) + ++ "\n Table Body: " + ++ sampleShow 0 (themeTableBody t) diff --git a/src/Ansiform/Internal/Utils.hs b/src/Ansiform/Internal/Utils.hs --- a/src/Ansiform/Internal/Utils.hs +++ b/src/Ansiform/Internal/Utils.hs @@ -2,30 +2,28 @@ -------------------------------------------------------------------------------- import qualified Data.List as List -import Data.Maybe (fromMaybe) - +import Data.Maybe (fromMaybe) -- Numbers -------------------------------------------------------------------------------- -- Version of maximum that takes a default, so it doesn't fail. -maximum' :: Ord a => a -> [a] -> a +maximum' :: (Ord a) => a -> [a] -> a maximum' = foldr max -- Version of minimum that takes a default, so it doesn't fail. -minimum' :: Ord a => a -> [a] -> a +minimum' :: (Ord a) => a -> [a] -> a minimum' = foldr min -- Calculates the average value from a list of Ints. average :: [Int] -> Int average xs = case xs of [] -> 0; _ -> div (sum xs) (length xs) - -- Lists -------------------------------------------------------------------------------- -- Version of head that returns a maybe. headMaybe :: [a] -> Maybe a headMaybe [] = Nothing -headMaybe (x:_) = Just x +headMaybe (x : _) = Just x -- Version of indexing that returns a maybe. atMay :: [a] -> Int -> Maybe a @@ -36,18 +34,17 @@ -- Version of head that takes a default. head' :: a -> [a] -> a head' d [] = d -head' _ (x:_) = x +head' _ (x : _) = x -- Version of last that returns a maybe. Still doesn't work for infinite lists. lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing -lastMaybe (x:xs) = Just (last' x xs) +lastMaybe (x : xs) = Just (last' x xs) -- Version of last that takes a default. last' :: a -> [a] -> a last' d [] = d -last' _ (x:xs) = last' x xs - +last' _ (x : xs) = last' x xs -- Reverses and concats a list simultaneously, used to avoid appending. concatRev :: [[a]] -> [a] @@ -56,23 +53,22 @@ concatRev' :: [[a]] -> [a] concatRev' = List.foldl' (flip (++)) [] - -- Checks if a List has at least a given number of items or more. atLeastLength :: Int -> [a] -> Bool -atLeastLength n = not . null . drop (n-1) +atLeastLength n = not . null . drop (n - 1) -- Checks if a List has exactly a given number of items. -- Doesn't run the rest of the list if it fails. exactLength :: Int -> [a] -> Bool exactLength n as - | n < 0 = False - | n == 0 = null as - | otherwise = lengthTest 0 as - where - lengthTest c as' - | null as' = c == n - | c > n = False - | otherwise = lengthTest (c+1) (drop 1 as') + | n < 0 = False + | n == 0 = null as + | otherwise = lengthTest 0 as + where + lengthTest c as' + | null as' = c == n + | c > n = False + | otherwise = lengthTest (c + 1) (drop 1 as') -- Inserts an element in a list at a given index. insertAt :: Int -> a -> [a] -> [a] @@ -81,28 +77,31 @@ -- GroupsBy using any binary operation, not only equality. (Brandon Simmons) groupBy' :: (a -> a -> Bool) -> [a] -> [[a]] groupBy' _ [] = [] -groupBy' c (a:as) = (a:ys) : groupBy' c zs - where (ys,zs) = spanC a as - spanC _ [] = ([], []) - spanC a' (x:xs) - | a' `c` x = let (ps,qs) = spanC x xs - in (x:ps,qs) - | otherwise = ([], x:xs) +groupBy' c (a : as) = (a : ys) : groupBy' c zs + where + (ys, zs) = spanC a as + spanC _ [] = ([], []) + spanC a' (x : xs) + | a' `c` x = + let (ps, qs) = spanC x xs + in (x : ps, qs) + | otherwise = ([], x : xs) --- Function to find the point to split a list of Ints +-- Function to find the point to split a list of Ints -- when their sum overflows an Int threshold. splitPoint :: [Int] -> Int -> Int splitPoint wl w = sumTest 0 0 wl - where - sumTest s i cs - | curSum <= w && not (null cs) = sumTest curSum (i + 1) (drop 1 cs) - | otherwise = i - where c = fromMaybe 0 $ headMaybe cs - curSum = s + c + where + sumTest s i cs + | curSum <= w && not (null cs) = sumTest curSum (i + 1) (drop 1 cs) + | otherwise = i + where + c = fromMaybe 0 $ headMaybe cs + curSum = s + c -- Monads -------------------------------------------------------------------------------- -- Shorthand for returning unit. -return_ :: Monad m => m () +return_ :: (Monad m) => m () return_ = return () diff --git a/src/Ansiform/Internal/Width.hs b/src/Ansiform/Internal/Width.hs --- a/src/Ansiform/Internal/Width.hs +++ b/src/Ansiform/Internal/Width.hs @@ -2,8 +2,7 @@ module Ansiform.Internal.Width (charWidth, textWidth) where -------------------------------------------------------------------------------- -import Data.Char (GeneralCategory (..), generalCategory, ord) - +import Data.Char (GeneralCategory (..), generalCategory, ord) -- Display Width -------------------------------------------------------------------------------- @@ -21,7 +20,6 @@ textWidth :: String -> Int textWidth = sum . fmap charWidth - -- Support Functions -------------------------------------------------------------------------------- @@ -31,13 +29,14 @@ NonSpacingMark -> True EnclosingMark -> True Format -> True - _ -> inRange 0x1160 0x11FF c -- Hangul Jamo vowels and finals. - || inRange 0x200B 0x200B c -- Zero width space. - || inRange 0x1F3FB 0x1F3FF c -- Emoji skin tone modifiers. + _ -> + inRange 0x1160 0x11FF c -- Hangul Jamo vowels and finals. + || inRange 0x200B 0x200B c -- Zero width space. + || inRange 0x1F3FB 0x1F3FF c -- Emoji skin tone modifiers. -- Checks for characters that occupy two columns. isWide :: Char -> Bool -isWide c = any (\(lo,hi) -> inRange lo hi c) wideRanges +isWide c = any (\(lo, hi) -> inRange lo hi c) wideRanges inRange :: Int -> Int -> Char -> Bool inRange lo hi c = lo <= ord c && ord c <= hi @@ -45,30 +44,30 @@ -- East Asian wide and fullwidth ranges, plus the main emoji blocks. wideRanges :: [(Int, Int)] wideRanges = - [ (0x1100, 0x115F) -- Hangul Jamo initials. - , (0x2329, 0x232A) -- Angle brackets. - , (0x2E80, 0x303E) -- CJK radicals, Kangxi and CJK symbols. - , (0x3041, 0x33FF) -- Kana, Bopomofo, Jamo and compatibility. - , (0x3400, 0x4DBF) -- CJK extension A. - , (0x4E00, 0x9FFF) -- CJK unified ideographs. - , (0xA000, 0xA4CF) -- Yi syllables. - , (0xA960, 0xA97F) -- Hangul Jamo extended A. - , (0xAC00, 0xD7A3) -- Hangul syllables. - , (0xF900, 0xFAFF) -- CJK compatibility ideographs. - , (0xFE10, 0xFE19) -- Vertical forms. - , (0xFE30, 0xFE6F) -- CJK compatibility forms. - , (0xFF00, 0xFF60) -- Fullwidth forms. - , (0xFFE0, 0xFFE6) -- Fullwidth signs. - , (0x1F004, 0x1F004) -- Mahjong red dragon. - , (0x1F0CF, 0x1F0CF) -- Playing card joker. - , (0x1F18E, 0x1F18E) -- Squared AB. - , (0x1F191, 0x1F19A) -- Squared symbols. - , (0x1F200, 0x1F2FF) -- Enclosed ideographic supplement. - , (0x1F300, 0x1F64F) -- Pictographs and emoticons. - , (0x1F680, 0x1F6FF) -- Transport and map symbols. - , (0x1F780, 0x1F7FF) -- Geometric shapes extended. - , (0x1F900, 0x1F9FF) -- Supplemental pictographs. - , (0x1FA70, 0x1FAFF) -- Pictographs extended A. - , (0x20000, 0x2FFFD) -- CJK extensions B to F. - , (0x30000, 0x3FFFD) -- CJK extensions G and later. + [ (0x1100, 0x115F) -- Hangul Jamo initials. + , (0x2329, 0x232A) -- Angle brackets. + , (0x2E80, 0x303E) -- CJK radicals, Kangxi and CJK symbols. + , (0x3041, 0x33FF) -- Kana, Bopomofo, Jamo and compatibility. + , (0x3400, 0x4DBF) -- CJK extension A. + , (0x4E00, 0x9FFF) -- CJK unified ideographs. + , (0xA000, 0xA4CF) -- Yi syllables. + , (0xA960, 0xA97F) -- Hangul Jamo extended A. + , (0xAC00, 0xD7A3) -- Hangul syllables. + , (0xF900, 0xFAFF) -- CJK compatibility ideographs. + , (0xFE10, 0xFE19) -- Vertical forms. + , (0xFE30, 0xFE6F) -- CJK compatibility forms. + , (0xFF00, 0xFF60) -- Fullwidth forms. + , (0xFFE0, 0xFFE6) -- Fullwidth signs. + , (0x1F004, 0x1F004) -- Mahjong red dragon. + , (0x1F0CF, 0x1F0CF) -- Playing card joker. + , (0x1F18E, 0x1F18E) -- Squared AB. + , (0x1F191, 0x1F19A) -- Squared symbols. + , (0x1F200, 0x1F2FF) -- Enclosed ideographic supplement. + , (0x1F300, 0x1F64F) -- Pictographs and emoticons. + , (0x1F680, 0x1F6FF) -- Transport and map symbols. + , (0x1F780, 0x1F7FF) -- Geometric shapes extended. + , (0x1F900, 0x1F9FF) -- Supplemental pictographs. + , (0x1FA70, 0x1FAFF) -- Pictographs extended A. + , (0x20000, 0x2FFFD) -- CJK extensions B to F. + , (0x30000, 0x3FFFD) -- CJK extensions G and later. ] diff --git a/src/Ansiform/Line.hs b/src/Ansiform/Line.hs --- a/src/Ansiform/Line.hs +++ b/src/Ansiform/Line.hs @@ -1,6 +1,10 @@ -- | Pure single-line editing for prefilled form fields. -module Ansiform.Line (LineState (..), LineKey (..), applyLineKey, - visibleLine) where +module Ansiform.Line + ( LineState (..) + , LineKey (..) + , applyLineKey + , visibleLine + ) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Line +import Ansiform.Internal.Line diff --git a/src/Ansiform/Number.hs b/src/Ansiform/Number.hs --- a/src/Ansiform/Number.hs +++ b/src/Ansiform/Number.hs @@ -1,20 +1,26 @@ -- | Non-negative numbers used for widths, offsets and padding. -module Ansiform.Number ( Number - , Width - , Padding - , Offset - , formNumber - , unNumber - , addNumber - , subtractNumber - , subtractNumberMaybe - ) where +module Ansiform.Number + ( Number + , Width + , Padding + , Offset + , formNumber + , unNumber + , addNumber + , subtractNumber + , subtractNumberMaybe + ) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Number (Number, Width, Padding, Offset, - formNum, unn) +import Ansiform.Internal.Number + ( Number + , Offset + , Padding + , Width + , formNum + , unn + ) import qualified Ansiform.Internal.Number as Internal - -- | Builds a 'Number', capping negative values at zero. formNumber :: Int -> Number diff --git a/src/Ansiform/Page.hs b/src/Ansiform/Page.hs --- a/src/Ansiform/Page.hs +++ b/src/Ansiform/Page.hs @@ -1,12 +1,16 @@ -- | Page builders and runners. -module Ansiform.Page ( module Ansiform.Page, Internal.Page, Internal.runPage - , Internal.runPageDefault, Internal.runPageDefault' - ) where +module Ansiform.Page + ( module Ansiform.Page + , Internal.Page + , Internal.runPage + , Internal.runPageDefault + , Internal.runPageDefault' + ) where +import Ansiform.Internal.Number -------------------------------------------------------------------------------- -import Ansiform.Internal.Page as Internal -import Ansiform.Internal.Number -import Ansiform.Internal.Section +import Ansiform.Internal.Page as Internal +import Ansiform.Internal.Section -- Page Builders -------------------------------------------------------------------------------- @@ -17,11 +21,13 @@ -- | Replaces one section at the given index. amendPage :: Page -> Section -> Number -> Page -amendPage p s n = amendPage' p [s] n +amendPage p s = amendPage' p [s] -- | Replaces the sections from the given index onwards. amendPage' :: Page -> [Section] -> Number -> Page amendPage' p ss n = formPage $ starter ++ remainder - where p' = unPage p; n' = unn n - remainder = ss ++ drop (n' + length ss) p' - starter = take n' p' + where + p' = unPage p + n' = unn n + remainder = ss ++ drop (n' + length ss) p' + starter = take n' p' diff --git a/src/Ansiform/Printer.hs b/src/Ansiform/Printer.hs --- a/src/Ansiform/Printer.hs +++ b/src/Ansiform/Printer.hs @@ -1,22 +1,23 @@ -- | Printer builders for lines, lists, groups, tables and text. -module Ansiform.Printer ( module Ansiform.Printer - , Internal.Printer, Internal.runPrinter - , Internal.runPrinterOn - , Internal.runPrinterDefault - , Internal.runPrinterDefaultOn - , Internal.runPrinterDefault' - , Internal.runPrinterDefaultOn' - ) where +module Ansiform.Printer + ( module Ansiform.Printer + , Internal.Printer + , Internal.runPrinter + , Internal.runPrinterOn + , Internal.runPrinterDefault + , Internal.runPrinterDefaultOn + , Internal.runPrinterDefault' + , Internal.runPrinterDefaultOn' + ) where +import Ansiform.Content -------------------------------------------------------------------------------- -import Ansiform.Internal.Content -import Ansiform.Internal.Number -import Ansiform.Internal.Output (outputConfig) -import Ansiform.Internal.Printer as Internal -import Ansiform.Internal.Table (Borders, TableFormat, defaultTableFormat) -import Ansiform.Content -import Ansiform.Style - +import Ansiform.Internal.Content +import Ansiform.Internal.Number +import Ansiform.Internal.Output (outputConfig) +import Ansiform.Internal.Printer as Internal +import Ansiform.Internal.Table (Borders, TableFormat, defaultTableFormat) +import Ansiform.Style -- Basic Printing -------------------------------------------------------------------------------- @@ -29,7 +30,6 @@ printerItem :: Item -> Printer printerItem i = formPrinter "Item" $ \s -> printSingleItem s i - -- Rules & Solid Printing -------------------------------------------------------------------------------- @@ -49,7 +49,6 @@ printerSolid' :: Offset -> Color -> Printer printerSolid' o c = formPrinter "Solid'" $ \s -> printRule o (ruleSolid c) s - -- Line Printing -------------------------------------------------------------------------------- @@ -77,7 +76,6 @@ printerLineCenter :: Offset -> [Block] -> Printer printerLineCenter o bs = formPrinter "LineCenter" $ \s -> printLineCenter o bs s - -- Solid Text Printing -------------------------------------------------------------------------------- @@ -111,7 +109,6 @@ printerSolidLineCenter :: Offset -> Padding -> Color -> [Block] -> Printer printerSolidLineCenter o p c bs = formPrinter "SolidLineCenter" $ \s -> printSolidLine o p c bs printLineCenter s - -- List Printing -------------------------------------------------------------------------------- @@ -127,7 +124,6 @@ printerList' :: Offset -> Number -> [Block] -> Printer printerList' o l bs = formPrinter "List'" $ \s -> printList' o l bs s - -- Group Printing -------------------------------------------------------------------------------- @@ -137,146 +133,141 @@ -- | Printer for groups with evenly spaced columns. printerGroups :: Offset -> [Group] -> Printer -printerGroups o gs = formPrinter "Groups" $ \s -> - printGroups defaultTableFormat o 0 0 True False (groupAverage (outputConfig s) gs) s +printerGroups o gs = formPrinter "Groups" $ \s -> + printGroups defaultTableFormat o 0 0 True False (groupAverage (outputConfig s) gs) s -- | Printer for groups with minimum spaced columns. printerGroups' :: Offset -> [Group] -> Printer -printerGroups' o gs = formPrinter "Groups'" $ \s -> - printGroups defaultTableFormat o 0 0 False False (groupAverage (outputConfig s) gs) s +printerGroups' o gs = formPrinter "Groups'" $ \s -> + printGroups defaultTableFormat o 0 0 False False (groupAverage (outputConfig s) gs) s -- | Printer for evenly spaced groups, limiting the number of rows. printerGroupsLimited :: Offset -> Number -> [Group] -> Printer -printerGroupsLimited o r gs = formPrinter "GroupsLimited" $ \s -> - printGroups defaultTableFormat o 0 r True False (groupAverage (outputConfig s) gs) s +printerGroupsLimited o r gs = formPrinter "GroupsLimited" $ \s -> + printGroups defaultTableFormat o 0 r True False (groupAverage (outputConfig s) gs) s -- | Printer for minimum spaced groups, limiting the number of rows. printerGroupsLimited' :: Offset -> Number -> [Group] -> Printer -printerGroupsLimited' o r gs = formPrinter "GroupsLimited'" $ \s -> - printGroups defaultTableFormat o 0 r False False (groupAverage (outputConfig s) gs) s +printerGroupsLimited' o r gs = formPrinter "GroupsLimited'" $ \s -> + printGroups defaultTableFormat o 0 r False False (groupAverage (outputConfig s) gs) s -- | Printer for a list of Groups inside box borders, with minimum spaced columns. printerGroupsBordered :: Borders -> Offset -> Padding -> [Group] -> Printer printerGroupsBordered brd o p gs = formPrinter "GroupsBordered" $ \s -> - printBorderedGroups brd defaultTableFormat o p 0 False gs s + printBorderedGroups brd defaultTableFormat o p 0 False gs s -- | Printer for a list of Groups inside box borders, with evenly spaced columns. printerGroupsBordered' :: Borders -> Offset -> Padding -> [Group] -> Printer printerGroupsBordered' brd o p gs = formPrinter "GroupsBordered'" $ \s -> - printBorderedGroups brd defaultTableFormat o p 0 True gs s + printBorderedGroups brd defaultTableFormat o p 0 True gs s -- | Printer for Groups inside box borders, limiting the number of rows. printerGroupsBorderedLimited :: Borders -> Offset -> Padding -> Number -> [Group] -> Printer printerGroupsBorderedLimited brd o p r gs = formPrinter "GroupsBorderedLimited" $ \s -> - printBorderedGroups brd defaultTableFormat o p r False gs s + printBorderedGroups brd defaultTableFormat o p r False gs s -- | Printer for evenly spaced Groups inside box borders, limiting the number of rows. printerGroupsBorderedLimited' :: Borders -> Offset -> Padding -> Number -> [Group] -> Printer printerGroupsBorderedLimited' brd o p r gs = formPrinter "GroupsBorderedLimited'" $ \s -> - printBorderedGroups brd defaultTableFormat o p r True gs s - + printBorderedGroups brd defaultTableFormat o p r True gs s -- Table Printing -------------------------------------------------------------------------------- -- | Prints a table with a zebra background and minimum spaced columns. printerTable :: Offset -> Padding -> Maybe Table -> Printer -printerTable o p mt = formPrinter "Table" $ \s -> - printGroups defaultTableFormat o p 0 False True (unMaybeTable mt) s +printerTable o p mt = formPrinter "Table" $ \s -> + printGroups defaultTableFormat o p 0 False True (unMaybeTable mt) s -- | Prints a table with a zebra background and evenly spaced columns. printerTable' :: Offset -> Padding -> Maybe Table -> Printer -printerTable' o p mt = formPrinter "Table'" $ \s -> - printGroups defaultTableFormat o p 0 True True (unMaybeTable mt) s +printerTable' o p mt = formPrinter "Table'" $ \s -> + printGroups defaultTableFormat o p 0 True True (unMaybeTable mt) s -- | Prints a table with a zebra background, limiting the number of rows. printerTableLimited :: Offset -> Padding -> Number -> Maybe Table -> Printer -printerTableLimited o p r mt = formPrinter "TableLimited" $ \s -> - printGroups defaultTableFormat o p r False True (unMaybeTable mt) s +printerTableLimited o p r mt = formPrinter "TableLimited" $ \s -> + printGroups defaultTableFormat o p r False True (unMaybeTable mt) s -- | Prints an evenly spaced table, limiting the number of rows. printerTableLimited' :: Offset -> Padding -> Number -> Maybe Table -> Printer -printerTableLimited' o p r mt = formPrinter "TableLimited'" $ \s -> - printGroups defaultTableFormat o p r True True (unMaybeTable mt) s +printerTableLimited' o p r mt = formPrinter "TableLimited'" $ \s -> + printGroups defaultTableFormat o p r True True (unMaybeTable mt) s -- | Prints a formatted Table with alternating background, with minimum spaced columns. printerTableFormat :: TableFormat -> Offset -> Padding -> Maybe Table -> Printer printerTableFormat fmt o p mt = formPrinter "TableFormat" $ \s -> - printGroups fmt o p 0 False True (unMaybeTable mt) s + printGroups fmt o p 0 False True (unMaybeTable mt) s -- | Prints a formatted Table with alternating background, with evenly spaced columns. printerTableFormat' :: TableFormat -> Offset -> Padding -> Maybe Table -> Printer printerTableFormat' fmt o p mt = formPrinter "TableFormat'" $ \s -> - printGroups fmt o p 0 True True (unMaybeTable mt) s + printGroups fmt o p 0 True True (unMaybeTable mt) s -- | Prints a formatted Table limiting the number of rows, with minimum spaced columns. printerTableLimitedFormat :: TableFormat -> Offset -> Padding -> Number -> Maybe Table -> Printer printerTableLimitedFormat fmt o p r mt = formPrinter "TableLimitedFormat" $ \s -> - printGroups fmt o p r False True (unMaybeTable mt) s + printGroups fmt o p r False True (unMaybeTable mt) s -- | Prints a formatted Table limiting the number of rows, with evenly spaced columns. printerTableLimitedFormat' :: TableFormat -> Offset -> Padding -> Number -> Maybe Table -> Printer printerTableLimitedFormat' fmt o p r mt = formPrinter "TableLimitedFormat'" $ \s -> - printGroups fmt o p r True True (unMaybeTable mt) s + printGroups fmt o p r True True (unMaybeTable mt) s -- | Prints a bordered Table with minimum spaced columns. printerTableBordered :: Borders -> TableFormat -> Offset -> Padding -> Maybe Table -> Printer printerTableBordered brd fmt o p mt = formPrinter "TableBordered" $ \s -> - printBorderedGroups brd fmt o p 0 False (unMaybeTable mt) s + printBorderedGroups brd fmt o p 0 False (unMaybeTable mt) s -- | Prints a bordered Table with evenly spaced columns. printerTableBordered' :: Borders -> TableFormat -> Offset -> Padding -> Maybe Table -> Printer printerTableBordered' brd fmt o p mt = formPrinter "TableBordered'" $ \s -> - printBorderedGroups brd fmt o p 0 True (unMaybeTable mt) s + printBorderedGroups brd fmt o p 0 True (unMaybeTable mt) s -- | Prints a bordered Table limiting the number of rows, with minimum spaced columns. printerTableBorderedLimited :: Borders -> TableFormat -> Offset -> Padding -> Number -> Maybe Table -> Printer printerTableBorderedLimited brd fmt o p r mt = formPrinter "TableBorderedLimited" $ \s -> - printBorderedGroups brd fmt o p r False (unMaybeTable mt) s + printBorderedGroups brd fmt o p r False (unMaybeTable mt) s -- | Prints a bordered Table limiting the number of rows, with evenly spaced columns. printerTableBorderedLimited' :: Borders -> TableFormat -> Offset -> Padding -> Number -> Maybe Table -> Printer printerTableBorderedLimited' brd fmt o p r mt = formPrinter "TableBorderedLimited'" $ \s -> - printBorderedGroups brd fmt o p r True (unMaybeTable mt) s - + printBorderedGroups brd fmt o p r True (unMaybeTable mt) s -- Text Printing -------------------------------------------------------------------------------- -- | Prints a continuous paragraph made from a list of blocks. printerParagraph :: Offset -> Offset -> Paragraph -> Printer -printerParagraph o o1 vbs = formPrinter "Paragraph" $ \s -> - printParagraph o o1 0 False vbs s +printerParagraph o o1 vbs = formPrinter "Paragraph" $ \s -> + printParagraph o o1 0 False vbs s -- | Prints paragraphs separated by a single line. printerArticle :: Offset -> Offset -> Article -> Printer -printerArticle o o1 vbss = formPrinter "Article" $ \s -> - printSequence o o1 0 False odd vbss s - +printerArticle o o1 vbss = formPrinter "Article" $ \s -> + printSequence o o1 0 False odd vbss s -- | Prints paragraphs with alternating backgrounds on odd entries. printerSequence :: Offset -> Offset -> Padding -> [Paragraph] -> Printer -printerSequence o o1 p vbss = formPrinter "Sequence" $ \s -> - printSequence o o1 p True odd vbss s +printerSequence o o1 p vbss = formPrinter "Sequence" $ \s -> + printSequence o o1 p True odd vbss s -- | Version of 'printerSequence' that highlights even entries. printerSequence' :: Offset -> Offset -> Padding -> [Paragraph] -> Printer -printerSequence' o o1 p vbss = formPrinter "Sequence'" $ \s -> - printSequence o o1 p True even vbss s +printerSequence' o o1 p vbss = formPrinter "Sequence'" $ \s -> + printSequence o o1 p True even vbss s -- | Prints paragraphs highlighting one selected index. printerSequenceSel :: Offset -> Offset -> Padding -> Number -> [Paragraph] -> Printer -printerSequenceSel o o1 p i vbss = formPrinter "SequenceSel" $ \s -> - printSequence o o1 p True (==unn i) vbss s +printerSequenceSel o o1 p i vbss = formPrinter "SequenceSel" $ \s -> + printSequence o o1 p True (== unn i) vbss s -- | Prints paragraphs highlighting entries at or after an index. printerSequenceAfter :: Offset -> Offset -> Padding -> Number -> [Paragraph] -> Printer -printerSequenceAfter o o1 p i vbss = formPrinter "SequenceAfter" $ \s -> - printSequence o o1 p True (>=unn i) vbss s +printerSequenceAfter o o1 p i vbss = formPrinter "SequenceAfter" $ \s -> + printSequence o o1 p True (>= unn i) vbss s -- | Prints paragraphs highlighting entries selected by a predicate. printerSequencePred :: Offset -> Offset -> Padding -> (Int -> Bool) -> [Paragraph] -> Printer -printerSequencePred o o1 p f vbss = formPrinter "SequencePred" $ \s -> - printSequence o o1 p True f vbss s - - +printerSequencePred o o1 p f vbss = formPrinter "SequencePred" $ \s -> + printSequence o o1 p True f vbss s diff --git a/src/Ansiform/Render.hs b/src/Ansiform/Render.hs --- a/src/Ansiform/Render.hs +++ b/src/Ansiform/Render.hs @@ -2,4 +2,4 @@ module Ansiform.Render (renderPage, renderSection, renderPrinter) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Render +import Ansiform.Internal.Render diff --git a/src/Ansiform/Sample.hs b/src/Ansiform/Sample.hs --- a/src/Ansiform/Sample.hs +++ b/src/Ansiform/Sample.hs @@ -1,5 +1,5 @@ -- | Inspection helpers for the values built by the library. -module Ansiform.Sample (Sample(..)) where +module Ansiform.Sample (Sample (..)) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Sample +import Ansiform.Internal.Sample diff --git a/src/Ansiform/Section.hs b/src/Ansiform/Section.hs --- a/src/Ansiform/Section.hs +++ b/src/Ansiform/Section.hs @@ -1,64 +1,61 @@ -- | Section builders and runners. -module Ansiform.Section ( module Ansiform.Section - , Internal.Section, Internal.runSection - , Internal.runSectionDefault, Internal.runSectionDefault' - ) where +module Ansiform.Section + ( module Ansiform.Section + , Internal.Section + , Internal.runSection + , Internal.runSectionDefault + , Internal.runSectionDefault' + ) where +import Ansiform.Content -------------------------------------------------------------------------------- -import Ansiform.Internal.Number -import Ansiform.Internal.Section as Internal -import Ansiform.Content -import Ansiform.Printer - +import Ansiform.Internal.Number +import Ansiform.Internal.Section as Internal +import Ansiform.Printer -- Section Builders -------------------------------------------------------------------------------- -- | Builds the simplest section from a list of printers. -section :: [Printer] -> Section +section :: [Printer] -> Section section = section' 0 -- | Builds a section with a minimum number of lines. -section' :: Number -> [Printer] -> Section -section' n = formSection n - +section' :: Number -> [Printer] -> Section +section' = formSection -- | Builds a section that prints a single rule. sectionRule :: Rule -> Section -sectionRule r = formSection 1 [ printerRule r ] - +sectionRule r = formSection 1 [printerRule r] -- | Builds a section with empty lines above and below the printers. sectionBody :: Number -> [Printer] -> Section -sectionBody n ps = sectionBody' 0 n ps +sectionBody = sectionBody' 0 -- | Like 'sectionBody', with an additional minimum number of lines. sectionBody' :: Number -> Number -> [Printer] -> Section -sectionBody' m n ps = formSection m $ [ printerEmpty n ] ++ ps ++ [ printerEmpty n ] - +sectionBody' m n ps = formSection m $ [printerEmpty n] ++ ps ++ [printerEmpty n] -- | Builds a section preceded by a rule and with empty lines above and below. sectionBodyRule :: Number -> Rule -> [Printer] -> Section -sectionBodyRule n r ps = sectionBodyRule' 0 n r ps +sectionBodyRule = sectionBodyRule' 0 -- | Like 'sectionBodyRule', with an additional minimum number of lines. sectionBodyRule' :: Number -> Number -> Rule -> [Printer] -> Section -sectionBodyRule' m n r ps = formSection m $ [ printerRule r, printerEmpty n ] ++ ps ++ [ printerEmpty n ] - +sectionBodyRule' m n r ps = formSection m $ [printerRule r, printerEmpty n] ++ ps ++ [printerEmpty n] -- | Builds a section with empty lines only below the printers. sectionTop :: Number -> [Printer] -> Section -sectionTop n ps = sectionTop' 0 n ps +sectionTop = sectionTop' 0 -- | Like 'sectionTop', with an additional minimum number of lines. sectionTop' :: Number -> Number -> [Printer] -> Section -sectionTop' m n ps = formSection m $ ps ++ [ printerEmpty n ] - +sectionTop' m n ps = formSection m $ ps ++ [printerEmpty n] -- | Builds a section preceded by a rule and with empty lines below. sectionTopRule :: Number -> Rule -> [Printer] -> Section -sectionTopRule n r ps = sectionTopRule' 0 n r ps +sectionTopRule = sectionTopRule' 0 -- | Like 'sectionTopRule', with an additional minimum number of lines. sectionTopRule' :: Number -> Number -> Rule -> [Printer] -> Section -sectionTopRule' m n r ps = formSection m $ [ printerRule r ] ++ ps ++ [ printerEmpty n ] +sectionTopRule' m n r ps = formSection m $ [printerRule r] ++ ps ++ [printerEmpty n] diff --git a/src/Ansiform/Settings.hs b/src/Ansiform/Settings.hs --- a/src/Ansiform/Settings.hs +++ b/src/Ansiform/Settings.hs @@ -1,15 +1,14 @@ -- | Settings and configuration modifiers. -module Ansiform.Settings (module Ansiform.Settings - , Internal.Config - , Internal.Settings - , Internal.ColorMode(..) - ) where - +module Ansiform.Settings + ( module Ansiform.Settings + , Internal.Config + , Internal.Settings + , Internal.ColorMode (..) + ) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Number -import Ansiform.Internal.Settings as Internal - +import Ansiform.Internal.Number +import Ansiform.Internal.Settings as Internal -- Default Settings -------------------------------------------------------------------------------- @@ -21,7 +20,6 @@ -- | The settings that use only the terminal defaults. defaultSettings :: Settings defaultSettings = formSettings [] - -- Configuration modifiers -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Style.hs b/src/Ansiform/Style.hs --- a/src/Ansiform/Style.hs +++ b/src/Ansiform/Style.hs @@ -1,13 +1,15 @@ -- | Colors, formats and reusable styles. -module Ansiform.Style ( module Ansiform.Style - , Internal.Color, Internal.Format, Internal.Style - ) where +module Ansiform.Style + ( module Ansiform.Style + , Internal.Color + , Internal.Format + , Internal.Style + ) where +import Ansiform.Internal.Style as Internal -------------------------------------------------------------------------------- import qualified System.Console.ANSI as ANSI -import Ansiform.Internal.Style as Internal - -- Colors -------------------------------------------------------------------------------- @@ -55,7 +57,6 @@ white = formColor Dull ANSI.White white' = formColor Vivid ANSI.White - -- Formats -------------------------------------------------------------------------------- @@ -80,7 +81,6 @@ formatItalicUnderline = formFormat NormalIntensity True SingleUnderline formatBoldItalicUnderline = formFormat BoldIntensity True SingleUnderline - -- Styles -------------------------------------------------------------------------------- @@ -110,7 +110,6 @@ solid c = formStyle black c formatDefault solidBold c = formStyle black c formatBold - -- Text Styles -------------------------------------------------------------------------------- @@ -136,5 +135,5 @@ -- | Colored text, or colored text on a solid background. textColor, textMark :: Color -> Style -textColor = normal +textColor = normal textMark = solid diff --git a/src/Ansiform/Table.hs b/src/Ansiform/Table.hs --- a/src/Ansiform/Table.hs +++ b/src/Ansiform/Table.hs @@ -1,9 +1,9 @@ -- | Per-column alignment and truncation for tables. module Ansiform.Table - ( Align(..) - , Borders(..) - , Ellipsis(..) - , ColumnSpec(..) + ( Align (..) + , Borders (..) + , Ellipsis (..) + , ColumnSpec (..) , TableFormat , defaultColumnSpec , defaultTableFormat @@ -11,8 +11,7 @@ ) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Table - +import Ansiform.Internal.Table -- Builders -------------------------------------------------------------------------------- diff --git a/src/Ansiform/Theme.hs b/src/Ansiform/Theme.hs --- a/src/Ansiform/Theme.hs +++ b/src/Ansiform/Theme.hs @@ -1,25 +1,25 @@ -- | Reusable styles for headers, footers, menus and tables. -module Ansiform.Theme (Theme(..), defaultTheme) where +module Ansiform.Theme (Theme (..), defaultTheme) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Theme -import Ansiform.Style - +import Ansiform.Internal.Theme +import Ansiform.Style -- Default Theme -------------------------------------------------------------------------------- -- | The default interface theme. defaultTheme :: Theme -defaultTheme = Theme - { themeHeader = bold white' - , themeSubtitle = bold yellow - , themeFooter = italic white - , themeAccent = bold cyan - , themeDanger = bold red' - , themeMuted = italic white - , themeRule = bold black' - , themeBar = blue - , themeTableHeader = bold yellow - , themeTableBody = normal blue' - } +defaultTheme = + Theme + { themeHeader = bold white' + , themeSubtitle = bold yellow + , themeFooter = italic white + , themeAccent = bold cyan + , themeDanger = bold red' + , themeMuted = italic white + , themeRule = bold black' + , themeBar = blue + , themeTableHeader = bold yellow + , themeTableBody = normal blue' + } diff --git a/src/Ansiform/Width.hs b/src/Ansiform/Width.hs --- a/src/Ansiform/Width.hs +++ b/src/Ansiform/Width.hs @@ -2,4 +2,4 @@ module Ansiform.Width (charWidth, textWidth) where -------------------------------------------------------------------------------- -import Ansiform.Internal.Width +import Ansiform.Internal.Width diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,266 +1,377 @@ -- | Small regression suite for the pure core of the library. module Main where -import Control.Monad (unless) -import Data.List (isInfixOf) -import Data.Maybe (isJust, isNothing) -import GHC.IO.Handle (hDuplicate, hDuplicateTo) -import System.Directory (getTemporaryDirectory, removeFile) -import System.Exit (exitFailure) -import System.IO (hClose, hFlush, hPutStr, hSeek, openTempFile, - readFile', SeekMode (AbsoluteSeek), stdin, stdout) -import Ansiform +import Ansiform +import Control.Monad (unless) +import Data.List (isInfixOf) +import Data.Maybe (isJust, isNothing) +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.Directory (getTemporaryDirectory, removeFile) +import System.Exit (exitFailure) +import System.IO + ( SeekMode (AbsoluteSeek) + , hClose + , hFlush + , hPutStr + , hSeek + , openTempFile + , readFile' + , stdin + , stdout + ) main :: IO () main = do - results <- sequence - [ test "Number caps negative values" - (unNumber (formNumber (-7)) == 0) - , test "Number keeps positive values" - (unNumber (formNumber 12) == 12) - , test "Number addition" - (unNumber (3 + 4 :: Number) == 7) - , test "Number subtraction caps at zero" - (unNumber (2 - 5 :: Number) == 0) - , test "Number checked subtraction rejects negative results" - (subtractNumberMaybe 2 5 == Nothing - && subtractNumberMaybe 5 2 == Just 3) - , test "Number explicit subtraction caps at zero" - (unNumber (subtractNumber 2 5) == 0) - , test "Number negation caps at zero" - (unNumber (negate (5 :: Number)) == 0) - , test "Number signum" - (unNumber (signum (0 :: Number)) == 0 - && unNumber (signum (5 :: Number)) == 1) - , test "Balanced block table is accepted" - (isJust (tableBlocks header [row])) - , test "Unbalanced block table is rejected" - (isNothing (tableBlocks header [[blockSimple "only" styleDefault]])) - , test "Balanced simple table is accepted" - (isJust (tableSimple header styleDefault [["a", "b"]])) - , test "Unbalanced simple table is rejected" - (isNothing (tableSimple header styleDefault [["a"]])) - , test "Balanced group table is accepted" - (isJust (tableGroups [balancedGroup, otherBalancedGroup])) - , test "Unbalanced group table is rejected" - (isNothing (tableGroups [balancedGroup, shortGroup])) - , test "Items are stripped of non-printable characters" - (let out = sampleShow 0 (item "a\tb\nc" styleDefault) - in "\"abc\"" `isInfixOf` out - && not ("\\" `isInfixOf` out)) - , test "Empty items are removed from blocks" - (let out = sampleShow 0 (block [ item "" styleDefault - , item "kept" styleDefault ]) - in "kept" `isInfixOf` out - && not ("\"\"" `isInfixOf` out)) - , test "Composite block builder keeps its parts" - (let out = sampleShow 0 (blockEnum "01" "Item" blue) - in "01" `isInfixOf` out && "Item" `isInfixOf` out) - , test "Default theme provides readable accent and muted styles" - (themeAccent defaultTheme == bold cyan - && themeDanger defaultTheme == bold red' - && themeFooter defaultTheme == italic white - && themeMuted defaultTheme == italic white) - , test "Theme record update changes a style" - (themeAccent (defaultTheme { themeAccent = bold magenta }) == bold magenta) - , test "Page amendment replaces the selected section" - (let replaced = amendPage' oldPage [newSection] 0 - out = sampleShow 0 replaced - in "" `isInfixOf` out - && not ("" `isInfixOf` out) - && "
" `isInfixOf` out) - , test "Display width of ASCII text" - (charWidth 'a' == 1 && textWidth "abc" == 3) - , test "Display width of wide characters" - (charWidth '漢' == 2 && textWidth "a漢" == 3) - , test "Display width of combining marks" - (charWidth '\x0301' == 0 && textWidth "e\x0301" == 1) - , test "Display width of emoji" - (charWidth '😀' == 2) - , test "Display width of emoji modifiers" - (charWidth '\x1F3FB' == 0) - , test "Display width of Hangul medial jamo" - (charWidth '\x1161' == 0) - , test "Display width of fullwidth forms" - (charWidth '\xFF21' == 2) - , test "Line editor inserts at the end" - (applyLineKey (LineInsert 'c') (LineState "ab" 2) == LineState "abc" 3) - , test "Line editor inserts in the middle" - (applyLineKey (LineInsert 'b') (LineState "ac" 1) == LineState "abc" 2) - , test "Line editor inserts at the start" - (applyLineKey (LineInsert 'a') (LineState "bc" 0) == LineState "abc" 1) - , test "Line editor backspace removes the previous character" - (applyLineKey LineBackspace (LineState "abc" 2) == LineState "ac" 1) - , test "Line editor backspace at the start is a no-op" - (applyLineKey LineBackspace (LineState "abc" 0) == LineState "abc" 0) - , test "Line editor delete removes the character at the cursor" - (applyLineKey LineDelete (LineState "abc" 1) == LineState "ac" 1) - , test "Line editor delete at the end is a no-op" - (applyLineKey LineDelete (LineState "abc" 3) == LineState "abc" 3) - , test "Line editor movement stops at the buffer boundaries" - (applyLineKey LineMoveLeft (LineState "ab" 0) == LineState "ab" 0 - && applyLineKey LineMoveRight (LineState "ab" 2) == LineState "ab" 2) - , test "Line editor moves home and end" - (lineCursor (applyLineKey LineMoveHome (LineState "ab" 2)) == 0 - && lineCursor (applyLineKey LineMoveEnd (LineState "ab" 0)) == 2) - , test "Line editor ignores non-printable characters" - (applyLineKey (LineInsert '\t') (LineState "a" 1) == LineState "a" 1) - , test "Line window shows text that fits" - (visibleLine 10 (LineState "abc" 3) == ("abc", 3)) - , test "Line window scrolls to keep the cursor visible" - (visibleLine 5 (LineState "abcdef" 6) == ("cdef", 4)) - , test "Line window keeps wide characters aligned" - (visibleLine 5 (LineState "漢漢漢" 3) == ("漢漢", 4)) - , test "Line window keeps combining marks attached" - (visibleLine 5 (LineState "e\x0301x" 3) == ("e\x0301x", 2)) - , test "Line window keeps the cursor at the start" - (visibleLine 5 (LineState "abcde" 0) == ("abcd", 0)) - , test "Line window of an empty buffer" - (visibleLine 5 (LineState "" 0) == ("", 0)) - , test "Prompt without an initial value has no buffer" - (promptInitial (promptAt 0 0 0) == Nothing) - , test "Prompt with an initial value removes non-printable characters" - (promptInitial (promptWithInitial 0 0 0 "a\tb\nc") == Just "abc") - , testIO "Render printer without styling" $ do - out <- renderPrinter (printerItem (item "plain" (bold red))) - (settings [neverColors]) - return $ out == "plain\n" - , testIO "Page renders to a string" $ do - let p = page [section [printerLeft 0 (blockSimple "rendered" styleDefault)]] - out <- renderPage p (settings [width 20, neverColors]) - return $ "rendered" `isInfixOf` out - , testIO "Formatted table aligns and truncates columns" $ do - let tbl = tableSimple - [ blockSimple "Name" styleDefault - , blockSimple "Age" styleDefault ] - styleDefault - [ ["Alexandra", "7"] - , ["Bo", "42"] ] - fmt = tableFormat - [ defaultColumnSpec { columnMaxWidth = Just 4 - , columnEllipsis = EllipsisChar '.' } - , defaultColumnSpec { columnAlign = AlignRight } ] - out <- renderPrinter (printerTableFormat fmt 0 0 tbl) - (settings [width 30, neverColors]) - return $ all (`isInfixOf` out) ["Ale.", "Bo ", " 7", " 42"] - , testIO "Formatted table centers columns" $ do - let tbl = tableSimple - [ blockSimple "X" styleDefault ] - styleDefault - [ ["ab"], ["abcd"] ] - fmt = tableFormat - [ defaultColumnSpec { columnAlign = AlignCenter } ] - out <- renderPrinter (printerTableFormat fmt 0 0 tbl) - (settings [width 20, neverColors]) - return $ " ab " `isInfixOf` out - , testIO "Bordered table draws a box" $ do - let tbl = tableSimple - [ blockSimple "A" styleDefault - , blockSimple "B" styleDefault ] - styleDefault - [ ["x", "y"] ] - out <- renderPrinter - (printerTableBordered BordersLight defaultTableFormat 0 0 tbl) - (settings [width 40, neverColors]) - return $ all (`isInfixOf` out) ["┌", "│", "└", "x", "y"] - , testIO "Bordered groups pad unequal columns" $ do - let tall = groupSimple (blockSimple "A" styleDefault) - [ blockSimple "1" styleDefault - , blockSimple "2" styleDefault ] - short = groupSimple (blockSimple "B" styleDefault) [] - out <- renderPrinter - (printerGroupsBordered BordersAscii 0 0 [tall, short]) - (settings [width 30, neverColors]) - let outputLines = lines out - allSameWidth = case outputLines of - [] -> False - (firstLine:_) -> all ((== length firstLine) . length) outputLines - return $ length outputLines == 7 && allSameWidth - , testIO "BordersNone keeps tall tables in one borderless block" $ do - let long = replicate 10 'A' - tall = groupSimple (blockSimple long styleDefault) - [ blockSimple "1" styleDefault - , blockSimple "2" styleDefault ] - short = groupSimple (blockSimple "B" styleDefault) [] - out <- renderPrinter - (printerGroupsBordered BordersNone 0 0 [tall, short]) - (settings [width 15, neverColors]) - let outputLines = lines out - allSameWidth = case outputLines of - [] -> False - (firstLine:_) -> all ((== length firstLine) . length) outputLines - return $ length outputLines == 3 - && allSameWidth - && (long ++ " B") `isInfixOf` out - && not (any (`elem` "+|") out) - , testIO "Form rejects a prompt outside the page" $ do - let p = page [section [printerLeft 0 (blockSimple "one" styleDefault)]] - prompt = promptAt 9 0 0 - (result, _) <- captureStdout $ do - st <- start p (settings [neverColors]) - (_, formResult) <- readForm p [prompt] st - return formResult - return $ result == Left (PromptOutsidePage prompt) - , testIO "Form reads prompts in order" $ do - let p = page [section - [ printerLeft 0 (blockSimple "first" styleDefault) - , printerLeft 0 (blockSimple "second" styleDefault) ]] - prompts = [promptAt 0 0 7, promptAt 0 1 8] - (result, _) <- withStdin "Ada\n42\n" $ captureStdout $ do - st <- start p (settings [neverColors]) - (_, formResult) <- readForm p prompts st - return formResult - return $ result == Right ["Ada", "42"] - , testIO "Form ignores initial values when stdin is not a terminal" $ do - let p = page [section - [ printerLeft 0 (blockSimple "first" styleDefault) - , printerLeft 0 (blockSimple "second" styleDefault) ]] - prompts = [ promptWithInitial 0 0 7 "old" - , promptWithInitial 0 1 8 "note" ] - (result, _) <- withStdin "Ada\n42\n" $ captureStdout $ do - st <- start p (settings [neverColors]) - (_, formResult) <- readForm p prompts st - return formResult - return $ result == Right ["Ada", "42"] - , testIO "Shortcut reader returns a plain key" $ do - result <- withStdin "x" readKeyPress - return $ result == Just 'x' - , testIO "Shortcut reader ignores arrow escape sequences" $ do - result <- withStdin "\ESC[Aq" readKeyPress - return $ result == Just 'q' - , testIO "Shortcut reader ignores application cursor sequences" $ do - result <- withStdin "\ESCOBr" readKeyPress - return $ result == Just 'r' - , testIO "Shortcut reader ignores parameterized sequences" $ do - result <- withStdin "\ESC[1;5Bz" readKeyPress - return $ result == Just 'z' - , testIO "Shortcut reader reports end of input" $ do - result <- withStdin "" readKeyPress - return $ result == Nothing - , testIO "Raw key reader returns escape sequence characters" $ do - result <- withStdin "\ESC[A" (sequence [readKey, readKey, readKey]) - return $ result == [Just '\ESC', Just '[', Just 'A'] - , testIO "Wide text wraps by display width" $ do - (_, out) <- captureStdout - $ runPrinter (settings [width 5, neverColors]) - (printerParagraph 0 0 [blockSimple "漢漢 漢漢" styleDefault]) - return $ length (filter (== '\n') out) == 2 - , testIO "Styles are suppressed when colors are never" $ do - (_, out) <- captureStdout - $ runPrinter (settings [neverColors]) (printerItem (item "plain" (bold red))) - return $ '\ESC' `notElem` out && "plain" `isInfixOf` out - , testIO "Styles are emitted when colors are always" $ do - (_, out) <- captureStdout - $ runPrinter (settings [alwaysColors]) (printerItem (item "styled" (bold red))) - return $ '\ESC' `elem` out && "styled" `isInfixOf` out - ] - unless (and results) exitFailure - putStrLn "All tests passed." + results <- + sequence + [ test + "Number caps negative values" + (unNumber (formNumber (-7)) == 0) + , test + "Number keeps positive values" + (unNumber (formNumber 12) == 12) + , test + "Number addition" + (unNumber (3 + 4 :: Number) == 7) + , test + "Number subtraction caps at zero" + (unNumber (2 - 5 :: Number) == 0) + , test + "Number checked subtraction rejects negative results" + ( isNothing (subtractNumberMaybe 2 5) + && subtractNumberMaybe 5 2 == Just 3 + ) + , test + "Number explicit subtraction caps at zero" + (unNumber (subtractNumber 2 5) == 0) + , test + "Number negation caps at zero" + (unNumber (negate (5 :: Number)) == 0) + , test + "Number signum" + ( unNumber (signum (0 :: Number)) == 0 + && unNumber (signum (5 :: Number)) == 1 + ) + , test + "Balanced block table is accepted" + (isJust (tableBlocks header [row])) + , test + "Unbalanced block table is rejected" + (isNothing (tableBlocks header [[blockSimple "only" styleDefault]])) + , test + "Balanced simple table is accepted" + (isJust (tableSimple header styleDefault [["a", "b"]])) + , test + "Unbalanced simple table is rejected" + (isNothing (tableSimple header styleDefault [["a"]])) + , test + "Balanced group table is accepted" + (isJust (tableGroups [balancedGroup, otherBalancedGroup])) + , test + "Unbalanced group table is rejected" + (isNothing (tableGroups [balancedGroup, shortGroup])) + , test + "Items are stripped of non-printable characters" + ( let out = sampleShow 0 (item "a\tb\nc" styleDefault) + in "\"abc\"" `isInfixOf` out + && not ("\\" `isInfixOf` out) + ) + , test + "Empty items are removed from blocks" + ( let out = + sampleShow + 0 + ( block + [ item "" styleDefault + , item "kept" styleDefault + ] + ) + in "kept" `isInfixOf` out + && not ("\"\"" `isInfixOf` out) + ) + , test + "Composite block builder keeps its parts" + ( let out = sampleShow 0 (blockEnum "01" "Item" blue) + in "01" `isInfixOf` out && "Item" `isInfixOf` out + ) + , test + "Default theme provides readable accent and muted styles" + ( themeAccent defaultTheme == bold cyan + && themeDanger defaultTheme == bold red' + && themeFooter defaultTheme == italic white + && themeMuted defaultTheme == italic white + ) + , test + "Theme record update changes a style" + (themeAccent (defaultTheme{themeAccent = bold magenta}) == bold magenta) + , test + "Page amendment replaces the selected section" + ( let replaced = amendPage' oldPage [newSection] 0 + out = sampleShow 0 replaced + in "" `isInfixOf` out + && not ("" `isInfixOf` out) + && "
" `isInfixOf` out + ) + , test + "Display width of ASCII text" + (charWidth 'a' == 1 && textWidth "abc" == 3) + , test + "Display width of wide characters" + (charWidth '漢' == 2 && textWidth "a漢" == 3) + , test + "Display width of combining marks" + (charWidth '\x0301' == 0 && textWidth "e\x0301" == 1) + , test + "Display width of emoji" + (charWidth '😀' == 2) + , test + "Display width of emoji modifiers" + (charWidth '\x1F3FB' == 0) + , test + "Display width of Hangul medial jamo" + (charWidth '\x1161' == 0) + , test + "Display width of fullwidth forms" + (charWidth '\xFF21' == 2) + , test + "Line editor inserts at the end" + (applyLineKey (LineInsert 'c') (LineState "ab" 2) == LineState "abc" 3) + , test + "Line editor inserts in the middle" + (applyLineKey (LineInsert 'b') (LineState "ac" 1) == LineState "abc" 2) + , test + "Line editor inserts at the start" + (applyLineKey (LineInsert 'a') (LineState "bc" 0) == LineState "abc" 1) + , test + "Line editor backspace removes the previous character" + (applyLineKey LineBackspace (LineState "abc" 2) == LineState "ac" 1) + , test + "Line editor backspace at the start is a no-op" + (applyLineKey LineBackspace (LineState "abc" 0) == LineState "abc" 0) + , test + "Line editor delete removes the character at the cursor" + (applyLineKey LineDelete (LineState "abc" 1) == LineState "ac" 1) + , test + "Line editor delete at the end is a no-op" + (applyLineKey LineDelete (LineState "abc" 3) == LineState "abc" 3) + , test + "Line editor movement stops at the buffer boundaries" + ( applyLineKey LineMoveLeft (LineState "ab" 0) == LineState "ab" 0 + && applyLineKey LineMoveRight (LineState "ab" 2) == LineState "ab" 2 + ) + , test + "Line editor moves home and end" + ( lineCursor (applyLineKey LineMoveHome (LineState "ab" 2)) == 0 + && lineCursor (applyLineKey LineMoveEnd (LineState "ab" 0)) == 2 + ) + , test + "Line editor ignores non-printable characters" + (applyLineKey (LineInsert '\t') (LineState "a" 1) == LineState "a" 1) + , test + "Line window shows text that fits" + (visibleLine 10 (LineState "abc" 3) == ("abc", 3)) + , test + "Line window scrolls to keep the cursor visible" + (visibleLine 5 (LineState "abcdef" 6) == ("cdef", 4)) + , test + "Line window keeps wide characters aligned" + (visibleLine 5 (LineState "漢漢漢" 3) == ("漢漢", 4)) + , test + "Line window keeps combining marks attached" + (visibleLine 5 (LineState "e\x0301x" 3) == ("e\x0301x", 2)) + , test + "Line window keeps the cursor at the start" + (visibleLine 5 (LineState "abcde" 0) == ("abcd", 0)) + , test + "Line window of an empty buffer" + (visibleLine 5 (LineState "" 0) == ("", 0)) + , test + "Prompt without an initial value has no buffer" + (isNothing (promptInitial (promptAt 0 0 0))) + , test + "Prompt with an initial value removes non-printable characters" + (promptInitial (promptWithInitial 0 0 0 "a\tb\nc") == Just "abc") + , testIO "Render printer without styling" $ do + out <- + renderPrinter + (printerItem (item "plain" (bold red))) + (settings [neverColors]) + return $ out == "plain\n" + , testIO "Page renders to a string" $ do + let p = page [section [printerLeft 0 (blockSimple "rendered" styleDefault)]] + out <- renderPage p (settings [width 20, neverColors]) + return $ "rendered" `isInfixOf` out + , testIO "Formatted table aligns and truncates columns" $ do + let tbl = + tableSimple + [ blockSimple "Name" styleDefault + , blockSimple "Age" styleDefault + ] + styleDefault + [ ["Alexandra", "7"] + , ["Bo", "42"] + ] + fmt = + tableFormat + [ defaultColumnSpec + { columnMaxWidth = Just 4 + , columnEllipsis = EllipsisChar '.' + } + , defaultColumnSpec{columnAlign = AlignRight} + ] + out <- + renderPrinter + (printerTableFormat fmt 0 0 tbl) + (settings [width 30, neverColors]) + return $ all (`isInfixOf` out) ["Ale.", "Bo ", " 7", " 42"] + , testIO "Formatted table centers columns" $ do + let tbl = + tableSimple + [blockSimple "X" styleDefault] + styleDefault + [["ab"], ["abcd"]] + fmt = + tableFormat + [defaultColumnSpec{columnAlign = AlignCenter}] + out <- + renderPrinter + (printerTableFormat fmt 0 0 tbl) + (settings [width 20, neverColors]) + return $ " ab " `isInfixOf` out + , testIO "Bordered table draws a box" $ do + let tbl = + tableSimple + [ blockSimple "A" styleDefault + , blockSimple "B" styleDefault + ] + styleDefault + [["x", "y"]] + out <- + renderPrinter + (printerTableBordered BordersLight defaultTableFormat 0 0 tbl) + (settings [width 40, neverColors]) + return $ all (`isInfixOf` out) ["┌", "│", "└", "x", "y"] + , testIO "Bordered groups pad unequal columns" $ do + let tall = + groupSimple + (blockSimple "A" styleDefault) + [ blockSimple "1" styleDefault + , blockSimple "2" styleDefault + ] + short = groupSimple (blockSimple "B" styleDefault) [] + out <- + renderPrinter + (printerGroupsBordered BordersAscii 0 0 [tall, short]) + (settings [width 30, neverColors]) + let outputLines = lines out + allSameWidth = case outputLines of + [] -> False + (firstLine : _) -> all ((== length firstLine) . length) outputLines + return $ length outputLines == 7 && allSameWidth + , testIO "BordersNone keeps tall tables in one borderless block" $ do + let long = replicate 10 'A' + tall = + groupSimple + (blockSimple long styleDefault) + [ blockSimple "1" styleDefault + , blockSimple "2" styleDefault + ] + short = groupSimple (blockSimple "B" styleDefault) [] + out <- + renderPrinter + (printerGroupsBordered BordersNone 0 0 [tall, short]) + (settings [width 15, neverColors]) + let outputLines = lines out + allSameWidth = case outputLines of + [] -> False + (firstLine : _) -> all ((== length firstLine) . length) outputLines + return $ + length outputLines == 3 + && allSameWidth + && (long ++ " B") `isInfixOf` out + && not (any (`elem` "+|") out) + , testIO "Form rejects a prompt outside the page" $ do + let p = page [section [printerLeft 0 (blockSimple "one" styleDefault)]] + prompt = promptAt 9 0 0 + (result, _) <- captureStdout $ do + st <- start p (settings [neverColors]) + (_, formResult) <- readForm p [prompt] st + return formResult + return $ result == Left (PromptOutsidePage prompt) + , testIO "Form reads prompts in order" $ do + let p = + page + [ section + [ printerLeft 0 (blockSimple "first" styleDefault) + , printerLeft 0 (blockSimple "second" styleDefault) + ] + ] + prompts = [promptAt 0 0 7, promptAt 0 1 8] + (result, _) <- withStdin "Ada\n42\n" $ captureStdout $ do + st <- start p (settings [neverColors]) + (_, formResult) <- readForm p prompts st + return formResult + return $ result == Right ["Ada", "42"] + , testIO "Form ignores initial values when stdin is not a terminal" $ do + let p = + page + [ section + [ printerLeft 0 (blockSimple "first" styleDefault) + , printerLeft 0 (blockSimple "second" styleDefault) + ] + ] + prompts = + [ promptWithInitial 0 0 7 "old" + , promptWithInitial 0 1 8 "note" + ] + (result, _) <- withStdin "Ada\n42\n" $ captureStdout $ do + st <- start p (settings [neverColors]) + (_, formResult) <- readForm p prompts st + return formResult + return $ result == Right ["Ada", "42"] + , testIO "Shortcut reader returns a plain key" $ do + result <- withStdin "x" readKeyPress + return $ result == Just 'x' + , testIO "Shortcut reader ignores arrow escape sequences" $ do + result <- withStdin "\ESC[Aq" readKeyPress + return $ result == Just 'q' + , testIO "Shortcut reader ignores application cursor sequences" $ do + result <- withStdin "\ESCOBr" readKeyPress + return $ result == Just 'r' + , testIO "Shortcut reader ignores parameterized sequences" $ do + result <- withStdin "\ESC[1;5Bz" readKeyPress + return $ result == Just 'z' + , testIO "Shortcut reader reports end of input" $ do + result <- withStdin "" readKeyPress + return $ isNothing result + , testIO "Raw key reader returns escape sequence characters" $ do + result <- withStdin "\ESC[A" (sequence [readKey, readKey, readKey]) + return $ result == [Just '\ESC', Just '[', Just 'A'] + , testIO "Wide text wraps by display width" $ do + (_, out) <- + captureStdout $ + runPrinter + (settings [width 5, neverColors]) + (printerParagraph 0 0 [blockSimple "漢漢 漢漢" styleDefault]) + return $ length (filter (== '\n') out) == 2 + , testIO "Styles are suppressed when colors are never" $ do + (_, out) <- + captureStdout $ + runPrinter (settings [neverColors]) (printerItem (item "plain" (bold red))) + return $ '\ESC' `notElem` out && "plain" `isInfixOf` out + , testIO "Styles are emitted when colors are always" $ do + (_, out) <- + captureStdout $ + runPrinter (settings [alwaysColors]) (printerItem (item "styled" (bold red))) + return $ '\ESC' `elem` out && "styled" `isInfixOf` out + ] + unless (and results) exitFailure + putStrLn "All tests passed." test :: String -> Bool -> IO Bool test name passed = do - putStrLn ((if passed then "ok " else "FAIL ") ++ name) - return passed + putStrLn ((if passed then "ok " else "FAIL ") ++ name) + return passed testIO :: String -> IO Bool -> IO Bool testIO name action = action >>= test name @@ -269,47 +380,51 @@ -- the captured output. captureStdout :: IO a -> IO (a, String) captureStdout action = do - tmp <- getTemporaryDirectory - (path, handle) <- openTempFile tmp "ansiform-test-output" - original <- hDuplicate stdout - hDuplicateTo handle stdout - result <- action - hFlush stdout - hDuplicateTo original stdout - hClose original - hClose handle - output <- readFile' path - removeFile path - return (result, output) + tmp <- getTemporaryDirectory + (path, handle) <- openTempFile tmp "ansiform-test-output" + original <- hDuplicate stdout + hDuplicateTo handle stdout + result <- action + hFlush stdout + hDuplicateTo original stdout + hClose original + hClose handle + output <- readFile' path + removeFile path + return (result, output) -- Runs an action with stdin replaced by a temporary file containing the input. withStdin :: String -> IO a -> IO a withStdin input action = do - tmp <- getTemporaryDirectory - (path, handle) <- openTempFile tmp "ansiform-test-input" - hPutStr handle input - hFlush handle - hSeek handle AbsoluteSeek 0 - original <- hDuplicate stdin - hDuplicateTo handle stdin - result <- action - hDuplicateTo original stdin - hClose original - hClose handle - removeFile path - return result + tmp <- getTemporaryDirectory + (path, handle) <- openTempFile tmp "ansiform-test-input" + hPutStr handle input + hFlush handle + hSeek handle AbsoluteSeek 0 + original <- hDuplicate stdin + hDuplicateTo handle stdin + result <- action + hDuplicateTo original stdin + hClose original + hClose handle + removeFile path + return result -------------------------------------------------------------------------------- -- Fixtures -------------------------------------------------------------------------------- header :: [Block] -header = [ blockSimple "A" styleDefault - , blockSimple "B" styleDefault ] +header = + [ blockSimple "A" styleDefault + , blockSimple "B" styleDefault + ] row :: [Block] -row = [ blockSimple "1" styleDefault - , blockSimple "2" styleDefault ] +row = + [ blockSimple "1" styleDefault + , blockSimple "2" styleDefault + ] balancedGroup, otherBalancedGroup, shortGroup :: Group balancedGroup = groupSimple (blockSimple "Header" styleDefault) [rowBlock] @@ -320,9 +435,9 @@ rowBlock = blockSimple "value" styleDefault oldPage :: Page -oldPage = page [ oldSection, keptSection ] +oldPage = page [oldSection, keptSection] oldSection, keptSection, newSection :: Section -oldSection = section [ printerLeft 0 (blockSimple "old" styleDefault) ] -keptSection = section [ printerCenter 0 (blockSimple "kept" styleDefault) ] -newSection = section [ printerRight 0 (blockSimple "new" styleDefault) ] +oldSection = section [printerLeft 0 (blockSimple "old" styleDefault)] +keptSection = section [printerCenter 0 (blockSimple "kept" styleDefault)] +newSection = section [printerRight 0 (blockSimple "new" styleDefault)]