-- 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.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