Modified version of taggedSum embedding value into JS object where tag key is defined
-- | Standard Argonaut "taggedSum" always wraps encoded content
-- into sub object and binds to the key "value",
-- but this is not compatible
-- with Aeson, which doesn't wrapp content if value is a record,
-- i.e. has named fields
module CoMajor.Argonaut.Sum where
import Prelude
import Control.Monad.ST (ST)
import Data.Argonaut.Core as J
import Data.Bifunctor (lmap)
import Data.Codec as Codec
import Data.Codec.Argonaut as CA
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Foreign.Object as FO
import Foreign.Object.ST as FOST
taggedSum'
∷ ∀ tag a
. String
→ (tag → String)
→ (String → Maybe tag)
→ (tag → Either a (J.Json → Either CA.JsonDecodeError a))
→ (a → Tuple tag (Maybe J.Json))
→ CA.JsonCodec a
taggedSum' name printTag parseTag f g = Codec.codec decodeCase encodeCase
where
decodeCase ∷ J.Json → Either CA.JsonDecodeError a
decodeCase j = lmap (CA.Named name) do
obj ← Codec.decode CA.jobject j
tag ← Codec.decode (CA.prop "tag" CA.string) obj
case parseTag tag of
Nothing → Left (CA.AtKey "tag" (CA.UnexpectedValue (J.fromString tag)))
Just t →
case f t of
Left a → pure a
Right decoder → lmap (CA.AtKey "value") (decoder j)
wNothing :: forall r. tag -> ST r (FOST.STObject r J.Json)
wNothing tag = do
ho ← FOST.new
FOST.poke "tag" (Codec.encode CA.string (printTag tag)) ho
wJust :: forall r. J.Json -> tag -> ST r (FOST.STObject r J.Json)
wJust j tag = do
J.caseJsonObject
FOST.new
(\o -> do
ho <- FO.thawST o
FOST.poke "tag" (Codec.encode CA.string (printTag tag)) ho
)
j
encodeCase ∷ a → J.Json
encodeCase a = case g a of
Tuple tag value →
Codec.encode CA.jobject $
FO.runST do
case value of
Nothing -> wNothing tag
Just j -> wJust j tag
https://github.com/haskell/aeson/issues/1050
Modified version of taggedSum embedding value into JS object where tag key is defined