Skip to content

New option for sum codecs: mapTag #71

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Jan 28, 2025
Merged

New option for sum codecs: mapTag #71

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
26bba8f
Add mapTag option
m-bock Jan 25, 2025
56583cb
mapTag for flat encoding
m-bock Jan 26, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
106 changes: 63 additions & 43 deletions src/Data/Codec/Argonaut/Sum.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,8 +18,7 @@ module Data.Codec.Argonaut.Sum
, sumFlatWith
, sumWith
, taggedSum
)
where
) where

import Prelude

Expand Down Expand Up @@ -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
Expand All @@ -124,6 +126,7 @@ defaultEncoding = EncodeTagged
, valuesKey: "values"
, unwrapSingleArguments: false
, omitEmptyArguments: false
, mapTag: identity
}

--------------------------------------------------------------------------------
Expand Down Expand Up @@ -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 <> "`"))
Expand All @@ -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
Expand All @@ -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 <> "`"))
Expand All @@ -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 ←
Expand All @@ -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 ←
Expand All @@ -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
Expand All @@ -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 =
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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')
Expand All @@ -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
Expand Down
Loading
Loading