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

module Json.Enc where

import Data.Aeson (Encoding, Value (..))
import Data.Aeson.Encoding qualified as AesonEnc
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap (KeyMap)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Int (Int64)
import Data.Map.Strict qualified as Map
import Data.Scientific
import Data.String (IsString (fromString))
import Data.Text.Lazy qualified as Lazy
import Data.Time qualified as Time
import Data.Time.Format.ISO8601 qualified as ISO8601
import GHC.TypeLits
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)

-- | You can create an @Enc any@ that renders an 'Aeson.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 an 'Aeson.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 an 'Aeson.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)

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

-- | Encode a '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 'Array'
emptyArray :: Enc
emptyArray :: Enc
emptyArray = Encoding -> Enc
Enc Encoding
AesonEnc.emptyArray_

-- | Encode an empty 'Object'
emptyObject :: Enc
emptyObject :: Enc
emptyObject = Encoding -> Enc
Enc Encoding
AesonEnc.emptyObject_

-- | Encode a 'Text'
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@
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 '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 '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 'Array'
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 an 'Array'.
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 'Object'.
--
-- Like with 'Map.fromList', if the list contains the same key multiple times, the last value in the list is retained:
--
-- @
-- (object [ ("foo", 42), ("foo", 23) ])
-- ~= "{\"foo\":23}"
-- @
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)
      forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
      (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList 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'.
--
-- 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'
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 'Null'
null :: Enc
null :: Enc
null = Encoding -> Enc
Enc Encoding
AesonEnc.null_

-- | Encode 'Bool'
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 '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 '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 '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 'Aeson.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 '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 UTCTime as '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)|]