{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuasiQuotes #-}

module Json.Enc where

import Data.Aeson (Encoding, Value (..))
import Data.Aeson qualified as Json
import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty
import Data.Aeson.Encoding qualified as AesonEnc
import Data.Aeson.Encoding qualified as Json.Enc
import Data.Aeson.Encoding qualified as Json.Encoding
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap (KeyMap)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Base64 qualified as Base64
import Data.ByteString.Lazy qualified as LazyBytes
import Data.Containers.ListUtils (nubOrdOn)
import Data.Int (Int64)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Scientific
import Data.String (IsString (fromString))
import Data.Text.Lazy qualified as Lazy
import Data.Text.Lazy.Builder qualified as Text.Builder
import Data.Time qualified as Time
import Data.Time.Format.ISO8601 qualified as ISO8601
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import PossehlAnalyticsPrelude

-- | A JSON encoder.
--
-- It is faster than going through 'Value', because 'Encoding' is just a wrapper around a @Bytes.Builder@.
-- But the @aeson@ interface for 'Encoding' is extremely bad, so let’s build a better one.
newtype Enc = Enc {Enc -> Encoding
unEnc :: Encoding}
  deriving (Integer -> Enc
Enc -> Enc
Enc -> Enc -> Enc
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Enc
$cfromInteger :: Integer -> Enc
signum :: Enc -> Enc
$csignum :: Enc -> Enc
abs :: Enc -> Enc
$cabs :: Enc -> Enc
negate :: Enc -> Enc
$cnegate :: Enc -> Enc
* :: Enc -> Enc -> Enc
$c* :: Enc -> Enc -> Enc
- :: Enc -> Enc -> Enc
$c- :: Enc -> Enc -> Enc
+ :: Enc -> Enc -> Enc
$c+ :: Enc -> Enc -> Enc
Num, Num Enc
Rational -> Enc
Enc -> Enc
Enc -> Enc -> Enc
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Enc
$cfromRational :: Rational -> Enc
recip :: Enc -> Enc
$crecip :: Enc -> Enc
/ :: Enc -> Enc -> Enc
$c/ :: Enc -> Enc -> Enc
Fractional) via (NumLiteralOnly "Enc" Enc)

instance Show Enc where
  show :: Enc -> String
show Enc
e = Enc
e.unEnc forall a b. a -> (a -> b) -> b
& forall a. Encoding' a -> ByteString
Json.Encoding.encodingToLazyByteString forall a b. a -> (a -> b) -> b
& ByteString -> Text
bytesToTextUtf8UnsafeLazy forall a b. a -> (a -> b) -> b
& forall a. Show a => a -> String
show

-- | You can create an @Enc any@ that renders a json string value with @OverloadedStrings@.
instance IsString Enc where
  fromString :: String -> Enc
fromString = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Encoding' a
AesonEnc.string

-- | You can create an @Enc any@ that renders a json number value with an integer literal.
instance IntegerLiteral Enc where
  integerLiteral :: Integer -> Enc
integerLiteral = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Encoding
AesonEnc.integer

-- | You can create an @Enc any@ that renders a json number value with an floating point literal.
--
-- __ATTN__: Bear in mind that this will crash on repeating rationals, so only use for literals in code!
instance RationalLiteral Enc where
  rationalLiteral :: Rational -> Enc
rationalLiteral Rational
r = Encoding -> Enc
Enc forall a b. (a -> b) -> a -> b
$ Scientific -> Encoding
AesonEnc.scientific (Rational
r forall a b. a -> (a -> b) -> b
& forall a. Fractional a => Rational -> a
fromRational @Scientific)

-- | Convert an 'Enc' to a strict UTF8-bytestring which is valid JSON (minified).
encToBytesUtf8 :: Enc -> ByteString
encToBytesUtf8 :: Enc -> ByteString
encToBytesUtf8 Enc
enc = Enc
enc forall a b. a -> (a -> b) -> b
& Enc -> ByteString
encToBytesUtf8Lazy forall a b. a -> (a -> b) -> b
& ByteString -> ByteString
toStrictBytes

-- | Convert an 'Enc' to a lazy UTF8-bytestring which is valid JSON (minified).
encToBytesUtf8Lazy :: Enc -> LazyBytes.ByteString
encToBytesUtf8Lazy :: Enc -> ByteString
encToBytesUtf8Lazy Enc
enc = Enc
enc.unEnc forall a b. a -> (a -> b) -> b
& forall a. Encoding' a -> ByteString
Json.Enc.encodingToLazyByteString

-- | Convert an 'Enc' to a strict Text which is valid JSON (prettyfied).
--
-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing.
encToTextPretty :: Enc -> Text
encToTextPretty :: Enc -> Text
encToTextPretty Enc
enc =
  Enc
enc
    forall a b. a -> (a -> b) -> b
& Enc -> Text
encToTextPrettyLazy
    forall a b. a -> (a -> b) -> b
& Text -> Text
toStrict

-- | Convert an 'Enc' to a lazy Text which is valid JSON (prettyfied).
--
-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing.
encToTextPrettyLazy :: Enc -> Lazy.Text
encToTextPrettyLazy :: Enc -> Text
encToTextPrettyLazy Enc
enc =
  Enc
enc
    forall a b. a -> (a -> b) -> b
& Enc -> ByteString
encToBytesUtf8Lazy
    forall a b. a -> (a -> b) -> b
& forall a. FromJSON a => ByteString -> Maybe a
Json.decode @Json.Value
    forall a b. a -> (a -> b) -> b
& forall err a. err -> Maybe a -> Either err a
annotate Error
"the json parser can’t parse json encodings??"
    forall a b. a -> (a -> b) -> b
& forall a. HasCallStack => Either Error a -> a
unwrapError
    forall a b. a -> (a -> b) -> b
& forall a. ToJSON a => a -> Builder
Aeson.Pretty.encodePrettyToTextBuilder
    forall a b. a -> (a -> b) -> b
& Builder -> Text
Text.Builder.toLazyText

-- | Embed a 'Json.Encoding' verbatim (it’s a valid JSON value)
encoding :: Encoding -> Enc
encoding :: Encoding -> Enc
encoding = Encoding -> Enc
Enc

-- | Encode a 'Json.Value' verbatim (it’s a valid JSON value)
value :: Value -> Enc
value :: Value -> Enc
value = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Encoding
AesonEnc.value

-- | Encode an empty json list
emptyArray :: Enc
emptyArray :: Enc
emptyArray = Encoding -> Enc
Enc Encoding
AesonEnc.emptyArray_

-- | Encode an empty json dict
emptyObject :: Enc
emptyObject :: Enc
emptyObject = Encoding -> Enc
Enc Encoding
AesonEnc.emptyObject_

-- | Encode a 'Text' as a json string
text :: Text -> Enc
text :: Text -> Enc
text = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Encoding' a
AesonEnc.text

-- | Encode a lazy 'Text' as a json string
lazyText :: Lazy.Text -> Enc
lazyText :: Text -> Enc
lazyText = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Encoding' a
AesonEnc.lazyText

-- | Encode a 'ByteString' as a base64-encoded json string
base64Bytes :: ByteString -> Enc
base64Bytes :: ByteString -> Enc
base64Bytes = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Encoding' a
AesonEnc.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
bytesToTextUtf8Unsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode

-- | Encode a 'Text' as a base64-encoded json string
base64 :: Text -> Enc
base64 :: Text -> Enc
base64 = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Encoding' a
AesonEnc.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
bytesToTextUtf8Unsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
textToBytesUtf8

-- | Encode a 'Prelude.String' as a json string
string :: String -> Enc
string :: String -> Enc
string = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Encoding' a
AesonEnc.string

-- | Encode as json @null@ if 'Nothing', else use the given encoder for @Just a@
nullOr :: (a -> Enc) -> Maybe a -> Enc
nullOr :: forall a. (a -> Enc) -> Maybe a -> Enc
nullOr a -> Enc
inner = \case
  Maybe a
Nothing -> Encoding -> Enc
Enc Encoding
AesonEnc.null_
  Just a
a -> a -> Enc
inner a
a

-- | Encode a list as a json list
list :: (a -> Enc) -> [a] -> Enc
list :: forall a. (a -> Enc) -> [a] -> Enc
list a -> Enc
f = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Encoding) -> [a] -> Encoding
AesonEnc.list (\a
a -> (a -> Enc
f a
a).unEnc)

