-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE NoImplicitPrelude #-}

-- | Partially implements the interface provided by the @fmt@ package on top of
-- @prettyprinter@.
module Fmt.Buildable
  ( Buildable(..)
  , FromDoc(..)
  , FromSimpleDoc(..)
  , ReflowingDoc
    -- * Helpers
  , pretty
  , prettyText
    -- * Brackets
  , (+|)
  , (|+)
  , (|++)
  , (|++^)
  , (++|)
    -- * Formatters
  , unlinesF
  , unwordsF
  , nameF
  , indentF
  , blockMapF
  , blockMapF'
  , blockListF
  , blockListF'
  , mapF
  , mapF'
  , listF
  , listF'
  , whenF
  , unlessF
  , enumerateF
  , enumerateF'
  , whenNE
  , fillSepF
  , fillSepF'
  , reflowF
  , singleLineF
  , punctuateF
  , punctuateF'
  , quoteF
  , quoteF'
  , quoteOrIndentF
  , flatAltF
  , TupleF(..)
    -- ** hexF
  , FormatAsHex(..)
  , Hex(..)
    -- * Generics
  , GenericBuildable(..)
  , GBuildable(..)
  , GetFields(..)
  ) where

import Universum

import Data.ByteString.Builder qualified as BB
import Data.Foldable qualified as F
import Data.Text qualified as TS
import Data.Text.Lazy.Builder qualified as TLB
import Data.Text.Lazy.Builder.Int (hexadecimal)
import Data.Text.Lazy.Encoding qualified as TLE
import GHC.Exts (IsList, Item)
import GHC.Exts qualified as Exts
import GHC.Generics qualified as G
import Language.Haskell.TH (newName, reifyInstances)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Lib (appT, conT, listE, tupP, tupleT, varE, varP, varT)
import Prettyprinter qualified as WL hiding ((<+>))
import Prettyprinter.Internal qualified as WL (unsafeTextWithoutNewlines)
import Prettyprinter.Render.Text qualified as WL
import Prettyprinter.Util qualified as WL

import Fmt.Operators qualified as WL
import Fmt.Utils (Doc, isEmpty, renderOneLine)

{- $setup
>>> import Prelude hiding (show)
>>> import Debug (show)
>>> import Fmt
-}

----------------------------------------------------------------------------
-- FromDoc
----------------------------------------------------------------------------

{- | Helper intermediary class to define 'FromDoc'. The primary motivation for
its existence is being able to override the default layout engine.

>>> :{
layoutNarrow =
  Prettyprinter.layoutPretty Prettyprinter.LayoutOptions
    {Prettyprinter.layoutPageWidth = Prettyprinter.AvailablePerLine 20 1}
:}

>>> doc = reflowF "Lorem ipsum dolor sit amet, consectetur adipiscing elit."
>>> fmt doc
Lorem ipsum dolor sit amet, consectetur adipiscing elit.
>>> fmtSimple $ layoutNarrow doc
Lorem ipsum dolor
sit amet,
consectetur
adipiscing elit.
-}
class FromSimpleDoc a where
  fmtSimple :: WL.SimpleDocStream ann -> a

instance FromSimpleDoc TLB.Builder where
  fmtSimple = TLB.fromLazyText . WL.renderLazy

instance FromSimpleDoc BB.Builder where
  fmtSimple = BB.lazyByteString . fmtSimple

instance FromSimpleDoc LText where
  fmtSimple = WL.renderLazy

instance FromSimpleDoc Text where
  fmtSimple = WL.renderStrict

instance FromSimpleDoc String where
  fmtSimple = toString @Text . fmtSimple

instance FromSimpleDoc LByteString where
  fmtSimple = encodeUtf8 . fmtSimple @LText

instance FromSimpleDoc ByteString where
  fmtSimple = encodeUtf8 . fmtSimple @LText

instance a ~ () => FromSimpleDoc (IO a) where
  fmtSimple = putText . fmtSimple

-- | A class of things that can be produced from 'Doc' using the default layout
-- engine. Mostly various text types.
class FromDoc a where
  {- | Render a 'Doc' to another format.

  >>> doc = "foo" :: Doc
  >>> fmt doc :: Text
  "foo"
  >>> fmt doc :: LText
  "foo"
  >>> fmt doc :: String
  "foo"
  >>> fmt doc :: ByteString
  "foo"
  >>> fmt doc :: LByteString
  "foo"
  >>> fmt doc :: IO ()
  foo
  >>> fmt doc :: Data.Text.Lazy.Builder.Builder
  "foo"
  >>> Data.ByteString.Builder.toLazyByteString (fmt doc :: Data.ByteString.Builder.Builder)
  "foo"
  -}
  fmt :: Doc -> a

