-
Notifications
You must be signed in to change notification settings - Fork 2
/
Variant.purs
197 lines (172 loc) · 5.76 KB
/
Variant.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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
module Yoga.JSON.Variant where
import Prelude
import Control.Alt ((<|>))
import Data.Newtype (class Newtype)
import Data.Symbol (class IsSymbol, reflectSymbol)
import Data.Tuple.Nested ((/\))
import Data.Variant (Variant, inj, on)
import Foreign (F, Foreign, ForeignError(..), fail)
import Foreign.Index (readProp)
import Foreign.Object as Object
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, RowList)
import Type.Proxy (Proxy(..))
import Yoga.JSON (class ReadForeign, class WriteForeign, readImpl, writeImpl)
newtype TaggedVariant ∷ Symbol → Symbol → Row Type → Type
newtype TaggedVariant tt vt v = TaggedVariant (Variant v)
instance Newtype (TaggedVariant tt vt v) (Variant v)
derive newtype instance (Show (Variant v)) => Show (TaggedVariant tt vt v)
derive newtype instance (Eq (Variant v)) => Eq (TaggedVariant tt vt v)
instance
( RowToList row rl
, WriteForeignTaggedVariant rl row
, IsSymbol typeTag
, IsSymbol valueTag
) ⇒
WriteForeign (TaggedVariant typeTag valueTag row) where
writeImpl (TaggedVariant variant) =
writeVariantImpl
(reflectSymbol (Proxy ∷ Proxy typeTag))
(reflectSymbol (Proxy ∷ Proxy valueTag))
(Proxy ∷ Proxy rl)
variant
class
WriteForeignTaggedVariant (rl ∷ RowList Type) (row ∷ Row Type)
| rl → row where
writeVariantImpl ∷ ∀ g. String → String → g rl → Variant row → Foreign
instance
WriteForeignTaggedVariant Nil () where
writeVariantImpl _ _ _ _ =
-- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
unsafeCrashWith "Attempted to write empty Variant"
instance
( IsSymbol name
, WriteForeign ty
, Row.Cons name ty subRow row
, WriteForeignTaggedVariant tail subRow
) ⇒
WriteForeignTaggedVariant (Cons name ty tail) row where
writeVariantImpl typeTag valueTag _ variant =
on
namep
writeVariant
(writeVariantImpl typeTag valueTag (Proxy ∷ Proxy tail))
variant
where
namep = Proxy ∷ Proxy name
name = reflectSymbol namep
writeVariant value = writeImpl $
Object.fromFoldable
[ valueTag /\ (writeImpl value)
, typeTag /\ (writeImpl name)
]
instance
( RowToList variants rl
, ReadForeignTaggedVariant typeTag valueTag rl variants
, IsSymbol typeTag
, IsSymbol valueTag
) ⇒
ReadForeign (TaggedVariant typeTag valueTag variants) where
readImpl o = readVariantImpl (Proxy ∷ Proxy rl) o
class
ReadForeignTaggedVariant typeTag valueTag (xs ∷ RowList Type) (row ∷ Row Type)
| xs → row where
readVariantImpl ∷
Proxy xs →
Foreign →
F (TaggedVariant typeTag valueTag row)
instance
ReadForeignTaggedVariant typeTag valueTag Nil trash where
readVariantImpl __ _ = fail $ ForeignError
"Unable to match any variant member."
instance
( IsSymbol name
, IsSymbol typeTag
, IsSymbol valueTag
, ReadForeign ty
, Row.Cons name ty trash row
, ReadForeignTaggedVariant typeTag valueTag tail row
) ⇒
ReadForeignTaggedVariant typeTag valueTag (Cons name ty tail) row where
readVariantImpl _ o = readVariantImpl (Proxy ∷ Proxy tail) o <|> do
type_ ← readProp typeTag o >>= readImpl
if type_ == name then do
value :: ty <- readProp valueTag o >>= readImpl
pure $ TaggedVariant (inj namep value)
else
(fail <<< ForeignError $ "Did not match variant tag " <> name)
where
typeTag = reflectSymbol (Proxy ∷ Proxy typeTag)
valueTag = reflectSymbol (Proxy ∷ Proxy valueTag)
namep = Proxy ∷ Proxy name
name = reflectSymbol namep
-- Untagged Variant
newtype UntaggedVariant ∷ Row Type → Type
newtype UntaggedVariant v = UntaggedVariant (Variant v)
instance Newtype (UntaggedVariant v) (Variant v)
derive newtype instance (Show (Variant v)) => Show (UntaggedVariant v)
derive newtype instance (Eq (Variant v)) => Eq (UntaggedVariant v)
instance
( RowToList row rl
, WriteForeignUntaggedVariant rl row
) ⇒
WriteForeign (UntaggedVariant row) where
writeImpl (UntaggedVariant variant) =
writeUntaggedVariantImpl
(Proxy ∷ Proxy rl)
variant
class
WriteForeignUntaggedVariant (rl ∷ RowList Type) (row ∷ Row Type)
| rl → row where
writeUntaggedVariantImpl ∷ ∀ g. g rl → Variant row → Foreign
instance
WriteForeignUntaggedVariant Nil () where
writeUntaggedVariantImpl _ _ =
-- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
unsafeCrashWith "Attempted to write empty Variant"
instance
( IsSymbol name
, WriteForeign ty
, Row.Cons name ty subRow row
, WriteForeignUntaggedVariant tail subRow
) ⇒
WriteForeignUntaggedVariant (Cons name ty tail) row where
writeUntaggedVariantImpl _ variant =
on
namep
writeImpl
(writeUntaggedVariantImpl (Proxy ∷ Proxy tail))
variant
where
namep = Proxy ∷ Proxy name
instance
( RowToList variants rl
, ReadForeignUntaggedVariant rl variants
) ⇒
ReadForeign (UntaggedVariant variants) where
readImpl o = readUntaggedVariantImpl (Proxy ∷ Proxy rl) o
class
ReadForeignUntaggedVariant (xs ∷ RowList Type) (row ∷ Row Type)
| xs → row where
readUntaggedVariantImpl ∷
Proxy xs →
Foreign →
F (UntaggedVariant row)
instance
ReadForeignUntaggedVariant Nil trash where
readUntaggedVariantImpl _ _ = fail $ ForeignError
"Unable to match any variant member."
instance
( IsSymbol name
, ReadForeign ty
, Row.Cons name ty trash row
, ReadForeignUntaggedVariant tail row
) ⇒
ReadForeignUntaggedVariant (Cons name ty tail) row where
readUntaggedVariantImpl _ o =
readUntaggedVariantImpl (Proxy ∷ Proxy tail) o <|> ado
v <- readImpl o
in UntaggedVariant (inj namep v)
where
namep = Proxy ∷ Proxy name