{- |
Module: Text.Sayable

This module provides a set of data structures, classes, and operators that
facilitate the construction of a Prettyprinter Doc object.

= Motivation

Standard prettyprinting is a monotonic conversion that does not allow for
customization for different uses or environments.  For example, when debugging,
full and explicit information about a structure should be generated, but for
checkpoint logging, a simple overview is usually more appropriate.

This library provides for an additional type parameter that can be used to
control the conversion to a suitably verbose Prettyprinter Doc representation.

This is also highly useful in conjunction with logging to generate successively
more verbose information as the logging verbosity increases.

= Usage

Typical usage is to create a sayable message using the operators defined here and
then extract Prettyprinter Doc from the saying and convert it to a printable
format (here, simply using @show@ for the default Prettyprinter rendering).

@
import qualified Prettyprinter as PP

foo :: Members '[ Logging SayMessage, Config ] r -> a -> b -> Eff r [b]
foo arg1 arg2 =
   do putStrLn $ show $ saying $ sayable @info "Entering foo with" &- arg1 &- "and" &- arg2
      rslt <- something arg1 arg2
      case rslt of
        Right vals ->
          do putStrLn $ show $ saying $ sayable @"verbose"
                 $ "Foo successfully returning" &% length vals &- "results:" &- vals
             return vals
        Left err ->
          do putStrLn $ show $ saying $ sayable @"error"
                 $ "Foo error (" &- arg1 &- PP.comma &- arg2 &- ") is" &- err
             throwError err
@

[Note: if viewing via Haddock HTML, the ampersand in front of @"info"@,
@"verbose"@, and @"error"@ on the putStrLn lines above may not be
visible.]

There are three messages printed: one on entry and one on either the success or
failure paths.  Each message may have different levels of information reported
for the various arguments.

== The @saytag@ type parameter

Each sayable message uses a @TypeApplication@ to specify a "saytag" which should
be used for controlling the rendering of that message (e.g. "info", "verbose", "error", etc.).

As a developer, it is encouraged to use whatever saytag makes sense relative to the current context and type of information being processed.

== Individual Arguments

The arguments passed to the sayable should be instances of the 'Sayable' class.
There are a number of standard instances of 'Sayable', but an instance can be
declared for any object that might be output.  The 'Sayable' class has two class
parameters: the second is object to be converted, and the first is the "saytag".
This allows different Sayable instances for an object to be used in different
saytag scenarios.  For example:

@
import Network.URL

instance Sayable "verbose" URL where
  sayable url =
    let newline = PP.line :: PP.Doc SayableAnn
        prettyShow x = PP.viaShow x :: PP.Doc SayableAnn
    in "URL {"
        &- "url_type=" &- prettyShow (url_type url) &- newline
        &- "url_path=" &- url_path url &- newline
        &- "url_params=" &* url_params url
        &- "}"
instance Sayable saytag URL where
  sayable = Sayable . PP.viaShow . exportURL
@

The above would cause a url emitted via a "verbose" saytag to be
expanded into a report on each individual field, whereas all other
saytags would simply output the @exportURL@ representation of the @URL@.

>>> let host = Host (HTTP True) "github.com" Nothing
>>> url' = URL (Absolute host) "by/one"
>>> saying $ sayable @"verbose" url'
URL { url_type= Absolute (Host {protocol = HTTP True, host= "github.com", port= Nothing})
 url_path= by/one
 url_params= }
>>> saying @"info" $ sayable url'
https://github.com:442/by/one

There are some tricky elements to the above however; see "Unfortunate
Details" below.

Note that there are several pre-declared Sayable instances for common
datatypes for convenience.

== Operators

In the logging lines above, there are several operators used, each of which
starts with the @&@ character.  These are described in detail in the 'Helper
operators' section below, but the general mnemonic for these is:

  * A dash is elements separated by a space

  * A plus indicates immediately adjacent elements

  * A colon is designates a separator

  * An asterisk is applied to a foldable (i.e. a list)

  * A percent sign preceeds a Pretty object

  * An exclamation follows a Pretty function, which is applied to the following
    argument.

  * A question mark is followed by a Maybe, with no output for a Nothing

  * A less-than character means newline (i.e. return to the left)

These characters will be combined for operators with combination effects.


== Convenience/other

  * This module also provides an instance to convert a Sayable back
    into a Prettyprinter.Pretty.

  * This module provides a helper function: 't'' which can be useful
    when @OverloadedStrings@ is active to designate its argument as
    being a Text string.

    If the following:

@
saying @"error" $ "This is an error:" &- err
@

    results in an error @Could not deduce (Data.String.IsString m0)
    arising from the literal '"This is an error:"'@ then this helper
    can fix that:

@
saying @"error" $ t'"This is an error:" &- err
@

  * This module provides a helper function: 'd'' which can be useful
    when creating a PP.Doc SayableAnn for inclusion into a 'Sayable'
    by fixing the @ann@ of 'PP.Doc ann' to 'SayableAnn'.

    Fixes the error:

@
    • Overlapping instances for Sayable saytag (PP.Doc ann1)
        arising from a use of ‘&-’
      Matching instances:
        instance [overlappable] Sayable tag (PP.Doc ann)
          -- Defined in ‘Taphos.Say’
        instance Sayable tag (PP.Doc SayableAnn)
          -- Defined in ‘Taphos.Say’
      (The choice depends on the instantiation of ‘saytag, ann1’
       To pick the first instance above, use IncoherentInstances
       when compiling the other instance declarations)
@

    This is similar to the '&%' operator except it takes a single
    argument rather than the two arguments passed to the operator.

  * The pattern of converting a saying into a String (e.g. for passing to
    putStrLn) is fairly common, so the simplistic operations of that is provided
    by the 'sez' function.


== Generating final output

  The 'sayable' method of the 'Sayable' class generates instances of
  the 'Saying' data object.  The 'saying' function can be used to
  extract the 'Prettyprinter.Doc' from the 'Saying' object.  This Doc
  can then be converted to a 'Lumberjack.LogMessage' or to a plain
  Text format for display.

== Unfortunate Details

  The use of the Sayable class to translate individual objects is
  fairly straightforward, but the management of the phantom @saytag@
  type parameter is a bit tricky.  As described above (with the
  Network.URL example), it's possible to provide different output
  generation by providing specialized instances for specific saytags.
  The determination of which instance GHC will use has some
  idiosyncrasies that make lead to unexpected instance selection when
  used transitively (viz.
  https://ghc.gitlab.haskell.org/ghc/doc/users_guide/extsinstances.html).

  For instance:

@
import Network.URL ( URL )
newtype Foo = Foo URL
data Bar a  = Bar String a

-- [previous instances for Sayable URL here...]

instance Sayable "loud" Foo where sayable (Foo url) = t'"{!" &- url &- t'"!}"
instance Sayable saytag Foo where sayable (Foo url) = sayable url

instance (Sayable saytag a) => Sayable saytag (Bar a) where
  sayable (Bar b a) = b &- t'"is" &- a

let host = Host (HTTP True) "github.com" Nothing
let url' = URL (Absolute host) "by/one"
let foo = Foo url'
let bar = Bar "bar" foo
@

  will generate:

>>> putStrLn $ sez @"info" $ t'"INFO:" &- bar &- "via" &- foo
INFO: bar is "https://github.com/by/one" via "https://github.com/by/one"
>>> putStrLn $ sez @"loud" $ t'"LOUD:" &- bar &- "via" &- foo
LOUD: bar is {! "https://github.com/by/one" !} via {! "https://github.com/by/one" !}

  which is expected.  However, if the calls to 'sez' are moved
  to a separate file from the instance declarations, the compilation
  error will be:

  @Overlapping instances for Sayable "loud" Foo arising from a use of &-@

  for the last (loud) line.  To resolve this, use OVERLAPPING and/or
  OVERLAPPABLE specifications on the instance declarations.  Usually
  it's sufficient (and easiest) to add the OVERLAPPABLE to the generic
  instance:

> instance Sayable "loud" Foo where sayable (Foo s) = t'"{!" &- s &- t'"!}"
> instance {-# OVERLAPPABLE #-} Sayable saytag Foo where sayable (Foo s) = sayable s

  [Note: if you are viewing the above via Haddock HTML, the second
  line has the @instance@ keyword, followed by an open comment
  directive (open curly brace, dash, hash) , @OVERLAPPABLE@ and a
  closing comment directive (hash, dash, close curly brace), followed
  by the @Sayable@ keyword, but that doesn't render under HTML Haddock
  (circa 2022).]

=== Sub-Element Constraints

  There's another annoyance to address when using Sayable: t he need for explicit
  contraints ofr data structure sub-elements.  To observe this new twist, add a
  @Baz@ datastructure and its generic 'Sayable' instance to the previous
  section's example:

  > data Baz = Baz Foo
  > instance Sayable saytag Baz where sayable (Baz a) = t'"BAZ :=" &- foo

  Now the following calls and corresponding output can be observed:

>>> putStrLn $ sez @"info" $ t'"INFO:" &- bar &- t'"and" &- baz
INFO: bar is "https://github.com/by/one" and BAZ := "https://github.com/by/one"
>>> putStrLn $ sez @"loud" $ t'"LOUD:" &- bar &- t'"and" &- baz
LOUD: bar is {! "https://github.com/by/one" !} and BAZ := "https://github.com/by/one"

  Notice how the @foo@ value in @bar@ changes when the '@"loud"' saytag is
  used, but the same @foo@ value in @baz@ does not change!

  The difference here is in the mechanism GHC uses to select instances
  (as described on the referenced link above).  In short, for @bar@, the
  generic 'Sayable' instance has a constraint for the inner element,
  which causes GHC to wait until the final use case to determine what
  the specific type parameters are; it sees the @"loud"@ @saytag@ value
  and selects the @"loud"@ @Foo@ 'Sayable' instance as the most specific.
  However, the @baz@ 'Sayable' instance does not have a constraint, so GHC
  takes the conservative approach and uses the most general instance,
  which means that it transitively selects the generic @Foo@ 'Sayable'
  instance instead of the @"loud"@ instance.

  There are two ways to fix this:

  1. Provide explicit @"loud"@ 'Sayable' instance for @Baz@.  This is
     problematic, because this must be done for *each* saytag for
     which there is a variation and it must be done for *each* upper
     level 'Sayable' instance.

  2. Provide 'Sayable' constraints for each sub-element.  This generates
     larger type signatures, but is preferrable to solution 1 because
     it makes no assumptions about current or future saytags and
     variations.

     This 'Sayable' constraint was already present on the @Bar@
     'Sayable' instance because of the parameterized type for @Bar@;
     the @Baz@ type has no type parameter, but a constraint can still
     be added for each interior type:

> instance Sayable saytag Foo => Sayable saytag Baz where
>   sayable (Baz a) = t'"BAZ :=" &- foo

     To facilitate generating the needed set of constraints for sub-elements
     (including ensuring that a sub-element isn't missed when writing these by
     hand), there is a Template Haskell helper that will automatically generate
     these constraints:

> instance $(sayableSubConstraints (const True) ''Baz "tag" []) => Sayable tag Baz where ...

     See the 'sayableSubConstraints' documentation for more information on using
     this Template Haskell helper.


  Using either of the above solutions, the new output is fully
  specialized as desired:

>>> putStrLn $ sez @"info" $ t'"INFO:" &- bar &- t'"and" &- baz
INFO: bar is "https://github.com/by/one" and BAZ := "https://github.com/by/one"
>>> putStrLn $ sez @"loud" $ t'"LOUD:" &- bar &- t'"and" &- baz
LOUD: bar is {! "https://github.com/by/one" !} and BAZ := {! "https://github.com/by/one" !}

-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Text.Sayable
  (
    -- * Primary Class
    Sayable(sayable)
    -- * Result Datatype
  , Saying(Saying, saying)
    -- * Helper operators
    --
    -- | These are typically used to facilitate the expression of a sayable
    -- phrase containing multiple elements.
  , t'
  , d'
  , (&-)
  , (&+)
  , (&%)
  , (&*)
  , (&+*)
  , (&:*)
  , (&?)
  , (&+?)
  , (&<)
  , (&<*)
  , (&<?)
  , (&!)
  , (&!?)
  , (&!*)
  , (&!$*)
  , (&!:*)
    -- * Annotation used in Sayables
    --
    -- | Generating a 'Prettyprinter.Doc' requires the identification of an @ann@
    -- type parameter.  For 'Sayable', this type parameter is the 'SayableAnn',
    -- although the 'Prettyprinter.reAnnotate' function can be used to switch
    -- from this abstract annotation to a functional annotation
    -- (e.g. 'Prettyprinter.Render.Terminal.AnsiStyle')
  , SayableAnn(SayableAnn)
    -- * Simple String Extraction
  , sez
  , sez_
    -- * Sub-element Sayable constraints
  , sayableSubConstraints
  , ConstrM
  , ofType
  , tagVar
  , tagSym
  , subWrapper
  , subElemFilter
  , paramVar
  , paramSym
  , paramNat
  , paramTH
  )
where

import           Control.Applicative ( liftA )
import           Control.Monad ( ap )
import qualified Control.Monad.Catch as X
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import           Data.Either ( rights )
import qualified Data.Int as I
import qualified Data.Map as Map
import           Data.Text ( Text, pack )
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TEL
import qualified Data.Word as W
import           GHC.Exts ( Proxy#, proxy# )
import           GHC.OverloadedLabels
import           GHC.TypeLits ( Symbol, KnownSymbol, symbolVal' )
import           Language.Haskell.TH as TH
import           Language.Haskell.TH.Datatype
import           Numeric.Natural ( Natural )
import           Prettyprinter ( (<+>) )
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.String as PPS


-- | The main class of things that can be passed to 'sayable'.  Arguments
-- provided to 'sayable' or 'sez' will be converted to the sayable form by
-- automatically applying the appropriate instance of this class.  The
-- default implementation is:
--
-- > sayable = Saying . Prettyprinter.pretty

class Sayable (tag :: Symbol) v where
  sayable :: v -> Saying tag

  default sayable :: PP.Pretty v => v -> Saying tag
  sayable = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag)
-> (v -> Doc SayableAnn) -> v -> Saying tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Doc SayableAnn
forall ann. v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty


-- | The result of applying the sayable method of the Sayable class is
-- the Saying object.  This object is internal to the Say module and
-- is mostly used for subsequently combining with additional Saying
-- objects to produce the final Saying object that is converted to a
-- SayMessage for actual logging.  A Sayable supports a Semigroup
-- combinator to allow composition of messages.

newtype Saying (tag :: Symbol) = Saying { forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying :: PP.Doc SayableAnn }

instance Semigroup (Saying tag) where
  Saying Doc SayableAnn
sm1 <> :: Saying tag -> Saying tag -> Saying tag
<> Saying Doc SayableAnn
sm2 = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag) -> Doc SayableAnn -> Saying tag
forall a b. (a -> b) -> a -> b
$ Doc SayableAnn
sm1 Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc SayableAnn
sm2


-- | Inputs that are 'Sayable', i.e. that can be converted to a Saying

instance {-# OVERLAPPING #-} (tagA ~ tagB) => Sayable tagA (Saying tagB) where sayable :: Saying tagB -> Saying tagA
sayable = Saying tagB -> Saying tagA
Saying tagB -> Saying tagB
forall a. a -> a
id
instance Sayable tag Text
instance Sayable tag String
instance Sayable tag Char
instance Sayable tag Bool
instance Sayable tag Int
instance Sayable tag Integer
instance Sayable tag I.Int32
instance Sayable tag I.Int64
instance Sayable tag W.Word8
instance Sayable tag W.Word16
instance Sayable tag W.Word32
instance Sayable tag W.Word64
instance Sayable tag Natural
instance Sayable tag Float
instance Sayable tag Double
instance Sayable tag TL.Text
instance Sayable tag BS.ByteString where sayable :: ByteString -> Saying tag
sayable = Text -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable (Text -> Saying tag)
-> (ByteString -> Text) -> ByteString -> Saying tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8
instance Sayable tag BSL.ByteString where sayable :: ByteString -> Saying tag
sayable = Text -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable (Text -> Saying tag)
-> (ByteString -> Text) -> ByteString -> Saying tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TEL.decodeUtf8
instance Sayable tag X.SomeException where sayable :: SomeException -> Saying tag
sayable = String -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable (String -> Saying tag)
-> (SomeException -> String) -> SomeException -> Saying tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
X.displayException
instance Sayable tag (PP.Doc SayableAnn) where sayable :: Doc SayableAnn -> Saying tag
sayable = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying
instance {-# OVERLAPPABLE #-} Sayable tag (PP.Doc ann) where sayable :: Doc ann -> Saying tag
sayable = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag)
-> (Doc ann -> Doc SayableAnn) -> Doc ann -> Saying tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc SayableAnn
forall ann xxx. Doc ann -> Doc xxx
PP.unAnnotate

-- | A Saying can be converted back into a PP.Pretty instance
-- representation.  Just saying... :-)
--
-- This can be convenient to apply Prettyprinter formatting elements.
-- For example:
--
-- > instance Sayable saytag Foo where
-- >   sayable foo = sayable @saytag $ Prettyprinter.group $ Prettyprinter.pretty
-- >                 $ field1 foo &- sayable @saytag PP.line &- field2 foo
--
-- This uses 'Prettyprinter.group' and 'Prettyprinter.line' formatters to show
-- the two fields on the same line if they will fit, otherwise stacked on top of
-- each other.  Note that the second portion needs an explicit @TypeApplication@
-- (applied here to the 'Prettyprinter.line') because the 'Prettyprinter.group'
-- and 'Prettyprinter.pretty' functions do not propagate that outer @saytag@ to
-- the inner portion.

instance PP.Pretty (Saying tag) where pretty :: forall ann. Saying tag -> Doc ann
pretty = Doc SayableAnn -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
PP.unAnnotate (Doc SayableAnn -> Doc ann)
-> (Saying tag -> Doc SayableAnn) -> Saying tag -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying


-- | A helper operator allowing two Sayable items to be composed into
-- a Saying.  This is the most common operator used to construct
-- composite Sayable messages.  The two Sayable items are separated by
-- a space.
--
-- >>> sez @"info" $ t'"hello" &- t'"world"
-- "hello world"
--
(&-) :: forall saytag m n . (Sayable saytag m, Sayable saytag n)
     => m -> n -> Saying saytag
m
m &- :: forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&- n
n = m -> Saying saytag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m Saying saytag -> Saying saytag -> Saying saytag
forall a. Semigroup a => a -> a -> a
<> n -> Saying saytag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable n
n
infixl 1 &-

-- | A helper operator allowing two Sayable items to be composed into
-- a Saying by placing the two Sayable items immediately adjacent with
-- no intervening spaces.  This is the high-density version of the
-- more common '&-' operator.
--
-- >>> sez @"info" $ t'"hello" &+ t'"world"
-- "helloworld"
--
(&+) :: forall saytag m n . (Sayable saytag m, Sayable saytag n)
     => m -> n -> Saying saytag
m
m &+ :: forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ n
n = Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying saytag)
-> Doc SayableAnn -> Saying saytag
forall a b. (a -> b) -> a -> b
$ (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag m
m) Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag n
n)
infixl 1 &+

-- | A helper operator allowing a Sayable item to be composed with a
-- Pretty item into a Saying.  This is infrequently used and primarily
-- allows the composition of a data object which has a "Prettyprinter"
-- instance but no 'Sayable' instance.
--
-- >>> sez @"info" $ t'"hello" &% (t'"world", t'"!")
-- "hello (world, !)"
--
(&%) :: (Sayable tag m, PP.Pretty n) => m -> n -> Saying tag
m
m &% :: forall (tag :: Symbol) m n.
(Sayable tag m, Pretty n) =>
m -> n -> Saying tag
&% n
n = m -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m Saying tag -> Saying tag -> Saying tag
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable (n -> Doc SayableAnn
forall ann. n -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty n
n :: PP.Doc SayableAnn)
infixl 1 &%

-- | A helper operator to /apply/ a "Prettyprinter" (@Doc ann -> Doc
-- ann@) function (the first argument) to the Sayable in the second
-- argument.  This is different from the '&%' operator in that the
-- former uses 'Prettyprinter.hcat' to join two independent
-- 'Prettyprinter.Doc' 'Saying' values, whereas this operator applies
-- a transformation (e.g. @Prettyprinter.annotate AnnValue@ or
-- @Prettyprinter.align . Prettyprinter.group@) to the
-- 'Prettyprinter.Doc' in the second 'Saying' argument.
--
-- >>> sez @"info" $ PP.group &! t'"hi"
-- "hi"
--
(&!) :: forall tag m . Sayable tag m
     => (PP.Doc SayableAnn -> PP.Doc SayableAnn) -> m -> Saying tag
Doc SayableAnn -> Doc SayableAnn
pf &! :: forall (tag :: Symbol) m.
Sayable tag m =>
(Doc SayableAnn -> Doc SayableAnn) -> m -> Saying tag
&! m
m = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag) -> Doc SayableAnn -> Saying tag
forall a b. (a -> b) -> a -> b
$ Doc SayableAnn -> Doc SayableAnn
pf (Doc SayableAnn -> Doc SayableAnn)
-> Doc SayableAnn -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying tag -> Doc SayableAnn) -> Saying tag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag m
m
infixl 2 &!

