add sum encoding and handling for sum types of unary constructors

bower.json

@@ -16,15 +16,16 @@
   },
   "dependencies": {
     "purescript-console": "^3.0.0",
-    "purescript-eff": "^3.0.0",
+    "purescript-eff": "^3.1.0",
     "purescript-exceptions": "^3.0.0",
-    "purescript-foreign": "^4.0.0",
-    "purescript-generics-rep": "^5.0.0",
+    "purescript-foreign": "^4.0.1",
+    "purescript-generics-rep": "^5.1.0",
     "purescript-globals": "^3.0.0",
-    "purescript-maps": "^3.0.0",
+    "purescript-maps": "^3.3.1",
     "purescript-nullable": "^3.0.0",
-    "purescript-proxy": "^2.0.0",
-    "purescript-symbols": "^3.0.0"
+    "purescript-proxy": "^2.1.0",
+    "purescript-symbols": "^3.0.0",
+    "purescript-strings": "^3.2.1"
   },
   "devDependencies": {
     "purescript-assert": "^3.0.0"

package.json

@@ -7,8 +7,8 @@
   },
   "devDependencies": {
     "pulp": "^11.0.0",
-    "purescript": "^0.11.1",
-    "purescript-psa": "^0.5.0",
-    "rimraf": "^2.5.0"
+    "purescript": "^0.11.5",
+    "purescript-psa": "^0.5.1",
+    "rimraf": "^2.6.1"
   }
 }

src/Data/Foreign/Generic.purs

@@ -9,6 +9,7 @@ module Data.Foreign.Generic
   ) where
 
 import Prelude
+
 import Data.Foreign (F, Foreign)
 import Data.Foreign.Class (class Decode, class Encode, decode, encode)
 import Data.Foreign.Generic.Class (class GenericDecode, class GenericEncode, decodeOpts, encodeOpts)
@@ -22,12 +23,14 @@ import Global.Unsafe (unsafeStringify)
 -- | - Represent sum types as records with `tag` and `contents` fields
 -- | - Unwrap single arguments
 -- | - Don't unwrap single constructors
