/
Rep.purs
118 lines (96 loc) · 5.42 KB
/
Rep.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
module Data.Argonaut.Decode.Generic.Rep (
class DecodeRep,
class DecodeRepArgs,
class DecodeLiteral,
decodeRep,
decodeRepWith,
decodeRepArgs,
genericDecodeJson,
genericDecodeJsonWith,
decodeLiteralSum,
decodeLiteralSumWithTransform,
decodeLiteral
) where
import Prelude
import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
import Control.Alt ((<|>))
import Data.Argonaut.Core (Json, toArray, toObject, toString)
import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
import Data.Array (uncons)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Generic.Rep as Rep
import Data.Maybe (Maybe, maybe)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Foreign.Object as FO
import Partial.Unsafe (unsafeCrashWith)
import Prim.TypeError (class Fail, Text)
class DecodeRep r where
decodeRepWith :: Encoding -> Json -> Either String r
decodeRep :: forall r. DecodeRep r => Json -> Either String r
decodeRep = decodeRepWith defaultEncoding
instance decodeRepNoConstructors :: DecodeRep Rep.NoConstructors where
decodeRepWith e _ = Left "Cannot decode empty data type"
instance decodeRepSum :: (DecodeRep a, DecodeRep b) => DecodeRep (Rep.Sum a b) where
decodeRepWith e j = Rep.Inl <$> decodeRepWith e j <|> Rep.Inr <$> decodeRepWith e j
instance decodeRepConstructor :: (IsSymbol name, DecodeRepArgs a) => DecodeRep (Rep.Constructor name a) where
decodeRepWith e j = do
let name = reflectSymbol (SProxy :: SProxy name)
let decodingErr msg = "When decoding a " <> name <> ": " <> msg
jObj <- mFail (decodingErr "expected an object") (toObject j)
jTag <- mFail (decodingErr $ "'" <> e.tagKey <> "' property is missing") (FO.lookup e.tagKey jObj)
tag <- mFail (decodingErr $ "'" <> e.tagKey <> "' property is not a string") (toString jTag)
when (tag /= name) $
Left $ decodingErr $ "'" <> e.tagKey <> "' property has an incorrect value"
jValues <- mFail (decodingErr $ "'" <> e.valuesKey <> "' property is missing") (FO.lookup e.valuesKey jObj)
values <- mFail (decodingErr $ "'" <> e.valuesKey <> "' property is not an array") (toArray jValues)
{init, rest} <- lmap decodingErr $ decodeRepArgs values
when (rest /= []) $
Left $ decodingErr $ "'" <> e.valuesKey <> "' property had too many values"
pure $ Rep.Constructor init
class DecodeRepArgs r where
decodeRepArgs :: Array Json -> Either String {init :: r, rest :: Array Json}
instance decodeRepArgsNoArguments :: DecodeRepArgs Rep.NoArguments where
decodeRepArgs js = Right {init: Rep.NoArguments, rest: js}
instance decodeRepArgsProduct :: (DecodeRepArgs a, DecodeRepArgs b) => DecodeRepArgs (Rep.Product a b) where
decodeRepArgs js = do
{init: a, rest: js'} <- decodeRepArgs js
{init: b, rest: js''} <- decodeRepArgs js'
pure {init: Rep.Product a b, rest: js''}
instance decodeRepArgsArgument :: (DecodeJson a) => DecodeRepArgs (Rep.Argument a) where
decodeRepArgs js = do
{head, tail} <- mFail "too few values were present" (uncons js)
{init: _, rest: tail} <<< Rep.Argument <$> decodeJson head
-- | Decode `Json` representation of a value which has a `Generic` type.
genericDecodeJson :: forall a r. Rep.Generic a r => DecodeRep r => Json -> Either String a
genericDecodeJson = genericDecodeJsonWith defaultEncoding
-- | Decode `Json` representation of a value which has a `Generic` type.
genericDecodeJsonWith :: forall a r. Rep.Generic a r => DecodeRep r => Encoding -> Json -> Either String a
genericDecodeJsonWith e = map Rep.to <<< decodeRepWith e
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 identity
-- | 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 =
Text "`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."