content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  {-# OPTIONS -Wno-orphans #-}
  
  -- | Display JSON values using pretty printing combinators.
  --
  -- Adapted from Text.Pretty.JSON in the json package, which is
  --   Copyright (c) Galois, Inc. 2007
  --
  -- Why would you use this instead of Aeson + aeson-pretty?
  --   1. You want to retain the ordering of fields in JSON objects. Aeson
  --      doesn't do this.
  --   2. The pretty-printer here produces more compact output than aeson-pretty.
  
  module Util.JSON.Pretty
    ( -- instance Pretty JSValue
    ) where
  
  import Data.Ratio
  import Data.Char
  import Numeric
  import Text.JSON
  
  import Compat.Prettyprinter
  
  instance Pretty JSValue where
    pretty v = case v of
      JSNull -> "null"
      JSBool True -> "true"
      JSBool False -> "false"
      JSRational asf x -> pp_number asf x
      JSString x -> pp_string (fromJSString x)
      JSArray vs -> pp_array vs
      JSObject xs -> pp_object (fromJSObject xs)
  
  pp_number :: Bool -> Rational -> Doc a
  pp_number _ x | denominator x == 1 = pretty (numerator x)
  pp_number True x = pretty (fromRational x :: Float)
  pp_number _ x = pretty (fromRational x :: Double)
  
  pp_array :: [JSValue] -> Doc a
  pp_array xs = sep [nest 2 (vsep ("[" : punctuate comma (map pretty xs))), "]"]
  
  pp_object :: [(String,JSValue)] -> Doc a
  pp_object xs =
    sep [nest 2 (vsep ("{" : punctuate comma (map pp_field xs))), "}"]
    where pp_field (k,v) = pp_string k <> colon <+> pretty v
  
  pp_string :: String -> Doc a
  pp_string x = dquotes $ hcat $ map pp_char x
    where pp_char '\\'            = "\\\\"
          pp_char '"'             = "\\\""
          pp_char c | isControl c = uni_esc c
          pp_char c               = pretty [c]
  
          uni_esc c = "\\u" <> pretty (pad 4 (showHex (fromEnum c) ""))
  
          pad n cs  | len < n   = replicate (n-len) '0' ++ cs
                    | otherwise = cs
            where len = length cs
  