-- | Encode a 'NonEmpty' as a json list.
nonEmpty :: (a -> Enc) -> NonEmpty a -> Enc
nonEmpty :: forall a. (a -> Enc) -> NonEmpty a -> Enc
nonEmpty a -> Enc
f = forall a. (a -> Enc) -> [a] -> Enc
list a -> Enc
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList

-- | Encode the given list of keys and their encoders as json dict.
--
-- If the list contains the same key multiple times, the first value in the list is retained:
--
-- @
-- (object [ ("foo", 42), ("foo", 23) ])
-- ~= "{\"foo\":42}"
-- @
object :: Foldable t => t (Text, Enc) -> Enc
object :: forall (t :: Type -> Type). Foldable t => t (Text, Enc) -> Enc
object t (Text, Enc)
m =
  Encoding -> Enc
Enc forall a b. (a -> b) -> a -> b
$
    forall k v m.
(k -> Encoding' Key)
-> (v -> Encoding)
-> (forall a. (k -> v -> a -> a) -> a -> m -> a)
-> m
-> Encoding
AesonEnc.dict
      forall a. Text -> Encoding' a
AesonEnc.text
      (\Enc
recEnc -> Enc
recEnc.unEnc)
      (\Text -> Enc -> a -> a
f -> forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr (\(Text
k, Enc
v) -> Text -> Enc -> a -> a
f Text
k Enc
v))
      (forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList t (Text, Enc)
m)

-- | A tag/value encoder; See 'choice'
data Choice = Choice Text Enc

-- | Encode a sum type as a @Choice@, an object with a @tag@/@value@ pair,
-- which is the conventional json sum type representation in our codebase.
--
-- @
-- foo :: Maybe Text -> Enc
-- foo = choice $ \case
--   Nothing -> Choice "no" emptyObject ()
--   Just t -> Choice "yes" text t
--
-- ex = foo Nothing == "{\"tag\": \"no\", \"value\": {}}"
-- ex2 = foo (Just "hi") == "{\"tag\": \"yes\", \"value\": \"hi\"}"
-- @
choice :: (from -> Choice) -> from -> Enc
choice :: forall from. (from -> Choice) -> from -> Enc
choice from -> Choice
f from
from = case from -> Choice
f from
from of
  Choice Text
key Enc
encA -> Text -> Enc -> Enc
singleChoice Text
key Enc
encA

-- | Like 'choice', but simply encode a single possibility into a @tag/value@ object.
-- This can be useful, but if you want to match on an enum, use 'choice' instead.
singleChoice :: Text -> Enc -> Enc
singleChoice :: Text -> Enc -> Enc
singleChoice Text
key Enc
encA =
  Encoding -> Enc
Enc forall a b. (a -> b) -> a -> b
$
    Series -> Encoding
AesonEnc.pairs forall a b. (a -> b) -> a -> b
$
      forall a. Monoid a => [a] -> a
mconcat
        [ Key -> Encoding -> Series
AesonEnc.pair Key
"tag" (forall a. Text -> Encoding' a
AesonEnc.text Text
key),
          Key -> Encoding -> Series
AesonEnc.pair Key
"value" Enc
encA.unEnc
        ]

-- | Encode a 'Map' as a json dict
--
-- We can’t really set the key to anything but text (We don’t keep the tag of 'Encoding')
-- so instead we allow anything that’s coercible from text as map key (i.e. newtypes).
map :: forall k v. (Coercible k Text) => (v -> Enc) -> Map k v -> Enc
map :: forall k v. Coercible k Text => (v -> Enc) -> Map k v -> Enc
map v -> Enc
valEnc Map k v
m =
  Encoding -> Enc
Enc forall a b. (a -> b) -> a -> b
$
    forall k v m.
(k -> Encoding' Key)
-> (v -> Encoding)
-> (forall a. (k -> v -> a -> a) -> a -> m -> a)
-> m
-> Encoding
AesonEnc.dict
      (forall a. Text -> Encoding' a
AesonEnc.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce @k @Text)
      (\v
v -> (v -> Enc
valEnc v
v).unEnc)
      forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
      Map k v
m

-- | Encode a 'KeyMap' as a json dict
keyMap :: (v -> Enc) -> KeyMap v -> Enc
keyMap :: forall v. (v -> Enc) -> KeyMap v -> Enc
keyMap v -> Enc
valEnc KeyMap v
m =
  Encoding -> Enc
Enc forall a b. (a -> b) -> a -> b
$
    forall k v m.
(k -> Encoding' Key)
-> (v -> Encoding)
-> (forall a. (k -> v -> a -> a) -> a -> m -> a)
-> m
-> Encoding
AesonEnc.dict
      (forall a. Text -> Encoding' a
AesonEnc.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText)
      (\v
v -> (v -> Enc
valEnc v
v).unEnc)
      forall v a. (Key -> v -> a -> a) -> a -> KeyMap v -> a
KeyMap.foldrWithKey
      KeyMap v
m

-- | Encode 'Json.Null'
null :: Enc
null :: Enc
null = Encoding -> Enc
Enc Encoding
AesonEnc.null_

-- | Encode a 'Prelude.Bool' as a json boolean
bool :: Bool -> Enc
bool :: Bool -> Enc
bool = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Encoding
AesonEnc.bool

-- | Encode an 'Integer' as a json number.
-- TODO: is it okay to just encode an arbitrarily-sized integer into json?
integer :: Integer -> Enc
integer :: Integer -> Enc
integer = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Encoding
AesonEnc.integer

-- | Encode a 'Scientific' as a json number.
scientific :: Scientific -> Enc
scientific :: Scientific -> Enc
scientific = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Encoding
AesonEnc.scientific

-- | Encode a 'Natural' as a json number.
natural :: Natural -> Enc
natural :: Natural -> Enc
natural = Integer -> Enc
integer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger @Natural

-- | Encode an 'Int' as a json number.
int :: Int -> Enc
int :: Int -> Enc
int = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Encoding
AesonEnc.int

-- | Encode an 'Int64' as a json number.
int64 :: Int64 -> Enc
int64 :: Int64 -> Enc
int64 = Encoding -> Enc
Enc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Encoding
AesonEnc.int64

-- | Encode 'Time.UTCTime' as a json string, as an ISO8601 timestamp with timezone (@yyyy-mm-ddThh:mm:ss[.sss]Z@)
utcTime :: Time.UTCTime -> Enc
utcTime :: UTCTime -> Enc
utcTime =
  Text -> Enc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
stringToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ISO8601 t => t -> String
ISO8601.iso8601Show @Time.UTCTime

-- | Implement this class if you want your type to only implement the part of 'Num'
-- that allows creating them from Integer-literals, then derive Num via 'NumLiteralOnly':
--
-- @
-- data Foo = Foo Integer
--   deriving (Num) via (NumLiteralOnly "Foo" Foo)
--
-- instance IntegerLiteral Foo where
--  integerLiteral i = Foo i
-- @
class IntegerLiteral a where
  integerLiteral :: Integer -> a

-- | The same as 'IntegerLiteral' but for floating point literals.
class RationalLiteral a where
  rationalLiteral :: Rational -> a

-- | Helper class for @deriving (Num) via …@, implements only literal syntax for integer and floating point numbers,
-- and throws descriptive runtime errors for any other methods in 'Num'.
--
-- See 'IntegerLiteral' and 'RationalLiteral' for examples.
newtype NumLiteralOnly (sym :: Symbol) num = NumLiteralOnly num

instance (IntegerLiteral num, KnownSymbol sym) => Num (NumLiteralOnly sym num) where
  fromInteger :: Integer -> NumLiteralOnly sym num
fromInteger = forall (sym :: Symbol) num. num -> NumLiteralOnly sym num
NumLiteralOnly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntegerLiteral a => Integer -> a
integerLiteral
  + :: NumLiteralOnly sym num
-> NumLiteralOnly sym num -> NumLiteralOnly sym num
(+) = forall a. HasCallStack => String -> a
error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to add (+) (NumLiteralOnly)|]
  * :: NumLiteralOnly sym num
-> NumLiteralOnly sym num -> NumLiteralOnly sym num
(*) = forall a. HasCallStack => String -> a
error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to multiply (*) (NumLiteralOnly)|]
  (-) = forall a. HasCallStack => String -> a
error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to subtract (-) (NumLiteralOnly)|]
  abs :: NumLiteralOnly sym num -> NumLiteralOnly sym num
abs = forall a. HasCallStack => String -> a
error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to use `abs` (NumLiteralOnly)|]
  signum :: NumLiteralOnly sym num -> NumLiteralOnly sym num
signum = forall a. HasCallStack => String -> a
error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to use `signum` (NumLiteralOnly)|]

instance (IntegerLiteral num, RationalLiteral num, KnownSymbol sym) => Fractional (NumLiteralOnly sym num) where
  fromRational :: Rational -> NumLiteralOnly sym num
fromRational = forall (sym :: Symbol) num. num -> NumLiteralOnly sym num
NumLiteralOnly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RationalLiteral a => Rational -> a
rationalLiteral
  recip :: NumLiteralOnly sym num -> NumLiteralOnly sym num
recip = forall a. HasCallStack => String -> a
error [fmt|Only use as rational literal allowed for {symbolVal (Proxy @sym)}, you tried to use `recip` (NumLiteralOnly)|]
  / :: NumLiteralOnly sym num
-> NumLiteralOnly sym num -> NumLiteralOnly sym num
(/) = forall a. HasCallStack => String -> a
error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to divide (/) (NumLiteralOnly)|]