{-# 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 = Rope -> Bytes
forall α. Binary α => α -> Bytes
intoBytes (Rope -> Bytes) -> (JsonValue -> Rope) -> JsonValue -> Bytes
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 = 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
            members :: [Rope]
members = ((JsonKey, JsonValue) -> Rope) -> [(JsonKey, JsonValue)] -> [Rope]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((JsonKey Rope
k), JsonValue
v) -> Rope
doublequote Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope -> Rope
escapeString Rope
k Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
doublequote Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
colonspace Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> JsonValue -> Rope
encodeToRope JsonValue
v) [(JsonKey, JsonValue)]
kvs
         in Rope
openbrace Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat (Rope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
List.intersperse Rope
commaspace [Rope]
members) Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
closebrace
    JsonArray [JsonValue]
xs ->
        Rope
openbracket Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat (Rope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
List.intersperse Rope
commaspace ((JsonValue -> Rope) -> [JsonValue] -> [Rope]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonValue -> Rope
encodeToRope [JsonValue]
xs)) Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
closebracket
    JsonString Rope
x ->
        Rope
doublequote Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope -> Rope
escapeString Rope
x Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
doublequote
    JsonNumber Scientific
x -> case Scientific -> Bool
isFloating Scientific
x of
        Bool
True -> String -> Rope
forall α. Textual α => α -> Rope
intoRope (FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Generic Maybe Int
forall a. Maybe a
Nothing Scientific
x)
        Bool
False -> String -> Rope
forall α. Textual α => α -> Rope
intoRope (FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (Int -> Maybe Int
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 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Char -> Rope
escapeCharacter Char
c Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope -> Rope
escapeString Rope
after'
  where
    needsEscaping :: Char -> Bool
needsEscaping Char
c =
        Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
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 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x10'
                then Rope
"\\u000" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope (Int -> Char
intToDigit (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c))
                else Rope
"\\u001" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope (Int -> Char
intToDigit ((Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) Int -> Int -> Int
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 = 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

{- |
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 = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict' (Rope -> ByteString
forall α. Textual α => Rope -> α
fromRope Rope
text)
     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"

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

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
#if MIN_VERSION_aeson(2,0,1)
    Aeson.Object Object
o ->
        let tvs :: [(Key, Value)]
tvs = Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Aeson.toList Object
o
            kvs :: [(JsonKey, JsonValue)]
kvs =
                ((Key, Value) -> (JsonKey, JsonValue))
-> [(Key, Value)] -> [(JsonKey, JsonValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                    ( \(Key
k, Value
v) ->
                        ( Rope -> JsonKey
JsonKey
                            (Text -> Rope
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 = [(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
#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 ((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
--

{- |
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 = 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

--
--  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 :: 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 #-}

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