{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures -fno-warn-orphans #-}

module Autodocodec.Aeson.Encode where

import qualified Autodocodec.Aeson.Compat as Compat
import Autodocodec.Class
import Autodocodec.Codec
import Autodocodec.DerivingVia
import Data.Aeson (toJSON)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Encoding as JSON
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Data.Scientific
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as V

-- | Implement 'JSON.toJSON' via a type's codec.
toJSONViaCodec :: HasCodec a => a -> JSON.Value
toJSONViaCodec :: a -> Value
toJSONViaCodec = ValueCodec a a -> a -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia ValueCodec a a
forall value. HasCodec value => JSONCodec value
codec

-- | Implement 'JSON.toJSON' via a given codec.
toJSONVia :: ValueCodec a void -> a -> JSON.Value
toJSONVia :: ValueCodec a void -> a -> Value
toJSONVia = (a -> ValueCodec a void -> Value)
-> ValueCodec a void -> a -> Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> ValueCodec a void -> Value
forall a void. a -> ValueCodec a void -> Value
go
  where
    -- We use type-annotations here for readability of type information that is
    -- gathered to case-matching on GADTs, they aren't strictly necessary.
    go :: a -> ValueCodec a void -> JSON.Value
    go :: a -> ValueCodec a void -> Value
go a
a = \case
      ValueCodec a void
NullCodec -> Value
JSON.Null
      BoolCodec Maybe Text
_ -> Bool -> Value
forall a. ToJSON a => a -> Value
toJSON (a
Bool
a :: Bool)
      StringCodec Maybe Text
_ -> Text -> Value
forall a. ToJSON a => a -> Value
toJSON (a
Text
a :: Text)
      NumberCodec Maybe Text
_ Maybe NumberBounds
_ -> Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON (a
Scientific
a :: Scientific)
      ArrayOfCodec Maybe Text
_ ValueCodec input output
c -> Vector Value -> Value
forall a. ToJSON a => a -> Value
toJSON ((input -> Value) -> Vector input -> Vector Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (input -> ValueCodec input output -> Value
forall a void. a -> ValueCodec a void -> Value
`go` ValueCodec input output
c) (a
Vector input
a :: Vector _))
      ObjectOfCodec Maybe Text
_ ObjectCodec a void
oc -> Object -> Value
JSON.Object (a -> ObjectCodec a void -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject a
a ObjectCodec a void
oc)
      HashMapCodec JSONCodec v
c -> (v -> Value) -> ([v] -> Value) -> HashMap k v -> Value
forall (f :: * -> *) a.
ToJSON1 f =>
(a -> Value) -> ([a] -> Value) -> f a -> Value
JSON.liftToJSON (v -> JSONCodec v -> Value
forall a void. a -> ValueCodec a void -> Value
`go` JSONCodec v
c) ([v] -> ValueCodec [v] [v] -> Value
forall a void. a -> ValueCodec a void -> Value
`go` JSONCodec v -> ValueCodec [v] [v]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) (a
HashMap k v
a :: HashMap _ _)
      MapCodec JSONCodec v
c -> (v -> Value) -> ([v] -> Value) -> Map k v -> Value
forall (f :: * -> *) a.
ToJSON1 f =>
(a -> Value) -> ([a] -> Value) -> f a -> Value
JSON.liftToJSON (v -> JSONCodec v -> Value
forall a void. a -> ValueCodec a void -> Value
`go` JSONCodec v
c) ([v] -> ValueCodec [v] [v] -> Value
forall a void. a -> ValueCodec a void -> Value
`go` JSONCodec v -> ValueCodec [v] [v]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) (a
Map k v
a :: Map _ _)
      ValueCodec a void
ValueCodec -> (a
Value
a :: JSON.Value)
      EqCodec a
value JSONCodec a
c -> a -> JSONCodec a -> Value
forall a void. a -> ValueCodec a void -> Value
go a
value JSONCodec a
c
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Value oldInput oldOutput
c -> oldInput -> Codec Value oldInput oldOutput -> Value
forall a void. a -> ValueCodec a void -> Value
go (a -> oldInput
g a
a) Codec Value oldInput oldOutput
c
      EitherCodec Union
_ Codec Value input1 output1
c1 Codec Value input2 output2
c2 -> case (a
Either input1 input2
a :: Either _ _) of
        Left input1
a1 -> input1 -> Codec Value input1 output1 -> Value
forall a void. a -> ValueCodec a void -> Value
go input1
a1 Codec Value input1 output1
c1
        Right input2
a2 -> input2 -> Codec Value input2 output2 -> Value
forall a void. a -> ValueCodec a void -> Value
go input2
a2 Codec Value input2 output2
c2
      CommentCodec Text
_ ValueCodec a void
c -> a -> ValueCodec a void -> Value
forall a void. a -> ValueCodec a void -> Value
go a
a ValueCodec a void
c
      ReferenceCodec Text
_ ValueCodec a void
c -> a -> ValueCodec a void -> Value
forall a void. a -> ValueCodec a void -> Value
go a
a ValueCodec a void
c

    goObject :: a -> ObjectCodec a void -> JSON.Object
    goObject :: a -> ObjectCodec a void -> Object
goObject a
a = \case
      RequiredKeyCodec Text
k ValueCodec a void
c Maybe Text
_ -> Text -> Key
Compat.toKey Text
k Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= a -> ValueCodec a void -> Value
forall a void. a -> ValueCodec a void -> Value
go a
a ValueCodec a void
c
      OptionalKeyCodec Text
k ValueCodec input output
c Maybe Text
_ -> case (a
Maybe input
a :: Maybe _) of
        Maybe input
Nothing -> Object
forall a. Monoid a => a
mempty
        Just input
b -> Text -> Key
Compat.toKey Text
k Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= input -> ValueCodec input output -> Value
forall a void. a -> ValueCodec a void -> Value
go input
b ValueCodec input output
c
      OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
_ Maybe Text
mdoc -> Maybe a -> ObjectCodec (Maybe a) (Maybe a) -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Text
-> ValueCodec a a -> Maybe Text -> ObjectCodec (Maybe a) (Maybe a)
forall input output.
Text
-> ValueCodec input output
-> Maybe Text
-> ObjectCodec (Maybe input) (Maybe output)
OptionalKeyCodec Text
k ValueCodec a a
c Maybe Text
mdoc)
      OptionalKeyWithOmittedDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mdoc ->
        if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
