{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

--
-- As currently implemented this module, in conjunction with
-- Core.Text, is the opposite of efficient. The idea right now is to
-- experiment with the surface API. If it stabilizes, then the fact
-- that our string objects are already in UTF-8 will make for a very
-- efficient emitter.
--

-- |
-- Encoding and decoding UTF-8 JSON content.
--
-- This module is a thin wrapper around the most excellent __aeson__ library,
-- which has rich and powerful facilities for encoding Haskell types into
-- JSON.
--
-- Quite often, however, you find yourself having to create a Haskell type
-- /just/ to read some JSON coming from an external web service or API. This
-- can be challenging when the source of the JSON is complex or varying its
-- schema over time. For ease of exploration this module simply defines an
-- easy to use intermediate type representing JSON as a format.
--
-- Often you'll be working with literals directly in your code. While you can
-- write:
--
-- @
--     j = 'JsonObject' ('intoMap' [('JsonKey' "answer", 'JsonNumber' 42)])
-- @
--
-- and it would be correct, enabling:
--
-- @
-- \{\-\# LANGUAGE OverloadedStrings \#\-\}
-- \{\-\# LANGUAGE OverloadedLists \#\-\}
-- @
--
-- allows you to write:
--
-- @
--     j = 'JsonObject' [("answer", 42)]
-- @
--
-- which you is somewhat less cumbersome in declaration-heavy code. You're
-- certainly welcome to use the constructors if you find it makes for more
-- readable code or if you need the type annotations.
module Core.Encoding.Json
  ( -- * Encoding and Decoding
    encodeToUTF8,
    decodeFromUTF8,
    JsonValue (..),
    JsonKey (..),

    -- * Syntax highlighting

    -- |
    -- Support for pretty-printing JSON values with syntax highlighting using the
    -- __prettyprinter__ library. To output a JSON structure to terminal
    -- colourized with ANSI escape codes you can use the 'Render' instance:
    --
    -- @
    --     debug "j" (render j)
    -- @
    --
    -- will get you:
    --
    -- @
    -- 23:46:04Z (00000.007) j =
    -- {
    --     "answer": 42.0
    -- }
    -- @
    JsonToken (..),
    colourizeJson,
    prettyKey,
    prettyValue,
  )
where

import Core.Data.Structures (Key, Map, fromMap, intoMap)
import Core.Text.Bytes (Bytes, fromBytes, intoBytes)
import Core.Text.Rope (Rope, Textual, fromRope, intoRope)
import Core.Text.Utilities
    ( brightBlue,
      brightGrey,
      brightMagenta,
      dullBlue,
      dullCyan,
      dullGreen,
      dullYellow,
      AnsiColour,
      Render(Token, highlight, colourize) )
import qualified Data.Aeson as Aeson
import Data.Coerce
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Hashable (Hashable)
import Data.Scientific (Scientific)
import Data.String (IsString (..))
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
  ( Doc,
    Pretty (..),
    annotate,
    comma,
    dquote,
    group,
    hcat,
    indent,
    lbrace,
    lbracket,
    line,
    line',
    nest,
    punctuate,
    rbrace,
    rbracket,
    sep,
    unAnnotate,
    viaShow,
    vsep,
    (<+>),
  )
import qualified Data.Vector as V
import GHC.Generics

-- |
-- Given a JSON value, encode it to UTF-8 bytes
--
-- I know we're not /supposed/ to rely on types to document functions, but
-- really, this one does what it says on the tin.
encodeToUTF8 :: JsonValue -> Bytes
encodeToUTF8 :: JsonValue -> Bytes
encodeToUTF8 = ByteString -> Bytes
forall α. Binary α => α -> Bytes
intoBytes (ByteString -> Bytes)
-> (JsonValue -> ByteString) -> JsonValue -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString)
-> (JsonValue -> Value) -> JsonValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonValue -> Value
intoAeson

-- |
-- Given an array of bytes, attempt to decode it as a JSON value.
decodeFromUTF8 :: Bytes -> Maybe JsonValue
decodeFromUTF8 :: Bytes -> Maybe JsonValue
decodeFromUTF8 Bytes
b =
  let x :: Maybe Aeson.Value
      x :: Maybe Value
x = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict' (Bytes -> ByteString
forall α. Binary α => Bytes -> α
fromBytes Bytes
b)
   in (Value -> JsonValue) -> Maybe Value -> Maybe JsonValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> JsonValue
fromAeson Maybe Value
x

-- |
-- A JSON value.
data JsonValue
  = JsonObject (Map JsonKey JsonValue)
  | JsonArray [JsonValue]
  | JsonString Rope
  | JsonNumber Scientific
  | JsonBool Bool
  | JsonNull
  deriving (JsonValue -> JsonValue -> Bool
(JsonValue -> JsonValue -> Bool)
-> (JsonValue -> JsonValue -> Bool) -> Eq JsonValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonValue -> JsonValue -> Bool
$c/= :: JsonValue -> JsonValue -> Bool
== :: JsonValue -> JsonValue -> Bool
$c== :: JsonValue -> JsonValue -> Bool
Eq, Int -> JsonValue -> ShowS
[JsonValue] -> ShowS
JsonValue -> String
(Int -> JsonValue -> ShowS)
-> (JsonValue -> String)
-> ([JsonValue] -> ShowS)
-> Show JsonValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonValue] -> ShowS
$cshowList :: [JsonValue] -> ShowS
show :: JsonValue -> String
$cshow :: JsonValue -> String
showsPrec :: Int -> JsonValue -> ShowS
$cshowsPrec :: Int -> JsonValue -> ShowS
Show, (forall x. JsonValue -> Rep JsonValue x)
-> (forall x. Rep JsonValue x -> JsonValue) -> Generic JsonValue
forall x. Rep JsonValue x -> JsonValue
forall x. JsonValue -> Rep JsonValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JsonValue x -> JsonValue
$cfrom :: forall x. JsonValue -> Rep JsonValue x
Generic)