-- | A helper operator allowing a Sayable item to be composed with a
-- Foldable series of Sayable items.  This can be used when the second
-- argument is a List, Sequence, Set, etc. to add all elements of the
-- set (comma-separated).
--
-- Note: this instance makes it easy to output lists, Sequence,
-- NonEmpty.List, etc., but it can have undesireable effects for data
-- structures whose Foldable (Functor) is irregular... for example,
-- folding over a tuple only returns the 'snd' value of a tuple.
-- Consider wrapping tuples in a newtype with an explicit Sayable to
-- avoid this.
--
-- >>> sez @"info" $ t'"three:" &* [1, 2, 3::Int]
-- "three: 1, 2, 3"
--
-- If the second argument is a null collection then no output is generated for
-- it.
(&*) :: forall tag m e t
        . (Sayable tag m, Sayable tag e, Foldable t) => m -> t e -> Saying tag
m
m &* :: forall (tag :: Symbol) m e (t :: * -> *).
(Sayable tag m, Sayable tag e, Foldable t) =>
m -> t e -> Saying tag
&* t e
l = let addElem :: e -> (Doc SayableAnn, Saying tag) -> (Doc SayableAnn, Saying tag)
addElem e
e (Doc SayableAnn
s, Saying Doc SayableAnn
p) =
               (Doc SayableAnn
"," Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
forall ann. Doc ann
PP.softline, Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag) -> Doc SayableAnn -> Saying tag
forall a b. (a -> b) -> a -> b
$ Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag e
e) Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
s Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
p)
         in m -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m Saying tag -> Saying tag -> Saying tag
