diff --git a/README.md b/README.md index 9744dad..3d6fbfd 100644 --- a/README.md +++ b/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 diff --git a/bower.json b/bower.json index b3d85e5..21ac983 100644 --- a/bower.json +++ b/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" + } } diff --git a/src/Data/Argonaut/Decode/Generic/Rep.purs b/src/Data/Argonaut/Decode/Generic/Rep.purs new file mode 100644 index 0000000..1263916 --- /dev/null +++ b/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 diff --git a/src/Data/Argonaut/Encode/Generic.purs b/src/Data/Argonaut/Encode/Generic.purs index 8744eba..6a6db07 100644 --- a/src/Data/Argonaut/Encode/Generic.purs +++ b/src/Data/Argonaut/Encode/Generic.purs @@ -1,5 +1,5 @@ module Data.Argonaut.Encode.Generic ( - gEncodeJson, + gEncodeJson, gEncodeJson' ) where diff --git a/src/Data/Argonaut/Encode/Generic/Rep.purs b/src/Data/Argonaut/Encode/Generic/Rep.purs new file mode 100644 index 0000000..23cb0aa --- /dev/null +++ b/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 diff --git a/test/Main.purs b/test/Main.purs new file mode 100644 index 0000000..a1cb85a --- /dev/null +++ b/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 $ "--------------------------------------------------------------------------------"