{-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-}

-- |Aeson-compatible pretty-printing of JSON 'Value's.
module Data.Aeson.Encode.Pretty (
    -- * Simple Pretty-Printing
    encodePretty, encodePrettyToTextBuilder,

    -- * Pretty-Printing with Configuration Options
    encodePretty', encodePrettyToTextBuilder',
    Config (..), defConfig,
    Indent(..), NumberFormat(..),
    -- ** Sorting Keys in Objects
    -- |With the Aeson library, the order of keys in objects is undefined due to
    --  objects being implemented as HashMaps. To allow user-specified key
    --  orders in the pretty-printed JSON, 'encodePretty'' can be configured
    --  with a comparison function. These comparison functions can be composed
    --  using the 'Monoid' interface. Some other useful helper functions to keep
    --  in mind are 'comparing' and 'on'.
    --
    --  Consider the following deliberately convoluted example, demonstrating
    --  the use of comparison functions:
    --
    --  An  object might pretty-print as follows
    --
    --  > {
    --  >   "baz": ...,
    --  >   "bar": ...,
    --  >   "foo": ...,
    --  >   "quux": ...,
    --  > }
    --
    --  which is clearly a confusing order of keys. By using a comparison
    --  function such as
    --
    --  > comp :: Text -> Text -> Ordering
    --  > comp = keyOrder ["foo","bar"] `mappend` comparing length
    --
    --  we can achieve the desired neat result:
    --
    --  > {
    --  >   "foo": ...,
    --  >   "bar": ...,
    --  >   "baz": ...,
    --  >   "quux": ...,
    --  > }
    --

    mempty,
    -- |Serves as an order-preserving (non-)sort function. Re-exported from
    --  "Data.Monoid".
    compare,
    -- |Sort keys in their natural order, i.e. by comparing character codes.
    -- Re-exported from the Prelude and "Data.Ord"
    keyOrder
) where

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as AK
import qualified Data.Aeson.KeyMap as AKM
#endif
import Data.Aeson (Value(..), ToJSON(..))
import qualified Data.Aeson.Text as Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Function (on)
#if !MIN_VERSION_aeson(2,0,0)
import qualified Data.HashMap.Strict as H (toList)
#endif
import Data.List (intersperse, sortBy, elemIndex)
import Data.Maybe (fromMaybe)
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ((<>))
#endif
import qualified Data.Scientific as S (Scientific, FPFormat(..))
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text.Lazy.Builder (Builder, toLazyText)
import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
import Data.Text.Lazy.Encoding (encodeUtf8)
import qualified Data.Vector as V (toList)
import Prelude ()
import Prelude.Compat


data PState = PState { PState -> Int
pLevel     :: Int
                     , PState -> Builder
pIndent    :: Builder
                     , PState -> Builder
pNewline   :: Builder
                     , PState -> Builder
pItemSep   :: Builder
                     , PState -> Builder
pKeyValSep :: Builder
                     , PState -> NumberFormat
pNumFormat :: NumberFormat
                     , PState -> [(Text, Value)] -> [(Text, Value)]
pSort      :: [(Text, Value)] -> [(Text, Value)]
                     }

-- | Indentation per level of nesting. @'Spaces' 0@ removes __all__ whitespace
--   from the output.
data Indent = Spaces Int | Tab

data NumberFormat
  -- | The standard behaviour of the 'Aeson.encode' function. Uses
  --   integer literals for integers (1, 2, 3...), simple decimals
  --   for fractional values between 0.1 and 9,999,999, and scientific
  --   notation otherwise.
  = Generic
  -- | Scientific notation (e.g. 2.3e123).
  | Scientific
  -- | Standard decimal notation
  | Decimal
  -- | Custom formatting function
  | Custom (S.Scientific -> Builder)

