{-|
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 :: Formatter
tidy = Api.Formatter {
  formatterStarted :: FormatM ()
formatterStarted      = () -> FormatM ()
forall a. a -> FormatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, formatterDone :: FormatM ()
formatterDone         = Formatter -> FormatM ()
Api.formatterDone Formatter
Api.checks -- footer, failures
, formatterGroupDone :: Path -> FormatM ()
formatterGroupDone    = \([[Char]]
_ ,[Char]
_  )     -> FormatM ()
nothing
, formatterGroupStarted :: Path -> FormatM ()
formatterGroupStarted = \([[Char]]
gs,[Char]
grp)     -> [[Char]] -> Lines -> FormatM ()
write     [[Char]]
gs ([Char] -> Lines
groupStarted [Char]
grp)
, formatterItemStarted :: Path -> FormatM ()
formatterItemStarted  = \([[Char]]
gs,[Char]
req)     -> [[Char]] -> [Char] -> FormatM ()
transient [[Char]]
gs ([Char] -> [Char]
itemStarted [Char]
req)
, formatterItemDone :: Path -> Item -> FormatM ()
formatterItemDone     = \([[Char]]
gs,[Char]
req) Item
itm -> [[Char]] -> Lines -> FormatM ()
write     [[Char]]
gs ([Char] -> Item -> Lines
itemDone [Char]
req Item
itm)
, formatterProgress :: Path -> Progress -> FormatM ()
formatterProgress     = \([[Char]]
gs,[Char]
_  ) Progress
prg -> [[Char]] -> [Char] -> FormatM ()
transient [[Char]]
gs (Progress -> [Char]
progress Progress
prg)
}
  where nothing :: FormatM ()
nothing = () -> FormatM ()
forall a. a -> FormatM a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: [Char] -> Chunks
chunk = [Char] -> Chunks
forall ann b. (Monoid ann, IsString b) => [Char] -> Parts ann b
string ([Char] -> Chunks) -> ([Char] -> [Char]) -> [Char] -> Chunks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')

line :: Chunks -> Lines
line :: Chunks -> Lines
line Chunks
chunks = [Chunks] -> Lines
forall ann b. Monoid ann => b -> Parts ann b
value [Chunks
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 :: [[Char]] -> Lines -> FormatM ()
write [[Char]]
gs = ([Chunks] -> FormatM ()) -> Lines -> FormatM ()
forall (m :: * -> *) b.
Monad m =>
(b -> m ()) -> Silenceable m b -> m ()
run (([Char] -> FormatM ()) -> Chunks -> FormatM ()
forall (m :: * -> *) b.
Monad m =>
(b -> m ()) -> Silenceable m b -> m ()
run [Char] -> FormatM ()
Api.write (Chunks -> FormatM ())
-> ([Chunks] -> Chunks) -> [Chunks] -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunks -> Chunks
vsep (Chunks -> Chunks) -> ([Chunks] -> Chunks) -> [Chunks] -> Chunks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Chunks] -> Chunks
unlines')
  where
    unlines' :: [Chunks] -> Chunks
unlines' = (Chunks -> Chunks) -> [Chunks] -> Chunks
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Chunks -> Chunks
mkLine
    mkLine :: Chunks -> Chunks
mkLine Chunks
c = [[Char]] -> Chunks
indentation [[Char]]
gs Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
c Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
"\n"

    vsep :: Chunks -> Chunks
vsep|Bool
isLevel0  = (Chunks
"\n" <>)
        |Bool
otherwise = Chunks -> Chunks
forall a. a -> a
id

    isLevel0 :: Bool
isLevel0 = [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
gs

transient :: Indentation -> TransientString -> FormatM ()
transient :: [[Char]] -> [Char] -> FormatM ()
transient [[Char]]
gs =
  [Char] -> FormatM ()
writeTransient
  ([Char] -> FormatM ())
-> ([Char] -> [Char]) -> [Char] -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Char]] -> [Char]
indentationStr [[Char]]
gs ++)
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')
  where
    writeTransient :: [Char] -> FormatM ()
writeTransient = FormatM () -> FormatM ()
whenReportProgress (FormatM () -> FormatM ())
-> ([Char] -> FormatM ()) -> [Char] -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FormatM ()
Api.writeTransient


--
-- Handlers
--

groupStarted :: Group -> Lines
groupStarted :: [Char] -> Lines
groupStarted [Char]
group = Chunks -> Lines
line ([Char] -> Chunks
chunk [Char]
group)

itemStarted :: Req -> TransientString
itemStarted :: [Char] -> [Char]
itemStarted [Char]
req = [Char]
"[ ] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
req

itemDone :: Req -> Api.Item -> Lines
itemDone :: [Char] -> Item -> Lines
itemDone [Char]
req Item
itm =
     Chunks -> Lines
line (Chunks
box Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> [Char] -> Chunks
chunk [Char]
req Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
duration Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Info' WithFormat -> Chunks
forall ann. Info' ann -> Chunks' ann
ifOneline Info' WithFormat
info)
  Lines -> Lines -> Lines
