add encoding of string literals to sum types of nullary constructors

Author: justinwoo

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."

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."

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 $ "--------------------------------------------------------------------------------"