data Config = Config
    { Config -> Indent
confIndent  :: Indent
      -- ^ Indentation per level of nesting
    , Config -> Text -> Text -> Ordering
confCompare :: Text -> Text -> Ordering
      -- ^ Function used to sort keys in objects
    , Config -> NumberFormat
confNumFormat :: NumberFormat
    , Config -> Bool
confTrailingNewline :: Bool
      -- ^ Whether to add a trailing newline to the output
    }

-- |Sort keys by their order of appearance in the argument list.
--
--  Keys that are not present in the argument list are considered to be greater
--  than any key in the list and equal to all keys not in the list. I.e. keys
--  not in the argument list are moved to the end, while their order is
--  preserved.
keyOrder :: [Text] -> Text -> Text -> Ordering
keyOrder :: [Text] -> Text -> Text -> Ordering
keyOrder [Text]
ks = (Text -> Int) -> Text -> Text -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Text -> Int) -> Text -> Text -> Ordering)
-> (Text -> Int) -> Text -> Text -> Ordering
forall a b. (a -> b) -> a -> b
$ \Text
k -> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. Bounded a => a
maxBound (Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Text
k [Text]
ks)


-- |The default configuration: indent by four spaces per level of nesting, do
--  not sort objects by key, do not add trailing newline.
--
--  > defConfig = Config { confIndent = Spaces 4, confCompare = mempty, confNumFormat = Generic, confTrailingNewline = False }
defConfig :: Config
defConfig :: Config
defConfig =
  Config {confIndent :: Indent
confIndent = Int -> Indent
Spaces Int
4, confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
forall a. Monoid a => a
mempty, confNumFormat :: NumberFormat
confNumFormat = NumberFormat
Generic, confTrailingNewline :: Bool
confTrailingNewline = Bool
False}

-- |A drop-in replacement for aeson's 'Aeson.encode' function, producing
--  JSON-ByteStrings for human readers.
--
--  Follows the default configuration in 'defConfig'.
encodePretty :: ToJSON a => a -> ByteString
encodePretty :: forall a. ToJSON a => a -> ByteString
encodePretty = Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig

-- |A variant of 'encodePretty' that takes an additional configuration
--  parameter.
encodePretty' :: ToJSON a => Config -> a -> ByteString
encodePretty' :: forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
conf = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> a -> Builder
forall a. ToJSON a => Config -> a -> Builder
encodePrettyToTextBuilder' Config
conf

-- |A drop-in replacement for aeson's 'Aeson.encodeToTextBuilder' function,
--  producing JSON-ByteStrings for human readers.
--
--  Follows the default configuration in 'defConfig'.
encodePrettyToTextBuilder :: ToJSON a => a -> Builder
encodePrettyToTextBuilder :: forall a. ToJSON a => a -> Builder
encodePrettyToTextBuilder = Config -> a -> Builder
forall a. ToJSON a => Config -> a -> Builder
encodePrettyToTextBuilder' Config
defConfig

-- |A variant of 'Aeson.encodeToTextBuilder' that takes an additional configuration
--  parameter.
encodePrettyToTextBuilder' :: ToJSON a => Config -> a -> Builder
encodePrettyToTextBuilder' :: forall a. ToJSON a => Config -> a -> Builder
encodePrettyToTextBuilder' Config{Bool
NumberFormat
Indent
Text -> Text -> Ordering
confIndent :: Config -> Indent
confCompare :: Config -> Text -> Text -> Ordering
confNumFormat :: Config -> NumberFormat
confTrailingNewline :: Config -> Bool
confIndent :: Indent
confCompare :: Text -> Text -> Ordering
confNumFormat :: NumberFormat
confTrailingNewline :: Bool
..} a
x = PState -> Value -> Builder
fromValue PState
st (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
trail
  where
    st :: PState
st      = Int
-> Builder
-> Builder
-> Builder
-> Builder
-> NumberFormat
-> ([(Text, Value)] -> [(Text, Value)])
-> PState
PState Int
0 Builder
indent Builder
newline Builder
itemSep Builder
kvSep NumberFormat
confNumFormat [(Text, Value)] -> [(Text, Value)]
forall {b}. [(Text, b)] -> [(Text, b)]
sortFn
    indent :: Builder
indent  = case Indent
confIndent of
                Spaces Int
n -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
n Builder
" ")
                Indent
