Merge pull request #12 from LiamGoodacre/feature/config

Support configuring which keys are used for tag & values

Author: thomashoneyman

bower.json

@@ -17,12 +17,12 @@
   "license": "MIT",
   "dependencies": {
     "purescript-argonaut-core": "^4.0.1",
-    "purescript-argonaut-codecs": "^4.0.1",
+    "purescript-argonaut-codecs": "^5.0.0",
     "purescript-generics-rep": "^6.0.0",
     "purescript-record": "^1.0.0"
   },
   "devDependencies": {
     "purescript-assert": "^4.0.0",
     "purescript-console": "^4.1.0"
   }
-}
+}

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

@@ -1,18 +1,18 @@
 module Data.Argonaut.Decode.Generic.Rep (
   class DecodeRep,
   class DecodeRepArgs,
-  class DecodeRepRowList,
   class DecodeLiteral,
-  decodeRep,
+  decodeRepWith,
   decodeRepArgs,
-  decodeRepRowList,
   genericDecodeJson,
+  genericDecodeJsonWith,
   decodeLiteralSum,
   decodeLiteralSumWithTransform,
   decodeLiteral
 ) where
 
 import Prelude
+import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
 
 import Control.Alt ((<|>))
 import Data.Argonaut.Core (Json, toArray, toObject, toString)
@@ -21,40 +21,35 @@ 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.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
+  decodeRepWith :: Encoding -> Json -> Either String r
 
 instance decodeRepNoConstructors :: DecodeRep Rep.NoConstructors where
-  decodeRep _ = Left "Cannot decode empty data type"
+  decodeRepWith e _ = Left "Cannot decode empty data type"
 
 instance decodeRepSum :: (DecodeRep a, DecodeRep b) => DecodeRep (Rep.Sum a b) where
-  decodeRep j = Rep.Inl <$> decodeRep j <|> Rep.Inr <$> decodeRep j
+  decodeRepWith e j = Rep.Inl <$> decodeRepWith e j <|> Rep.Inr <$> decodeRepWith e j
 
 instance decodeRepConstructor :: (IsSymbol name, DecodeRepArgs a) => DecodeRep (Rep.Constructor name a) where
-  decodeRep j = do
+  decodeRepWith e j = do
     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") (FO.lookup "tag" jObj)
-    tag <- mFail (decodingErr "'tag' property is not a string") (toString jTag)
+    jTag <- mFail (decodingErr $ "'" <> e.tagKey <> "' property is missing") (FO.lookup e.tagKey jObj)
+    tag <- mFail (decodingErr $ "'" <> e.tagKey <> "' 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") (FO.lookup "values" jObj)
-    values <- mFail (decodingErr "'values' property is not an array") (toArray jValues)
+      Left $ decodingErr $ "'" <> e.tagKey <> "' property has an incorrect value"
+    jValues <- mFail (decodingErr $ "'" <> e.valuesKey <> "' property is missing") (FO.lookup e.valuesKey jObj)
+    values <- mFail (decodingErr $ "'" <> e.valuesKey <> "' property is not an array") (toArray jValues)
     {init, rest} <- lmap decodingErr $ decodeRepArgs values
     when (rest /= []) $
-      Left $ decodingErr "'values' property had too many values"
+      Left $ decodingErr $ "'" <> e.valuesKey <> "' property had too many values"
     pure $ Rep.Constructor init
 
 class DecodeRepArgs r where
@@ -69,72 +64,18 @@ instance decodeRepArgsProduct :: (DecodeRepArgs a, DecodeRepArgs b) => DecodeRep
     {init: b, rest: js''} <- decodeRepArgs js'
     pure {init: Rep.Product a b, rest: js''}
 
