diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,110 @@ +# `hr-haskell` Changelog + +This project follows the [Haskell package versioning policy][PVP], with +versions in `A.B.C.D` format. `A` may be incremented arbitrarily for +non-technical reasons, but [semantic versioning][SemVer] is otherwise +followed, where `A.B` is the major version, `C` is the minor version, and `D` +is the patch version. Initial development uses versions `0.0.0.D`, for which +every version is considered breaking. + +[PVP]: +[SemVer]: + +The format of this changelog is based on [Keep a Changelog][KaC], with the +following conventions: + +* Level-two heading `Unreleased` is used to track changes that have not been + released. +* Other level-two headings specify the release in `A.B.C.D (YYYY-MM-DD)` + format, with newer versions above older versions. +* Level-three headings are used to categorize changes as follows: + 1. Breaking + 2. Non-Breaking +* Changes are listed in arbitrary order and present tense. + +[KaC]: + +## 0.5.0.0 (2022-03-01) + +### Breaking + +* Rename Haskell package to `horizontal-rule` +* Refactor API to use `MonadTerminal` instead of `IO` directly + +### Non-Breaking + +* Add mock tests +* Bump `text` dependency version upper bound +* Bump `time` dependency version upper bound +* Bump `optparse-applicative` dependency version upper bound + +## 0.4.0.0 (2021-06-25) + +### Breaking + +* Fix `--help` when using `optparse-applicative` `0.16` + +### Non-Breaking + +* Refactor Nix configuration + +## 0.3.0.1 (2021-05-28) + +### Non-Breaking + +* Add library usage example + +## 0.3.0.0 (2021-05-28) + +### Breaking + +* Add library +* Add `--width` and `--default` CLI options +* Add `--input` and `--timeout` CLI options + +## 0.2.0.1 (2021-05-27) + +### Non-Breaking + +* Fix link in README +* Fix formatting in RPM description + +## 0.2.0.0 (2021-05-26) + +### Breaking + +* Add support for `optparse-applicative` `0.16` + +### Non-Breaking + +* Add `.deb` and `.rpm` packaging +* Add Cabal support to `Makefile` +* Add Cabal tests to GitHub Actions +* Add [stan](https://hackage.haskell.org/package/stan) static analysis + +## 0.1.0.3 (2020-11-21) + +### Non-Breaking + +* Use GitHub Actions instead of Travis CI + +## 0.1.0.2 (2020-11-05) + +### Non-Breaking + +* Rename Git default branch to `main` +* Refactor `Makefile`, add `STACK_NIX_PATH` support +* Add `test-all` command to `Makefile` +* Add Nix configuration + +## 0.1.0.1 (2019-12-29) + +### Non-Breaking + +* Fix operator for compatibility with GHC 8.2.2 + +## 0.1.0.0 (2019-12-29) + +### Breaking + +* Initial public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2019-2022 Travis Cardwell + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,186 @@ +# hr + +[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) +[![GitHub CI](https://github.com/ExtremaIS/hr-haskell/workflows/CI/badge.svg?branch=main)](https://github.com/ExtremaIS/hr-haskell/actions) +[![Hackage](https://img.shields.io/hackage/v/horizontal-rule.svg)](https://hackage.haskell.org/package/horizontal-rule) +[![Stackage LTS](https://stackage.org/package/horizontal-rule/badge/lts)](https://stackage.org/package/horizontal-rule) +[![Stackage Nightly](https://stackage.org/package/horizontal-rule/badge/nightly)](https://stackage.org/nightly/package/horizontal-rule) + +* [Overview](#overview) +* [CLI](#cli) + * [Requirements](#requirements) + * [Installation](#installation) + * [`.deb` Package Installation](#deb-package-installation) + * [`.rpm` Package Installation](#rpm-package-installation) + * [Installation From Hackage](#installation-from-hackage) + * [Installation From Stackage](#installation-from-stackage) + * [Usage](#usage) + * [Examples](#examples) +* [Library](#library) +* [Project](#project) + * [Links](#links) + * [Tags](#tags) + * [Contribution](#contribution) + * [License](#license) + +## Overview + +`hr` is a utility for displaying a horizontal rule in a terminal. + +It is useful for marking a position in your terminal so that you can easily +find it again. For example, use `hr` to display a horizontal rule before each +build of a project so that you can easily find the beginning of the output of +the last build. + +## CLI + +### Requirements + +`hr` has only been tested on Linux. It *might* work on Windows and macOS. + +### Installation + +#### `.deb` Package Installation + +Check the [Releases][] page for `.deb` packages. + +[Releases]: + +#### `.rpm` Package Installation + +Check the [Releases][] page for `.rpm` packages. + +#### Installation From Hackage + +Install `hr` from [Hackage][] using [Cabal][] as follows: + +``` +$ cabal v2-install horizontal-rule +``` + +[Hackage]: +[Cabal]: + +#### Installation From Stackage + +Install `hr` from [Stackage][] using [Stack][] as follows: + +``` +$ stack install horizontal-rule +``` + +[Stackage]: +[Stack]: + +### Usage + +See the [`hr` man page](doc/hr.1.md) for usage information. + +#### Examples + +The rule fills with width of the terminal by default: + +``` +$ hr +━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +In cases when the terminal width cannot be determined, a default width is +used. This default width can be set with an option: + +``` +$ hr -d 78 +━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +If desired, the rule width can be specified: + +``` +$ hr -w 60 +━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +In cases where the terminal cannot display Unicode, ASCII may be used: + +``` +$ hr -a +------------------------------------------------------------------------------ +``` + +The rule can include the current time: + +``` +$ hr -t +━━┫2021-05-27 19:26:09┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +The time format can be specified: + +``` +$ hr -t -f "%H:%M:%S.%q" +━━┫19:30:44.861779179000┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +The first line read from `STDIN` can be used as a note: + +``` +$ uname -m | hr -i +━━┫x86_64┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +When input is read, a timeout is used to ensure that `hr` does not "hang" when +there is no input. The timeout (in milliseconds) can be specified: + +``` +$ uname -m | hr -i --timeout 100 +━━┫x86_64┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +A note can be specified as one or more arguments: + +``` +$ hr unit tests +━━┫unit tests┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +Different types of notes can be combined: + +``` +$ uname -m | hr -it unit tests +━━┫2021-05-27 19:48:48┣━┫unit tests┣━┫x86_64┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +``` + +## Library + +You can easily include horizontal rules in the output of your own Haskell +software by using the library. The Haskell package is named `horizontal-rule` +in [Hackage][] and [Stackage][] because there is an existing package named +[`hR`](https://hackage.haskell.org/package/hR). + +## Project + +### Links + +* Hackage: +* Stackage: +* GitHub: +* GitHub Actions CI: + +### Tags + +All releases are tagged in the `main` branch. Release tags are signed using +the +[`security@extrema.is` GPG key](http://keys.gnupg.net/pks/lookup?op=vindex&fingerprint=on&search=0x1D484E4B4705FADF). + +### Contribution + +Issues and feature requests are tracked on GitHub: + + +Issues may also be submitted via email to . + +### License + +This project is released under the +[MIT License](https://opensource.org/licenses/MIT) as specified in the +[`LICENSE`](LICENSE) file. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/LibOA.hs b/app/LibOA.hs new file mode 100644 --- /dev/null +++ b/app/LibOA.hs @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- | +-- Module : LibOA +-- Description : supplementary functions for optparse-applicative +-- Copyright : Copyright (c) 2019-2022 Travis Cardwell +-- License : MIT +-- +-- This is a collection of functions that I often use with +-- @optparse-applicative@. I do not feel that it is worth maintaining yet +-- another helper package on Hackage, so I just copy the code to different +-- projects as required. If the library grows to a substantial size or others +-- with to use it, I will reconsider. +-- +-- Revision: 2022-01-02 +------------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module LibOA + ( -- * Options + -- $Options + helper + , versioner + -- * Utilities + , commands + -- * Help + , (<||>) + , section + , table + , table_ + , vspace + ) where + +-- https://hackage.haskell.org/package/ansi-wl-pprint +import qualified Text.PrettyPrint.ANSI.Leijen as Doc +import Text.PrettyPrint.ANSI.Leijen (Doc) + +-- https://hackage.haskell.org/package/base +import Data.List (intersperse, transpose) +import Data.Maybe (fromMaybe) +#if !MIN_VERSION_base (4,11,0) +import Data.Monoid ((<>)) +#endif + +-- https://hackage.haskell.org/package/optparse-applicative +import qualified Options.Applicative as OA +#if MIN_VERSION_optparse_applicative (0,16,0) +import qualified Options.Applicative.Builder.Internal as OABI +#endif +import qualified Options.Applicative.Common as OAC +import qualified Options.Applicative.Types as OAT + +------------------------------------------------------------------------------ +-- $Options +-- +-- Option descriptions are not capitalized. + +-- | A hidden @-h@ / @--help@ option that always fails, showing the help +-- +-- This is the same as 'OA.helper' except that it has a different help +-- message. +helper :: OA.Parser (a -> a) +#if MIN_VERSION_optparse_applicative (0,16,0) +helper = OA.option helpReader $ mconcat + [ OA.short 'h' + , OA.long "help" + , OA.value id + , OA.metavar "" + , OABI.noGlobal + , OA.noArgError (OA.ShowHelpText Nothing) + , OA.help "show this help text" + , OA.hidden + ] + where + helpReader = do + potentialCommand <- OAT.readerAsk + OA.readerAbort $ OA.ShowHelpText (Just potentialCommand) +#else +helper = OA.abortOption OA.ShowHelpText $ mconcat + [ OA.short 'h' + , OA.long "help" + , OA.help "show help and exit" + , OA.hidden + ] +#endif + +-- | A hidden @--version@ option that always fails, showing the version +versioner + :: String -- ^ version string + -> OA.Parser (a -> a) +versioner verStr = OA.infoOption verStr $ mconcat + [ OA.long "version" + , OA.help "show version and exit" + , OA.hidden + ] + +------------------------------------------------------------------------------ +-- $Utilities + +-- | Get a list of commands for a parser +commands :: OA.Parser a -> [String] +commands = + let go _ opt = case OAT.optMain opt of + OAT.CmdReader _ cmds _ -> reverse cmds + _otherReader -> [] + in concat . OAC.mapParser go + +------------------------------------------------------------------------------ +-- $Help + +-- | Insert a blank line between two documents +(<||>) :: Doc -> Doc -> Doc +d1 <||> d2 = d1 <> Doc.line <> Doc.line <> d2 +infixr 5 <||> + +-- | Create a section with a title and indented body +section :: String -> Doc -> Doc +section title = (Doc.text title Doc.<$$>) . Doc.indent 2 + +-- | Create a table, with formatting +table :: Int -> [[(String, Doc -> Doc)]] -> Doc +table sep rows = Doc.vcat $ + map (fromMaybe Doc.empty . foldr go Nothing . zip lengths) rows + where + lengths :: [Int] + lengths = map ((+) sep . maximum . map (length . fst)) $ transpose rows + + go :: (Int, (String, Doc -> Doc)) -> Maybe Doc -> Maybe Doc + go (len, (s, f)) = Just . \case + Just doc -> Doc.fill len (f $ Doc.string s) <> doc + Nothing -> f $ Doc.string s + +-- | Create a table, without formatting +table_ :: Int -> [[String]] -> Doc +table_ sep = table sep . (map . map) (, id) + +-- | Vertically space documents with blank lines between them +vspace :: [Doc] -> Doc +vspace = mconcat . intersperse (Doc.line <> Doc.line) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : hr: a horizontal rule for terminals +-- Copyright : Copyright (c) 2019-2022 Travis Cardwell +-- License : MIT +-- +-- See the README for details. +------------------------------------------------------------------------------ + +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +-- https://hackage.haskell.org/package/ansi-wl-pprint +import Text.PrettyPrint.ANSI.Leijen (Doc) + +-- https://hackage.haskell.org/package/base +import Control.Applicative (many, optional) +import Data.Maybe (maybeToList) +import System.Timeout (timeout) + +-- https://hackage.haskell.org/package/optparse-applicative +import qualified Options.Applicative as OA + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T + +-- https://hackage.haskell.org/package/time +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (getZonedTime) + +-- (horizontal-rule) +import qualified HR + +-- (horizontal-rule:executable) +import qualified LibOA + +------------------------------------------------------------------------------ +-- $Constants + +defaultWidth :: Int +defaultWidth = 80 + +defaultFormat :: String +defaultFormat = "%Y-%m-%d %H:%M:%S" + +defaultTimeout :: Int +defaultTimeout = 500 + +------------------------------------------------------------------------------ +-- $Options + +data Options + = Options + { optWidth :: !(Maybe Int) + , optDefault :: !Int + , optAscii :: !Bool + , optTime :: !Bool + , optFormat :: !String + , optInput :: !Bool + , optTimeout :: !Int + , optNote :: !(Maybe String) + } + +options :: OA.Parser Options +options = + Options + <$> optional widthOption + <*> defaultOption + <*> asciiOption + <*> timeOption + <*> formatOption + <*> inputOption + <*> timeoutOption + <*> noteArguments + +widthOption :: OA.Parser Int +widthOption = OA.option OA.auto $ mconcat + [ OA.long "width" + , OA.short 'w' + , OA.metavar "CHARS" + , OA.help "target rule width (default: terminal width)" + ] + +defaultOption :: OA.Parser Int +defaultOption = OA.option OA.auto $ mconcat + [ OA.long "default" + , OA.short 'd' + , OA.metavar "CHARS" + , OA.value defaultWidth + , OA.showDefault + , OA.help "default target rule width" + ] + +asciiOption :: OA.Parser Bool +asciiOption = OA.switch $ mconcat + [ OA.long "ascii" + , OA.short 'a' + , OA.help "use ASCII lines (default: use Unicode lines)" + ] + +timeOption :: OA.Parser Bool +timeOption = OA.switch $ mconcat + [ OA.long "time" + , OA.short 't' + , OA.help "show time" + ] + +formatOption :: OA.Parser String +formatOption = OA.strOption $ mconcat + [ OA.long "format" + , OA.short 'f' + , OA.metavar "FORMAT" + , OA.value defaultFormat + , OA.showDefaultWith id + , OA.help "time format" + ] + +inputOption :: OA.Parser Bool +inputOption = OA.switch $ mconcat + [ OA.long "input" + , OA.short 'i' + , OA.help "read note from STDIN within MS milliseconds" + ] + +timeoutOption :: OA.Parser Int +timeoutOption = OA.option OA.auto $ mconcat + [ OA.long "timeout" + , OA.metavar "MS" + , OA.value defaultTimeout + , OA.showDefault + , OA.help "timeout in milliseconds" + ] + +noteArguments :: OA.Parser (Maybe String) +noteArguments = fmap mjoin . many . OA.strArgument $ mconcat + [ OA.metavar "NOTE ..." + , OA.help "show a note" + ] + where + mjoin :: [String] -> Maybe String + mjoin [] = Nothing + mjoin ss = Just $ unwords ss + +------------------------------------------------------------------------------ +-- $Main + +main :: IO () +main = do + Options{..} <- OA.execParser pinfo + mTime <- if optTime + then Just . formatTime defaultTimeLocale optFormat <$> getZonedTime + else pure Nothing + mInput <- if optInput + then timeout (optTimeout * 1000) getLine + else pure Nothing + let hr = case (optWidth, optAscii) of + (Nothing, False) -> HR.putAutoUnicode optDefault + (Nothing, True) -> HR.putAutoAscii optDefault + (Just width, False) -> HR.putUnicode width + (Just width, True) -> HR.putAscii width + hr . map T.pack $ concat + [ maybeToList mTime + , maybeToList optNote + , maybeToList mInput + ] + where + pinfo :: OA.ParserInfo Options + pinfo + = OA.info (LibOA.helper <*> LibOA.versioner HR.version <*> options) + $ mconcat + [ OA.fullDesc + , OA.progDesc "horizontal rule for the terminal" + , OA.failureCode 2 + , OA.footerDoc $ Just formatHelp + ] + + formatHelp :: Doc + formatHelp = LibOA.section "FORMAT codes:" $ LibOA.table_ 2 + [ ["%Y", "four-digit year"] + , ["%y", "two-digit year"] + , ["%m", "two-digit month"] + , ["%d", "two-digit day"] + , ["%H", "two-digit hour using 24-hour clock"] + , ["%I", "two-digit hour using 12-hour clock"] + , ["%p", "locale equivalent of AM or PM"] + , ["%M", "two-digit minute"] + , ["%S", "two-digit second"] + , ["%q", "twelve-digit picosecond"] + , ["%z", "UTC offset"] + ] diff --git a/horizontal-rule.cabal b/horizontal-rule.cabal new file mode 100644 --- /dev/null +++ b/horizontal-rule.cabal @@ -0,0 +1,92 @@ +name: horizontal-rule +version: 0.5.0.0 +category: Utils +synopsis: horizontal rule for the terminal +description: + This package provides a utility for displaying a horizontal rule in a + terminal. Please see the README on GitHub at + . + +homepage: https://github.com/ExtremaIS/hr-haskell#readme +bug-reports: https://github.com/ExtremaIS/hr-haskell/issues +author: Travis Cardwell +maintainer: Travis Cardwell +copyright: Copyright (c) 2019-2022 Travis Cardwell +license: MIT +license-file: LICENSE + +cabal-version: 1.24 +build-type: Simple +tested-with: + GHC ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.1 + +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/ExtremaIS/hr-haskell.git + +flag write-hie + description: write .hie files + default: False + +library + hs-source-dirs: src + exposed-modules: + HR + , HR.Monad.Terminal + other-modules: + Paths_horizontal_rule + build-depends: + base >=4.7 && <5 + , terminal-size >=0.3 && <0.4 + , text >=1.2.3 && <2.1 + default-language: Haskell2010 + default-extensions: + OverloadedStrings + if flag(write-hie) + ghc-options: -Wall -fwrite-ide-info -hiedir=.hie + else + ghc-options: -Wall + +executable hr + hs-source-dirs: app + main-is: Main.hs + other-modules: + LibOA + build-depends: + ansi-wl-pprint >=0.6 && <0.7 + , base + , horizontal-rule + , optparse-applicative >=0.14 && <0.18 + , text + , time >=1.8 && <1.13 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite horizontal-rule-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + HR.Test + build-depends: + base + , horizontal-rule + , tasty >=1.0 && <1.5 + , tasty-hunit >=0.10 && <0.11 + if impl(ghc >= 8.6.1) + other-modules: + HR.Mock + build-depends: + HMock >=0.5.1 && <0.6 + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/src/HR.hs b/src/HR.hs new file mode 100644 --- /dev/null +++ b/src/HR.hs @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- | +-- Module : HR +-- Description : horizontal rule for terminals +-- Copyright : Copyright (c) 2019-2022 Travis Cardwell +-- License : MIT +-- +-- This library is meant to be imported qualified, as follows: +-- +-- @ +-- import qualified HR +-- @ +------------------------------------------------------------------------------ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module HR + ( -- * Constants + version + -- * Parts + , Parts(..) + , asciiParts + , unicodeParts + -- * API + -- ** Pure + , render + , renderAscii + , renderUnicode + -- ** IO + , put + , putAscii + , putUnicode + , putAuto + , putAutoAscii + , putAutoUnicode + ) where + +-- https://hackage.haskell.org/package/base +import Data.Maybe (fromMaybe) +import Data.Version (showVersion) + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import Data.Text (Text) + +-- (horizontal-rule) +import qualified HR.Monad.Terminal as Terminal +import HR.Monad.Terminal (MonadTerminal) + +-- (horizontal-rule:cabal) +import qualified Paths_horizontal_rule as Project + +------------------------------------------------------------------------------ +-- $Constants + +-- | hr version string (\"@hr-haskell X.X.X.X@\") +-- +-- @since 0.3.0.0 +version :: String +version = "hr-haskell " ++ showVersion Project.version + +------------------------------------------------------------------------------ +-- $Parts + +-- | Text parts of a horizontal rule +-- +-- @since 0.3.0.0 +data Parts + = Parts + { leftPart :: !Text -- ^ text before the first note + , midPart :: !Text -- ^ text between notes + , rightPart :: !Text -- ^ text after the last note + , fillPart :: !Char -- ^ fill character + } + +-- | ASCII text parts of a horizontal rule +-- +-- @since 0.3.0.0 +asciiParts :: Parts +asciiParts = Parts + { leftPart = "--|" + , midPart = "|-|" + , rightPart = "|--" + , fillPart = '-' + } + +-- | Unicode text parts of a horizontal rule +-- +-- @since 0.3.0.0 +unicodeParts :: Parts +unicodeParts = Parts + { leftPart = "━━┫" + , midPart = "┣━┫" + , rightPart = "┣━━" + , fillPart = '━' + } + +------------------------------------------------------------------------------ +-- $API + +-- | Render a horizontal rule +-- +-- Note that the rendered horizontal rule maybe longer than the specified rule +-- width if the provided notes is too wide. +-- +-- @since 0.3.0.0 +render + :: Parts + -> Int -- ^ rule width (characters) + -> [Text] -- ^ notes + -> Text +render Parts{..} width = \case + [] -> T.pack $ replicate width fillPart + notes -> + let rule = T.concat + [ leftPart + , T.intercalate midPart notes + , rightPart + ] + in case max 0 (width - T.length rule) of + 0 -> rule + fillWidth -> rule `T.append` T.pack (replicate fillWidth fillPart) + +-- | Render an ASCII horizontal rule +-- +-- Note that the rendered horizontal rule maybe longer than the specified rule +-- width if the provided notes is too wide. +-- +-- @since 0.3.0.0 +renderAscii + :: Int -- ^ rule width (characters) + -> [Text] -- ^ notes + -> Text +renderAscii = render asciiParts + +-- | Render a Unicode horizontal rule +-- +-- Note that the rendered horizontal rule maybe longer than the specified rule +-- width if the provided notes is too wide. +-- +-- @since 0.3.0.0 +renderUnicode + :: Int -- ^ rule width (characters) + -> [Text] -- ^ notes + -> Text +renderUnicode = render unicodeParts + +------------------------------------------------------------------------------ + +-- | Write a horizontal rule to the standard output device +-- +-- @since 0.5.0.0 +put + :: MonadTerminal m + => Parts + -> Int -- ^ rule width (characters) + -> [Text] -- ^ notes + -> m () +put parts width = Terminal.putStrLn . render parts width + +-- | Write an ASCII horizontal rule to the standard output device +-- +-- @since 0.5.0.0 +putAscii + :: MonadTerminal m + => Int -- ^ rule width (characters) + -> [Text] -- ^ notes + -> m () +putAscii = put asciiParts + +-- | Write a Unicode horizontal rule to the standard output device +-- +-- @since 0.5.0.0 +putUnicode + :: MonadTerminal m + => Int -- ^ rule width (characters) + -> [Text] -- ^ notes + -> m () +putUnicode = put unicodeParts + +------------------------------------------------------------------------------ + +-- | Write a full-width horizontal rule to the standard output device +-- +-- The default rule width is used if the terminal width cannot be determined. +-- +-- @since 0.5.0.0 +putAuto + :: MonadTerminal m + => Parts + -> Int -- ^ default rule width (characters) + -> [Text] -- ^ notes + -> m () +putAuto parts defaultWidth notes = do + width <- fromMaybe defaultWidth <$> Terminal.getWidth + Terminal.putStrLn $ render parts width notes + +-- | Write a full-width ASCII horizontal rule to the standard output device +-- +-- The default rule width is used if the terminal width cannot be determined. +-- +-- @since 0.5.0.0 +putAutoAscii + :: MonadTerminal m + => Int -- ^ default rule width (characters) + -> [Text] -- ^ notes + -> m () +putAutoAscii = putAuto asciiParts + +-- | Write a full-width Unicode horizontal rule to the standard output device +-- +-- The default rule width is used if the terminal width cannot be determined. +-- +-- @since 0.5.0.0 +putAutoUnicode + :: MonadTerminal m + => Int -- ^ default rule width (characters) + -> [Text] -- ^ notes + -> m () +putAutoUnicode = putAuto unicodeParts diff --git a/src/HR/Monad/Terminal.hs b/src/HR/Monad/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/HR/Monad/Terminal.hs @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- | +-- Module : HR.Monad.Terminal +-- Description : terminal output +-- Copyright : Copyright (c) 2019-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +module HR.Monad.Terminal + ( -- * MonadTerminal + MonadTerminal(..) + ) where + +-- https://hackage.haskell.org/package/terminal-size +import qualified System.Console.Terminal.Size as TS + +-- https://hackage.haskell.org/package/text +import Data.Text (Text) +import qualified Data.Text.IO as TIO + +------------------------------------------------------------------------------ +-- $MonadTerminal + +-- | Terminal output +-- +-- @since 0.5.0.0 +class Monad m => MonadTerminal m where + -- | Get the width of the terminal, if possible + getWidth :: m (Maybe Int) + + -- | Write a string to @STDOUT@, appending a newline + putStrLn :: Text -> m () + +instance MonadTerminal IO where + getWidth = fmap TS.width <$> TS.size + {-# INLINE getWidth #-} + + putStrLn = TIO.putStrLn + {-# INLINE putStrLn #-} diff --git a/test/HR/Mock.hs b/test/HR/Mock.hs new file mode 100644 --- /dev/null +++ b/test/HR/Mock.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HR.Mock (tests) where + +-- https://hackage.haskell.org/package/HMock +import qualified Test.HMock as HMock +import Test.HMock ((|->)) + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (TestTree, testGroup) + +-- https://hackage.haskell.org/package/tasty-hunit +import Test.Tasty.HUnit (testCase) + +-- (horizontal-rule) +import qualified HR +import HR.Monad.Terminal (MonadTerminal(..)) + +------------------------------------------------------------------------------ + +HMock.makeMockable [t|MonadTerminal|] + +------------------------------------------------------------------------------ + +parts :: HR.Parts +parts = HR.Parts + { HR.leftPart = "══╣" + , HR.midPart = "╠═╣" + , HR.rightPart = "╠══" + , HR.fillPart = '═' + } + +------------------------------------------------------------------------------ + +testPutAscii :: TestTree +testPutAscii = testCase "putAscii" . HMock.runMockT $ do + HMock.expect $ PutStrLn "--|test|------------" |-> () + HR.putAscii 20 ["test"] + +------------------------------------------------------------------------------ + +testPutUnicode :: TestTree +testPutUnicode = testCase "putUnicode" . HMock.runMockT $ do + HMock.expect $ PutStrLn "━━┫test┣━━━━━━━━━━━━" |-> () + HR.putUnicode 20 ["test"] + +------------------------------------------------------------------------------ + +testPut :: TestTree +testPut = testCase "put" . HMock.runMockT $ do + HMock.expect $ PutStrLn "══╣test╠════════════" |-> () + HR.put parts 20 ["test"] + +------------------------------------------------------------------------------ + +testPutAutoAscii :: TestTree +testPutAutoAscii = testGroup "putAutoAscii" + [ testCase "auto" . HMock.runMockT $ do + HMock.expect $ GetWidth |-> Just 20 + HMock.expect $ PutStrLn "--|test|------------" |-> () + HR.putAutoAscii 30 ["test"] + , testCase "default" . HMock.runMockT $ do + HMock.expect $ GetWidth |-> Nothing + HMock.expect $ PutStrLn "--|test|--" |-> () + HR.putAutoAscii 10 ["test"] + ] + +------------------------------------------------------------------------------ + +testPutAutoUnicode :: TestTree +testPutAutoUnicode = testGroup "putAutoUnicode" + [ testCase "auto" . HMock.runMockT $ do + HMock.expect $ GetWidth |-> Just 20 + HMock.expect $ PutStrLn "━━┫test┣━━━━━━━━━━━━" |-> () + HR.putAutoUnicode 30 ["test"] + , testCase "default" . HMock.runMockT $ do + HMock.expect $ GetWidth |-> Nothing + HMock.expect $ PutStrLn "━━┫test┣━━" |-> () + HR.putAutoUnicode 10 ["test"] + ] + +------------------------------------------------------------------------------ + +testPutAuto :: TestTree +testPutAuto = testGroup "putAuto" + [ testCase "auto" . HMock.runMockT $ do + HMock.expect $ GetWidth |-> Just 20 + HMock.expect $ PutStrLn "══╣test╠════════════" |-> () + HR.putAuto parts 30 ["test"] + , testCase "default" . HMock.runMockT $ do + HMock.expect $ GetWidth |-> Nothing + HMock.expect $ PutStrLn "══╣test╠══" |-> () + HR.putAuto parts 10 ["test"] + ] + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "HR:Mock" + [ testPutAscii + , testPutUnicode + , testPut + , testPutAutoAscii + , testPutAutoUnicode + , testPutAuto + ] diff --git a/test/HR/Test.hs b/test/HR/Test.hs new file mode 100644 --- /dev/null +++ b/test/HR/Test.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HR.Test (tests) where + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (TestTree, testGroup) + +-- https://hackage.haskell.org/package/tasty-hunit +import Test.Tasty.HUnit ((@=?), testCase) + +-- (horizontal-rule) +import qualified HR + +------------------------------------------------------------------------------ + +testRenderAscii :: TestTree +testRenderAscii = testGroup "renderAscii" + [ testCase "fill" $ + "----------------------------------------" @=? + HR.renderAscii 40 [] + , testCase "oneNote" $ + "--|test|--------------------------------" @=? + HR.renderAscii 40 ["test"] + , testCase "twoNotes" $ + "--|2021-05-27 17:29:42|-|test|----------" @=? + HR.renderAscii 40 ["2021-05-27 17:29:42", "test"] + , testCase "long" $ + "--|2021-05-27 17:29:42|-|this note is long|--" @=? + HR.renderAscii 40 ["2021-05-27 17:29:42", "this note is long"] + ] + +------------------------------------------------------------------------------ + +testRenderUnicode :: TestTree +testRenderUnicode = testGroup "renderUnicode" + [ testCase "fill" $ + "━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━" @=? + HR.renderUnicode 40 [] + , testCase "oneNote" $ + "━━┫test┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━" @=? + HR.renderUnicode 40 ["test"] + , testCase "twoNotes" $ + "━━┫2021-05-27 17:29:42┣━┫test┣━━━━━━━━━━" @=? + HR.renderUnicode 40 ["2021-05-27 17:29:42", "test"] + , testCase "long" $ + "━━┫2021-05-27 17:29:42┣━┫this note is long┣━━" @=? + HR.renderUnicode 40 ["2021-05-27 17:29:42", "this note is long"] + ] + +------------------------------------------------------------------------------ + +testRender :: TestTree +testRender = testGroup "render" + [ testCase "fill" $ + "════════════════════════════════════════" @=? + HR.render parts 40 [] + , testCase "oneNote" $ + "══╣test╠════════════════════════════════" @=? + HR.render parts 40 ["test"] + , testCase "twoNotes" $ + "══╣2021-05-27 17:29:42╠═╣test╠══════════" @=? + HR.render parts 40 ["2021-05-27 17:29:42", "test"] + , testCase "long" $ + "══╣2021-05-27 17:29:42╠═╣this note is long╠══" @=? + HR.render parts 40 ["2021-05-27 17:29:42", "this note is long"] + ] + where + parts :: HR.Parts + parts = HR.Parts + { HR.leftPart = "══╣" + , HR.midPart = "╠═╣" + , HR.rightPart = "╠══" + , HR.fillPart = '═' + } + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "HR" + [ testRenderAscii + , testRenderUnicode + , testRender + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (defaultMain, testGroup) + +-- (horizontal-rule:test) +import qualified HR.Test +#if __GLASGOW_HASKELL__ >= 806 +import qualified HR.Mock +#endif + +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ testGroup "test" + [ HR.Test.tests +#if __GLASGOW_HASKELL__ >= 806 + , HR.Mock.tests +#endif + ]