defaultValue
          then Object
forall a. Monoid a => a
mempty
          else a -> ObjectCodec a a -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject a
a (Text -> ValueCodec a a -> a -> Maybe Text -> ObjectCodec a a
forall value.
Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mdoc)
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Object oldInput oldOutput
c -> oldInput -> Codec Object oldInput oldOutput -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject (a -> oldInput
g a
a) Codec Object oldInput oldOutput
c
      PureCodec void
_ -> Object
forall a. Monoid a => a
mempty
      EitherCodec Union
_ Codec Object input1 output1
c1 Codec Object input2 output2
c2 -> case (a
Either input1 input2
a :: Either _ _) of
        Left input1
a1 -> input1 -> Codec Object input1 output1 -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject input1
a1 Codec Object input1 output1
c1
        Right input2
a2 -> input2 -> Codec Object input2 output2 -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject input2
a2 Codec Object input2 output2
c2
      DiscriminatedUnionCodec Text
propertyName a -> (Text, ObjectCodec a ())
mapping HashMap Text (Text, ObjectCodec Void void)
_ ->
        case a -> (Text, ObjectCodec a ())
mapping a
a of
          (Text
discriminatorValue, ObjectCodec a ()
c) ->
            Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
Compat.insert (Text -> Key
Compat.toKey Text
propertyName) (Text -> Value
JSON.String Text
discriminatorValue) (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ a -> ObjectCodec a () -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject a
a ObjectCodec a ()
c
      ApCodec ObjectCodec a (output -> void)
oc1 ObjectCodec a output
oc2 -> a -> ObjectCodec a (output -> void) -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject a
a ObjectCodec a (output -> void)
oc1 Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> a -> ObjectCodec a output -> Object
forall a void. a -> ObjectCodec a void -> Object
goObject a
a ObjectCodec a output
oc2

-- | Implement 'JSON.toEncoding' via a type's codec.
toEncodingViaCodec :: HasCodec a => a -> JSON.Encoding
toEncodingViaCodec :: a -> Encoding
toEncodingViaCodec = ValueCodec a a -> a -> Encoding
forall a void. ValueCodec a void -> a -> Encoding
toEncodingVia ValueCodec a a
forall value. HasCodec value => JSONCodec value
codec

-- | Implement 'JSON.toEncoding' via the given codec.
toEncodingVia :: ValueCodec a void -> a -> JSON.Encoding
toEncodingVia :: ValueCodec a void -> a -> Encoding
toEncodingVia = (a -> ValueCodec a void -> Encoding)
-> ValueCodec a void -> a -> Encoding
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> ValueCodec a void -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go
  where
    go :: a -> ValueCodec a void -> JSON.Encoding
    go :: a -> ValueCodec a void -> Encoding
go a
a = \case
      ValueCodec a void
NullCodec -> Encoding
JSON.null_
      BoolCodec Maybe Text
_ -> Bool -> Encoding
JSON.bool (a
Bool
a :: Bool)
      StringCodec Maybe Text
_ -> Text -> Encoding
forall a. Text -> Encoding' a
JSON.text (a
Text
a :: Text)
      NumberCodec Maybe Text
_ Maybe NumberBounds
_ -> Scientific -> Encoding
JSON.scientific (a
Scientific
a :: Scientific)
      ArrayOfCodec Maybe Text
_ ValueCodec input output
c -> (input -> Encoding) -> [input] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
JSON.list (input -> ValueCodec input output -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
`go` ValueCodec input output
c) (Vector input -> [input]
forall a. Vector a -> [a]
V.toList (a
Vector input
a :: Vector _))
      ObjectOfCodec Maybe Text
_ ObjectCodec a void
oc -> Series -> Encoding
JSON.pairs (a -> ObjectCodec a void -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject a
a ObjectCodec a void
oc)
      HashMapCodec JSONCodec v
c -> (v -> Encoding) -> ([v] -> Encoding) -> HashMap k v -> Encoding
forall (f :: * -> *) a.
ToJSON1 f =>
(a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
JSON.liftToEncoding (v -> JSONCodec v -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
`go` JSONCodec v
c) ([v] -> ValueCodec [v] [v] -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
`go` JSONCodec v -> ValueCodec [v] [v]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) (a
HashMap k v
a :: HashMap _ _)
      MapCodec JSONCodec v
c -> (v -> Encoding) -> ([v] -> Encoding) -> Map k v -> Encoding
forall (f :: * -> *) a.
ToJSON1 f =>
(a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
JSON.liftToEncoding (v -> JSONCodec v -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
`go` JSONCodec v
c) ([v] -> ValueCodec [v] [v] -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
`go` JSONCodec v -> ValueCodec [v] [v]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) (a
Map k v
a :: Map _ _)
      ValueCodec a void
ValueCodec -> Value -> Encoding
JSON.value (a
Value
a :: JSON.Value)
      EqCodec a
value JSONCodec a
c -> a -> JSONCodec a -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go a
value JSONCodec a
c
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Value oldInput oldOutput
c -> oldInput -> Codec Value oldInput oldOutput -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go (a -> oldInput
g a
a) Codec Value oldInput oldOutput
c
      EitherCodec Union
_ Codec Value input1 output1
c1 Codec Value input2 output2
c2 -> case (a
Either input1 input2
a :: Either _ _) of
        Left input1
a1 -> input1 -> Codec Value input1 output1 -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go input1
a1 Codec Value input1 output1
c1
        Right input2
a2 -> input2 -> Codec Value input2 output2 -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go input2
a2 Codec Value input2 output2
c2
      CommentCodec Text
_ ValueCodec a void
c -> a -> ValueCodec a void -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go a
a ValueCodec a void
c
      ReferenceCodec Text
_ ValueCodec a void
c -> a -> ValueCodec a void -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go a
a ValueCodec a void
c
    goObject :: a -> ObjectCodec a void -> JSON.Series
    goObject :: a -> ObjectCodec a void -> Series
goObject a
a = \case
      RequiredKeyCodec Text
k ValueCodec a void
c Maybe Text
_ -> Key -> Encoding -> Series
JSON.pair (Text -> Key
Compat.toKey Text
k) (a -> ValueCodec a void -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go a
a ValueCodec a void
c)
      OptionalKeyCodec Text
k ValueCodec input output
c Maybe Text
_ -> case (a
Maybe input
a :: Maybe _) of
        Maybe input
Nothing -> Series
forall a. Monoid a => a
mempty :: JSON.Series
        Just input
b -> Key -> Encoding -> Series
JSON.pair (Text -> Key
Compat.toKey Text
k) (input -> ValueCodec input output -> Encoding
forall a void. a -> ValueCodec a void -> Encoding
go input
b ValueCodec input output
c)
      OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
_ Maybe Text
mdoc -> Maybe a -> ObjectCodec (Maybe a) (Maybe a) -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Text
-> ValueCodec a a -> Maybe Text -> ObjectCodec (Maybe a) (Maybe a)
forall input output.
Text
-> ValueCodec input output
-> Maybe Text
-> ObjectCodec (Maybe input) (Maybe output)
OptionalKeyCodec Text
k ValueCodec a a
c Maybe Text
mdoc)
      OptionalKeyWithOmittedDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mdoc ->
        if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
defaultValue
          then Series
forall a. Monoid a => a
mempty
          else a -> ObjectCodec a a -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject a
a (Text -> ValueCodec a a -> a -> Maybe Text -> ObjectCodec a a
forall value.
Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mdoc)
      PureCodec void
_ -> Series
forall a. Monoid a => a
mempty :: JSON.Series
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Object oldInput oldOutput
c -> oldInput -> Codec Object oldInput oldOutput -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject (a -> oldInput
g a
a) Codec Object oldInput oldOutput
c
      EitherCodec Union
_ Codec Object input1 output1
c1 Codec Object input2 output2
c2 -> case (a
Either input1 input2
a :: Either _ _) of
        Left input1
a1 -> input1 -> Codec Object input1 output1 -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject input1
a1 Codec Object input1 output1
c1
        Right input2
a2 -> input2 -> Codec Object input2 output2 -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject input2
a2 Codec Object input2 output2
c2
      DiscriminatedUnionCodec Text
propertyName a -> (Text, ObjectCodec a ())
mapping HashMap Text (Text, ObjectCodec Void void)
_ ->
        case a -> (Text, ObjectCodec a ())
mapping a
a of
          (Text
discriminatorValue, ObjectCodec a ()
c) ->
            Key -> Encoding -> Series
JSON.pair (Text -> Key
Compat.toKey Text
propertyName) (Text -> Encoding
forall a. ToJSON a => a -> Encoding
JSON.toEncoding Text
discriminatorValue) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> a -> ObjectCodec a () -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject a
a ObjectCodec a ()
c
      ApCodec ObjectCodec a (output -> void)
oc1 ObjectCodec a output
oc2 -> a -> ObjectCodec a (output -> void) -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject a
a ObjectCodec a (output -> void)
oc1 Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> a -> ObjectCodec a output -> Series
forall a void. a -> ObjectCodec a void -> Series
goObject a
a ObjectCodec a output
oc2

instance HasCodec a => JSON.ToJSON (Autodocodec a) where
  toJSON :: Autodocodec a -> Value
toJSON = a -> Value
forall a. HasCodec a => a -> Value
toJSONViaCodec (a -> Value) -> (Autodocodec a -> a) -> Autodocodec a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Autodocodec a -> a
forall a. Autodocodec a -> a
unAutodocodec
  toEncoding :: Autodocodec a -> Encoding
toEncoding = a -> Encoding
forall a. HasCodec a => a -> Encoding
toEncodingViaCodec (a -> Encoding)
-> (Autodocodec a -> a) -> Autodocodec a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Autodocodec a -> a
forall a. Autodocodec a -> a
unAutodocodec