{-|
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 ((forall a b. (a -> b) -> Parts ann a -> Parts ann b)
-> (forall a b. a -> Parts ann b -> Parts ann a)
-> Functor (Parts ann)
forall a b. a -> Parts ann b -> Parts ann a
forall a b. (a -> b) -> Parts ann a -> Parts ann b
forall ann a b. a -> Parts ann b -> Parts ann a
forall ann a b. (a -> b) -> Parts ann a -> Parts ann b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ann a b. (a -> b) -> Parts ann a -> Parts ann b
fmap :: forall a b. (a -> b) -> Parts ann a -> Parts ann b
$c<$ :: forall ann a b. a -> Parts ann b -> Parts ann a
<$ :: forall a b. a -> Parts ann b -> Parts ann a
Functor, ReadPrec [Parts ann b]
ReadPrec (Parts ann b)
Int -> ReadS (Parts ann b)
ReadS [Parts ann b]
(Int -> ReadS (Parts ann b))
-> ReadS [Parts ann b]
-> ReadPrec (Parts ann b)
-> ReadPrec [Parts ann b]
-> Read (Parts ann b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall ann b. (Read ann, Read b) => ReadPrec [Parts ann b]
forall ann b. (Read ann, Read b) => ReadPrec (Parts ann b)
forall ann b. (Read ann, Read b) => Int -> ReadS (Parts ann b)
forall ann b. (Read ann, Read b) => ReadS [Parts ann b]
$creadsPrec :: forall ann b. (Read ann, Read b) => Int -> ReadS (Parts ann b)
readsPrec :: Int -> ReadS (Parts ann b)
$creadList :: forall ann b. (Read ann, Read b) => ReadS [Parts ann b]
readList :: ReadS [Parts ann b]
$creadPrec :: forall ann b. (Read ann, Read b) => ReadPrec (Parts ann b)
readPrec :: ReadPrec (Parts ann b)
$creadListPrec :: forall ann b. (Read ann, Read b) => ReadPrec [Parts ann b]
readListPrec :: ReadPrec [Parts ann b]
Read, Int -> Parts ann b -> ShowS
[Parts ann b] -> ShowS
Parts ann b -> String
(Int -> Parts ann b -> ShowS)
-> (Parts ann b -> String)
-> ([Parts ann b] -> ShowS)
-> Show (Parts ann b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ann b. (Show ann, Show b) => Int -> Parts ann b -> ShowS
forall ann b. (Show ann, Show b) => [Parts ann b] -> ShowS
forall ann b. (Show ann, Show b) => Parts ann b -> String
$cshowsPrec :: forall ann b. (Show ann, Show b) => Int -> Parts ann b -> ShowS
showsPrec :: Int -> Parts ann b -> ShowS
$cshow :: forall ann b. (Show ann, Show b) => Parts ann b -> String
show :: Parts ann b -> String
$cshowList :: forall ann b. (Show ann, Show b) => [Parts ann b] -> ShowS
showList :: [Parts ann b] -> ShowS
Show, Parts ann b -> Parts ann b -> Bool
(Parts ann b -> Parts ann b -> Bool)
-> (Parts ann b -> Parts ann b -> Bool) -> Eq (Parts ann b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ann b. (Eq ann, Eq b) => Parts ann b -> Parts ann b -> Bool
$c== :: forall ann b. (Eq ann, Eq b) => Parts ann b -> Parts ann b -> Bool
== :: Parts ann b -> Parts ann b -> Bool
$c/= :: forall ann b. (Eq ann, Eq b) => Parts ann b -> Parts ann b -> Bool
/= :: Parts ann b -> Parts ann b -> Bool
Eq, Eq (Parts ann b)
Eq (Parts ann b) =>
(Parts ann b -> Parts ann b -> Ordering)
-> (Parts ann b -> Parts ann b -> Bool)
-> (Parts ann b -> Parts ann b -> Bool)
-> (Parts ann b -> Parts ann b -> Bool)
-> (Parts ann b -> Parts ann b -> Bool)
-> (Parts ann b -> Parts ann b -> Parts ann b)
-> (Parts ann b -> Parts ann b -> Parts ann b)
-> Ord (Parts ann b)
Parts ann b -> Parts ann b -> Bool
Parts ann b -> Parts ann b -> Ordering
Parts ann b -> Parts ann b -> Parts ann b
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall ann b. (Ord ann, Ord b) => Eq (Parts ann b)
forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Bool
forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Ordering
forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Parts ann b
$ccompare :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Ordering
compare :: Parts ann b -> Parts ann b -> Ordering
$c< :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Bool
< :: Parts ann b -> Parts ann b -> Bool
$c<= :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Bool
<= :: Parts ann b -> Parts ann b -> Bool
$c> :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Bool
> :: Parts ann b -> Parts ann b -> Bool
$c>= :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Bool
>= :: Parts ann b -> Parts ann b -> Bool
$cmax :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Parts ann b
max :: Parts ann b -> Parts ann b -> Parts ann b
$cmin :: forall ann b.
(Ord ann, Ord b) =>
Parts ann b -> Parts ann b -> Parts ann b
min :: Parts ann b -> Parts ann b -> Parts ann b
Ord)

instance Bifunctor Parts where
  bimap :: (ann -> ann') -> (b -> b') -> Parts ann b -> Parts ann' b'
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Parts a c -> Parts b d
bimap ann -> ann'
f b -> b'
g = (ann -> ann') -> Parts ann b' -> Parts ann' b'
forall a b c. (a -> b) -> Parts a c -> Parts b c
mapAnn ann -> ann'
f (Parts ann b' -> Parts ann' b')
-> (Parts ann b -> Parts ann b') -> Parts ann b -> Parts ann' b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b') -> Parts ann b -> Parts ann b'
forall a b. (a -> b) -> Parts ann a -> Parts ann b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> b'
g

instance Semigroup (Parts ann b) where
  Parts [(ann, b)]
xs <> :: Parts ann b -> Parts ann b -> Parts ann b
<> Parts [(ann, b)]
ys = [(ann, b)] -> Parts ann b
forall ann b. [(ann, b)] -> Parts ann b
Parts ([(ann, b)]
xs [(ann, b)] -> [(ann, b)] -> [(ann, b)]
forall a. [a] -> [a] -> [a]
++ [(ann, b)]
ys)

instance Monoid (Parts ann b) where
  mempty :: Parts ann b
mempty = [(ann, b)] -> Parts ann b
forall ann b. [(ann, b)] -> Parts ann b
Parts []

instance (Monoid ann, IsString b) => IsString (Parts ann b) where
  fromString :: String -> Parts ann b
fromString = String -> Parts ann b
forall ann b. (Monoid ann, IsString b) => String -> Parts ann b
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 :: forall ann b. ann -> b -> Parts ann b
singleton ann
ann b
x = [(ann, b)] -> Parts ann b
forall ann b. [(ann, b)] -> Parts ann b
Parts [(ann
ann,b
x)]

-- | Embed a value annotated with 'mempty'.
value :: Monoid ann => b -> Parts ann b
value :: forall ann b. Monoid ann => b -> Parts ann b
value b
x = [(ann, b)] -> Parts ann b
forall ann b. [(ann, b)] -> Parts ann b
Parts [(ann
forall a. Monoid a => a
mempty,b
x)]

-- | Embed a string literal annotated with 'mempty'.
string :: (Monoid ann, IsString b) => String -> Parts ann b
string :: forall ann b. (Monoid ann, IsString b) => String -> Parts ann b
string String
s = [(ann, b)] -> Parts ann b
forall ann b. [(ann, b)] -> Parts ann b
Parts [(ann
forall a. Monoid a => a
mempty,String -> b
forall a. IsString a => String -> a
fromString String
s)]

empty :: Parts ann b
empty :: forall ann b. Parts ann b
empty = [(ann, b)] -> Parts ann b
forall ann b. [(ann, b)] -> Parts ann b
Parts []


-- * Modify

maybeEmpty :: Maybe (Parts ann b) -> Parts ann b
maybeEmpty :: forall ann b. Maybe (Parts ann b) -> Parts ann b
maybeEmpty = \case
  Just Parts ann b
p -> Parts ann b
p
  Maybe (Parts ann b)
_      -> Parts ann b
forall ann b. Parts ann b
empty

{- | Map annotations.

@
mapAnn == 'first'
@
-}
mapAnn :: (ann->ann') -> Parts ann b -> Parts ann' b
mapAnn :: forall a b c. (a -> b) -> Parts a c -> Parts b c
mapAnn ann -> ann'
f (Parts [(ann, b)]
xs) = [(ann', b)] -> Parts ann' b
forall ann b. [(ann, b)] -> Parts ann b
Parts ((ann, b) -> (ann', b)
forall {b}. (ann, b) -> (ann', b)
f' ((ann, b) -> (ann', b)) -> [(ann, b)] -> [(ann', b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ann, b)]
xs)
  where
    f' :: (ann, b) -> (ann', b)
f' (ann
ann,b
b) = (ann -> ann'
f ann
ann,b
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 :: forall ann b ann'. Parts ann b -> (ann -> ann') -> Parts ann' b
with = ((ann -> ann') -> Parts ann b -> Parts ann' b)
-> Parts ann b -> (ann -> ann') -> Parts ann' b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ann -> ann') -> Parts ann b -> Parts ann' b
forall a b c. (a -> b) -> Parts a c -> Parts b c
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 :: forall ann b acc.
((ann, b) -> acc -> acc) -> acc -> Parts ann b -> acc
foldParts (ann, b) -> acc -> acc
f acc
z (Parts [(ann, b)]
xs) = ((ann, b) -> acc -> acc) -> acc -> [(ann, b)] -> acc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ann, b) -> acc -> acc
f acc
z [(ann, b)]
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 :: forall ann b c acc.
(ann -> b -> c) -> (c -> acc -> acc) -> acc -> Parts ann b -> acc
interpret ann -> b -> c
interp c -> acc -> acc
f = ((ann, b) -> acc -> acc) -> acc -> Parts ann b -> acc
forall ann b acc.
((ann, b) -> acc -> acc) -> acc -> Parts ann b -> acc
foldParts (ann, b) -> acc -> acc
f'
  where
    f' :: (ann,b) -> acc -> acc
    f' :: (ann, b) -> acc -> acc
f' (ann
ann,b
b) acc
acc = ann -> b -> c
interp ann
ann b
b c -> acc -> acc
`f` acc
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' :: forall (m :: * -> *) b.
Monad m =>
m Bool -> Silenceable m b -> Silenceable m b
when' m Bool
bM = (Endo (m ()) -> Endo (m ()))
-> Parts (Endo (m ())) b -> Parts (Endo (m ())) b
forall a b c. (a -> b) -> Parts a c -> Parts b c
mapAnn ((m () -> m ()) -> Endo (m ())
forall a. (a -> a) -> Endo a
Endo m () -> m ()
f <>)
  where
    f :: m () -> m ()
f m ()
action = do
      Bool
b <- m Bool
bM
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b m ()
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 :: forall (f :: * -> *) b.
Applicative f =>
Bool -> Silenceable f b -> Silenceable f b
whenA Bool
b = (Endo (f ()) -> Endo (f ()))
-> Parts (Endo (f ())) b -> Parts (Endo (f ())) b
forall a b c. (a -> b) -> Parts a c -> Parts b c
mapAnn ((f () -> f ()) -> Endo (f ())
forall a. (a -> a) -> Endo a
Endo (Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
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 :: forall (m :: * -> *) b.
Monad m =>
Silenceable m b -> m Bool -> Silenceable m b
onlyIf = (m Bool -> Silenceable m b -> Silenceable m b)
-> Silenceable m b -> m Bool -> Silenceable m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip m Bool -> Silenceable m b -> Silenceable m b
forall (m :: * -> *) b.
Monad m =>
m Bool -> Silenceable m b -> Silenceable m b
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 :: forall (m :: * -> *) b.
Monad m =>
m Bool -> Silenceable m b -> Silenceable m b -> Silenceable m b
ifThenElse m Bool
pM Silenceable m b
true Silenceable m b
false =
     (m Bool -> Silenceable m b -> Silenceable m b
forall (m :: * -> *) b.
Monad m =>
m Bool -> Silenceable m b -> Silenceable m b
when'        m Bool
pM  Silenceable m b
true )
  Silenceable m b -> Silenceable m b -> Silenceable m b
forall a. Semigroup a => a -> a -> a
<> (m Bool -> Silenceable m b -> Silenceable m b
forall (m :: * -> *) b.
Monad m =>
m Bool -> Silenceable m b -> Silenceable m b
when' (Bool -> Bool
not(Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>m Bool
pM) Silenceable m b
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 :: forall (m :: * -> *) b.
Monad m =>
(b -> m ()) -> Silenceable m b -> m ()
run b -> m ()
emit = (Endo (m ()) -> b -> m ())
-> (m () -> m () -> m ()) -> m () -> Parts (Endo (m ())) b -> m ()
forall ann b c acc.
(ann -> b -> c) -> (c -> acc -> acc) -> acc -> Parts ann b -> acc
interpret Endo (m ()) -> b -> m ()
f m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) m ()
z
  where
    f :: Endo (m ()) -> b -> m ()
f Endo (m ())
ann b
b = Endo (m ()) -> m () -> m ()
forall a. Endo a -> a -> a
appEndo Endo (m ())
ann (b -> m ()
emit b
b)
    z :: m ()
z       = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()