Skip to content

Commit ce29496

Browse files
garybgaryb
authored
Merge pull request #3 from justinwoo/string-literal-sum
add encoding of string literals to sum types of unary constructors
2 parents d3066c2 + 926213b commit ce29496

File tree

3 files changed

+116
-6
lines changed

3 files changed

+116
-6
lines changed

‎src/Data/Argonaut/Decode/Generic/Rep.purs

Lines changed: 37 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,10 +2,14 @@ module Data.Argonaut.Decode.Generic.Rep (
22
class DecodeRep,
33
class DecodeRepArgs,
44
class DecodeRepFields,
5+
class DecodeLiteral,
56
decodeRep,
67
decodeRepArgs,
78
decodeRepFields,
8-
genericDecodeJson
9+
genericDecodeJson,
10+
decodeLiteralSum,
11+
decodeLiteralSumWithTransform,
12+
decodeLiteral
913
) where
1014

1115
import Prelude
@@ -20,6 +24,7 @@ import Data.Generic.Rep as Rep
2024
import Data.Maybe (Maybe, maybe)
2125
import Data.StrMap as SM
2226
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
27+
import Partial.Unsafe (unsafeCrashWith)
2328

2429
class DecodeRep r where
2530
decodeRep :: Json -> Either String r
@@ -87,3 +92,34 @@ genericDecodeJson = map Rep.to <<< decodeRep
8792

8893
mFail :: forall a. String -> Maybe a -> Either String a
8994
mFail msg = maybe (Left msg) Right
95+
96+
-- | A function for decoding `Generic` sum types using string literal representations
97+
decodeLiteralSum :: forall a r. Rep.Generic a r => DecodeLiteral r => Json -> Either String a
98+
decodeLiteralSum = decodeLiteralSumWithTransform id
99+
100+
-- | A function for decoding `Generic` sum types using string literal representations
101+
-- | Takes a function for transforming the tag name in encoding
102+
decodeLiteralSumWithTransform :: forall a r. Rep.Generic a r => DecodeLiteral r => (String -> String) -> Json -> Either String a
103+
decodeLiteralSumWithTransform tagNameTransform = map Rep.to <<< decodeLiteral tagNameTransform
104+
105+
class DecodeLiteral r where
106+
decodeLiteral :: (String -> String) -> Json -> Either String r
107+
108+
instance decodeLiteralSumInst :: (DecodeLiteral a, DecodeLiteral b) => DecodeLiteral (Rep.Sum a b) where
109+
decodeLiteral tagNameTransform j = Rep.Inl <$> decodeLiteral tagNameTransform j <|> Rep.Inr <$> decodeLiteral tagNameTransform j
110+
111+
instance decodeLiteralConstructor :: (IsSymbol name) => DecodeLiteral (Rep.Constructor name (Rep.NoArguments)) where
112+
decodeLiteral tagNameTransform j = do
113+
let name = reflectSymbol (SProxy :: SProxy name)
114+
let decodingErr msg = "When decoding a " <> name <> ": " <> msg
115+
tag <- mFail (decodingErr "could not read string for constructor") (toString j)
116+
when (tag /= tagNameTransform name) $
117+
Left $ decodingErr "string literal " <> tag <> " had an incorrect value."
118+
pure $ Rep.Constructor (Rep.NoArguments)
119+
120+
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."""
121+
122+
instance decodeLiteralConstructorCannotTakeProduct
123+
:: Fail FailMessage
124+
=> DecodeLiteral (Rep.Product a b) where
125+
decodeLiteral _ _ = unsafeCrashWith "unreachable DecodeLiteral was reached."

‎src/Data/Argonaut/Encode/Generic/Rep.purs

Lines changed: 33 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,19 +2,24 @@ module Data.Argonaut.Encode.Generic.Rep (
22
class EncodeRep,
33
class EncodeRepArgs,
44
class EncodeRepFields,
5+
class EncodeLiteral,
56
encodeRep,
67
encodeRepArgs,
78
encodeRepFields,
8-
genericEncodeJson
9+
genericEncodeJson,
10+
encodeLiteralSum,
11+
encodeLiteralSumWithTransform,
12+
encodeLiteral
913
) where
1014

1115
import Prelude
1216

13-
import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
1417
import Data.Argonaut.Core (Json, fromArray, fromObject, fromString)
18+
import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
1519
import Data.Generic.Rep as Rep
1620
import Data.StrMap as SM
1721
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
22+
import Partial.Unsafe (unsafeCrashWith)
1823

1924
class EncodeRep r where
2025
encodeRep :: r -> Json
@@ -63,3 +68,29 @@ instance encodeRepFieldsField :: (IsSymbol field, EncodeJson a) => EncodeRepFiel
6368
-- | Encode any `Generic` data structure into `Json`.
6469
genericEncodeJson :: forall a r. Rep.Generic a r => EncodeRep r => a -> Json
6570
genericEncodeJson = encodeRep <<< Rep.from
71+
72+
-- | A function for encoding `Generic` sum types using string literal representations
73+
encodeLiteralSum :: forall a r. Rep.Generic a r => EncodeLiteral r => a -> Json
74+
encodeLiteralSum = encodeLiteralSumWithTransform id
75+
76+
-- | A function for encoding `Generic` sum types using string literal representations
77+
-- | Takes a function for transforming the tag name in encoding
78+
encodeLiteralSumWithTransform :: forall a r. Rep.Generic a r => EncodeLiteral r => (String -> String) -> a -> Json
79+
encodeLiteralSumWithTransform tagNameTransform = encodeLiteral tagNameTransform <<< Rep.from
80+
81+
class EncodeLiteral r where
82+
encodeLiteral :: (String -> String) -> r -> Json
83+
84+
instance encodeLiteralSumInst :: (EncodeLiteral a, EncodeLiteral b) => EncodeLiteral (Rep.Sum a b) where
85+
encodeLiteral tagNameTransform (Rep.Inl a) = encodeLiteral tagNameTransform a
86+
encodeLiteral tagNameTransform (Rep.Inr b) = encodeLiteral tagNameTransform b
87+
88+
instance encodeLiteralConstructor :: (IsSymbol name) => EncodeLiteral (Rep.Constructor name (Rep.NoArguments)) where
89+
encodeLiteral tagNameTransform _ = fromString <<< tagNameTransform $ reflectSymbol (SProxy :: SProxy name)
90+
91+
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."""
92+
93+
instance encodeLiteralConstructorCannotBeProduct
94+
:: Fail FailMessage
95+
=> EncodeLiteral (Rep.Product a b) where
96+
encodeLiteral _ _ = unsafeCrashWith "unreachable encodeLiteral was reached."