--
-- Overloads so that Haskell code literals can be interpreted as JSON
-- values. Obviously these are a lot on the partial side, but what else are
-- you supposed to do? This is all Haskell gives us for getting at
-- literals.
--
instance IsString JsonValue where
  fromString :: String -> JsonValue
  fromString :: String -> JsonValue
fromString = Rope -> JsonValue
JsonString (Rope -> JsonValue) -> (String -> Rope) -> String -> JsonValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Rope
forall α. Textual α => α -> Rope
intoRope

instance Num JsonValue where
  fromInteger :: Integer -> JsonValue
fromInteger = Scientific -> JsonValue
JsonNumber (Scientific -> JsonValue)
-> (Integer -> Scientific) -> Integer -> JsonValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger
  + :: JsonValue -> JsonValue -> JsonValue
(+) = String -> JsonValue -> JsonValue -> JsonValue
forall a. HasCallStack => String -> a
error String
"Sorry, you can't add JsonValues"
  (-) = String -> JsonValue -> JsonValue -> JsonValue
forall a. HasCallStack => String -> a
error String
"Sorry, you can't negate JsonValues"
  * :: JsonValue -> JsonValue -> JsonValue
(*) = String -> JsonValue -> JsonValue -> JsonValue
forall a. HasCallStack => String -> a
error String
"Sorry, you can't multiply JsonValues"
  abs :: JsonValue -> JsonValue
abs = String -> JsonValue -> JsonValue
forall a. HasCallStack => String -> a
error String
"Sorry, not applicable for JsonValues"
  signum :: JsonValue -> JsonValue
signum = String -> JsonValue -> JsonValue
forall a. HasCallStack => String -> a
error String
"Sorry, not applicable for JsonValues"

instance Fractional JsonValue where
  fromRational :: Rational -> JsonValue
  fromRational :: Rational -> JsonValue
