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..210c5eb1 --- /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 + ( ToValue (..) + , toValue + ) 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 + +toValue :: ToValue a -> a -> Aeson.Value +toValue (ToValue _name f) = + f + +data ToValue a + = ToValue FC.Name (a -> Aeson.Value) + +instance FC.Fleece ToValue where + newtype Object ToValue object _constructor + = Object (object -> [AesonTypes.Pair]) + + newtype Field ToValue object _a + = Field (object -> [AesonTypes.Pair]) + + newtype AdditionalFields ToValue object _a + = AdditionalFields (object -> [AesonTypes.Pair]) + + newtype UnionMembers ToValue _allTypes handledTypes + = UnionMembers (Shrubbery.BranchBuilder handledTypes Aeson.Value) + + newtype TaggedUnionMembers ToValue _allTypes handledTypes + = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTypes (T.Text, [AesonTypes.Pair])) + + schemaName (ToValue name _toJSON) = + name + + number = + ToValue (FC.unqualifiedName "number") Aeson.toJSON + + text = + ToValue (FC.unqualifiedName "text") Aeson.toJSON + + boolean = + ToValue (FC.unqualifiedName "boolean") Aeson.toJSON + + null = + ToValue + (FC.unqualifiedName "null") + (\FC.Null -> Aeson.Null) + + array (ToValue name itemToJSON) = + ToValue + (FC.annotateName name "array") + (Aeson.Array . fmap itemToJSON) + + nullable (ToValue name toJSON) = + ToValue (FC.annotateName name "nullable") $ \mbValue -> + case mbValue of + Left FC.Null -> Aeson.Null + Right value -> toJSON value + + required name accessor (ToValue _name toJSON) = + let + key = AesonKey.fromString name + in + Field $ \object -> + [(key, toJSON (accessor object))] + + optional name accessor (ToValue _name toJSON) = + let + key = AesonKey.fromString name + in + Field $ \object -> + case accessor object of + Just value -> + [(key, toJSON value)] + Nothing -> + [] + + additionalFields accessor (ToValue _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) = + ToValue name (Aeson.object . toObject) + + boundedEnumNamed name toText = + ToValue name (Aeson.toJSON . toText) + + validateNamed name uncheck _check (ToValue _unvalidatedName toJSON) = + ToValue name (toJSON . uncheck) + + unionNamed name (UnionMembers builder) = + let + branches = + Shrubbery.branchBuild builder + in + ToValue 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. + ToValue _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 + ToValue 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 ToValue a a -> + FC.TaggedUnionMembers ToValue 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 (ToValue name toJSON) = + ToValue + 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"