{-# LANGUAGE CPP #-}
{-# 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
    , encodeToRope
    , decodeFromUTF8
    , decodeFromRope
    , JsonValue (..)
    , JsonKey (..)

      -- * Syntax highlighting
    , JsonToken (..)
    , colourizeJson
    , prettyKey
    , prettyValue
    ) where

#if MIN_VERSION_aeson(2,0,1)
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as Aeson
#else
import qualified Data.HashMap.Strict as HashMap
#endif

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

{- |
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 = forall α. Binary α => α -> Bytes
intoBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonValue -> Rope
encodeToRope

{- |
Given a JSON value, encode it to a Rope (which, by definition, is UTF-8
internally).
-}
encodeToRope :: JsonValue -> Rope
encodeToRope :: JsonValue -> Rope
encodeToRope JsonValue
value = case JsonValue
value of
    JsonObject Map JsonKey JsonValue
xm ->
        let kvs :: [(JsonKey, JsonValue)]
kvs = forall α. Dictionary α => Map (K α) (V α) -> α
fromMap Map JsonKey JsonValue
xm
            members :: [Rope]
members = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((JsonKey Rope
k), JsonValue
v) -> Rope
doublequote forall a. Semigroup a => a -> a -> a
<> Rope -> Rope
escapeString Rope
k forall a. Semigroup a => a -> a -> a
<> Rope
doublequote forall a. Semigroup a => a -> a -> a
<> Rope
colonspace forall a. Semigroup a => a -> a -> a
<> JsonValue -> Rope
encodeToRope JsonValue
v) [(JsonKey, JsonValue)]
kvs
        in  Rope
openbrace forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
List.intersperse Rope
commaspace [Rope]
members) forall a. Semigroup a => a -> a -> a
<> Rope
closebrace
    JsonArray [JsonValue]
xs ->
        Rope
openbracket forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
List.intersperse Rope
commaspace (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonValue -> Rope
encodeToRope [JsonValue]
xs)) forall a. Semigroup a => a -> a -> a
<> Rope
closebracket
    JsonString Rope
x ->
        Rope
doublequote forall a. Semigroup a => a -> a -> a
<> Rope -> Rope
escapeString Rope
x forall a. Semigroup a => a -> a -> a
<> Rope
doublequote
    JsonNumber Scientific
x -> case Scientific -> Bool
isFloating Scientific
x of
        Bool
True -> forall α. Textual α => α -> Rope
intoRope (FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Generic forall a. Maybe a
Nothing Scientific
x)
        Bool
False -> forall α. Textual α => α -> Rope
intoRope (FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (forall a. a -> Maybe a
Just Int
0) Scientific
x)
    JsonBool Bool
x -> case Bool
x of
        Bool
True -> Rope
"true"
        Bool
False -> Rope
"false"
    JsonValue
JsonNull -> Rope
"null"
  where
    commaspace :: Rope
commaspace = Char -> Rope
singletonRope Char
','
    colonspace :: Rope
colonspace = Char -> Rope
singletonRope Char
':'
    doublequote :: Rope
doublequote = Char -> Rope
singletonRope Char
'"'
    openbrace :: Rope
openbrace = Char -> Rope
singletonRope Char
'{'
    closebrace :: Rope
closebrace = Char -> Rope
singletonRope Char
'}'
    openbracket :: Rope
openbracket = Char -> Rope
singletonRope Char
'['
    closebracket :: Rope
closebracket = Char -> Rope
singletonRope Char
']'

{- |
Escape any quotes, backslashes, or other possible rubbish in a 'JsonString'.
-}
escapeString :: Rope -> Rope
escapeString :: Rope -> Rope
escapeString Rope
text =
    let (Rope
before, Rope
after) = (Char -> Bool) -> Rope -> (Rope, Rope)
breakRope Char -> Bool
needsEscaping Rope
text
    in  case Rope -> Maybe (Char, Rope)
unconsRope Rope
after of
            Maybe (Char, Rope)
Nothing ->
                Rope