forall a. Semigroup a => a -> a -> a
<> ((Doc SayableAnn, Saying tag) -> Saying tag
forall a b. (a, b) -> b
snd ((Doc SayableAnn, Saying tag) -> Saying tag)
-> (Doc SayableAnn, Saying tag) -> Saying tag
forall a b. (a -> b) -> a -> b
$ (e -> (Doc SayableAnn, Saying tag) -> (Doc SayableAnn, Saying tag))
-> (Doc SayableAnn, Saying tag)
-> t e
-> (Doc SayableAnn, Saying tag)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr e -> (Doc SayableAnn, Saying tag) -> (Doc SayableAnn, Saying tag)
addElem (Doc SayableAnn
"", Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying Doc SayableAnn
forall ann. Doc ann
PP.emptyDoc) t e
l)
infixl 1 &*

-- | A helper operator that generates a sayable from a foldable group (e.g. list)
-- of sayable items.  This helper is linke the '&*' operator except that the
-- folded output is immediately adjacent to the preceeding sayable output instead
-- of separated by a space; this is useful for situations where the folded output
-- has delimiters like parentheses or brackets.
--
-- >>> sez @"info" $ t'"three:" &- '(' &+* [1,2,3::Int] &+ ')'
-- "three: (1, 2, 3)"
--
-- If the second argument is an empty collection then no output is generated for
-- it.

(&+*) :: forall tag m e t
        . (Sayable tag m, Sayable tag e, Foldable t) => m -> t e -> Saying tag
m
m &+* :: forall (tag :: Symbol) m e (t :: * -> *).
(Sayable tag m, Sayable tag e, Foldable t) =>
m -> t e -> Saying tag
&+* t e
l = let addElem :: e -> (Doc SayableAnn, Saying Any) -> (Doc SayableAnn, Saying Any)
addElem e
e (Doc SayableAnn
s, Saying Doc SayableAnn
p) =
               (Doc SayableAnn
"," Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
forall ann. Doc ann
PP.softline, Doc SayableAnn -> Saying Any
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying Any) -> Doc SayableAnn -> Saying Any
forall a b. (a -> b) -> a -> b
$ Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag e
e) Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
s Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
p)
         in Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag m
m)
                    Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Saying Any -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying ((Doc SayableAnn, Saying Any) -> Saying Any
forall a b. (a, b) -> b
snd ((Doc SayableAnn, Saying Any) -> Saying Any)
-> (Doc SayableAnn, Saying Any) -> Saying Any
forall a b. (a -> b) -> a -> b
$ (e -> (Doc SayableAnn, Saying Any) -> (Doc SayableAnn, Saying Any))
-> (Doc SayableAnn, Saying Any)
-> t e
-> (Doc SayableAnn, Saying Any)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr e -> (Doc SayableAnn, Saying Any) -> (Doc SayableAnn, Saying Any)
addElem (Doc SayableAnn
"", Doc SayableAnn -> Saying Any
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying Doc SayableAnn
forall ann. Doc ann
PP.emptyDoc) t e
l))
infixl 1 &+*