fromRational = Scientific -> JsonValue
JsonNumber (Scientific -> JsonValue)
-> (Rational -> Scientific) -> Rational -> JsonValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational
  / :: JsonValue -> JsonValue -> JsonValue
(/) = String -> JsonValue -> JsonValue -> JsonValue
forall a. HasCallStack => String -> a
error String
"Sorry, you can't do division on JsonValues"

intoAeson :: JsonValue -> Aeson.Value
intoAeson :: JsonValue -> Value
intoAeson JsonValue
value = case JsonValue
value of
  JsonObject Map JsonKey JsonValue
xm ->
    let kvs :: [(JsonKey, JsonValue)]
kvs = Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
-> [(JsonKey, JsonValue)]
forall α. Dictionary α => Map (K α) (V α) -> α
fromMap Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
Map JsonKey JsonValue
xm
        tvs :: [(Text, Value)]
tvs = ((JsonKey, JsonValue) -> (Text, Value))
-> [(JsonKey, JsonValue)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(JsonKey
k, JsonValue
v) -> (Rope -> Text
forall α. Textual α => Rope -> α
fromRope (JsonKey -> Rope
coerce JsonKey
k), JsonValue -> Value
intoAeson JsonValue
v)) [(JsonKey, JsonValue)]
kvs
        tvm :: HashMap T.Text Aeson.Value
        tvm :: HashMap Text Value
tvm = [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Text, Value)]
tvs
     in HashMap Text Value -> Value
Aeson.Object HashMap Text Value
tvm
  JsonArray [JsonValue]
xs ->
    let vs :: [Value]
vs = (JsonValue -> Value) -> [JsonValue] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonValue -> Value
intoAeson [JsonValue]
xs
     in Array -> Value
Aeson.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
vs)
  JsonString Rope
x -> Text -> Value
Aeson.String (Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
x)
  JsonNumber Scientific
x -> Scientific -> Value
Aeson.Number Scientific
x
  JsonBool Bool
x -> Bool -> Value
Aeson.Bool Bool
x
  JsonValue
JsonNull -> Value
Aeson.Null

-- |
--    Keys in a JSON object.
newtype JsonKey
  = JsonKey Rope
  deriving (JsonKey -> JsonKey -> Bool
(JsonKey -> JsonKey -> Bool)
-> (JsonKey -> JsonKey -> Bool) -> Eq JsonKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonKey -> JsonKey -> Bool
$c/= :: JsonKey -> JsonKey -> Bool
== :: JsonKey -> JsonKey -> Bool
$c== :: JsonKey -> JsonKey -> Bool
Eq, Int -> JsonKey -> ShowS
[JsonKey] -> ShowS
JsonKey -> String
(Int -> JsonKey -> ShowS)
-> (JsonKey -> String) -> ([JsonKey] -> ShowS) -> Show JsonKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonKey] -> ShowS
$cshowList :: [JsonKey] -> ShowS
show :: JsonKey -> String
$cshow :: JsonKey -> String
showsPrec :: Int -> JsonKey -> ShowS
$cshowsPrec :: Int -> JsonKey -> ShowS
Show, (forall x. JsonKey -> Rep JsonKey x)
-> (forall x. Rep JsonKey x -> JsonKey) -> Generic JsonKey
forall x. Rep JsonKey x -> JsonKey
forall x. JsonKey -> Rep JsonKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JsonKey x -> JsonKey
$cfrom :: forall x. JsonKey -> Rep JsonKey x
Generic, String -> JsonKey
(String -> JsonKey) -> IsString JsonKey
forall a. (String -> a) -> IsString a
fromString :: String -> JsonKey
$cfromString :: String -> JsonKey
IsString, Eq JsonKey
Eq JsonKey
-> (JsonKey -> JsonKey -> Ordering)
-> (JsonKey -> JsonKey -> Bool)
-> (JsonKey -> JsonKey -> Bool)
-> (JsonKey -> JsonKey -> Bool)
-> (JsonKey -> JsonKey -> Bool)
-> (JsonKey -> JsonKey -> JsonKey)
-> (JsonKey -> JsonKey -> JsonKey)
-> Ord JsonKey
JsonKey -> JsonKey -> Bool
JsonKey -> JsonKey -> Ordering
JsonKey -> JsonKey -> JsonKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: JsonKey -> JsonKey -> JsonKey
$cmin :: JsonKey -> JsonKey -> JsonKey
max :: JsonKey -> JsonKey -> JsonKey
$cmax :: JsonKey -> JsonKey -> JsonKey
>= :: JsonKey -> JsonKey -> Bool
$c>= :: JsonKey -> JsonKey -> Bool
> :: JsonKey -> JsonKey -> Bool
$c> :: JsonKey -> JsonKey -> Bool
<= :: JsonKey -> JsonKey -> Bool
$c<= :: JsonKey -> JsonKey -> Bool
< :: JsonKey -> JsonKey -> Bool
$c< :: JsonKey -> JsonKey -> Bool
compare :: JsonKey -> JsonKey -> Ordering
$ccompare :: JsonKey -> JsonKey -> Ordering
$cp1Ord :: Eq JsonKey
Ord)

