Merge pull request #3 from zudov/generics

Generic deriving

Author: jdegoes

bower.json

@@ -23,9 +23,11 @@
   "license": "MIT",
   "dependencies": {
     "purescript-argonaut-core": "^0.2.0",
-    "purescript-integers": "^0.2.1"
+    "purescript-integers": "^0.2.1",
+    "purescript-generics": "^0.5.1"
   },
   "devDependencies": {
-    "purescript-strongcheck": "^0.12.1"
+    "purescript-strongcheck": "^0.12.1",
+    "purescript-strongcheck-generics": "^0.1.0"
   }
 }

docs/Data/Argonaut/Decode.md

@@ -25,6 +25,22 @@ instance decodeList :: (DecodeJson a) => DecodeJson (List a)
 instance decodeMap :: (Ord a, DecodeJson a, DecodeJson b) => DecodeJson (Map a b)
 ```
 
+#### `gDecodeJson`
+
+``` purescript
+gDecodeJson :: forall a. (Generic a) => Json -> Either String a
+```
+
+Decode `Json` representation of a value which has a `Generic` type.
+
+#### `gDecodeJson'`
+
+``` purescript
+gDecodeJson' :: GenericSignature -> Json -> Either String GenericSpine
+```
+
+Decode `Json` representation of a `GenericSpine`.
+
 #### `decodeMaybe`
 
 ``` purescript

docs/Data/Argonaut/Encode.md

@@ -25,4 +25,20 @@ instance encodeStrMap :: (EncodeJson a) => EncodeJson (StrMap a)
 instance encodeMap :: (Ord a, EncodeJson a, EncodeJson b) => EncodeJson (Map a b)
 ```
 
+#### `gEncodeJson`
+
+``` purescript
+gEncodeJson :: forall a. (Generic a) => a -> Json
+```
+
+Encode any `Generic` data structure into `Json`.
+
+#### `gEncodeJson'`
+
+``` purescript
+gEncodeJson' :: GenericSpine -> Json
+```
+
+Encode `GenericSpine` into `Json`.
+
 

src/Data/Argonaut/Decode.purs

@@ -1,6 +1,8 @@
 module Data.Argonaut.Decode
   ( DecodeJson
   , decodeJson
+  , gDecodeJson
+  , gDecodeJson'
   , decodeMaybe
   ) where
 
@@ -20,23 +22,65 @@ import Data.Argonaut.Core
   , toNumber
   , toObject
   , toString
+  , toBoolean
   )
+import Data.Array (zipWithA)
 import Data.Either (either, Either(..))
 import Data.Int (fromNumber)
 import Data.Maybe (maybe, Maybe(..))
-import Data.Traversable (traverse)
 import Data.Tuple (Tuple(..))
 import Data.String
 import Data.List (List(..), toList)
 import Control.Alt
-import Data.Traversable (traverse)
+import Control.Bind ((=<<))
+import Data.Traversable (traverse, for)
+import Data.Foldable (find)
+import Data.Generic
 
 import qualified Data.StrMap as M
 import qualified Data.Map as Map
 
 class DecodeJson a where
   decodeJson :: Json -> Either String a
 
