From 302aebe93234048b71a7e00bd7095e87b571b017 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Tue, 25 Aug 2015 00:52:37 +0300 Subject: [PATCH] Generic deriving --- bower.json | 6 ++- docs/Data/Argonaut/Decode.md | 16 ++++++++ docs/Data/Argonaut/Encode.md | 16 ++++++++ src/Data/Argonaut/Decode.purs | 48 +++++++++++++++++++++++- src/Data/Argonaut/Encode.purs | 28 ++++++++++++-- test/Test/Main.purs | 70 +++++++++++++++++++++++++++++++---- 6 files changed, 169 insertions(+), 15 deletions(-) diff --git a/bower.json b/bower.json index 7276843..60676a7 100644 --- a/bower.json +++ b/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" } } diff --git a/docs/Data/Argonaut/Decode.md b/docs/Data/Argonaut/Decode.md index de47fd8..3cb3735 100644 --- a/docs/Data/Argonaut/Decode.md +++ b/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 diff --git a/docs/Data/Argonaut/Encode.md b/docs/Data/Argonaut/Encode.md index 21a6ff2..6e16667 100644 --- a/docs/Data/Argonaut/Encode.md +++ b/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`. + diff --git a/src/Data/Argonaut/Decode.purs b/src/Data/Argonaut/Decode.purs index 62e0de4..20f3a6d 100644 --- a/src/Data/Argonaut/Decode.purs +++ b/src/Data/Argonaut/Decode.purs @@ -1,6 +1,8 @@ module Data.Argonaut.Decode ( DecodeJson , decodeJson + , gDecodeJson + , gDecodeJson' , decodeMaybe ) where @@ -20,16 +22,20 @@ 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 @@ -37,6 +43,44 @@ 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 diff --git a/src/Data/Argonaut/Encode.purs b/src/Data/Argonaut/Encode.purs index f11366f..1f1dd22 100644 --- a/src/Data/Argonaut/Encode.purs +++ b/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,11 +24,12 @@ 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 @@ -34,6 +37,25 @@ 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 diff --git a/test/Test/Main.purs b/test/Test/Main.purs index f4b3ce3..cd2afba 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,14 +2,15 @@ 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 @@ -17,7 +18,7 @@ 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