-instance decodeRepRecordArgument ::
-  ( RowToList row rl
-  , DecodeRepRowList rl () row
-  ) => DecodeRepArgs (Rep.Argument (Record row)) where
-  decodeRepArgs js = do
-    {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
+instance decodeRepArgsArgument :: (DecodeJson a) => DecodeRepArgs (Rep.Argument a) where
   decodeRepArgs js = do
     {head, tail} <- mFail "too few values were present" (uncons js)
     {init: _, rest: tail} <<< Rep.Argument <$> decodeJson head
 
-
--- | 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
-genericDecodeJson = map Rep.to <<< decodeRep
+genericDecodeJson = genericDecodeJsonWith defaultEncoding
+
+-- | Decode `Json` representation of a value which has a `Generic` type.
+genericDecodeJsonWith :: forall a r. Rep.Generic a r => DecodeRep r => Encoding -> Json -> Either String a
+genericDecodeJsonWith e = map Rep.to <<< decodeRepWith e
 
 mFail :: forall a. String -> Maybe a -> Either String a
 mFail msg = maybe (Left msg) Right
@@ -164,7 +105,7 @@ instance decodeLiteralConstructor :: (IsSymbol name) => DecodeLiteral (Rep.Const
     pure $ Rep.Constructor (Rep.NoArguments)
 
 
-type FailMessage = 
+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

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

@@ -2,47 +2,43 @@ module Data.Argonaut.Encode.Generic.Rep (
   class EncodeRep,
   class EncodeRepArgs,
   class EncodeRepFields,
-  class EncodeRepRowList,
   class EncodeLiteral,
-  encodeRep,
+  encodeRepWith,
   encodeRepArgs,
   encodeRepFields,
-  encodeRepRowList,
   genericEncodeJson,
+  genericEncodeJsonWith,
   encodeLiteralSum,
   encodeLiteralSumWithTransform,
   encodeLiteral
 ) where
 
 import Prelude
+import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
 
 import Data.Argonaut.Core (Json, fromArray, fromObject, fromString)
 import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
 import Data.Generic.Rep as Rep
 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
+  encodeRepWith :: Encoding -> r -> Json
 
 instance encodeRepNoConstructors :: EncodeRep Rep.NoConstructors where
-  encodeRep r = encodeRep r
+  encodeRepWith e = encodeRepWith e
 
 instance encodeRepSum :: (EncodeRep a, EncodeRep b) => EncodeRep (Rep.Sum a b) where
-  encodeRep (Rep.Inl a) = encodeRep a
-  encodeRep (Rep.Inr b) = encodeRep b
+  encodeRepWith e (Rep.Inl a) = encodeRepWith e a
+  encodeRepWith e (Rep.Inr b) = encodeRepWith e b
 
 instance encodeRepConstructor :: (IsSymbol name, EncodeRepArgs a) => EncodeRep (Rep.Constructor name a) where
-  encodeRep (Rep.Constructor a) =
+  encodeRepWith e (Rep.Constructor a) =
     fromObject
-      $ FO.insert "tag" (fromString (reflectSymbol (SProxy :: SProxy name)))
-      $ FO.insert "values" (fromArray (encodeRepArgs a))
+      $ FO.insert e.tagKey (fromString (reflectSymbol (SProxy :: SProxy name)))
+      $ FO.insert e.valuesKey (fromArray (encodeRepArgs a))
       $ FO.empty
 
 class EncodeRepArgs r where
@@ -54,11 +50,7 @@ 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 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
-
-else instance encodeRepArgsArgument :: (EncodeJson a) => EncodeRepArgs (Rep.Argument a) where
+instance encodeRepArgsArgument :: (EncodeJson a) => EncodeRepArgs (Rep.Argument a) where
   encodeRepArgs (Rep.Argument a) = [encodeJson a]
 
 class EncodeRepFields r where
@@ -69,38 +61,13 @@ instance encodeRepFieldsProduct :: (EncodeRepFields a, EncodeRepFields b) => Enc
     FO.union (encodeRepFields a) (encodeRepFields b)
 
 
--- | a `EncodeRepRowList` represents a relation between a `RowList` and a record you
--- | can serialize into a Json `Object`
--- |
--- | this one is strictly internal to help out `encodeRepRecordArgument` 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 use the `Cons` cases to to compose functions that adds the field
--- | and values from the given record into a Json-`Object`
--- | the field in question is indicated by the head of the `RowList`
--- |
--- | the `Nil` case just returns `identity` to bootstrap the composition-chain
-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 _ _ = identity
-
-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
-
-
-
 -- | Encode any `Generic` data structure into `Json`.
 genericEncodeJson :: forall a r. Rep.Generic a r => EncodeRep r => a -> Json
-genericEncodeJson = encodeRep <<< Rep.from
+genericEncodeJson = genericEncodeJsonWith defaultEncoding
+
+-- | Encode any `Generic` data structure into `Json`.
+genericEncodeJsonWith :: forall a r. Rep.Generic a r => EncodeRep r => Encoding -> a -> Json
+genericEncodeJsonWith e = encodeRepWith e <<< 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

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

@@ -0,0 +1,16 @@
+module Data.Argonaut.Types.Generic.Rep (
+  Encoding(..),
+  defaultEncoding
+) where
+
+type Encoding =
+  { tagKey :: String
+  , valuesKey :: String
+  }
+
+defaultEncoding :: Encoding
+defaultEncoding =
+  { tagKey: "tag"
+  , valuesKey: "values"
+  }
+

test/Main.purs

@@ -8,9 +8,10 @@ import Effect (Effect)
 import Effect.Console (log)
 import Data.Argonaut.Core (stringify)
 import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
-import Data.Argonaut.Decode.Generic.Rep (class DecodeLiteral, decodeLiteralSumWithTransform, genericDecodeJson)
+import Data.Argonaut.Decode.Generic.Rep (class DecodeLiteral, decodeLiteralSumWithTransform, genericDecodeJson, genericDecodeJsonWith)
 import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
-import Data.Argonaut.Encode.Generic.Rep (class EncodeLiteral, encodeLiteralSumWithTransform, genericEncodeJson)
+import Data.Argonaut.Encode.Generic.Rep (class EncodeLiteral, encodeLiteralSumWithTransform, genericEncodeJson, genericEncodeJsonWith)
+import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
 import Data.Argonaut.Parser (jsonParser)
 import Data.Either (Either(..), fromRight)
 import Data.Generic.Rep (class Generic)
@@ -47,13 +48,31 @@ instance encodeJsonLiteralStringExample :: EncodeJson LiteralStringExample where
 instance decodeJsonLiteralStringExample :: DecodeJson LiteralStringExample where
   decodeJson a = decodeLiteralSumWithTransform identity a
 
+diffEncodingOptions :: Encoding
+diffEncodingOptions = defaultEncoding
+  { tagKey = "type"
+  , valuesKey = "value"
+  }
+
+data DiffEncoding = A | B Int
+derive instance eqDiffEncoding :: Eq DiffEncoding
+derive instance genericDiffEncoding :: Generic DiffEncoding _
+instance showDiffENcoding :: Show DiffEncoding where
+  show a = genericShow a
+instance encodeJsonDiffEncoding :: EncodeJson DiffEncoding where
+  encodeJson a = genericEncodeJsonWith diffEncodingOptions a
+instance decodeJsonDiffEncoding :: DecodeJson DiffEncoding where
+  decodeJson a = genericDecodeJsonWith diffEncodingOptions a
+
 main :: Effect Unit
 main = do
   example $ Either $ Left "foo"
   example $ Either $ Right $ Either $ Left "foo"
   example $ Record {foo: 42, bar: "bar"}
   example $ Product 1 2 $ Either $ Left "foo"
   example $ Frikandel
+  example $ A
+  example $ B 42
   testLiteralSumWithTransform identity Frikandel "\"Frikandel\""
   testLiteralSumWithTransform toUpper Frikandel "\"FRIKANDEL\""
   testLiteralSumWithTransform toLower Frikandel "\"frikandel\""