mapTag for flat encoding

garyb · Jan 26, 2025 · 56583cb · 56583cb
1 parent 26bba8f
commit 56583cb
Show file tree

Hide file tree

Showing 2 changed files with 84 additions and 65 deletions.
diff --git a/src/Data/Codec/Argonaut/Sum.purs b/src/Data/Codec/Argonaut/Sum.purs
@@ -415,27 +415,31 @@ encodeSumCase encoding rawTag jsons =
 
 type FlatEncoding (tag ∷ Symbol) =
   { tag ∷ Proxy tag
+  , mapTag ∷ String → String
   }
 
 defaultFlatEncoding ∷ FlatEncoding "tag"
-defaultFlatEncoding = { tag: Proxy }
+defaultFlatEncoding =
+  { tag: Proxy
+  , mapTag: identity
+  }
 
 sumFlat ∷ ∀ r rep a. GFlatCases "tag" r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
 sumFlat = sumFlatWith defaultFlatEncoding
 
 sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag → String → Record r → JsonCodec a
-sumFlatWith _ name r =
+sumFlatWith encoding name r =
   dimap from to $ codec' dec enc
   where
-  dec = gFlatCasesDecode @tag r >>> (lmap $ Named name)
-  enc = gFlatCasesEncode @tag r
+  dec = gFlatCasesDecode @tag encoding r >>> (lmap $ Named name)
+  enc = gFlatCasesEncode @tag encoding r
 
 class GFlatCases ∷ Symbol → Row Type → Type → Constraint
 class
   GFlatCases tag r rep
   where
-  gFlatCasesEncode ∷ Record r → rep → Json
-  gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError rep
+  gFlatCasesEncode ∷ FlatEncoding tag → Record r → rep → Json
+  gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either JsonDecodeError rep
 
 instance gFlatCasesConstructorNoArg ∷
   ( Row.Cons name Unit () rc
@@ -444,22 +448,23 @@ instance gFlatCasesConstructorNoArg ∷
   , IsSymbol tag
   ) ⇒
   GFlatCases tag rc (Constructor name NoArguments) where
-  gFlatCasesEncode ∷ Record rc → Constructor name NoArguments → Json
-  gFlatCasesEncode _ (Constructor NoArguments) =
+  gFlatCasesEncode ∷ FlatEncoding tag → Record rc → Constructor name NoArguments → Json
+  gFlatCasesEncode { mapTag } _ (Constructor NoArguments) =
     let
-      name = reflectSymbol (Proxy @name) ∷ String
+      nameRaw = reflectSymbol (Proxy @name) ∷ String
+      name = mapTag nameRaw ∷ String
       propCodec = CAR.record {} ∷ JPropCodec {}
       propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
       codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
       rcWithTag = Record.insert (Proxy @tag) name {} ∷ Record rf
     in
       CA.encode codecWithTag rcWithTag
 
-  gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
-  gFlatCasesDecode _ json = do
+  gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
+  gFlatCasesDecode { mapTag } _ json = do
     let
-      name = reflectSymbol (Proxy @name) ∷ String
-
+      nameRaw = reflectSymbol (Proxy @name) ∷ String
+      name = mapTag nameRaw ∷ String
       propCodec = CAR.record {} ∷ JPropCodec {}
       propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
       codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
@@ -480,21 +485,23 @@ instance gFlatCasesConstructorSingleArg ∷
   , IsSymbol tag
   ) ⇒
   GFlatCases tag rc (Constructor name (Argument (Record rf))) where
-  gFlatCasesEncode ∷ Record rc → Constructor name (Argument (Record rf)) → Json
-  gFlatCasesEncode rc (Constructor (Argument rf)) =
+  gFlatCasesEncode ∷ FlatEncoding tag → Record rc → Constructor name (Argument (Record rf)) → Json
+  gFlatCasesEncode { mapTag } rc (Constructor (Argument rf)) =
     let
-      name = reflectSymbol (Proxy @name) ∷ String
+      nameRaw = reflectSymbol (Proxy @name) ∷ String
+      name = mapTag nameRaw ∷ String
       propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
       propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
       codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
       rcWithTag = Record.insert (Proxy @tag) name rf ∷ Record rf'
     in
       CA.encode codecWithTag rcWithTag
 
-  gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
-  gFlatCasesDecode rc json = do
+  gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
+  gFlatCasesDecode { mapTag } rc json = do
     let
-      name = reflectSymbol (Proxy @name) ∷ String
+      nameRaw = reflectSymbol (Proxy @name) ∷ String
+      name = mapTag nameRaw ∷ String
       propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
       propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
       codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
@@ -518,61 +525,30 @@ instance gFlatCasesSum ∷
   , IsSymbol name
   ) ⇒
   GFlatCases tag r (Sum (Constructor name lhs) rhs) where
-  gFlatCasesEncode ∷ Record r → Sum (Constructor name lhs) rhs → Json
-  gFlatCasesEncode r =
+  gFlatCasesEncode ∷ FlatEncoding tag → Record r → Sum (Constructor name lhs) rhs → Json
+  gFlatCasesEncode encoding r =
     let
       codec = Record.get (Proxy @name) r ∷ codec
       r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
       r2 = unsafeDelete (Proxy @name) r ∷ Record r2
     in
       case _ of
-        Inl lhs → gFlatCasesEncode @tag r1 lhs
-        Inr rhs → gFlatCasesEncode @tag r2 rhs
+        Inl lhs → gFlatCasesEncode @tag encoding r1 lhs
+        Inr rhs → gFlatCasesEncode @tag encoding r2 rhs
 