Tab      -> Builder
"\t"
    newline :: Builder
newline = case Indent
confIndent of
                Spaces Int
0 -> Builder
""
                Indent
_        -> Builder
"\n"
    itemSep :: Builder
itemSep = Builder
","
    kvSep :: Builder
kvSep   = case Indent
confIndent of
                Spaces Int
0 -> Builder
":"
                Indent
_        -> Builder
": "
    sortFn :: [(Text, b)] -> [(Text, b)]
sortFn  = ((Text, b) -> (Text, b) -> Ordering) -> [(Text, b)] -> [(Text, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Text -> Text -> Ordering
confCompare (Text -> Text -> Ordering)
-> ((Text, b) -> Text) -> (Text, b) -> (Text, b) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Text, b) -> Text
forall a b. (a, b) -> a
fst)
    trail :: Builder
trail   = if Bool
confTrailingNewline then Builder
"\n" else Builder
""


fromValue :: PState -> Value -> Builder
fromValue :: PState -> Value -> Builder
fromValue st :: PState
st@PState{Int
Builder
NumberFormat
[(Text, Value)] -> [(Text, Value)]
pLevel :: PState -> Int
pIndent :: PState -> Builder
pNewline :: PState -> Builder
pItemSep :: PState -> Builder
pKeyValSep :: PState -> Builder
pNumFormat :: PState -> NumberFormat
pSort :: PState -> [(Text, Value)] -> [(Text, Value)]
pLevel :: Int
pIndent :: Builder
pNewline :: Builder
pItemSep :: Builder
pKeyValSep :: Builder
pNumFormat :: NumberFormat
pSort :: [(Text, Value)] -> [(Text, Value)]
..} Value
val = Value -> Builder
go Value
val
  where
    go :: Value -> Builder
go (Array Array
v)  = PState
-> (Builder, Builder)
-> (PState -> Value -> Builder)
-> [Value]
-> Builder
forall a.
PState
-> (Builder, Builder) -> (PState -> a -> Builder) -> [a] -> Builder
fromCompound PState
st (Builder
"[",Builder
"]") PState -> Value -> Builder
fromValue (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
v)
    go (Object Object
m) = PState
-> (Builder, Builder)
-> (PState -> (Text, Value) -> Builder)
-> [(Text, Value)]
-> Builder
forall a.
PState
-> (Builder, Builder) -> (PState -> a -> Builder) -> [a] -> Builder
fromCompound PState
st (Builder
"{",Builder
"}") PState -> (Text, Value) -> Builder
fromPair ([(Text, Value)] -> [(Text, Value)]
pSort (Object -> [(Text, Value)]
forall {b}. KeyMap b -> [(Text, b)]
toList' Object
m))
    go (Number Scientific
x) = PState -> Scientific -> Builder
fromNumber PState
st Scientific
x
    go Value
v          = Value -> Builder
forall a. ToJSON a => a -> Builder
Aeson.encodeToTextBuilder Value
v

#if MIN_VERSION_aeson(2,0,0)
    toList' :: KeyMap b -> [(Text, b)]