-- | A helper operator that generates a sayable from a list of sayable items,
-- separated by the first sayable argument (instead of the ", " that use used by
-- the '&*' operator).
--
-- >>> sez @"info" $ t'"three:" &- t'".." &:* [1, 2, 3::Int]
-- "three: 1..2..3"
--
(&:*) :: forall tag m e t
         . (Sayable tag m, Sayable tag e, Foldable t) => m -> t e -> Saying tag
m
m &:* :: forall (tag :: Symbol) m e (t :: * -> *).
(Sayable tag m, Sayable tag e, Foldable t) =>
m -> t e -> Saying tag
&:* t e
l = let addElem :: e -> (Maybe m, Saying tag) -> (Maybe m, Saying tag)
addElem e
e (Maybe m
s, Saying Doc SayableAnn
p) = (m -> Maybe m
forall a. a -> Maybe a
Just m
m,
                                         case Maybe m
s of
                                           Maybe m
Nothing -> forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag e
e Saying tag -> Doc SayableAnn -> Saying tag
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ Doc SayableAnn
p
                                           Just m
s' -> forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag e
e Saying tag -> m -> Saying tag
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ m
s' Saying tag -> Doc SayableAnn -> Saying tag
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ Doc SayableAnn
p
                                        )
          in (Maybe m, Saying tag) -> Saying tag
forall a b. (a, b) -> b
snd ((Maybe m, Saying tag) -> Saying tag)
-> (Maybe m, Saying tag) -> Saying tag
forall a b. (a -> b) -> a -> b
$ (e -> (Maybe m, Saying tag) -> (Maybe m, Saying tag))
-> (Maybe m, Saying tag) -> t e -> (Maybe m, Saying tag)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr e -> (Maybe m, Saying tag) -> (Maybe m, Saying tag)
addElem (Maybe m
forall a. Maybe a
Nothing, Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying Doc SayableAnn
forall ann. Doc ann
PP.emptyDoc) t e
l
infixl 2 &:*

-- | A helper operator that is a combination of the '&!' and '&*' operators.  It
-- applies the first argument (which converts an array of 'Prettyprinter.Doc ann'
-- elements into a single 'PrettyPrinter.Doc ann' element) to the second argument
-- (which is a Foldable collection of 'Sayable' items).
--
-- >>> sez @"info" $ t'"three:" &- PP.align . PP.vsep &!* [1, 2, 3::Int]
-- "three: 1, \n       2, \n       3"
--
(&!*) :: forall tag m t
         . (Sayable tag m, Foldable t)
      => ([PP.Doc SayableAnn] -> PP.Doc SayableAnn) -> t m -> Saying tag
[Doc SayableAnn] -> Doc SayableAnn
pf &!* :: forall (tag :: Symbol) m (t :: * -> *).
(Sayable tag m, Foldable t) =>
([Doc SayableAnn] -> Doc SayableAnn) -> t m -> Saying tag
&!* t m
l = let addElem :: m
-> (Doc SayableAnn, [Doc SayableAnn])
-> (Doc SayableAnn, [Doc SayableAnn])
addElem m
e (Doc SayableAnn
s, [Doc SayableAnn]
p) = (Doc SayableAnn
"," Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
forall ann. Doc ann
PP.softline
                                  , Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag m
e) Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
s Doc SayableAnn -> [Doc SayableAnn] -> [Doc SayableAnn]
forall a. a -> [a] -> [a]
: [Doc SayableAnn]
p)
           in Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag) -> Doc SayableAnn -> Saying tag
forall a b. (a -> b) -> a -> b
$ [Doc SayableAnn] -> Doc SayableAnn
pf ([Doc SayableAnn] -> Doc SayableAnn)
-> [Doc SayableAnn] -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ (Doc SayableAnn, [Doc SayableAnn]) -> [Doc SayableAnn]
forall a b. (a, b) -> b
snd ((Doc SayableAnn, [Doc SayableAnn]) -> [Doc SayableAnn])
-> (Doc SayableAnn, [Doc SayableAnn]) -> [Doc SayableAnn]
forall a b. (a -> b) -> a -> b
$ (m
 -> (Doc SayableAnn, [Doc SayableAnn])
 -> (Doc SayableAnn, [Doc SayableAnn]))
-> (Doc SayableAnn, [Doc SayableAnn])
-> t m
-> (Doc SayableAnn, [Doc SayableAnn])
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr m
-> (Doc SayableAnn, [Doc SayableAnn])
-> (Doc SayableAnn, [Doc SayableAnn])
addElem (Doc SayableAnn
"", []) t m
l
infixl 2 &!*


-- | A helper operator that applies the first argument (a Prettyprinter
-- adaptation function) to the result of a Foldable collection of 'Sayable'
-- items.  This is essentially a combination of the '&!' and '&*' operators where
-- the first operation is applied to the entire list, rather than each element of
-- the list (as with `&!*`).
--
-- >>> sez @"info" $ t'"three:" &- PP.align &!$* [1, 2, 3::Int]
-- "three: 1, 2, 3"
--
-- As with the '&!*' operator (and unlike the '&*' operator), a null collection
-- is passed to the converter first argument.
--
-- @since: 1.1.0.0
(&!$*) :: forall tag m t
         . (Sayable tag m, Foldable t)
      => (PP.Doc SayableAnn -> PP.Doc SayableAnn) -> t m -> Saying tag
Doc SayableAnn -> Doc SayableAnn
pf &!$* :: forall (tag :: Symbol) m (t :: * -> *).
(Sayable tag m, Foldable t) =>
(Doc SayableAnn -> Doc SayableAnn) -> t m -> Saying tag
&!$* t m
l = let addElem :: m
-> (Doc SayableAnn, Doc SayableAnn)
-> (Doc SayableAnn, Doc SayableAnn)
addElem m
e (Doc SayableAnn
s, Doc SayableAnn
p) = (Doc SayableAnn
"," Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
forall ann. Doc ann
PP.softline
                                   , Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag m
e) Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
s Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
p)
           in Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag) -> Doc SayableAnn -> Saying tag
forall a b. (a -> b) -> a -> b
$ Doc SayableAnn -> Doc SayableAnn
pf (Doc SayableAnn -> Doc SayableAnn)
-> Doc SayableAnn -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ (Doc SayableAnn, Doc SayableAnn) -> Doc SayableAnn
forall a b. (a, b) -> b
snd ((Doc SayableAnn, Doc SayableAnn) -> Doc SayableAnn)
-> (Doc SayableAnn, Doc SayableAnn) -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ (m
 -> (Doc SayableAnn, Doc SayableAnn)
 -> (Doc SayableAnn, Doc SayableAnn))
-> (Doc SayableAnn, Doc SayableAnn)
-> t m
-> (Doc SayableAnn, Doc SayableAnn)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr m
-> (Doc SayableAnn, Doc SayableAnn)
-> (Doc SayableAnn, Doc SayableAnn)
addElem (Doc SayableAnn
"", Doc SayableAnn
forall a. Monoid a => a
mempty) t m
l
infixl 2 &!$*


-- | A helper operator that applies the first argument (which converts
-- an array of 'Prettyprinter.Doc ann' elements to a single
-- 'PrettyPrinter.Doc ann' element) to the second argument, which is a
-- Foldable collection of 'Sayable' items.  This is essentially a
-- combination of the '&!' and '&:*' operators.
--
-- Unlike the other operators defined in this package, this is a trinary operator
-- rather than a binary operator.  Because function application (whitespace) is
-- the highest precedence, the last argument will typically need a preceeding $
-- to prevent applying the second argument to the third argument before applying
-- this operator.
--
-- >>> sez @"info" $ t'"three:" &- (PP.align . PP.vsep &!:* (t'" or")) [1, 2, 3::Int]
-- "three: 1 or\n       2 or\n       3"
--
(&!:*) :: forall tag m t b . (Sayable tag b, Sayable tag m, Foldable t)
       => ([PP.Doc SayableAnn] -> PP.Doc SayableAnn) -> b -> t m -> Saying tag
[Doc SayableAnn] -> Doc SayableAnn
pf &!:* :: forall (tag :: Symbol) m (t :: * -> *) b.
(Sayable tag b, Sayable tag m, Foldable t) =>
([Doc SayableAnn] -> Doc SayableAnn) -> b -> t m -> Saying tag
&!:* b
b = let addElem :: m -> (Maybe b, [Doc SayableAnn]) -> (Maybe b, [Doc SayableAnn])
addElem m
e (Maybe b
s, [Doc SayableAnn]
p) =
                  (b -> Maybe b
forall a. a -> Maybe a
Just b
b, (case Maybe b
s of
                               Maybe b
Nothing -> Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag m
e)
                               Just b
x -> Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag m
e Saying tag -> b -> Saying tag
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ b
x)
                           ) Doc SayableAnn -> [Doc SayableAnn] -> [Doc SayableAnn]
forall a. a -> [a] -> [a]
: [Doc SayableAnn]
p)
            in Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag)
