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..eed8cda 100644 --- a/package.json +++ b/package.json @@ -3,9 +3,11 @@ "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": { + "bower": "^1.8.4", "pulp": "^12.0.0", "purescript": "^0.12.0", "purescript-psa": "^0.5.0", diff --git a/src/Foreign/Generic.purs b/src/Foreign/Generic.purs index 0836fbd..5233219 100644 --- a/src/Foreign/Generic.purs +++ b/src/Foreign/Generic.purs @@ -1,5 +1,6 @@ module Foreign.Generic ( defaultOptions + , aesonSumEncoding , genericDecode , genericEncode , decodeJSON @@ -32,11 +33,21 @@ 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 + } -- | Read a value which has a `Generic` type. genericDecode diff --git a/src/Foreign/Generic/Class.purs b/src/Foreign/Generic/Class.purs index 1ec0a7d..1d78951 100644 --- a/src/Foreign/Generic/Class.purs +++ b/src/Foreign/Generic/Class.purs @@ -10,10 +10,10 @@ import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), NoConst import Data.List (List(..), fromFoldable, null, singleton, toUnfoldable, (:)) import Data.Maybe (Maybe(..), maybe) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) -import Foreign (F, Foreign, ForeignError(..), fail, readArray, readString, unsafeToForeign) +import Foreign (F, Foreign, ForeignError(..), fail, isArray, readArray, readString, typeOf, unsafeFromForeign, unsafeToForeign) import Foreign.Class (class Encode, class Decode, encode, decode) import Foreign.Generic.Types (Options, SumEncoding(..)) -import Foreign.Index (index) +import Foreign.Index (hasProperty, index) import Foreign.Object (Object) import Foreign.Object as Object import Prim.Row (class Cons, class Lacks) @@ -56,7 +56,7 @@ instance genericDecodeConstructor if opts.unwrapSingleConstructors then Constructor <$> readArguments f else case opts.sumEncoding of - TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> do + TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform, unwrapRecords } -> do tag <- mapExcept (lmap (map (ErrorAtProperty tagFieldName))) do tag <- index f tagFieldName >>= readString let expected = constructorTagTransform ctorName @@ -64,13 +64,18 @@ instance genericDecodeConstructor fail (ForeignError ("Expected " <> show expected <> " tag")) pure tag args <- mapExcept (lmap (map (ErrorAtProperty contentsFieldName))) - (index f contentsFieldName >>= readArguments) + ((contents unwrapRecords contentsFieldName f) >>= readArguments) pure (Constructor args) where ctorName = reflectSymbol (SProxy :: SProxy name) numArgs = countArgs (Proxy :: Proxy rep) + contents :: Boolean -> String -> Foreign -> F Foreign + contents unwrapRecords contentsFieldName f' + | unwrapRecords && not (hasProperty contentsFieldName f') = pure f' + | otherwise = index f' contentsFieldName + readArguments args = case numArgs of Left a -> pure a @@ -95,10 +100,16 @@ instance genericEncodeConstructor else case opts.sumEncoding of TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> unsafeToForeign (Object.singleton tagFieldName (unsafeToForeign $ constructorTagTransform ctorName) - `Object.union` maybe Object.empty (Object.singleton contentsFieldName) (encodeArgsArray args)) + `Object.union` objectFromArgs opts.sumEncoding (encodeArgsArray args)) where ctorName = reflectSymbol (SProxy :: SProxy name) + objectFromArgs :: SumEncoding -> Maybe Foreign -> Object Foreign + objectFromArgs _ Nothing = Object.empty + objectFromArgs (TaggedObject { contentsFieldName, unwrapRecords }) (Just f) + | typeOf f == "object" && not isArray f && unwrapRecords = unsafeFromForeign f + | otherwise = Object.singleton contentsFieldName f + encodeArgsArray :: rep -> Maybe Foreign encodeArgsArray = unwrapArguments <<< toUnfoldable <<< encodeArgs opts diff --git a/src/Foreign/Generic/Types.purs b/src/Foreign/Generic/Types.purs index 3a6b023..6a562e5 100644 --- a/src/Foreign/Generic/Types.purs +++ b/src/Foreign/Generic/Types.purs @@ -15,4 +15,5 @@ data SumEncoding { tagFieldName :: String , contentsFieldName :: String , constructorTagTransform :: String -> String + , unwrapRecords :: Boolean } diff --git a/test/Main.purs b/test/Main.purs index 306cc2b..3df7858 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -22,7 +22,7 @@ import Foreign.JSON (parseJSON) import Foreign.Object as Object import Global.Unsafe (unsafeStringify) import Test.Assert (assert, assert') -import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..)) +import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..), SumWithRecord(..)) buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a buildTree _ 0 a = Leaf a @@ -128,6 +128,10 @@ testNothingFromMissing = main :: Effect Unit main = do testRoundTrip (RecordTest { foo: 1, bar: "test", baz: 'a' }) + testRoundTrip NoArgs + testRoundTrip (SomeArg "some argument") + testRoundTrip (ManyArgs "fst" "snd") + testRoundTrip (RecordArgs { foo: 1, bar: "test", baz: 'a' }) testRoundTrip (Cons 1 (Cons 2 (Cons 3 Nil))) testRoundTrip (UndefinedTest {a: Just "test"}) testRoundTrip (UndefinedTest {a: Nothing}) diff --git a/test/Types.purs b/test/Types.purs index c97e690..10eb3a5 100644 --- a/test/Types.purs +++ b/test/Types.purs @@ -57,6 +57,38 @@ instance decodeRecordTest :: Decode RecordTest where instance encodeRecordTest :: Encode RecordTest where encode x = genericEncode (defaultOptions { unwrapSingleConstructors = true }) x +-- | A sum type with record args +data SumWithRecord + = NoArgs + | SomeArg String + | ManyArgs String String + | RecordArgs + { foo :: Int + , bar :: String + , baz :: Char + } + +derive instance genericSumWithRecord :: Generic SumWithRecord _ + +instance showSumWithRecord :: Show SumWithRecord where + show x = genericShow x + +instance eqSumWithRecord :: Eq SumWithRecord where + eq x y = genericEq x y + +unwrapRecordsEncoding :: SumEncoding +unwrapRecordsEncoding = TaggedObject { tagFieldName: "tag" + , contentsFieldName: "contents" + , constructorTagTransform: identity + , unwrapRecords: true + } + +instance decodeSumWithRecord :: Decode SumWithRecord where + decode x = genericDecode (defaultOptions { unwrapSingleConstructors = true, sumEncoding = unwrapRecordsEncoding }) x + +instance encodeSumWithRecord :: Encode SumWithRecord where + encode x = genericEncode (defaultOptions { unwrapSingleConstructors = true, sumEncoding = unwrapRecordsEncoding }) x + -- | An example of an ADT with nullary constructors data IntList = Nil | Cons Int IntList @@ -76,6 +108,7 @@ intListOptions = , constructorTagTransform: \tag -> case tag of "Cons" -> "cOnS" _ -> "" + , unwrapRecords: false } }