Merge pull request #71 from m-bock/mapTag

New option for sum codecs: `mapTag`

Author: garyb

src/Data/Codec/Argonaut/Sum.purs

@@ -18,8 +18,7 @@ module Data.Codec.Argonaut.Sum
   , sumFlatWith
   , sumWith
   , taggedSum
-  )
-  where
+  ) where
 
 import Prelude
 
@@ -110,12 +109,15 @@ taggedSum name printTag parseTag f g = Codec.codec decodeCase encodeCase
 
 data Encoding
   = EncodeNested
-      { unwrapSingleArguments ∷ Boolean }
+      { unwrapSingleArguments ∷ Boolean
+      , mapTag ∷ String → String
+      }
   | EncodeTagged
       { tagKey ∷ String
       , valuesKey ∷ String
       , omitEmptyArguments ∷ Boolean
       , unwrapSingleArguments ∷ Boolean
+      , mapTag ∷ String → String
       }
 
 defaultEncoding ∷ Encoding
@@ -124,6 +126,7 @@ defaultEncoding = EncodeTagged
   , valuesKey: "values"
   , unwrapSingleArguments: false
   , omitEmptyArguments: false
+  , mapTag: identity
   }
 
 --------------------------------------------------------------------------------
@@ -301,9 +304,10 @@ checkTag tagKey obj expectedTag = do
     $ TypeMismatch ("Expecting tag `" <> expectedTag <> "`, got `" <> tag <> "`")
 
 parseNoFields ∷ Encoding → Json → String → Either JsonDecodeError Unit
-parseNoFields encoding json expectedTag =
+parseNoFields encoding json expectedTagRaw =
   case encoding of
-    EncodeNested {} → do
+    EncodeNested { mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← CA.decode jobject json
       val ←
         ( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
@@ -313,7 +317,8 @@ parseNoFields encoding json expectedTag =
         $ Left
         $ TypeMismatch "Expecting an empty array"
 
-    EncodeTagged { tagKey, valuesKey, omitEmptyArguments } → do
+    EncodeTagged { tagKey, valuesKey, omitEmptyArguments, mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← CA.decode jobject json
       checkTag tagKey obj expectedTag
       when (not omitEmptyArguments) do
@@ -327,8 +332,9 @@ parseNoFields encoding json expectedTag =
           $ TypeMismatch "Expecting an empty array"
 
 parseSingleField ∷ Encoding → Json → String → Either JsonDecodeError Json
-parseSingleField encoding json expectedTag = case encoding of
-  EncodeNested { unwrapSingleArguments } → do
+parseSingleField encoding json expectedTagRaw = case encoding of
+  EncodeNested { unwrapSingleArguments, mapTag } → do
+    let expectedTag = mapTag expectedTagRaw ∷ String
     obj ← CA.decode jobject json
     val ←
       ( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
@@ -341,7 +347,8 @@ parseSingleField encoding json expectedTag = case encoding of
         [ head ] → pure head
         _ → Left $ TypeMismatch "Expecting exactly one element"
 
-  EncodeTagged { tagKey, valuesKey, unwrapSingleArguments } → do
+  EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, mapTag } → do
+    let expectedTag = mapTag expectedTagRaw ∷ String
     obj ← CA.decode jobject json
     checkTag tagKey obj expectedTag
     val ←
@@ -357,16 +364,18 @@ parseSingleField encoding json expectedTag = case encoding of
         _ → Left $ TypeMismatch "Expecting exactly one element"
 
 parseManyFields ∷ Encoding → Json → String → Either JsonDecodeError (Array Json)
-parseManyFields encoding json expectedTag =
+parseManyFields encoding json expectedTagRaw =
   case encoding of
-    EncodeNested {} → do
+    EncodeNested { mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← CA.decode jobject json
       val ←
         ( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
         ) ∷ _ Json
       CA.decode CA.jarray val
 
-    EncodeTagged { tagKey, valuesKey } → do
+    EncodeTagged { tagKey, valuesKey, mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← CA.decode jobject json
       checkTag tagKey obj expectedTag
       val ←
@@ -376,10 +385,11 @@ parseManyFields encoding json expectedTag =
       CA.decode CA.jarray val
 
 encodeSumCase ∷ Encoding → String → Array Json → Json
-encodeSumCase encoding tag jsons =
+encodeSumCase encoding rawTag jsons =
   case encoding of
-    EncodeNested { unwrapSingleArguments } →
+    EncodeNested { unwrapSingleArguments, mapTag } →
       let
+        tag = mapTag rawTag ∷ String
         val = case jsons of
           [] → CA.encode CA.jarray []
           [ json ] | unwrapSingleArguments → json
@@ -389,8 +399,9 @@ encodeSumCase encoding tag jsons =
           [ tag /\ val
           ]
 
-    EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, omitEmptyArguments } →
+    EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, omitEmptyArguments, mapTag } →
       let
+        tag = mapTag rawTag ∷ String
         tagEntry =
           Just (tagKey /\ CA.encode CA.string tag) ∷ Maybe (String /\ Json)
         valEntry =
@@ -404,27 +415,31 @@ encodeSumCase encoding tag 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 ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag → String → Record r → JsonCodec a
+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
@@ -433,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)
@@ -469,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')
@@ -507,28 +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)
 
+--------------------------------------------------------------------------------
+
 -- | 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