text
            Just (Char
c, Rope
after') ->
                Rope
before forall a. Semigroup a => a -> a -> a
<> Char -> Rope
escapeCharacter Char
c forall a. Semigroup a => a -> a -> a
<> Rope -> Rope
escapeString Rope
after'
  where
    needsEscaping :: Char -> Bool
needsEscaping Char
c =
        Char
c forall a. Eq a => a -> a -> Bool
== Char
'\"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c forall a. Ord a => a -> a -> Bool
< Char
'\x20'
{-# INLINEABLE escapeString #-}

escapeCharacter :: Char -> Rope
escapeCharacter :: Char -> Rope
escapeCharacter Char
c =
    case Char
c of
        Char
'\"' -> Rope
"\\\""
        Char
'\\' -> Rope
"\\\\"
        Char
'\n' -> Rope
"\\n"
        Char
'\r' -> Rope
"\\r"
        Char
'\t' -> Rope
"\\t"
        Char
_ ->
            if Char
c forall a. Ord a => a -> a -> Bool
< Char
'\x10'
                then Rope
"\\u000" forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope (Int -> Char
intToDigit (forall a. Enum a => a -> Int
fromEnum Char
c))
                else Rope
"\\u001" forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope (Int -> Char
intToDigit ((forall a. Enum a => a -> Int
fromEnum Char
c) forall a. Num a => a -> a -> a
- Int
16))
{-# INLINEABLE escapeCharacter #-}

{- |
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 = forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict' (forall α. Binary α => Bytes -> α
fromBytes Bytes
b)
    in  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> JsonValue
fromAeson Maybe Value
x

{- |
Given an string that is full of a bunch of JSON, attempt to decode
it.
-}
decodeFromRope :: Rope -> Maybe JsonValue
decodeFromRope :: Rope -> Maybe JsonValue
decodeFromRope Rope
text =
    let x :: Maybe Aeson.Value
        x :: Maybe Value
x = forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict' (forall α. Textual α => Rope -> α
fromRope Rope
text)
    in  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
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
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. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. Textual α => α -> Rope
intoRope

instance Num JsonValue where
    fromInteger :: Integer -> JsonValue
fromInteger = Scientific -> JsonValue
JsonNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
    + :: JsonValue -> JsonValue -> JsonValue
(+) = forall a. HasCallStack => String -> a
error String
"Sorry, you can't add JsonValues"
    (-) = forall a. HasCallStack => String -> a
error String
"Sorry, you can't negate JsonValues"
    * :: JsonValue -> JsonValue -> JsonValue
(*) = forall a. HasCallStack => String -> a
error String
"Sorry, you can't multiply JsonValues"
    abs :: JsonValue -> JsonValue
abs = forall a. HasCallStack => String -> a
error String
"Sorry, not applicable for JsonValues"
    signum :: JsonValue -> JsonValue
signum = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational
    / :: JsonValue -> JsonValue -> JsonValue
(/) = forall a. HasCallStack => String -> a
error String
"Sorry, you can't do division on JsonValues"

{- |
Keys in a JSON object.
-}
newtype JsonKey
    = JsonKey Rope
    deriving (JsonKey -> JsonKey -> Bool
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
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. 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
forall a. (String -> a) -> IsString a
fromString :: String -> JsonKey
$cfromString :: String -> JsonKey
IsString, Eq 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
Ord)

instance Hashable JsonKey

instance Key JsonKey

instance Textual JsonKey where
    fromRope :: Rope -> JsonKey
fromRope Rope
t = coerce :: forall a b. Coercible a b => a -> b
coerce Rope
t
    intoRope :: JsonKey -> Rope
intoRope JsonKey
x = coerce :: forall a b. Coercible a b => a -> b
coerce JsonKey
x

{- FOURMOLU_DISABLE -}
fromAeson :: Aeson.Value -> JsonValue
fromAeson :: Value -> JsonValue
fromAeson Value
value = case Value
value of
#if MIN_VERSION_aeson(2,0,1)
    Aeson.Object Object
o ->
        let tvs :: [(Key, Value)]
tvs = forall v. KeyMap v -> [(Key, v)]
Aeson.toList Object
o
            kvs :: [(JsonKey, JsonValue)]
kvs =
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                    ( \(Key
k, Value
v) ->
                        ( Rope -> JsonKey
JsonKey
                            (forall α. Textual α => α -> Rope
intoRope (Key -> Text
Aeson.toText Key
k))
                        , Value -> JsonValue
fromAeson Value
v
                        )
                    )
                    [(Key, Value)]
tvs
            kvm :: Map JsonKey JsonValue
            kvm :: Map JsonKey JsonValue
kvm = forall α. Dictionary α => α -> Map (K α) (V α)
intoMap [(JsonKey, JsonValue)]
kvs
         in Map JsonKey JsonValue -> JsonValue
JsonObject Map JsonKey JsonValue
kvm
#else
    Aeson.Object o ->
        let tvs = HashMap.toList o
            kvs =
                fmap ( \(k, v) ->
                        ( JsonKey
                            (intoRope k)
                        , fromAeson v
                        )
                    )
                    tvs
            kvm :: Map JsonKey JsonValue
            kvm = intoMap kvs
         in JsonObject kvm
#endif
    Aeson.Array Array
v -> [JsonValue] -> JsonValue
JsonArray (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> JsonValue
fromAeson (forall a. Vector a -> [a]
V.toList Array
v))
    Aeson.String Text
t -> Rope -> JsonValue
JsonString (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
{- FOURMOLU_ENABLE -}

--
-- Pretty printing
--

{- |
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 (00.007) j =
{
    "answer": 42
}
@
-}
data JsonToken
    = SymbolToken
    | QuoteToken
    | KeyToken
    | StringToken
    | EscapeToken
    | NumberToken
    | BooleanToken
    | LiteralToken

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

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

--
--  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
pureGrey
    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 :: forall ann. JsonKey -> Doc ann
pretty = forall ann xxx. Doc ann -> Doc xxx
unAnnotate 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) =
    forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken forall ann. Doc ann
dquote
        forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
KeyToken (forall a ann. Pretty a => a -> Doc ann
pretty (forall α. Textual α => Rope -> α
fromRope Rope
t :: T.Text))
        forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken forall ann. Doc ann
dquote

instance Pretty JsonValue where
    pretty :: forall ann. JsonValue -> Doc ann
pretty = forall ann xxx. Doc ann -> Doc xxx
unAnnotate 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 = forall α. Dictionary α => Map (K α) (V α) -> α
fromMap Map JsonKey JsonValue
xm
            entries :: [Doc JsonToken]
entries = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(JsonKey
k, JsonValue
v) -> (JsonKey -> Doc JsonToken
prettyKey JsonKey
k) forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken Doc JsonToken
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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
_) -> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> Doc ann
doc
                (JsonArray [JsonValue]
_) -> forall ann. Doc ann -> Doc ann
group Doc ann
doc
                JsonValue
_ -> Doc ann
doc
        in  if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc JsonToken]
