Merge pull request #2 from rightfold/master

Add generics-rep encoding and decoding

Author: garyb

README.md

@@ -4,7 +4,7 @@
 [![Build status](https://travis-ci.org/purescript-contrib/purescript-argonaut-generic.svg?branch=master)](https://travis-ci.org/purescript-contrib/purescript-argonaut-generic)
 [![Maintainer: slamdata](https://img.shields.io/badge/maintainer-slamdata-lightgrey.svg)](http://github.com/slamdata)
 
-This package provides `gEncodeJson` and `gDecodeJson` functions for any data types that have a `Generic` instance. Currently only [`purescript-generics`](https://github.com/purescript/purescript-generics) is supported (not [`purescript-generics-rep`](https://github.com/purescript/purescript-generics-rep)).
+This package provides `gEncodeJson` and `gDecodeJson` functions for any data types that have a `Generic` instance, and `genericEncodeJson` and `genericDecodeJson` functions for any data types that have a `Rep.Generic` instance.
 
 ## Installation
 

bower.json

@@ -18,7 +18,11 @@
   "dependencies": {
     "purescript-generics": "^4.0.0",
     "purescript-argonaut-core": "^3.1.0",
-    "purescript-argonaut-codecs": "^3.0.0"
+    "purescript-argonaut-codecs": "^3.0.0",
+    "purescript-generics-rep": "^5.1.0"
   },
-  "devDependencies": {}
+  "devDependencies": {
+    "purescript-assert": "^3.0.0",
+    "purescript-console": "^3.0.0"
+  }
 }

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

@@ -0,0 +1,89 @@
+module Data.Argonaut.Decode.Generic.Rep (
+  class DecodeRep,
+  class DecodeRepArgs,
+  class DecodeRepFields,
+  decodeRep,
+  decodeRepArgs,
+  decodeRepFields,
+  genericDecodeJson
+) where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Argonaut.Core (Json, toArray, toObject, toString)
+import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
+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.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+
+class DecodeRep r where
+  decodeRep :: Json -> Either String r
+
+instance decodeRepNoConstructors :: DecodeRep Rep.NoConstructors where
+  decodeRep _ = 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
+
+instance decodeRepConstructor :: (IsSymbol name, DecodeRepArgs a) => DecodeRep (Rep.Constructor name a) where
+  decodeRep 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") (SM.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)
+    values <- mFail (decodingErr "'values' property is not an array") (toArray jValues)
+    {init, rest} <- lmap decodingErr $ decodeRepArgs values
+    when (rest /= []) $
+      Left $ decodingErr "'values' property had too many values"
+    pure $ Rep.Constructor init
+
+class DecodeRepArgs r where
+  decodeRepArgs :: Array Json -> Either String {init :: r, rest :: Array Json}
+
+instance decodeRepArgsNoArguments :: DecodeRepArgs Rep.NoArguments where
+  decodeRepArgs js = Right {init: Rep.NoArguments, rest: js}
+
+instance decodeRepArgsProduct :: (DecodeRepArgs a, DecodeRepArgs b) => DecodeRepArgs (Rep.Product a b) where
+  decodeRepArgs js = do
+    {init: a, rest: js'} <- decodeRepArgs js
+    {init: b, rest: js''} <- decodeRepArgs js'
+    pure {init: Rep.Product a b, rest: js''}
+
+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
+
+instance decodeRepArgsRec :: (DecodeRepFields fields) => DecodeRepArgs (Rep.Rec fields) 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
+
+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
+
+-- | 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
+
+mFail :: forall a. String -> Maybe a -> Either String a
+mFail msg = maybe (Left msg) Right

src/Data/Argonaut/Encode/Generic.purs

@@ -1,5 +1,5 @@
 module Data.Argonaut.Encode.Generic (
-  gEncodeJson, 
+  gEncodeJson,
   gEncodeJson'
 ) where
 

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

@@ -0,0 +1,65 @@
+module Data.Argonaut.Encode.Generic.Rep (
+  class EncodeRep,
+  class EncodeRepArgs,
+  class EncodeRepFields,
+  encodeRep,
+  encodeRepArgs,
+  encodeRepFields,
+  genericEncodeJson
+) where
+
+import Prelude
+
+import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
+import Data.Argonaut.Core (Json, fromArray, fromObject, fromString)
+import Data.Generic.Rep as Rep
+import Data.StrMap as SM
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+
+class EncodeRep r where
+  encodeRep :: r -> Json
+
+instance encodeRepNoConstructors :: EncodeRep Rep.NoConstructors where
+  encodeRep r = encodeRep r
+
+instance encodeRepSum :: (EncodeRep a, EncodeRep b) => EncodeRep (Rep.Sum a b) where
+  encodeRep (Rep.Inl a) = encodeRep a
+  encodeRep (Rep.Inr b) = encodeRep b
+
+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
+
+class EncodeRepArgs r where
+  encodeRepArgs :: r -> Array Json
+
+instance encodeRepArgsNoArguments :: EncodeRepArgs Rep.NoArguments where
+  encodeRepArgs Rep.NoArguments = []
+
+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 encodeRepArgsRec :: (EncodeRepFields fields) => EncodeRepArgs (Rep.Rec fields) where
+  encodeRepArgs (Rep.Rec fields) = [fromObject $ encodeRepFields fields]
+
+class EncodeRepFields r where
+  encodeRepFields :: r -> SM.StrMap Json
+
+instance encodeRepFieldsProduct :: (EncodeRepFields a, EncodeRepFields b) => EncodeRepFields (Rep.Product a b) where
+  encodeRepFields (Rep.Product a b) =
+    SM.union (encodeRepFields a) (encodeRepFields b)
+
+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

test/Main.purs

@@ -0,0 +1,47 @@
+module Test.Main
+  ( main
+  ) where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Data.Argonaut.Core (stringify)
+import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
+import Data.Argonaut.Decode.Generic.Rep (genericDecodeJson)
+import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
+import Data.Argonaut.Encode.Generic.Rep (genericEncodeJson)
+import Data.Either (Either(..))
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Show (genericShow)
+import Test.Assert (ASSERT, assert)
+
+data Example
+  = Either (Either String Example)
+  | Record {foo :: Int, bar :: String}
+  | Product Int Int Example
+
+derive instance eqExample :: Eq Example
+derive instance genericExample :: Generic Example _
+instance showExample :: Show Example where
+  show a = genericShow a
+instance encodeJsonExample :: EncodeJson Example where
+  encodeJson a = genericEncodeJson a
+instance decodeJson :: DecodeJson Example where
+  decodeJson a = genericDecodeJson a
+
+main :: forall eff. Eff (assert :: ASSERT, console :: CONSOLE | eff) 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"
+  where
+  example original = do
+    let json = encodeJson original
+    let parsed = decodeJson json
+    log $ "Original:  " <> show original
+    log $ "To JSON:   " <> stringify json
+    log $ "From JSON: " <> show parsed
+    assert $ parsed == Right original
+    log $ "--------------------------------------------------------------------------------"