Skip to content

Commit 34332d8

Browse files
justinwoopaf31
justinwoo
authored and
paf31
committed
Provide enum/unary constructor sum type functions for use in instances (#26)
Adds constructor tag transform so that users can customize the tag as needed
1 parent f43b4af commit 34332d8

File tree

8 files changed

+208
-17
lines changed

8 files changed

+208
-17
lines changed

‎bower.json‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -16,15 +16,16 @@
1616
},
1717
"dependencies": {
1818
"purescript-console": "^3.0.0",
19-
"purescript-eff": "^3.0.0",
19+
"purescript-eff": "^3.1.0",
2020
"purescript-exceptions": "^3.0.0",
21-
"purescript-foreign": "^4.0.0",
22-
"purescript-generics-rep": "^5.0.0",
21+
"purescript-foreign": "^4.0.1",
22+
"purescript-generics-rep": "^5.1.0",
2323
"purescript-globals": "^3.0.0",
24-
"purescript-maps": "^3.0.0",
24+
"purescript-maps": "^3.3.1",
2525
"purescript-nullable": "^3.0.0",
26-
"purescript-proxy": "^2.0.0",
27-
"purescript-symbols": "^3.0.0"
26+
"purescript-proxy": "^2.1.0",
27+
"purescript-symbols": "^3.0.0",
28+
"purescript-strings": "^3.2.1"
2829
},
2930
"devDependencies": {
3031
"purescript-assert": "^3.0.0"

‎package.json‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,8 @@
77
},
88
"devDependencies": {
99
"pulp": "^11.0.0",
10-
"purescript": "^0.11.1",
11-
"purescript-psa": "^0.5.0",
12-
"rimraf": "^2.5.0"
10+
"purescript": "^0.11.5",
11+
"purescript-psa": "^0.5.1",
12+
"rimraf": "^2.6.1"
1313
}
1414
}

‎src/Data/Foreign/Generic.purs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Data.Foreign.Generic
99
) where
1010