forall a. Semigroup a => a -> a -> a
<> Lines
pending
  Lines -> Lines -> Lines
forall a. Semigroup a => a -> a -> a
<> Info' WithFormat -> Lines
forall ann. Info' ann -> Lines' ann
ifMultiline Info' WithFormat
info
  where
    duration :: Chunks
duration = Seconds -> Chunks
mkDuration (Item -> Seconds
Api.itemDuration Item
itm)
    info :: Info' WithFormat
info     = [Char] -> Info' WithFormat
mkInfo     (Item -> [Char]
Api.itemInfo     Item
itm)

    (Chunks
box,Lines
pending) =
      case Item -> Result
Api.itemResult Item
itm of
        Result
Api.Success     -> (Char -> Char -> Color -> Chunks
mkBox Char
'✔' Char
'v' Color
succColor,Lines
forall ann b. Parts ann b
empty   )
        Api.Failure Maybe Location
_ FailureReason
_ -> (Char -> Char -> Color -> Chunks
mkBox Char
'✘' Char
'x' Color
failColor,Lines
forall ann b. Parts ann b
empty   )
        Api.Pending Maybe Location
_ Maybe [Char]
s -> (Char -> Char -> Color -> Chunks
mkBox Char
'‐' Char
'-' Color
pendColor,Maybe [Char] -> Lines
mkPending Maybe [Char]
s)

progress :: Api.Progress -> TransientString
progress :: Progress -> [Char]
progress (Int
now,Int
total) = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
  where
    str :: [Char]
str
      |Int
totalInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0  = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
now
      |Bool
otherwise = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
now [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
total


--
-- Handler helpers
--

data Info' ann = Info
  { forall ann. Info' ann -> Chunks' ann
ifOneline   :: Chunks' ann
  , forall ann. Info' ann -> Lines' ann
ifMultiline :: Lines'  ann
  }

instance Functor Info' where
  fmap :: forall a b. (a -> b) -> Info' a -> Info' b
fmap a -> b
f (Info Chunks' a
one Lines' a
multi) = Chunks' b -> Lines' b -> Info' b
forall ann. Chunks' ann -> Lines' ann -> Info' ann
Info ((a -> b) -> Chunks' a -> Chunks' b
forall a b c. (a -> b) -> Parts a c -> Parts b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f Chunks' a
one) ((a -> b) -> Lines' a -> Lines' b
forall a b c. (a -> b) -> Parts a c -> Parts b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f Lines' a
multi)

type Info = Info' WithFormat

mkInfo :: ItemInfo -> Info
mkInfo :: [Char] -> Info' WithFormat
mkInfo [Char]
str =
  Color
unlessExpert Color -> Color -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color
infoColor Color -> Info' WithFormat -> Info' WithFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  case [Char] -> [[Char]]
lines [Char]
str of
    []  -> Info' WithFormat
forall {ann}. Info' ann
z
    [[Char]
l] -> Info' WithFormat
forall {ann}. Info' ann
z{ ifOneline   =       (one   $ l ) `onlyIf` isVerbose }
    [[Char]]
ls  -> Info' WithFormat
forall {ann}. Info' ann
z{ ifMultiline = value (multi<$>ls) }
  where
    z :: Info' ann
z       = Chunks' ann -> Lines' ann -> Info' ann
forall ann. Chunks' ann -> Lines' ann -> Info' ann
Info Chunks' ann
forall ann b. Parts ann b
empty Lines' ann
forall ann b. Parts ann b
empty
    one :: [Char] -> Chunks
one   [Char]
s = [Char] -> Chunks
chunk ([Char] -> Chunks) -> [Char] -> Chunks
forall a b. (a -> b) -> a -> b
$ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
    multi :: [Char] -> Chunks
multi [Char]
s = [Char] -> Chunks
chunk ([Char] -> Chunks) -> [Char] -> Chunks
forall a b. (a -> b) -> a -> b
$ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s

mkPending :: Maybe String -> Lines
mkPending :: Maybe [Char] -> Lines
mkPending Maybe [Char]
mb =
  [Chunks] -> Lines
forall ann b. Monoid ann => b -> Parts ann b
value ([Chunks] -> Lines) -> [Chunks] -> Lines
forall a b. (a -> b) -> a -> b
$
  Chunks -> Chunks
forall {a}. (Semigroup a, IsString a) => a -> a
extraInd (Chunks -> Chunks) -> ([Char] -> Chunks) -> [Char] -> Chunks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Chunks -> Chunks
forall a b c. (a -> b) -> Parts a c -> Parts b c
mapAnn Color
pendColor (Chunks -> Chunks) -> ([Char] -> Chunks) -> [Char] -> Chunks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Chunks
chunk ([Char] -> Chunks) -> [[Char]] -> [Chunks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  case [Char] -> [[Char]]
lines ([Char] -> [[Char]]) -> Maybe [Char] -> Maybe [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
mb of
    Maybe [[Char]]
Nothing -> [ [Char]
"# PENDING"   ]
    Just [[Char]]
ls -> ( [Char]
"# PENDING: "
               , [Char]
"           " ) ([Char], [Char]) -> [[Char]] -> [[Char]]
forall {a}. ([a], [a]) -> [[a]] -> [[a]]
`laminate` [[Char]]
ls
  where
    laminate :: ([a], [a]) -> [[a]] -> [[a]]
laminate ([a]
x,[a]
y) = ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a]
x [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
forall a. a -> [a]
repeat [a]
y)
    extraInd :: a -> a
extraInd a
c     = a
"    " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c

mkDuration :: Api.Seconds -> Chunks
mkDuration :: Seconds -> Chunks
mkDuration (Api.Seconds Double
secs) =
  Maybe Chunks -> Chunks
forall ann b. Maybe (Parts ann b) -> Parts ann b
maybeEmpty ([Char] -> Chunks
chunk ([Char] -> Chunks) -> Maybe [Char] -> Maybe Chunks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
mbStr)
    Chunks -> Color -> Chunks
forall ann b ann'. Parts ann b -> (ann -> ann') -> Parts ann' b
`with`   Color
infoColor
    Chunks -> FormatM Bool -> Chunks
forall (m :: * -> *) b.
Monad m =>
Silenceable m b -> m Bool -> Silenceable m b
`onlyIf` FormatM Bool
Api.printTimes
  where
    mbStr :: Maybe [Char]
mbStr = case Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
secs Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000) of
      Integer
