From 68a1e4737e5ed70999b53715ed4e230dfb9fbe10 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 10 May 2019 13:57:20 +0100 Subject: [PATCH 01/42] 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 736a8dda32f1e4e58931727ef4b24b5b44dc64be Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 12:48:54 +0100 Subject: [PATCH 02/42] rebase upstream master and add spago --- .gitignore | 1 + package.json | 1 + packages.dhall | 128 +++++++++++++++++++++++++++++++++ spago.dhall | 22 ++++++ src/Foreign/Generic/Class.purs | 32 +++++++-- test/Main.purs | 6 +- test/Types.purs | 33 +++++++++ 7 files changed, 217 insertions(+), 6 deletions(-) create mode 100644 packages.dhall create mode 100644 spago.dhall diff --git a/.gitignore b/.gitignore index bfc53b1..06fda40 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ output/ .psc-ide-port node_modules/ yarn.lock +.spago 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/packages.dhall b/packages.dhall new file mode 100644 index 0000000..97dadbd --- /dev/null +++ b/packages.dhall @@ -0,0 +1,128 @@ +{- +Welcome to your new Dhall package-set! + +Below are instructions for how to edit this file for most use +cases, so that you don't need to know Dhall to use it. + +## Warning: Don't Move This Top-Level Comment! + +Due to how `dhall format` currently works, this comment's +instructions cannot appear near corresponding sections below +because `dhall format` will delete the comment. However, +it will not delete a top-level comment like this one. + +## Use Cases + +Most will want to do one or both of these options: +1. Override/Patch a package's dependency +2. Add a package not already in the default package set + +This file will continue to work whether you use one or both options. +Instructions for each option are explained below. + +### Overriding/Patching a package + +Purpose: +- Change a package's dependency to a newer/older release than the + default package set's release +- Use your own modified version of some dependency that may + include new API, changed API, removed API by + using your custom git repo of the library rather than + the package set's repo + +Syntax: +Replace the overrides' "{=}" (an empty record) with the following idea +The "//" or "⫽" means "merge these two records and + when they have the same value, use the one on the right:" +------------------------------- +let override = + { packageName = + upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" } + , packageName = + upstream.packageName // { version = "v4.0.0" } + , packageName = + upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" } + } +------------------------------- + +Example: +------------------------------- +let overrides = + { halogen = + upstream.halogen // { version = "master" } + , halogen-vdom = + upstream.halogen-vdom // { version = "v4.0.0" } + } +------------------------------- + +### Additions + +Purpose: +- Add packages that aren't already included in the default package set + +Syntax: +Replace the additions' "{=}" (an empty record) with the following idea: +------------------------------- +let additions = + { package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "tag ('v4.0.0') or branch ('master')" + } + , package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "tag ('v4.0.0') or branch ('master')" + } + , etc. + } +------------------------------- + +Example: +------------------------------- +let additions = + { benchotron = + { dependencies = + [ "arrays" + , "exists" + , "profunctor" + , "strings" + , "quickcheck" + , "lcg" + , "transformers" + , "foldable-traversable" + , "exceptions" + , "node-fs" + , "node-buffer" + , "node-readline" + , "datetime" + , "now" + ] + , repo = + "https://github.com/hdgarrood/purescript-benchotron.git" + , version = + "v7.0.0" + } + } +------------------------------- +-} + + +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20200724/packages.dhall sha256:bb941d30820a49345a0e88937094d2b9983d939c9fd3a46969b85ce44953d7d9 + +let overrides = {=} + +let additions = {=} + +in upstream // overrides // additions diff --git a/spago.dhall b/spago.dhall new file mode 100644 index 0000000..74fbbf9 --- /dev/null +++ b/spago.dhall @@ -0,0 +1,22 @@ +{- +Welcome to a Spago project! +You can edit this file as you like. +-} +{ name = "foreign-generic" +, dependencies = + [ "assert" + , "console" + , "effect" + , "exceptions" + , "foreign" + , "foreign-object" + , "generics-rep" + , "identity" + , "ordered-collections" + , "proxy" + , "psci-support" + , "record" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs", "test/**/*.purs" ] +} diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 9370082..94ffce7 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -15,10 +15,10 @@ import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence) -import Foreign (F, Foreign, ForeignError(..), fail, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign) +import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign, unsafeFromForeign) import Foreign.Generic.Internal (readObject) -import Foreign.Index (index) import Foreign.NullOrUndefined (readNullOrUndefined, null) +import Foreign.Index (hasProperty, index) import Foreign.Object (Object) import Foreign.Object as Object import Prim.Row (class Cons, class Lacks) @@ -48,6 +48,7 @@ data SumEncoding { tagFieldName :: String , contentsFieldName :: String , constructorTagTransform :: String -> String + , unwrapRecords :: Boolean } -- | Default decoding/encoding options: @@ -64,12 +65,22 @@ defaultOptions = { tagFieldName: "tag" , contentsFieldName: "contents" , constructorTagTransform: identity + , unwrapRecords: false } , unwrapSingleConstructors: false , 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 + } + -- | The `Decode` class is used to generate decoding functions -- | of the form `Foreign -> F a` using `generics-rep` deriving. -- | @@ -288,7 +299,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 @@ -296,13 +307,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 @@ -327,10 +343,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 <<< List.toUnfoldable <<< encodeArgs opts diff --git a/test/Main.purs b/test/Main.purs index 1c80643..de800b2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -19,7 +19,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 @@ -125,6 +125,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 3c51ea5..e915ff0 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -55,6 +55,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 @@ -74,6 +106,7 @@ intListOptions = , constructorTagTransform: \tag -> case tag of "Cons" -> "cOnS" _ -> "" + , unwrapRecords: false } } From 090a0c9737faf8b48895974dc1cac4e4940b5f59 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 13:10:19 +0100 Subject: [PATCH 03/42] add List decode/encode --- src/Foreign/Generic/Class.purs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 94ffce7..6e0acd8 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -134,6 +134,9 @@ instance arrayDecode :: Decode a => Decode (Array a) where readElement :: Int -> Foreign -> F a readElement i value = mapExcept (lmap (map (ErrorAtIndex i))) (decode value) +instance listDecode :: Decode a => Decode (List a) where + decode f = let (array :: F (Array a)) = decode f in List.fromFoldable <$> array + instance maybeDecode :: Decode a => Decode (Maybe a) where decode = readNullOrUndefined decode @@ -191,6 +194,9 @@ instance identityEncode :: Encode a => Encode (Identity a) where instance arrayEncode :: Encode a => Encode (Array a) where encode = unsafeToForeign <<< map encode +instance listEncode :: Encode a => Encode (List a) where + encode f = let (arr :: Array a) = List.toUnfoldable f in encode arr + instance maybeEncode :: Encode a => Encode (Maybe a) where encode = maybe null encode From f34d0c3e36156c7184f7864ac20d0bff529dc103 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 15:45:23 +0100 Subject: [PATCH 04/42] encode/decode tuple using array as this is what is normally done --- src/Foreign/Generic/Class.purs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 6e0acd8..a5e334a 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -15,6 +15,7 @@ import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence) +import Data.Tuple (Tuple(..)) import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign, unsafeFromForeign) import Foreign.Generic.Internal (readObject) import Foreign.NullOrUndefined (readNullOrUndefined, null) @@ -137,6 +138,13 @@ instance arrayDecode :: Decode a => Decode (Array a) where instance listDecode :: Decode a => Decode (List a) where decode f = let (array :: F (Array a)) = decode f in List.fromFoldable <$> array +instance tupleDecode :: (Decode a, Decode b) => Decode (Tuple a b) where + decode f = do + (arr :: Array Foreign) <- decode f + case arr of + [a, b] -> Tuple <$> decode a <*> decode b + _ -> except (Left (pure (ForeignError "Decode: Tuple was not a list of exactly 2 items"))) + instance maybeDecode :: Decode a => Decode (Maybe a) where decode = readNullOrUndefined decode @@ -197,6 +205,9 @@ instance arrayEncode :: Encode a => Encode (Array a) where instance listEncode :: Encode a => Encode (List a) where encode f = let (arr :: Array a) = List.toUnfoldable f in encode arr +instance encodeTuple :: (Encode a, Encode b) => Encode (Tuple a b) where + encode (Tuple a b) = unsafeToForeign [encode a, encode b] + instance maybeEncode :: Encode a => Encode (Maybe a) where encode = maybe null encode From 9fcc6eef13096809d4f9ae5357f40b9d857a5e8a Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 16:07:15 +0100 Subject: [PATCH 05/42] encode/decode Map using array of tuples, not sure there is another way --- src/Foreign/Generic/Class.purs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index a5e334a..e7b2189 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -11,6 +11,8 @@ import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConst import Data.Identity (Identity(..)) import Data.List (List(..), (:)) import Data.List as List +import Data.Map (Map) +import Data.Map as Map import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) @@ -154,6 +156,11 @@ instance objectDecode :: Decode v => Decode (Object v) where instance recordDecode :: (RowToList r rl, DecodeRecord r rl) => Decode (Record r) where decode = decodeWithOptions defaultOptions +instance mapDecode :: (Ord k, Decode k, Decode v) => Decode (Map k v) where + decode f = do + (tuple :: Array (Tuple k v)) <- decode f + pure $ Map.fromFoldable tuple + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -217,6 +224,9 @@ instance objectEncode :: Encode v => Encode (Object v) where instance recordEncode :: (RowToList r rl, EncodeRecord r rl) => Encode (Record r) where encode = encodeWithOptions defaultOptions +instance mapEncode :: (Encode k, Encode v) => Encode (Map k v) where + encode m = encode (Map.toUnfoldable m :: Array _) + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. From fd7f49f47061f708021064e17bb11b193ab389a3 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 16:26:24 +0100 Subject: [PATCH 06/42] encode/decode Set using array --- src/Foreign/Generic/Class.purs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index e7b2189..640e41c 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -15,6 +15,8 @@ import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) +import Data.Set (Set) +import Data.Set as Set import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence) import Data.Tuple (Tuple(..)) @@ -161,6 +163,11 @@ instance mapDecode :: (Ord k, Decode k, Decode v) => Decode (Map k v) where (tuple :: Array (Tuple k v)) <- decode f pure $ Map.fromFoldable tuple +instance setDecode :: (Ord a, Decode a) => Decode (Set a) where + decode f = do + (arr :: Array a) <- decode f + pure $ Set.fromFoldable arr + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -227,6 +234,9 @@ instance recordEncode :: (RowToList r rl, EncodeRecord r rl) => Encode (Record r instance mapEncode :: (Encode k, Encode v) => Encode (Map k v) where encode m = encode (Map.toUnfoldable m :: Array _) +instance setEncode :: (Ord a, Encode a) => Encode (Set a) where + encode s = let (arr :: Array a) = Set.toUnfoldable s in encode arr + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. From d356fd2bf4943e8a85f7d9da5af2ecd12301a48c Mon Sep 17 00:00:00 2001 From: David Smith Date: Mon, 17 Aug 2020 11:16:43 +0100 Subject: [PATCH 07/42] upgrade purs --- bower.json | 14 +++++--------- package.json | 10 +++++----- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/bower.json b/bower.json index fe2c285..59a51f6 100644 --- a/bower.json +++ b/bower.json @@ -15,18 +15,14 @@ "url": "git://github.com/paf31/purescript-foreign-generic.git" }, "dependencies": { - "purescript-effect": "^2.0.0", + "purescript-prelude": "^4.1.1", "purescript-foreign": "^5.0.0", - "purescript-foreign-object": "^2.0.0", - "purescript-generics-rep": "^6.0.0", - "purescript-ordered-collections": "^1.0.0", - "purescript-proxy": "^3.0.0", - "purescript-exceptions": "^4.0.0", - "purescript-record": "^2.0.0", - "purescript-identity": "^4.1.0" + "purescript-generics-rep": "^6.1.1", + "purescript-foreign-object": "^2.0.3", + "purescript-record": "^2.0.1" }, "devDependencies": { - "purescript-assert": "^4.0.0", + "purescript-assert": "^4.1.0", "purescript-psci-support": "^4.0.0" } } diff --git a/package.json b/package.json index eed8cda..2b386b1 100644 --- a/package.json +++ b/package.json @@ -7,10 +7,10 @@ "test": "pulp test" }, "devDependencies": { - "bower": "^1.8.4", - "pulp": "^12.0.0", - "purescript": "^0.12.0", - "purescript-psa": "^0.5.0", - "rimraf": "^2.5.0" + "bower": "^1.8.8", + "pulp": "^13.0.0", + "purescript": "^0.13.3", + "purescript-psa": "^0.7.3", + "rimraf": "^3.0.0" } } From db3685ac6acfeb9ffa058c99f2fae20fe1a2ca02 Mon Sep 17 00:00:00 2001 From: David Smith Date: Mon, 17 Aug 2020 12:06:08 +0100 Subject: [PATCH 08/42] use spago in travis --- .travis.yml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index ebd09cd..d6d36ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,10 +3,8 @@ dist: trusty sudo: required node_js: stable install: - - npm install -g bower + - npm install -g purescript-spago - npm install script: - - bower install --production - - npm run -s build - - bower install - - npm run -s test + - spago build + - spago test From e9064e267785da9e108cda7dd3addeba277b6840 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 14:36:17 +0100 Subject: [PATCH 09/42] Adding a roundtrip test for Map. --- test/Main.purs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Main.purs b/test/Main.purs index de800b2..f7b88d6 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -6,6 +6,7 @@ import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) +import Data.Map as Map import Data.Maybe (Maybe(..), isNothing) import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) @@ -138,6 +139,7 @@ main = do testRoundTrip (makeTree 0) testRoundTrip (makeTree 5) testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) + testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From 26bc66f9508676544dbeb1a6afb9f49e1c9c3630 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 14:36:30 +0100 Subject: [PATCH 10/42] More flexible Map decoding. Sometimes Aeson encodes maps as objects with string keys, or as `null`. We can now decode these cases. --- src/Foreign/Generic/Class.purs | 42 +++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 640e41c..2146675 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -18,12 +18,13 @@ import Data.Newtype (unwrap) import Data.Set (Set) import Data.Set as Set import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) -import Data.Traversable (sequence) +import Data.Traversable (sequence, traverse) import Data.Tuple (Tuple(..)) -import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign, unsafeFromForeign) +import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, unsafeToForeign, unsafeFromForeign) import Foreign.Generic.Internal (readObject) +import Foreign.Index (hasProperty, index, readProp) +import Foreign.Keys as Keys import Foreign.NullOrUndefined (readNullOrUndefined, null) -import Foreign.Index (hasProperty, index) import Foreign.Object (Object) import Foreign.Object as Object import Prim.Row (class Cons, class Lacks) @@ -159,9 +160,38 @@ instance recordDecode :: (RowToList r rl, DecodeRecord r rl) => Decode (Record r decode = decodeWithOptions defaultOptions instance mapDecode :: (Ord k, Decode k, Decode v) => Decode (Map k v) where - decode f = do - (tuple :: Array (Tuple k v)) <- decode f - pure $ Map.fromFoldable tuple + decode json = decodeAsArrayOfPairs json <|> decodeAsObjectWithStringKeys json <|> decodeAsNull json + where + decodeAsArrayOfPairs o = do + pairs <- readArray o + asArray <- + traverse + ( \foreignPair -> + readArray foreignPair + >>= case _ of + [ foreignKey, foreignValue ] -> Tuple <$> decode foreignKey <*> decode foreignValue + other -> fail $ TypeMismatch "Array (key-value pair)" "" + ) + pairs + pure $ Map.fromFoldable asArray + + decodeAsObjectWithStringKeys o = do + keys <- Keys.keys o + asArray <- + traverse + ( \keyString -> do + foreignValue <- readProp keyString o + key <- decode $ encode keyString + value <- decode foreignValue + pure (Tuple key value) + ) + keys + pure $ Map.fromFoldable asArray + + decodeAsNull o = do + _ <- readNull o + pure mempty + instance setDecode :: (Ord a, Decode a) => Decode (Set a) where decode f = do From 16989ec9db1453979a2edbe9ceb229dc70553bf9 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 14:41:46 +0100 Subject: [PATCH 11/42] Adding encoders/decoders for Either. --- src/Foreign/Generic/Class.purs | 11 +++++++++++ test/Main.purs | 1 + 2 files changed, 12 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 2146675..7d8663a 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -198,6 +198,12 @@ instance setDecode :: (Ord a, Decode a) => Decode (Set a) where (arr :: Array a) <- decode f pure $ Set.fromFoldable arr +instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where + decode value = + (readProp "Left" value >>= (map Left <<< decode)) + <|> + (readProp "Right" value >>= (map Right <<< decode)) + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -267,6 +273,11 @@ instance mapEncode :: (Encode k, Encode v) => Encode (Map k v) where instance setEncode :: (Ord a, Encode a) => Encode (Set a) where encode s = let (arr :: Array a) = Set.toUnfoldable s in encode arr + +instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where + encode (Left a) = encode $ Object.singleton "Left" a + encode (Right b) = encode $ Object.singleton "Right" b + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. diff --git a/test/Main.purs b/test/Main.purs index f7b88d6..e9a2e0d 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -140,6 +140,7 @@ main = do testRoundTrip (makeTree 5) testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) + testRoundTrip [ Left 5, Right "Test" ] testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From 1e0b95f167879e331e05c7b1f13d03cec95cfb2f Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 16:15:45 +0100 Subject: [PATCH 12/42] Adding Data.BigInt support. --- bower.json | 3 ++- package.json | 3 +++ spago.dhall | 1 + src/Foreign/Generic/Class.purs | 12 +++++++++++- test/Main.purs | 2 ++ 5 files changed, 19 insertions(+), 2 deletions(-) diff --git a/bower.json b/bower.json index 59a51f6..b6e3512 100644 --- a/bower.json +++ b/bower.json @@ -19,7 +19,8 @@ "purescript-foreign": "^5.0.0", "purescript-generics-rep": "^6.1.1", "purescript-foreign-object": "^2.0.3", - "purescript-record": "^2.0.1" + "purescript-record": "^2.0.1", + "purescript-bigints": "^4.0.0" }, "devDependencies": { "purescript-assert": "^4.1.0", diff --git a/package.json b/package.json index 2b386b1..fe2953b 100644 --- a/package.json +++ b/package.json @@ -12,5 +12,8 @@ "purescript": "^0.13.3", "purescript-psa": "^0.7.3", "rimraf": "^3.0.0" + }, + "dependencies": { + "big-integer": "^1.6.48" } } diff --git a/spago.dhall b/spago.dhall index 74fbbf9..6da6e65 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,6 +5,7 @@ You can edit this file as you like. { name = "foreign-generic" , dependencies = [ "assert" + , "bigints" , "console" , "effect" , "exceptions" diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 7d8663a..94db9ac 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -6,7 +6,9 @@ import Control.Alt ((<|>)) import Control.Monad.Except (except, mapExcept) import Data.Array ((..), zipWith, length) import Data.Bifunctor (lmap) -import Data.Either (Either(..)) +import Data.BigInt (BigInt) +import Data.BigInt as BigInt +import Data.Either (Either(..), note) import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConstructors, Product(..), Sum(..)) import Data.Identity (Identity(..)) import Data.List (List(..), (:)) @@ -204,6 +206,11 @@ instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where <|> (readProp "Right" value >>= (map Right <<< decode)) +instance bigIntDecode :: Decode BigInt where + decode value = do + str <- readString value + except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -278,6 +285,9 @@ instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where encode (Left a) = encode $ Object.singleton "Left" a encode (Right b) = encode $ Object.singleton "Right" b +instance bigIntEncode :: Encode BigInt where + encode = encode <<< BigInt.toString + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. diff --git a/test/Main.purs b/test/Main.purs index e9a2e0d..7886ef1 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -4,6 +4,7 @@ import Prelude import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) +import Data.BigInt as BigInt import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Map as Map @@ -141,6 +142,7 @@ main = do testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip [ Left 5, Right "Test" ] + testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 will confuse JavaScript. testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From ecd14aec0fd674c1b18343da1bab34c018547ed3 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 16:31:39 +0100 Subject: [PATCH 13/42] Adding a shell.nix file, for a repeatable env. --- shell.nix | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 shell.nix diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..89138f3 --- /dev/null +++ b/shell.nix @@ -0,0 +1,30 @@ +{ pkgs ? import ( + builtins.fetchTarball { + name = "nixos-20.03"; + url = "https://github.com/NixOS/nixpkgs/archive/5272327b81ed355bbed5659b8d303cf2979b6953.tar.gz"; + sha256 = "0182ys095dfx02vl2a20j1hz92dx3mfgz2a6fhn31bqlp1wa8hlq"; + } + ) + {} +}: +let + easyPS = import ( + builtins.fetchTarball { + name = "easy-purescript"; + url = "https://github.com/justinwoo/easy-purescript-nix/archive/1ec689df0adf8e8ada7fcfcb513876307ea34226.tar.gz"; + sha256 = "12hk2zbjkrq2i5fs6xb3x254lnhm9fzkcxph0a7ngxyzfykvf4hi"; + } + ) {}; +in +pkgs.mkShell { + buildInputs = [ + pkgs.git + pkgs.yarn + pkgs.nodePackages.bower + pkgs.nodePackages.pulp + pkgs.nodejs + easyPS.spago + easyPS.purs + easyPS.purty + ]; +} From b77bf997a5370361643cde97dd8281ee624d113d Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 4 Sep 2020 14:59:49 +0100 Subject: [PATCH 14/42] Adding extra map-decoding tests. --- test/Main.purs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/test/Main.purs b/test/Main.purs index 7886ef1..b7a5af9 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -8,6 +8,7 @@ import Data.BigInt as BigInt import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Map as Map +import Data.Map (Map) import Data.Maybe (Maybe(..), isNothing) import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) @@ -20,7 +21,7 @@ import Foreign.Index (readProp) import Foreign.JSON (parseJSON) import Foreign.Object as Object import Global.Unsafe (unsafeStringify) -import Test.Assert (assert, assert') +import Test.Assert (assert, assert', assertEqual) import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a @@ -141,6 +142,12 @@ main = do testRoundTrip (makeTree 5) testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) + assertEqual { expected: Right (Map.fromFoldable [Tuple "foo" 5]) + , actual: runExcept (decodeJSON "{\"foo\": 5}") + } + assertEqual { expected: Right (Map.empty :: Map String Int) + , actual: runExcept (decodeJSON "null") + } testRoundTrip [ Left 5, Right "Test" ] testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 will confuse JavaScript. testUnaryConstructorLiteral From 4963d867034011350c69335aaa6e48c538cd781d Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 4 Sep 2020 15:00:45 +0100 Subject: [PATCH 15/42] Improving the resiliency of BigInt decoding. It will now decode ints as well. Note that this is just us being more tolerant of recieving something like `1234`. If the number sent is actually in the "big" integer range (>2^32) then it won't work and it's the sender's fault. The JSON spec doesn't support numbers that big. They'd have to be sent as strings. --- src/Foreign/Generic/Class.purs | 11 ++++++++--- test/Main.purs | 5 ++++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 94db9ac..a717c5f 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -207,9 +207,14 @@ instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where (readProp "Right" value >>= (map Right <<< decode)) instance bigIntDecode :: Decode BigInt where - decode value = do - str <- readString value - except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str + decode json = decodeAsString json <|> decodeAsDigits json + where + decodeAsString value = do + str <- readString value + except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str + decodeAsDigits value = do + int <- readInt value + pure $ BigInt.fromInt int -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. diff --git a/test/Main.purs b/test/Main.purs index b7a5af9..e31b198 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -149,7 +149,10 @@ main = do , actual: runExcept (decodeJSON "null") } testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 will confuse JavaScript. + testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. + assertEqual { expected: Right (BigInt.fromInt 50) + , actual: runExcept (decodeJSON "50") + } testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From bd0a108a983d26b2c0502ae5de02efdc1e5370a3 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 8 Sep 2020 11:48:16 +0100 Subject: [PATCH 16/42] Improved encoding/decoding for big integers. Instead of encoding them as strings, we use numbers. 'Improved' is somewhat subjective here. More likely to be successfully read and written, perhaps less likely to be correct in all cases. Sadly I don't see a good alternative short of forking all the consuming libraries too. --- src/Foreign/Generic/Class.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index a717c5f..a445747 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -213,8 +213,8 @@ instance bigIntDecode :: Decode BigInt where str <- readString value except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str decodeAsDigits value = do - int <- readInt value - pure $ BigInt.fromInt int + number <- readNumber value + except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromNumber number -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. @@ -291,7 +291,7 @@ instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where encode (Right b) = encode $ Object.singleton "Right" b instance bigIntEncode :: Encode BigInt where - encode = encode <<< BigInt.toString + encode = unsafeToForeign <<< BigInt.toNumber -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) From 1f6a328e55269222af22c91448a748264a1b7592 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 11 Sep 2020 10:29:35 +0100 Subject: [PATCH 17/42] Moving to a more formal test suite. Since we no longer care about introducing a dependency on test-unit, let's tidy up the ad-hoc test framework. --- spago.dhall | 1 + test/Main.purs | 217 ++++++++++++++++++++++++------------------------ test/Types.purs | 4 + 3 files changed, 115 insertions(+), 107 deletions(-) diff --git a/spago.dhall b/spago.dhall index 6da6e65..ffb6a81 100644 --- a/spago.dhall +++ b/spago.dhall @@ -13,6 +13,7 @@ You can edit this file as you like. , "foreign-object" , "generics-rep" , "identity" + , "test-unit" , "ordered-collections" , "proxy" , "psci-support" diff --git a/test/Main.purs b/test/Main.purs index e31b198..54946cf 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,19 +1,17 @@ module Test.Main where import Prelude - import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.BigInt as BigInt import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) -import Data.Map as Map import Data.Map (Map) +import Data.Map as Map import Data.Maybe (Maybe(..), isNothing) import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) import Effect (Effect) -import Effect.Console (log) import Foreign (isNull, unsafeToForeign) import Foreign.Generic (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, encode, defaultOptions, decodeJSON, encodeJSON, genericDecodeJSON, genericEncodeJSON) import Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum) @@ -21,11 +19,15 @@ import Foreign.Index (readProp) import Foreign.JSON (parseJSON) import Foreign.Object as Object import Global.Unsafe (unsafeStringify) -import Test.Assert (assert, assert', assertEqual) +import Test.Assert (assert') import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) +import Test.Unit (TestSuite, failure, success, suite, test) +import Test.Unit.Assert (equal) +import Test.Unit.Main (runTest) buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a buildTree _ 0 a = Leaf a + buildTree f n a = Branch $ buildTree (bimap f f) (n - 1) (f a) -- A balanced binary tree of depth N @@ -35,126 +37,127 @@ makeTree n = buildTree (\i -> TupleArray (Tuple (2 * i) (2 * i + 1))) n 0 throw :: String -> Effect Unit throw = flip assert' false -testRoundTrip - :: ∀ a - . Eq a - => Decode a - => Encode a - => a - -> Effect Unit -testRoundTrip x = do - let json = encodeJSON x - log json - case runExcept (decodeJSON json) of - Right y -> assert (x == y) - Left err -> throw (show err) +testRoundTrip :: + ∀ a. + Eq a => + Show a => + Decode a => + Encode a => + a -> + TestSuite +testRoundTrip x = + test ("RoundTrip " <> show x) do + equal (Right x) (runExcept (decodeJSON (encodeJSON x))) -testGenericRoundTrip - :: ∀ a r - . Eq a - => Generic a r - => GenericDecode r - => GenericEncode r - => Options - -> a - -> Effect Unit -testGenericRoundTrip opts x = do - let json = genericEncodeJSON opts x - log json - case runExcept (genericDecodeJSON opts json) of - Right y -> assert (x == y) - Left err -> throw (show err) +testGenericRoundTrip :: + ∀ a r. + Eq a => + Show a => + Generic a r => + GenericDecode r => + GenericEncode r => + Options -> + a -> + TestSuite +testGenericRoundTrip opts x = + test ("Generic roundtrip " <> show x) do + equal (Right x) (runExcept (genericDecodeJSON opts (genericEncodeJSON opts x))) -testOption - :: ∀ a rep - . Eq a - => Generic a rep - => GenericEncodeEnum rep - => GenericDecodeEnum rep - => GenericEnumOptions - -> String - -> a - -> Effect Unit -testOption options string value = do - let json = unsafeStringify $ genericEncodeEnum options value - log json - case runExcept $ Tuple <$> decode' json <*> decode' string of - Right (Tuple x y) -> assert (value == y && value == x) - Left err -> throw (show err) +testOption :: + ∀ a rep. + Eq a => + Show a => + Generic a rep => + GenericEncodeEnum rep => + GenericDecodeEnum rep => + GenericEnumOptions -> + String -> + a -> + TestSuite +testOption options string value = + test "testOption" do + let + json = unsafeStringify $ genericEncodeEnum options value + equal (Right value) (runExcept (decode' json)) + equal (Right value) (runExcept (decode' string)) where - decode' = genericDecodeEnum options <=< parseJSON + decode' = genericDecodeEnum options <=< parseJSON -testUnaryConstructorLiteral :: Effect Unit +testUnaryConstructorLiteral :: TestSuite testUnaryConstructorLiteral = do - testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel - testOption (makeCasingOptions toLower) "\"frikandel\"" Frikandel + testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel + testOption (makeCasingOptions toLower) "\"frikandel\"" Frikandel where - makeCasingOptions f = - { constructorTagTransform: f - } + makeCasingOptions f = + { constructorTagTransform: f + } -- Test that `Nothing` record fields, when encoded to JSON, are present and -- encoded as `null` -testNothingToNull :: Effect Unit +testNothingToNull :: TestSuite testNothingToNull = - let - json = encode (UndefinedTest {a: Nothing}) - in do - log (encodeJSON json) + test "Nothing to Null" do + let json = encode (UndefinedTest { a: Nothing }) case runExcept (pure json >>= readProp "contents" >>= readProp "a") of Right val -> - when (not (isNull val)) - (throw ("property 'a' was not null; got: " <> encodeJSON val)) - Left err -> - throw (show err) + if (isNull val) then + success + else + failure ("property 'a' was not null; got: " <> encodeJSON val) + Left err -> failure (show err) -- Test that `Maybe` fields which are not present in the JSON are decoded to -- `Nothing` -testNothingFromMissing :: Effect Unit +testNothingFromMissing :: TestSuite testNothingFromMissing = - let - json = unsafeToForeign - { tag: "UndefinedTest" - , contents: 0 - } - in + test "Nothing from missing" do + let + json = + unsafeToForeign + { tag: "UndefinedTest" + , contents: 0 + } case runExcept (decode json) of Right (UndefinedTest x) -> - when (not (isNothing x.a)) - (throw ("Expected Nothing, got: " <> show x.a)) - Left err -> - throw (show err) + if (isNothing x.a) then + success + else + failure ("Expected Nothing, got: " <> show x.a) + Left err -> failure (show err) 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}) - testRoundTrip [Just "test"] - testRoundTrip [Nothing :: Maybe String] - testRoundTrip (Apple) - testRoundTrip (makeTree 0) - testRoundTrip (makeTree 5) - testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) - testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) - assertEqual { expected: Right (Map.fromFoldable [Tuple "foo" 5]) - , actual: runExcept (decodeJSON "{\"foo\": 5}") - } - assertEqual { expected: Right (Map.empty :: Map String Int) - , actual: runExcept (decodeJSON "null") - } - testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. - assertEqual { expected: Right (BigInt.fromInt 50) - , actual: runExcept (decodeJSON "50") - } - testUnaryConstructorLiteral - let opts = defaultOptions { fieldTransform = toUpper } - testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) - testNothingToNull - testNothingFromMissing +main = + runTest do + suite "RoundTrips" 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 }) + testRoundTrip [ Just "test" ] + testRoundTrip [ Nothing :: Maybe String ] + testRoundTrip (Apple) + testRoundTrip (makeTree 0) + testRoundTrip (makeTree 5) + testRoundTrip (Object.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + testRoundTrip (Map.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + test "Maps" do + equal (Right (Map.fromFoldable [ Tuple "foo" 5 ])) + (runExcept (decodeJSON "{\"foo\": 5}")) + equal (Right (Map.empty :: Map String Int)) + (runExcept (decodeJSON "null")) + testRoundTrip [ Left 5, Right "Test" ] + testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. + test "BigInt" do + equal (Right (BigInt.fromInt 50)) + (runExcept (decodeJSON "50")) + testUnaryConstructorLiteral + let + opts = defaultOptions { fieldTransform = toUpper } + pure unit + testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) + testNothingToNull + testNothingFromMissing diff --git a/test/Types.purs b/test/Types.purs index e915ff0..80a5ce3 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -140,6 +140,8 @@ newtype UndefinedTest = UndefinedTest derive instance eqUT :: Eq UndefinedTest derive instance geUT :: Generic UndefinedTest _ +instance showUT :: Show UndefinedTest where + show = genericShow instance dUT :: Decode UndefinedTest where decode = genericDecode $ defaultOptions instance eUT :: Encode UndefinedTest where @@ -153,6 +155,8 @@ data Fruit derive instance eqFruit :: Eq Fruit derive instance geFruit :: Generic Fruit _ +instance showFruit :: Show Fruit where + show = genericShow instance dFruit :: Decode Fruit where decode = genericDecodeEnum defaultGenericEnumOptions instance eFruit :: Encode Fruit where From a2c5a0d623bb543207968110065e585d407c36d2 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 10 Sep 2020 16:25:33 +0100 Subject: [PATCH 18/42] BigInteger support. The motivation for this is JSON parsing. In order to correctly parse big integers from JSON, we need use a custom parser. The `JSON.parse` builtin won't do. --- bower.json | 2 +- package.json | 3 +- spago.dhall | 3 +- src/Data/BigInteger.js | 97 +++++++++++++++++++++++++++++++ src/Data/BigInteger.purs | 97 +++++++++++++++++++++++++++++++ src/Foreign/Generic.purs | 5 +- src/Foreign/Generic/Class.purs | 17 +----- src/Foreign/Generic/Internal.purs | 1 - src/Foreign/JSON.js | 9 ++- src/Foreign/JSON.purs | 3 + test/BigIntegerTests.purs | 66 +++++++++++++++++++++ test/Main.purs | 18 ++++-- test/Types.purs | 4 +- 13 files changed, 294 insertions(+), 31 deletions(-) create mode 100644 src/Data/BigInteger.js create mode 100644 src/Data/BigInteger.purs create mode 100644 test/BigIntegerTests.purs diff --git a/bower.json b/bower.json index b6e3512..f1e51dd 100644 --- a/bower.json +++ b/bower.json @@ -20,7 +20,7 @@ "purescript-generics-rep": "^6.1.1", "purescript-foreign-object": "^2.0.3", "purescript-record": "^2.0.1", - "purescript-bigints": "^4.0.0" + "purescript-quickcheck": "^6.1.0" }, "devDependencies": { "purescript-assert": "^4.1.0", diff --git a/package.json b/package.json index fe2953b..14e2015 100644 --- a/package.json +++ b/package.json @@ -14,6 +14,7 @@ "rimraf": "^3.0.0" }, "dependencies": { - "big-integer": "^1.6.48" + "bignumber": "^1.1.0", + "json-bigint": "^1.0.0" } } diff --git a/spago.dhall b/spago.dhall index ffb6a81..72e4f55 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,7 +5,6 @@ You can edit this file as you like. { name = "foreign-generic" , dependencies = [ "assert" - , "bigints" , "console" , "effect" , "exceptions" @@ -13,6 +12,8 @@ You can edit this file as you like. , "foreign-object" , "generics-rep" , "identity" + , "rationals" + , "quickcheck" , "test-unit" , "ordered-collections" , "proxy" diff --git a/src/Data/BigInteger.js b/src/Data/BigInteger.js new file mode 100644 index 0000000..f76bae9 --- /dev/null +++ b/src/Data/BigInteger.js @@ -0,0 +1,97 @@ +/*global exports, require*/ +'use strict'; + +var BigNumber = require('bignumber.js'); + +exports.eq_ = function (a) { + return function (b) { + return a.isEqualTo(b); + }; +}; + +exports.show_ = function (n) { + return n.toString(10); +}; + +exports.toNumber = function (n) { + return n.toNumber(); +}; + +exports.fromInt = function (int) { + return BigNumber(int); +}; + +exports.fromString_ = function (nothing) { + return function (just) { + return function (str) { + var n = BigNumber(str); + if (n && n.isInteger()) { + return just(n); + } else { + return nothing; + } + }; + }; +}; + +exports.add_ = function (x) { + return function (y) { + return x.plus(y); + }; +}; + +exports.mul_ = function (x) { + return function (y) { + return x.multipliedBy(y); + }; +}; + +exports.sub_ = function (x) { + return function (y) { + return x.minus(y); + }; +}; + +exports.div_ = function (x) { + return function (y) { + return x.dividedToIntegerBy(y); + }; +}; + +exports.mod_ = function (x) { + return function (y) { + return x.modulo(y); + }; +}; + +exports.degree_ = function (x) { + return x.absoluteValue().toNumber(); +}; + +exports.comparedTo_ = function (x) { + return function (y) { + return x.comparedTo(y); + }; +}; + +exports.readBigInteger_ = function (nothing) { + return function (just) { + return function (value) { + var tag = Object.prototype.toString.call(value).slice(8,-1); + if (value !== undefined && (BigNumber.isBigNumber(value) || tag === "Number" || tag === "String")) { + var n = BigNumber(value); + if (n && n.isInteger()) { + return just(n); + } else { + return nothing; + } + } else { + return nothing; + } + }; + }; +}; + +exports.format = function (value) { + return value.toFormat(); +}; diff --git a/src/Data/BigInteger.purs b/src/Data/BigInteger.purs new file mode 100644 index 0000000..e7c911e --- /dev/null +++ b/src/Data/BigInteger.purs @@ -0,0 +1,97 @@ +module Data.BigInteger + ( BigInteger + , fromString + , fromInt + , toNumber + , format + , readBigInteger + ) where + +import Control.Applicative (pure) +import Data.CommutativeRing (class CommutativeRing) +import Data.Eq (class Eq) +import Data.EuclideanRing (class EuclideanRing) +import Data.Function (($)) +import Data.Maybe (Maybe(..)) +import Data.Ord (class Ord, compare) +import Data.Ring (class Ring) +import Data.Semiring (class Semiring) +import Data.Show (class Show) +import Foreign (fail, tagOf, unsafeToForeign) +import Foreign.Generic (F, Foreign, ForeignError(..)) +import Foreign.Generic.Class (class Decode, class Encode) + +foreign import data BigInteger :: Type + +------------------------------------------------------------ +foreign import eq_ :: BigInteger -> BigInteger -> Boolean + +instance eqBigInteger :: Eq BigInteger where + eq = eq_ + +foreign import comparedTo_ :: BigInteger -> BigInteger -> Int + +instance ordBigInteger :: Ord BigInteger where + compare x y = compare (comparedTo_ x y) 0 + +foreign import show_ :: BigInteger -> String + +instance showBigInteger :: Show BigInteger where + show = show_ + +------------------------------------------------------------ +foreign import add_ :: BigInteger -> BigInteger -> BigInteger + +foreign import mul_ :: BigInteger -> BigInteger -> BigInteger + +instance semiringBigInteger :: Semiring BigInteger where + zero = fromInt 0 + one = fromInt 1 + add = add_ + mul = mul_ + +foreign import sub_ :: BigInteger -> BigInteger -> BigInteger + +instance ringBigInteger :: Ring BigInteger where + sub = sub_ + +foreign import div_ :: BigInteger -> BigInteger -> BigInteger + +foreign import mod_ :: BigInteger -> BigInteger -> BigInteger + +foreign import degree_ :: BigInteger -> Int + +instance commutativeRingBigInteger :: CommutativeRing BigInteger + +instance euclideanRingBigInteger :: EuclideanRing BigInteger where + div = div_ + mod = mod_ + degree = degree_ + +------------------------------------------------------------ +foreign import fromInt :: Int -> BigInteger + +foreign import toNumber :: BigInteger -> Number + +foreign import fromString_ :: Maybe BigInteger -> (BigInteger -> Maybe BigInteger) -> String -> Maybe BigInteger + +fromString :: String -> Maybe BigInteger +fromString = fromString_ Nothing Just + +------------------------------------------------------------ +instance bigIntegerDecode :: Decode BigInteger where + decode = readBigInteger + +instance bigIntegerEncode :: Encode BigInteger where + encode = unsafeToForeign + +foreign import readBigInteger_ :: Maybe BigInteger -> (BigInteger -> Maybe BigInteger) -> Foreign -> Maybe BigInteger + +-- | Attempt to coerce a foreign value to a `BigInteger`. +readBigInteger :: Foreign -> F BigInteger +readBigInteger value = case readBigInteger_ Nothing Just value of + Just n -> pure n + Nothing -> fail $ TypeMismatch "bigint" (tagOf value) + +------------------------------------------------------------ +foreign import format :: BigInteger -> String diff --git a/src/Foreign/Generic.purs b/src/Foreign/Generic.purs index 3125a7d..d5953fa 100644 --- a/src/Foreign/Generic.purs +++ b/src/Foreign/Generic.purs @@ -13,10 +13,9 @@ import Prelude import Data.Generic.Rep (class Generic, from, to) import Foreign (F, Foreign) import Foreign (F, Foreign, ForeignError(..)) as Reexports -import Foreign.Generic.Class (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, decodeOpts, encode, encodeOpts) import Foreign.Generic.Class (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, SumEncoding(..), defaultOptions, decode, encode) as Reexports -import Foreign.JSON (decodeJSONWith, parseJSON) -import Global.Unsafe (unsafeStringify) +import Foreign.Generic.Class (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, decodeOpts, encode, encodeOpts) +import Foreign.JSON (decodeJSONWith, parseJSON, unsafeStringify) -- | Read a value which has a `Generic` type. genericDecode diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index a445747..7d8663a 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -6,9 +6,7 @@ import Control.Alt ((<|>)) import Control.Monad.Except (except, mapExcept) import Data.Array ((..), zipWith, length) import Data.Bifunctor (lmap) -import Data.BigInt (BigInt) -import Data.BigInt as BigInt -import Data.Either (Either(..), note) +import Data.Either (Either(..)) import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConstructors, Product(..), Sum(..)) import Data.Identity (Identity(..)) import Data.List (List(..), (:)) @@ -206,16 +204,6 @@ instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where <|> (readProp "Right" value >>= (map Right <<< decode)) -instance bigIntDecode :: Decode BigInt where - decode json = decodeAsString json <|> decodeAsDigits json - where - decodeAsString value = do - str <- readString value - except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str - decodeAsDigits value = do - number <- readNumber value - except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromNumber number - -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -290,9 +278,6 @@ instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where encode (Left a) = encode $ Object.singleton "Left" a encode (Right b) = encode $ Object.singleton "Right" b -instance bigIntEncode :: Encode BigInt where - encode = unsafeToForeign <<< BigInt.toNumber - -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. diff --git a/src/Foreign/Generic/Internal.purs b/src/Foreign/Generic/Internal.purs index 6a0d5cd..7412026 100644 --- a/src/Foreign/Generic/Internal.purs +++ b/src/Foreign/Generic/Internal.purs @@ -1,7 +1,6 @@ module Foreign.Generic.Internal where import Prelude - import Foreign (F, Foreign, ForeignError(..), fail, tagOf, unsafeFromForeign) import Foreign.Object (Object) diff --git a/src/Foreign/JSON.js b/src/Foreign/JSON.js index 5ec76c1..e8971c7 100644 --- a/src/Foreign/JSON.js +++ b/src/Foreign/JSON.js @@ -1,5 +1,12 @@ +/*global exports, require*/ "use strict"; +var JSONbig = require('json-bigint'); + exports.parseJSONImpl = function (str) { - return JSON.parse(str); + return JSONbig.parse(str); +}; + +exports.unsafeStringify = function (value) { + return JSONbig.stringify(value); }; diff --git a/src/Foreign/JSON.purs b/src/Foreign/JSON.purs index 565d253..3d9f976 100644 --- a/src/Foreign/JSON.purs +++ b/src/Foreign/JSON.purs @@ -1,6 +1,7 @@ module Foreign.JSON ( parseJSON , decodeJSONWith + , unsafeStringify ) where import Control.Monad.Except (ExceptT(..)) @@ -26,3 +27,5 @@ parseJSON = decodeJSONWith :: forall a. (Foreign -> F a) -> String -> F a decodeJSONWith f = f <=< parseJSON + +foreign import unsafeStringify :: forall a. a -> String diff --git a/test/BigIntegerTests.purs b/test/BigIntegerTests.purs new file mode 100644 index 0000000..b18c004 --- /dev/null +++ b/test/BigIntegerTests.purs @@ -0,0 +1,66 @@ +module BigIntegerTests where + +import Prelude +import Control.Monad.Except (runExcept) +import Data.BigInteger (fromInt, readBigInteger, format) +import Data.BigInteger as BigInteger +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Data.Ord (abs) +import Data.Ratio (reduce) +import Data.Tuple (Tuple(..)) +import Foreign (unsafeToForeign) +import Foreign.Generic (ForeignError(..)) +import Test.QuickCheck ((===)) +import Test.Unit (TestSuite, suite, test) +import Test.Unit.Assert (equal) +import Test.Unit.QuickCheck (quickCheck) + +all :: TestSuite +all = + suite "BigInteger" do + test "show(some_int) is always parsable." do + quickCheck \x -> + Just (fromInt x) === (BigInteger.fromString (show x)) + test "show behaves as it would for Int" do + quickCheck \x -> + show x === show (fromInt x) + test "abs behaves as it would for Int" do + quickCheck \x -> + fromInt (abs x) === abs (fromInt x) + test "compare behaves as it would for Int" do + quickCheck \(Tuple x y) -> + compare x y === compare (fromInt x) (fromInt y) + test "Rationals" do + equal + (reduce (fromInt 2) (fromInt 3)) + (reduce (fromInt 50) (fromInt 75)) + equal + (reduce (fromInt 181) (fromInt 97)) + (reduce (fromInt 362) (fromInt 194)) + suite "readBigInteger" do + suite "should succeed" do + test "int" do + equal (Right zero) + (runExcept (readBigInteger (unsafeToForeign 0))) + equal (Right (fromInt 1234)) + (runExcept (readBigInteger (unsafeToForeign 1234))) + test "big integer" do + equal (Right (fromInt 123)) + (runExcept (readBigInteger (unsafeToForeign (fromInt 123)))) + test "good string" do + equal (Right (fromInt 123)) + (runExcept (readBigInteger (unsafeToForeign "123"))) + suite "should fail" do + test "float" do + equal (Left (pure (TypeMismatch "bigint" "Number"))) + (runExcept (readBigInteger (unsafeToForeign 1234.6789))) + test "object" do + equal (Left (pure (TypeMismatch "bigint" "Object"))) + (runExcept (readBigInteger (unsafeToForeign { a: 1 }))) + test "bad string" do + equal (Left (pure (TypeMismatch "bigint" "String"))) + (runExcept (readBigInteger (unsafeToForeign "asdf"))) + test "formatting" do + equal "0" (format zero) + equal "1,234,567,890" (format (fromInt 1234567890)) diff --git a/test/Main.purs b/test/Main.purs index 54946cf..c367e00 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,9 +1,10 @@ module Test.Main where import Prelude +import BigIntegerTests as BigIntegerTests import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) -import Data.BigInt as BigInt +import Data.BigInteger as BigInteger import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Map (Map) @@ -128,6 +129,11 @@ testNothingFromMissing = main :: Effect Unit main = runTest do + roundTripTests + BigIntegerTests.all + +roundTripTests :: TestSuite +roundTripTests = suite "RoundTrips" do testRoundTrip (RecordTest { foo: 1, bar: "test", baz: 'a' }) testRoundTrip NoArgs @@ -150,10 +156,12 @@ main = equal (Right (Map.empty :: Map String Int)) (runExcept (decodeJSON "null")) testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. - test "BigInt" do - equal (Right (BigInt.fromInt 50)) - (runExcept (decodeJSON "50")) + testRoundTrip (BigInteger.fromString ("9055784127882682410409638")) -- 2^60. Anything over 2^32 would baffle JavaScript. + test "BigInteger" do + equal (Right (BigInteger.fromInt 50)) + (runExcept (decodeJSON "50")) + equal (Right {a: (BigInteger.fromInt 50)}) + (runExcept (decodeJSON "{\"a\": 50}")) testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } diff --git a/test/Types.purs b/test/Types.purs index 80a5ce3..a6c505a 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -141,7 +141,7 @@ derive instance eqUT :: Eq UndefinedTest derive instance geUT :: Generic UndefinedTest _ instance showUT :: Show UndefinedTest where - show = genericShow + show x = genericShow x instance dUT :: Decode UndefinedTest where decode = genericDecode $ defaultOptions instance eUT :: Encode UndefinedTest where @@ -156,7 +156,7 @@ derive instance eqFruit :: Eq Fruit derive instance geFruit :: Generic Fruit _ instance showFruit :: Show Fruit where - show = genericShow + show x = genericShow x instance dFruit :: Decode Fruit where decode = genericDecodeEnum defaultGenericEnumOptions instance eFruit :: Encode Fruit where From 695e30b4b841df540dcc26d13b2f48e01750ea9a Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 17 Sep 2020 09:59:13 +0100 Subject: [PATCH 19/42] Refactoring the test suite. --- test/Main.purs | 132 ++++++++++++++------------------------------ test/TestUtils.purs | 63 +++++++++++++++++++++ 2 files changed, 103 insertions(+), 92 deletions(-) create mode 100644 test/TestUtils.purs diff --git a/test/Main.purs b/test/Main.purs index c367e00..58cf6f3 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,12 +1,12 @@ module Test.Main where import Prelude +import TestUtils (testGenericRoundTrip, testOption, testRoundTrip) import BigIntegerTests as BigIntegerTests import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.BigInteger as BigInteger import Data.Either (Either(..)) -import Data.Generic.Rep (class Generic) import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), isNothing) @@ -14,14 +14,10 @@ import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) import Effect (Effect) import Foreign (isNull, unsafeToForeign) -import Foreign.Generic (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, encode, defaultOptions, decodeJSON, encodeJSON, genericDecodeJSON, genericEncodeJSON) -import Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum) +import Foreign.Generic (decode, decodeJSON, defaultOptions, encode, encodeJSON) import Foreign.Index (readProp) -import Foreign.JSON (parseJSON) import Foreign.Object as Object -import Global.Unsafe (unsafeStringify) -import Test.Assert (assert') -import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) +import Test.Types (Fruit(..), IntList(..), RecordTest(..), SumWithRecord(..), Tree(..), TupleArray(..), UndefinedTest(..)) import Test.Unit (TestSuite, failure, success, suite, test) import Test.Unit.Assert (equal) import Test.Unit.Main (runTest) @@ -35,55 +31,6 @@ buildTree f n a = Branch $ buildTree (bimap f f) (n - 1) (f a) makeTree :: Int -> Tree Int makeTree n = buildTree (\i -> TupleArray (Tuple (2 * i) (2 * i + 1))) n 0 -throw :: String -> Effect Unit -throw = flip assert' false - -testRoundTrip :: - ∀ a. - Eq a => - Show a => - Decode a => - Encode a => - a -> - TestSuite -testRoundTrip x = - test ("RoundTrip " <> show x) do - equal (Right x) (runExcept (decodeJSON (encodeJSON x))) - -testGenericRoundTrip :: - ∀ a r. - Eq a => - Show a => - Generic a r => - GenericDecode r => - GenericEncode r => - Options -> - a -> - TestSuite -testGenericRoundTrip opts x = - test ("Generic roundtrip " <> show x) do - equal (Right x) (runExcept (genericDecodeJSON opts (genericEncodeJSON opts x))) - -testOption :: - ∀ a rep. - Eq a => - Show a => - Generic a rep => - GenericEncodeEnum rep => - GenericDecodeEnum rep => - GenericEnumOptions -> - String -> - a -> - TestSuite -testOption options string value = - test "testOption" do - let - json = unsafeStringify $ genericEncodeEnum options value - equal (Right value) (runExcept (decode' json)) - equal (Right value) (runExcept (decode' string)) - where - decode' = genericDecodeEnum options <=< parseJSON - testUnaryConstructorLiteral :: TestSuite testUnaryConstructorLiteral = do testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel @@ -98,7 +45,8 @@ testUnaryConstructorLiteral = do testNothingToNull :: TestSuite testNothingToNull = test "Nothing to Null" do - let json = encode (UndefinedTest { a: Nothing }) + let + json = encode (UndefinedTest { a: Nothing }) case runExcept (pure json >>= readProp "contents" >>= readProp "a") of Right val -> if (isNull val) then @@ -134,38 +82,38 @@ main = roundTripTests :: TestSuite roundTripTests = - suite "RoundTrips" 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 }) - testRoundTrip [ Just "test" ] - testRoundTrip [ Nothing :: Maybe String ] - testRoundTrip (Apple) - testRoundTrip (makeTree 0) - testRoundTrip (makeTree 5) - testRoundTrip (Object.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) - testRoundTrip (Map.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) - test "Maps" do - equal (Right (Map.fromFoldable [ Tuple "foo" 5 ])) - (runExcept (decodeJSON "{\"foo\": 5}")) - equal (Right (Map.empty :: Map String Int)) - (runExcept (decodeJSON "null")) - testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInteger.fromString ("9055784127882682410409638")) -- 2^60. Anything over 2^32 would baffle JavaScript. - test "BigInteger" do - equal (Right (BigInteger.fromInt 50)) - (runExcept (decodeJSON "50")) - equal (Right {a: (BigInteger.fromInt 50)}) - (runExcept (decodeJSON "{\"a\": 50}")) - testUnaryConstructorLiteral - let - opts = defaultOptions { fieldTransform = toUpper } - pure unit - testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) - testNothingToNull - testNothingFromMissing + suite "RoundTrips" 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 }) + testRoundTrip [ Just "test" ] + testRoundTrip [ Nothing :: Maybe String ] + testRoundTrip (Apple) + testRoundTrip (makeTree 0) + testRoundTrip (makeTree 5) + testRoundTrip (Object.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + testRoundTrip (Map.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + test "Maps" do + equal (Right (Map.fromFoldable [ Tuple "foo" 5 ])) + (runExcept (decodeJSON "{\"foo\": 5}")) + equal (Right (Map.empty :: Map String Int)) + (runExcept (decodeJSON "null")) + testRoundTrip [ Left 5, Right "Test" ] + testRoundTrip (BigInteger.fromString ("9055784127882682410409638")) -- 2^60. Anything over 2^32 would baffle JavaScript. + test "BigInteger" do + equal (Right (BigInteger.fromInt 50)) + (runExcept (decodeJSON "50")) + equal (Right { a: (BigInteger.fromInt 50) }) + (runExcept (decodeJSON "{\"a\": 50}")) + testUnaryConstructorLiteral + let + opts = defaultOptions { fieldTransform = toUpper } + pure unit + testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) + testNothingToNull + testNothingFromMissing diff --git a/test/TestUtils.purs b/test/TestUtils.purs new file mode 100644 index 0000000..a9fcd75 --- /dev/null +++ b/test/TestUtils.purs @@ -0,0 +1,63 @@ +module TestUtils where + +import Prelude +import Control.Monad.Except (runExcept) +import Data.Either (Either(..)) +import Data.Generic.Rep (class Generic) +import Effect (Effect) +import Foreign.Generic (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decodeJSON, encodeJSON, genericDecodeJSON, genericEncodeJSON) +import Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum) +import Foreign.JSON (parseJSON) +import Global.Unsafe (unsafeStringify) +import Test.Assert (assert') +import Test.Unit (TestSuite, test) +import Test.Unit.Assert (equal) + +throw :: String -> Effect Unit +throw = flip assert' false + +testRoundTrip :: + ∀ a. + Eq a => + Show a => + Decode a => + Encode a => + a -> + TestSuite +testRoundTrip x = + test ("RoundTrip " <> show x) do + equal (Right x) (runExcept (decodeJSON (encodeJSON x))) + +testGenericRoundTrip :: + ∀ a r. + Eq a => + Show a => + Generic a r => + GenericDecode r => + GenericEncode r => + Options -> + a -> + TestSuite +testGenericRoundTrip opts x = + test ("Generic roundtrip " <> show x) do + equal (Right x) (runExcept (genericDecodeJSON opts (genericEncodeJSON opts x))) + +testOption :: + ∀ a rep. + Eq a => + Show a => + Generic a rep => + GenericEncodeEnum rep => + GenericDecodeEnum rep => + GenericEnumOptions -> + String -> + a -> + TestSuite +testOption options string value = + test "testOption" do + let + json = unsafeStringify $ genericEncodeEnum options value + equal (Right value) (runExcept (decode' json)) + equal (Right value) (runExcept (decode' string)) + where + decode' = genericDecodeEnum options <=< parseJSON From f5b1c439c0c97d15051a3779f3a09f6f4f80a10d Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 17 Sep 2020 11:04:17 +0100 Subject: [PATCH 20/42] Fixing a bug with aeson-style encoding on nested sum types. And adding tests. --- src/Foreign/Generic/Class.purs | 9 ++-- test/AesonEncodingTests.purs | 99 ++++++++++++++++++++++++++++++++++ test/Main.purs | 2 + 3 files changed, 107 insertions(+), 3 deletions(-) create mode 100644 test/AesonEncodingTests.purs diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 7d8663a..b54bb6f 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -1,7 +1,6 @@ module Foreign.Generic.Class where import Prelude - import Control.Alt ((<|>)) import Control.Monad.Except (except, mapExcept) import Data.Array ((..), zipWith, length) @@ -420,8 +419,12 @@ instance genericEncodeConstructor then maybe (unsafeToForeign {}) unsafeToForeign (encodeArgsArray args) else case opts.sumEncoding of TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> - unsafeToForeign (Object.singleton tagFieldName (unsafeToForeign $ constructorTagTransform ctorName) - `Object.union` objectFromArgs opts.sumEncoding (encodeArgsArray args)) + unsafeToForeign $ + let tagPart = Object.singleton tagFieldName (unsafeToForeign $ constructorTagTransform ctorName) + contentPart = objectFromArgs opts.sumEncoding (encodeArgsArray args) + in if Object.member tagFieldName contentPart + then Object.insert contentsFieldName (unsafeToForeign contentPart) tagPart + else tagPart `Object.union` contentPart where ctorName = reflectSymbol (SProxy :: SProxy name) diff --git a/test/AesonEncodingTests.purs b/test/AesonEncodingTests.purs new file mode 100644 index 0000000..877dbc4 --- /dev/null +++ b/test/AesonEncodingTests.purs @@ -0,0 +1,99 @@ +module AesonEncodingTests (all) where + +import Prelude +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Foreign.Generic (class Decode, class Encode, Options, defaultOptions, encodeJSON, genericDecode, genericEncode) +import Foreign.Generic.Class (aesonSumEncoding) +import Test.Unit (TestSuite, suite, test) +import Test.Unit.Assert (equal) +import TestUtils (testRoundTrip) + +all :: TestSuite +all = + suite "Aeson Encoding" do + suite "Records" do + test "Record" do + equal "{\"name\":\"Tester\",\"age\":13}" + (encodeJSON (ARecord { name: "Tester", age: 13 })) + testRoundTrip (ARecord { name: "Tester", age: 13 }) + suite "Sum Types" do + test "Sum type, no arg constructor." do + equal "{\"tag\":\"NoShipperChoice\"}" + (encodeJSON NoShipperChoice) + test "Sum type, 1 arg constructor." do + equal "{\"contents\":\"Test\",\"tag\":\"ShipperChoice\"}" + (encodeJSON (ShipperChoice "Test")) + testRoundTrip NoShipperChoice + testRoundTrip (ShipperChoice "Test") + suite "Nesting" do + test "Nested no arg constructor" do + equal "{\"tag\":\"FreightForwarderShipper\",\"contents\":{\"tag\":\"NoShipperChoice\"}}" + (encodeJSON (FreightForwarderShipper NoShipperChoice)) + test "Nested 1 arg constructor" do + equal "{\"tag\":\"FreightForwarderShipper\",\"contents\":{\"contents\":\"Test\",\"tag\":\"ShipperChoice\"}}" + (encodeJSON (FreightForwarderShipper (ShipperChoice "Test"))) + testRoundTrip (FreightForwarderShipper NoShipperChoice) + testRoundTrip (FreightForwarderShipper (ShipperChoice "Test")) + +------------------------------------------------------------ +opts :: Options +opts = + defaultOptions + { sumEncoding = aesonSumEncoding + , unwrapSingleConstructors = true + } + +------------------------------------------------------------ +newtype ARecord + = ARecord + { name :: String + , age :: Int + } + +derive instance eqARecord :: Eq ARecord + +derive instance genericARecord :: Generic ARecord _ + +instance showARecord :: Show ARecord where + show = genericShow + +instance decodeARecord :: Decode ARecord where + decode value = genericDecode opts value + +instance encodeARecord :: Encode ARecord where + encode value = genericEncode opts value + +data ShipperChoice + = ShipperChoice String + | NoShipperChoice + +derive instance eqShipperChoice :: Eq ShipperChoice + +derive instance genericShipperChoice :: Generic ShipperChoice _ + +instance showShipperChoice :: Show ShipperChoice where + show = genericShow + +instance decodeShipperChoice :: Decode ShipperChoice where + decode value = genericDecode opts value + +instance encodeShipperChoice :: Encode ShipperChoice where + encode value = genericEncode opts value + +data FreightForwarderChoice + = FreightForwarderContact Int + | FreightForwarderShipper ShipperChoice + +derive instance eqFreightForwarderChoice :: Eq FreightForwarderChoice + +derive instance genericFreightForwarderChoice :: Generic FreightForwarderChoice _ + +instance showFreightForwarderChoice :: Show FreightForwarderChoice where + show = genericShow + +instance decodeFreightForwarderChoice :: Decode FreightForwarderChoice where + decode value = genericDecode opts value + +instance encodeFreightForwarderChoice :: Encode FreightForwarderChoice where + encode value = genericEncode opts value diff --git a/test/Main.purs b/test/Main.purs index 58cf6f3..9909d43 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -3,6 +3,7 @@ module Test.Main where import Prelude import TestUtils (testGenericRoundTrip, testOption, testRoundTrip) import BigIntegerTests as BigIntegerTests +import AesonEncodingTests as AesonEncodingTests import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.BigInteger as BigInteger @@ -79,6 +80,7 @@ main = runTest do roundTripTests BigIntegerTests.all + AesonEncodingTests.all roundTripTests :: TestSuite roundTripTests = From 57692ed7b1bc512bcfddd2c00c27e865e9c21b84 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 17 Sep 2020 11:04:46 +0100 Subject: [PATCH 21/42] Simplifying a fromMaybe clause. --- src/Foreign/Generic/Class.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index b54bb6f..6952d22 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -12,7 +12,7 @@ import Data.List (List(..), (:)) import Data.List as List import Data.Map (Map) import Data.Map as Map -import Data.Maybe (Maybe(..), maybe) +import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Newtype (unwrap) import Data.Set (Set) import Data.Set as Set @@ -415,8 +415,8 @@ instance genericEncodeConstructor :: (IsSymbol name, GenericEncodeArgs rep) => GenericEncode (Constructor name rep) where encodeOpts opts (Constructor args) = - if opts.unwrapSingleConstructors - then maybe (unsafeToForeign {}) unsafeToForeign (encodeArgsArray args) + if opts.unwrapSingleConstructors + then fromMaybe (unsafeToForeign {}) (encodeArgsArray args) else case opts.sumEncoding of TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> unsafeToForeign $ From c7cb62332c22edbf65bed0e7bd21d97af7b145d8 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 10 May 2019 13:57:20 +0100 Subject: [PATCH 22/42] 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 9054539a4de5d572f25495ea2d2bfc2369a5a92b Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 12:48:54 +0100 Subject: [PATCH 23/42] rebase upstream master and add spago --- .gitignore | 1 + package.json | 1 + packages.dhall | 128 +++++++++++++++++++++++++++++++++ spago.dhall | 22 ++++++ src/Foreign/Generic/Class.purs | 32 +++++++-- test/Main.purs | 6 +- test/Types.purs | 33 +++++++++ 7 files changed, 217 insertions(+), 6 deletions(-) create mode 100644 packages.dhall create mode 100644 spago.dhall diff --git a/.gitignore b/.gitignore index bfc53b1..06fda40 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ output/ .psc-ide-port node_modules/ yarn.lock +.spago 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/packages.dhall b/packages.dhall new file mode 100644 index 0000000..97dadbd --- /dev/null +++ b/packages.dhall @@ -0,0 +1,128 @@ +{- +Welcome to your new Dhall package-set! + +Below are instructions for how to edit this file for most use +cases, so that you don't need to know Dhall to use it. + +## Warning: Don't Move This Top-Level Comment! + +Due to how `dhall format` currently works, this comment's +instructions cannot appear near corresponding sections below +because `dhall format` will delete the comment. However, +it will not delete a top-level comment like this one. + +## Use Cases + +Most will want to do one or both of these options: +1. Override/Patch a package's dependency +2. Add a package not already in the default package set + +This file will continue to work whether you use one or both options. +Instructions for each option are explained below. + +### Overriding/Patching a package + +Purpose: +- Change a package's dependency to a newer/older release than the + default package set's release +- Use your own modified version of some dependency that may + include new API, changed API, removed API by + using your custom git repo of the library rather than + the package set's repo + +Syntax: +Replace the overrides' "{=}" (an empty record) with the following idea +The "//" or "⫽" means "merge these two records and + when they have the same value, use the one on the right:" +------------------------------- +let override = + { packageName = + upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" } + , packageName = + upstream.packageName // { version = "v4.0.0" } + , packageName = + upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" } + } +------------------------------- + +Example: +------------------------------- +let overrides = + { halogen = + upstream.halogen // { version = "master" } + , halogen-vdom = + upstream.halogen-vdom // { version = "v4.0.0" } + } +------------------------------- + +### Additions + +Purpose: +- Add packages that aren't already included in the default package set + +Syntax: +Replace the additions' "{=}" (an empty record) with the following idea: +------------------------------- +let additions = + { package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "tag ('v4.0.0') or branch ('master')" + } + , package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "tag ('v4.0.0') or branch ('master')" + } + , etc. + } +------------------------------- + +Example: +------------------------------- +let additions = + { benchotron = + { dependencies = + [ "arrays" + , "exists" + , "profunctor" + , "strings" + , "quickcheck" + , "lcg" + , "transformers" + , "foldable-traversable" + , "exceptions" + , "node-fs" + , "node-buffer" + , "node-readline" + , "datetime" + , "now" + ] + , repo = + "https://github.com/hdgarrood/purescript-benchotron.git" + , version = + "v7.0.0" + } + } +------------------------------- +-} + + +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20200724/packages.dhall sha256:bb941d30820a49345a0e88937094d2b9983d939c9fd3a46969b85ce44953d7d9 + +let overrides = {=} + +let additions = {=} + +in upstream // overrides // additions diff --git a/spago.dhall b/spago.dhall new file mode 100644 index 0000000..74fbbf9 --- /dev/null +++ b/spago.dhall @@ -0,0 +1,22 @@ +{- +Welcome to a Spago project! +You can edit this file as you like. +-} +{ name = "foreign-generic" +, dependencies = + [ "assert" + , "console" + , "effect" + , "exceptions" + , "foreign" + , "foreign-object" + , "generics-rep" + , "identity" + , "ordered-collections" + , "proxy" + , "psci-support" + , "record" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs", "test/**/*.purs" ] +} diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 9370082..94ffce7 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -15,10 +15,10 @@ import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence) -import Foreign (F, Foreign, ForeignError(..), fail, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign) +import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign, unsafeFromForeign) import Foreign.Generic.Internal (readObject) -import Foreign.Index (index) import Foreign.NullOrUndefined (readNullOrUndefined, null) +import Foreign.Index (hasProperty, index) import Foreign.Object (Object) import Foreign.Object as Object import Prim.Row (class Cons, class Lacks) @@ -48,6 +48,7 @@ data SumEncoding { tagFieldName :: String , contentsFieldName :: String , constructorTagTransform :: String -> String + , unwrapRecords :: Boolean } -- | Default decoding/encoding options: @@ -64,12 +65,22 @@ defaultOptions = { tagFieldName: "tag" , contentsFieldName: "contents" , constructorTagTransform: identity + , unwrapRecords: false } , unwrapSingleConstructors: false , 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 + } + -- | The `Decode` class is used to generate decoding functions -- | of the form `Foreign -> F a` using `generics-rep` deriving. -- | @@ -288,7 +299,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 @@ -296,13 +307,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 @@ -327,10 +343,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 <<< List.toUnfoldable <<< encodeArgs opts diff --git a/test/Main.purs b/test/Main.purs index 1c80643..de800b2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -19,7 +19,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 @@ -125,6 +125,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 3c51ea5..e915ff0 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -55,6 +55,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 @@ -74,6 +106,7 @@ intListOptions = , constructorTagTransform: \tag -> case tag of "Cons" -> "cOnS" _ -> "" + , unwrapRecords: false } } From 57539e71e374a2e8e405d719207b166e3b129cc9 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 13:10:19 +0100 Subject: [PATCH 24/42] add List decode/encode --- src/Foreign/Generic/Class.purs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 94ffce7..6e0acd8 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -134,6 +134,9 @@ instance arrayDecode :: Decode a => Decode (Array a) where readElement :: Int -> Foreign -> F a readElement i value = mapExcept (lmap (map (ErrorAtIndex i))) (decode value) +instance listDecode :: Decode a => Decode (List a) where + decode f = let (array :: F (Array a)) = decode f in List.fromFoldable <$> array + instance maybeDecode :: Decode a => Decode (Maybe a) where decode = readNullOrUndefined decode @@ -191,6 +194,9 @@ instance identityEncode :: Encode a => Encode (Identity a) where instance arrayEncode :: Encode a => Encode (Array a) where encode = unsafeToForeign <<< map encode +instance listEncode :: Encode a => Encode (List a) where + encode f = let (arr :: Array a) = List.toUnfoldable f in encode arr + instance maybeEncode :: Encode a => Encode (Maybe a) where encode = maybe null encode From 209e04048357c393901ae4c3cf7971cbe47220d8 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 15:45:23 +0100 Subject: [PATCH 25/42] encode/decode tuple using array as this is what is normally done --- src/Foreign/Generic/Class.purs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 6e0acd8..a5e334a 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -15,6 +15,7 @@ import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence) +import Data.Tuple (Tuple(..)) import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign, unsafeFromForeign) import Foreign.Generic.Internal (readObject) import Foreign.NullOrUndefined (readNullOrUndefined, null) @@ -137,6 +138,13 @@ instance arrayDecode :: Decode a => Decode (Array a) where instance listDecode :: Decode a => Decode (List a) where decode f = let (array :: F (Array a)) = decode f in List.fromFoldable <$> array +instance tupleDecode :: (Decode a, Decode b) => Decode (Tuple a b) where + decode f = do + (arr :: Array Foreign) <- decode f + case arr of + [a, b] -> Tuple <$> decode a <*> decode b + _ -> except (Left (pure (ForeignError "Decode: Tuple was not a list of exactly 2 items"))) + instance maybeDecode :: Decode a => Decode (Maybe a) where decode = readNullOrUndefined decode @@ -197,6 +205,9 @@ instance arrayEncode :: Encode a => Encode (Array a) where instance listEncode :: Encode a => Encode (List a) where encode f = let (arr :: Array a) = List.toUnfoldable f in encode arr +instance encodeTuple :: (Encode a, Encode b) => Encode (Tuple a b) where + encode (Tuple a b) = unsafeToForeign [encode a, encode b] + instance maybeEncode :: Encode a => Encode (Maybe a) where encode = maybe null encode From 33f2a7ffff7b1d7e98c0709f3398036f108720ee Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 16:07:15 +0100 Subject: [PATCH 26/42] encode/decode Map using array of tuples, not sure there is another way --- src/Foreign/Generic/Class.purs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index a5e334a..e7b2189 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -11,6 +11,8 @@ import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConst import Data.Identity (Identity(..)) import Data.List (List(..), (:)) import Data.List as List +import Data.Map (Map) +import Data.Map as Map import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) @@ -154,6 +156,11 @@ instance objectDecode :: Decode v => Decode (Object v) where instance recordDecode :: (RowToList r rl, DecodeRecord r rl) => Decode (Record r) where decode = decodeWithOptions defaultOptions +instance mapDecode :: (Ord k, Decode k, Decode v) => Decode (Map k v) where + decode f = do + (tuple :: Array (Tuple k v)) <- decode f + pure $ Map.fromFoldable tuple + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -217,6 +224,9 @@ instance objectEncode :: Encode v => Encode (Object v) where instance recordEncode :: (RowToList r rl, EncodeRecord r rl) => Encode (Record r) where encode = encodeWithOptions defaultOptions +instance mapEncode :: (Encode k, Encode v) => Encode (Map k v) where + encode m = encode (Map.toUnfoldable m :: Array _) + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. From 60a7a0f7b1f983f760e31b162e19a9440cd5cf46 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 14 Aug 2020 16:26:24 +0100 Subject: [PATCH 27/42] encode/decode Set using array --- src/Foreign/Generic/Class.purs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index e7b2189..640e41c 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -15,6 +15,8 @@ import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), maybe) import Data.Newtype (unwrap) +import Data.Set (Set) +import Data.Set as Set import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence) import Data.Tuple (Tuple(..)) @@ -161,6 +163,11 @@ instance mapDecode :: (Ord k, Decode k, Decode v) => Decode (Map k v) where (tuple :: Array (Tuple k v)) <- decode f pure $ Map.fromFoldable tuple +instance setDecode :: (Ord a, Decode a) => Decode (Set a) where + decode f = do + (arr :: Array a) <- decode f + pure $ Set.fromFoldable arr + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -227,6 +234,9 @@ instance recordEncode :: (RowToList r rl, EncodeRecord r rl) => Encode (Record r instance mapEncode :: (Encode k, Encode v) => Encode (Map k v) where encode m = encode (Map.toUnfoldable m :: Array _) +instance setEncode :: (Ord a, Encode a) => Encode (Set a) where + encode s = let (arr :: Array a) = Set.toUnfoldable s in encode arr + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. From 0b954026834b0d6fc9438057be3883fbf658daaa Mon Sep 17 00:00:00 2001 From: David Smith Date: Mon, 17 Aug 2020 11:16:43 +0100 Subject: [PATCH 28/42] upgrade purs --- bower.json | 14 +++++--------- package.json | 10 +++++----- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/bower.json b/bower.json index fe2c285..59a51f6 100644 --- a/bower.json +++ b/bower.json @@ -15,18 +15,14 @@ "url": "git://github.com/paf31/purescript-foreign-generic.git" }, "dependencies": { - "purescript-effect": "^2.0.0", + "purescript-prelude": "^4.1.1", "purescript-foreign": "^5.0.0", - "purescript-foreign-object": "^2.0.0", - "purescript-generics-rep": "^6.0.0", - "purescript-ordered-collections": "^1.0.0", - "purescript-proxy": "^3.0.0", - "purescript-exceptions": "^4.0.0", - "purescript-record": "^2.0.0", - "purescript-identity": "^4.1.0" + "purescript-generics-rep": "^6.1.1", + "purescript-foreign-object": "^2.0.3", + "purescript-record": "^2.0.1" }, "devDependencies": { - "purescript-assert": "^4.0.0", + "purescript-assert": "^4.1.0", "purescript-psci-support": "^4.0.0" } } diff --git a/package.json b/package.json index eed8cda..2b386b1 100644 --- a/package.json +++ b/package.json @@ -7,10 +7,10 @@ "test": "pulp test" }, "devDependencies": { - "bower": "^1.8.4", - "pulp": "^12.0.0", - "purescript": "^0.12.0", - "purescript-psa": "^0.5.0", - "rimraf": "^2.5.0" + "bower": "^1.8.8", + "pulp": "^13.0.0", + "purescript": "^0.13.3", + "purescript-psa": "^0.7.3", + "rimraf": "^3.0.0" } } From 58a9b339ac66fe5f8068e25730e88b8c8d64ee69 Mon Sep 17 00:00:00 2001 From: David Smith Date: Mon, 17 Aug 2020 12:06:08 +0100 Subject: [PATCH 29/42] use spago in travis --- .travis.yml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index ebd09cd..d6d36ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,10 +3,8 @@ dist: trusty sudo: required node_js: stable install: - - npm install -g bower + - npm install -g purescript-spago - npm install script: - - bower install --production - - npm run -s build - - bower install - - npm run -s test + - spago build + - spago test From 037702997626918beee5717d9716dc7bffeed283 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 14:36:17 +0100 Subject: [PATCH 30/42] Adding a roundtrip test for Map. --- test/Main.purs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Main.purs b/test/Main.purs index de800b2..f7b88d6 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -6,6 +6,7 @@ import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) +import Data.Map as Map import Data.Maybe (Maybe(..), isNothing) import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) @@ -138,6 +139,7 @@ main = do testRoundTrip (makeTree 0) testRoundTrip (makeTree 5) testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) + testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From 961aa70c89bc37d22600fbc5da397a4e98520934 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 14:36:30 +0100 Subject: [PATCH 31/42] More flexible Map decoding. Sometimes Aeson encodes maps as objects with string keys, or as `null`. We can now decode these cases. --- src/Foreign/Generic/Class.purs | 42 +++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 640e41c..2146675 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -18,12 +18,13 @@ import Data.Newtype (unwrap) import Data.Set (Set) import Data.Set as Set import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) -import Data.Traversable (sequence) +import Data.Traversable (sequence, traverse) import Data.Tuple (Tuple(..)) -import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNumber, readString, unsafeToForeign, unsafeFromForeign) +import Foreign (F, Foreign, ForeignError(..), fail, typeOf, isArray, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, unsafeToForeign, unsafeFromForeign) import Foreign.Generic.Internal (readObject) +import Foreign.Index (hasProperty, index, readProp) +import Foreign.Keys as Keys import Foreign.NullOrUndefined (readNullOrUndefined, null) -import Foreign.Index (hasProperty, index) import Foreign.Object (Object) import Foreign.Object as Object import Prim.Row (class Cons, class Lacks) @@ -159,9 +160,38 @@ instance recordDecode :: (RowToList r rl, DecodeRecord r rl) => Decode (Record r decode = decodeWithOptions defaultOptions instance mapDecode :: (Ord k, Decode k, Decode v) => Decode (Map k v) where - decode f = do - (tuple :: Array (Tuple k v)) <- decode f - pure $ Map.fromFoldable tuple + decode json = decodeAsArrayOfPairs json <|> decodeAsObjectWithStringKeys json <|> decodeAsNull json + where + decodeAsArrayOfPairs o = do + pairs <- readArray o + asArray <- + traverse + ( \foreignPair -> + readArray foreignPair + >>= case _ of + [ foreignKey, foreignValue ] -> Tuple <$> decode foreignKey <*> decode foreignValue + other -> fail $ TypeMismatch "Array (key-value pair)" "" + ) + pairs + pure $ Map.fromFoldable asArray + + decodeAsObjectWithStringKeys o = do + keys <- Keys.keys o + asArray <- + traverse + ( \keyString -> do + foreignValue <- readProp keyString o + key <- decode $ encode keyString + value <- decode foreignValue + pure (Tuple key value) + ) + keys + pure $ Map.fromFoldable asArray + + decodeAsNull o = do + _ <- readNull o + pure mempty + instance setDecode :: (Ord a, Decode a) => Decode (Set a) where decode f = do From 652a993a54d32b0653bed5d9c872857f190d2bff Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 14:41:46 +0100 Subject: [PATCH 32/42] Adding encoders/decoders for Either. --- src/Foreign/Generic/Class.purs | 11 +++++++++++ test/Main.purs | 1 + 2 files changed, 12 insertions(+) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 2146675..7d8663a 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -198,6 +198,12 @@ instance setDecode :: (Ord a, Decode a) => Decode (Set a) where (arr :: Array a) <- decode f pure $ Set.fromFoldable arr +instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where + decode value = + (readProp "Left" value >>= (map Left <<< decode)) + <|> + (readProp "Right" value >>= (map Right <<< decode)) + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -267,6 +273,11 @@ instance mapEncode :: (Encode k, Encode v) => Encode (Map k v) where instance setEncode :: (Ord a, Encode a) => Encode (Set a) where encode s = let (arr :: Array a) = Set.toUnfoldable s in encode arr + +instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where + encode (Left a) = encode $ Object.singleton "Left" a + encode (Right b) = encode $ Object.singleton "Right" b + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. diff --git a/test/Main.purs b/test/Main.purs index f7b88d6..e9a2e0d 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -140,6 +140,7 @@ main = do testRoundTrip (makeTree 5) testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) + testRoundTrip [ Left 5, Right "Test" ] testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From 538d5e87c6b02076c9b141cf9734cfd1ca022586 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 16:15:45 +0100 Subject: [PATCH 33/42] Adding Data.BigInt support. --- bower.json | 3 ++- package.json | 3 +++ spago.dhall | 1 + src/Foreign/Generic/Class.purs | 12 +++++++++++- test/Main.purs | 2 ++ 5 files changed, 19 insertions(+), 2 deletions(-) diff --git a/bower.json b/bower.json index 59a51f6..b6e3512 100644 --- a/bower.json +++ b/bower.json @@ -19,7 +19,8 @@ "purescript-foreign": "^5.0.0", "purescript-generics-rep": "^6.1.1", "purescript-foreign-object": "^2.0.3", - "purescript-record": "^2.0.1" + "purescript-record": "^2.0.1", + "purescript-bigints": "^4.0.0" }, "devDependencies": { "purescript-assert": "^4.1.0", diff --git a/package.json b/package.json index 2b386b1..fe2953b 100644 --- a/package.json +++ b/package.json @@ -12,5 +12,8 @@ "purescript": "^0.13.3", "purescript-psa": "^0.7.3", "rimraf": "^3.0.0" + }, + "dependencies": { + "big-integer": "^1.6.48" } } diff --git a/spago.dhall b/spago.dhall index 74fbbf9..6da6e65 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,6 +5,7 @@ You can edit this file as you like. { name = "foreign-generic" , dependencies = [ "assert" + , "bigints" , "console" , "effect" , "exceptions" diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 7d8663a..94db9ac 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -6,7 +6,9 @@ import Control.Alt ((<|>)) import Control.Monad.Except (except, mapExcept) import Data.Array ((..), zipWith, length) import Data.Bifunctor (lmap) -import Data.Either (Either(..)) +import Data.BigInt (BigInt) +import Data.BigInt as BigInt +import Data.Either (Either(..), note) import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConstructors, Product(..), Sum(..)) import Data.Identity (Identity(..)) import Data.List (List(..), (:)) @@ -204,6 +206,11 @@ instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where <|> (readProp "Right" value >>= (map Right <<< decode)) +instance bigIntDecode :: Decode BigInt where + decode value = do + str <- readString value + except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str + -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -278,6 +285,9 @@ instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where encode (Left a) = encode $ Object.singleton "Left" a encode (Right b) = encode $ Object.singleton "Right" b +instance bigIntEncode :: Encode BigInt where + encode = encode <<< BigInt.toString + -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. diff --git a/test/Main.purs b/test/Main.purs index e9a2e0d..7886ef1 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -4,6 +4,7 @@ import Prelude import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) +import Data.BigInt as BigInt import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Map as Map @@ -141,6 +142,7 @@ main = do testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip [ Left 5, Right "Test" ] + testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 will confuse JavaScript. testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From b0584addca510b1d8312eb9bde4bcfcc5c68ae51 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 3 Sep 2020 16:31:39 +0100 Subject: [PATCH 34/42] Adding a shell.nix file, for a repeatable env. --- shell.nix | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 shell.nix diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..89138f3 --- /dev/null +++ b/shell.nix @@ -0,0 +1,30 @@ +{ pkgs ? import ( + builtins.fetchTarball { + name = "nixos-20.03"; + url = "https://github.com/NixOS/nixpkgs/archive/5272327b81ed355bbed5659b8d303cf2979b6953.tar.gz"; + sha256 = "0182ys095dfx02vl2a20j1hz92dx3mfgz2a6fhn31bqlp1wa8hlq"; + } + ) + {} +}: +let + easyPS = import ( + builtins.fetchTarball { + name = "easy-purescript"; + url = "https://github.com/justinwoo/easy-purescript-nix/archive/1ec689df0adf8e8ada7fcfcb513876307ea34226.tar.gz"; + sha256 = "12hk2zbjkrq2i5fs6xb3x254lnhm9fzkcxph0a7ngxyzfykvf4hi"; + } + ) {}; +in +pkgs.mkShell { + buildInputs = [ + pkgs.git + pkgs.yarn + pkgs.nodePackages.bower + pkgs.nodePackages.pulp + pkgs.nodejs + easyPS.spago + easyPS.purs + easyPS.purty + ]; +} From bcd6e20b321c63ba56f2c616455395af131e7df4 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 4 Sep 2020 14:59:49 +0100 Subject: [PATCH 35/42] Adding extra map-decoding tests. --- test/Main.purs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/test/Main.purs b/test/Main.purs index 7886ef1..b7a5af9 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -8,6 +8,7 @@ import Data.BigInt as BigInt import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Map as Map +import Data.Map (Map) import Data.Maybe (Maybe(..), isNothing) import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) @@ -20,7 +21,7 @@ import Foreign.Index (readProp) import Foreign.JSON (parseJSON) import Foreign.Object as Object import Global.Unsafe (unsafeStringify) -import Test.Assert (assert, assert') +import Test.Assert (assert, assert', assertEqual) import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a @@ -141,6 +142,12 @@ main = do testRoundTrip (makeTree 5) testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) + assertEqual { expected: Right (Map.fromFoldable [Tuple "foo" 5]) + , actual: runExcept (decodeJSON "{\"foo\": 5}") + } + assertEqual { expected: Right (Map.empty :: Map String Int) + , actual: runExcept (decodeJSON "null") + } testRoundTrip [ Left 5, Right "Test" ] testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 will confuse JavaScript. testUnaryConstructorLiteral From f840a4307c4d7d93eef76364be3295c4f58b8306 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 4 Sep 2020 15:00:45 +0100 Subject: [PATCH 36/42] Improving the resiliency of BigInt decoding. It will now decode ints as well. Note that this is just us being more tolerant of recieving something like `1234`. If the number sent is actually in the "big" integer range (>2^32) then it won't work and it's the sender's fault. The JSON spec doesn't support numbers that big. They'd have to be sent as strings. --- src/Foreign/Generic/Class.purs | 11 ++++++++--- test/Main.purs | 5 ++++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 94db9ac..a717c5f 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -207,9 +207,14 @@ instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where (readProp "Right" value >>= (map Right <<< decode)) instance bigIntDecode :: Decode BigInt where - decode value = do - str <- readString value - except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str + decode json = decodeAsString json <|> decodeAsDigits json + where + decodeAsString value = do + str <- readString value + except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str + decodeAsDigits value = do + int <- readInt value + pure $ BigInt.fromInt int -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. diff --git a/test/Main.purs b/test/Main.purs index b7a5af9..e31b198 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -149,7 +149,10 @@ main = do , actual: runExcept (decodeJSON "null") } testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 will confuse JavaScript. + testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. + assertEqual { expected: Right (BigInt.fromInt 50) + , actual: runExcept (decodeJSON "50") + } testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) From 2d2e3515a84232a48f93e9718dac01e905211ee7 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 8 Sep 2020 11:48:16 +0100 Subject: [PATCH 37/42] Improved encoding/decoding for big integers. Instead of encoding them as strings, we use numbers. 'Improved' is somewhat subjective here. More likely to be successfully read and written, perhaps less likely to be correct in all cases. Sadly I don't see a good alternative short of forking all the consuming libraries too. --- src/Foreign/Generic/Class.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index a717c5f..a445747 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -213,8 +213,8 @@ instance bigIntDecode :: Decode BigInt where str <- readString value except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str decodeAsDigits value = do - int <- readInt value - pure $ BigInt.fromInt int + number <- readNumber value + except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromNumber number -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. @@ -291,7 +291,7 @@ instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where encode (Right b) = encode $ Object.singleton "Right" b instance bigIntEncode :: Encode BigInt where - encode = encode <<< BigInt.toString + encode = unsafeToForeign <<< BigInt.toNumber -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) From cd8ed030bc3564fb6eda4d48b83a5c4ae939934c Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 11 Sep 2020 10:29:35 +0100 Subject: [PATCH 38/42] Moving to a more formal test suite. Since we no longer care about introducing a dependency on test-unit, let's tidy up the ad-hoc test framework. --- spago.dhall | 1 + test/Main.purs | 217 ++++++++++++++++++++++++------------------------ test/Types.purs | 4 + 3 files changed, 115 insertions(+), 107 deletions(-) diff --git a/spago.dhall b/spago.dhall index 6da6e65..ffb6a81 100644 --- a/spago.dhall +++ b/spago.dhall @@ -13,6 +13,7 @@ You can edit this file as you like. , "foreign-object" , "generics-rep" , "identity" + , "test-unit" , "ordered-collections" , "proxy" , "psci-support" diff --git a/test/Main.purs b/test/Main.purs index e31b198..54946cf 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,19 +1,17 @@ module Test.Main where import Prelude - import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.BigInt as BigInt import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) -import Data.Map as Map import Data.Map (Map) +import Data.Map as Map import Data.Maybe (Maybe(..), isNothing) import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) import Effect (Effect) -import Effect.Console (log) import Foreign (isNull, unsafeToForeign) import Foreign.Generic (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, encode, defaultOptions, decodeJSON, encodeJSON, genericDecodeJSON, genericEncodeJSON) import Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum) @@ -21,11 +19,15 @@ import Foreign.Index (readProp) import Foreign.JSON (parseJSON) import Foreign.Object as Object import Global.Unsafe (unsafeStringify) -import Test.Assert (assert, assert', assertEqual) +import Test.Assert (assert') import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) +import Test.Unit (TestSuite, failure, success, suite, test) +import Test.Unit.Assert (equal) +import Test.Unit.Main (runTest) buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a buildTree _ 0 a = Leaf a + buildTree f n a = Branch $ buildTree (bimap f f) (n - 1) (f a) -- A balanced binary tree of depth N @@ -35,126 +37,127 @@ makeTree n = buildTree (\i -> TupleArray (Tuple (2 * i) (2 * i + 1))) n 0 throw :: String -> Effect Unit throw = flip assert' false -testRoundTrip - :: ∀ a - . Eq a - => Decode a - => Encode a - => a - -> Effect Unit -testRoundTrip x = do - let json = encodeJSON x - log json - case runExcept (decodeJSON json) of - Right y -> assert (x == y) - Left err -> throw (show err) +testRoundTrip :: + ∀ a. + Eq a => + Show a => + Decode a => + Encode a => + a -> + TestSuite +testRoundTrip x = + test ("RoundTrip " <> show x) do + equal (Right x) (runExcept (decodeJSON (encodeJSON x))) -testGenericRoundTrip - :: ∀ a r - . Eq a - => Generic a r - => GenericDecode r - => GenericEncode r - => Options - -> a - -> Effect Unit -testGenericRoundTrip opts x = do - let json = genericEncodeJSON opts x - log json - case runExcept (genericDecodeJSON opts json) of - Right y -> assert (x == y) - Left err -> throw (show err) +testGenericRoundTrip :: + ∀ a r. + Eq a => + Show a => + Generic a r => + GenericDecode r => + GenericEncode r => + Options -> + a -> + TestSuite +testGenericRoundTrip opts x = + test ("Generic roundtrip " <> show x) do + equal (Right x) (runExcept (genericDecodeJSON opts (genericEncodeJSON opts x))) -testOption - :: ∀ a rep - . Eq a - => Generic a rep - => GenericEncodeEnum rep - => GenericDecodeEnum rep - => GenericEnumOptions - -> String - -> a - -> Effect Unit -testOption options string value = do - let json = unsafeStringify $ genericEncodeEnum options value - log json - case runExcept $ Tuple <$> decode' json <*> decode' string of - Right (Tuple x y) -> assert (value == y && value == x) - Left err -> throw (show err) +testOption :: + ∀ a rep. + Eq a => + Show a => + Generic a rep => + GenericEncodeEnum rep => + GenericDecodeEnum rep => + GenericEnumOptions -> + String -> + a -> + TestSuite +testOption options string value = + test "testOption" do + let + json = unsafeStringify $ genericEncodeEnum options value + equal (Right value) (runExcept (decode' json)) + equal (Right value) (runExcept (decode' string)) where - decode' = genericDecodeEnum options <=< parseJSON + decode' = genericDecodeEnum options <=< parseJSON -testUnaryConstructorLiteral :: Effect Unit +testUnaryConstructorLiteral :: TestSuite testUnaryConstructorLiteral = do - testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel - testOption (makeCasingOptions toLower) "\"frikandel\"" Frikandel + testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel + testOption (makeCasingOptions toLower) "\"frikandel\"" Frikandel where - makeCasingOptions f = - { constructorTagTransform: f - } + makeCasingOptions f = + { constructorTagTransform: f + } -- Test that `Nothing` record fields, when encoded to JSON, are present and -- encoded as `null` -testNothingToNull :: Effect Unit +testNothingToNull :: TestSuite testNothingToNull = - let - json = encode (UndefinedTest {a: Nothing}) - in do - log (encodeJSON json) + test "Nothing to Null" do + let json = encode (UndefinedTest { a: Nothing }) case runExcept (pure json >>= readProp "contents" >>= readProp "a") of Right val -> - when (not (isNull val)) - (throw ("property 'a' was not null; got: " <> encodeJSON val)) - Left err -> - throw (show err) + if (isNull val) then + success + else + failure ("property 'a' was not null; got: " <> encodeJSON val) + Left err -> failure (show err) -- Test that `Maybe` fields which are not present in the JSON are decoded to -- `Nothing` -testNothingFromMissing :: Effect Unit +testNothingFromMissing :: TestSuite testNothingFromMissing = - let - json = unsafeToForeign - { tag: "UndefinedTest" - , contents: 0 - } - in + test "Nothing from missing" do + let + json = + unsafeToForeign + { tag: "UndefinedTest" + , contents: 0 + } case runExcept (decode json) of Right (UndefinedTest x) -> - when (not (isNothing x.a)) - (throw ("Expected Nothing, got: " <> show x.a)) - Left err -> - throw (show err) + if (isNothing x.a) then + success + else + failure ("Expected Nothing, got: " <> show x.a) + Left err -> failure (show err) 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}) - testRoundTrip [Just "test"] - testRoundTrip [Nothing :: Maybe String] - testRoundTrip (Apple) - testRoundTrip (makeTree 0) - testRoundTrip (makeTree 5) - testRoundTrip (Object.fromFoldable [Tuple "one" 1, Tuple "two" 2]) - testRoundTrip (Map.fromFoldable [Tuple "one" 1, Tuple "two" 2]) - assertEqual { expected: Right (Map.fromFoldable [Tuple "foo" 5]) - , actual: runExcept (decodeJSON "{\"foo\": 5}") - } - assertEqual { expected: Right (Map.empty :: Map String Int) - , actual: runExcept (decodeJSON "null") - } - testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. - assertEqual { expected: Right (BigInt.fromInt 50) - , actual: runExcept (decodeJSON "50") - } - testUnaryConstructorLiteral - let opts = defaultOptions { fieldTransform = toUpper } - testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) - testNothingToNull - testNothingFromMissing +main = + runTest do + suite "RoundTrips" 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 }) + testRoundTrip [ Just "test" ] + testRoundTrip [ Nothing :: Maybe String ] + testRoundTrip (Apple) + testRoundTrip (makeTree 0) + testRoundTrip (makeTree 5) + testRoundTrip (Object.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + testRoundTrip (Map.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + test "Maps" do + equal (Right (Map.fromFoldable [ Tuple "foo" 5 ])) + (runExcept (decodeJSON "{\"foo\": 5}")) + equal (Right (Map.empty :: Map String Int)) + (runExcept (decodeJSON "null")) + testRoundTrip [ Left 5, Right "Test" ] + testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. + test "BigInt" do + equal (Right (BigInt.fromInt 50)) + (runExcept (decodeJSON "50")) + testUnaryConstructorLiteral + let + opts = defaultOptions { fieldTransform = toUpper } + pure unit + testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) + testNothingToNull + testNothingFromMissing diff --git a/test/Types.purs b/test/Types.purs index e915ff0..80a5ce3 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -140,6 +140,8 @@ newtype UndefinedTest = UndefinedTest derive instance eqUT :: Eq UndefinedTest derive instance geUT :: Generic UndefinedTest _ +instance showUT :: Show UndefinedTest where + show = genericShow instance dUT :: Decode UndefinedTest where decode = genericDecode $ defaultOptions instance eUT :: Encode UndefinedTest where @@ -153,6 +155,8 @@ data Fruit derive instance eqFruit :: Eq Fruit derive instance geFruit :: Generic Fruit _ +instance showFruit :: Show Fruit where + show = genericShow instance dFruit :: Decode Fruit where decode = genericDecodeEnum defaultGenericEnumOptions instance eFruit :: Encode Fruit where From 040060dfd5cef229d048ff1709971e3483f0c078 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 10 Sep 2020 16:25:33 +0100 Subject: [PATCH 39/42] BigInteger support. The motivation for this is JSON parsing. In order to correctly parse big integers from JSON, we need use a custom parser. The `JSON.parse` builtin won't do. --- bower.json | 2 +- package.json | 3 +- spago.dhall | 3 +- src/Data/BigInteger.js | 97 +++++++++++++++++++++++++++++++ src/Data/BigInteger.purs | 97 +++++++++++++++++++++++++++++++ src/Foreign/Generic.purs | 5 +- src/Foreign/Generic/Class.purs | 17 +----- src/Foreign/Generic/Internal.purs | 1 - src/Foreign/JSON.js | 9 ++- src/Foreign/JSON.purs | 3 + test/BigIntegerTests.purs | 66 +++++++++++++++++++++ test/Main.purs | 18 ++++-- test/Types.purs | 4 +- 13 files changed, 294 insertions(+), 31 deletions(-) create mode 100644 src/Data/BigInteger.js create mode 100644 src/Data/BigInteger.purs create mode 100644 test/BigIntegerTests.purs diff --git a/bower.json b/bower.json index b6e3512..f1e51dd 100644 --- a/bower.json +++ b/bower.json @@ -20,7 +20,7 @@ "purescript-generics-rep": "^6.1.1", "purescript-foreign-object": "^2.0.3", "purescript-record": "^2.0.1", - "purescript-bigints": "^4.0.0" + "purescript-quickcheck": "^6.1.0" }, "devDependencies": { "purescript-assert": "^4.1.0", diff --git a/package.json b/package.json index fe2953b..14e2015 100644 --- a/package.json +++ b/package.json @@ -14,6 +14,7 @@ "rimraf": "^3.0.0" }, "dependencies": { - "big-integer": "^1.6.48" + "bignumber": "^1.1.0", + "json-bigint": "^1.0.0" } } diff --git a/spago.dhall b/spago.dhall index ffb6a81..72e4f55 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,7 +5,6 @@ You can edit this file as you like. { name = "foreign-generic" , dependencies = [ "assert" - , "bigints" , "console" , "effect" , "exceptions" @@ -13,6 +12,8 @@ You can edit this file as you like. , "foreign-object" , "generics-rep" , "identity" + , "rationals" + , "quickcheck" , "test-unit" , "ordered-collections" , "proxy" diff --git a/src/Data/BigInteger.js b/src/Data/BigInteger.js new file mode 100644 index 0000000..f76bae9 --- /dev/null +++ b/src/Data/BigInteger.js @@ -0,0 +1,97 @@ +/*global exports, require*/ +'use strict'; + +var BigNumber = require('bignumber.js'); + +exports.eq_ = function (a) { + return function (b) { + return a.isEqualTo(b); + }; +}; + +exports.show_ = function (n) { + return n.toString(10); +}; + +exports.toNumber = function (n) { + return n.toNumber(); +}; + +exports.fromInt = function (int) { + return BigNumber(int); +}; + +exports.fromString_ = function (nothing) { + return function (just) { + return function (str) { + var n = BigNumber(str); + if (n && n.isInteger()) { + return just(n); + } else { + return nothing; + } + }; + }; +}; + +exports.add_ = function (x) { + return function (y) { + return x.plus(y); + }; +}; + +exports.mul_ = function (x) { + return function (y) { + return x.multipliedBy(y); + }; +}; + +exports.sub_ = function (x) { + return function (y) { + return x.minus(y); + }; +}; + +exports.div_ = function (x) { + return function (y) { + return x.dividedToIntegerBy(y); + }; +}; + +exports.mod_ = function (x) { + return function (y) { + return x.modulo(y); + }; +}; + +exports.degree_ = function (x) { + return x.absoluteValue().toNumber(); +}; + +exports.comparedTo_ = function (x) { + return function (y) { + return x.comparedTo(y); + }; +}; + +exports.readBigInteger_ = function (nothing) { + return function (just) { + return function (value) { + var tag = Object.prototype.toString.call(value).slice(8,-1); + if (value !== undefined && (BigNumber.isBigNumber(value) || tag === "Number" || tag === "String")) { + var n = BigNumber(value); + if (n && n.isInteger()) { + return just(n); + } else { + return nothing; + } + } else { + return nothing; + } + }; + }; +}; + +exports.format = function (value) { + return value.toFormat(); +}; diff --git a/src/Data/BigInteger.purs b/src/Data/BigInteger.purs new file mode 100644 index 0000000..e7c911e --- /dev/null +++ b/src/Data/BigInteger.purs @@ -0,0 +1,97 @@ +module Data.BigInteger + ( BigInteger + , fromString + , fromInt + , toNumber + , format + , readBigInteger + ) where + +import Control.Applicative (pure) +import Data.CommutativeRing (class CommutativeRing) +import Data.Eq (class Eq) +import Data.EuclideanRing (class EuclideanRing) +import Data.Function (($)) +import Data.Maybe (Maybe(..)) +import Data.Ord (class Ord, compare) +import Data.Ring (class Ring) +import Data.Semiring (class Semiring) +import Data.Show (class Show) +import Foreign (fail, tagOf, unsafeToForeign) +import Foreign.Generic (F, Foreign, ForeignError(..)) +import Foreign.Generic.Class (class Decode, class Encode) + +foreign import data BigInteger :: Type + +------------------------------------------------------------ +foreign import eq_ :: BigInteger -> BigInteger -> Boolean + +instance eqBigInteger :: Eq BigInteger where + eq = eq_ + +foreign import comparedTo_ :: BigInteger -> BigInteger -> Int + +instance ordBigInteger :: Ord BigInteger where + compare x y = compare (comparedTo_ x y) 0 + +foreign import show_ :: BigInteger -> String + +instance showBigInteger :: Show BigInteger where + show = show_ + +------------------------------------------------------------ +foreign import add_ :: BigInteger -> BigInteger -> BigInteger + +foreign import mul_ :: BigInteger -> BigInteger -> BigInteger + +instance semiringBigInteger :: Semiring BigInteger where + zero = fromInt 0 + one = fromInt 1 + add = add_ + mul = mul_ + +foreign import sub_ :: BigInteger -> BigInteger -> BigInteger + +instance ringBigInteger :: Ring BigInteger where + sub = sub_ + +foreign import div_ :: BigInteger -> BigInteger -> BigInteger + +foreign import mod_ :: BigInteger -> BigInteger -> BigInteger + +foreign import degree_ :: BigInteger -> Int + +instance commutativeRingBigInteger :: CommutativeRing BigInteger + +instance euclideanRingBigInteger :: EuclideanRing BigInteger where + div = div_ + mod = mod_ + degree = degree_ + +------------------------------------------------------------ +foreign import fromInt :: Int -> BigInteger + +foreign import toNumber :: BigInteger -> Number + +foreign import fromString_ :: Maybe BigInteger -> (BigInteger -> Maybe BigInteger) -> String -> Maybe BigInteger + +fromString :: String -> Maybe BigInteger +fromString = fromString_ Nothing Just + +------------------------------------------------------------ +instance bigIntegerDecode :: Decode BigInteger where + decode = readBigInteger + +instance bigIntegerEncode :: Encode BigInteger where + encode = unsafeToForeign + +foreign import readBigInteger_ :: Maybe BigInteger -> (BigInteger -> Maybe BigInteger) -> Foreign -> Maybe BigInteger + +-- | Attempt to coerce a foreign value to a `BigInteger`. +readBigInteger :: Foreign -> F BigInteger +readBigInteger value = case readBigInteger_ Nothing Just value of + Just n -> pure n + Nothing -> fail $ TypeMismatch "bigint" (tagOf value) + +------------------------------------------------------------ +foreign import format :: BigInteger -> String diff --git a/src/Foreign/Generic.purs b/src/Foreign/Generic.purs index 3125a7d..d5953fa 100644 --- a/src/Foreign/Generic.purs +++ b/src/Foreign/Generic.purs @@ -13,10 +13,9 @@ import Prelude import Data.Generic.Rep (class Generic, from, to) import Foreign (F, Foreign) import Foreign (F, Foreign, ForeignError(..)) as Reexports -import Foreign.Generic.Class (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, decodeOpts, encode, encodeOpts) import Foreign.Generic.Class (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, SumEncoding(..), defaultOptions, decode, encode) as Reexports -import Foreign.JSON (decodeJSONWith, parseJSON) -import Global.Unsafe (unsafeStringify) +import Foreign.Generic.Class (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, decodeOpts, encode, encodeOpts) +import Foreign.JSON (decodeJSONWith, parseJSON, unsafeStringify) -- | Read a value which has a `Generic` type. genericDecode diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index a445747..7d8663a 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -6,9 +6,7 @@ import Control.Alt ((<|>)) import Control.Monad.Except (except, mapExcept) import Data.Array ((..), zipWith, length) import Data.Bifunctor (lmap) -import Data.BigInt (BigInt) -import Data.BigInt as BigInt -import Data.Either (Either(..), note) +import Data.Either (Either(..)) import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConstructors, Product(..), Sum(..)) import Data.Identity (Identity(..)) import Data.List (List(..), (:)) @@ -206,16 +204,6 @@ instance eitherDecode :: (Decode a, Decode b) => Decode (Either a b) where <|> (readProp "Right" value >>= (map Right <<< decode)) -instance bigIntDecode :: Decode BigInt where - decode json = decodeAsString json <|> decodeAsDigits json - where - decodeAsString value = do - str <- readString value - except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromString str - decodeAsDigits value = do - number <- readNumber value - except $ note (pure (ForeignError ("Expected BigInt"))) $ BigInt.fromNumber number - -- | The `Encode` class is used to generate encoding functions -- | of the form `a -> Foreign` using `generics-rep` deriving. -- | @@ -290,9 +278,6 @@ instance encodeEither :: (Encode a, Encode b) => Encode (Either a b) where encode (Left a) = encode $ Object.singleton "Left" a encode (Right b) = encode $ Object.singleton "Right" b -instance bigIntEncode :: Encode BigInt where - encode = unsafeToForeign <<< BigInt.toNumber - -- | When deriving `En`/`Decode` instances using `Generic`, we want -- | the `Options` object to apply to the outermost record type(s) -- | under the data constructors. diff --git a/src/Foreign/Generic/Internal.purs b/src/Foreign/Generic/Internal.purs index 6a0d5cd..7412026 100644 --- a/src/Foreign/Generic/Internal.purs +++ b/src/Foreign/Generic/Internal.purs @@ -1,7 +1,6 @@ module Foreign.Generic.Internal where import Prelude - import Foreign (F, Foreign, ForeignError(..), fail, tagOf, unsafeFromForeign) import Foreign.Object (Object) diff --git a/src/Foreign/JSON.js b/src/Foreign/JSON.js index 5ec76c1..e8971c7 100644 --- a/src/Foreign/JSON.js +++ b/src/Foreign/JSON.js @@ -1,5 +1,12 @@ +/*global exports, require*/ "use strict"; +var JSONbig = require('json-bigint'); + exports.parseJSONImpl = function (str) { - return JSON.parse(str); + return JSONbig.parse(str); +}; + +exports.unsafeStringify = function (value) { + return JSONbig.stringify(value); }; diff --git a/src/Foreign/JSON.purs b/src/Foreign/JSON.purs index 565d253..3d9f976 100644 --- a/src/Foreign/JSON.purs +++ b/src/Foreign/JSON.purs @@ -1,6 +1,7 @@ module Foreign.JSON ( parseJSON , decodeJSONWith + , unsafeStringify ) where import Control.Monad.Except (ExceptT(..)) @@ -26,3 +27,5 @@ parseJSON = decodeJSONWith :: forall a. (Foreign -> F a) -> String -> F a decodeJSONWith f = f <=< parseJSON + +foreign import unsafeStringify :: forall a. a -> String diff --git a/test/BigIntegerTests.purs b/test/BigIntegerTests.purs new file mode 100644 index 0000000..b18c004 --- /dev/null +++ b/test/BigIntegerTests.purs @@ -0,0 +1,66 @@ +module BigIntegerTests where + +import Prelude +import Control.Monad.Except (runExcept) +import Data.BigInteger (fromInt, readBigInteger, format) +import Data.BigInteger as BigInteger +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Data.Ord (abs) +import Data.Ratio (reduce) +import Data.Tuple (Tuple(..)) +import Foreign (unsafeToForeign) +import Foreign.Generic (ForeignError(..)) +import Test.QuickCheck ((===)) +import Test.Unit (TestSuite, suite, test) +import Test.Unit.Assert (equal) +import Test.Unit.QuickCheck (quickCheck) + +all :: TestSuite +all = + suite "BigInteger" do + test "show(some_int) is always parsable." do + quickCheck \x -> + Just (fromInt x) === (BigInteger.fromString (show x)) + test "show behaves as it would for Int" do + quickCheck \x -> + show x === show (fromInt x) + test "abs behaves as it would for Int" do + quickCheck \x -> + fromInt (abs x) === abs (fromInt x) + test "compare behaves as it would for Int" do + quickCheck \(Tuple x y) -> + compare x y === compare (fromInt x) (fromInt y) + test "Rationals" do + equal + (reduce (fromInt 2) (fromInt 3)) + (reduce (fromInt 50) (fromInt 75)) + equal + (reduce (fromInt 181) (fromInt 97)) + (reduce (fromInt 362) (fromInt 194)) + suite "readBigInteger" do + suite "should succeed" do + test "int" do + equal (Right zero) + (runExcept (readBigInteger (unsafeToForeign 0))) + equal (Right (fromInt 1234)) + (runExcept (readBigInteger (unsafeToForeign 1234))) + test "big integer" do + equal (Right (fromInt 123)) + (runExcept (readBigInteger (unsafeToForeign (fromInt 123)))) + test "good string" do + equal (Right (fromInt 123)) + (runExcept (readBigInteger (unsafeToForeign "123"))) + suite "should fail" do + test "float" do + equal (Left (pure (TypeMismatch "bigint" "Number"))) + (runExcept (readBigInteger (unsafeToForeign 1234.6789))) + test "object" do + equal (Left (pure (TypeMismatch "bigint" "Object"))) + (runExcept (readBigInteger (unsafeToForeign { a: 1 }))) + test "bad string" do + equal (Left (pure (TypeMismatch "bigint" "String"))) + (runExcept (readBigInteger (unsafeToForeign "asdf"))) + test "formatting" do + equal "0" (format zero) + equal "1,234,567,890" (format (fromInt 1234567890)) diff --git a/test/Main.purs b/test/Main.purs index 54946cf..c367e00 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,9 +1,10 @@ module Test.Main where import Prelude +import BigIntegerTests as BigIntegerTests import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) -import Data.BigInt as BigInt +import Data.BigInteger as BigInteger import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Map (Map) @@ -128,6 +129,11 @@ testNothingFromMissing = main :: Effect Unit main = runTest do + roundTripTests + BigIntegerTests.all + +roundTripTests :: TestSuite +roundTripTests = suite "RoundTrips" do testRoundTrip (RecordTest { foo: 1, bar: "test", baz: 'a' }) testRoundTrip NoArgs @@ -150,10 +156,12 @@ main = equal (Right (Map.empty :: Map String Int)) (runExcept (decodeJSON "null")) testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInt.pow (BigInt.fromInt 2) (BigInt.fromInt 60)) -- 2^60. Anything over 2^32 would baffle JavaScript. - test "BigInt" do - equal (Right (BigInt.fromInt 50)) - (runExcept (decodeJSON "50")) + testRoundTrip (BigInteger.fromString ("9055784127882682410409638")) -- 2^60. Anything over 2^32 would baffle JavaScript. + test "BigInteger" do + equal (Right (BigInteger.fromInt 50)) + (runExcept (decodeJSON "50")) + equal (Right {a: (BigInteger.fromInt 50)}) + (runExcept (decodeJSON "{\"a\": 50}")) testUnaryConstructorLiteral let opts = defaultOptions { fieldTransform = toUpper } diff --git a/test/Types.purs b/test/Types.purs index 80a5ce3..a6c505a 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -141,7 +141,7 @@ derive instance eqUT :: Eq UndefinedTest derive instance geUT :: Generic UndefinedTest _ instance showUT :: Show UndefinedTest where - show = genericShow + show x = genericShow x instance dUT :: Decode UndefinedTest where decode = genericDecode $ defaultOptions instance eUT :: Encode UndefinedTest where @@ -156,7 +156,7 @@ derive instance eqFruit :: Eq Fruit derive instance geFruit :: Generic Fruit _ instance showFruit :: Show Fruit where - show = genericShow + show x = genericShow x instance dFruit :: Decode Fruit where decode = genericDecodeEnum defaultGenericEnumOptions instance eFruit :: Encode Fruit where From 2a6259328c0cb0f06065cec03def70ee7b3c45b4 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 17 Sep 2020 09:59:13 +0100 Subject: [PATCH 40/42] Refactoring the test suite. --- test/Main.purs | 132 ++++++++++++++------------------------------ test/TestUtils.purs | 63 +++++++++++++++++++++ 2 files changed, 103 insertions(+), 92 deletions(-) create mode 100644 test/TestUtils.purs diff --git a/test/Main.purs b/test/Main.purs index c367e00..58cf6f3 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,12 +1,12 @@ module Test.Main where import Prelude +import TestUtils (testGenericRoundTrip, testOption, testRoundTrip) import BigIntegerTests as BigIntegerTests import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.BigInteger as BigInteger import Data.Either (Either(..)) -import Data.Generic.Rep (class Generic) import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), isNothing) @@ -14,14 +14,10 @@ import Data.String (toLower, toUpper) import Data.Tuple (Tuple(..)) import Effect (Effect) import Foreign (isNull, unsafeToForeign) -import Foreign.Generic (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decode, encode, defaultOptions, decodeJSON, encodeJSON, genericDecodeJSON, genericEncodeJSON) -import Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum) +import Foreign.Generic (decode, decodeJSON, defaultOptions, encode, encodeJSON) import Foreign.Index (readProp) -import Foreign.JSON (parseJSON) import Foreign.Object as Object -import Global.Unsafe (unsafeStringify) -import Test.Assert (assert') -import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) +import Test.Types (Fruit(..), IntList(..), RecordTest(..), SumWithRecord(..), Tree(..), TupleArray(..), UndefinedTest(..)) import Test.Unit (TestSuite, failure, success, suite, test) import Test.Unit.Assert (equal) import Test.Unit.Main (runTest) @@ -35,55 +31,6 @@ buildTree f n a = Branch $ buildTree (bimap f f) (n - 1) (f a) makeTree :: Int -> Tree Int makeTree n = buildTree (\i -> TupleArray (Tuple (2 * i) (2 * i + 1))) n 0 -throw :: String -> Effect Unit -throw = flip assert' false - -testRoundTrip :: - ∀ a. - Eq a => - Show a => - Decode a => - Encode a => - a -> - TestSuite -testRoundTrip x = - test ("RoundTrip " <> show x) do - equal (Right x) (runExcept (decodeJSON (encodeJSON x))) - -testGenericRoundTrip :: - ∀ a r. - Eq a => - Show a => - Generic a r => - GenericDecode r => - GenericEncode r => - Options -> - a -> - TestSuite -testGenericRoundTrip opts x = - test ("Generic roundtrip " <> show x) do - equal (Right x) (runExcept (genericDecodeJSON opts (genericEncodeJSON opts x))) - -testOption :: - ∀ a rep. - Eq a => - Show a => - Generic a rep => - GenericEncodeEnum rep => - GenericDecodeEnum rep => - GenericEnumOptions -> - String -> - a -> - TestSuite -testOption options string value = - test "testOption" do - let - json = unsafeStringify $ genericEncodeEnum options value - equal (Right value) (runExcept (decode' json)) - equal (Right value) (runExcept (decode' string)) - where - decode' = genericDecodeEnum options <=< parseJSON - testUnaryConstructorLiteral :: TestSuite testUnaryConstructorLiteral = do testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel @@ -98,7 +45,8 @@ testUnaryConstructorLiteral = do testNothingToNull :: TestSuite testNothingToNull = test "Nothing to Null" do - let json = encode (UndefinedTest { a: Nothing }) + let + json = encode (UndefinedTest { a: Nothing }) case runExcept (pure json >>= readProp "contents" >>= readProp "a") of Right val -> if (isNull val) then @@ -134,38 +82,38 @@ main = roundTripTests :: TestSuite roundTripTests = - suite "RoundTrips" 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 }) - testRoundTrip [ Just "test" ] - testRoundTrip [ Nothing :: Maybe String ] - testRoundTrip (Apple) - testRoundTrip (makeTree 0) - testRoundTrip (makeTree 5) - testRoundTrip (Object.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) - testRoundTrip (Map.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) - test "Maps" do - equal (Right (Map.fromFoldable [ Tuple "foo" 5 ])) - (runExcept (decodeJSON "{\"foo\": 5}")) - equal (Right (Map.empty :: Map String Int)) - (runExcept (decodeJSON "null")) - testRoundTrip [ Left 5, Right "Test" ] - testRoundTrip (BigInteger.fromString ("9055784127882682410409638")) -- 2^60. Anything over 2^32 would baffle JavaScript. - test "BigInteger" do - equal (Right (BigInteger.fromInt 50)) - (runExcept (decodeJSON "50")) - equal (Right {a: (BigInteger.fromInt 50)}) - (runExcept (decodeJSON "{\"a\": 50}")) - testUnaryConstructorLiteral - let - opts = defaultOptions { fieldTransform = toUpper } - pure unit - testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) - testNothingToNull - testNothingFromMissing + suite "RoundTrips" 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 }) + testRoundTrip [ Just "test" ] + testRoundTrip [ Nothing :: Maybe String ] + testRoundTrip (Apple) + testRoundTrip (makeTree 0) + testRoundTrip (makeTree 5) + testRoundTrip (Object.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + testRoundTrip (Map.fromFoldable [ Tuple "one" 1, Tuple "two" 2 ]) + test "Maps" do + equal (Right (Map.fromFoldable [ Tuple "foo" 5 ])) + (runExcept (decodeJSON "{\"foo\": 5}")) + equal (Right (Map.empty :: Map String Int)) + (runExcept (decodeJSON "null")) + testRoundTrip [ Left 5, Right "Test" ] + testRoundTrip (BigInteger.fromString ("9055784127882682410409638")) -- 2^60. Anything over 2^32 would baffle JavaScript. + test "BigInteger" do + equal (Right (BigInteger.fromInt 50)) + (runExcept (decodeJSON "50")) + equal (Right { a: (BigInteger.fromInt 50) }) + (runExcept (decodeJSON "{\"a\": 50}")) + testUnaryConstructorLiteral + let + opts = defaultOptions { fieldTransform = toUpper } + pure unit + testGenericRoundTrip opts (RecordTest { foo: 1, bar: "test", baz: 'a' }) + testNothingToNull + testNothingFromMissing diff --git a/test/TestUtils.purs b/test/TestUtils.purs new file mode 100644 index 0000000..a9fcd75 --- /dev/null +++ b/test/TestUtils.purs @@ -0,0 +1,63 @@ +module TestUtils where + +import Prelude +import Control.Monad.Except (runExcept) +import Data.Either (Either(..)) +import Data.Generic.Rep (class Generic) +import Effect (Effect) +import Foreign.Generic (class Decode, class Encode, class GenericDecode, class GenericEncode, Options, decodeJSON, encodeJSON, genericDecodeJSON, genericEncodeJSON) +import Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum) +import Foreign.JSON (parseJSON) +import Global.Unsafe (unsafeStringify) +import Test.Assert (assert') +import Test.Unit (TestSuite, test) +import Test.Unit.Assert (equal) + +throw :: String -> Effect Unit +throw = flip assert' false + +testRoundTrip :: + ∀ a. + Eq a => + Show a => + Decode a => + Encode a => + a -> + TestSuite +testRoundTrip x = + test ("RoundTrip " <> show x) do + equal (Right x) (runExcept (decodeJSON (encodeJSON x))) + +testGenericRoundTrip :: + ∀ a r. + Eq a => + Show a => + Generic a r => + GenericDecode r => + GenericEncode r => + Options -> + a -> + TestSuite +testGenericRoundTrip opts x = + test ("Generic roundtrip " <> show x) do + equal (Right x) (runExcept (genericDecodeJSON opts (genericEncodeJSON opts x))) + +testOption :: + ∀ a rep. + Eq a => + Show a => + Generic a rep => + GenericEncodeEnum rep => + GenericDecodeEnum rep => + GenericEnumOptions -> + String -> + a -> + TestSuite +testOption options string value = + test "testOption" do + let + json = unsafeStringify $ genericEncodeEnum options value + equal (Right value) (runExcept (decode' json)) + equal (Right value) (runExcept (decode' string)) + where + decode' = genericDecodeEnum options <=< parseJSON From 22aac68fbd80d49bf49317343863408a22a8a0db Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 17 Sep 2020 11:04:17 +0100 Subject: [PATCH 41/42] Fixing a bug with aeson-style encoding on nested sum types. And adding tests. --- src/Foreign/Generic/Class.purs | 9 ++-- test/AesonEncodingTests.purs | 99 ++++++++++++++++++++++++++++++++++ test/Main.purs | 2 + 3 files changed, 107 insertions(+), 3 deletions(-) create mode 100644 test/AesonEncodingTests.purs diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 7d8663a..b54bb6f 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -1,7 +1,6 @@ module Foreign.Generic.Class where import Prelude - import Control.Alt ((<|>)) import Control.Monad.Except (except, mapExcept) import Data.Array ((..), zipWith, length) @@ -420,8 +419,12 @@ instance genericEncodeConstructor then maybe (unsafeToForeign {}) unsafeToForeign (encodeArgsArray args) else case opts.sumEncoding of TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> - unsafeToForeign (Object.singleton tagFieldName (unsafeToForeign $ constructorTagTransform ctorName) - `Object.union` objectFromArgs opts.sumEncoding (encodeArgsArray args)) + unsafeToForeign $ + let tagPart = Object.singleton tagFieldName (unsafeToForeign $ constructorTagTransform ctorName) + contentPart = objectFromArgs opts.sumEncoding (encodeArgsArray args) + in if Object.member tagFieldName contentPart + then Object.insert contentsFieldName (unsafeToForeign contentPart) tagPart + else tagPart `Object.union` contentPart where ctorName = reflectSymbol (SProxy :: SProxy name) diff --git a/test/AesonEncodingTests.purs b/test/AesonEncodingTests.purs new file mode 100644 index 0000000..877dbc4 --- /dev/null +++ b/test/AesonEncodingTests.purs @@ -0,0 +1,99 @@ +module AesonEncodingTests (all) where + +import Prelude +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Foreign.Generic (class Decode, class Encode, Options, defaultOptions, encodeJSON, genericDecode, genericEncode) +import Foreign.Generic.Class (aesonSumEncoding) +import Test.Unit (TestSuite, suite, test) +import Test.Unit.Assert (equal) +import TestUtils (testRoundTrip) + +all :: TestSuite +all = + suite "Aeson Encoding" do + suite "Records" do + test "Record" do + equal "{\"name\":\"Tester\",\"age\":13}" + (encodeJSON (ARecord { name: "Tester", age: 13 })) + testRoundTrip (ARecord { name: "Tester", age: 13 }) + suite "Sum Types" do + test "Sum type, no arg constructor." do + equal "{\"tag\":\"NoShipperChoice\"}" + (encodeJSON NoShipperChoice) + test "Sum type, 1 arg constructor." do + equal "{\"contents\":\"Test\",\"tag\":\"ShipperChoice\"}" + (encodeJSON (ShipperChoice "Test")) + testRoundTrip NoShipperChoice + testRoundTrip (ShipperChoice "Test") + suite "Nesting" do + test "Nested no arg constructor" do + equal "{\"tag\":\"FreightForwarderShipper\",\"contents\":{\"tag\":\"NoShipperChoice\"}}" + (encodeJSON (FreightForwarderShipper NoShipperChoice)) + test "Nested 1 arg constructor" do + equal "{\"tag\":\"FreightForwarderShipper\",\"contents\":{\"contents\":\"Test\",\"tag\":\"ShipperChoice\"}}" + (encodeJSON (FreightForwarderShipper (ShipperChoice "Test"))) + testRoundTrip (FreightForwarderShipper NoShipperChoice) + testRoundTrip (FreightForwarderShipper (ShipperChoice "Test")) + +------------------------------------------------------------ +opts :: Options +opts = + defaultOptions + { sumEncoding = aesonSumEncoding + , unwrapSingleConstructors = true + } + +------------------------------------------------------------ +newtype ARecord + = ARecord + { name :: String + , age :: Int + } + +derive instance eqARecord :: Eq ARecord + +derive instance genericARecord :: Generic ARecord _ + +instance showARecord :: Show ARecord where + show = genericShow + +instance decodeARecord :: Decode ARecord where + decode value = genericDecode opts value + +instance encodeARecord :: Encode ARecord where + encode value = genericEncode opts value + +data ShipperChoice + = ShipperChoice String + | NoShipperChoice + +derive instance eqShipperChoice :: Eq ShipperChoice + +derive instance genericShipperChoice :: Generic ShipperChoice _ + +instance showShipperChoice :: Show ShipperChoice where + show = genericShow + +instance decodeShipperChoice :: Decode ShipperChoice where + decode value = genericDecode opts value + +instance encodeShipperChoice :: Encode ShipperChoice where + encode value = genericEncode opts value + +data FreightForwarderChoice + = FreightForwarderContact Int + | FreightForwarderShipper ShipperChoice + +derive instance eqFreightForwarderChoice :: Eq FreightForwarderChoice + +derive instance genericFreightForwarderChoice :: Generic FreightForwarderChoice _ + +instance showFreightForwarderChoice :: Show FreightForwarderChoice where + show = genericShow + +instance decodeFreightForwarderChoice :: Decode FreightForwarderChoice where + decode value = genericDecode opts value + +instance encodeFreightForwarderChoice :: Encode FreightForwarderChoice where + encode value = genericEncode opts value diff --git a/test/Main.purs b/test/Main.purs index 58cf6f3..9909d43 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -3,6 +3,7 @@ module Test.Main where import Prelude import TestUtils (testGenericRoundTrip, testOption, testRoundTrip) import BigIntegerTests as BigIntegerTests +import AesonEncodingTests as AesonEncodingTests import Control.Monad.Except (runExcept) import Data.Bifunctor (bimap) import Data.BigInteger as BigInteger @@ -79,6 +80,7 @@ main = runTest do roundTripTests BigIntegerTests.all + AesonEncodingTests.all roundTripTests :: TestSuite roundTripTests = From cc4519d34b398db6fdcf5ce40d22931a9d2bfff1 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 17 Sep 2020 11:04:46 +0100 Subject: [PATCH 42/42] Simplifying a fromMaybe clause. --- src/Foreign/Generic/Class.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index b54bb6f..6952d22 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -12,7 +12,7 @@ import Data.List (List(..), (:)) import Data.List as List import Data.Map (Map) import Data.Map as Map -import Data.Maybe (Maybe(..), maybe) +import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Newtype (unwrap) import Data.Set (Set) import Data.Set as Set @@ -415,8 +415,8 @@ instance genericEncodeConstructor :: (IsSymbol name, GenericEncodeArgs rep) => GenericEncode (Constructor name rep) where encodeOpts opts (Constructor args) = - if opts.unwrapSingleConstructors - then maybe (unsafeToForeign {}) unsafeToForeign (encodeArgsArray args) + if opts.unwrapSingleConstructors + then fromMaybe (unsafeToForeign {}) (encodeArgsArray args) else case opts.sumEncoding of TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> unsafeToForeign $