option to unwrap records

.gitignore

@@ -3,3 +3,5 @@ bower_components/
 output/
 .psc-package
 .psc-ide-port
+node_modules/
+yarn.lock

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",

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

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,21 +56,26 @@ 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
                    unless (tag == expected) $
                      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
 

src/Foreign/Generic/Types.purs

@@ -15,4 +15,5 @@ data SumEncoding
     { tagFieldName :: String
     , contentsFieldName :: String
     , constructorTagTransform :: String -> String
+    , unwrapRecords :: Boolean
     }

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})

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
                                                }
                  }