ansiform 1.0.0.1 → 1.1.0.0
raw patch · 27 files changed
+714/−294 lines, 27 filesdep +QuickCheckdep +textPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, text
API changes (from Hackage documentation)
+ Ansiform.Printer: printerName :: Printer -> String
Files
- CHANGELOG.md +22/−0
- README.md +2/−2
- ansiform.cabal +21/−5
- docs/architecture.md +1/−1
- docs/ports.md +1/−1
- docs/printers.md +8/−0
- docs/quality.md +11/−2
- docs/releasing.md +62/−16
- examples/Demo.hs +7/−4
- src/Ansiform/Content.hs +1/−1
- src/Ansiform/Draw.hs +2/−99
- src/Ansiform/Internal/Content.hs +1/−1
- src/Ansiform/Internal/Draw.hs +101/−0
- src/Ansiform/Internal/Input.hs +1/−1
- src/Ansiform/Internal/Line.hs +2/−2
- src/Ansiform/Internal/Page.hs +17/−1
- src/Ansiform/Internal/Printer.hs +46/−28
- src/Ansiform/Internal/Render.hs +17/−5
- src/Ansiform/Internal/Section.hs +2/−3
- src/Ansiform/Internal/State.hs +5/−4
- src/Ansiform/Internal/Style.hs +25/−13
- src/Ansiform/Internal/Table.hs +2/−3
- src/Ansiform/Internal/Utils.hs +0/−42
- src/Ansiform/Page.hs +2/−7
- src/Ansiform/Printer.hs +25/−21
- src/Ansiform/Style.hs +8/−8
- test/Spec.hs +322/−24
CHANGELOG.md view
@@ -4,6 +4,28 @@ ## Functional Versions +### 1.1.0.0 -- 2026-10-24+* Removed the unlawful `Eq` instances from `Printer`, `Section` and `Page`. The old `Eq Printer` compared only the diagnostic label, so two different printers could be equal; `Section` and `Page` cannot keep `Eq` because they contain printers.+* Added `printerName :: Printer -> String` for diagnostics. `printerSequencePred` and the function-based `Printer` are unchanged.+* Rendering output is unchanged; the property suite and the golden corpus pass.+* Updated the release checklist for 1.1.0.0 and documented that the Hackage token belongs in `~/.cabal/config` with mode `600`, so it never enters the command line.+* Documented that Fourmolu and HLint must be installed one at a time because their `ghc-lib-parser` bounds do not resolve together.++### 1.0.0.3 -- 2026-10-24+* Added a QuickCheck property suite with a fixed seed for display width, line editing, visible windows, table invariants, Number arithmetic and paragraph wrapping.+* Added an inline golden corpus for paragraph wrapping, Unicode text, bordered groups and pages; cursor movement sequences are stripped before the comparison.+* No production code changed.++### 1.0.0.2 -- 2026-10-24+* Added the compiler gates to the shared Cabal stanza. The `werror` flag adds `-Werror`; `cabal.project` enables it locally and CI passes `-fwerror`, while the default stays false so `cabal check` and Hackage builds remain valid.+* Replaced the banned partial functions `init`, `last` and `read` in the line editor, the table truncation and the demo.+* The demo version now comes from `Paths_ansiform`, so it follows the package version.+* The render capture reads the temporary handle as strict UTF-8, so non-ASCII output round-trips.+* Replaced the Boolean modes in the group printer with `Spacing` and `GroupMode`, and the italic flag in `Format` with `Italic`.+* Moved the drawing implementation to `Ansiform.Internal.Draw`; `Ansiform.Draw` is now a facade and internal modules no longer import public facades.+* Declared the `directory` bound once in a common stanza and removed unused helpers from `Ansiform.Internal.Utils`.+* The test harness restores stdin and stdout with `bracket` and `finally`.+ ### 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.
README.md view
@@ -10,7 +10,7 @@ > **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.1**.+Current version: **1.1.0.0**. Repository: <https://github.com/Tralen/ansiform>. @@ -50,7 +50,7 @@ - Multi-section pages with amend, replace and redraw support. - Errors as data: malformed tables return `Nothing` instead of throwing. - Explicit saturating and checked subtraction for non-negative `Number` values.-- Small dependency footprint: `ansi-terminal`, `terminal-size`, `split`, `transformers` and `directory`.+- Small dependency footprint: `ansi-terminal`, `terminal-size`, `split`, `text`, `transformers` and `directory`. ## Quick start
ansiform.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ansiform-version: 1.0.0.1+version: 1.1.0.0 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.@@ -37,13 +37,25 @@ docs/tutorial.md extra-source-files: fourmolu.yaml +flag werror+ description: Treat compiler warnings as errors.+ default: False+ manual: True+ common shared default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -Wcompat -Wincomplete-patterns+ -Wincomplete-uni-patterns+ if flag(werror)+ ghc-options: -Werror build-depends: base >= 4.10 && < 5 +common directory-dep+ build-depends: directory >= 1.3 && < 1.4+ library import: shared+ , directory-dep exposed-modules: Ansiform , Ansiform.Content@@ -64,6 +76,7 @@ other-modules: Ansiform.Internal , Ansiform.Internal.Content+ , Ansiform.Internal.Draw , Ansiform.Internal.Input , Ansiform.Internal.Line , Ansiform.Internal.Number@@ -83,9 +96,9 @@ , Ansiform.Internal.Width build-depends: ansi-terminal >= 0.8 && < 1.2- , directory >= 1.3 && < 1.4- , terminal-size >= 0.3 && < 0.4 , split >= 0.2 && < 0.3+ , terminal-size >= 0.3 && < 0.4+ , text >= 1.2 && < 2.3 , transformers >= 0.5 && < 0.7 hs-source-dirs: src@@ -95,6 +108,8 @@ main-is: Demo.hs hs-source-dirs: examples+ other-modules: Paths_ansiform+ autogen-modules: Paths_ansiform build-depends: ansiform if os(windows) ghc-options: -with-rtsopts=--io-manager=winio@@ -110,12 +125,13 @@ test-suite ansiform-test import: shared+ , directory-dep type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test build-depends: ansiform- , directory >= 1.3 && < 1.4+ , QuickCheck >= 2.14 && < 2.15 source-repository head type: git
docs/architecture.md view
@@ -43,7 +43,7 @@ +--------------------------------------------------------------+ ``` -`Printer` stores a function `Output -> IO Number`. `Output` combines the target `Handle` with the `Config` resolved for it. The function is created by a pure builder, but it runs only when a section or page is drawn. This keeps the description of a screen pure while allowing the drawing layer to query the terminal width and move the cursor.+`Printer` stores a function `Output -> IO Number`. `Output` combines the target `Handle` with the `Config` resolved for it. The function is created by a pure builder, but it runs only when a section or page is drawn. This keeps the description of a screen pure while allowing the drawing layer to query the terminal width and move the cursor. It has no `Eq` instance because functions cannot be compared structurally; `printerName` returns only the diagnostic label. The default runners write to stdout. The `On` variants accept any handle, and `Ansiform.Render` captures the same output in a `String` through a temporary handle.
docs/ports.md view
@@ -20,7 +20,7 @@ ### What complicates - **Ownership and lifetimes:** choosing between `&str`, `String`, `Cow<'static, str>` and `Arc<str>` 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<dyn Fn(&mut dyn Write, &Config) -> io::Result<usize>>`. An enum tends to be better for tests and composition; a trait is better for extensibility. This choice defines the API.+- **Representing `Printer`:** in Haskell, `Printer` stores a function and has no `Eq`; the label returned by `printerName` is diagnostic only. In Rust there are two options: an enum that represents the printing AST plus an interpreter, or `Box<dyn Fn(&mut dyn Write, &Config) -> io::Result<usize>>`. 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<usize>` 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<char>`, 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.
docs/printers.md view
@@ -158,3 +158,11 @@ - `printerParagraph` wraps the blocks at the terminal width. - `printerArticle` prints paragraphs separated by a blank line. - The `printerSequence` variants add a solid background to selected paragraphs: `printerSequence` selects odd indices, `printerSequence'` selects even indices, `printerSequenceSel` selects one index, `printerSequenceAfter` selects indices greater than or equal to a value, and `printerSequencePred` accepts any predicate.++## Inspection++```haskell+printerName :: Printer -> String+```++`Printer` has no `Eq` instance because it is a function; the old label-only equality was removed in 1.1.0.0. `printerName` returns the diagnostic label printed by `Show`; compare rendered output when the actual result matters.
docs/quality.md view
@@ -13,6 +13,10 @@ The first command reports files that would change and fails when any file is not formatted. The second rewrites them. +## Compiler gates++The shared Cabal stanza declares `-Wall -Wcompat -Wincomplete-patterns` and `-Wincomplete-uni-patterns`. The `werror` Cabal flag adds `-Werror`; `cabal.project` enables it for local builds and CI passes `-fwerror`. The flag defaults to false so `cabal check` and Hackage builds stay valid, while local and CI builds still enforce `-Werror`.+ ## Linting HLint 3.10 checks the same three directories:@@ -34,6 +38,10 @@ 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. +## Tests++The suite uses QuickCheck 2.14 with a fixed seed for the properties, and an inline golden corpus for paragraph wrapping, Unicode text, bordered groups and pages. `stripCsi` removes the cursor movement sequences before a golden comparison, so the expected output is layout-only and portable.+ ## Continuous integration `.github/workflows/ci.yml` has two jobs:@@ -47,10 +55,11 @@ ## Local setup -Fourmolu has release binaries for Linux and macOS, and HLint also ships a Windows binary. Both can be installed with Cabal:+Fourmolu has release binaries for Linux and macOS, and HLint also ships a Windows binary. Both can be installed with Cabal, one at a time, because their `ghc-lib-parser` bounds do not resolve together: ```sh-cabal install --installdir="$HOME/.local/bin" --overwrite-policy=always fourmolu-0.21.0.0 hlint-3.10+cabal install --installdir="$HOME/.local/bin" --overwrite-policy=always fourmolu-0.21.0.0+cabal install --installdir="$HOME/.local/bin" --overwrite-policy=always 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`.
docs/releasing.md view
@@ -5,7 +5,8 @@ ## Current status - Package: `ansiform`. The name is already registered on Hackage.-- Version: 1.0.0.1.+- Version: 1.1.0.0, the release that removes the unlawful `Eq` instances and adds `printerName`.+- The previous published release is 1.0.0.1. The 1.1.0.0 candidate is built from the signed tag and reviewed before publication. - License: MIT. - `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.@@ -13,10 +14,11 @@ - GitHub: public at <https://github.com/Tralen/ansiform>; 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 `1.0.0` and its GitHub release are published at <https://github.com/Tralen/ansiform/releases/tag/1.0.0>.-- Hackage: 1.0.0 is published at <https://hackage.haskell.org/package/ansiform-1.0.0>, 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.+- Tag `1.0.0.1` and its GitHub release are published at <https://github.com/Tralen/ansiform/releases/tag/1.0.0.1>.+- Hackage: 1.0.0.1 is published at <https://hackage.haskell.org/package/ansiform-1.0.0.1>, with documentation uploaded.+- The 1.0.0 release marked the library stable and drew 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 added Fourmolu, HLint, gitleaks, the Intel macOS CI job and the manual release workflow. 1.0.0.2 applied the non-breaking compliance patch, and 1.0.0.3 added the QuickCheck and golden tests.+- 1.1.0.0 removes the unlawful `Eq` instances from `Printer`, `Section` and `Page` and adds `printerName`. It is the first release whose tag is signed with the configured SSH key; the 1.0.0.1 tag remains annotated and unsigned because it was published before the key was configured. ## Credentials @@ -24,20 +26,28 @@ ### Hackage -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:+Store the token in the global Cabal configuration, outside any `repository` stanza, and restrict the file: ```sh-cabal upload --token "$HACKAGE_TOKEN" dist-newstyle/sdist/ansiform-<version>.tar.gz+chmod 600 ~/.cabal/config ``` -For documentation:+Add the line `token: <value>` to `~/.cabal/config`. Cabal sends it as `Authorization: X-ApiKey`, so the value never enters `argv` or the environment. Verify only the entry count and the mode, never the value: ```sh-cabal upload --token "$HACKAGE_TOKEN" --documentation dist-newstyle/ansiform-<version>-docs.tar.gz+grep -c '^token:' ~/.cabal/config+stat -c '%a' ~/.cabal/config ``` -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.+Then upload without a token argument: +```sh+cabal upload dist-newstyle/sdist/ansiform-<version>.tar.gz+cabal upload --documentation dist-newstyle/ansiform-<version>-docs.tar.gz+```++The automated release stores the token as an environment secret named `HACKAGE_TOKEN` in the GitHub environment `release` and exposes it to the upload step as an environment variable. Do not add the token or the location of the secret manager to the repository.+ 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. ### GitHub@@ -62,6 +72,37 @@ Never print the values of the tokens or commit the location of your secrets. +### Signed tags++The `1.0.0.1` tag is annotated and unsigned because the key was configured afterwards. The `1.1.0.0` tag is the first one signed with SSH. To use another key format, configure it once.++SSH signing uses an existing SSH key and works with Git 2.34 or later:++1. Tell Git to use the public key:++ ```sh+ git config --global gpg.format ssh+ git config --global user.signingkey <path-to-public-key>+ git config --global tag.gpgSign true+ ```++2. Add the same public key to GitHub as a Signing Key under Settings > SSH and GPG keys > New SSH key. The authentication entry is separate and can stay as it is.+3. For local verification, list the key in an allowed signers file and point Git to it:++ ```sh+ echo "<github-noreply-email> namespaces=\"git\" $(cat <path-to-public-key>)" > <allowed-signers-file>+ git config --global gpg.ssh.allowedSignersFile <allowed-signers-file>+ ```++4. Create and verify a signed tag:++ ```sh+ git tag -s <version> -m "ansiform <version>"+ git tag -v <version>+ ```++For OpenPGP, create a key with `gpg --full-generate-key`, set `user.signingkey` to the long key ID, export the public key with `gpg --armor --export <key-id>` and add it to GitHub as a GPG key. Use `git tag -s` and `git tag -v` in the same way.+ ## Automated release `.github/workflows/release.yml` publishes a version through `workflow_dispatch`. It has two jobs:@@ -88,6 +129,8 @@ git push origin <version> ``` + If a signing key is configured, use `git tag -s <version> -m "ansiform <version>"` and verify it with `git tag -v <version>`. Without a key, keep the annotated tag.+ 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.@@ -150,7 +193,7 @@ `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. 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.+2. Add the token to `~/.cabal/config` as described above. Do not paste the token value into a command or store it in the repository. 3. Build the documentation tarball: ```sh@@ -162,13 +205,13 @@ 4. Upload the source distribution as a candidate: ```sh- cabal upload --token "$HACKAGE_TOKEN" dist-newstyle/sdist/ansiform-<version>.tar.gz+ cabal upload dist-newstyle/sdist/ansiform-<version>.tar.gz ``` 5. Upload the documentation candidate: ```sh- cabal upload --token "$HACKAGE_TOKEN" --documentation dist-newstyle/ansiform-<version>-docs.tar.gz+ cabal upload --documentation dist-newstyle/ansiform-<version>-docs.tar.gz ``` 6. Inspect the candidate page at `https://hackage.haskell.org/package/ansiform/candidates`. Check the rendered documentation, the dependency bounds and the build report. A candidate that fails verification can be deleted from that page.@@ -176,8 +219,8 @@ 8. After approval, publish the package and its documentation: ```sh- cabal upload --token "$HACKAGE_TOKEN" --publish dist-newstyle/sdist/ansiform-<version>.tar.gz- cabal upload --token "$HACKAGE_TOKEN" --documentation --publish dist-newstyle/ansiform-<version>-docs.tar.gz+ cabal upload --publish dist-newstyle/sdist/ansiform-<version>.tar.gz+ cabal upload --documentation --publish dist-newstyle/ansiform-<version>-docs.tar.gz ``` 9. Check the public package page, the documentation links and the dependency bounds.@@ -195,6 +238,8 @@ git push origin master --tags ``` + As in the automated process, use `git tag -s` and `git tag -v <version>` when a signing key is configured.+ 3. Create a GitHub release from the tag, using the relevant changelog section as the description: ```sh@@ -202,7 +247,8 @@ ``` 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.+5. Do not add provenance attestations unless the release contains binaries. This project ships source and documentation only.+6. The Hackage badge is already present in the README. ### Verification
examples/Demo.hs view
@@ -9,6 +9,9 @@ import Data.Char (isSpace, toLower) import Data.List (elemIndex) import Data.Maybe (listToMaybe)+import Data.Version (showVersion)+import Paths_ansiform (version)+import Text.Read (readMaybe) -------------------------------------------------------------------------------- -- Application@@ -16,7 +19,7 @@ -- Version of this demo, following the package version. demoVersion :: String-demoVersion = "1.0.0"+demoVersion = showVersion version -- The philosophers shown in the Groups screen. data Philosopher@@ -345,9 +348,9 @@ | 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+philosopherByNumber s = readMaybe s >>= \n -> lookup n numbered+ where+ numbered = zip [1 :: Int ..] philosophers trim :: String -> String trim = f . f
src/Ansiform/Content.hs view
@@ -15,7 +15,7 @@ import Ansiform.Internal.Content as Internal import Ansiform.Style ---------------------------------------------------------------------------------import Data.List+import Data.List (intersperse) -- Basic builders --------------------------------------------------------------------------------
src/Ansiform/Draw.hs view
@@ -1,102 +1,5 @@ -- | 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 (module Ansiform.Internal.Draw) 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)---- Drawing Functions------------------------------------------------------------------------------------- | Prints the first page and generates the initial state on stdout.-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---- | Redraws the last printed page on stdout.-redraw :: State -> IO State-redraw = redrawOn stdout---- | Redraws the last printed page on a given handle.-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 = amendOn' h [s]---- | Amends several sections on stdout.-amend' :: [Section] -> Number -> State -> IO State-amend' = amendOn' stdout---- | Amends several sections on a given handle.-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 = replaceOn' h [s]---- | Replaces a list of sections on stdout, preserving what is above.-replace' :: [Section] -> Number -> State -> IO State-replace' = replaceOn' stdout---- | 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+import Ansiform.Internal.Draw
src/Ansiform/Internal/Content.hs view
@@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- import Data.Bifunctor (bimap) import Data.Char-import Data.List+import Data.List (transpose) import Data.List.Split import Data.Maybe
+ src/Ansiform/Internal/Draw.hs view
@@ -0,0 +1,101 @@+-- | Drawing functions and the page state lifecycle.+module Ansiform.Internal.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 System.IO (Handle, stdout)++-- Drawing Functions+--------------------------------------------------------------------------------++-- | Prints the first page and generates the initial state on stdout.+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 >> resolveStateSettingsOn 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+redraw = redrawOn stdout++-- | Redraws the last printed page on a given handle.+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 = amendOn' h [s]++-- | Amends several sections on stdout.+amend' :: [Section] -> Number -> State -> IO State+amend' = amendOn' stdout++-- | Amends several sections on a given handle.+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 = replaceOn' h [s]++-- | Replaces a list of sections on stdout, preserving what is above.+replace' :: [Section] -> Number -> State -> IO State+replace' = replaceOn' stdout++-- | Replaces a list of sections on a given handle.+replaceOn' :: Handle -> [Section] -> Number -> State -> IO State+replaceOn' h ss n st =+ clr h preserve+ >> resolveStateSettingsOn 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 = formPage $ ss ++ drop (n' + length ss) sections+ newPage = amendPage' (unStatePage st) ss n
src/Ansiform/Internal/Input.hs view
@@ -19,7 +19,7 @@ , readFormOn ) where -import Ansiform.Draw (drawOn)+import Ansiform.Internal.Draw (drawOn) import Ansiform.Internal.Line import Ansiform.Internal.Number import Ansiform.Internal.Page
src/Ansiform/Internal/Line.hs view
@@ -57,8 +57,8 @@ LineBackspace | position <= 0 -> LineState text position | otherwise ->- let (before, after) = splitAt position text- in LineState (init before ++ after) (position - 1)+ let after = drop position text+ in LineState (take (position - 1) text ++ after) (position - 1) LineDelete | position >= length text -> LineState text position | otherwise ->
src/Ansiform/Internal/Page.hs view
@@ -12,7 +12,7 @@ -- | An ordered list of sections. newtype Page = Page [Section]- deriving (Eq, Show)+ deriving (Show) instance Sample Page where sampleShow n (Page sns) = sampleFormat "Page" n sns@@ -23,6 +23,22 @@ unPage :: Page -> [Section] unPage (Page ss) = ss++-- Page Builders+--------------------------------------------------------------------------------++-- | Replaces one section at the given index.+amendPage :: Page -> Section -> Number -> Page+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' -- Page Runners --------------------------------------------------------------------------------
src/Ansiform/Internal/Printer.hs view
@@ -1,6 +1,5 @@ module Ansiform.Internal.Printer where -import Ansiform.Content import Ansiform.Internal.Content import Ansiform.Internal.Number import Ansiform.Internal.Output@@ -10,7 +9,6 @@ import Ansiform.Internal.Table import Ansiform.Internal.Terminal import Ansiform.Internal.Utils-import Ansiform.Style -------------------------------------------------------------------------------- import Control.Monad import Data.List (transpose, zipWith4)@@ -21,22 +19,28 @@ -------------------------------------------------------------------------------- -- | A printer is a function from the output target to the number of lines printed.--- The printer name is used for inspection and equality.+-- The printer name is used for inspection; there is no 'Eq' instance because+-- two different functions cannot be compared structurally. newtype Printer = Printer (String, Output -> IO Number) -instance Eq Printer where- Printer (n1, _) == Printer (n2, _) = n1 == n2- instance Show Printer where show (Printer (nm, _)) = "Printer <" ++ nm ++ ">" instance Sample Printer where sampleShow _ = show +-- | The diagnostic name of a printer.+printerName :: Printer -> String+printerName (Printer (nm, _)) = nm+ -- Wrapper formPrinter :: String -> (Output -> IO Number) -> Printer formPrinter nm fio = Printer (nm, fio) +-- | Printer for a number of empty lines.+emptyPrinter :: Number -> Printer+emptyPrinter n = formPrinter "Empty" $ \s -> printEmpty s n+ -- | Runs a printer on stdout with the given settings. runPrinter :: Settings -> Printer -> IO Number runPrinter = runPrinterOn stdout@@ -120,7 +124,7 @@ -- Prints a line filled with spaces with the background color given. printSolid :: Offset -> Color -> Output -> IO Number-printSolid o c = printRule o (ruleSolid c)+printSolid o c = printRule o (formRule ' ' (solidStyle c)) -- Line Printing --------------------------------------------------------------------------------@@ -272,24 +276,32 @@ printGroup :: Output -> Offset -> Group -> IO Number printGroup out o g = printColumn out o (unGroup g) +-- | How groups use the available width.+data Spacing = SpacingMinimum | SpacingEven+ deriving (Eq, Show)++-- | Whether rows use a zebra background and a repeating index column.+data GroupMode = GroupPlain | GroupZebra+ deriving (Eq, Show)+ -- Main function for printing groups and tables, used by the specialized versions. -- Configured by the arguments: -- Offset -> Offset from both sides. -- Padding -> Padding between text and background. -- 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.+-- Spacing -> Sets the alignment to be evenly spaced or max per row.+-- GroupMode -> Table mode: zebra background and repeating index column. printGroups :: TableFormat -> Offset -> Padding -> Number ->- Bool ->- Bool ->+ Spacing ->+ GroupMode -> [Group] -> Output -> IO Number-printGroups fmt o p n bSpace bTable gs out = mainPrinter+printGroups fmt o p n spacing mode gs out = mainPrinter where cfg = outputConfig out h = outputHandle out@@ -306,7 +318,9 @@ widthList = fmap (+ m') cappedWidths maxWidth = maximum' 0 widthList evenList = replicate (length gs) maxWidth- chosenWidthList | bSpace = evenList | otherwise = widthList+ chosenWidthList = case spacing of+ SpacingEven -> evenList+ SpacingMinimum -> widthList formattedGroups = zipWith4 formatOne specs cappedWidths chosenWidthList gs formatOne :: ColumnSpec -> Int -> Int -> Group -> Group@@ -329,18 +343,20 @@ restartLoop = printLoop finalRemGroups finalRemWidths (ri + 1) (addNumber nls (formNumber rowLength)) executePrint :: IO ()- executePrint- | bTable =+ executePrint = case mode of+ GroupZebra -> printZebraBG o rowLength out >> hCursorUp h rowLength >> printContent- | otherwise = printContent+ GroupPlain -> printContent where printContent = mapM_ printEach (zip3 (fst splitGroups) curOffsets [0 ..]) lastRow = null remWidths- validIndex = bTable && not lastRow+ validIndex = case mode of+ GroupZebra -> not lastRow+ GroupPlain -> False rowColumns = length curWidths rowLength = maximum' 0 $ fmap (length . unGroup) curGroups @@ -379,14 +395,14 @@ | otherwise = printEmpty out 1 >> return_ setBG :: Group -> Group- setBG g'- | bTable = formGroup' $ changeBlocks <$> zip (unGroup g') [0 ..]- | otherwise = g'+ setBG g' = case mode of+ GroupZebra -> formGroup' $ changeBlocks <$> zip (unGroup g') [0 ..]+ GroupPlain -> g' where changeBlocks :: (Block, Int) -> Block changeBlocks (b, ib) | even ib = b- | otherwise = blockSetBG black b+ | otherwise = blockSetBG blackDull b -- Bordered Groups & Tables --------------------------------------------------------------------------------@@ -403,11 +419,11 @@ Offset -> Padding -> Number ->- Bool ->+ Spacing -> [Group] -> Output -> IO Number-printBorderedGroups brd fmt o p n bSpace gs out+printBorderedGroups brd fmt o p n spacing gs out | null gs = return 0 | otherwise = maybe printBorderless printBordered (borderChars brd) where@@ -416,7 +432,9 @@ specs = fmap (columnSpecAt fmt) [0 .. length gs - 1] cappedWidths = zipWith cappedWidth specs gs maxWidth = maximum' 0 cappedWidths- contentWidths = if bSpace then replicate (length gs) maxWidth else cappedWidths+ contentWidths = case spacing of+ SpacingEven -> replicate (length gs) maxWidth+ SpacingMinimum -> cappedWidths cellWidths = fmap (+ (2 * p')) contentWidths rows = transpose (fmap unGroup (padGroups gs)) n' = unn n@@ -542,9 +560,9 @@ offset = formNumber offset' printEachBlock vb | bZebra =- printSolid o black out+ printSolid o blackDull out >> hCursorUp h 1- >> printLeft' (blockSetBG black blockPretty)+ >> printLeft' (blockSetBG blackDull blockPretty) | otherwise = printLeft' blockPretty where printLeft' = printLeft out offset@@ -575,7 +593,7 @@ predZebra = bZebra && fInt i printParagraph' bZebra' = printParagraph o o1 p bZebra' vbs out printSeparation- | predZebra = printSolid o black out+ | predZebra = printSolid o blackDull out | otherwise = printEmpty out 1 -- Background Printing@@ -583,7 +601,7 @@ -- Prints a series of alternating lines, black and grey, for usage with tables. -- The offset and number of lines are given as parameters. printZebraBG :: Offset -> Int -> Output -> IO ()-printZebraBG o n out = sequence_ $ take n $ cycle [printEmpty out 1, printSolid o black out]+printZebraBG o n out = sequence_ $ take n $ cycle [printEmpty out 1, printSolid o blackDull out] -- Prints a solid background of several lines of the same color. printSolidBG :: Offset -> Int -> Color -> Output -> IO ()
src/Ansiform/Internal/Render.hs view
@@ -7,8 +7,19 @@ import Ansiform.Internal.Settings -------------------------------------------------------------------------------- import Control.Exception (bracket)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO import System.Directory (getTemporaryDirectory, removeFile)-import System.IO (Handle, hClose, hFlush, openTempFile)+import System.IO+ ( Handle+ , SeekMode (AbsoluteSeek)+ , hClose+ , hFlush+ , hSeek+ , hSetEncoding+ , openTempFile+ , utf8+ ) -- Rendering --------------------------------------------------------------------------------@@ -44,12 +55,13 @@ captureOutput :: (Handle -> IO a) -> IO (a, String) captureOutput action = do tmp <- getTemporaryDirectory- bracket (openTempFile tmp "ansiform-render") cleanup $ \(path, h) -> do+ bracket (openTempFile tmp "ansiform-render") cleanup $ \(_path, h) -> do+ hSetEncoding h utf8 result <- action h hFlush h- hClose h- output <- readFile path- length output `seq` return (result, output)+ hSeek h AbsoluteSeek 0+ output <- TIO.hGetContents h+ return (result, T.unpack output) where cleanup (path, h) = do hClose h
src/Ansiform/Internal/Section.hs view
@@ -4,7 +4,6 @@ import Ansiform.Internal.Printer import Ansiform.Internal.Sample import Ansiform.Internal.Settings-import Ansiform.Printer -------------------------------------------------------------------------------- import Control.Monad import System.IO (Handle, stdout)@@ -14,7 +13,7 @@ -- | A list of printers and a minimum number of lines. newtype Section = Section (Number, [Printer])- deriving (Eq, Show)+ deriving (Show) instance Sample Section where sampleShow n (Section (m, ps)) = "Section (minimum lines: " ++ sampleShow 0 m ++ ")\n" ++ sampleShow n ps@@ -77,5 +76,5 @@ runCalc acc p = f p >>= \n -> return (acc + n) minNumber = unSectionNumber vs enforceMin n- | n < minNumber = f (printerEmpty (minNumber - n)) >> return minNumber+ | n < minNumber = f (emptyPrinter (minNumber - n)) >> return minNumber | otherwise = return n
src/Ansiform/Internal/State.hs view
@@ -17,12 +17,13 @@ formState :: Settings -> Page -> [Number] -> State formState s p ns = State (s, p, ns) -unStateSettings :: State -> IO Config-unStateSettings (State (s, _, _)) = runSettings s+-- Resolves the state settings for stdout.+resolveStateSettings :: State -> IO Config+resolveStateSettings (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+resolveStateSettingsOn :: Handle -> State -> IO Config+resolveStateSettingsOn h (State (s, _, _)) = runSettingsOn h s unStatePage :: State -> Page unStatePage (State (_, p, _)) = p
src/Ansiform/Internal/Style.hs view
@@ -77,23 +77,27 @@ -------------------------------------------------------------------------------- -- Bold Italic Underline +-- | Whether italic is enabled in a format.+data Italic = ItalicOff | ItalicOn+ deriving (Eq, Show)+ -- | Bold, italic and underline attributes.-data Format = FormatDefault | Format ConsoleIntensity Bool Underlining+data Format = FormatDefault | Format ConsoleIntensity Italic Underlining deriving (Eq, Show) instance Sample Format where sampleShow _ FormatDefault = "FormatDefault"- sampleShow _ (Format BoldIntensity False NoUnderline) = "Bold"- sampleShow _ (Format NormalIntensity True NoUnderline) = "Italic"- sampleShow _ (Format NormalIntensity False SingleUnderline) = "Underline"- sampleShow _ (Format BoldIntensity True NoUnderline) = "BoldItalic"- sampleShow _ (Format BoldIntensity False SingleUnderline) = "BoldUnderline"- sampleShow _ (Format NormalIntensity True SingleUnderline) = "ItalicUnderline"- sampleShow _ (Format BoldIntensity True SingleUnderline) = "BoldItalicUnderline"+ sampleShow _ (Format BoldIntensity ItalicOff NoUnderline) = "Bold"+ sampleShow _ (Format NormalIntensity ItalicOn NoUnderline) = "Italic"+ sampleShow _ (Format NormalIntensity ItalicOff SingleUnderline) = "Underline"+ sampleShow _ (Format BoldIntensity ItalicOn NoUnderline) = "BoldItalic"+ sampleShow _ (Format BoldIntensity ItalicOff SingleUnderline) = "BoldUnderline"+ sampleShow _ (Format NormalIntensity ItalicOn SingleUnderline) = "ItalicUnderline"+ sampleShow _ (Format BoldIntensity ItalicOn SingleUnderline) = "BoldItalicUnderline" sampleShow _ _ = "Regular" -- Wrapper and Default-formFormat :: ConsoleIntensity -> Bool -> Underlining -> Format+formFormat :: ConsoleIntensity -> Italic -> Underlining -> Format formFormat = Format defaultFormat :: Format@@ -105,9 +109,9 @@ FormatDefault -> NormalIntensity Format b _ _ -> b -unItalic :: Format -> Bool+unItalic :: Format -> Italic unItalic vf = case vf of- FormatDefault -> False+ FormatDefault -> ItalicOff Format _ i _ -> i unUnderline :: Format -> Underlining@@ -123,7 +127,7 @@ isBold vf = case unBold vf of BoldIntensity -> True; _ -> False isItalic :: Format -> Bool-isItalic = unItalic+isItalic vf = case unItalic vf of ItalicOn -> True; ItalicOff -> False isUnderline :: Format -> Bool isUnderline vf = case unUnderline vf of SingleUnderline -> True; _ -> False@@ -173,7 +177,7 @@ | isFormatDefault f = [] | otherwise = [ SetConsoleIntensity (unBold f)- , SetItalicized (unItalic f)+ , SetItalicized (isItalic f) , SetUnderlining (unUnderline f) ] @@ -183,6 +187,14 @@ defaultStyle :: Style defaultStyle = formStyle defaultColor defaultColor defaultFormat++-- | Dull black, used by solid backgrounds and zebra tables.+blackDull :: Color+blackDull = formColor Dull ANSI.Black++-- | Style with dull black text on the given background.+solidStyle :: Color -> Style+solidStyle c = formStyle blackDull c defaultFormat -- Unwrappers unStyleForeground :: Style -> Color
src/Ansiform/Internal/Table.hs view
@@ -6,6 +6,7 @@ import Ansiform.Internal.Number import Ansiform.Internal.Sample import Ansiform.Internal.Style+import Ansiform.Internal.Utils (lastMaybe) import Ansiform.Internal.Width -- Table Format Types@@ -210,9 +211,7 @@ in if cw <= w' then (w' - cw, [formItem [c] ellipsisStyle]) else (w', [])- ellipsisStyle = case unBlock b of- [] -> defaultStyle- items -> unItemStyle (last items)+ ellipsisStyle = maybe defaultStyle unItemStyle (lastMaybe (unBlock b)) -- Keeps items while their display width fits. takeItems :: Int -> [Item] -> [Item]
src/Ansiform/Internal/Utils.hs view
@@ -1,7 +1,6 @@ module Ansiform.Internal.Utils where ---------------------------------------------------------------------------------import qualified Data.List as List import Data.Maybe (fromMaybe) -- Numbers@@ -10,10 +9,6 @@ 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' = 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)@@ -49,43 +44,6 @@ -- Reverses and concats a list simultaneously, used to avoid appending. concatRev :: [[a]] -> [a] concatRev = foldr (flip (++)) []--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)---- 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')---- Inserts an element in a list at a given index.-insertAt :: Int -> a -> [a] -> [a]-insertAt n e es = take n es ++ [e] ++ drop n es---- 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) -- Function to find the point to split a list of Ints -- when their sum overflows an Int threshold.
src/Ansiform/Page.hs view
@@ -21,13 +21,8 @@ -- | Replaces one section at the given index. amendPage :: Page -> Section -> Number -> Page-amendPage p s = amendPage' p [s]+amendPage = Internal.amendPage -- | 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'+amendPage' = Internal.amendPage'
src/Ansiform/Printer.hs view
@@ -24,7 +24,7 @@ -- | Printer for a number of empty lines. printerEmpty :: Number -> Printer-printerEmpty n = formPrinter "Empty" $ \s -> printEmpty s n+printerEmpty = Internal.emptyPrinter -- | Printer for a single item followed by a newline. printerItem :: Item -> Printer@@ -134,42 +134,42 @@ -- | 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+ printGroups defaultTableFormat o 0 0 SpacingEven GroupPlain (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+ printGroups defaultTableFormat o 0 0 SpacingMinimum GroupPlain (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+ printGroups defaultTableFormat o 0 r SpacingEven GroupPlain (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+ printGroups defaultTableFormat o 0 r SpacingMinimum GroupPlain (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 SpacingMinimum 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 SpacingEven 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 SpacingMinimum 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 SpacingEven gs s -- Table Printing --------------------------------------------------------------------------------@@ -177,62 +177,62 @@ -- | 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+ printGroups defaultTableFormat o p 0 SpacingMinimum GroupZebra (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+ printGroups defaultTableFormat o p 0 SpacingEven GroupZebra (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+ printGroups defaultTableFormat o p r SpacingMinimum GroupZebra (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+ printGroups defaultTableFormat o p r SpacingEven GroupZebra (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 SpacingMinimum GroupZebra (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 SpacingEven GroupZebra (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 SpacingMinimum GroupZebra (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 SpacingEven GroupZebra (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 SpacingMinimum (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 SpacingEven (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 SpacingMinimum (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 SpacingEven (unMaybeTable mt) s -- Text Printing --------------------------------------------------------------------------------@@ -271,3 +271,7 @@ 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++-- | The diagnostic name of a printer.+printerName :: Printer -> String+printerName = Internal.printerName
src/Ansiform/Style.hs view
@@ -66,20 +66,20 @@ -- | Regular, bold, italic and underline formats. formatRegular, formatBold, formatItalic, formatUnderline :: Format-formatRegular = formFormat NormalIntensity False NoUnderline-formatBold = formFormat BoldIntensity False NoUnderline-formatItalic = formFormat NormalIntensity True NoUnderline-formatUnderline = formFormat NormalIntensity False SingleUnderline+formatRegular = formFormat NormalIntensity ItalicOff NoUnderline+formatBold = formFormat BoldIntensity ItalicOff NoUnderline+formatItalic = formFormat NormalIntensity ItalicOn NoUnderline+formatUnderline = formFormat NormalIntensity ItalicOff SingleUnderline -- | Bold italic and bold underline formats. formatBoldItalic, formatBoldUnderline :: Format-formatBoldItalic = formFormat BoldIntensity True NoUnderline-formatBoldUnderline = formFormat BoldIntensity False SingleUnderline+formatBoldItalic = formFormat BoldIntensity ItalicOn NoUnderline+formatBoldUnderline = formFormat BoldIntensity ItalicOff SingleUnderline -- | Italic underline and bold italic underline formats. formatItalicUnderline, formatBoldItalicUnderline :: Format-formatItalicUnderline = formFormat NormalIntensity True SingleUnderline-formatBoldItalicUnderline = formFormat BoldIntensity True SingleUnderline+formatItalicUnderline = formFormat NormalIntensity ItalicOn SingleUnderline+formatBoldItalicUnderline = formFormat BoldIntensity ItalicOn SingleUnderline -- Styles --------------------------------------------------------------------------------
test/Spec.hs view
@@ -2,6 +2,7 @@ module Main where import Ansiform+import Control.Exception (bracket, finally) import Control.Monad (unless) import Data.List (isInfixOf) import Data.Maybe (isJust, isNothing)@@ -19,6 +20,25 @@ , stdin , stdout )+import Test.QuickCheck+ ( Args (..)+ , Gen+ , Property+ , arbitrary+ , choose+ , elements+ , forAll+ , ioProperty+ , listOf+ , listOf1+ , oneof+ , property+ , quickCheckWithResult+ , resize+ , stdArgs+ )+import Test.QuickCheck.Random (mkQCGen)+import Test.QuickCheck.Test (isSuccess, output) main :: IO () main = do@@ -113,6 +133,19 @@ && "<Center>" `isInfixOf` out ) , test+ "Printer exposes its diagnostic name"+ (printerName (printerLeft 0 (blockSimple "a" styleDefault)) == "Left")+ , testIO "Sequence predicate renders the paragraphs" $ do+ let paragraphs =+ [ [blockSimple "first" styleDefault]+ , [blockSimple "second" styleDefault]+ ]+ out <-+ renderPrinter+ (printerSequencePred 0 0 0 (== 1) paragraphs)+ (settings [width 20, neverColors])+ return $ "first" `isInfixOf` out && "second" `isInfixOf` out+ , test "Display width of ASCII text" (charWidth 'a' == 1 && textWidth "abc" == 3) , test@@ -238,6 +271,47 @@ (printerTableFormat fmt 0 0 tbl) (settings [width 20, neverColors]) return $ " ab " `isInfixOf` out+ , testIO "Truncated table styles the ellipsis like the last item" $ do+ let cell =+ block+ [ item "AB" (bold red)+ , item "C" (italic blue)+ ]+ tbl =+ tableBlocks+ [blockSimple "H" styleDefault]+ [[cell]]+ fmt =+ tableFormat+ [ defaultColumnSpec+ { columnMaxWidth = Just 2+ , columnEllipsis = EllipsisChar '.'+ }+ ]+ out <-+ renderPrinter+ (printerTableFormat fmt 0 0 tbl)+ (settings [width 20, alwaysColors])+ return $ "." `isInfixOf` out && ";3;" `isInfixOf` out+ , testIO "Evenly spaced tables render" $ do+ let tbl =+ tableSimple+ [ blockSimple "A" styleDefault+ , blockSimple "B" styleDefault+ ]+ styleDefault+ [["1", "2"]]+ out <-+ renderPrinter+ (printerTable' 0 0 tbl)+ (settings [width 30, neverColors])+ return $ all (`isInfixOf` out) ["A", "B", "1", "2"]+ , testIO "Render preserves non-ASCII text" $ do+ out <-+ renderPrinter+ (printerItem (item "ação 漢" styleDefault))+ (settings [neverColors])+ return $ "ação 漢" `isInfixOf` out , testIO "Bordered table draws a box" $ do let tbl = tableSimple@@ -365,7 +439,9 @@ runPrinter (settings [alwaysColors]) (printerItem (item "styled" (bold red))) return $ '\ESC' `elem` out && "styled" `isInfixOf` out ]- unless (and results) exitFailure+ propertyResults <- sequence propertyTests+ goldenResults <- sequence goldenTests+ unless (and (results ++ propertyResults ++ goldenResults)) exitFailure putStrLn "All tests passed." test :: String -> Bool -> IO Bool@@ -376,39 +452,261 @@ testIO :: String -> IO Bool -> IO Bool testIO name action = action >>= test name +testQuickCheck :: String -> Property -> IO Bool+testQuickCheck name prop = do+ result <- quickCheckWithResult args prop+ let passed = isSuccess result+ putStrLn ((if passed then "ok " else "FAIL ") ++ name)+ unless passed $ putStr (output result)+ return passed+ where+ args =+ stdArgs+ { replay = Just (mkQCGen 42, 0)+ , maxSuccess = 100+ , chatty = False+ }++propertyTests :: [IO Bool]+propertyTests =+ [ testQuickCheck+ "Display width is additive"+ ( property $ \a b ->+ textWidth (a ++ b) == textWidth (a :: String) + textWidth b+ )+ , testQuickCheck+ "Display width is non-negative"+ (property $ \s -> textWidth (s :: String) >= 0)+ , testQuickCheck+ "Line editor keeps the cursor in range"+ ( forAll genLineKey $ \key ->+ forAll arbitrary $ \text ->+ forAll arbitrary $ \cursor ->+ let next = applyLineKey key (LineState text cursor)+ in lineCursor next >= 0+ && lineCursor next <= length (lineText next)+ )+ , testQuickCheck+ "Line editor changes at most one character"+ ( forAll genLineKey $ \key ->+ forAll arbitrary $ \text ->+ forAll arbitrary $ \cursor ->+ let next = applyLineKey key (LineState text cursor)+ in abs (length (lineText next) - length text) <= 1+ )+ , testQuickCheck+ "Line movement leaves the text unchanged"+ ( forAll (elements [LineMoveLeft, LineMoveRight, LineMoveHome, LineMoveEnd]) $ \key ->+ forAll arbitrary $ \text ->+ let next = applyLineKey key (LineState text (length text))+ in lineText next == text+ )+ , testQuickCheck+ "Printable insertion adds one character"+ ( forAll (choose ('a', 'z')) $ \c ->+ forAll arbitrary $ \text ->+ let next = applyLineKey (LineInsert c) (LineState text (length text))+ in length (lineText next) == length text + 1+ )+ , testQuickCheck+ "Non-printable insertion is ignored"+ ( forAll (elements ['\t', '\n', '\DEL']) $ \c ->+ forAll arbitrary $ \text ->+ let next = applyLineKey (LineInsert c) (LineState text (length text))+ in lineText next == text+ )+ , testQuickCheck+ "Visible line fits the available width"+ ( forAll (choose (1, 40)) $ \availableWidth ->+ forAll arbitrary $ \text ->+ forAll arbitrary $ \cursor ->+ let (window, offset) = visibleLine availableWidth (LineState text cursor)+ in textWidth window <= max 1 (availableWidth - 1)+ && offset >= 0+ && offset <= textWidth window+ )+ , testQuickCheck+ "Block tables accept exactly balanced rows"+ ( forAll (listOf genBlock) $ \headerBlocks ->+ forAll (listOf (listOf genBlock)) $ \rows ->+ isJust (tableBlocks headerBlocks rows)+ == all ((== length headerBlocks) . length) rows+ )+ , testQuickCheck+ "Simple tables accept exactly balanced rows"+ ( forAll (listOf genBlock) $ \headerBlocks ->+ forAll (listOf (listOf arbitrary)) $ \rows ->+ isJust (tableSimple headerBlocks styleDefault rows)+ == all ((== length headerBlocks) . length) rows+ )+ , testQuickCheck+ "Group tables accept groups of equal height"+ ( forAll (listOf1 (choose (0, 5))) $ \heights ->+ let groups = fmap genGroupOfHeight heights+ in case heights of+ [] -> property False+ (firstHeight : rest) ->+ property $+ isJust (tableGroups groups)+ == all (== firstHeight) rest+ )+ , testQuickCheck+ "Number caps negative input"+ (property $ \n -> unNumber (formNumber n) == max 0 (n :: Int))+ , testQuickCheck+ "Checked subtraction is exact"+ ( forAll (choose (0, 1000)) $ \a ->+ forAll (choose (0, 1000)) $ \b ->+ let x = formNumber (a :: Int)+ y = formNumber b+ in case subtractNumberMaybe x y of+ Nothing -> unNumber x < unNumber y+ Just d -> unNumber d == unNumber x - unNumber y+ )+ , testQuickCheck+ "Paragraph lines fit the width"+ ( forAll (choose (10, 40)) $ \lineWidth ->+ forAll (resize 4 (listOf1 (listOf1 (choose ('a', 'z'))))) $ \wordList ->+ ioProperty $ do+ out <-+ renderPrinter+ (printerParagraph 0 0 [blockSimple (unwords wordList) styleDefault])+ (settings [width (formNumber lineWidth), neverColors])+ return $ all (\line -> textWidth line <= lineWidth) (lines (stripCsi out))+ )+ ]++genLineKey :: Gen LineKey+genLineKey =+ oneof+ [ LineInsert <$> arbitrary+ , pure LineBackspace+ , pure LineDelete+ , pure LineMoveLeft+ , pure LineMoveRight+ , pure LineMoveHome+ , pure LineMoveEnd+ ]++genBlock :: Gen Block+genBlock = blockSimple <$> arbitrary <*> pure styleDefault++genGroupOfHeight :: Int -> Group+genGroupOfHeight height =+ groupSimple+ (blockSimple "header" styleDefault)+ (replicate height (blockSimple "body" styleDefault))++goldenTests :: [IO Bool]+goldenTests =+ [ goldenTest+ "Paragraph wraps at the width"+ ( renderPrinter+ (printerParagraph 0 0 [blockSimple "one two three four five" styleDefault])+ (settings [width 12, neverColors])+ )+ "one two \nthree four \nfive\n"+ , goldenTest+ "Unicode paragraph keeps wide and combining characters"+ ( renderPrinter+ (printerParagraph 0 0 [blockSimple "漢漢 e\x0301 漢" styleDefault])+ (settings [width 8, neverColors])+ )+ "漢漢 e\x0301 \n漢\n"+ , goldenTest+ "Bordered groups pad the shorter column"+ ( renderPrinter+ ( printerGroupsBordered+ BordersAscii+ 0+ 0+ [ groupSimple+ (blockSimple "A" styleDefault)+ [ blockSimple "1" styleDefault+ , blockSimple "2" styleDefault+ ]+ , groupSimple (blockSimple "B" styleDefault) []+ ]+ )+ (settings [width 32, neverColors])+ )+ "+-+-+\n|A|B|\n+-+-+\n|1| |\n+-+-+\n|2| |\n+-+-+\n"+ , goldenTest+ "Page renders a rule and a body line"+ ( renderPage+ ( page+ [ section [printerRule (rule '-' styleDefault)]+ , section [printerLeft 0 (blockSimple "body" styleDefault)]+ ]+ )+ (settings [width 20, neverColors])+ )+ "--------------------\nbody\n"+ ]++goldenTest :: String -> IO String -> String -> IO Bool+goldenTest name render expected = do+ actual <- render+ let normalized = stripCsi actual+ passed = normalized == expected+ putStrLn ((if passed then "ok " else "FAIL ") ++ "Golden: " ++ name)+ unless passed $ do+ putStrLn "--- expected"+ putStr expected+ putStrLn "--- actual"+ putStr normalized+ return passed++-- Removes the cursor movement sequences that the drawing layer emits even+-- when styling is disabled, so a golden output compares only the layout.+stripCsi :: String -> String+stripCsi [] = []+stripCsi ('\ESC' : '[' : rest) = stripCsi (dropFinal rest)+ where+ dropFinal [] = []+ dropFinal (c : cs)+ | c >= '@' && c <= '~' = cs+ | otherwise = dropFinal cs+stripCsi (c : cs) = c : stripCsi cs+ -- Runs an action with stdout redirected to a temporary file and returns -- 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)+ bracket (openTempFile tmp "ansiform-test-output") cleanup $ \(path, handle) -> do+ original <- hDuplicate stdout+ result <-+ ( do+ hDuplicateTo handle stdout+ value <- action+ hFlush stdout+ return value+ )+ `finally` (hDuplicateTo original stdout >> hClose original)+ hClose handle+ captured <- readFile' path+ return (result, captured)+ where+ cleanup (path, handle) = do+ hClose handle+ removeFile path -- 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+ bracket (openTempFile tmp "ansiform-test-input") cleanup $ \(_path, handle) -> do+ hPutStr handle input+ hFlush handle+ hSeek handle AbsoluteSeek 0+ original <- hDuplicate stdin+ hDuplicateTo handle stdin+ action `finally` (hDuplicateTo original stdin >> hClose original)+ where+ cleanup (path, handle) = do+ hClose handle+ removeFile path -------------------------------------------------------------------------------- -- Fixtures