From 3b206f03d753302420c03cbc4f5f0a9042555479 Mon Sep 17 00:00:00 2001
From: Tom Sydney Kerckhove <syd@cs-syd.eu>
Date: Thu, 11 Nov 2021 13:45:40 +0100
Subject: [PATCH] automatically implement toEncoding via codec as well

---
 README.md                                   |  2 +-
 autodocodec/src/Autodocodec.hs              |  2 ++
 autodocodec/src/Autodocodec/Aeson.hs        |  2 ++
 autodocodec/src/Autodocodec/Aeson/Encode.hs | 39 ++++++++++++++++++++-
 4 files changed, 43 insertions(+), 2 deletions(-)

diff --git a/README.md b/README.md
index 3ac1f14..645ac4c 100644
--- a/README.md
+++ b/README.md
@@ -5,7 +5,7 @@ Autodocodec is short for "self(auto)- documenting encoder and decoder".
 In short:
 You write a single instance, of the 'Codec' type-class, for your type, and you get:
 
-* [A 'ToJSON' instance from 'aeson'](https://hackage.haskell.org/package/aeson-2.0.1.0/docs/Data-Aeson-Types.html#t:ToJSON)
+* [A 'ToJSON' instance from 'aeson' with both a `toJSON` and `toEncoding` implementation](https://hackage.haskell.org/package/aeson-2.0.1.0/docs/Data-Aeson-Types.html#t:ToJSON)
 * [A 'FromJSON' instance from 'aeson'](https://hackage.haskell.org/package/aeson-2.0.1.0/docs/Data-Aeson-Types.html#t:FromJSON)
 * [A 'ToYaml] instance from 'yaml'](https://hackage.haskell.org/package/yaml-0.11.7.0/docs/Data-Yaml-Builder.html#t:ToYaml)
 * [A json schema](http://json-schema.org/)
diff --git a/autodocodec/src/Autodocodec.hs b/autodocodec/src/Autodocodec.hs
index bfea85b..09c0bbb 100644
--- a/autodocodec/src/Autodocodec.hs
+++ b/autodocodec/src/Autodocodec.hs
@@ -5,6 +5,8 @@ module Autodocodec
     encodeViaCodec,
     toJSONViaCodec,
     toJSONVia,
+    toEncodingViaCodec,
+    toEncodingVia,
 
     -- * Decoding
     eitherDecodeViaCodec,
diff --git a/autodocodec/src/Autodocodec/Aeson.hs b/autodocodec/src/Autodocodec/Aeson.hs
index 31bfa2e..82506e3 100644
--- a/autodocodec/src/Autodocodec/Aeson.hs
+++ b/autodocodec/src/Autodocodec/Aeson.hs
@@ -5,6 +5,8 @@ module Autodocodec.Aeson
     encodeViaCodec,
     toJSONViaCodec,
     toJSONVia,
+    toEncodingViaCodec,
+    toEncodingVia,
 
     -- * Decoding
     eitherDecodeViaCodec,
diff --git a/autodocodec/src/Autodocodec/Aeson/Encode.hs b/autodocodec/src/Autodocodec/Aeson/Encode.hs
index 33a4169..e7b8f91 100644
--- a/autodocodec/src/Autodocodec/Aeson/Encode.hs
+++ b/autodocodec/src/Autodocodec/Aeson/Encode.hs
@@ -10,9 +10,11 @@ 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.Scientific
 import Data.Text (Text)
-import Data.Vector
+import Data.Vector (Vector)
+import qualified Data.Vector as V
 
 -- | Encode a value using its JSON codec.
 toJSONViaCodec :: HasCodec a => a -> JSON.Value
@@ -55,5 +57,40 @@ toJSONContextVia = flip go
       PureCodec _ -> error "Cannot toJSON a pure object codec."
       ApCodec oc1 oc2 -> go a oc1 <> go a oc2
 
+toEncodingViaCodec :: HasCodec a => a -> JSON.Encoding
+toEncodingViaCodec = toEncodingVia codec
+
+toEncodingVia :: ValueCodec a void -> a -> JSON.Encoding
+toEncodingVia = flip go
+  where
+    go :: a -> ValueCodec a void -> JSON.Encoding
+    go a = \case
+      NullCodec -> JSON.null_
+      BoolCodec _ -> JSON.bool (a :: Bool)
+      StringCodec _ -> JSON.text (a :: Text)
+      NumberCodec _ -> JSON.scientific (a :: Scientific)
+      ArrayOfCodec _ c -> JSON.list (`go` c) (V.toList (a :: Vector _))
+      ObjectOfCodec _ oc -> JSON.pairs (goObject a oc)
+      ObjectCodec -> JSON.toEncoding (a :: JSON.Object)
+      ValueCodec -> JSON.value (a :: JSON.Value)
+      EqCodec value c -> go value c
+      MapCodec _ g c -> go (g a) c
+      EitherCodec c1 c2 -> case (a :: Either _ _) of
+        Left a1 -> go a1 c1
+        Right a2 -> go a2 c2
+      CommentCodec _ c -> go a c
+      ReferenceCodec _ c -> go a c
+    goObject :: a -> ObjectCodec a void -> JSON.Series
+    goObject a = \case
+      RequiredKeyCodec k c _ -> JSON.pair k (go a c)
+      OptionalKeyCodec k c _ -> case (a :: Maybe _) of
+        Nothing -> mempty :: JSON.Series
+        Just b -> JSON.pair k (go b c)
+      OptionalKeyWithDefaultCodec k c _ mdoc -> goObject (Just a) (OptionalKeyCodec k c mdoc)
+      PureCodec _ -> mempty :: JSON.Series
+      MapCodec _ g c -> goObject (g a) c
+      ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
+
 instance HasCodec a => JSON.ToJSON (Autodocodec a) where
   toJSON = toJSONViaCodec . unAutodocodec
+  toEncoding = toEncodingViaCodec . unAutodocodec