From d53a6231a39bb3e4698e01b514ee018d960d5a1c Mon Sep 17 00:00:00 2001 From: AugmenTab Date: Wed, 12 Feb 2025 18:13:30 -0600 Subject: [PATCH] Adds mechanism for converting Fleece schemas to Aeson Values This allows for the use of Fleece schemas in defining `ToJSON` instances. --- json-fleece-aeson/json-fleece-aeson.cabal | 3 +- json-fleece-aeson/src/Fleece/Aeson.hs | 1 + json-fleece-aeson/src/Fleece/Aeson/ToValue.hs | 186 ++++++++++++++++++ json-fleece-core/json-fleece-core.cabal | 4 +- json-fleece-core/package.yaml | 2 +- 5 files changed, 192 insertions(+), 4 deletions(-) create mode 100644 json-fleece-aeson/src/Fleece/Aeson/ToValue.hs diff --git a/json-fleece-aeson/json-fleece-aeson.cabal b/json-fleece-aeson/json-fleece-aeson.cabal index 457c4892..54100785 100644 --- a/json-fleece-aeson/json-fleece-aeson.cabal +++ b/json-fleece-aeson/json-fleece-aeson.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -33,6 +33,7 @@ library other-modules: Fleece.Aeson.AnyJSON Fleece.Aeson.EncoderDecoder + Fleece.Aeson.ToValue Paths_json_fleece_aeson hs-source-dirs: src diff --git a/json-fleece-aeson/src/Fleece/Aeson.hs b/json-fleece-aeson/src/Fleece/Aeson.hs index 36a6327a..39b59ec2 100644 --- a/json-fleece-aeson/src/Fleece/Aeson.hs +++ b/json-fleece-aeson/src/Fleece/Aeson.hs @@ -8,3 +8,4 @@ import Fleece.Aeson.AnyJSON as Export import Fleece.Aeson.Decoder as Export import Fleece.Aeson.Encoder as Export import Fleece.Aeson.EncoderDecoder as Export +import Fleece.Aeson.ToValue as Export diff --git a/json-fleece-aeson/src/Fleece/Aeson/ToValue.hs b/json-fleece-aeson/src/Fleece/Aeson/ToValue.hs new file mode 100644 index 00000000..f7c571d2 --- /dev/null +++ b/json-fleece-aeson/src/Fleece/Aeson/ToValue.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Fleece.Aeson.ToValue + ( FleeceToJSON (..) + , fleeceToJSON + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as AesonKey +import qualified Data.Aeson.Types as AesonTypes +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Text.Encoding as Enc +import GHC.TypeLits (KnownSymbol, symbolVal) +import Shrubbery (type (@=)) +import qualified Shrubbery + +import qualified Fleece.Core as FC + +fleeceToJSON :: FleeceToJSON a -> a -> Aeson.Value +fleeceToJSON (FleeceToJSON _name f) = + f + +data FleeceToJSON a + = FleeceToJSON FC.Name (a -> Aeson.Value) + +instance FC.Fleece FleeceToJSON where + newtype Object FleeceToJSON object _constructor + = Object (object -> [AesonTypes.Pair]) + + newtype Field FleeceToJSON object _a + = Field (object -> [AesonTypes.Pair]) + + newtype AdditionalFields FleeceToJSON object _a + = AdditionalFields (object -> [AesonTypes.Pair]) + + newtype UnionMembers FleeceToJSON _allTypes handledTypes + = UnionMembers (Shrubbery.BranchBuilder handledTypes Aeson.Value) + + newtype TaggedUnionMembers FleeceToJSON _allTypes handledTypes + = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTypes (T.Text, [AesonTypes.Pair])) + + schemaName (FleeceToJSON name _toJSON) = + name + + number = + FleeceToJSON (FC.unqualifiedName "number") Aeson.toJSON + + text = + FleeceToJSON (FC.unqualifiedName "text") Aeson.toJSON + + boolean = + FleeceToJSON (FC.unqualifiedName "boolean") Aeson.toJSON + + null = + FleeceToJSON + (FC.unqualifiedName "null") + (\FC.Null -> Aeson.Null) + + array (FleeceToJSON name itemToJSON) = + FleeceToJSON + (FC.annotateName name "array") + (Aeson.Array . fmap itemToJSON) + + nullable (FleeceToJSON name toJSON) = + FleeceToJSON (FC.annotateName name "nullable") $ \mbValue -> + case mbValue of + Left FC.Null -> Aeson.Null + Right value -> toJSON value + + required name accessor (FleeceToJSON _name toJSON) = + let + key = AesonKey.fromString name + in + Field $ \object -> + [(key, toJSON (accessor object))] + + optional name accessor (FleeceToJSON _name toJSON) = + let + key = AesonKey.fromString name + in + Field $ \object -> + case accessor object of + Just value -> + [(key, toJSON value)] + Nothing -> + [] + + additionalFields accessor (FleeceToJSON _name toJSON) = + AdditionalFields $ \object -> + map (\(key, value) -> (AesonKey.fromText key, toJSON value)) + . Map.toList + . accessor + $ object + + mapField _f encoder = + coerce encoder + + constructor _f = + Object (\_ -> mempty) + + field (Object mkStart) (Field mkNext) = + Object $ \object -> + mkStart object <> mkNext object + + additional (Object mkStart) (AdditionalFields mkRest) = + Object $ \object -> + mkStart object <> mkRest object + + objectNamed name (Object toObject) = + FleeceToJSON name (Aeson.object . toObject) + + boundedEnumNamed name toText = + FleeceToJSON name (Aeson.toJSON . toText) + + validateNamed name uncheck _check (FleeceToJSON _unvalidatedName toJSON) = + FleeceToJSON name (toJSON . uncheck) + + unionNamed name (UnionMembers builder) = + let + branches = + Shrubbery.branchBuild builder + in + FleeceToJSON name (Shrubbery.dissectUnion branches) + + unionMemberWithIndex _index encoder = + UnionMembers $ + let + -- It's important that this let is _inside_ the 'UnionMembers' + -- constructor so that it lazy enough to allow the recursive reference + -- of 'anyJSON' to itself within arrays. + FleeceToJSON _name toJSON = encoder + in + Shrubbery.singleBranch toJSON + + unionCombine (UnionMembers left) (UnionMembers right) = + UnionMembers (Shrubbery.appendBranches left right) + + taggedUnionNamed name tagProperty (TaggedUnionMembers builder) = + let + branches = + Shrubbery.taggedBranchBuild builder + + tagKey = + AesonKey.fromString tagProperty + in + FleeceToJSON name $ \value -> + let + (tagValue, fields) = + Shrubbery.dissectTaggedUnion branches value + in + Aeson.object ((tagKey, Aeson.toJSON tagValue) : fields) + + taggedUnionMemberWithTag :: + forall tag allTags a proxy. + KnownSymbol tag => + proxy tag -> + FC.Object FleeceToJSON a a -> + FC.TaggedUnionMembers FleeceToJSON allTags '[tag @= a] + taggedUnionMemberWithTag tag (Object mkFields) = + let + tagValue = + T.pack (symbolVal tag) + in + TaggedUnionMembers (Shrubbery.taggedSingleBranch @tag (\a -> (tagValue, mkFields a))) + + taggedUnionCombine (TaggedUnionMembers left) (TaggedUnionMembers right) = + TaggedUnionMembers (Shrubbery.appendTaggedBranches left right) + + jsonString (FleeceToJSON name toJSON) = + FleeceToJSON + name + ( Aeson.String + . Enc.decodeUtf8 + . LBS.toStrict + . Aeson.encode + . toJSON + ) diff --git a/json-fleece-core/json-fleece-core.cabal b/json-fleece-core/json-fleece-core.cabal index 16f8c8ca..d6dd81db 100644 --- a/json-fleece-core/json-fleece-core.cabal +++ b/json-fleece-core/json-fleece-core.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: json-fleece-core -version: 0.7.0.0 +version: 0.7.1.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues diff --git a/json-fleece-core/package.yaml b/json-fleece-core/package.yaml index c97d472f..b1595164 100644 --- a/json-fleece-core/package.yaml +++ b/json-fleece-core/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-core -version: 0.7.0.0 +version: 0.7.1.0 github: "flipstone/json-fleece/json-fleece-core" license: BSD3 author: "Author name here"