packages feed

hspec-tidy-formatter (empty) → 0.1.0.0

raw patch · 18 files changed

+1348/−0 lines, 18 filesdep +basedep +doctest-paralleldep +hedgehogbinary-added

Dependencies added: base, doctest-parallel, hedgehog, hspec, hspec-api, hspec-core, hspec-hedgehog, hspec-tidy-formatter

Files

+ README.lhs view
@@ -0,0 +1,166 @@+# `hspec-tidy-formatter`++_A custom [`hspec`] formatter for terminal output._++![GitHub License](https://img.shields.io/github/license/carlwr/hspec-tidy-formatter)+![Hackage Version](https://img.shields.io/hackage/v/hspec-tidy-formatter)++<br>++<p align="center">+  <ins>left</ins>: this formatter, <ins>right</ins>: hspec default<br>+</p>++![Screenshot](./assets/montage.png)++<p align="center">+  <sub>(color choices: &copy;<code>hspec</code>&nbsp;&nbsp;<del>me</del>&nbsp;&nbsp;<del>terminal theme</del>)</sub>+</p>+<br>++---++The formatter should work with with any test runner backend. It may be particularly useful with [Hedgehog] tests through [`hspec-hedgehog`]: it omits the _"passed 100 tests."_ otherwise printed after each spec item, yet includes manually added test output (`Hedgehog.collect`, `Hedgehog.label` etc.).+++<!--+```haskell+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- module Main (main) where+-- import Prelude++```+-->+++## How to enable++### With `hspec-discover`++Place a file `SpecHook.hs` in the source directory of the test component:++```haskell+-- --- test/SpecHook.hs ---++import Test.Hspec+import qualified Test.Hspec.TidyFormatter as TidyFormatter++hook :: Spec -> Spec++-- use by default:+hook = TidyFormatter.use++-- to instead use only if requested (`hspec --format=tidy`):+-- hook = TidyFormatter.register+```++`hspec --help` can be used to inspect which formatters `hspec` is aware of:++```diff+ $ cabal test hspec --test-options=--help | grep -A3 FORMATTER++ FORMATTER OPTIONS+   -f NAME  --format=NAME     use a custom formatter; can be one of+-                             checks, specdoc, progress,++                             checks, specdoc, progress, tidy+                              failed-examples or silent+```++### By modifying `Spec`-s directly++```haskell+main :: IO ()+main = hspec . TidyFormatter.use $ spec++spec :: Spec+spec = it "adds" $ 1+1 `shouldBe` (2::Int)+```+++## Functionality, options++* supports transient output/progress++* honors most `hspec` options, including: `--times`, `--no-unicode`, `--no-color`, `--print-cpu-time`, `--print-slow-items=[=N]`++### Printing of additional text from test runners++`hspec` allows test runners to pass it additional text together with the outcome of each test. This formatter, by default, prints such text only if it spans more than one line. To instead print all such text unconditionally, use `--times` (default: `--no-times`). This will additionally do what this option is originally supposed to do: print the execution time for spec items (if `> 0` after rounding to milliseconds).++E.g. with [`hspec-hedgehog`], which passes the number of tests run for each item as a single line of text:++```diff+- $  hspec --format=tidy++ $  hspec --format=tidy --times++  [...]+    is Applicative-lawful per+-     [✔] Identity++     [✔] Identity  (21ms) (passed 100 tests.)+```++To instead _suppress_ the printing of any additional text from the test runner, use `--expert` (default: `--no-expert`).++### Verbosity switches `--[no-]expert`, `--[no-]times` combinations++_For two spec items whose test runner returns a single line, and a few lines, respectively, of additional text:_++```+===========       =========================================+<ARGS>            `hspec <ARGS>` example output+===========       =========================================+++                                             (most verbose)+++-----------       -----------------------------------------+--times           [✔] Identity  (21ms) (passed 100 tests.)+--no-expert       [✔] Hedgehog generator  (49ms)+                    passed 100 tests.+                      n:   0       1% ▏···················+                      n:   1- 4    5% █···················+                      n:   5-19   16% ███▏················+++-----------       -----------------------------------------+--no-times        [✔] Identity+--no-expert       [✔] Hedgehog generator+(DEFAULT)           passed 100 tests.+                      n:   0       1% ▏···················+                      n:   1- 4    5% █···················+                      n:   5-19   16% ███▏················+++-----------       -----------------------------------------+--times           [✔] Identity  (21ms)+--expert          [✔] Hedgehog generator  (49ms)+++-----------       -----------------------------------------+--no-times        [✔] Identity+--expert          [✔] Hedgehog generator+++                                            (least verbose)++```+<!-- zsh command to produce material for the table:+foreach e (--no-expert --expert) {+foreach t (--times --no-times) {+  echo $t+  echo $e+  command cabal -v0 test test:readme-example --test-options="--no-color --format=tidy $t $e" \+  | awk "NR==6 || (NR>=18 && NR<=22)" \+  | grep -P '^ '+  echo+} }+-->+++<!-- links -->++[Hedgehog]: https://hackage.haskell.org/package/hedgehog+[`hspec`]: http://hspec.github.io+[`hspec-hedgehog`]: https://hackage.haskell.org/package/hspec-hedgehog
+ README.md view
@@ -0,0 +1,166 @@+# `hspec-tidy-formatter`++_A custom [`hspec`] formatter for terminal output._++![GitHub License](https://img.shields.io/github/license/carlwr/hspec-tidy-formatter)+![Hackage Version](https://img.shields.io/hackage/v/hspec-tidy-formatter)++<br>++<p align="center">+  <ins>left</ins>: this formatter, <ins>right</ins>: hspec default<br>+</p>++![Screenshot](./assets/montage.png)++<p align="center">+  <sub>(color choices: &copy;<code>hspec</code>&nbsp;&nbsp;<del>me</del>&nbsp;&nbsp;<del>terminal theme</del>)</sub>+</p>+<br>++---++The formatter should work with with any test runner backend. It may be particularly useful with [Hedgehog] tests through [`hspec-hedgehog`]: it omits the _"passed 100 tests."_ otherwise printed after each spec item, yet includes manually added test output (`Hedgehog.collect`, `Hedgehog.label` etc.).+++<!--+```haskell+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- module Main (main) where+-- import Prelude++```+-->+++## How to enable++### With `hspec-discover`++Place a file `SpecHook.hs` in the source directory of the test component:++```haskell+-- --- test/SpecHook.hs ---++import Test.Hspec+import qualified Test.Hspec.TidyFormatter as TidyFormatter++hook :: Spec -> Spec++-- use by default:+hook = TidyFormatter.use++-- to instead use only if requested (`hspec --format=tidy`):+-- hook = TidyFormatter.register+```++`hspec --help` can be used to inspect which formatters `hspec` is aware of:++```diff+ $ cabal test hspec --test-options=--help | grep -A3 FORMATTER++ FORMATTER OPTIONS+   -f NAME  --format=NAME     use a custom formatter; can be one of+-                             checks, specdoc, progress,++                             checks, specdoc, progress, tidy+                              failed-examples or silent+```++### By modifying `Spec`-s directly++```haskell+main :: IO ()+main = hspec . TidyFormatter.use $ spec++spec :: Spec+spec = it "adds" $ 1+1 `shouldBe` (2::Int)+```+++## Functionality, options++* supports transient output/progress++* honors most `hspec` options, including: `--times`, `--no-unicode`, `--no-color`, `--print-cpu-time`, `--print-slow-items=[=N]`++### Printing of additional text from test runners++`hspec` allows test runners to pass it additional text together with the outcome of each test. This formatter, by default, prints such text only if it spans more than one line. To instead print all such text unconditionally, use `--times` (default: `--no-times`). This will additionally do what this option is originally supposed to do: print the execution time for spec items (if `> 0` after rounding to milliseconds).++E.g. with [`hspec-hedgehog`], which passes the number of tests run for each item as a single line of text:++```diff+- $  hspec --format=tidy++ $  hspec --format=tidy --times++  [...]+    is Applicative-lawful per+-     [✔] Identity++     [✔] Identity  (21ms) (passed 100 tests.)+```++To instead _suppress_ the printing of any additional text from the test runner, use `--expert` (default: `--no-expert`).++### Verbosity switches `--[no-]expert`, `--[no-]times` combinations++_For two spec items whose test runner returns a single line, and a few lines, respectively, of additional text:_++```+===========       =========================================+<ARGS>            `hspec <ARGS>` example output+===========       =========================================+++                                             (most verbose)+++-----------       -----------------------------------------+--times           [✔] Identity  (21ms) (passed 100 tests.)+--no-expert       [✔] Hedgehog generator  (49ms)+                    passed 100 tests.+                      n:   0       1% ▏···················+                      n:   1- 4    5% █···················+                      n:   5-19   16% ███▏················+++-----------       -----------------------------------------+--no-times        [✔] Identity+--no-expert       [✔] Hedgehog generator+(DEFAULT)           passed 100 tests.+                      n:   0       1% ▏···················+                      n:   1- 4    5% █···················+                      n:   5-19   16% ███▏················+++-----------       -----------------------------------------+--times           [✔] Identity  (21ms)+--expert          [✔] Hedgehog generator  (49ms)+++-----------       -----------------------------------------+--no-times        [✔] Identity+--expert          [✔] Hedgehog generator+++                                            (least verbose)++```+<!-- zsh command to produce material for the table:+foreach e (--no-expert --expert) {+foreach t (--times --no-times) {+  echo $t+  echo $e+  command cabal -v0 test test:readme-example --test-options="--no-color --format=tidy $t $e" \+  | awk "NR==6 || (NR>=18 && NR<=22)" \+  | grep -P '^ '+  echo+} }+-->+++<!-- links -->++[Hedgehog]: https://hackage.haskell.org/package/hedgehog+[`hspec`]: http://hspec.github.io+[`hspec-hedgehog`]: https://hackage.haskell.org/package/hspec-hedgehog
+ assets/montage.png view

