diff --git a/src/Data/Argonaut/Decode/Generic/Rep.purs b/src/Data/Argonaut/Decode/Generic/Rep.purs index 1263916..dc4c736 100644 --- a/src/Data/Argonaut/Decode/Generic/Rep.purs +++ b/src/Data/Argonaut/Decode/Generic/Rep.purs @@ -2,10 +2,14 @@ module Data.Argonaut.Decode.Generic.Rep ( class DecodeRep, class DecodeRepArgs, class DecodeRepFields, + class DecodeLiteral, decodeRep, decodeRepArgs, decodeRepFields, - genericDecodeJson + genericDecodeJson, + decodeLiteralSum, + decodeLiteralSumWithTransform, + decodeLiteral ) where import Prelude @@ -20,6 +24,7 @@ import Data.Generic.Rep as Rep import Data.Maybe (Maybe, maybe) import Data.StrMap as SM import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) +import Partial.Unsafe (unsafeCrashWith) class DecodeRep r where decodeRep :: Json -> Either String r @@ -87,3 +92,34 @@ genericDecodeJson = map Rep.to <<< decodeRep mFail :: forall a. String -> Maybe a -> Either String a mFail msg = maybe (Left msg) Right + +-- | A function for decoding `Generic` sum types using string literal representations +decodeLiteralSum :: forall a r. Rep.Generic a r => DecodeLiteral r => Json -> Either String a +decodeLiteralSum = decodeLiteralSumWithTransform id + +-- | A function for decoding `Generic` sum types using string literal representations +-- | Takes a function for transforming the tag name in encoding +decodeLiteralSumWithTransform :: forall a r. Rep.Generic a r => DecodeLiteral r => (String -> String) -> Json -> Either String a +decodeLiteralSumWithTransform tagNameTransform = map Rep.to <<< decodeLiteral tagNameTransform + +class DecodeLiteral r where + decodeLiteral :: (String -> String) -> Json -> Either String r + +instance decodeLiteralSumInst :: (DecodeLiteral a, DecodeLiteral b) => DecodeLiteral (Rep.Sum a b) where + decodeLiteral tagNameTransform j = Rep.Inl <$> decodeLiteral tagNameTransform j <|> Rep.Inr <$> decodeLiteral tagNameTransform j + +instance decodeLiteralConstructor :: (IsSymbol name) => DecodeLiteral (Rep.Constructor name (Rep.NoArguments)) where + decodeLiteral tagNameTransform j = do + let name = reflectSymbol (SProxy :: SProxy name) + let decodingErr msg = "When decoding a " <> name <> ": " <> msg + tag <- mFail (decodingErr "could not read string for constructor") (toString j) + when (tag /= tagNameTransform name) $ + Left $ decodingErr "string literal " <> tag <> " had an incorrect value." + pure $ Rep.Constructor (Rep.NoArguments) + +type FailMessage = """`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 + :: Fail FailMessage + => DecodeLiteral (Rep.Product a b) where + decodeLiteral _ _ = unsafeCrashWith "unreachable DecodeLiteral was reached." diff --git a/src/Data/Argonaut/Encode/Generic/Rep.purs b/src/Data/Argonaut/Encode/Generic/Rep.purs index 23cb0aa..48c47ee 100644 --- a/src/Data/Argonaut/Encode/Generic/Rep.purs +++ b/src/Data/Argonaut/Encode/Generic/Rep.purs @@ -2,19 +2,24 @@ module Data.Argonaut.Encode.Generic.Rep ( class EncodeRep, class EncodeRepArgs, class EncodeRepFields, + class EncodeLiteral, encodeRep, encodeRepArgs, encodeRepFields, - genericEncodeJson + genericEncodeJson, + encodeLiteralSum, + encodeLiteralSumWithTransform, + encodeLiteral ) where import Prelude -import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) import Data.Argonaut.Core (Json, fromArray, fromObject, fromString) +import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) import Data.Generic.Rep as Rep import Data.StrMap as SM import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) +import Partial.Unsafe (unsafeCrashWith) class EncodeRep r where encodeRep :: r -> Json @@ -63,3 +68,29 @@ instance encodeRepFieldsField :: (IsSymbol field, EncodeJson a) => EncodeRepFiel -- | Encode any `Generic` data structure into `Json`. genericEncodeJson :: forall a r. Rep.Generic a r => EncodeRep r => a -> Json genericEncodeJson = encodeRep <<< 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 +encodeLiteralSum = encodeLiteralSumWithTransform id + +-- | A function for encoding `Generic` sum types using string literal representations +-- | Takes a function for transforming the tag name in encoding +encodeLiteralSumWithTransform :: forall a r. Rep.Generic a r => EncodeLiteral r => (String -> String) -> a -> Json +encodeLiteralSumWithTransform tagNameTransform = encodeLiteral tagNameTransform <<< Rep.from + +class EncodeLiteral r where + encodeLiteral :: (String -> String) -> r -> Json + +instance encodeLiteralSumInst :: (EncodeLiteral a, EncodeLiteral b) => EncodeLiteral (Rep.Sum a b) where + encodeLiteral tagNameTransform (Rep.Inl a) = encodeLiteral tagNameTransform a + encodeLiteral tagNameTransform (Rep.Inr b) = encodeLiteral tagNameTransform b + +instance encodeLiteralConstructor :: (IsSymbol name) => EncodeLiteral (Rep.Constructor name (Rep.NoArguments)) where + encodeLiteral tagNameTransform _ = fromString <<< tagNameTransform $ reflectSymbol (SProxy :: SProxy name) + +type FailMessage = """`encodeLiteralSum` 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 encodeLiteralConstructorCannotBeProduct + :: Fail FailMessage + => EncodeLiteral (Rep.Product a b) where + encodeLiteral _ _ = unsafeCrashWith "unreachable encodeLiteral was reached." diff --git a/test/Main.purs b/test/Main.purs index a1cb85a..bbcd087 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -8,12 +8,15 @@ 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.Decode.Generic.Rep (class DecodeLiteral, decodeLiteralSumWithTransform, genericDecodeJson) import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) -import Data.Argonaut.Encode.Generic.Rep (genericEncodeJson) -import Data.Either (Either(..)) +import Data.Argonaut.Encode.Generic.Rep (class EncodeLiteral, encodeLiteralSumWithTransform, genericEncodeJson) +import Data.Argonaut.Parser (jsonParser) +import Data.Either (Either(..), fromRight) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Show (genericShow) +import Data.String (toLower, toUpper) +import Partial.Unsafe (unsafePartial) import Test.Assert (ASSERT, assert) data Example @@ -30,13 +33,33 @@ instance encodeJsonExample :: EncodeJson Example where instance decodeJson :: DecodeJson Example where decodeJson a = genericDecodeJson a +data LiteralStringExample + = Apple + | Banana + | Frikandel + +derive instance eqLiteralStringExample :: Eq LiteralStringExample +derive instance genericLiteralStringExample :: Generic LiteralStringExample _ +instance showLiteralStringExample :: Show LiteralStringExample where + show a = genericShow a +instance encodeJsonLiteralStringExample :: EncodeJson LiteralStringExample where + encodeJson a = encodeLiteralSumWithTransform id a +instance decodeJsonLiteralStringExample :: DecodeJson LiteralStringExample where + decodeJson a = decodeLiteralSumWithTransform id 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" + example $ Frikandel + testLiteralSumWithTransform id Frikandel "\"Frikandel\"" + testLiteralSumWithTransform toUpper Frikandel "\"FRIKANDEL\"" + testLiteralSumWithTransform toLower Frikandel "\"frikandel\"" + where + example :: forall a. Show a => Eq a => EncodeJson a => DecodeJson a => a -> Eff _ Unit example original = do let json = encodeJson original let parsed = decodeJson json @@ -45,3 +68,23 @@ main = do log $ "From JSON: " <> show parsed assert $ parsed == Right original log $ "--------------------------------------------------------------------------------" + testLiteralSumWithTransform :: forall a rep + . Show a + => Eq a + => Generic a rep + => EncodeLiteral rep + => DecodeLiteral rep + => (String -> String) + -> a + -> String + -> Eff _ Unit + testLiteralSumWithTransform tagNameTransform original string = do + let json = encodeLiteralSumWithTransform tagNameTransform original + let parsed = decodeLiteralSumWithTransform tagNameTransform json + let parsed' = decodeLiteralSumWithTransform tagNameTransform <<< unsafePartial fromRight $ jsonParser string + log $ "Original: " <> show original + log $ "To JSON: " <> stringify json + log $ "From JSON: " <> show parsed + assert $ parsed == Right original + assert $ parsed' == Right original + log $ "--------------------------------------------------------------------------------"