+-- | - Use the constructor names as-is
 defaultOptions :: Options
 defaultOptions =
   { sumEncoding:
       TaggedObject
         { tagFieldName: "tag"
         , contentsFieldName: "contents"
+        , constructorTagTransform: id
         }
   , unwrapSingleConstructors: false
   , unwrapSingleArguments: true

src/Data/Foreign/Generic/Class.purs

@@ -1,7 +1,7 @@
 module Data.Foreign.Generic.Class where
 
 import Prelude
-import Data.StrMap as S
+
 import Control.Alt ((<|>))
 import Control.Monad.Except (mapExcept)
 import Data.Bifunctor (lmap)
@@ -14,6 +14,7 @@ import Data.Generic.Rep (Argument(..), Constructor(..), Field(..), NoArguments(.
 import Data.List (List(..), fromFoldable, null, singleton, toUnfoldable, (:))
 import Data.Maybe (Maybe(..), maybe)
 import Data.Monoid (mempty)
+import Data.StrMap as S
 import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Type.Proxy (Proxy(..))
 
@@ -54,11 +55,12 @@ instance genericDecodeConstructor
       if opts.unwrapSingleConstructors
         then Constructor <$> readArguments f
         else case opts.sumEncoding of
-               TaggedObject { tagFieldName, contentsFieldName } -> do
+               TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> do
                  tag <- mapExcept (lmap (map (ErrorAtProperty contentsFieldName))) do
                    tag <- index f tagFieldName >>= readString
-                   unless (tag == ctorName) $
-                     fail (ForeignError ("Expected " <> show ctorName <> " tag"))
+                   let expected = constructorTagTransform ctorName
+                   unless (constructorTagTransform tag == expected) $
+                     fail (ForeignError ("Expected " <> show expected <> " tag"))
                    pure tag
                  args <- mapExcept (lmap (map (ErrorAtProperty contentsFieldName)))
                            (index f contentsFieldName >>= readArguments)
@@ -90,10 +92,9 @@ instance genericEncodeConstructor
       if opts.unwrapSingleConstructors
         then maybe (toForeign {}) toForeign (encodeArgsArray args)
         else case opts.sumEncoding of
-               TaggedObject { tagFieldName, contentsFieldName } ->
-                 toForeign (S.singleton tagFieldName (toForeign ctorName)
+               TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } ->
+                 toForeign (S.singleton tagFieldName (toForeign $ constructorTagTransform ctorName)
                            `S.union` maybe S.empty (S.singleton contentsFieldName) (encodeArgsArray args))
-
     where
       ctorName = reflectSymbol (SProxy :: SProxy name)
 

src/Data/Foreign/Generic/Enum.purs

@@ -0,0 +1,122 @@
+module Data.Foreign.Generic.EnumEncoding where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Foreign (F, Foreign, ForeignError(..), fail, readString, toForeign)
+import Data.Generic.Rep (class Generic, Argument, Constructor(Constructor), NoArguments(NoArguments), Product, Rec, Sum(Inr, Inl), from, to)
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+import Partial.Unsafe (unsafeCrashWith)
+
+type GenericEnumOptions =
+  { constructorTagTransform :: String -> String
+  }
+
+defaultGenericEnumOptions :: GenericEnumOptions
+defaultGenericEnumOptions =
+  { constructorTagTransform: id
+  }
+
+-- | A generic function to be used with "Enums", or sum types with only no-argument constructors. This is used for decoding from strings to one of the constructors, combined with the `constructorTagTransform` property of `SumEncoding`.
+genericDecodeEnum
+  :: forall a rep
+   . Generic a rep
+  => GenericDecodeEnum rep
+  => GenericEnumOptions
+  -> Foreign
+  -> F a
+genericDecodeEnum opts = map to <<< decodeEnum opts
+
+-- | A generic function to be used with "Enums", or sum types with only no-argument constructors. This is used for encoding to strings from one of the constructors, combined with the `constructorTagTransform` property of `SumEncoding`.
+-- |
+-- | For example:
+-- |
+-- | ```purescript
+-- | data Fruit = Apple | Banana | Frikandel
+-- | derive instance geFruit :: Generic Fruit _
+-- | instance eFruit :: Encode Fruit where
+-- |   encode = genericEncodeEnum defaultGenericEnumOptions
+genericEncodeEnum
+  :: forall a rep
+   . Generic a rep
+  => GenericEncodeEnum rep
+  => GenericEnumOptions
+  -> a
+  -> Foreign
+genericEncodeEnum opts = encodeEnum opts <<< from
+
+-- | A type class for type representations that can be used for decoding to an Enum. Only the sum and no-argument constructor instances are valid, while others provide a `Fail` constraint to fail in compilation.
+-- |
+-- | For example:
+-- |
+-- | ```purescript
+-- | data Fruit = Apple | Banana | Frikandel
+-- | derive instance geFruit :: Generic Fruit _
+-- | instance dFruit :: Decode Fruit where
+-- |   decode = genericDecodeEnum defaultGenericEnumOptions
+-- | ```
+class GenericDecodeEnum a where
+  decodeEnum :: GenericEnumOptions -> Foreign -> F a
+
+-- | A type class for type representations that can be used for encoding from an Enum. Only the sum and no-argument constructor instances are valid, while others provide a `Fail` constraint to fail in compilation.
+class GenericEncodeEnum a where
+  encodeEnum :: GenericEnumOptions -> a -> Foreign
+
+instance sumGenericDecodeEnum
+  :: (GenericDecodeEnum a, GenericDecodeEnum b)
+  => GenericDecodeEnum (Sum a b) where
+  decodeEnum opts f = Inl <$> decodeEnum opts f <|> Inr <$> decodeEnum opts f
+
+instance ctorNoArgsGenericDecodeEnum
+  :: IsSymbol name
+  => GenericDecodeEnum (Constructor name NoArguments) where
+  decodeEnum {constructorTagTransform} f = do
+    tag <- readString f
+    unless (tag == ctorName) $
+      fail (ForeignError ("Expected " <> show ctorName <> " tag for unary constructor literal " <> ctorName))
+    pure $ Constructor NoArguments
+    where
+      ctorName = constructorTagTransform $ reflectSymbol (SProxy :: SProxy name)
+
+instance ctorArgumentGenericDecodeEnum
+  :: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
+  => GenericDecodeEnum (Constructor name (Argument a)) where
+  decodeEnum _ _ = unsafeCrashWith "unreachable decodeEnum was reached."
+
+instance ctorProductGenericDecodeEnum
+  :: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
+  => GenericDecodeEnum (Constructor name (Product a b)) where
+  decodeEnum _ _ = unsafeCrashWith "unreachable decodeEnum was reached."
+
+instance ctorRecGenericDecodeEnum
+  :: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
+  => GenericDecodeEnum (Constructor name (Rec a)) where
+  decodeEnum _ _ = unsafeCrashWith "unreachable decodeEnum was reached."
+
+instance sumGenericEncodeEnum
+  :: (GenericEncodeEnum a, GenericEncodeEnum b)
+  => GenericEncodeEnum (Sum a b) where
+  encodeEnum opts (Inl a) = encodeEnum opts a
+  encodeEnum opts (Inr b) = encodeEnum opts b
+
+instance ctorNoArgsGenericEncodeEnum
+  :: IsSymbol name
+  => GenericEncodeEnum (Constructor name NoArguments) where
+  encodeEnum {constructorTagTransform} _ = toForeign ctorName
+    where
+      ctorName = constructorTagTransform $ reflectSymbol (SProxy :: SProxy name)
+
+instance ctorArgumentGenericEncodeEnum
+  :: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
+  => GenericEncodeEnum (Constructor name (Argument a)) where
+  encodeEnum _ _ = unsafeCrashWith "unreachable encodeEnum was reached."
+
+instance ctorProductGenericEncodeEnum
+  :: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
+  => GenericEncodeEnum (Constructor name (Product a b)) where
+  encodeEnum _ _ = unsafeCrashWith "unreachable encodeEnum was reached."
+
+instance ctorRecGenericEncodeEnum
+  :: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
+  => GenericEncodeEnum (Constructor name (Rec a)) where
+  encodeEnum _ _ = unsafeCrashWith "unreachable encodeEnum was reached."

src/Data/Foreign/Generic/Types.purs

@@ -6,8 +6,12 @@ type Options =
   , unwrapSingleArguments :: Boolean
   }
 
+-- | The encoding of sum types for your type.
+-- | `TaggedObject`s will be encoded in the form `{ [tagFieldName]: "ConstructorTag", [contentsFieldName]: "Contents"}`.
+-- | `constructorTagTransform` can be provided to transform the constructor tag to a form you use, e.g. `toLower`/`toUpper`.
 data SumEncoding
   = TaggedObject
     { tagFieldName :: String
     , contentsFieldName :: String
+    , constructorTagTransform :: String -> String
     }

test/Main.purs

@@ -1,18 +1,24 @@
 module Test.Main where
 
 import Prelude
+
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE, log)
 import Control.Monad.Except (runExcept)
 import Data.Bifunctor (bimap)
 import Data.Either (Either(..))
 import Data.Foreign.Class (class Encode, class Decode)
 import Data.Foreign.Generic (decodeJSON, encodeJSON)
+import Data.Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum)
+import Data.Foreign.JSON (parseJSON)
 import Data.Foreign.NullOrUndefined (NullOrUndefined(..))
+import Data.Generic.Rep (class Generic)
 import Data.Maybe (Maybe(..))
+import Data.String (toLower, toUpper)
 import Data.Tuple (Tuple(..))
+import Global.Unsafe (unsafeStringify)
 import Test.Assert (assert, assert', ASSERT)
-import Test.Types (IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..))
+import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..))
 
 buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a
 buildTree _ 0 a = Leaf a
@@ -42,6 +48,43 @@ testRoundTrip x = do
     Right y -> assert (x == y)
     Left err -> throw (show err)
 
+testOption
+  :: ∀ a rep eff
+   . Eq a
+  => Generic a rep
+  => GenericEncodeEnum rep
+  => GenericDecodeEnum rep
+  => GenericEnumOptions
+  -> String
+  -> a
+  -> Eff ( console :: CONSOLE
+         , assert :: ASSERT
+         | eff
+         ) Unit
+testOption options string value = do
+  let json = unsafeStringify $ genericEncodeEnum options value
+  log json
+  case runExcept $ Tuple <$> decode' json <*> decode' string of
+    Right (Tuple x y) -> assert (value == y && value == x)
+    Left err -> throw (show err)
+  where
+    decode' = genericDecodeEnum options <=< parseJSON
+
+testUnaryConstructorLiteral :: forall e.
+  Eff
+    ( console :: CONSOLE
+    , assert :: ASSERT
+    | e
+    )
+    Unit
+testUnaryConstructorLiteral = do
+    testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel
+    testOption (makeCasingOptions toLower) "\"frikandel\"" Frikandel
+  where
+    makeCasingOptions f =
+      { constructorTagTransform: f
+      }
+
 main :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
 main = do
   testRoundTrip (RecordTest { foo: 1, bar: "test", baz: 'a' })
@@ -50,5 +93,7 @@ main = do
   testRoundTrip (UndefinedTest {a: NullOrUndefined Nothing})
   testRoundTrip [NullOrUndefined (Just "test")]
   testRoundTrip [NullOrUndefined (Nothing :: Maybe String)]
+  testRoundTrip (Apple)
   testRoundTrip (makeTree 0)
   testRoundTrip (makeTree 5)
+  testUnaryConstructorLiteral

test/Types.purs

@@ -1,10 +1,12 @@
 module Test.Types where
 
 import Prelude
+
 import Data.Bifunctor (class Bifunctor)
 import Data.Foreign (ForeignError(ForeignError), fail, readArray, toForeign)
 import Data.Foreign.Class (class Encode, class Decode, encode, decode)
 import Data.Foreign.Generic (defaultOptions, genericDecode, genericEncode)
+import Data.Foreign.Generic.EnumEncoding (defaultGenericEnumOptions, genericDecodeEnum, genericEncodeEnum)
 import Data.Foreign.NullOrUndefined (NullOrUndefined)
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Eq (genericEq)
@@ -99,3 +101,16 @@ instance dUT :: Decode UndefinedTest where
   decode = genericDecode $ defaultOptions
 instance eUT :: Encode UndefinedTest where
   encode = genericEncode $ defaultOptions
+
+data Fruit
+  = Apple
+  | Banana
+  | Frikandel
+
+derive instance eqFruit :: Eq Fruit
+derive instance geFruit :: Generic Fruit _
+
+instance dFruit :: Decode Fruit where
+  decode = genericDecodeEnum defaultGenericEnumOptions
+instance eFruit :: Encode Fruit where
+  encode = genericEncodeEnum defaultGenericEnumOptions