1111
import Prelude
12+
1213
import Data.Foreign (F, Foreign)
1314
import Data.Foreign.Class (class Decode, class Encode, decode, encode)
1415
import Data.Foreign.Generic.Class (class GenericDecode, class GenericEncode, decodeOpts, encodeOpts)
@@ -22,12 +23,14 @@ import Global.Unsafe (unsafeStringify)
2223
-- | - Represent sum types as records with `tag` and `contents` fields
2324
-- | - Unwrap single arguments
2425
-- | - Don't unwrap single constructors
26+
-- | - Use the constructor names as-is
2527
defaultOptions :: Options
2628
defaultOptions =
2729
{ sumEncoding:
2830
TaggedObject
2931
{ tagFieldName: "tag"
3032
, contentsFieldName: "contents"
33+
, constructorTagTransform: id
3134
}
3235
, unwrapSingleConstructors: false
3336
, unwrapSingleArguments: true

‎src/Data/Foreign/Generic/Class.purs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
module Data.Foreign.Generic.Class where
22

33
import Prelude
4-
import Data.StrMap as S
4+
55
import Control.Alt ((<|>))
66
import Control.Monad.Except (mapExcept)
77
import Data.Bifunctor (lmap)
@@ -14,6 +14,7 @@ import Data.Generic.Rep (Argument(..), Constructor(..), Field(..), NoArguments(.
1414
import Data.List (List(..), fromFoldable, null, singleton, toUnfoldable, (:))
1515
import Data.Maybe (Maybe(..), maybe)
1616
import Data.Monoid (mempty)
17+
import Data.StrMap as S
1718
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
1819
import Type.Proxy (Proxy(..))
1920

@@ -54,11 +55,12 @@ instance genericDecodeConstructor
5455
if opts.unwrapSingleConstructors
5556
then Constructor <$> readArguments f
5657
else case opts.sumEncoding of
57-
TaggedObject { tagFieldName, contentsFieldName } -> do
58+
TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } -> do
5859
tag <- mapExcept (lmap (map (ErrorAtProperty contentsFieldName))) do
5960
tag <- index f tagFieldName >>= readString
60-
unless (tag == ctorName) $
61-
fail (ForeignError ("Expected " <> show ctorName <> " tag"))
61+
let expected = constructorTagTransform ctorName
62+
unless (constructorTagTransform tag == expected) $
63+
fail (ForeignError ("Expected " <> show expected <> " tag"))
6264
pure tag
6365
args <- mapExcept (lmap (map (ErrorAtProperty contentsFieldName)))
6466
(index f contentsFieldName >>= readArguments)
@@ -90,10 +92,9 @@ instance genericEncodeConstructor
9092
if opts.unwrapSingleConstructors
9193
then maybe (toForeign {}) toForeign (encodeArgsArray args)
9294
else case opts.sumEncoding of
93-
TaggedObject { tagFieldName, contentsFieldName } ->
94-
toForeign (S.singleton tagFieldName (toForeign ctorName)
95+
TaggedObject { tagFieldName, contentsFieldName, constructorTagTransform } ->
96+
toForeign (S.singleton tagFieldName (toForeign $ constructorTagTransform ctorName)
9597
`S.union` maybe S.empty (S.singleton contentsFieldName) (encodeArgsArray args))
96-
9798
where
9899
ctorName = reflectSymbol (SProxy :: SProxy name)
99100

‎src/Data/Foreign/Generic/Enum.purs‎

Lines changed: 122 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,122 @@
1+
module Data.Foreign.Generic.EnumEncoding where
2+
3+
import Prelude
4+
5+
import Control.Alt ((<|>))
6+
import Data.Foreign (F, Foreign, ForeignError(..), fail, readString, toForeign)
7+
import Data.Generic.Rep (class Generic, Argument, Constructor(Constructor), NoArguments(NoArguments), Product, Rec, Sum(Inr, Inl), from, to)
8+
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
9+
import Partial.Unsafe (unsafeCrashWith)
10+
11+
type GenericEnumOptions =
12+
{ constructorTagTransform :: String -> String
13+
}
14+
15+
defaultGenericEnumOptions :: GenericEnumOptions
16+
defaultGenericEnumOptions =
17+
{ constructorTagTransform: id
18+
}
19+
20+
-- | 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`.
21+
genericDecodeEnum
22+
:: forall a rep
23+
. Generic a rep
24+
=> GenericDecodeEnum rep
25+
=> GenericEnumOptions
26+
-> Foreign
27+
-> F a
28+
genericDecodeEnum opts = map to <<< decodeEnum opts
29+
30+
-- | 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`.
31+
-- |
32+
-- | For example:
33+
-- |
34+
-- | ```purescript
35+
-- | data Fruit = Apple | Banana | Frikandel
36+
-- | derive instance geFruit :: Generic Fruit _
37+
-- | instance eFruit :: Encode Fruit where
38+
-- | encode = genericEncodeEnum defaultGenericEnumOptions
39+
genericEncodeEnum
40+
:: forall a rep
41+
. Generic a rep
42+
=> GenericEncodeEnum rep
43+
=> GenericEnumOptions
44+
-> a
45+
-> Foreign
46+
genericEncodeEnum opts = encodeEnum opts <<< from
47+
48+
-- | 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.
49+
-- |
50+
-- | For example:
51+
-- |
52+
-- | ```purescript
53+
-- | data Fruit = Apple | Banana | Frikandel
54+
-- | derive instance geFruit :: Generic Fruit _
55+
-- | instance dFruit :: Decode Fruit where
56+
-- | decode = genericDecodeEnum defaultGenericEnumOptions
57+
-- | ```
58+
class GenericDecodeEnum a where
59+
decodeEnum :: GenericEnumOptions -> Foreign -> F a
60+
61+
-- | 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.
62+
class GenericEncodeEnum a where
63+
encodeEnum :: GenericEnumOptions -> a -> Foreign
64+
65+
instance sumGenericDecodeEnum
66+
:: (GenericDecodeEnum a, GenericDecodeEnum b)
67+
=> GenericDecodeEnum (Sum a b) where
68+
decodeEnum opts f = Inl <$> decodeEnum opts f <|> Inr <$> decodeEnum opts f
69+
70+
instance ctorNoArgsGenericDecodeEnum
71+
:: IsSymbol name
72+
=> GenericDecodeEnum (Constructor name NoArguments) where
73+
decodeEnum {constructorTagTransform} f = do
74+
tag <- readString f
75+
unless (tag == ctorName) $
76+
fail (ForeignError ("Expected " <> show ctorName <> " tag for unary constructor literal " <> ctorName))
77+
pure $ Constructor NoArguments
78+
where
79+
ctorName = constructorTagTransform $ reflectSymbol (SProxy :: SProxy name)
80+
81+
instance ctorArgumentGenericDecodeEnum
82+
:: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
83+
=> GenericDecodeEnum (Constructor name (Argument a)) where
84+
decodeEnum _ _ = unsafeCrashWith "unreachable decodeEnum was reached."
85+
86+
instance ctorProductGenericDecodeEnum
87+
:: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
88+
=> GenericDecodeEnum (Constructor name (Product a b)) where
89+
decodeEnum _ _ = unsafeCrashWith "unreachable decodeEnum was reached."
90+
91+
instance ctorRecGenericDecodeEnum
92+
:: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
93+
=> GenericDecodeEnum (Constructor name (Rec a)) where
94+
decodeEnum _ _ = unsafeCrashWith "unreachable decodeEnum was reached."
95+
96+
instance sumGenericEncodeEnum
97+
:: (GenericEncodeEnum a, GenericEncodeEnum b)
98+
=> GenericEncodeEnum (Sum a b) where
99+
encodeEnum opts (Inl a) = encodeEnum opts a
100+
encodeEnum opts (Inr b) = encodeEnum opts b
101+
102+
instance ctorNoArgsGenericEncodeEnum
103+
:: IsSymbol name
104+
=> GenericEncodeEnum (Constructor name NoArguments) where
105+
encodeEnum {constructorTagTransform} _ = toForeign ctorName
106+
where
107+
ctorName = constructorTagTransform $ reflectSymbol (SProxy :: SProxy name)
108+
109+
instance ctorArgumentGenericEncodeEnum
110+
:: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
111+
=> GenericEncodeEnum (Constructor name (Argument a)) where
112+
encodeEnum _ _ = unsafeCrashWith "unreachable encodeEnum was reached."
113+
114+
instance ctorProductGenericEncodeEnum
115+
:: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
116+
=> GenericEncodeEnum (Constructor name (Product a b)) where
117+
encodeEnum _ _ = unsafeCrashWith "unreachable encodeEnum was reached."
118+
119+
instance ctorRecGenericEncodeEnum
120+
:: Fail "genericEncode/DecodeEnum cannot be used on types that are not sums of constructors with no arguments."
121+
=> GenericEncodeEnum (Constructor name (Rec a)) where
122+
encodeEnum _ _ = unsafeCrashWith "unreachable encodeEnum was reached."

‎src/Data/Foreign/Generic/Types.purs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,8 +6,12 @@ type Options =
66
, unwrapSingleArguments :: Boolean
77
}
88

9+
-- | The encoding of sum types for your type.
10+
-- | `TaggedObject`s will be encoded in the form `{ [tagFieldName]: "ConstructorTag", [contentsFieldName]: "Contents"}`.
11+
-- | `constructorTagTransform` can be provided to transform the constructor tag to a form you use, e.g. `toLower`/`toUpper`.
912
data SumEncoding
1013
= TaggedObject
1114
{ tagFieldName :: String
1215
, contentsFieldName :: String
16+
, constructorTagTransform :: String -> String
1317
}

‎test/Main.purs‎

Lines changed: 46 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,24 @@
11
module Test.Main where
22

33
import Prelude
4+
45
import Control.Monad.Eff (Eff)
56
import Control.Monad.Eff.Console (CONSOLE, log)
67
import Control.Monad.Except (runExcept)
78
import Data.Bifunctor (bimap)
89
import Data.Either (Either(..))
910
import Data.Foreign.Class (class Encode, class Decode)
1011
import Data.Foreign.Generic (decodeJSON, encodeJSON)
12+
import Data.Foreign.Generic.EnumEncoding (class GenericDecodeEnum, class GenericEncodeEnum, GenericEnumOptions, genericDecodeEnum, genericEncodeEnum)
13+
import Data.Foreign.JSON (parseJSON)
1114
import Data.Foreign.NullOrUndefined (NullOrUndefined(..))
15+
import Data.Generic.Rep (class Generic)
1216
import Data.Maybe (Maybe(..))
17+
import Data.String (toLower, toUpper)
1318
import Data.Tuple (Tuple(..))
19+
import Global.Unsafe (unsafeStringify)
1420
import Test.Assert (assert, assert', ASSERT)
15-
import Test.Types (IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..))
21+
import Test.Types (Fruit(..), IntList(..), RecordTest(..), Tree(..), TupleArray(..), UndefinedTest(..))
1622

1723
buildTree :: forall a. (a -> TupleArray a a) -> Int -> a -> Tree a
1824
buildTree _ 0 a = Leaf a
@@ -42,6 +48,43 @@ testRoundTrip x = do
4248
Right y -> assert (x == y)
4349
Left err -> throw (show err)
4450

51+
testOption
52+
:: ∀ a rep eff
53+
. Eq a
54+
=> Generic a rep
55+
=> GenericEncodeEnum rep
56+
=> GenericDecodeEnum rep
57+
=> GenericEnumOptions
58+
-> String
59+
-> a
60+
-> Eff ( console :: CONSOLE
61+
, assert :: ASSERT
62+
| eff
63+
) Unit
64+
testOption options string value = do
65+
let json = unsafeStringify $ genericEncodeEnum options value
66+
log json
67+
case runExcept $ Tuple <$> decode' json <*> decode' string of
68+
Right (Tuple x y) -> assert (value == y && value == x)
69+
Left err -> throw (show err)
70+
where
71+
decode' = genericDecodeEnum options <=< parseJSON
72+
73+
testUnaryConstructorLiteral :: forall e.
74+
Eff
75+
( console :: CONSOLE
76+
, assert :: ASSERT
77+
| e
78+
)
79+
Unit
80+
testUnaryConstructorLiteral = do
81+
testOption (makeCasingOptions toUpper) "\"FRIKANDEL\"" Frikandel
82+
testOption (makeCasingOptions toLower) "\"frikandel\"" Frikandel
83+
where
84+
makeCasingOptions f =
85+
{ constructorTagTransform: f
86+
}
87+
4588
main :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
4689
main = do
4790
testRoundTrip (RecordTest { foo: 1, bar: "test", baz: 'a' })
@@ -50,5 +93,7 @@ main = do
5093
testRoundTrip (UndefinedTest {a: NullOrUndefined Nothing})
5194
testRoundTrip [NullOrUndefined (Just "test")]
5295
testRoundTrip [NullOrUndefined (Nothing :: Maybe String)]
96+
testRoundTrip (Apple)
5397
testRoundTrip (makeTree 0)
5498
testRoundTrip (makeTree 5)
99+
testUnaryConstructorLiteral

‎test/Types.purs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,12 @@
11
module Test.Types where
22

33
import Prelude
4+
45
import Data.Bifunctor (class Bifunctor)
56
import Data.Foreign (ForeignError(ForeignError), fail, readArray, toForeign)
67
import Data.Foreign.Class (class Encode, class Decode, encode, decode)
78
import Data.Foreign.Generic (defaultOptions, genericDecode, genericEncode)
9+
import Data.Foreign.Generic.EnumEncoding (defaultGenericEnumOptions, genericDecodeEnum, genericEncodeEnum)
810
import Data.Foreign.NullOrUndefined (NullOrUndefined)
911
import Data.Generic.Rep (class Generic)
1012
import Data.Generic.Rep.Eq (genericEq)
@@ -99,3 +101,16 @@ instance dUT :: Decode UndefinedTest where
99101
decode = genericDecode $ defaultOptions
100102
instance eUT :: Encode UndefinedTest where
101103
encode = genericEncode $ defaultOptions
104+
105+
data Fruit
106+
= Apple
107+
| Banana
108+
| Frikandel
109+
110+
derive instance eqFruit :: Eq Fruit
111+
derive instance geFruit :: Generic Fruit _
112+
113+
instance dFruit :: Decode Fruit where
114+
decode = genericDecodeEnum defaultGenericEnumOptions
115+
instance eFruit :: Encode Fruit where
116+
encode = genericEncodeEnum defaultGenericEnumOptions

0 commit comments

Comments
 (0)