binary file changed (absent → 163354 bytes)

+ hspec-tidy-formatter.cabal view
@@ -0,0 +1,172 @@+cabal-version: 3.0++name:           hspec-tidy-formatter+version:        0.1.0.0+stability:      experimental+category:       Testing+synopsis:       A custom hspec formatter for easy-to-read terminal output.+homepage:       https://github.com/carlwr/hspec-tidy-formatter#readme+bug-reports:    https://github.com/carlwr/hspec-tidy-formatter/issues+author:         Carl+maintainer:     Carl+copyright:      none+license:        MIT+build-type:     Simple+tested-with:+    GHC == 9.12.2+    GHC == 9.10.2+    GHC == 9.4.8+extra-doc-files:+    README.md+    README.lhs+    assets/montage.png+description:+    A custom hspec formatter for easy-to-read terminal output. For details, refer to the README.md file.++source-repository head+  type: git+  location: https://github.com/carlwr/hspec-tidy-formatter++flag doctest+  description: enable doctests+  default: False+  manual: True++flag suppress-module-prefixes+  default: False+  manual: True++common dep_base       { build-depends: base             >= 4.17.2.1 && < 5 }+common dep_hspec-api  { build-depends: hspec-api        >= 2.11.8   && < 3 }+common dep_hspec      { build-depends: hspec            >= 2.11.8   && < 3 }+common dep_hspec-core { build-depends: hspec-core       >= 2.11.8   && < 3 }+common dep_hspec-hh   { build-depends: hspec-hedgehog   >= 0.3.0.0  && < 1 }+common dep_hh         { build-depends: hedgehog         >= 1.5      && < 2 }++common tooldep_hspec-discover+  build-tool-depends:+      hspec-discover:hspec-discover >= 2.11.8 && < 3++common defaults+  autogen-modules: Paths_hspec_tidy_formatter+  other-modules:   Paths_hspec_tidy_formatter+  ghc-options:+      -Wall+      -Wcompat+      -Widentities+      -Wincomplete-record-updates+      -Wincomplete-uni-patterns+      -Wredundant-constraints+      -Wno-type-defaults+      -Wno-partial-type-signatures+      -Wnoncanonical-monad-instances+      -Wpartial-fields+      -Winvalid-haddock+      -Wredundant-bang-patterns+      -Wredundant-strictness-flags+      -freverse-errors+      -fshow-hole-matches-of-hole-fits+      -fhide-source-paths+      -fwrite-ide-info+  if impl(ghc >= 9.8) { ghc-options:+      -Winconsistent-flags+      }+  if flag(suppress-module-prefixes) { ghc-options:+      -dsuppress-module-prefixes+      }+  default-language: GHC2021+  default-extensions:+      PartialTypeSignatures+      UnicodeSyntax+      ExtendedDefaultRules+      LambdaCase+      RecordWildCards++library+  import:+    , defaults+    , dep_base+    , dep_hspec-api+  hs-source-dirs: src+  exposed-modules:+      Test.Hspec.TidyFormatter+      Test.Hspec.TidyFormatter.Internal+      Test.Hspec.TidyFormatter.Internal.Parts++test-suite readme+  import:+    , defaults+    , dep_base+    , dep_hspec+  type:            exitcode-stdio-1.0+  main-is:         README.lhs+  ghc-options:     -pgmL markdown-unlit+  build-tool-depends:+    , markdown-unlit:markdown-unlit == 0.6.0+  build-depends:+    , hspec-tidy-formatter++test-suite doctest+  import:+    , defaults+    , dep_base+  if !flag(doctest)+      buildable: False+  hs-source-dirs:  test/doctests+  type:            exitcode-stdio-1.0+  main-is:         doctests.hs+  ghc-options:+      -threaded+  build-depends:+    , hspec-tidy-formatter+    , doctest-parallel >= 0.3 && < 1.0++test-suite readme-example+  import:+    , defaults+    , dep_base+    , dep_hspec+    , dep_hspec-core+    , dep_hspec-hh+    , dep_hh+    , tooldep_hspec-discover+  hs-source-dirs:  readme-example+  type:            exitcode-stdio-1.0+  main-is:         Spec.hs+  ghc-options:+      -threaded+      -rtsopts+      -with-rtsopts=-N+      -main-is Spec+  other-modules:+      Data.MyLogic.Core.InstancesSpec+      Data.MyLogic.EvaluatorSpec+      Data.MyLogic.TestUtils.GeneratorSpec+      Helpers+      SpecHook+  build-depends:+    , hspec-tidy-formatter++test-suite dev-example+  import:+    , defaults+    , dep_base+    , dep_hspec+    , dep_hspec-core+    , dep_hspec-hh+    , dep_hh+    , tooldep_hspec-discover+  hs-source-dirs:  test/dev-example+  type:            exitcode-stdio-1.0+  main-is:         Spec.hs+  ghc-options:+      -threaded+      -rtsopts+      -with-rtsopts=-N+      -main-is Spec+  other-modules:+      ExampleSpec+      Example.SubSpec+      SpecHook+  build-depends:+    , hspec-tidy-formatter
+ readme-example/Data/MyLogic/Core/InstancesSpec.hs view
@@ -0,0 +1,17 @@+module Data.MyLogic.Core.InstancesSpec+( spec+) where++import Test.Hspec+import Helpers++spec :: Spec+spec = do+  it "Functor"   True+  it "Monoid" True+  describe "is Applicative-lawful per" $ do+    it_hh_slow "Identity"+    it_hh      "Homomorphism"+    it_hh      "Interchange"+    it_hh      "Composition"+
+ readme-example/Data/MyLogic/EvaluatorSpec.hs view
@@ -0,0 +1,12 @@+module Data.MyLogic.EvaluatorSpec+( spec+) where++import Test.Hspec+import Helpers++spec :: Spec+spec = do+  it_hh "is consistent"+  it    "proves this test to fail"+    $ pendingWith "seems to run forever\n->TODO trouble-shoot"
+ readme-example/Data/MyLogic/TestUtils/GeneratorSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.MyLogic.TestUtils.GeneratorSpec+( spec+) where++import Helpers+import Test.Hspec+import Test.Hspec.Hedgehog+import Hedgehog.Gen   qualified as Gen+import Hedgehog.Range qualified as Range++spec :: Spec+spec = do+  it "Hedgehog generator" $ hedgehog $ do+    x <- forAll (Gen.int $ Range.constant 0 100)+    distributions x+    delayIO++distributions :: MonadTest m => Int -> m ()+distributions x = do+  classify "  n:   0     " (x== 0         )+  classify "  n:   1- 4  " (x>= 1 && x<= 4)+  classify "  n:   5-19  " (x>= 5 && x<=19)+  classify "  n:  20-79  " (x>=20 && x<=79)+  classify "  n:  80-    " (x>=80         )
+ readme-example/Helpers.hs view
@@ -0,0 +1,15 @@+module Helpers where++import Test.Hspec+import Test.Hspec.Hedgehog+import Control.Concurrent (threadDelay)+++it_hh      :: String -> Spec+it_hh_slow :: String -> Spec++it_hh      desc = it desc $ hedgehog $ success+it_hh_slow desc = it desc $ hedgehog $ delayIO++delayIO :: PropertyT IO ()+delayIO = evalIO (threadDelay 6)
+ readme-example/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ readme-example/SpecHook.hs view
@@ -0,0 +1,19 @@+module SpecHook+( hook+) where++import qualified Test.Hspec.TidyFormatter as Tidy+import Test.Hspec+import Test.Hspec.Core.Spec (modifyConfig)+import Test.Hspec.Core.Runner (Config(..))+import Test.Hspec.Runner (ColorMode(ColorAlways))++hook :: Spec -> Spec+hook = (setupSpec >>) . Tidy.use++setupSpec :: Spec+setupSpec = modifyConfig $+    (\c -> c { configSeed      = Just seed   })+  . (\c -> c { configColorMode = ColorAlways })+  where+    seed = 1
+ src/Test/Hspec/TidyFormatter.hs view
@@ -0,0 +1,41 @@+{-|+Description : A custom hspec formatter for easy-to-read terminal output.+License     : MIT+-}++module Test.Hspec.TidyFormatter+(+  -- * Formatter+  use+, register+, formatter++  -- * Re-exported API+, module Test.Hspec.Api.Formatters.V3++) where+++import Test.Hspec.TidyFormatter.Internal qualified as Internal+import Test.Hspec.Api.Formatters.V3+++-- | Use the formatter by default. Also makes it available for selection with @hspec --format=tidy@.+use :: SpecWith () -> SpecWith ()+use = (modifyConfig (useFormatter formatter) >>)++-- | Make the formatter available for selection with @hspec --format=tidy@.+register :: SpecWith a -> SpecWith a+register = (modifyConfig (registerFormatter formatter) >>)++-- | The named formatter.+formatter :: (String,Formatter)+formatter = (name,Internal.tidy)+++--+-- non-exported+--++name :: String+name = "tidy"
+ src/Test/Hspec/TidyFormatter/Internal.hs view
@@ -0,0 +1,286 @@+{-|+Description : (Internal module)+License     : MIT+-}++{-# LANGUAGE OverloadedStrings #-}++module Test.Hspec.TidyFormatter.Internal+( tidy+) where++import Test.Hspec.TidyFormatter.Internal.Parts++import Test.Hspec.Api.Formatters.V3 qualified as Api+import Test.Hspec.Api.Formatters.V3 (Formatter, FormatM)+import Data.Monoid (Endo (..))+import Control.Monad (when)+import Data.Bifunctor+++--+-- Exported formatter+--++tidy :: Formatter+tidy = Api.Formatter {+  formatterStarted      = pure ()+, formatterDone         = Api.formatterDone Api.checks -- footer, failures+, formatterGroupDone    = \(_ ,_  )     -> nothing+, formatterGroupStarted = \(gs,grp)     -> write     gs (groupStarted grp)+, formatterItemStarted  = \(gs,req)     -> transient gs (itemStarted req)+, formatterItemDone     = \(gs,req) itm -> write     gs (itemDone req itm)+, formatterProgress     = \(gs,_  ) prg -> transient gs (progress prg)+}+  where nothing = pure ()+++--+-- hspec API type aliases+--++type Group       = String   -- ([Group],Req) == Api.Path+type Req         = String+type ItemInfo    = String+type Indentation = [Group]  -- [Group] when used to determine indentation+++--+-- Chunks and Lines+--++{- |+'Chunks': a sequence of text fragments to be written to the terminal; constitutes a full line or part of a line+'Lines' : a list of 'Chunks' with each element representing one printed line of text, in the String/[String]/lines/unlines sense++Neither ever contains \n-s.++Note: the [Chunks] of 'Lines' is embedded in an outer t'Parts' to allow monadic FormatM conditions to influence whether the newlines implied by [Chunks] are printed or not, i.e. to influence whether a 'Lines' value (including its implied newlines) are printed or not.++> Chunks ~ Silenceable FormatM String+> Lines  ~ Silenceable FormatM [Chunks]++-}++type WithFormat = Endo (FormatM ())++type Chunks' ann = Parts ann String+type Lines'  ann = Parts ann [Chunks]++type Chunks = Chunks' WithFormat+type Lines  = Lines'  WithFormat++chunk :: String -> Chunks+chunk = string . filter (/='\n')++line :: Chunks -> Lines+line chunks = value [chunks]+++--+-- Output+--++-- `write` and `transient` find and leave the terminal state as: cursor at column 0 of next line to be written++type TransientString = String++write :: Indentation -> Lines -> FormatM ()+write gs = run (run Api.write . vsep . unlines')+  where+    unlines' = foldMap mkLine+    mkLine c = indentation gs <> c <> "\n"++    vsep|isLevel0  = ("\n" <>)+        |otherwise = id++    isLevel0 = null gs++transient :: Indentation -> TransientString -> FormatM ()+transient gs =+  writeTransient+  . (indentationStr gs ++)+  . filter (/='\n')+  where+    writeTransient = whenReportProgress . Api.writeTransient+++--+-- Handlers+--++groupStarted :: Group -> Lines+groupStarted group = line (chunk group)++itemStarted :: Req -> TransientString+itemStarted req = "[ ] " ++ req++itemDone :: Req -> Api.Item -> Lines+itemDone req itm =+     line (box <> chunk req <> duration <> ifOneline info)+  <> pending+  <> ifMultiline info+  where+    duration = mkDuration (Api.itemDuration itm)+    info     = mkInfo     (Api.itemInfo     itm)++    (box,pending) =+      case Api.itemResult itm of+        Api.Success     -> (mkBox '✔' 'v' succColor,empty   )+        Api.Failure _ _ -> (mkBox '✘' 'x' failColor,empty   )+        Api.Pending _ s -> (mkBox '‐' '-' pendColor,mkPending s)++progress :: Api.Progress -> TransientString+progress (now,total) = "[" ++ str ++ "]"+  where+    str+      |total==0  = show now+      |otherwise = show now ++ "/" ++ show total+++--+-- Handler helpers+--++data Info' ann = Info+  { ifOneline   :: Chunks' ann+  , ifMultiline :: Lines'  ann+  }++instance Functor Info' where+  fmap f (Info one multi) = Info (first f one) (first f multi)++type Info = Info' WithFormat++mkInfo :: ItemInfo -> Info+mkInfo str =+  unlessExpert . infoColor <$>+  case lines str of+    []  -> z+    [l] -> z{ ifOneline   =       (one   $ l ) `onlyIf` isVerbose }+    ls  -> z{ ifMultiline = value (multi<$>ls) }+  where+    z       = Info empty empty+    one   s = chunk $ " (" <> s <> ")"+    multi s = chunk $ "  " <> s++mkPending :: Maybe String -> Lines+mkPending mb =+  value $+  extraInd . mapAnn pendColor . chunk <$>+  case lines <$> mb of+    Nothing -> [ "# PENDING"   ]+    Just ls -> ( "# PENDING: "+               , "           " ) `laminate` ls+  where+    laminate (x,y) = zipWith (++) (x : repeat y)+    extraInd c     = "    " <> c++mkDuration :: Api.Seconds -> Chunks+mkDuration (Api.Seconds secs) =+  maybeEmpty (chunk <$> mbStr)+    `with`   infoColor+    `onlyIf` Api.printTimes+  where+    mbStr = case floor (secs * 1000) of+      0  -> Nothing+      ms -> Just $ ("  (" ++ show ms ++ "ms)")++mkBox :: Char -> Char -> Color -> Chunks+mkBox unicode ascii color = "[" <> marker <> "] "+  where+    marker =+      ifThenElse Api.outputUnicode+        (chunk [unicode] `with` color)+        (chunk [ascii  ] `with` color)+++--+-- Api shorthands+--++type Color = WithFormat -> WithFormat++infoColor :: Color+pendColor :: Color+succColor :: Color+failColor :: Color++infoColor = (<> Endo Api.withInfoColor   )+pendColor = (<> Endo Api.withPendingColor)+succColor = (<> Endo Api.withSuccessColor)+failColor = (<> Endo Api.withFailColor   )++isVerbose :: FormatM Bool+isVerbose = Api.printTimes+  -- borrow '--times' as verbosity switch since that gives non-verbose by default, which is what we want (using '--expert' would give _verbose_ by default)++unlessExpert :: WithFormat -> WithFormat+unlessExpert = (<> Endo Api.unlessExpert)++whenReportProgress :: FormatM () -> FormatM ()+whenReportProgress = whenM (Api.getConfigValue Api.formatConfigReportProgress)+++--+-- Misc+--++indentationStr :: Indentation -> String+indentationStr gs = replicate (length gs * 2) ' '++indentation :: Indentation -> Chunks+indentation gs = chunk (indentationStr gs)+++--+-- General helpers+--++whenM :: Monad m => m Bool -> m () -> m ()+whenM bM action = do+  b <- bM+  when b action+++--+-- Dev notes+--++{- Dev notes:++ref.: source code for built-in formatters:+  https://hackage-content.haskell.org/package/hspec-core/docs/src/Test.Hspec.Core.Formatters.V2.html++---++'writeTransient' of `hspec-api` does roughly:++> writeTransient str = do+>   IO.hPutStr stdout str         -- print payload+>   IO.hFlush  stdout+>   IO.hPutStr stdout "\r\ESC[K"  -- schedule CR, ^K (^K == clear-line)++Effect: the clear-line control sequence will be emitted the next time the output buffer is flushed; until then, the transient payload will be visible in the terminal++---++With this spec tree...++@+spec :: 'Test.Hspec.Spec'+spec = do+  describe "d0" $ do+    describe "d1" $ do+      it "i" $ do+        1 == 1+@++...the t'Api.Path' provided for the inner 'Test.Hspec.it' node will be:++@+path :: 'Api.Path'+path = (["d0","d1"],"i")+@++-}
+ src/Test/Hspec/TidyFormatter/Internal/Parts.hs view
@@ -0,0 +1,285 @@+{-|+Description : Ordered annotated sequences useful for conditional emission+License     : MIT++/The mise-en-place utility set needed for a readable, declarative implementation of "Test.Hspec.TidyFormatter" -- in the dress of a small, general annotated-sequence module./++The t'Parts' type expresses /ordered annotated sequences/. It is expected to be useful primarily in its 'Silenceable' specialization.++The 'Silenceable' type, together with utility functions and instances, can be useful as an abstraction over sequences of /pairs of pure values and effect-modifying functions/.++-}+++{-# LANGUAGE OverloadedStrings #-}++module Test.Hspec.TidyFormatter.Internal.Parts+where++import Control.Monad (when)+import Data.String (IsString (..))+import Data.Monoid (Endo (..))+import Data.Bifunctor (Bifunctor (..))+++{- $setup+>>> import Data.Monoid (Sum)+-}++-- * Type++{- | An ordered sequence of /elements/ where each /element/ consists of an /annotation/ and a /label/.++This type is a thin newtype wrapper over [(a,b)], and usefully different from that bare type in nuance only: in t'Parts', the first tuple component (the /annotation/) is assumed to be meaningful only together with the second tuple component (the /label/). Therefore, t'Parts' have no utility functions or instances that allow combining over only the annotations of a t'Parts' - hence the lack of (Bi)Foldable and (Bi)Traversable. t'Parts' instead offers up to (Bi)Functor, Semigroup and Monoid; all of which retains the structural pairing of annotations and labels. For combining over the @(ann,b)@ pairs (elements) of a t'Parts', 'foldParts' and 'interpret' are provided instead.++Further, the justification of a 'Parts' type could be claimed to rely solely on its specialization to the 'Silenceable' type.+-}+newtype Parts ann b = Parts [(ann,b)]+  deriving (Functor, Read, Show, Eq, Ord)++instance Bifunctor Parts where+  bimap :: (ann -> ann') -> (b -> b') -> Parts ann b -> Parts ann' b'+  bimap f g = mapAnn f . fmap g++instance Semigroup (Parts ann b) where+  Parts xs <> Parts ys = Parts (xs ++ ys)++instance Monoid (Parts ann b) where+  mempty = Parts []++instance (Monoid ann, IsString b) => IsString (Parts ann b) where+  fromString = string+++-- * Create++{- $create++Examples:++>>> singleton [] "a" :: Parts [Int] String+Parts [([],"a")]++>>> string "a" :: Parts [Int] String+Parts [([],"a")]++>>> p = singleton [] "a" :: Parts [Int] String+>>> :seti -XOverloadedStrings+>>> p <> "b"+Parts [([],"a"),([],"b")]+-}++singleton :: ann -> b -> Parts ann b+singleton ann x = Parts [(ann,x)]++-- | Embed a value annotated with 'mempty'.+value :: Monoid ann => b -> Parts ann b+value x = Parts [(mempty,x)]++-- | Embed a string literal annotated with 'mempty'.+string :: (Monoid ann, IsString b) => String -> Parts ann b+string s = Parts [(mempty,fromString s)]++empty :: Parts ann b+empty = Parts []+++-- * Modify++maybeEmpty :: Maybe (Parts ann b) -> Parts ann b+maybeEmpty = \case+  Just p -> p+  _      -> empty++{- | Map annotations.++@+mapAnn == 'first'+@+-}+mapAnn :: (ann->ann') -> Parts ann b -> Parts ann' b+mapAnn f (Parts xs) = Parts (f' <$> xs)+  where+    f' (ann,b) = (f ann,b)++{- | Flipped 'mapAnn'.++Examples:++>>> p = string "ab" :: Parts [Int] String+>>> p+Parts [([],"ab")]++>>> p `with` (++[1])+Parts [([1],"ab")]++The high precedence of the operator variant means it binds tighter than e.g. '<>', which is inteded to facilitate constructs such as:++>>> :seti -XOverloadedStrings+>>> :{+let parts :: Parts (Sum Int) String+    parts =    "a" `with` (+1)+            <> "b" `with` (+2)+in  parts+:}+Parts [(Sum {getSum = 1},"a"),(Sum {getSum = 2},"b")]++(Note: above, the 'IsString' instance promotes the string literals to 'Parts', initializing the annotation to 'mempty' == 'Sum 0'.)+-}+with :: Parts ann b -> (ann -> ann') -> Parts ann' b+with = flip mapAnn+infixl 7 `with`+++-- * Fold++{- | Right-fold a t'Parts'.++@+v'Parts' . 'foldParts' (:) [] == 'id'+@+-}+foldParts ::+     ((ann,b) -> acc -> acc) -- ^ combine+  -> acc                     -- ^ initial aggregate+  -> Parts ann b+  -> acc+foldParts f z (Parts xs) = foldr f z xs+++-- * Interpret++{- | Interpret an annotated sequence by applying a function to each element and combine the results.++@+'interpret' (,)                == 'foldParts'+'Parts' . 'interpret' (,) (:) [] == 'id'+@++Examples:++>>> parts = singleton 'a' 1 <> singleton 'b' 2+>>> interpret (,) (:) [] parts+[('a',1),('b',2)]++> >>> :seti -XOverloadedStrings+> >>> import Data.Monoid (Endo(..))+> >>> interp  = interpret (\ann -> appEndo ann . putStr) (>>) (pure ())+> >>> bold    = putStr "\ESC[1m"+> >>> stop    = putStr "\ESC[0m"+> >>> asBold  = Endo $ \x -> bold >> x >> stop+> >>> interp $ "plain, " <> "bold" `with` (<> asBold)+> <prints "plain, bold" with "bold" bold-formatted>+-}+interpret :: ∀ ann b c acc.+     (ann->b->c)   -- ^ interpreting one element+  -> (c->acc->acc) -- ^ adding an interpretation to the aggregate+  -> acc           -- ^ initial aggregate+  -> Parts ann b   -- ^ the t'Parts' to interpret+  -> acc           -- ^ returned interpretation+interpret interp f = foldParts f'+  where+    f' :: (ann,b) -> acc -> acc+    f' (ann,b) acc = interp ann b `f` acc+++-- * t'Parts' with 'Silenceable' elements++{- $silenceable++The 'Silenceable' specialization of t'Parts' have annotations that /describe how to transform the effect of emitting the label it is paired with/. This allows embedding per-element effectfully-predicated include/suppress decisions in the annotations. The decisions are effectuated at interpretation time.+-}++type Silenceable m b = Parts (Endo (m ())) b+++-- ** Conditionals++{- $silenceable-conditionals++These transformations are semantically meaningful, and in a way that aligns with the function names, if later interpreted with 'run', e.g. @'run' 'putStr'@.++Labels remain pure, inspectable and 'fmap'-able; instances remain lawful.++Note: upon interpretation,++- effectful predicates will run /for each element/+- conditionals nested on the same element have short-circuiting behaviour+-}+++{- | /Conditional inclusion/.++Transform each annotation so that, when interpreted as a wrapper around the element’s action, the element’s effects are only run if the effectful predicate evaluates to True.+-}+when' :: Monad m =>+     m Bool+  -> Silenceable m b -- ^ to include if True (else nothing)+  -> Silenceable m b+when' bM = mapAnn (Endo f <>)+  where+    f action = do+      b <- bM+      when b action++-- | /Conditional inclusion/ based on a pure predicate.+whenA :: Applicative f =>+     Bool+  -> Silenceable f b -- ^ to include if True (else nothing)+  -> Silenceable f b+whenA b = mapAnn (Endo (when b) <>)+++{- | Flipped 'when''.++Example:++>>> import Data.Monoid (Endo(..))+>>> import Data.Char (toUpper)+>>> upper  = fmap toUpper+>>> interp = interpret (\ann -> appEndo ann . putStr) (>>) (pure ())+>>> yes    = string "yes" `onlyIf` (pure True )+>>> no     = string "no"  `onlyIf` (pure False)+>>> ok     = upper <$> (yes <> no <> string ".")+>>> interp ok+YES.+-}+onlyIf :: Monad m =>+     Silenceable m b+  -> m Bool+  -> Silenceable m b+onlyIf = flip when'+infixl 7 `onlyIf`+++{- | /Binary choice/.++At interpretation, the monadic condition will be run twice (for every element).++The expectation that exactly one of the arguments will have all its elements included and the other have all its elements suppressed will hold if the same Bool is returned every time the effectful condition is run.+-}++ifThenElse :: Monad m =>+     m Bool+  -> Silenceable m b  -- ^ to include if True+  -> Silenceable m b  -- ^ to include if False+  -> Silenceable m b+ifThenElse pM true false =+     (when'        pM  true )+  <> (when' (not<$>pM) false)+++-- ** Interpret++{- | Interpret by emitting each label with the given function, then applying the annotation, and combining with '>>'.++Note: this function is basically 'interpret', but with some type specialization, some defaults and an adjusted API shape.+-}+run :: Monad m =>+     (b -> m ())      -- ^ emitting a label+  -> Silenceable m b  -- ^ the t'Silenceable' to interpret+  -> m ()             -- ^ returned interpretation+run emit = interpret f (>>) z+  where+    f ann b = appEndo ann (emit b)+    z       = pure ()
+ test/dev-example/Example/SubSpec.hs view
@@ -0,0 +1,10 @@+module Example.SubSpec+( spec+) where++import Test.Hspec++spec :: Spec+spec = do+  it "SubEx non-hh 0" $ True+  it "SubEx non-hh 1" $ True
+ test/dev-example/ExampleSpec.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module ExampleSpec+( spec+) where+++import Test.Hspec+import Test.Hspec.Hedgehog+import Control.Concurrent+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Control.Monad.IO.Class (liftIO)+import Control.Monad (when)+++spec :: Spec+spec = do+  when True simple+  when True full++simple :: Spec+simple = do+  it_slow "" 200+  it_slow "" 300+  it_slow "" 600+  describe "sub1" $ do+    it_slow "1_a" 200+    it_slow "1_b" 300+  it_ok "under root"++full :: Spec+full = describe "FULL" $ do+  it_hh_slow  ""   15+  it_slow     "1" 100+  it_slow     "2" 200+  it_slow     "3" 300+  it_hh_cubic ""+  describe "desc0" $ do+    it_hh      ""+    it_pend    "pending"+    it_hh_slow "" 15+    describe "sub" $ do+      it_pendW "sub-pending" "pending msg"+      it_pendW "sub-pending" "pending multi-\nline-\nmsg"+      it_ok    "sub"+  describe "hedgehog stats" $ do+    it_hh_stats "stats"+    it_ok       "stats-after"+  when False $+    _t_hh_fails "fails"+++it_ok       :: String -> Spec+it_pend     :: String -> Spec+it_pendW    :: String -> String -> Spec+it_slow     :: String -> Int -> Spec+it_hh       :: String -> Spec+it_hh_slow  :: String -> Int -> Spec+it_hh_cubic :: String -> Spec+_t_hh_fails :: String -> Spec+it_hh_stats :: String -> Spec++it_ok       desc   = it desc $ True+it_pend     desc   = it desc $ pending+it_pendW    desc s = it desc $ pendingWith s+it_slow     desc n = it ("DELAY "   <>desc) $ example  $ delay n+it_hh       desc   = it ("HH "      <>desc) $ hedgehog $ success+_t_hh_fails desc   = it ("HH FAIL " <>desc) $ hedgehog $ prop+it_hh_slow  desc n = it ("HH DELAY "<>desc) $ hedgehog $ evalIO (delay n)+it_hh_cubic desc   = it ("HH CUBIC "<>desc) $ hedgehog $ prop_cubic+it_hh_stats desc   = it ("HH STATS "<>desc) $ hedgehog $ prop_stats++prop_stats :: PropertyT IO ()+prop_stats = do+    x <- forAll (Gen.int $ Range.constant 0 100)+    classify "  n:   0     " (x== 0         )+    classify "  n:   1- 4  " (x>= 1 && x<= 4)+    classify "  n:   5-19  " (x>= 5 && x<=19)+    evalIO (delay 10)++prop_cubic :: PropertyT IO ()+prop_cubic = do+    (x'::Int) <- forAll $ Gen.integral (Range.linear 0 8)+    let x = fromIntegral x'+    liftIO $ threadDelay (round (x ** 3))++prop :: PropertyT IO ()+prop = do+  i <- forAll $ Gen.int (Range.linear 0 100)+  assert (i <= 10)++delay :: Int -> IO ()+delay n = threadDelay $ n * delayScale * 10++delayScale :: Int+delayScale = 15
+ test/dev-example/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ test/dev-example/SpecHook.hs view
@@ -0,0 +1,21 @@+module SpecHook+( hook+) where++import qualified Test.Hspec.TidyFormatter as Formatter+import Test.Hspec+import Test.Hspec.Core.Spec (modifyConfig)+import Test.Hspec.Core.Runner (Config(..))+import Test.Hspec.Runner (ColorMode(ColorAlways))++hook :: Spec -> Spec+hook = (setupSpec >>) . Formatter.use -- . parallel+++setupSpec :: Spec+setupSpec = modifyConfig $ \c -> c+  { configSeed      = Just seed+  , configColorMode = ColorAlways+  }+  where+    seed = 1
+ test/doctests/doctests.hs view
@@ -0,0 +1,13 @@+module Main where++import System.Environment (getArgs)++import Test.DocTest+  ( mainFromCabal+  )++main :: IO ()+main = do+  mainFromCabal+    "hspec-tidy-formatter"+    =<< getArgs