From a56e32229f3be4b5f5f3a1a9c369b9546b1f49d1 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 10 May 2019 13:57:20 +0100 Subject: [PATCH 1/3] add node stuff to gitignore --- .gitignore | 2 ++ package.json | 1 + 2 files changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index 760bddf..bfc53b1 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ bower_components/ output/ .psc-package .psc-ide-port +node_modules/ +yarn.lock diff --git a/package.json b/package.json index aa08719..9b50ad8 100644 --- a/package.json +++ b/package.json @@ -6,6 +6,7 @@ "test": "pulp test" }, "devDependencies": { + "bower": "^1.8.4", "pulp": "^12.0.0", "purescript": "^0.12.0", "purescript-psa": "^0.5.0", From 62d9609507d48f1700c9fa227e63106a6766e38f Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 10 May 2019 15:22:42 +0100 Subject: [PATCH 2/3] option to unwrap records Aeson unwraps a record argument to a constructor into the JSON object see http://hackage.haskell.org/package/aeson-1.4.0.0/docs/Data-Aeson.html#t:SumEncoding "If the constructor is a record the encoded record fields will be unpacked into this object" In this commit we add an option to TaggedObject to do this unwrapping but we leave the default behaviour as is --- package.json | 1 + src/Foreign/Generic.purs | 1 + src/Foreign/Generic/Class.purs | 21 ++++++++++++++++----- src/Foreign/Generic/Types.purs | 1 + test/Main.purs | 6 +++++- test/Types.purs | 33 +++++++++++++++++++++++++++++++++ 6 files changed, 57 insertions(+), 6 deletions(-) diff --git a/package.json b/package.json index 9b50ad8..eed8cda 100644 --- a/package.json +++ b/package.json @@ -3,6 +3,7 @@ "scripts": { "clean": "rimraf output && rimraf .pulp-cache", "build": "pulp build -- --censor-lib --strict", + "purs:ide": "purs ide server --log-level=debug 'bower_components/purescript-*/src/**/*.purs' 'src/**/*.purs' 'test/**/*.purs'", "test": "pulp test" }, "devDependencies": { diff --git a/src/Foreign/Generic.purs b/src/Foreign/Generic.purs index 0836fbd..4f846d4 100644 --- a/src/Foreign/Generic.purs +++ b/src/Foreign/Generic.purs @@ -32,6 +32,7 @@ defaultOptions = { tagFieldName: "tag" , contentsFieldName: "contents" , constructorTagTransform: identity + , unwrapRecords: false } , unwrapSingleConstructors: false , unwrapSingleArguments: true diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 1ec0a7d..1d78951 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -10,10 +10,10 @@ import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConst import Data.List (List(..), fromFoldable, null, singleton, toUnfoldable, (:)) import Data.Maybe (Maybe(..), maybe) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) -import Foreign (F, Foreign, ForeignError(..), fail, readArray, readString, unsafeToForeign) +import Foreign (F, Foreign, ForeignError(..), fail, isArray, readArray, readString, typeOf, unsafeFromForeign, unsafeToForeign) import Foreign.Class (class Encode, class Decode, encode, decode) import Foreign.Generic.Types (Options, SumEncoding(..)) -import Foreign.Index (index) +import Foreign.Index (hasProperty, index) import Foreign.Object (Object) import Foreign.Object as Object import Prim.Row (class Cons, class Lacks) @@ -56,7 +56,7 @@ instance genericDecodeConstructor if opts.unwrapSingleConstructors then Constructor <$> readArguments f else case opts.sumEncoding of - TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> do + TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform, unwrapRecords } -> do tag <- mapExcept (lmap (map (ErrorAtProperty tagFieldName))) do tag <- index f tagFieldName >>= readString let expected = constructorTagTransform ctorName @@ -64,13 +64,18 @@ instance genericDecodeConstructor fail (ForeignError ("Expected " <> show expected <> " tag")) pure tag args <- mapExcept (lmap (map (ErrorAtProperty contentsFieldName))) - (index f contentsFieldName >>= readArguments) + ((contents unwrapRecords contentsFieldName f) >>= readArguments) pure (Constructor args) where ctorName = reflectSymbol (SProxy :: SProxy name) numArgs = countArgs (Proxy :: Proxy rep) + contents :: Boolean -> String -> Foreign -> F Foreign + contents unwrapRecords contentsFieldName f' + | unwrapRecords && not (hasProperty contentsFieldName f') = pure f' + | otherwise = index f' contentsFieldName + readArguments args = case numArgs of Left a -> pure a @@ -95,10 +100,16 @@ instance genericEncodeConstructor else case opts.sumEncoding of TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> unsafeToForeign (Object.singleton tagFieldName (unsafeToForeign $ constructorTagTransform ctorName) - `Object.union` maybe Object.empty (Object.singleton contentsFieldName) (encodeArgsArray args)) + `Object.union` objectFromArgs opts.sumEncoding (encodeArgsArray args)) where ctorName = reflectSymbol (SProxy :: SProxy name) + objectFromArgs :: SumEncoding -> Maybe Foreign -> Object Foreign + objectFromArgs _ Nothing = Object.empty + objectFromArgs (TaggedObject { contentsFieldName, unwrapRecords }) (Just f) + | typeOf f == "object" && not isArray f && unwrapRecords = unsafeFromForeign f + | otherwise = Object.singleton contentsFieldName f + encodeArgsArray :: rep -> Maybe Foreign encodeArgsArray = unwrapArguments <<< toUnfoldable <<< encodeArgs opts diff --git a/src/Foreign/Generic/Types.purs b/src/Foreign/Generic/Types.purs index 3a6b023..6a562e5 100644 --- a/src/Foreign/Generic/Types.purs +++ b/src/Foreign/Generic/Types.purs @@ -15,4 +15,5 @@ data SumEncoding { tagFieldName :: String , contentsFieldName :: String , constructorTagTransform :: String -> String + , unwrapRecords :: Boolean } diff --git a/test/Main.purs b/test/Main.purs index 306cc2b..3df7858 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -22,7 +22,7 @@ import Foreign.JSON (parseJSON) import Foreign.Object as Object import Global.Unsafe (unsafeStringify) import Test.Assert (assert, assert') -import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..)) +import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a buildTree _ 0 a = Leaf a @@ -128,6 +128,10 @@ testNothingFromMissing = main :: Effect Unit main = do testRoundTrip (RecordTest { foo: 1, bar: "test", baz: 'a' }) + testRoundTrip NoArgs + testRoundTrip (SomeArg "some argument") + testRoundTrip (ManyArgs "fst" "snd") + testRoundTrip (RecordArgs { foo: 1, bar: "test", baz: 'a' }) testRoundTrip (Cons 1 (Cons 2 (Cons 3 Nil))) testRoundTrip (UndefinedTest {a: Just "test"}) testRoundTrip (UndefinedTest {a: Nothing}) diff --git a/test/Types.purs b/test/Types.purs index c97e690..10eb3a5 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -57,6 +57,38 @@ instance decodeRecordTest :: Decode RecordTest where instance encodeRecordTest :: Encode RecordTest where encode x = genericEncode (defaultOptions { unwrapSingleConstructors = true }) x +-- | A sum type with record args +data SumWithRecord + = NoArgs + | SomeArg String + | ManyArgs String String + | RecordArgs + { foo :: Int + , bar :: String + , baz :: Char + } + +derive instance genericSumWithRecord :: Generic SumWithRecord _ + +instance showSumWithRecord :: Show SumWithRecord where + show x = genericShow x + +instance eqSumWithRecord :: Eq SumWithRecord where + eq x y = genericEq x y + +unwrapRecordsEncoding :: SumEncoding +unwrapRecordsEncoding = TaggedObject { tagFieldName: "tag" + , contentsFieldName: "contents" + , constructorTagTransform: identity + , unwrapRecords: true + } + +instance decodeSumWithRecord :: Decode SumWithRecord where + decode x = genericDecode (defaultOptions { unwrapSingleConstructors = true, sumEncoding = unwrapRecordsEncoding }) x + +instance encodeSumWithRecord :: Encode SumWithRecord where + encode x = genericEncode (defaultOptions { unwrapSingleConstructors = true, sumEncoding = unwrapRecordsEncoding }) x + -- | An example of an ADT with nullary constructors data IntList = Nil | Cons Int IntList @@ -76,6 +108,7 @@ intListOptions = , constructorTagTransform: \tag -> case tag of "Cons" -> "cOnS" _ -> "" + , unwrapRecords: false } } From 8c8fe8469a53b4ba2906add14d2d831b081ad587 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 10 May 2019 17:28:32 +0100 Subject: [PATCH 3/3] make life easier with a default sum encoding for aeson --- src/Foreign/Generic.purs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Foreign/Generic.purs b/src/Foreign/Generic.purs index 4f846d4..5233219 100644 --- a/src/Foreign/Generic.purs +++ b/src/Foreign/Generic.purs @@ -1,5 +1,6 @@ module Foreign.Generic ( defaultOptions + , aesonSumEncoding , genericDecode , genericEncode , decodeJSON @@ -38,6 +39,15 @@ defaultOptions = , unwrapSingleArguments: true , fieldTransform: identity } + +-- | Aeson unwraps records, use this sum encoding with Aeson generated json +aesonSumEncoding :: SumEncoding +aesonSumEncoding = TaggedObject + { tagFieldName: "tag" + , contentsFieldName: "contents" + , constructorTagTransform: identity + , unwrapRecords: true + } -- | Read a value which has a `Generic` type. genericDecode