diff --git a/src/Data/Codec/Argonaut/Sum.purs b/src/Data/Codec/Argonaut/Sum.purs index c9a3cab..7efa257 100644 --- a/src/Data/Codec/Argonaut/Sum.purs +++ b/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,10 +448,11 @@ 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) @@ -444,11 +460,11 @@ instance gFlatCasesConstructorNoArg ∷ 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,10 +485,11 @@ 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') @@ -480,10 +497,11 @@ instance gFlatCasesConstructorSingleArg ∷ 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 diff --git a/test/Test/Sum.purs b/test/Test/Sum.purs index f1d82b9..3bc0831 100644 --- 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, sumFlat, 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 @@ -22,7 +22,6 @@ import Test.QuickCheck (class Arbitrary, arbitrary, quickCheck) import Test.QuickCheck.Arbitrary (genericArbitrary) import Test.Util (propCodec) import Type.Prelude (Proxy(..)) -import Type.Proxy (Proxy) -------------------------------------------------------------------------------- @@ -67,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 @@ -146,6 +145,7 @@ main = do , valuesKey: "customValues" , omitEmptyArguments: false , unwrapSingleArguments: false + , mapTag: identity } check @@ -192,6 +192,7 @@ main = do , valuesKey: "values" , omitEmptyArguments: true , unwrapSingleArguments: false + , mapTag: identity } check @@ -237,6 +238,7 @@ main = do , valuesKey: "values" , omitEmptyArguments: false , unwrapSingleArguments: true + , mapTag: identity } check @@ -273,6 +275,51 @@ main = do , "}" ] + log " - Option: mapTag" + do + let + opts = EncodeTagged + { tagKey: "tag" + , valuesKey: "values" + , omitEmptyArguments: false + , unwrapSingleArguments: true + , mapTag: Str.toLower + } + + check + (codecSample opts) + Foo + $ Str.joinWith "\n" + [ "{" + , " \"tag\": \"foo\"," + , " \"values\": []" + , "}" + ] + + check + (codecSample opts) + (Bar 42) + $ Str.joinWith "\n" + [ "{" + , " \"tag\": \"bar\"," + , " \"values\": 42" + , "}" + ] + + check + (codecSample opts) + (Baz true "hello" 42) + $ Str.joinWith "\n" + [ "{" + , " \"tag\": \"baz\"," + , " \"values\": [" + , " true," + , " \"hello\"," + , " 42" + , " ]" + , "}" + ] + log " - EncodeNested" do log " - default" @@ -280,6 +327,7 @@ main = do let opts = EncodeNested { unwrapSingleArguments: false + , mapTag: identity } check @@ -320,6 +368,7 @@ main = do let opts = EncodeNested { unwrapSingleArguments: true + , mapTag: identity } check @@ -353,18 +402,64 @@ main = do , "}" ] + log " - Option: mapTag" + do + let + opts = EncodeNested + { unwrapSingleArguments: true + , mapTag: Str.toLower + } + + check + (codecSample opts) + Foo + $ Str.joinWith "\n" + [ "{" + , " \"foo\": []" + , "}" + ] + + check + (codecSample opts) + (Bar 42) + $ Str.joinWith "\n" + [ "{" + , " \"bar\": 42" + , "}" + ] + + check + (codecSample opts) + (Baz true "hello" 42) + $ Str.joinWith "\n" + [ "{" + , " \"baz\": [" + , " true," + , " \"hello\"," + , " 42" + , " ]" + , "}" + ] + quickCheck (propCodec arbitrary (codecSample defaultEncoding)) 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\"," @@ -372,7 +467,7 @@ main = do , "}" ] - 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\"," @@ -385,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))