0  -> Maybe [Char]
forall a. Maybe a
Nothing
      Integer
ms -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ ([Char]
"  (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
ms [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ms)")

mkBox :: Char -> Char -> Color -> Chunks
mkBox :: Char -> Char -> Color -> Chunks
mkBox Char
unicode Char
ascii Color
color = Chunks
"[" Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
marker Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
"] "
  where
    marker :: Chunks
marker =
      FormatM Bool -> Chunks -> Chunks -> Chunks
forall (m :: * -> *) b.
Monad m =>
m Bool -> Silenceable m b -> Silenceable m b -> Silenceable m b
ifThenElse FormatM Bool
Api.outputUnicode
        ([Char] -> Chunks
chunk [Char
unicode] Chunks -> Color -> Chunks
forall ann b ann'. Parts ann b -> (ann -> ann') -> Parts ann' b
`with` Color
color)
        ([Char] -> Chunks
chunk [Char
ascii  ] Chunks -> Color -> Chunks
forall ann b ann'. Parts ann b -> (ann -> ann') -> Parts ann' b
`with` Color
color)


--
-- Api shorthands
--

type Color = WithFormat -> WithFormat

infoColor :: Color
pendColor :: Color
succColor :: Color
failColor :: Color

infoColor :: Color
infoColor = (WithFormat -> Color
forall a. Semigroup a => a -> a -> a
<> (FormatM () -> FormatM ()) -> WithFormat
forall a. (a -> a) -> Endo a
Endo FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
Api.withInfoColor   )
pendColor :: Color
pendColor = (WithFormat -> Color
forall a. Semigroup a => a -> a -> a
<> (FormatM () -> FormatM ()) -> WithFormat
forall a. (a -> a) -> Endo a
Endo FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
Api.withPendingColor)
succColor :: Color
succColor = (WithFormat -> Color
forall a. Semigroup a => a -> a -> a
<> (FormatM () -> FormatM ()) -> WithFormat
forall a. (a -> a) -> Endo a
Endo FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
Api.withSuccessColor)
failColor :: Color
failColor = (WithFormat -> Color
forall a. Semigroup a => a -> a -> a
<> (FormatM () -> FormatM ()) -> WithFormat
forall a. (a -> a) -> Endo a
Endo FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
Api.withFailColor   )

isVerbose :: FormatM Bool
isVerbose :: FormatM Bool
isVerbose = FormatM Bool
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 :: Color
unlessExpert = (WithFormat -> Color
forall a. Semigroup a => a -> a -> a
<> (FormatM () -> FormatM ()) -> WithFormat
forall a. (a -> a) -> Endo a
Endo FormatM () -> FormatM ()
Api.unlessExpert)

whenReportProgress :: FormatM () -> FormatM ()
whenReportProgress :: FormatM () -> FormatM ()
whenReportProgress = FormatM Bool -> FormatM () -> FormatM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
Api.getConfigValue FormatConfig -> Bool
Api.formatConfigReportProgress)


--
-- Misc
--

indentationStr :: Indentation -> String
indentationStr :: [[Char]] -> [Char]
indentationStr [[Char]]
gs = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
gs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '

indentation :: Indentation -> Chunks
indentation :: [[Char]] -> Chunks
indentation [[Char]]
gs = [Char] -> Chunks
chunk ([[Char]] -> [Char]
indentationStr [[Char]]
gs)


--
-- General helpers
--

whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
bM m ()
action = do
  Bool
b <- m Bool
bM
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b m ()
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")
@

-}