instance Hashable JsonKey

instance Key JsonKey

-- FIXME what is this instance?
instance Aeson.ToJSON Rope where
  toJSON :: Rope -> Value
toJSON Rope
text = Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
text :: T.Text) -- BAD

instance Textual JsonKey where
  fromRope :: Rope -> JsonKey
fromRope Rope
t = Rope -> JsonKey
coerce Rope
t
  intoRope :: JsonKey -> Rope
intoRope JsonKey
x = JsonKey -> Rope
coerce JsonKey
x

fromAeson :: Aeson.Value -> JsonValue
fromAeson :: Value -> JsonValue
fromAeson Value
value = case Value
value of
  Aeson.Object HashMap Text Value
o ->
    let tvs :: [(Text, Value)]
tvs = HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text Value
o
        kvs :: [(JsonKey, JsonValue)]
kvs = ((Text, Value) -> (JsonKey, JsonValue))
-> [(Text, Value)] -> [(JsonKey, JsonValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
k, Value
v) -> (Rope -> JsonKey
JsonKey (Text -> Rope
forall α. Textual α => α -> Rope
intoRope Text
k), Value -> JsonValue
fromAeson Value
v)) [(Text, Value)]
tvs

        kvm :: Map JsonKey JsonValue
        kvm :: Map JsonKey JsonValue
kvm = [(JsonKey, JsonValue)]
-> Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
forall α. Dictionary α => α -> Map (K α) (V α)
intoMap [(JsonKey, JsonValue)]
kvs
     in Map JsonKey JsonValue -> JsonValue
JsonObject Map JsonKey JsonValue
kvm
  Aeson.Array Array
