WIP: records with RowToList

.travis.yml

@@ -12,4 +12,4 @@ after_success:
 - >-
   test $TRAVIS_TAG &&
   echo $GITHUB_TOKEN | pulp login &&
-  echo y | pulp publish --no-push
+  echo y | pulp publish --no-push

bower.json

@@ -16,13 +16,13 @@
   },
   "license": "MIT",
   "dependencies": {
-    "purescript-generics": "^4.0.0",
-    "purescript-argonaut-core": "^3.1.0",
-    "purescript-argonaut-codecs": "^3.0.0",
-    "purescript-generics-rep": "^5.1.0"
+    "purescript-argonaut-core": "^4.0.1",
+    "purescript-argonaut-codecs": "^4.0.1",
+    "purescript-generics-rep": "^6.0.0",
+    "purescript-record": "^1.0.0"
   },
   "devDependencies": {
-    "purescript-assert": "^3.0.0",
-    "purescript-console": "^3.0.0"
+    "purescript-assert": "^4.0.0",
+    "purescript-console": "^4.1.0"
   }
-}
+}

package.json

@@ -6,9 +6,9 @@
     "test": "pulp test"
   },
   "devDependencies": {
-    "pulp": "^11.0.0",
+    "pulp": "^12.2.0",
     "purescript-psa": "^0.5.0",
-    "purescript": "^0.11.1",
+    "purescript": "^0.12.0",
     "rimraf": "^2.6.1"
   }
-}
+}

src/Data/Argonaut/Decode/Generic/Rep.purs

