{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Core.Encoding.Json (
encodeToUTF8,
encodeToRope,
decodeFromUTF8,
decodeFromRope,
JsonValue (..),
JsonKey (..),
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,
(<+>),
)
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
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
']'
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 #-}
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
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
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)
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"
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
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
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'
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 #-}
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"