instance FromDoc Doc where
  fmt a = a

-- | Default layout engine. Uses 80 columns with ribbon width 1.
layout :: Doc -> WL.SimpleDocStream ()
layout = WL.layoutSmart WL.LayoutOptions {WL.layoutPageWidth = WL.AvailablePerLine 80 1}

do
  -- this isn't pretty, but it avoids an overlapping instance for FromDoc Doc
  varty <- varT =<< newName "a"
  reifyInstances ''FromSimpleDoc [varty] >>= mapM \case
    (TH.InstanceD _ con (TH.AppT _ ty) _) -> do
      inst <- appT (conT ''FromDoc) (pure ty)
      TH.InstanceD Nothing con inst <$> [d|$(varP 'fmt) = fmtSimple . layout|]
    _ -> error "impossible"

----------------------------------------------------------------------------
-- Buildable
----------------------------------------------------------------------------

-- | A thing that can be prettyprinted in human-readable (but not necessarily
-- machine-readable) format
class Buildable a where
  -- | Make a document with human-readable representation
  build :: a -> Doc
  default build :: (Generic a, GBuildable (G.Rep a)) => a -> Doc
  build = build . GenericBuildable

  -- | Used to avoid overlapping instances with 'String', cf. 'Prelude.showList'.
  buildList :: [a] -> Doc
  buildList = WL.align . WL.list . map build

-- | Newtype wrapper for @DerivingVia@, that uses the corresponding instance of
-- 'WL.Pretty' to derive 'Buildable'
newtype ViaPretty a = ViaPretty {unViaPretty :: a}

instance WL.Pretty a => Buildable (ViaPretty a) where
  build = WL.pretty . unViaPretty
  buildList = WL.prettyList . map unViaPretty

instance Buildable Doc where
  build x = x

-- NB: see below for more instances (because TH staging)

{- | Differs from the corresponding 'WL.Pretty' instance in one important
aspect. It converts newlines to hard lines. Thus,

>>> str = "Hello,\nWorld!" :: String
>>> Prettyprinter.group @() $ Prettyprinter.pretty str
Hello, World!
>>> Prettyprinter.group $ build str
Hello,
World!
-}
instance Buildable Char where
  build '\n' = WL.hardline
  build c = WL.pretty c
  buildList = build . toText

{- | Differs from the corresponding 'WL.Pretty' instance in one important
aspect. It converts newlines to hard lines.

>>> txt = "Hello,\nWorld!" :: Text
>>> Prettyprinter.group @() $ Prettyprinter.pretty txt
Hello, World!
>>> Prettyprinter.group $ build txt
Hello,
World!
-}
instance Buildable Text where
  build = unlinesF . map (WL.unsafeTextWithoutNewlines @()) . TS.splitOn "\n"

{- | Differs from the corresponding 'WL.Pretty' instance in one important
aspect. It converts newlines to hard lines.

>>> txt = "Hello,\nWorld!" :: LText
>>> Prettyprinter.group @() $ Prettyprinter.pretty txt
Hello, World!
>>> Prettyprinter.group $ build txt
Hello,
World!
-}
instance Buildable LText where
  build = build . toStrict

instance Buildable TLB.Builder where
  build = build . TLB.toLazyText

instance Buildable a => Buildable [a] where build = buildList
instance Buildable a => Buildable (NonEmpty a) where build = buildList . toList

{- | One important quirk of this instance is it skips over 'Nothing' values
entirely:

>>> build $ [Just 1, Nothing, Just 3]
[1, 3]
-}
instance Buildable a => Buildable (Maybe a) where
  build = maybe mempty build
  buildList = buildList . catMaybes
instance Buildable a => Buildable (Identity a) where
  build = build . runIdentity
instance Buildable a => Buildable (Const a b) where
  build = build . getConst

{- |

>>> pretty (Left "foo" :: Either String Int)
<Left: foo>
>>> pretty (Right 123 :: Either String Int)
<Right: 123>
-}
instance (Buildable a, Buildable b) => Buildable (Either a b) where
  build (Left a) = "<Left: " <> build a <> ">"
  build (Right b) = "<Right: " <> build b <> ">"

{- |

>>> pretty (fromList [("foo", "bar"), ("baz", "quux")] :: Map Text Text)
{baz: quux, foo: bar}
-}
instance (Buildable k, Buildable v) => Buildable (Map k v) where
  build = mapF . toPairs

{- |

>>> pretty (fromList ["foo", "bar", "baz", "quux"] :: Set Text)
[bar, baz, foo, quux]
-}
instance Buildable v => Buildable (Set v) where
  build = listF

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | 'build' then 'fmt'. Convenience synonym for @fmt . build@.
pretty :: (Buildable a, FromDoc b) => a -> b
pretty = fmt . build

-- | A less polymorphic version of 'pretty' for convenience.
prettyText :: Buildable a => a -> Text
prettyText = pretty

-- | When the second argument is empty, return 'mempty', otherwise, return the
-- first argument.
whenNE :: Monoid a => a -> Doc -> a
{-# SPECIALIZE whenNE :: Doc -> Doc -> Doc #-}
whenNE z y
  | isEmpty y = mempty
  | otherwise = z

----------------------------------------------------------------------------
-- Brackets
----------------------------------------------------------------------------

infixr 1 +|, |+

{- | Left format bracket. Enclose the value to format in these for concise syntax:

>>> :{
data WorldType = Cruel | Wonderful
  deriving (Generic, Buildable)
:}

>>> sayHello worldType = "Hello, " +| worldType |+ " world!"
>>> sayHello Cruel
Hello, Cruel world!
>>> sayHello Wonderful
Hello, Wonderful world!
-}
(+|) :: FromDoc b => Doc -> Doc -> b
d1 +| d2 = fmt $ d1 <> d2

-- | Right format bracket
(|+) :: (Buildable a, FromDoc b) => a -> Doc -> b
a |+ d = fmt (build a <> d)

infixr 1 ++|, |++, |++^

-- | Opaque type for reflowing brackets @++|@ @|++@.
newtype ReflowingDoc = ReflowingDoc (Text -> Doc)

{- | Bracket versions of 'enumerateF'. Note that unlike with @|+@, both brackets
are required.

>>> let splice = "lorem posuere dapibus in ut lorem." :: Doc
>>> let long_splice = splice <> " " <> splice
>>> :{
"Lorem ipsum dolor sit amet, consectetur adipiscing elit." ++| splice
  |++ "Morbi aliquet accumsan libero." ++| long_splice
  |++ "Consectetur adipiscing elit."
:}
Lorem ipsum dolor sit amet, consectetur adipiscing elit.
lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero.
lorem posuere dapibus in ut lorem. lorem posuere dapibus in ut lorem.
Consectetur adipiscing elit.

>>> let splice = build "lorem\nposuere\ndapibus"
>>> :{
"Lorem ipsum dolor sit amet, consectetur adipiscing elit." ++| splice |++
  "Morbi aliquet accumsan libero."
:}
Lorem ipsum dolor sit amet, consectetur adipiscing elit.
lorem
posuere
dapibus
Morbi aliquet accumsan libero.
-}
(|++) :: Buildable a => a -> Doc -> ReflowingDoc
x |++ trail = ReflowingDoc $ reflowDoc' WL.group trail x

{- | A version of the reflowing bracket that always breaks after a splice if
there's a break before the splice.

Compare with the similar example for @|++@, notice the line break after
@splice@. It may be combined with 'quoteOrIndentF'.

>>> let splice = "lorem posuere dapibus in ut lorem." :: Doc
>>> let long_splice = splice <> " " <> splice
>>> :{
"Lorem ipsum dolor sit amet, consectetur adipiscing elit." ++| splice
  |++^ "Morbi aliquet accumsan libero." ++| long_splice
  |++^ "Consectetur adipiscing elit."
:}
Lorem ipsum dolor sit amet, consectetur adipiscing elit.
lorem posuere dapibus in ut lorem.
Morbi aliquet accumsan libero.
lorem posuere dapibus in ut lorem. lorem posuere dapibus in ut lorem.
Consectetur adipiscing elit.
-}
(|++^) :: Buildable a => a -> Doc -> ReflowingDoc
x |++^ trail = ReflowingDoc $ reflowDoc' id trail x

reflowDoc' :: Buildable a => (Doc -> Doc) -> Doc -> a -> Text -> Doc
reflowDoc' tailGroup trail x (WL.reflow -> lead) =
  lead
  <> WL.group (whenNE WL.line lead
    <> tailGroup (WL.align (build x) <> whenNE WL.line trail))
  WL.<//> trail

-- | Left formatting bracket.
(++|) :: FromDoc b => Text -> ReflowingDoc -> b
lead ++| (ReflowingDoc f) = fmt $ f lead

----------------------------------------------------------------------------
-- Formatters
----------------------------------------------------------------------------

{-| Join a 'Foldable' with hardlines.

>>> Prettyprinter.group $ unlinesF ["foo", "bar", "baz"]
foo
bar
baz
-}
unlinesF :: (Foldable f, Buildable a) => f a -> Doc
unlinesF = WL.concatWith (WL.surround WL.hardline) . map build . F.toList

{-| Join a 'Foldable' with spaces.

>>> unwordsF ["foo", "bar", "baz"]
foo bar baz
-}
unwordsF :: (Buildable a, Foldable f) => f a -> Doc
unwordsF = WL.fillSep . map build . F.toList


{- | If @name@ and @content@ fit into the page width and @content@ doesn't
contain hard line breaks, layout as single line with @: @ between. Otherwise,
make a multiline layout, appending @:@ to @name@, and nesting @content@ by 2
spaces.

>>> nameF "Test" "foo"
Test: foo
>>> nameF "Test" $ fillSepF $ replicate 27 "foo"
Test:
  foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo
  foo foo foo foo foo foo foo foo

If either name or content is empty, returns only the other one.

>>> nameF "" "foo"
foo
>>> nameF "Test" ""
Test
-}
nameF :: Buildable a => Doc -> a -> Doc
nameF name (build -> content)
  | isEmpty name = content
  | isEmpty content = name
  | otherwise = WL.group $ WL.nest 2 $ name <> ":" <>
      WL.flatAlt (WL.hardline <> content) (WL.space <> content)

{-| Indent 'Doc' by a given number of spaces.

>>> indentF 4 "foo"
    foo
>>> indentF 4 "foo\nbar"
    foo
    bar
-}
indentF :: Int -> Doc -> Doc
indentF = WL.indent

{-| Print a map-like thing in the style of a YAML map.

>>> blockMapF $ [("foo", "bar"), ("baz", "quux")]
foo: bar
baz: quux
>>> blockMapF ([] :: [(Text, Text)])
{}
-}
blockMapF :: (Buildable k, Buildable v, IsList f, Item f ~ (k, v)) => f -> Doc
blockMapF = blockMapF' build build

{- | Version of 'blockMapF' that allows explicitly passing functions to format
key and value.

>>> blockMapF' hexF build $ [(123, "foo"), (456, "bar")]
7b: foo
1c8: bar
-}
blockMapF' :: (IsList f, Item f ~ (k, v)) => (k -> Doc) -> (v -> Doc) -> f -> Doc
blockMapF' fbuild_k fbuild_v xs
  | null items = "{}"
  | otherwise = unlinesF items
  where
    items = uncurry nameF . bimap fbuild_k fbuild_v <$> Exts.toList xs

{- | Render a list-like thing, YAML style.

>>> blockListF ["foo", "bar", "baz"]
- foo
- bar
- baz
>>> blockListF ([] :: [Text])
[]
-}
blockListF :: (Buildable a, Foldable f) => f a -> Doc
blockListF = blockListF' "-" build

{- | Version of 'blockListF' that allows explicitly passing a bullet style and
formatter for items

>>> blockListF' "*" hexF [1,11,21]
* 1
* b
* 15
-}
blockListF' :: (Foldable f) => Doc -> (a -> Doc) -> f a -> Doc
blockListF' bullet fa xs
  | F.null xs = "[]"
  | otherwise = unlinesF $ map (buildItem . fa) $ F.toList xs
  where
    buildItem x
      | isEmpty x = bullet
      | otherwise = bullet WL.<+> WL.align x

{-| Format a map-like thing, JSON-style.

>>> mapF [("foo", "bar"), ("baz", "quux")]
{foo: bar, baz: quux}
>>> mapF ([] :: [(Text, Text)])
{}
>>> mapF $ replicate 9 ("foo", "bar")
{ foo: bar
, foo: bar
...
, foo: bar }
>>> mapF $ [("foo", "bar\nquux"), ("baz", "corge")]
{ foo:
    bar
    quux
, baz: corge }
-}
mapF :: (Buildable k, Buildable v, IsList f, Item f ~ (k, v)) => f -> Doc
mapF = mapF' build build

{-| Version of 'mapF' allowing for custom formatters.

>>> mapF' hexF build [(128, "foo"), (512, "bar")]
{80: foo, 200: bar}
-}
mapF' :: (IsList f, Item f ~ (k, v)) => (k -> Doc) -> (v -> Doc) -> f -> Doc
mapF' fk fv
  = WL.group
  . WL.encloseSep lbrace rbrace ", "
  . map (WL.align . uncurry nameF . bimap fk fv)
  . Exts.toList
  where
    lbrace = WL.flatAlt "{ " "{"
    rbrace = WL.flatAlt " }" "}"

{-| Print a list, JSON-style.

>>> listF [1..3]
[1, 2, 3]
>>> listF [1..100]
[ 1
, 2
...
, 100 ]
>>> listF ["foo", "bar\nbaz"]
[ foo
, bar
  baz ]
-}
listF :: (Buildable a, Foldable f) => f a -> Doc
listF = listF' build

{-| Version of 'listF' that allows explicitly specifying a formatter for items.

>>> listF' hexF [1,11,21]
[1, b, 15]
-}
listF' :: Foldable f => (a -> Doc) -> f a -> Doc
listF' f = WL.list . map (WL.align . f) . F.toList

{-| Conditionally print something.

>>> whenF True "foo"
foo
>>> show $ whenF False "foo"
""
-}
whenF :: Bool -> Doc -> Doc
whenF True x = x
whenF False _ = mempty

{-| Boolean inverse of 'whenF'

>>> unlessF False "foo"
foo
>>> show $ unlessF True "foo"
""
-}
unlessF :: Bool -> Doc -> Doc
unlessF = whenF . not

{-| Class for formatting tuples

>>> tupleF ("foo", "bar", "baz")
(foo, bar, baz)
>>> tupleF ("foo","bar\nbaz")
( foo
, bar
  baz )
>>> :{
tupleF
  ( "foo", "foo", "foo", "foo", "foo"
  , "foo", "foo", "foo", "foo", "foo"
  , "foo", "foo", "foo", "foo", "foo"
  , "foo", "foo", "foo", "foo", "foo"
  )
:}
( foo
, foo
...
, foo )
-}
class TupleF a where
  tupleF :: a -> Doc

-- NB: see below for a bunch of TH-derived instances for tuples

instance Buildable a => TupleF [a] where
  tupleF = WL.tupled . map (WL.align . build)

class FormatAsHex a where
  {- | Format a number or bytestring as hex:

  >>> pretty $ hexF 3635
  e33
  >>> pretty $ hexF (-3635)
  -e33
  >>> pretty $ hexF ("\0\50\63\80" :: ByteString)
  00323f50
  >>> pretty $ hexF ("\0\50\63\80" :: LByteString)
  00323f50
  -}
  hexF :: a -> Doc

instance FormatAsHex ByteString where
  hexF = build . TLE.decodeLatin1 . BB.toLazyByteString . BB.byteStringHex

instance FormatAsHex LByteString where
  hexF = build . TLE.decodeLatin1 . BB.toLazyByteString . BB.lazyByteStringHex

{- | Wrap an integral type with this if there's no 'FormatAsHex' instance for it
yet, or use it with @DerivingVia@.

>>> hexF $ Hex 128
80
-}
newtype Hex a = Hex a
instance Integral a => FormatAsHex (Hex a) where
  hexF (Hex i) = sgn <> build (hexadecimal $ abs i)
    where
      sgn = if i < 0 then "-" else mempty

-- NB: see below for more TH-derived instances

{- | Enumerate pairs of text and 'Doc', reflowing the content to best-fit line
width. This will line-wrap text on whitespace. If 'Doc' is rendered single-line,
this will try to fit it inline. Otherwise, it's surrounded by newlines.

>>> :{
long_text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. \
  \ Donec eget diam ac lorem posuere dapibus in ut lorem. Morbi \
  \ aliquet accumsan libero, a tempor nunc egestas ac."
:}

>>> enumerateF [(long_text, mempty)]
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec eget diam ac
lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero, a tempor nunc
egestas ac.

>>> let splice = "SPLICE SPLICE SPLICE" :: Doc
>>> :{
enumerateF
  [ (long_text, splice)
  , (long_text, mempty)
  ]
:}
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec eget diam ac
lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero, a tempor nunc
egestas ac. SPLICE SPLICE SPLICE Lorem ipsum dolor sit amet, consectetur
adipiscing elit. Donec eget diam ac lorem posuere dapibus in ut lorem. Morbi
aliquet accumsan libero, a tempor nunc egestas ac.

>>> let splice = build "SPLICE\nSPLICE\nSPLICE"
>>> :{
enumerateF
  [ (long_text, splice)
  , ("Short text", mempty)
  ]
:}
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec eget diam ac
lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero, a tempor nunc
egestas ac.
SPLICE
SPLICE
SPLICE
Short text

-}
enumerateF :: [(Text, Doc)] -> Doc
enumerateF = enumerateF' mempty

{- | Version of 'enumerateF' that allows specifying separator between items.

>>> enumerateF' "," [("Foo", build 1), ("bar", build 2), ("baz", build 3)]
Foo 1, bar 2, baz 3
-}
enumerateF' :: Doc -> [(Text, Doc)] -> Doc
enumerateF' sep = foldr merge mempty
  where
    merge (lead, x) trail = lead ++| (x <> whenNE sep trail) |++ trail

{- | Surround a 'Buildable' with quotes (or anything else really).

@quoteF' l r x@ is equivalent to @l <> build x <> r@, but it may be more
convenient in some cases.

>>> quoteF' "\"" "\"" "Foo"
"Foo"
-}
quoteF' :: Buildable a => Doc -> Doc -> a -> Doc
quoteF' l r = WL.enclose l r . build

{- | Surround a 'Buildable' with the same 'Doc' on both sides.

>>> quoteF "\"" "Foo"
"Foo"
-}
quoteF :: Buildable a => Doc -> a -> Doc
quoteF q = quoteF' q q

{- | If buildable fits into the line, wrap it in single quotes. Otherwise,
indent it by 2 spaces. This is convenient with 'enumerateF' or reflowing
brackets to format a splice that can be long and multiline or short and
singleline with about equal probability.

This is a particularly useful specialization of 'flatAltF'.

>>> let splice = "lorem posuere dapibus" :: Doc
>>> let long_splice = unwordsF $ replicate 3 splice
>>> let very_long_splice = unwordsF $ replicate 4 splice

>>> "Foobar" ++| quoteOrIndentF splice |++ "bazbar."
Foobar 'lorem posuere dapibus' bazbar.

>>> "Foobarbazquux" ++| quoteOrIndentF long_splice |++ "bazbar."
Foobarbazquux
'lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus' bazbar.

>>> "Foobarbazquux" ++| quoteOrIndentF long_splice |++^ "bazbar."
Foobarbazquux
  lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus
bazbar.

>>> "Foobar" ++| quoteOrIndentF very_long_splice |++ "bazbar."
Foobar
  lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus
  lorem posuere dapibus
bazbar.

>>> "Foobar" ++| quoteOrIndentF very_long_splice |++^ "bazbar."
Foobar
  lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus
  lorem posuere dapibus
bazbar.
-}
quoteOrIndentF :: Buildable a => a -> Doc
quoteOrIndentF = flatAltF (indentF 2 . build) (quoteF "'" . build)

{- | Use different formatters depending on whether the pretty-printed
representation fits on the current line or not. The exact meaning of "fits" is
determined by the surrounding context. In precise terms, whether multiline or
single-line format is chosen is determined by whether the enclosing @group@ is
broken or not, respectively. Useful with reflowing brackets, 'nameF', etc to
specify alternate format for short and/or single-line and long and/or multiline
text.

>>> let short = "bar baz" :: Text
>>> let long = unwordsF $ replicate 10 short

>>> nameF "Foo" $ flatAltF (quoteF "\"") (quoteF "'") short
Foo: 'bar baz'

>>> nameF "Foo" $ flatAltF (quoteF "\"") (quoteF "'") long
Foo:
  "bar baz bar baz bar baz bar baz bar baz bar baz bar baz bar baz bar baz
  bar baz"
-}
flatAltF
  :: (a -> Doc) -- ^ Multiline formatter
  -> (a -> Doc) -- ^ Single-line formatter
  -> (a -> Doc)
flatAltF nonFlat flat res = WL.flatAlt (nonFlat res) (flat res)

-- | Like 'WL.fillSep', but skips over empty elements.
fillSepF :: (Foldable t, Buildable a) => t a -> Doc
fillSepF = F.foldr (\x acc -> build x WL.</> acc) mempty

-- | Version of 'fillSepF' with punctuation.
fillSepF' :: (Foldable t, Buildable a) => Doc -> t a -> Doc
fillSepF' sep = fillSepF . WL.punctuate sep . map build . F.toList

-- | Reflow text, line-wrapping on white-space. Any leading and trailing
-- whitespace is stripped.
reflowF :: Text -> Doc
reflowF = WL.reflow

{- | Punctuate a foldable with a distinct separator for the last two elements.
Useful for enumerations. Does the oxford comma by concatenating first and second
arguments. Note that when using a word, a leading space is expected on the pair
separator.

>>> fillSepF $ punctuateF "," " and" ([] :: [Doc])
<BLANKLINE>
>>> fillSepF $ punctuateF "," " and" ["foo"]
foo
>>> fillSepF $ punctuateF "," " and" ["bar", "baz"]
bar and baz
>>> fillSepF $ punctuateF "," " and" ["foo", "bar", "baz"]
foo, bar, and baz
-}
punctuateF
  :: (Foldable t, Buildable a)
  => Doc -- ^ Default separator, usually comma
  -> Doc -- ^ Pair separator, usually @" and"@ or @" or"@
  -> t a -- ^ Foldable to punctuate
  -> [Doc]
punctuateF sep sep2 = punctuateF' sep sep2 (sep <> sep2)

{- | Version of 'punctuateF' with explicit distinct separators for penultimate
element and just two elements.

>>> fillSepF $ punctuateF' "," " and" ", and" ([] :: [Doc])
<BLANKLINE>
>>> fillSepF $ punctuateF' "," " and" ", and" ["foo"]
foo
>>> fillSepF $ punctuateF' "," " and" ", and" ["bar", "baz"]
bar and baz
>>> fillSepF $ punctuateF' "," " and" ", and" ["foo", "bar", "baz"]
foo, bar, and baz
-}
punctuateF'
  :: (Foldable t, Buildable a)
  => Doc -- ^ Default separator
  -> Doc -- ^ Pair separator
  -> Doc -- ^ Penultimate element separator
  -> t a
  -> [Doc]
punctuateF' sep sep2 sepOxford = go False . F.toList
  where
    go oxfordComma = \case
      [] -> []
      [x] -> [build x]
      [x, y] -> [build x <> if oxfordComma then sepOxford else sep2, build y]
      (x:xs) -> build x <> sep : go True xs

{- | Force the 'Doc' to be rendered on a single line, regardless of anything,
including hard line breaks. Will lead to horrible terrible formatting if
overused. In all likelihood, this is not the function you're looking for.

Note that hard line breaks will be removed entirely, not replaced with spaces.

>>> singleLineF ("foo\nbar\nbaz" :: Text)
foobarbaz
-}
singleLineF :: Buildable a => a -> Doc
singleLineF = WL.unsafeTextWithoutNewlines . fmtSimple . renderOneLine . build

----------------------------------------------------------------------------
-- Generic stuff
----------------------------------------------------------------------------

{- | Newtype for use with @DerivingVia@, e.g.

>>> :{
data Foo = Bar | Baz
  deriving (Generic, Buildable)
:}

>>> build Bar
Bar

Handles infix constructors properly:

>>> data Inf = Text :-> Text deriving (Generic, Buildable)
>>> build $ "foo" :-> "bar"
foo :-> bar
>>> data Inf2 = Text `Con` Text deriving (Generic, Buildable)
>>> build $ Con "foo" "bar"
foo `Con` bar

>>> :{
data LargeTy = LargeTy
  Text Text Text Text Text
  Text Text Text Text Text
  Text Text Text Text Text
  Text Text Text Text Text
  deriving (Generic, Buildable)
:}

>>> :{
build $ LargeTy
  "foo" "foo" "foo" "foo" "foo"
  "foo" "foo" "foo" "foo" "foo"
  "foo" "foo" "foo" "foo" "foo"
  "foo" "foo" "foo" "foo" "foo"
:}
LargeTy;
  foo,  foo,  foo,  foo,  foo,  foo,  foo,  foo,  foo,  foo,  foo,  foo,  foo,
  foo,  foo,  foo,  foo,  foo,  foo,  foo


There is a special case for tuples:

>>> :{
newtype Tup = Tup (Int, Int, Text)
  deriving stock Generic
  deriving anyclass Buildable
:}

>>> build $ Tup (1, 2, "many")
Tup; (1, 2, many)
>>> build $ Tup (1, 2, "many\nlines")
Tup;
  ( 1
  , 2
  , many
    lines )

Renders records as maps

>>> :{
data Rec = Rec
  { foo :: Text
  , bar :: Text
  , baz :: Text
  } deriving (Generic, Buildable)
:}

>>> build $ Rec "quux" "waldo" "corge"
Rec:
  foo: quux
  bar: waldo
  baz: corge
-}
newtype GenericBuildable a = GenericBuildable a

instance (GBuildable (G.Rep a), Generic a) => Buildable (GenericBuildable a) where
  build (GenericBuildable a) = gbuild $ G.from a

class GBuildable f where
  gbuild :: f a -> Doc

instance Buildable c => GBuildable (G.Rec0 c) where
  gbuild (G.K1 a) = build a

instance (GBuildable a, GBuildable b) => GBuildable (a G.:+: b) where
  gbuild (G.L1 x) = gbuild x
  gbuild (G.R1 x) = gbuild x

instance GBuildable a => GBuildable (G.D1 d a) where
  gbuild (G.M1 x) = gbuild x

instance (GetFields a, G.Constructor c) => GBuildable (G.C1 c a) where
  -- A note on fixity:
  --   * Ordinarily e.g. "Foo" is prefix and e.g. ":|" is infix
  --   * However, "Foo" can be infix when defined as "a `Foo` b"
  --   * And ":|" can be prefix when defined as "(:|) a b"
  gbuild c@(G.M1 x)
    | G.Infix{} <- G.conFixity c
    -- There will always be two fields in this case.
    , [a, b] <- fields = a WL.<+> infixName WL.<+> b
    | isTuple = WL.tupled fields
    | G.conIsRecord c = nameF prefixName $ blockMapF fieldsWithNames
    | null fields = prefixName
    | otherwise = WL.nest 2 $ WL.group $ WL.surround (";" <> WL.line) prefixName $
        WL.fillSep $ WL.punctuate ", " fields
    where
      fieldsWithNames = getFields x
      fields = snd <$> fieldsWithNames
      (prefixName, infixName)
        | ':':_ <- G.conName c = (WL.enclose "(" ")" cn, cn)
        | otherwise = (cn, WL.enclose "`" "`" cn)
        where cn = build (G.conName c)
      isTuple
        | '(':',':_ <- G.conName c = True
        | otherwise = False

-- | Helper class for 'GBuildable'.
class GetFields f where
  -- | Get fields, together with their names if available
  getFields :: f a -> [(String, Doc)]

instance (GetFields a, GetFields b) => GetFields (a G.:*: b) where
  getFields (a G.:*: b) = getFields a <> getFields b

instance (GBuildable a, G.Selector c) => GetFields (G.S1 c a) where
  getFields s@(G.M1 a) = [(G.selName s, WL.align $ gbuild a)]

instance GetFields G.U1 where
  getFields _ = []

----------------------------------------------------------------------------
-- TH-derived instances and those that depend on it
----------------------------------------------------------------------------

concatMapM
  (\(conT -> ty) -> [d|deriving via ViaPretty $ty instance Buildable $ty|])
  [ ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Integer
  , ''Word, ''Word8, ''Word16, ''Word32, ''Word64, ''Natural
  , ''(), ''Void
  , ''Bool, ''Double, ''Float
  ]

concatMapM
  (\(conT -> ty) -> [d|deriving via Hex $ty instance FormatAsHex $ty|])
  [ ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Integer
  , ''Word, ''Word8, ''Word16, ''Word32, ''Word64, ''Natural
  ]

concatForM [2..30] \n -> do
  names <- replicateM n $ newName "a"
  let constr = tupT $ tys <&> \ty -> [t|Buildable $ty|]
      tup = tupT tys
      tupT = foldl' appT (tupleT n)
      tys = varT <$> names
      pat = tupP $ varP <$> names
      list = listE $ names <&> \name -> [|WL.align $ build $(varE name)|]
  [d|
    instance $constr => TupleF $tup where
      tupleF $pat = WL.tupled $list
    instance $constr => Buildable $tup where
      build = tupleF
    |]

instance Buildable a => Buildable (Ratio a) where
  {-# SPECIALIZE instance Buildable (Ratio Integer) #-}
  build a = build (numerator a) <> "/" <> build (denominator a)

{- |

>>> pretty (fromList [(100, "bar"), (500, "quux")] :: IntMap Text)
{100: bar, 500: quux}
-}
instance Buildable v => Buildable (IntMap v) where
  build = mapF

{- |

>>> pretty (fromList [100, 500] :: IntSet)
[100, 500]
-}
instance Buildable IntSet where
  build = listF . toList