-> (t m -> Doc SayableAnn) -> t m -> Saying tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc SayableAnn] -> Doc SayableAnn
pf ([Doc SayableAnn] -> Doc SayableAnn)
-> (t m -> [Doc SayableAnn]) -> t m -> Doc SayableAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe b, [Doc SayableAnn]) -> [Doc SayableAnn]
forall a b. (a, b) -> b
snd ((Maybe b, [Doc SayableAnn]) -> [Doc SayableAnn])
-> (t m -> (Maybe b, [Doc SayableAnn])) -> t m -> [Doc SayableAnn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m -> (Maybe b, [Doc SayableAnn]) -> (Maybe b, [Doc SayableAnn]))
-> (Maybe b, [Doc SayableAnn])
-> t m
-> (Maybe b, [Doc SayableAnn])
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr m -> (Maybe b, [Doc SayableAnn]) -> (Maybe b, [Doc SayableAnn])
addElem (Maybe b
forall a. Maybe a
Nothing, [])
infixl 2 &!:*


-- | A helper operator allowing a Sayable item to be wrapped in a
-- 'Maybe'.  This adds the 'Sayable' of the first argument to the
-- 'Sayable' of the second argument in the 'Just' case, or just emits
-- the 'Sayable' of the first argument if the second argument is
-- 'Nothing'.
--
-- >>> sez @"info" $ t'"It's" &? Just (t'"something") &- t'"or" &? (Nothing :: Maybe Text)
-- "It's something or"
--
(&?) :: forall tag m e
        . (Sayable tag m, Sayable tag e) => m -> Maybe e -> Saying tag
m
m &? :: forall (tag :: Symbol) m e.
(Sayable tag m, Sayable tag e) =>
m -> Maybe e -> Saying tag
&? Maybe e
Nothing = m -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m
m
m &? (Just e
a) = m -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m Saying tag -> Saying tag -> Saying tag
forall a. Semigroup a => a -> a -> a
<> e -> Saying tag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable e
a
infixl 1 &?


-- | A helper operator allowing a Sayable item to be wrapped in a 'Maybe' and a
-- prettyprinter conversion as the first argument.  This is a combination of the
-- `&!` and `&?` operators.
--
-- >>> sez @"info" $ PP.group &!? Just (t'"hi")
-- "hi"
--
-- @since: 1.1.0.0
(&!?) :: forall tag e . (Sayable tag e)
      => (PP.Doc SayableAnn -> PP.Doc SayableAnn) -> Maybe e -> Saying tag
Doc SayableAnn -> Doc SayableAnn
_ &!? :: forall (tag :: Symbol) e.
Sayable tag e =>
(Doc SayableAnn -> Doc SayableAnn) -> Maybe e -> Saying tag
&!? Maybe e
Nothing = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying Doc SayableAnn
forall a. Monoid a => a
mempty
Doc SayableAnn -> Doc SayableAnn
pf &!? (Just e
a) = Doc SayableAnn -> Saying tag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying tag) -> Doc SayableAnn -> Saying tag
forall a b. (a -> b) -> a -> b
$ Doc SayableAnn -> Doc SayableAnn
pf (Doc SayableAnn -> Doc SayableAnn)
-> Doc SayableAnn -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ Saying tag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying tag -> Doc SayableAnn) -> Saying tag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @tag e
a
infixl 1 &!?


-- | A helper operator that generates a newline between its two arguments.  Many
-- times the '&-' operator is a better choice to allow normal prettyprinter
-- layout capabilities, but in situations where it is known that multiple lines
-- will or should be generated, this operator makes it easy to separate the
-- lines.
--
-- >>> sez @"info" $ t'"Hello" &< t'"world"
-- "Hello\nworld"
--
-- @since: 1.1.0.0
(&<) :: forall saytag m n . (Sayable saytag m, Sayable saytag n)
     => m -> n -> Saying saytag
m
m &< :: forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&< n
n = Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying
         (Doc SayableAnn -> Saying saytag)
-> Doc SayableAnn -> Saying saytag
forall a b. (a -> b) -> a -> b
$ (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag m
m)
         Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Doc SayableAnn
forall ann. Doc ann
PP.line :: PP.Doc SayableAnn)
         Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag n
n)
infixl 1 &<


-- | A helper operator that combines '&<' and '&*' which will generate a newline
-- between its two arguments, where the second argument is a foldable collection
-- whose elements will be sayable emitted with comma separators.
--
-- >>> sez @"info" $ t'"three:" &<* [1, 2, 3::Int]
-- "three:\n1, 2, 3"
--
-- @since: 1.1.0.0
(&<*) :: forall saytag m n t . (Sayable saytag m, Sayable saytag n, Foldable t)
      => m -> t n -> Saying saytag
m
m &<* :: forall (tag :: Symbol) m e (t :: * -> *).
(Sayable tag m, Sayable tag e, Foldable t) =>
m -> t e -> Saying tag
&<* t n
n = let addElem :: n
-> (Doc SayableAnn, Saying saytag)
-> (Doc SayableAnn, Saying saytag)
addElem n
e (Doc SayableAnn
s, Saying Doc SayableAnn
p) =
                (Doc SayableAnn
", ", Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying (Doc SayableAnn -> Saying saytag)
-> Doc SayableAnn -> Saying saytag
forall a b. (a -> b) -> a -> b
$ Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag n
e) Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
s Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> Doc SayableAnn
p)
          in Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying
             (Doc SayableAnn -> Saying saytag)
-> Doc SayableAnn -> Saying saytag
forall a b. (a -> b) -> a -> b
$ (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag m
m)
             Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Doc SayableAnn
forall ann. Doc ann
PP.line :: PP.Doc SayableAnn)
             Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag
                  ((Doc SayableAnn, Saying saytag) -> Saying saytag
forall a b. (a, b) -> b
snd ((Doc SayableAnn, Saying saytag) -> Saying saytag)
-> (Doc SayableAnn, Saying saytag) -> Saying saytag
forall a b. (a -> b) -> a -> b
$ (n
 -> (Doc SayableAnn, Saying saytag)
 -> (Doc SayableAnn, Saying saytag))
-> (Doc SayableAnn, Saying saytag)
-> t n
-> (Doc SayableAnn, Saying saytag)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr n
-> (Doc SayableAnn, Saying saytag)
-> (Doc SayableAnn, Saying saytag)
addElem (Doc SayableAnn
"", Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying Doc SayableAnn
forall ann. Doc ann
PP.emptyDoc) t n
n))
infixl 1 &<*


-- | A helper operator that emits the first argument and optionally emits a
-- newline and the 'Just' value of the second argument if the second argument is
-- not 'Nothing' (a combination of the '&<' and '&?' operators).
--
-- >>> sez @"info" $ t'"First" &<? Just (t'"something")
-- "First\nsomething"
-- >>> sez @"info" $ t'"Then" &<? (Nothing :: Maybe Text)
-- "Then"
--
-- @since: 1.1.0.0
(&<?) :: forall saytag m n . (Sayable saytag m, Sayable saytag n)
      => m -> Maybe n -> Saying saytag
m
m &<? :: forall (tag :: Symbol) m e.
(Sayable tag m, Sayable tag e) =>
m -> Maybe e -> Saying tag
&<? Maybe n
Nothing = m -> Saying saytag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m
m
m &<? (Just n
n) = Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying
                 (Doc SayableAnn -> Saying saytag)
-> Doc SayableAnn -> Saying saytag
forall a b. (a -> b) -> a -> b
$ (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag m
m)
                 Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Doc SayableAnn
forall ann. Doc ann
PP.line :: PP.Doc SayableAnn)
                 Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag n
n)
infixl 1 &<?


-- | A helper operator that emits the first argument and optionally emits a the
-- 'Just' value of the second argument immediately thereafter if the second
-- argument is not 'Nothing'
--
-- >>> sez @"info" $ t'"It's" &+? Nothing &- t'"ok" &+? Just "time"
-- "It's oktime"
--
-- @since: 1.2.0.0
(&+?) :: forall saytag m n . (Sayable saytag m, Sayable saytag n)
      => m -> Maybe n -> Saying saytag
m
m &+? :: forall (tag :: Symbol) m e.
(Sayable tag m, Sayable tag e) =>
m -> Maybe e -> Saying tag
&+? Maybe n
Nothing = m -> Saying saytag
forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable m
m
m
m &+? (Just n
n) = Doc SayableAnn -> Saying saytag
forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying
                 (Doc SayableAnn -> Saying saytag)
-> Doc SayableAnn -> Saying saytag
forall a b. (a -> b) -> a -> b
$ (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag m
m)
                 Doc SayableAnn -> Doc SayableAnn -> Doc SayableAnn
forall a. Semigroup a => a -> a -> a
<> (Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> Saying saytag -> Doc SayableAnn
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag n
n)
infixl 1 &+?