-  gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
-  gFlatCasesDecode r tagged = do
+  gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
+  gFlatCasesDecode encoding r tagged = do
     let
       codec = Record.get (Proxy @name) r ∷ codec
       r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
       r2 = Record.delete (Proxy @name) r ∷ Record r2
     let
-      lhs = gFlatCasesDecode @tag r1 tagged ∷ _ (Constructor name lhs)
-      rhs = gFlatCasesDecode @tag r2 tagged ∷ _ rhs
+      lhs = gFlatCasesDecode @tag encoding r1 tagged ∷ _ (Constructor name lhs)
+      rhs = gFlatCasesDecode @tag encoding r2 tagged ∷ _ rhs
     (Inl <$> lhs) <|> (Inr <$> rhs)
 
 --------------------------------------------------------------------------------
 
-sumEnum ∷ ∀ r rep a. GEnumCases r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
-sumEnum = unsafeCoerce 1
-
-class GEnumCases ∷ Row Type → Type → Constraint
-class
-  GEnumCases r rep
-  where
-  gEnumCasesEncode ∷ Record r → rep → Json
-  gEnumCasesDecode ∷ Record r → Json → Either JsonDecodeError rep
-
-instance gEnumCasesConstructorNoArg ∷
-  ( Row.Cons name Unit () rc
-  , IsSymbol name
-  ) ⇒
-  GEnumCases rc (Constructor name NoArguments) where
-  gEnumCasesEncode ∷ Record rc → Constructor name NoArguments → Json
-  gEnumCasesEncode _ _ =
-    let
-      name = reflectSymbol (Proxy @name) ∷ String
-    in
-      encodeSumCase defaultEncoding name []
-
-  gEnumCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
-  gEnumCasesDecode _ json = do
-    let name = reflectSymbol (Proxy @name) ∷ String
-
-    parseNoFields defaultEncoding json name
-    pure $ Constructor NoArguments
-
---------------------------------------------------------------------------------
-
 -- | Same as `Record.delete` but deleting only happens at the type level
 -- | and the value is left untouched.
 unsafeDelete ∷ ∀ r1 r2 l a. IsSymbol l ⇒ Row.Lacks l r1 ⇒ Row.Cons l a r1 r2 ⇒ Proxy l → Record r2 → Record r1

diff --git a/test/Test/Sum.purs b/test/Test/Sum.purs
@@ -10,7 +10,7 @@ import Data.Codec (decode, encode)
 import Data.Codec.Argonaut (JsonCodec)
 import Data.Codec.Argonaut as C
 import Data.Codec.Argonaut.Record as CR
-import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlatWith, sumWith)
+import Data.Codec.Argonaut.Sum (Encoding(..), FlatEncoding, defaultEncoding, sumFlatWith, sumWith)
 import Data.Generic.Rep (class Generic)
 import Data.Show.Generic (genericShow)
 import Data.String as Str
@@ -66,8 +66,8 @@ instance Arbitrary SampleFlat where
 instance Show SampleFlat where
   show = genericShow
 
-codecSampleFlat ∷ JsonCodec SampleFlat
-codecSampleFlat = sumFlatWith { tag: Proxy @"tag" } "Sample"
+codecSampleFlat ∷ FlatEncoding "tag" → JsonCodec SampleFlat
+codecSampleFlat encoding = sumFlatWith encoding "Sample"
   { "FlatFoo": unit
   , "FlatBar": CR.record { errors: C.int }
   , "FlatBaz": CR.record
@@ -445,22 +445,29 @@ main = do
 
   log "Check sum flat"
   do
-    check codecSampleFlat FlatFoo
+    log "  - Custom tag"
+    let
+      opts =
+        { tag: Proxy @"tag"
+        , mapTag: identity
+        }
+
+    check (codecSampleFlat opts) FlatFoo
       $ Str.joinWith "\n"
           [ "{"
           , "  \"tag\": \"FlatFoo\""
           , "}"
           ]
 
-    check codecSampleFlat (FlatBar { errors: 42 })
+    check (codecSampleFlat opts) (FlatBar { errors: 42 })
       $ Str.joinWith "\n"
           [ "{"
           , "  \"tag\": \"FlatBar\","
           , "  \"errors\": 42"
           , "}"
           ]
 
-    check codecSampleFlat (FlatBaz { active: true, name: "hello", pos: { x: 42, y: 42 } })
+    check (codecSampleFlat opts) (FlatBaz { active: true, name: "hello", pos: { x: 42, y: 42 } })
       $ Str.joinWith "\n"
           [ "{"
           , "  \"tag\": \"FlatBaz\","
@@ -473,5 +480,41 @@ main = do
           , "}"
           ]
 
-    quickCheck (propCodec arbitrary codecSampleFlat)
+  do
+    log "  - mapTag"
+    let
+      opts =
+        { tag: Proxy @"tag"
+        , mapTag: Str.toLower
+        }
+
+    check (codecSampleFlat opts) FlatFoo
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"flatfoo\""
+          , "}"
+          ]
+
+    check (codecSampleFlat opts) (FlatBar { errors: 42 })
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"flatbar\","
+          , "  \"errors\": 42"
+          , "}"
+          ]
+
+    check (codecSampleFlat opts) (FlatBaz { active: true, name: "hello", pos: { x: 42, y: 42 } })
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"flatbaz\","
+          , "  \"active\": true,"
+          , "  \"name\": \"hello\","
+          , "  \"pos\": {"
+          , "    \"x\": 42,"
+          , "    \"y\": 42"
+          , "  }"
+          , "}"
+          ]
+
+    quickCheck (propCodec arbitrary (codecSampleFlat opts))