v -> [JsonValue] -> JsonValue
JsonArray ((Value -> JsonValue) -> [Value] -> [JsonValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> JsonValue
fromAeson (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
v))
  Aeson.String Text
t -> Rope -> JsonValue
JsonString (Text -> Rope
forall α. Textual α => α -> Rope
intoRope Text
t)
  Aeson.Number Scientific
n -> Scientific -> JsonValue
JsonNumber Scientific
n
  Aeson.Bool Bool
x -> Bool -> JsonValue
JsonBool Bool
x
  Value
Aeson.Null -> JsonValue
JsonNull

--
-- Pretty printing
--

data JsonToken
  = SymbolToken
  | QuoteToken
  | KeyToken
  | StringToken
  | EscapeToken
  | NumberToken
  | BooleanToken
  | LiteralToken

instance Render JsonValue where
  type Token JsonValue = JsonToken
  colourize :: Token JsonValue -> AnsiColour
colourize = Token JsonValue -> AnsiColour
JsonToken -> AnsiColour
colourizeJson
  highlight :: JsonValue -> Doc (Token JsonValue)
highlight = JsonValue -> Doc (Token JsonValue)
JsonValue -> Doc JsonToken
prettyValue

instance Render JsonKey where
  type Token JsonKey = JsonToken
  colourize :: Token JsonKey -> AnsiColour
colourize = Token JsonKey -> AnsiColour
JsonToken -> AnsiColour
colourizeJson
  highlight :: JsonKey -> Doc (Token JsonKey)
highlight = JsonKey -> Doc (Token JsonKey)
JsonKey -> Doc JsonToken
prettyKey

instance Render Aeson.Value where
  type Token Aeson.Value = JsonToken
  colourize :: Token Value -> AnsiColour
colourize = Token Value -> AnsiColour
JsonToken -> AnsiColour
colourizeJson
  highlight :: Value -> Doc (Token Value)
highlight = JsonValue -> Doc JsonToken
prettyValue (JsonValue -> Doc JsonToken)
-> (Value -> JsonValue) -> Value -> Doc JsonToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> JsonValue
fromAeson

--
--  Ugh. If you want to experiment with narrower output, then:
--
--            . layoutPretty (LayoutOptions {layoutPageWidth = AvailablePerLine 15 1.0}) . prettyValue
--

-- |
-- Used by the 'Render' instance to turn symbolic annotations into ANSI colours annotations.
-- If you're curious, the render pipeline looks like:
--
-- @
--     render = 'intoText' . 'renderStrict' . 'reAnnotateS' 'colourize'
--                 . 'layoutPretty' 'defaultLayoutOptions' . 'prettyValue'
-- @
colourizeJson :: JsonToken -> AnsiColour
colourizeJson :: JsonToken -> AnsiColour
colourizeJson JsonToken
token = case JsonToken
token of
  JsonToken
SymbolToken -> AnsiColour
brightGrey
  JsonToken
QuoteToken -> AnsiColour
brightGrey
  JsonToken
KeyToken -> AnsiColour
brightBlue
  JsonToken
StringToken -> AnsiColour
dullCyan
  JsonToken
EscapeToken -> AnsiColour
dullYellow
  JsonToken
NumberToken -> AnsiColour
dullGreen
  JsonToken
BooleanToken -> AnsiColour
brightMagenta
  JsonToken
LiteralToken -> AnsiColour
dullBlue

instance Pretty JsonKey where
  pretty :: JsonKey -> Doc ann
pretty = Doc JsonToken -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc JsonToken -> Doc ann)
-> (JsonKey -> Doc JsonToken) -> JsonKey -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonKey -> Doc JsonToken
prettyKey

prettyKey :: JsonKey -> Doc JsonToken
prettyKey :: JsonKey -> Doc JsonToken
prettyKey (JsonKey Rope
t) =
  JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken Doc JsonToken
forall ann. Doc ann
dquote
    Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
KeyToken (Text -> Doc JsonToken
forall a ann. Pretty a => a -> Doc ann
pretty (Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
t :: T.Text))
    Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken Doc JsonToken
forall ann. Doc ann
dquote

instance Pretty JsonValue where
  pretty :: JsonValue -> Doc ann
pretty = Doc JsonToken -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc JsonToken -> Doc ann)
-> (JsonValue -> Doc JsonToken) -> JsonValue -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonValue -> Doc JsonToken
prettyValue

prettyValue :: JsonValue -> Doc JsonToken
prettyValue :: JsonValue -> Doc JsonToken
prettyValue JsonValue
value = case JsonValue
value of
  JsonObject Map JsonKey JsonValue
xm ->
    let pairs :: [(JsonKey, JsonValue)]
pairs = Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
-> [(JsonKey, JsonValue)]
forall α. Dictionary α => Map (K α) (V α) -> α
fromMap Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
Map JsonKey JsonValue
xm
        entries :: [Doc JsonToken]
entries = ((JsonKey, JsonValue) -> Doc JsonToken)
-> [(JsonKey, JsonValue)] -> [Doc JsonToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(JsonKey
k, JsonValue
v) -> (JsonKey -> Doc JsonToken
prettyKey JsonKey
k) Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
":" Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> JsonValue -> Doc JsonToken -> Doc JsonToken
forall ann. JsonValue -> Doc ann -> Doc ann
clear JsonValue
v (JsonValue -> Doc JsonToken
prettyValue JsonValue
v)) [(JsonKey, JsonValue)]
pairs

        clear :: JsonValue -> Doc ann -> Doc ann