-- | A helper function to use when @OverloadedStrings@ is active to identify the
-- following quoted literal as a "Data.Text" object.  It is common to enable
-- OverloadedStrings because 'Prettyprinter.Pretty' declares an 'Data.String.IsString'
-- instance and thus facilitates the pretty-printing of string values, but this
-- causes GHC to emit warnings about assuming the types of strings, so this
-- function can be used to clarify the intended type.
--
-- >>> putStrLn $ t'"This is type: Data.Text"
-- "This is type: Data.Text"
--
t' :: Text -> Text
t' :: Text -> Text
t' = Text -> Text
forall a. a -> a
id
{-# INLINE t' #-}


-- | A helper function to use when creating a PP.Doc SayableAnn data
-- object (i.e. fixing the @ann@ of 'Doc ann' to 'SayableAnn')
d' :: PP.Pretty n => n -> PP.Doc SayableAnn
d' :: forall n. Pretty n => n -> Doc SayableAnn
d' = n -> Doc SayableAnn
forall ann. n -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty


----------------------------------------------------------------------

-- | This is the default annotation type for the Saying module.  The
-- Prettyprinter reannotate operation can be used to change this annotation into
-- any other annotation type the client desires.
--
-- The SayableAnn is an instance of IsLabel, so if OverloadedLabels is enabled,
-- this can easily be specified:
--
-- @
-- import qualified Prettyprinter as PP
-- import Text.Sayable
--
-- putStrLn $ sez @"info" $ PP.annotate #myann $ "Hello" &- "world!"
-- @
--
-- Note however that labels cannot start with a capital letter.

data SayableAnn = SayableAnn Text

instance KnownSymbol ann => IsLabel (ann :: Symbol) SayableAnn where
  fromLabel :: SayableAnn
fromLabel = Text -> SayableAnn
SayableAnn (Text -> SayableAnn) -> Text -> SayableAnn
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy# ann -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (Proxy# ann
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# ann)


----------------------------------------------------------------------

-- | This is a convenience function that can be used for simple conversions of a
-- Sayable to a String.  The use of this function is not generally recommended: a
-- more controlled rendering of the resulting 'Prettyprinter.Doc' (obtained from
-- the via 'saying') is recommended, but there are times (especially when
-- debugging) when a quick conversion/extraction to a @String@ is convenient.
--
--  This function is often used with a type application:
--
--  > putStrLn $ sez @"info" $ "There are" &- length lst &- "list elements."
--
-- Note that this will use the 'show' representation provided by 'Prettyprinter';
-- notably this will usually assume a width of 80 characters and perform wrapping
-- accordingly.

sez :: forall saytag a . Sayable saytag a => a -> String
sez :: forall (saytag :: Symbol) a. Sayable saytag a => a -> String
sez = Doc SayableAnn -> String
forall a. Show a => a -> String
show (Doc SayableAnn -> String) -> (a -> Doc SayableAnn) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> (a -> Saying saytag) -> a -> Doc SayableAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag

-- | This is a convenience function similar to the 'sez' helper, but specifies an
-- unlimited width so there is no wrapping.

sez_ :: forall saytag a . Sayable saytag a => a -> String
sez_ :: forall (saytag :: Symbol) a. Sayable saytag a => a -> String
sez_ = SimpleDocStream SayableAnn -> String
forall ann. SimpleDocStream ann -> String
PPS.renderString
       (SimpleDocStream SayableAnn -> String)
-> (a -> SimpleDocStream SayableAnn) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc SayableAnn -> SimpleDocStream SayableAnn
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty (PageWidth -> LayoutOptions
PP.LayoutOptions PageWidth
PP.Unbounded)
       (Doc SayableAnn -> SimpleDocStream SayableAnn)
-> (a -> Doc SayableAnn) -> a -> SimpleDocStream SayableAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Saying saytag -> Doc SayableAnn
forall (tag :: Symbol). Saying tag -> Doc SayableAnn
saying (Saying saytag -> Doc SayableAnn)
-> (a -> Saying saytag) -> a -> Doc SayableAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tag :: Symbol) v. Sayable tag v => v -> Saying tag
sayable @saytag


----------------------------------------------------------------------

-- | When creating 'Sayable' instances, it is necessary to create a Sayable
-- constraint for all sub-element data structures so that GHC will search for the
-- specific tagged instance, otherwise GHC will use a default instance that is
-- not necessarily associated with the current tag (see the "Sub-Element
-- Constraints" section above for more information).
--
-- The 'sayableSubConstraints' function is a Template Haskell helper that can
-- automatically generate the constraints for the sub-elements of this
-- datastructure.  This has several advantages, including brevity and ensuring
-- that no sub-elements are missed.  The 'sayableSubConstraints' is a function
-- taking a 'ConstrM' monad where that monad specifies the various information
-- (via the 'ConstrM' operations defined below) that are needed to generate the
-- sub-element constraints.
--
-- To use this, you will need to enable the @ConstraintKinds@ and
-- @TemplateHaskell@ pragmas.
--
-- With these enabled, the instance declaration would
-- be specified as:
--
-- > instance $(sayableSubConstraints $ ofType ''Baz) => Sayable saytag Foo where ...
--
-- If there are other constraints that should also be included, those can be
-- specified in a standard constraint tuple:
--
-- @
-- instance ( $(sayableSubConstraints $ ofType ''Baz)
--          , Show Bar
--          ) => Sayable tag Foo where ...
-- @
--
-- The 'sayableSubConstraints' function will examine the definition of the type
-- referenced by the second argument, and for every sub-type referenced (that is
-- accepted by any 'subElemFilter' specified), it will generate a Sayable
-- constraint for the sub type(s).
--
-- @
-- data Bar = ...
-- data Baz = ...
-- data Foo = Foo { fld1 :: Bar
--                , fld2 :: [Baz]
--                , fld3 :: Maybe Bar
--                }
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       tagVar "stag"
--           ) => Sayable stag Foo where
--   sayable foo = ...
-- @
--
-- becomes (via the magic of Template Haskell):
--
-- @
-- instance ( Sayable stag Bar
--          , Sayable stag Baz
--          ) => Sayable stag Foo where
--   sayable foo = ...
-- @
--
-- The 'subElemFilter' 'ConstrM' operation can be used to select only a subset of
-- the sub-elements for this constraints generation.  For example, with the
-- following definition:
--
-- @
-- data Foo2 = FC1 Bar [Maybe Baz] | FC2 Bar Int HiddenValue
-- @
--
-- The Sayable instance for Foo2 does not need a tag-specific constraint for the
-- Int type, and the instance will not output the @fld5@ hidden value, so no
-- 'Sayable' instance constraint is needed (and in fact, for safety, no actual
-- 'Sayable' instance will ever be created for @HiddenValue@).  To support this,
-- a filtering function can be used for the "Language.Haskell.TH.Name" type
-- references:
--
-- @
-- module MyModule where
--
-- import qualified Language.Haskell.TH as TH
--
-- data Bar = ...
-- data Baz = ...
-- data HiddenValue = ...
-- data Foo2 = FC1 Bar [Baz] | FC2 (Maybe Bar) Int HiddenValue
--
-- foo2Filter :: TH.Name -> Bool
-- foo2Filter nm = and [ \"HiddenValue\" /= TH.nameBase nm
--                     , maybe False (\"MyModule\" ==) $ TH.nameModule nm
--                     ]
--
-- instance $(sayableSubConstraints $ do ofType ''Foo2
--                                       tagVar "t"
--                                       subElemFilter foo2Filter
--           ) => Sayable t Foo2 where
--   sayable = \case
--       FC1 x y -> "First Foo2 form with" &- x &- "and" &- y
--       FC2 x y h -> "Second Foo2 form with" &? x &- y
--
-- instance Sayable t Bar where ...
-- instance Sayable t Baz where ...
-- @
--
-- which generates:
--
-- @
-- instance ( Sayable t Bar, Sayable t Baz ) => Sayable t Foo2 where ...
-- @
--
-- When the sub-elements are themselves parameterized, it is necessary to specify
-- what those parameters should map to: either the same parameter variables that
-- occur on the main type, or other types or values based on the usage of the
-- main type.  This can be done using the 'paramVar', 'paramSym', 'paramNat', or
-- 'paramTH' 'ConstrM' operations.  Each of these param declarations specifies
-- one of the parameters for sub-elements. All sub-elements must specify the
-- parameters in the same order, although each does not need to use all of the
-- parameters; sub-element types that do not follow this arrangement will need to
-- be manually specified instead (and filtered out of the template-haskell
-- generated constraints via the 'subElemFilter').
--
-- @
-- data Bar a = Bar (Maybe a)
-- data Baz a b = BazL a | BazR b
--
-- data Foo3 a = Foo3 { inputs :: Bar a, outputs :: Baz a String }
--
-- instance $(sayableSubConstraints $ do ofType ''Foo3
--                                       tagVar "t"
--                                       paramVar "a"
--                                       paramTH $ TH.ConT ''String
--           ) => Sayable t (Foo3 a) where ...
-- @
--
-- generates the following:
--
-- @
-- instance ( Sayable t (Bar a), Sayable t (Baz a String), Sayable t a ) => Sayable (Foo3 a) where ...
-- @
--
-- Clearly, there are some limitations to the 'sayableSubConstraints'
-- capabilities, so it is not always useable in all situations (e.g. with
-- tuples).  The sub-element constraints can and should be manually generated in
-- these situations.
--
-- In order to debug the output of the 'sayableSubConstraints' or otherwise
-- examine its suitability, enable @-ddump-splices@ when compiling.
--
sayableSubConstraints :: ConstrM () -> PredQ
sayableSubConstraints :: ConstrM () -> PredQ
sayableSubConstraints ConstrM ()
cspec =
  let initCtx :: SCCtx
initCtx = SCCtx { cTgt :: Name
cTgt = ''()
                      , cFilt :: Name -> Bool
cFilt = Bool -> Name -> Bool
forall a b. a -> b -> a
const Bool
True
                      , cSaytag :: Either Type String
cSaytag = String -> Either Type String
forall a b. b -> Either a b
Right String
"saytag"
                      , cVars :: [Either Type String]
cVars = [Either Type String]
forall a. Monoid a => a
mempty
                      , cWrapper :: Maybe Type
cWrapper = Maybe Type
forall a. Maybe a
Nothing
                      }
      (SCCtx
ctx, ()
_) = ConstrM () -> SCCtx -> (SCCtx, ())
forall a. ConstrM a -> SCCtx -> (SCCtx, a)
runConstrM ConstrM ()
cspec SCCtx
initCtx
  in (Name -> Bool)
-> Name
-> Either Type String
-> Maybe Type
-> [Either Type String]
-> PredQ
sayableSubConstraints' (SCCtx -> Name -> Bool
cFilt SCCtx
ctx) (SCCtx -> Name
cTgt SCCtx
ctx) (SCCtx -> Either Type String
cSaytag SCCtx
ctx) (SCCtx -> Maybe Type
cWrapper SCCtx
ctx) (SCCtx -> [Either Type String]
cVars SCCtx
ctx)