@@ -1,11 +1,11 @@
 module Data.Argonaut.Decode.Generic.Rep (
   class DecodeRep,
   class DecodeRepArgs,
-  class DecodeRepFields,
+  class DecodeRepRowList,
   class DecodeLiteral,
   decodeRep,
   decodeRepArgs,
-  decodeRepFields,
+  decodeRepRowList,
   genericDecodeJson,
   decodeLiteralSum,
   decodeLiteralSumWithTransform,
@@ -21,10 +21,16 @@ import Data.Array (uncons)
 import Data.Bifunctor (lmap)
 import Data.Either (Either(..))
 import Data.Generic.Rep as Rep
-import Data.Maybe (Maybe, maybe)
-import Data.StrMap as SM
+import Data.Maybe (Maybe(..), maybe)
 import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+import Foreign.Object as FO
 import Partial.Unsafe (unsafeCrashWith)
+import Prim.Row as Row
+import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
+import Prim.TypeError (class Fail, Text)
+import Record.Builder (Builder)
+import Record.Builder as Builder
+import Type.Data.RowList (RLProxy(..))
 
 class DecodeRep r where
   decodeRep :: Json -> Either String r
@@ -40,11 +46,11 @@ instance decodeRepConstructor :: (IsSymbol name, DecodeRepArgs a) => DecodeRep (
     let name = reflectSymbol (SProxy :: SProxy name)
     let decodingErr msg = "When decoding a " <> name <> ": " <> msg
     jObj <- mFail (decodingErr "expected an object") (toObject j)
-    jTag <- mFail (decodingErr "'tag' property is missing") (SM.lookup "tag" jObj)
+    jTag <- mFail (decodingErr "'tag' property is missing") (FO.lookup "tag" jObj)
     tag <- mFail (decodingErr "'tag' property is not a string") (toString jTag)
     when (tag /= name) $
       Left $ decodingErr "'tag' property has an incorrect value"
-    jValues <- mFail (decodingErr "'values' property is missing") (SM.lookup "values" jObj)
+    jValues <- mFail (decodingErr "'values' property is missing") (FO.lookup "values" jObj)
     values <- mFail (decodingErr "'values' property is not an array") (toArray jValues)
     {init, rest} <- lmap decodingErr $ decodeRepArgs values
     when (rest /= []) $
@@ -63,28 +69,52 @@ instance decodeRepArgsProduct :: (DecodeRepArgs a, DecodeRepArgs b) => DecodeRep
     {init: b, rest: js''} <- decodeRepArgs js'
     pure {init: Rep.Product a b, rest: js''}
 
-instance decodeRepArgsArgument :: (DecodeJson a) => DecodeRepArgs (Rep.Argument a) where
+instance decodeRepRecordArgument ::
+  ( RowToList row rl
+  , DecodeRepRowList rl () row
+  ) => DecodeRepArgs (Rep.Argument (Record row)) where
   decodeRepArgs js = do
-    {head, tail} <- mFail "too few values were present" (uncons js)
-    {init: _, rest: tail} <<< Rep.Argument <$> decodeJson head
-
-instance decodeRepArgsRec :: (DecodeRepFields fields) => DecodeRepArgs (Rep.Rec fields) where
+    {head, tail} <- mFail "to few values were present" (uncons js)
+    obj <- mFail "no json object" (toObject head)
+    steps <- decodeRepRowList rlp obj
+    let arg = Rep.Argument $ Builder.build steps {}
+    pure {init: arg, rest: tail}
+    where
+      rlp :: RLProxy rl
+      rlp = RLProxy
+
+else instance decodeRepArgsArgument :: (DecodeJson a) => DecodeRepArgs (Rep.Argument a) where
   decodeRepArgs js = do
     {head, tail} <- mFail "too few values were present" (uncons js)
-    jObj <- mFail "record is not encoded as an object" (toObject head)
-    {init: _, rest: tail} <<< Rep.Rec <$> decodeRepFields jObj
-
-class DecodeRepFields r where
-  decodeRepFields :: SM.StrMap Json -> Either String r
+    {init: _, rest: tail} <<< Rep.Argument <$> decodeJson head
 
-instance decodeRepFieldsProduct :: (DecodeRepFields a, DecodeRepFields b) => DecodeRepFields (Rep.Product a b) where
-  decodeRepFields js = Rep.Product <$> decodeRepFields js <*> decodeRepFields js
 
-instance decodeRepFieldsField :: (IsSymbol field, DecodeJson a) => DecodeRepFields (Rep.Field field a) where
-  decodeRepFields js = do
-    let name = reflectSymbol (SProxy :: SProxy field)
-    value <- mFail ("the field '" <> name <> "' is not present") (SM.lookup name js)
-    Rep.Field <$> decodeJson value
+class DecodeRepRowList (rl :: RowList) (from :: #Type) (to :: #Type) | rl -> from to where
+  decodeRepRowList :: forall g . g rl -> FO.Object Json -> Either String (Builder (Record from) (Record to))
+
+instance decodeRepRowListNil :: DecodeRepRowList Nil () () where
+  decodeRepRowList _ _ = pure identity
+
+instance decodeRepRowListCons :: 
+  ( DecodeJson ty
+  , IsSymbol name
+  , DecodeRepRowList tail from from'
+  , Row.Lacks name from'
+  , Row.Cons name ty from' to
+  ) => DecodeRepRowList (Cons name ty tail) from to where
+  decodeRepRowList _ obj = do
+    value :: ty <- (error $ FO.lookup name obj) >>= decodeJson
+    rest  <- decodeRepRowList tailp obj
+    let
+      first :: Builder (Record from') (Record to)
+      first = Builder.insert namep value
+    pure $ first <<< rest
+    where
+      namep = SProxy :: SProxy name
+      tailp = RLProxy :: RLProxy tail
+      name  = reflectSymbol namep
+      error Nothing  = Left ("error while decoding field " <> name)
+      error (Just a) = Right a
 
 -- | Decode `Json` representation of a value which has a `Generic` type.
 genericDecodeJson :: forall a r. Rep.Generic a r => DecodeRep r => Json -> Either String a
@@ -95,7 +125,7 @@ mFail msg = maybe (Left msg) Right
 
 -- | A function for decoding `Generic` sum types using string literal representations
 decodeLiteralSum :: forall a r. Rep.Generic a r => DecodeLiteral r => Json -> Either String a
-decodeLiteralSum = decodeLiteralSumWithTransform id
+decodeLiteralSum = decodeLiteralSumWithTransform (\a -> a)
 
 -- | A function for decoding `Generic` sum types using string literal representations
 -- | Takes a function for transforming the tag name in encoding
@@ -117,7 +147,9 @@ instance decodeLiteralConstructor :: (IsSymbol name) => DecodeLiteral (Rep.Const
       Left $ decodingErr "string literal " <> tag <> " had an incorrect value."
     pure $ Rep.Constructor (Rep.NoArguments)
 
-type FailMessage = """`decodeLiteralSum` can only be used with sum types, where all of the constructors are nullary. This is because a string literal cannot be encoded into a product type."""
+
+type FailMessage = 
+  Text "`decodeLiteralSum` can only be used with sum types, where all of the constructors are nullary. This is because a string literal cannot be encoded into a product type."
 
 instance decodeLiteralConstructorCannotTakeProduct
   :: Fail FailMessage

src/Data/Argonaut/Encode/Generic/Rep.purs

@@ -2,10 +2,12 @@ module Data.Argonaut.Encode.Generic.Rep (
   class EncodeRep,
   class EncodeRepArgs,
   class EncodeRepFields,
+  class EncodeRepRowList,
   class EncodeLiteral,
   encodeRep,
   encodeRepArgs,
   encodeRepFields,
+  encodeRepRowList,
   genericEncodeJson,
   encodeLiteralSum,
   encodeLiteralSumWithTransform,
@@ -17,9 +19,14 @@ import Prelude
 import Data.Argonaut.Core (Json, fromArray, fromObject, fromString)
 import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
 import Data.Generic.Rep as Rep
-import Data.StrMap as SM
 import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+import Foreign.Object as FO
 import Partial.Unsafe (unsafeCrashWith)
+import Prim.Row as Row
+import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
+import Prim.TypeError (class Fail, Text)
+import Record (get)
+import Type.Data.RowList (RLProxy(..))
 
 class EncodeRep r where
   encodeRep :: r -> Json
@@ -34,9 +41,9 @@ instance encodeRepSum :: (EncodeRep a, EncodeRep b) => EncodeRep (Rep.Sum a b) w
 instance encodeRepConstructor :: (IsSymbol name, EncodeRepArgs a) => EncodeRep (Rep.Constructor name a) where
   encodeRep (Rep.Constructor a) =
     fromObject
-      $ SM.insert "tag" (fromString (reflectSymbol (SProxy :: SProxy name)))
-      $ SM.insert "values" (fromArray (encodeRepArgs a))
-      $ SM.empty
+      $ FO.insert "tag" (fromString (reflectSymbol (SProxy :: SProxy name)))
+      $ FO.insert "values" (fromArray (encodeRepArgs a))
+      $ FO.empty
 
 class EncodeRepArgs r where
   encodeRepArgs :: r -> Array Json
@@ -47,31 +54,44 @@ instance encodeRepArgsNoArguments :: EncodeRepArgs Rep.NoArguments where
 instance encodeRepArgsProduct :: (EncodeRepArgs a, EncodeRepArgs b) => EncodeRepArgs (Rep.Product a b) where
   encodeRepArgs (Rep.Product a b) = encodeRepArgs a <> encodeRepArgs b
 
-instance encodeRepArgsArgument :: (EncodeJson a) => EncodeRepArgs (Rep.Argument a) where
-  encodeRepArgs (Rep.Argument a) = [encodeJson a]
+instance encodeRepRecordArgument :: (RowToList row rl, EncodeRepRowList rl row) => EncodeRepArgs (Rep.Argument (Record row)) where
+  encodeRepArgs (Rep.Argument rec) = [ fromObject (encodeRepRowList rlp rec FO.empty) ]
+    where rlp = RLProxy :: RLProxy rl
 
-instance encodeRepArgsRec :: (EncodeRepFields fields) => EncodeRepArgs (Rep.Rec fields) where
-  encodeRepArgs (Rep.Rec fields) = [fromObject $ encodeRepFields fields]
+else instance encodeRepArgsArgument :: (EncodeJson a) => EncodeRepArgs (Rep.Argument a) where
+  encodeRepArgs (Rep.Argument a) = [encodeJson a]
 
 class EncodeRepFields r where
-  encodeRepFields :: r -> SM.StrMap Json
+  encodeRepFields :: r -> FO.Object Json
 
 instance encodeRepFieldsProduct :: (EncodeRepFields a, EncodeRepFields b) => EncodeRepFields (Rep.Product a b) where
   encodeRepFields (Rep.Product a b) =
-    SM.union (encodeRepFields a) (encodeRepFields b)
+    FO.union (encodeRepFields a) (encodeRepFields b)
+
+
+class EncodeRepRowList (rl :: RowList) (row :: #Type) | rl -> row where
+  encodeRepRowList :: forall g . g rl -> Record row -> (FO.Object Json -> FO.Object Json)
+
+instance encodeRepRowListNil :: EncodeRepRowList Nil row where
+  encodeRepRowList _ _ = \obj -> obj
+
+instance encodeRepRowListCons :: (EncodeJson ty, IsSymbol name, EncodeRepRowList tail row, Row.Cons name ty ignore row) => EncodeRepRowList (Cons name ty tail) row where
+  encodeRepRowList _ rec = \obj -> FO.insert (reflectSymbol namep) (encodeJson value) (cont obj)
+    where
+      namep = SProxy :: SProxy name
+      value = get namep rec
+      tailp = RLProxy :: RLProxy tail
+      cont  = encodeRepRowList tailp rec
+
 
-instance encodeRepFieldsField :: (IsSymbol field, EncodeJson a) => EncodeRepFields (Rep.Field field a) where
-  encodeRepFields (Rep.Field a) =
-    SM.singleton (reflectSymbol (SProxy :: SProxy field))
-                 (encodeJson a)
 
 -- | Encode any `Generic` data structure into `Json`.
 genericEncodeJson :: forall a r. Rep.Generic a r => EncodeRep r => a -> Json
 genericEncodeJson = encodeRep <<< Rep.from
 
 -- | A function for encoding `Generic` sum types using string literal representations
 encodeLiteralSum :: forall a r. Rep.Generic a r => EncodeLiteral r => a -> Json
-encodeLiteralSum = encodeLiteralSumWithTransform id
+encodeLiteralSum = encodeLiteralSumWithTransform (\a -> a)
 
 -- | A function for encoding `Generic` sum types using string literal representations
 -- | Takes a function for transforming the tag name in encoding
@@ -88,7 +108,8 @@ instance encodeLiteralSumInst :: (EncodeLiteral a, EncodeLiteral b) => EncodeLit
 instance encodeLiteralConstructor :: (IsSymbol name) => EncodeLiteral (Rep.Constructor name (Rep.NoArguments)) where
   encodeLiteral tagNameTransform _ = fromString <<< tagNameTransform $ reflectSymbol (SProxy :: SProxy name)
 
-type FailMessage = """`encodeLiteralSum` can only be used with sum types, where all of the constructors are nullary. This is because a string literal cannot be encoded into a product type."""
+type FailMessage = 
+  Text """`encodeLiteralSum` can only be used with sum types, where all of the constructors are nullary. This is because a string literal cannot be encoded into a product type."""
 
 instance encodeLiteralConstructorCannotBeProduct
   :: Fail FailMessage