clear JsonValue
v Doc ann
doc = case JsonValue
v of
          (JsonObject Map JsonKey JsonValue
_) -> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
doc
          (JsonArray [JsonValue]
_) -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group Doc ann
doc
          JsonValue
_ -> Doc ann
doc
     in if [Doc JsonToken] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc JsonToken]
entries Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          then JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken (Doc JsonToken
forall ann. Doc ann
lbrace Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Doc JsonToken
forall ann. Doc ann
rbrace)
          else JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
forall ann. Doc ann
lbrace Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Doc JsonToken
forall ann. Doc ann
line Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Int -> Doc JsonToken -> Doc JsonToken
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 ([Doc JsonToken] -> Doc JsonToken
forall ann. [Doc ann] -> Doc ann
vsep (Doc JsonToken -> [Doc JsonToken] -> [Doc JsonToken]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
forall ann. Doc ann
comma) [Doc JsonToken]
entries)) Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Doc JsonToken
forall ann. Doc ann
line Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
forall ann. Doc ann
rbrace
  JsonArray [JsonValue]
xs ->
    let entries :: [Doc JsonToken]
entries = (JsonValue -> Doc JsonToken) -> [JsonValue] -> [Doc JsonToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonValue -> Doc JsonToken
prettyValue [JsonValue]
xs
     in Doc JsonToken
forall ann. Doc ann
line'
          Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Int -> Doc JsonToken -> Doc JsonToken
forall ann. Int -> Doc ann -> Doc ann
nest
            Int
4
            ( JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
forall ann. Doc ann
lbracket
                Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Doc JsonToken
forall ann. Doc ann
line' -- first line not indented
                Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> [Doc JsonToken] -> Doc JsonToken
forall ann. [Doc ann] -> Doc ann
sep (Doc JsonToken -> [Doc JsonToken] -> [Doc JsonToken]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
forall ann. Doc ann
comma) [Doc JsonToken]
entries)
            )
          Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> Doc JsonToken
forall ann. Doc ann
line'
          Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
forall ann. Doc ann
rbracket
  JsonString Rope
x ->
    JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken Doc JsonToken
forall ann. Doc ann
dquote
      Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
StringToken (Rope -> Doc JsonToken
escapeText Rope
x)
      Doc JsonToken -> Doc JsonToken -> Doc JsonToken
forall a. Semigroup a => a -> a -> a
<> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken Doc JsonToken
forall ann. Doc ann
dquote
  JsonNumber Scientific
x -> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
NumberToken (Scientific -> Doc JsonToken
forall a ann. Show a => a -> Doc ann
viaShow Scientific
x)
  JsonBool Bool
x -> case Bool
x of
    Bool
True -> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
BooleanToken Doc JsonToken
"true"
    Bool
False -> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
BooleanToken Doc JsonToken
"false"
  JsonValue
JsonNull -> JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
LiteralToken Doc JsonToken
"null"
{-# INLINEABLE prettyValue #-}

escapeText :: Rope -> Doc JsonToken
escapeText :: Rope -> Doc JsonToken
escapeText Rope
text =
  let t :: Text
t = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
text :: T.Text
      ts :: [Text]
ts = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"') Text
t
      ds :: [Doc JsonToken]
ds = (Text -> Doc JsonToken) -> [Text] -> [Doc JsonToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc JsonToken
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
ts
   in [Doc JsonToken] -> Doc JsonToken
forall ann. [Doc ann] -> Doc ann
hcat (Doc JsonToken -> [Doc JsonToken] -> [Doc JsonToken]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (JsonToken -> Doc JsonToken -> Doc JsonToken
forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
EscapeToken Doc JsonToken
"\\\"") [Doc JsonToken]
ds)
{-# INLINEABLE escapeText #-}