-- | ConstrM is a monadic context for describing the constraint parameters needed
-- by 'sayableSubConstraints' when generating sub-element Sayable constraints.
newtype ConstrM a = ConstrM { forall a. ConstrM a -> SCCtx -> (SCCtx, a)
runConstrM :: SCCtx -> (SCCtx, a) }

instance Applicative ConstrM where
  pure :: forall a. a -> ConstrM a
pure a
x = (SCCtx -> (SCCtx, a)) -> ConstrM a
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, a)) -> ConstrM a)
-> (SCCtx -> (SCCtx, a)) -> ConstrM a
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c, a
x)
  <*> :: forall a b. ConstrM (a -> b) -> ConstrM a -> ConstrM b
(<*>) = ConstrM (a -> b) -> ConstrM a -> ConstrM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor ConstrM where fmap :: forall a b. (a -> b) -> ConstrM a -> ConstrM b
fmap = (a -> b) -> ConstrM a -> ConstrM b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA

instance Monad ConstrM where
  return :: forall a. a -> ConstrM a
return = a -> ConstrM a
forall a. a -> ConstrM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ConstrM a
m >>= :: forall a b. ConstrM a -> (a -> ConstrM b) -> ConstrM b
>>= a -> ConstrM b
k = (SCCtx -> (SCCtx, b)) -> ConstrM b
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, b)) -> ConstrM b)
-> (SCCtx -> (SCCtx, b)) -> ConstrM b
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> let (SCCtx
c', a
a) = ConstrM a -> SCCtx -> (SCCtx, a)
forall a. ConstrM a -> SCCtx -> (SCCtx, a)
runConstrM ConstrM a
m SCCtx
c in ConstrM b -> SCCtx -> (SCCtx, b)
forall a. ConstrM a -> SCCtx -> (SCCtx, a)
runConstrM (a -> ConstrM b
k a
a) SCCtx
c'


-- | This ConstrM operation is used to declare the target data type for which the
-- Sayable constraints are to be generated via template-haskell.
--
-- > instance $(sayableSubConstraints $ do { ofType ''Foo; ... }) => Sayable t Foo where
--
-- If not used, the default type is @()@, which is not likely to be the desired
-- type.
ofType :: Name -> ConstrM ()
ofType :: Name -> ConstrM ()
ofType Name
nm = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cTgt = nm }, ())

-- | This ConstrM operation is used to declare the name of the saytag variable
-- used to specify the "Saying VAR sub-element" constraints.  This should match
-- the variable for the primary instance declaration.
--
-- > instance $(sayableSubConstraints $ do { ...; tagVar "t" }) => Sayable t X where ...
--
-- If not used, the default saytag is the variable @saytag@.  This operation is
-- coincident with the 'tagSym', 'tagNat', and 'tagTH' operations and the last
-- such operation will be the one used.
tagVar :: String -> ConstrM ()
tagVar :: String -> ConstrM ()
tagVar String
var = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cSaytag = Right var }, ())

-- | This ConstrM operation is used to declare a Symbol singleton value for the
-- saytag of the sub-element Sayable constraints.  This should match the Symbol
-- used for the primary instance declaration.
--
-- @
-- instance $(sayableSubConstraints $ do tagSym "loud"
--                                       ofType ''X
--           ) => Sayable "loud" X where ...
-- @
--
-- If not used, the default saytag is the variable @saytag@.  This operation is
-- coincident with the 'tagVar', 'tagNat', and 'tagTH' operations and the last
-- such operation will be the one used.
tagSym :: String -> ConstrM ()
tagSym :: String -> ConstrM ()
tagSym String
str = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cSaytag = Left $ TH.LitT $ TH.StrTyLit str }, ())

-- | Sometimes the sub-constraints should be wrapped in another type (via a
-- constructor for that type).  For example:
--
-- @
-- data WithIndentation a = WInd Int a
--
-- data Foo { subVal :: Bar }
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       subWrapper (TH.ConT ''WithIndentation)
--           ) => Sayable saytag Foo where
--    sayable foo = "FOO" &< WInd 2 (subVal foo)
--
subWrapper :: Type -> ConstrM ()
subWrapper :: Type -> ConstrM ()
subWrapper Type
wrp = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cWrapper = Just wrp }, ())


-- | This ConstrM operation is used to declare a filter to be applied to the
-- sub-elements: only sub-element 'Name' candidates for which this filter
-- function returns 'True' will have a Sayable constraint generated.
--
-- @
-- myModuleNames :: TH.Name -> Bool
-- myModuleNames = maybe False ("MyModule" ==) . TH.nameModule
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       subElemFilter myModuleNames
--          ) => Sayable saytag Foo where ...
-- @
--
-- If not used, the default is equivalent to @subElemFilter (const True)@ which
-- accepts all sub-element names.
subElemFilter :: (Name -> Bool) -> ConstrM ()
subElemFilter :: (Name -> Bool) -> ConstrM ()
subElemFilter Name -> Bool
fltrf = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cFilt = fltrf }, ())


-- | This ConstrM operation is used to specify the variable name that should be
-- used for the next sub-element parameter.  When sub-elements are parameterized
-- (e.g. @Maybe a@) then this operation allows the identification of a primary
-- instance variable to be used for the sub-element. All sub-elements must take
-- parameters in the same order, although they don't need to accept all
-- parameters.
--
-- @
-- data Foo b a = Foo (Either a b)
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       paramVar "x"
--                                       paramVar "y"
--           ) => Sayable saytag (Foo y x) where ...
-- @
--
-- generates: @(Sayable saytag (Either x y), Sayable saytag x, Sayable saytag y)@
--
-- As shown above, this operation can be used multiple times to specify multiple
-- parameters.
paramVar :: String -> ConstrM ()
paramVar :: String -> ConstrM ()
paramVar String
pname = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cVars = cVars c <> [ Right pname ] }, ())


-- | This ConstrM operation is used to specify a Symbol singleton value that
-- should be used for the next sub-element parameter.  When sub-elements are
-- parameterized (e.g. @Maybe a@) then this operation allows the identification
-- of a Symbol to be used for the sub-element. All sub-elements must take
-- parameters in the same order, although they don't need to accept all
-- parameters.
--
-- @
-- data Bar (s :: Symbol) = ...
-- data Foo (s :: Symbol) = Foo { thing :: Bar s }
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       paramSym "arg"
--           ) => Sayable saytag (Foo "arg") where ...
-- @
--
-- generates: @Sayable saytag (Bar "arg")@
--
-- This operation can be used multiple times to specify multiple parameters.
paramSym :: String -> ConstrM ()
paramSym :: String -> ConstrM ()
paramSym String
pname = let psym :: Either Type String
psym = Type -> Either Type String
forall a b. a -> Either a b
Left (Type -> Either Type String) -> Type -> Either Type String
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
TH.LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
TH.StrTyLit String
pname
                 in (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cVars = cVars c <> [ psym ] }, ())