‎test/Main.purs

Lines changed: 46 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -8,12 +8,15 @@ import Control.Monad.Eff (Eff)
88
import Control.Monad.Eff.Console (CONSOLE, log)
99
import Data.Argonaut.Core (stringify)
1010
import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
11-
import Data.Argonaut.Decode.Generic.Rep (genericDecodeJson)
11+
import Data.Argonaut.Decode.Generic.Rep (class DecodeLiteral, decodeLiteralSumWithTransform, genericDecodeJson)
1212
import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
13-
import Data.Argonaut.Encode.Generic.Rep (genericEncodeJson)
14-
import Data.Either (Either(..))
13+
import Data.Argonaut.Encode.Generic.Rep (class EncodeLiteral, encodeLiteralSumWithTransform, genericEncodeJson)
14+
import Data.Argonaut.Parser (jsonParser)
15+
import Data.Either (Either(..), fromRight)
1516
import Data.Generic.Rep (class Generic)
1617
import Data.Generic.Rep.Show (genericShow)
18+
import Data.String (toLower, toUpper)
19+
import Partial.Unsafe (unsafePartial)
1720
import Test.Assert (ASSERT, assert)
1821

1922
data Example
@@ -30,13 +33,33 @@ instance encodeJsonExample :: EncodeJson Example where
3033
instance decodeJson :: DecodeJson Example where
3134
decodeJson a = genericDecodeJson a
3235

36+
data LiteralStringExample
37+
= Apple
38+
| Banana
39+
| Frikandel
40+
41+
derive instance eqLiteralStringExample :: Eq LiteralStringExample
42+
derive instance genericLiteralStringExample :: Generic LiteralStringExample _
43+
instance showLiteralStringExample :: Show LiteralStringExample where
44+
show a = genericShow a
45+
instance encodeJsonLiteralStringExample :: EncodeJson LiteralStringExample where
46+
encodeJson a = encodeLiteralSumWithTransform id a
47+
instance decodeJsonLiteralStringExample :: DecodeJson LiteralStringExample where
48+
decodeJson a = decodeLiteralSumWithTransform id a
49+
3350
main :: forall eff. Eff (assert :: ASSERT, console :: CONSOLE | eff) Unit
3451
main = do
3552
example $ Either $ Left "foo"
3653
example $ Either $ Right $ Either $ Left "foo"
3754
example $ Record {foo: 42, bar: "bar"}
3855
example $ Product 1 2 $ Either $ Left "foo"
56+
example $ Frikandel
57+
testLiteralSumWithTransform id Frikandel "\"Frikandel\""
58+
testLiteralSumWithTransform toUpper Frikandel "\"FRIKANDEL\""
59+
testLiteralSumWithTransform toLower Frikandel "\"frikandel\""
60+
3961
where
62+
example :: forall a. Show a => Eq a => EncodeJson a => DecodeJson a => a -> Eff _ Unit
4063
example original = do
4164
let json = encodeJson original
4265
let parsed = decodeJson json
@@ -45,3 +68,23 @@ main = do
4568
log $ "From JSON: " <> show parsed
4669
assert $ parsed == Right original
4770
log $ "--------------------------------------------------------------------------------"
71+
testLiteralSumWithTransform :: forall a rep
72+
. Show a
73+
=> Eq a
74+
=> Generic a rep
75+
=> EncodeLiteral rep
76+
=> DecodeLiteral rep
77+
=> (String -> String)
78+
-> a
79+
-> String
80+
-> Eff _ Unit
81+
testLiteralSumWithTransform tagNameTransform original string = do
82+
let json = encodeLiteralSumWithTransform tagNameTransform original
83+
let parsed = decodeLiteralSumWithTransform tagNameTransform json
84+
let parsed' = decodeLiteralSumWithTransform tagNameTransform <<< unsafePartial fromRight $ jsonParser string
85+
log $ "Original: " <> show original
86+
log $ "To JSON: " <> stringify json
87+
log $ "From JSON: " <> show parsed
88+
assert $ parsed == Right original
89+
assert $ parsed' == Right original
90+
log $ "--------------------------------------------------------------------------------"

0 commit comments

Comments
 (0)