diff --git a/bower.json b/bower.json index 85dee42..b91169f 100644 --- a/bower.json +++ b/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" diff --git a/package.json b/package.json index 93fa370..7b9ec16 100644 --- a/package.json +++ b/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" } } diff --git a/src/Data/Foreign/Generic.purs b/src/Data/Foreign/Generic.purs index bb4eed0..46745f5 100644 --- a/src/Data/Foreign/Generic.purs +++ b/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 diff --git a/src/Data/Foreign/Generic/Class.purs b/src/Data/Foreign/Generic/Class.purs index 00e9f42..ce9de82 100644 --- a/src/Data/Foreign/Generic/Class.purs +++ b/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) diff --git a/src/Data/Foreign/Generic/Enum.purs b/src/Data/Foreign/Generic/Enum.purs new file mode 100644 index 0000000..d294894 --- /dev/null +++ b/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." diff --git a/src/Data/Foreign/Generic/Types.purs b/src/Data/Foreign/Generic/Types.purs index b4551c3..f7255f8 100644 --- a/src/Data/Foreign/Generic/Types.purs +++ b/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 } diff --git a/test/Main.purs b/test/Main.purs index 3b806db..e718776 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,6 +1,7 @@ module Test.Main where import Prelude + import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (CONSOLE, log) import Control.Monad.Except (runExcept) @@ -8,11 +9,16 @@ 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 diff --git a/test/Types.purs b/test/Types.purs index f847aff..0e13bfc 100644 --- a/test/Types.purs +++ b/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