-- | This ConstrM operation is used to specify a Nat singleton value that
-- should be used for the next sub-element parameter.  When sub-elements are
-- parameterized (e.g. @Maybe a@) then this operation allows the identification
-- of a Nat to be used for the sub-element. All sub-elements must take
-- parameters in the same order, although they don't need to accept all
-- parameters.
--
-- @
-- data Bar (s :: Symbol) (n :: Nat) = ...
-- data Foo (n :: Nat) (s :: Symbol) = Foo { thing :: Bar s n }
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       paramSym "arg"
--                                       paramNat 2
--           ) => Sayable saytag (Foo 2 "arg") where ...
-- @
--
-- generates: @Sayable saytag (Bar "arg" 2)@
--
-- This operation can be used multiple times to specify multiple parameters.
paramNat :: Integer -> ConstrM ()
paramNat :: Integer -> ConstrM ()
paramNat Integer
pnum = let pnat :: Either Type String
pnat = Type -> Either Type String
forall a b. a -> Either a b
Left (Type -> Either Type String) -> Type -> Either Type String
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
TH.LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
TH.NumTyLit Integer
pnum
                 in (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cVars = cVars c <> [ pnat ] }, ())


-- | This ConstrM operation is used to specify a template-haskell Type that
-- should be used for the next sub-element parameter.  When sub-elements are
-- parameterized (e.g. @Maybe a@) then this operation allows specification of a
-- specific Type for that parameter.  The use of this operation is unusual and is
-- expected only in cases where 'paramVar', 'paramSym', or 'paramNat' are
-- insufficient.
--
-- @
-- data Bar '(s :: Symbol, n :: Nat) = ...
-- data Foo (n :: Nat) (s :: Symbol) = Foo { thing :: Bar '(s, n) }
--
-- instance $(sayableSubConstraints $ do ofType ''Foo
--                                       paramTH (TH.App
--                                                (TH.App (TH.TupleT 2)
--                                                 (TH.LitT $ TH.StrTyLit "loud"))
--                                                (TH.LitT $ TH.NumTyLit 3))
--           ) => Sayable saytag (Foo 3 "loud") where ...
-- @
--
-- generates: @Sayable saytag (Bar '("loud", 3))@
--
-- This operation can be used multiple times to specify multiple parameters.
paramTH :: TH.Type -> ConstrM ()
paramTH :: Type -> ConstrM ()
paramTH Type
pty = (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a. (SCCtx -> (SCCtx, a)) -> ConstrM a
ConstrM ((SCCtx -> (SCCtx, ())) -> ConstrM ())
-> (SCCtx -> (SCCtx, ())) -> ConstrM ()
forall a b. (a -> b) -> a -> b
$ \SCCtx
c -> (SCCtx
c { cVars = cVars c <> [ Left pty ] }, ())


data SCCtx = SCCtx { SCCtx -> Name
cTgt :: Name
                   , SCCtx -> Name -> Bool
cFilt :: Name -> Bool
                   , SCCtx -> Either Type String
cSaytag :: Either TH.Type String
                   , SCCtx -> [Either Type String]
cVars :: [Either TH.Type String]
                   , SCCtx -> Maybe Type
cWrapper :: Maybe Type
                   }


sayableSubConstraints' :: (Name -> Bool)
                       -> Name
                       -> Either TH.Type String
                       -> Maybe TH.Type
                       -> [Either TH.Type String]
                       -> PredQ
sayableSubConstraints' :: (Name -> Bool)
-> Name
-> Either Type String
-> Maybe Type
-> [Either Type String]
-> PredQ
sayableSubConstraints' Name -> Bool
fltr Name
t Either Type String
tagName Maybe Type
mbWrapper [Either Type String]
varBindings = do
  Type
v <- case Either Type String
tagName of
         Left Type
x -> Type -> PredQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
x
         Right String
tn -> Name -> PredQ
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> PredQ) -> Name -> PredQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
tn

  let vbs :: [Type]
vbs = let toTgt :: Either Type String -> Type
toTgt = \case
                  Left Type
ty -> Type
ty
                  Right String
nm -> Name -> Type
VarT (String -> Name
mkName String
nm)
        in (Either Type String -> Type) -> [Either Type String] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Type String -> Type
toTgt [Either Type String]
varBindings

  DatatypeInfo
rt <- Name -> Q DatatypeInfo
reifyDatatype Name
t
  let cf' :: [Type]
cf' = [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ConstructorInfo -> [Type]
constructorFields (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
rt)
  [Type]
cf <- (Type -> PredQ) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> PredQ
resolveTypeSynonyms [Type]
cf'

  let tsubmap :: Map Name Type
tsubmap = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$ [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [TyVarBndr_ ()]
datatypeVars DatatypeInfo
rt) [Type]
vbs

  let collectTC :: TH.Type -> Q [TH.Type]
      collectTC :: Type -> Q [Type]
collectTC = \case

        -- String as a [Char] is a special case because String is the fundamental
        -- Pretty printable type, so restore it after resolveTypeSynonyms.
        AppT Type
ListT (ConT Name
a) | Name
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Char -> [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> Type
ConT ''String]

        -- Assumes that lists or list-like sequences are handled via &* and so
        -- only a dependency on the element type and not the sequence type itself
        -- is needed.
        AppT Type
ListT Type
b -> Type -> Q [Type]
collectTC Type
b
        AppT (ConT Name
a) Type
b | Name -> String
TH.nameBase Name
a String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String
"NonEmpty"
                                               , String
"Seq"
                                               , String
"Set"
                                               ] -> Type -> Q [Type]
collectTC Type
b

        -- Assumes Maybe is handled via &? so only a dependency on the element
        -- type and not on the Maybe itself.
        x :: Type
x@(AppT (ConT Name
a) Type
b) -> if Name
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe
                               then Type -> Q [Type]
collectTC Type
b
                               else [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ if Name -> Bool
fltr Name
a then [Type
x] else []

        (AppT Type
a Type
b) -> do [Type]
y <- Type -> Q [Type]
collectTC Type
a
                         [Type]
z <- Type -> Q [Type]
collectTC Type
b
                         [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((\Type
x -> Type -> Type -> Type
AppT Type
x (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
z) (Type -> [Type]) -> [Type] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
y)
        x :: Type
x@(ConT Name
a) -> [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ if Name -> Bool
fltr Name
a then [Type
x] else []
        x :: Type
x@(VarT Name
a) -> [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ if Name -> Bool
fltr Name
a then [Type
x] else []
        Type
x -> [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type
x]
  [Type]
tc <- (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
tsubmap) ([Type] -> [Type]) -> ([[Type]] -> [Type]) -> [[Type]] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q [Type]
collectTC [Type]
cf)


  -- Make a tuple of constraints for all the sub-element types collected in tc.
  -- Note that tc may contain duplicates, but it is fine to express duplicate
  -- constraints, so don't bother trying to filter down to only unique target
  -- types here.  However, the maximum tuple arity is 62, so create nested tuples
  -- if necessary to stay under that limit.

  let mkConstrTpl :: Type -> [Type] -> Type
mkConstrTpl Type
elem0 [Type]
lst =
        if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
lst then Type
elem0
        else let ([Type]
lst1, [Type]
lst2) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
60 [Type]
lst
                 l1len :: Int
l1len = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
lst1
                 base :: Type
base = Type -> Type -> Type
AppT (Int -> Type
TupleT (Int
l1len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Type
elem0
                 next :: Type -> Type -> Type
next Type
tc' Type
p' = Type -> Type -> Type
AppT Type
p' (Name -> [Type] -> Type
classPred ''Sayable [Type
v, Type
tc'])
             in Type -> [Type] -> Type
mkConstrTpl ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
next Type
base [Type]
lst1) [Type]
lst2
  let p :: Type
p = Type -> [Type] -> Type
mkConstrTpl (Int -> Type
TupleT Int
0) ((Type -> Type)
-> (Type -> Type -> Type) -> Maybe Type -> Type -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type -> Type
forall a. a -> a
id Type -> Type -> Type
AppT Maybe Type
mbWrapper (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tc)
  let pv :: Type
pv = Type -> [Type] -> Type
mkConstrTpl Type
p (Name -> Type
VarT (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Type) -> [String] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type String] -> [String]
forall a b. [Either a b] -> [b]
rights [Either Type String]
varBindings)
  Type -> PredQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
pv