entries forall a. Eq a => a -> a -> Bool
== Int
0
                then forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken (forall ann. Doc ann
lbrace forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
rbrace)
                else forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken forall ann. Doc ann
lbrace forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (forall ann. [Doc ann] -> Doc ann
vsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken forall ann. Doc ann
comma) [Doc JsonToken]
entries)) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken forall ann. Doc ann
rbrace
    JsonArray [JsonValue]
xs ->
        let entries :: [Doc JsonToken]
entries = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonValue -> Doc JsonToken
prettyValue [JsonValue]
xs
        in  forall ann. Doc ann
line'
                forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
nest
                    Int
4
                    ( forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken forall ann. Doc ann
lbracket
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line' -- first line not indented
                        forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
sep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken forall ann. Doc ann
comma) [Doc JsonToken]
entries)
                    )
                forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line'
                forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
SymbolToken forall ann. Doc ann
rbracket
    JsonString Rope
x ->
        forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken forall ann. Doc ann
dquote
            forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
StringToken (Rope -> Doc JsonToken
escapeText Rope
x)
            forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
QuoteToken forall ann. Doc ann
dquote
    JsonNumber Scientific
x -> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
NumberToken (forall a ann. Show a => a -> Doc ann
viaShow Scientific
x)
    JsonBool Bool
x -> case Bool
x of
        Bool
True -> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
BooleanToken Doc JsonToken
"true"
        Bool
False -> forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
BooleanToken Doc JsonToken
"false"
    JsonValue
JsonNull -> 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 = forall α. Textual α => Rope -> α
fromRope Rope
text :: T.Text
        ts :: [Text]
ts = (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
'"') Text
t
        ds :: [Doc JsonToken]
ds = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a ann. Pretty a => a -> Doc ann
pretty [Text]
ts
    in  forall ann. [Doc ann] -> Doc ann
hcat (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (forall ann. ann -> Doc ann -> Doc ann
annotate JsonToken
EscapeToken Doc JsonToken
"\\\"") [Doc JsonToken]
ds)
{-# INLINEABLE escapeText #-}

--
-- Orphan instance; ideally we wouldn't need this anywhere but people are
-- asking for it and the relevant symbols are imported here.
--

instance FromJSON Rope where
    parseJSON :: Value -> Parser Rope
parseJSON (String Text
text) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall α. Textual α => α -> Rope
intoRope Text
text)
    parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't parse this non-textual field as a Rope"