Merge branch 'master' into error-improvements

Author: m-bock

src/Data/Codec/Argonaut/Sum.purs

@@ -109,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
@@ -123,6 +126,7 @@ defaultEncoding = EncodeTagged
   , valuesKey: "values"
   , unwrapSingleArguments: false
   , omitEmptyArguments: false
+  , mapTag: identity
   }
 
 --------------------------------------------------------------------------------
@@ -312,9 +316,10 @@ checkTag tagKey obj expectedTag = do
     (Left UnmatchedCase)
 
 parseNoFields ∷ Encoding → Json → String → Either Err Unit
-parseNoFields encoding json expectedTag =
+parseNoFields encoding json expectedTagRaw =
   case encoding of
-    EncodeNested {} → do
+    EncodeNested { mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← lmap JErr $ CA.decode jobject json
       val ←
         ( Obj.lookup expectedTag obj # note UnmatchedCase
@@ -325,7 +330,8 @@ parseNoFields encoding json expectedTag =
             (JErr $ TypeMismatch "Expecting an empty array")
       pure unit
 
-    EncodeTagged { tagKey, valuesKey, omitEmptyArguments } → do
+    EncodeTagged { tagKey, valuesKey, omitEmptyArguments, mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← lmap JErr $ CA.decode jobject json
       checkTag tagKey obj expectedTag
       when (not omitEmptyArguments) do
@@ -340,8 +346,9 @@ parseNoFields encoding json expectedTag =
         pure unit
 
 parseSingleField ∷ Encoding → Json → String → Either Err 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 ← lmap JErr $ CA.decode jobject json
     val ←
       ( Obj.lookup expectedTag obj # note UnmatchedCase
@@ -354,7 +361,8 @@ parseSingleField encoding json expectedTag = case encoding of
         [ head ] → pure head
         _ → Left $ JErr $ TypeMismatch "Expecting exactly one element"
 
-  EncodeTagged { tagKey, valuesKey, unwrapSingleArguments } → do
+  EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, mapTag } → do
+    let expectedTag = mapTag expectedTagRaw ∷ String
     obj ← lmap JErr $ CA.decode jobject json
     checkTag tagKey obj expectedTag
     val ←
@@ -370,16 +378,18 @@ parseSingleField encoding json expectedTag = case encoding of
         _ → Left $ JErr $ TypeMismatch "Expecting exactly one element"
 
 parseManyFields ∷ Encoding → Json → String → Either Err (Array Json)
-parseManyFields encoding json expectedTag =
+parseManyFields encoding json expectedTagRaw =
   case encoding of
-    EncodeNested {} → do
+    EncodeNested { mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← lmap JErr $ CA.decode jobject json
       val ←
         ( Obj.lookup expectedTag obj # note UnmatchedCase
         ) ∷ _ Json
       lmap JErr $ CA.decode CA.jarray val
 
-    EncodeTagged { tagKey, valuesKey } → do
+    EncodeTagged { tagKey, valuesKey, mapTag } → do
+      let expectedTag = mapTag expectedTagRaw ∷ String
       obj ← lmap JErr $ CA.decode jobject json
       checkTag tagKey obj expectedTag
       val ←
@@ -389,10 +399,11 @@ parseManyFields encoding json expectedTag =
       lmap JErr $ 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
@@ -402,8 +413,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 =
@@ -417,27 +429,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 encoding name r =
   dimap from to $ codec' dec enc
   where
-  dec = gFlatCasesDecode @tag r >>> (lmap $ finalizeError name)
-  enc = gFlatCasesEncode @tag r
+  dec = gFlatCasesDecode @tag encoding r >>> (lmap $ finalizeError 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 Err rep
+  gFlatCasesEncode ∷ FlatEncoding tag → Record r → rep → Json
+  gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either Err rep
 
 instance gFlatCasesConstructorNoArg ∷
   ( Row.Cons name Unit () rc
@@ -446,21 +462,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 Err (Constructor name NoArguments)
-  gFlatCasesDecode _ json = do
+  gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either Err (Constructor name NoArguments)
+  gFlatCasesDecode { mapTag } _ json = do
     let
-      name = reflectSymbol (Proxy @name) ∷ String
+      nameRaw = reflectSymbol (Proxy @name) ∷ String
+      name = mapTag nameRaw ∷ String
       tag = reflectSymbol (Proxy @tag) ∷ String
 
     obj ← lmap JErr $ CA.decode jobject json
@@ -469,6 +487,7 @@ instance gFlatCasesConstructorNoArg ∷
 
     pure (Constructor NoArguments)
 
+
 instance gFlatCasesConstructorSingleArg ∷
   ( Row.Cons name (JPropCodec (Record rf)) () rc
   , Row.Lacks tag rf
@@ -477,27 +496,31 @@ 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 Err (Constructor name (Argument (Record rf)))
-  gFlatCasesDecode rc json = do
+
+  gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either Err (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
       tag = reflectSymbol (Proxy @tag) ∷ String
+    
 
     obj ← lmap JErr $ CA.decode jobject json
 
     checkTag tag obj name
-
+      
     let
       propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
       codec = CA.object ("case " <> name) propCodec ∷ JsonCodec (Record rf)
@@ -516,31 +539,33 @@ 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 Err (Sum (Constructor name lhs) rhs)
-  gFlatCasesDecode r tagged = do
+  gFlatCasesDecode ∷ FlatEncoding tag -> Record r → Json → Either Err (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
     case lhs unit of
       Left UnmatchedCase → Inr <$> rhs unit
       Left (JErr err) → Left (JErr err)
       Right val → Right (Inl val)
 
+--------------------------------------------------------------------------------
+
 -- | 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