+-- | Decode `Json` representation of a value which has a `Generic` type.
+gDecodeJson :: forall a. (Generic a) => Json -> Either String a
+gDecodeJson json = maybe (Left "fromSpine failed") Right <<< fromSpine
+                 =<< gDecodeJson' (toSignature (Proxy :: Proxy a)) json
+
+-- | Decode `Json` representation of a `GenericSpine`.
+gDecodeJson' :: GenericSignature -> Json -> Either String GenericSpine
+gDecodeJson' signature json = case signature of
+  SigNumber
+    -> SNumber <$> mFail "Expected a number" (toNumber json)
+  SigInt
+    -> SInt <$> mFail "Expected an integer number" (fromNumber =<< toNumber json)
+  SigString
+    -> SString <$> mFail "Expected a string" (toString json)
+  SigBoolean
+    -> SBoolean <$> mFail "Expected a boolean" (toBoolean json)
+  SigArray thunk
+    -> do jArr <- mFail "Expected an array" $ toArray json
+          SArray <$> traverse (map const <<< gDecodeJson' (thunk unit)) jArr
+  SigRecord props
+    -> do jObj <- mFail "Expected an object" $ toObject json
+          SRecord <$> for props \({recLabel: lbl, recValue: val})
+            -> do pf <- mFail ("'" <> lbl <> "' property missing") (M.lookup lbl jObj)
+                  sp <- gDecodeJson' (val unit) pf
+                  pure { recLabel: lbl, recValue: const sp }
+  SigProd alts
+    -> do jObj <- mFail "Expected an object" $ toObject json
+          tag  <- mFail "'tag' string property is missing" (toString =<< M.lookup "tag" jObj)
+          case find ((tag ==) <<< _.sigConstructor) alts of
+            Nothing -> Left ("'" <> tag <> "' isn't a valid constructor")
+            Just { sigValues: sigValues } -> do
+              vals <- mFail "'values' array is missing" (toArray =<< M.lookup "values" jObj)
+              sps  <- zipWithA (\k -> gDecodeJson' (k unit)) sigValues vals
+              pure (SProd tag (const <$> sps))
+  where
+    mFail :: forall a. String -> Maybe a -> Either String a
+    mFail msg = maybe (Left msg) Right
+
 instance decodeJsonMaybe :: (DecodeJson a) => DecodeJson (Maybe a) where
   decodeJson j = (Just <$> decodeJson j) <|> pure Nothing
 

src/Data/Argonaut/Encode.purs

@@ -1,12 +1,14 @@
 module Data.Argonaut.Encode
        ( EncodeJson
        , encodeJson
+       , gEncodeJson
+       , gEncodeJson'
        ) where
 
 import Prelude
 
 import Data.Argonaut.Core
-  ( Json(..)
+  ( Json()
   , foldJsonObject
   , jsonNull
   , fromNull
@@ -22,18 +24,38 @@ import Data.Argonaut.Core
 import Data.String (fromChar)
 import Data.Maybe
 import Data.Either
-import Data.List (List(..), fromList)
+import Data.List (List(..), fromList, toList)
 import Data.Int (toNumber)
 import Data.Unfoldable ()
-import Data.Foldable (foldr)
+import Data.Foldable (foldMap, foldr)
 import Data.Tuple (Tuple(..))
+import Data.Generic
 
 import qualified Data.StrMap as SM
 import qualified Data.Map as M
 
 class EncodeJson a where
   encodeJson :: a -> Json
 
+-- | Encode any `Generic` data structure into `Json`.
+gEncodeJson :: forall a. (Generic a) => a -> Json
+gEncodeJson = gEncodeJson' <<< toSpine
+
+-- | Encode `GenericSpine` into `Json`.
+gEncodeJson' :: GenericSpine -> Json
+gEncodeJson' spine = case spine of
+  SInt x            -> fromNumber $ toNumber x
+  SString x         -> fromString x
+  SNumber x         -> fromNumber x
+  SBoolean x        -> fromBoolean x
+  SArray thunks     -> fromArray (gEncodeJson' <<< (unit #) <$> thunks)
+  SProd constr args -> fromObject
+                         $ SM.insert    "tag"    (encodeJson constr)
+                         $ SM.singleton "values" (encodeJson (gEncodeJson' <<< (unit #) <$> args))
+  SRecord fields    -> fromObject $ foldr addField SM.empty fields
+    where addField field = SM.insert field.recLabel
+                                     (gEncodeJson' $ field.recValue unit)
+
 instance encodeJsonMaybe :: (EncodeJson a) => EncodeJson (Maybe a) where
   encodeJson Nothing  = jsonNull
   encodeJson (Just a) = encodeJson a

test/Test/Main.purs

@@ -2,22 +2,23 @@ module Test.Main where
 
 import Prelude
 
-import Data.Argonaut.Core 
-import Data.Argonaut.Decode (decodeJson, DecodeJson)
-import Data.Argonaut.Encode (encodeJson, EncodeJson)
+import Data.Argonaut.Core
+import Data.Argonaut.Decode (decodeJson, DecodeJson, gDecodeJson, gDecodeJson')
+import Data.Argonaut.Encode (encodeJson, EncodeJson, gEncodeJson, gEncodeJson')
 import Data.Argonaut.Combinators ((:=), (~>), (?>>=), (.?))
 import Data.Either
 import Data.Tuple
 import Data.Maybe
 import Data.Array
+import Data.Generic
 import Data.Foldable (foldl)
 import Data.List (toList, List(..))
 import Control.Monad.Eff.Console
 import qualified Data.StrMap as M
 
 import Test.StrongCheck
 import Test.StrongCheck.Gen
-
+import Test.StrongCheck.Generic
 
 genJNull :: Gen Json
 genJNull = pure jsonNull
@@ -67,7 +68,7 @@ prop_decode_then_encode (TestJson json) =
   Right json == (decoded >>= (encodeJson >>> pure))
 
 
-encodeDecodeCheck = do 
+encodeDecodeCheck = do
   log "Showing small sample of JSON"
   showSample (genJson 10)
 
@@ -81,7 +82,7 @@ prop_assoc_builder_str :: Tuple String String -> Boolean
 prop_assoc_builder_str (Tuple key str) =
   case (key := str) of
     Tuple k json ->
-      (key == k) && (decodeJson json == Right str) 
+      (key == k) && (decodeJson json == Right str)
 
 newtype Obj = Obj Json
 unObj :: Obj -> Json
@@ -110,7 +111,7 @@ prop_get_jobject_field (Obj obj) =
     in foldl (\ok key -> ok && (isJust $ M.lookup key obj)) true keys
 
 assert_maybe_msg :: Boolean
-assert_maybe_msg = 
+assert_maybe_msg =
   (isLeft (Nothing ?>>= "Nothing is Left"))
   &&
   ((Just 2 ?>>= "Nothing is left") == Right 2)
@@ -127,9 +128,62 @@ combinatorsCheck = do
   quickCheck' 20 prop_get_jobject_field
   log "Assert maybe to either convertion"
   assert assert_maybe_msg
-  
+
+newtype MyRecord = MyRecord { foo :: String, bar :: Int}
+derive instance genericMyRecord :: Generic MyRecord
+
+data User = Anonymous
+          | Guest String
+          | Registered { name :: String
+                       , age :: Int
+                       , balance :: Number
+                       , banned :: Boolean
+                       , tweets :: Array String
+                       , followers :: Array User
+                       }
+derive instance genericUser :: Generic User
+
+prop_iso_generic :: GenericValue -> Boolean
+prop_iso_generic genericValue =
+  Right val.spine == gDecodeJson' val.signature (gEncodeJson' val.spine)
+  where val = runGenericValue genericValue
+
+prop_decoded_spine_valid :: GenericValue -> Boolean
+prop_decoded_spine_valid genericValue =
+  Right true == (isValidSpine val.signature <$> gDecodeJson' val.signature (gEncodeJson' val.spine))
+  where val = runGenericValue genericValue
+
+genericsCheck = do
+  log "Check that decodeJson' and encodeJson' form an isomorphism"
+  quickCheck prop_iso_generic
+  log "Check that decodeJson' returns a valid spine"
+  quickCheck prop_decoded_spine_valid
+  log "Print samples of values encoded with gEncodeJson"
+  print $ gEncodeJson 5
+  print $ gEncodeJson [1, 2, 3, 5]
+  print $ gEncodeJson (Just "foo")
+  print $ gEncodeJson (Right "foo" :: Either String String)
+  print $ gEncodeJson $ MyRecord { foo: "foo", bar: 2}
+  print $ gEncodeJson "foo"
+  print $ gEncodeJson Anonymous
+  print $ gEncodeJson $ Guest "guest's handle"
+  print $ gEncodeJson $ Registered { name: "user1"
+                                   , age: 5
+                                   , balance: 26.6
+                                   , banned: false
+                                   , tweets: ["Hello", "What's up"]
+                                   , followers: [ Anonymous
+                                                , Guest "someGuest"
+                                                , Registered { name: "user2"
+                                                             , age: 6
+                                                             , balance: 32.1
+                                                             , banned: false
+                                                             , tweets: ["Hi"]
+                                                             , followers: []
+                                                             }]}
 
 
 main = do
   encodeDecodeCheck
   combinatorsCheck
+  genericsCheck