toList' = ((Key, b) -> (Text, b)) -> [(Key, b)] -> [(Text, b)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Key
k, b
v) -> (Key -> Text
AK.toText Key
k, b
v)) ([(Key, b)] -> [(Text, b)])
-> (KeyMap b -> [(Key, b)]) -> KeyMap b -> [(Text, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap b -> [(Key, b)]
forall v. KeyMap v -> [(Key, v)]
AKM.toList
#else
    toList' = H.toList
#endif

fromCompound :: PState
             -> (Builder, Builder)
             -> (PState -> a -> Builder)
             -> [a]
             -> Builder
fromCompound :: forall a.
PState
-> (Builder, Builder) -> (PState -> a -> Builder) -> [a] -> Builder
fromCompound st :: PState
st@PState{Int
Builder
NumberFormat
[(Text, Value)] -> [(Text, Value)]
pLevel :: PState -> Int
pIndent :: PState -> Builder
pNewline :: PState -> Builder
pItemSep :: PState -> Builder
pKeyValSep :: PState -> Builder
pNumFormat :: PState -> NumberFormat
pSort :: PState -> [(Text, Value)] -> [(Text, Value)]
pLevel :: Int
pIndent :: Builder
pNewline :: Builder
pItemSep :: Builder
pKeyValSep :: Builder
pNumFormat :: NumberFormat
pSort :: [(Text, Value)] -> [(Text, Value)]
..} (Builder
delimL,Builder
delimR) PState -> a -> Builder
fromItem [a]
items = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Builder
delimL
    , if [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
items then Builder
forall a. Monoid a => a
mempty
        else Builder
pNewline Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
items' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
pNewline Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> PState -> Builder
fromIndent PState
st
    , Builder
delimR
    ]
  where
    items' :: Builder
items' = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Builder
pItemSep Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
pNewline) ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
                (a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\a
item -> PState -> Builder
fromIndent PState
st' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> PState -> a -> Builder
fromItem PState
st' a
item)
                    [a]
items
    st' :: PState
st' = PState
st { pLevel :: Int
pLevel = Int
pLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}

fromPair :: PState -> (Text, Value) -> Builder
fromPair :: PState -> (Text, Value) -> Builder
fromPair PState
st (Text
k,Value
v) =
  Value -> Builder
forall a. ToJSON a => a -> Builder
Aeson.encodeToTextBuilder (Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
k) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> PState -> Builder
pKeyValSep PState
st Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> PState -> Value -> Builder
fromValue PState
st Value
v

fromIndent :: PState -> Builder
fromIndent :: PState -> Builder
fromIndent PState{Int
Builder
NumberFormat
[(Text, Value)] -> [(Text, Value)]
pLevel :: PState -> Int
pIndent :: PState -> Builder
pNewline :: PState -> Builder
pItemSep :: PState -> Builder
pKeyValSep :: PState -> Builder
pNumFormat :: PState -> NumberFormat
pSort :: PState -> [(Text, Value)] -> [(Text, Value)]
pLevel :: Int
pIndent :: Builder
pNewline :: Builder
pItemSep :: Builder
pKeyValSep :: Builder
pNumFormat :: NumberFormat
pSort :: [(Text, Value)] -> [(Text, Value)]
..} = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
pLevel Builder
pIndent)

fromNumber :: PState -> S.Scientific -> Builder
fromNumber :: PState -> Scientific -> Builder
fromNumber PState
st Scientific
x = case PState -> NumberFormat
pNumFormat PState
st of
  NumberFormat
Generic
    | (Scientific
x Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
> Scientific
1.0e19 Bool -> Bool -> Bool
|| Scientific
x Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< -Scientific
1.0e19) -> FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
S.Exponent Maybe Int
forall a. Maybe a
Nothing Scientific
x
    | Bool
otherwise -> Value -> Builder
forall a. ToJSON a => a -> Builder
Aeson.encodeToTextBuilder (Value -> Builder) -> Value -> Builder
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number Scientific
x
  NumberFormat
Scientific -> FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
S.Exponent Maybe Int
forall a. Maybe a
Nothing Scientific
x
  NumberFormat
Decimal    -> FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
S.Fixed Maybe Int
forall a. Maybe a
Nothing Scientific
x
  Custom Scientific -> Builder
f   -> Scientific -> Builder
f Scientific
x