Merge pull request #8 from CarstenKoenig/GenRepRowToList

updated to PureScript 0.12

Author: thomashoneyman

.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.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,68 @@ 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
+-- | a `DecodeRepRowList` represents a relation between a `RowList` and a record you
+-- | can build from it by deserializing it's fields from a JSON `Object`
+-- |
+-- | this one is strictly internal to help out `decodeRepRecordArgument` handling records 
+-- |
+-- | a `RowList` on the type level is very similar to a *cons-list* on the value level
+-- | so the two instances handle all possible `RowList`s
+-- |
+-- | the idea is to use `Builder` to convert a `RowList` into a record at the type-level
+-- | and have `decodeRepRowList` as witness on the value level that will try to decode
+-- | JSON in to the resulting record value
+-- | 
+-- | `from` and `to` are two helper types - using these `decodeRepRowListCons` can 
+-- | recursively create `Builder`-steps and make sure that every *symbol* in `rl` 
+-- | can only occur once (the fields in the records must be unique)
+-- | (see `Row.Lacks`)
+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 +141,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 identity
 
 -- | A function for decoding `Generic` sum types using string literal representations
 -- | Takes a function for transforming the tag name in encoding
@@ -117,7 +163,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