git.iko.soy/rowtype-yoga/psfp
on 110e143 help sign in
rowtype-yoga/psfp/components/src/Simple/JSON.purs
421 lines 12 kB history raw
1module Simple.JSON
2 ( E
3 , readJSON
4 , readJSON'
5 , readJSON_
6 , writeJSON
7 , write
8 , read
9 , read'
10 , read_
11 , parseJSON
12 , undefined
13 , class ReadForeign
14 , readImpl
15 , class ReadForeignFields
16 , getFields
17 , class ReadForeignVariant
18 , readVariantImpl
19 , class WriteForeign
20 , writeImpl
21 , class WriteForeignFields
22 , writeImplFields
23 , class WriteForeignVariant
24 , writeVariantImpl
25 ) where
27import Prelude
28import Control.Alt ((<|>))
29import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, withExcept)
30import Data.Array.NonEmpty (NonEmptyArray, fromArray, toArray)
31import Data.Bifunctor (lmap)
32import Data.Either (Either(..), hush, note)
33import Data.Identity (Identity(..))
34import Data.List.NonEmpty (singleton)
35import Data.Maybe (Maybe(..), maybe)
36import Data.Nullable (Nullable, toMaybe, toNullable)
37import Data.Symbol (class IsSymbol, reflectSymbol)
38import Data.Traversable (sequence, traverse)
39import Data.TraversableWithIndex (traverseWithIndex)
40import Data.Variant (Variant, inj, on)
41import Effect.Exception (message, try)
42import Effect.Uncurried as EU
43import Effect.Unsafe (unsafePerformEffect)
44import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
45import Foreign.Index (readProp)
46import Foreign.Object (Object)
47import Foreign.Object as Object
48import Partial.Unsafe (unsafeCrashWith)
49import Prim.Row as Row
50import Prim.RowList (class RowToList, Cons, Nil, RowList)
51import Record (get)
52import Record.Builder (Builder)
53import Record.Builder as Builder
54import Type.Prelude (Proxy(..))
56-- | An alias for the Either result of decoding
57type E a =
58 Either MultipleErrors a
60-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
61-- | parsing failed.
62readJSON ∷
63 ∀ a.
64 ReadForeign a =>
65 String ->
66 E a
67readJSON = runExcept <<< (readImpl <=< parseJSON)
69-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
70readJSON' ∷
71 ∀ a.
72 ReadForeign a =>
73 String ->
74 F a
75readJSON' = readImpl <=< parseJSON
77-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
78-- | failed.
79readJSON_ ∷
80 ∀ a.
81 ReadForeign a =>
82 String ->
83 Maybe a
84readJSON_ = hush <<< readJSON
86-- | Write a JSON string from a type `a`.
87writeJSON ∷
88 ∀ a.
89 WriteForeign a =>
90 a ->
91 String
92writeJSON = unsafeStringify <<< writeImpl
94write ∷
95 ∀ a.
96 WriteForeign a =>
97 a ->
98 Foreign
99write = writeImpl
101-- | Read a Foreign value to a type
102read ∷
103 ∀ a.
104 ReadForeign a =>
105 Foreign ->
106 E a
107read = runExcept <<< readImpl
109-- | Read a value of any type as Foreign to a type
110readAsForeign ∷
111 ∀ a b.
112 ReadForeign a =>
113 b ->
114 E a
115readAsForeign = read <<< unsafeToForeign
117read' ∷
118 ∀ a.
119 ReadForeign a =>
120 Foreign ->
121 F a
122read' = readImpl
124-- | Read a Foreign value to a type, as a Maybe of type
125read_ ∷
126 ∀ a.
127 ReadForeign a =>
128 Foreign ->
129 Maybe a
130read_ = hush <<< read
132foreign import _parseJSON ∷ EU.EffectFn1 String Foreign
134parseJSON ∷ String -> F Foreign
135parseJSON =
136 ExceptT
137 <<< Identity
138 <<< lmap (pure <<< ForeignError <<< message)
139 <<< runPure
140 <<< try
141 <<< EU.runEffectFn1 _parseJSON
142 where
143 -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
144 runPure = unsafePerformEffect
146foreign import _undefined ∷ Foreign
148undefined ∷ Foreign
149undefined = _undefined
151foreign import unsafeStringify ∷ ∀ a. a -> String
153-- | A class for reading foreign values to a type
154class ReadForeign a where
155 readImpl ∷ Foreign -> F a
157instance readForeign ∷ ReadForeign Foreign where
158 readImpl = pure
160instance readChar ∷ ReadForeign Char where
161 readImpl = readChar
163instance readNumber ∷ ReadForeign Number where
164 readImpl = readNumber
166instance readInt ∷ ReadForeign Int where
167 readImpl = readInt
169instance readString ∷ ReadForeign String where
170 readImpl = readString
172instance readBoolean ∷ ReadForeign Boolean where
173 readImpl = readBoolean
175instance readArray ∷ ReadForeign a => ReadForeign (Array a) where
176 readImpl = traverseWithIndex readAtIdx <=< readArray
177 where
178 readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)
180instance readMaybe ∷ ReadForeign a => ReadForeign (Maybe a) where
181 readImpl = readNullOrUndefined readImpl
182 where
183 readNullOrUndefined _ value
184 | isNull value || isUndefined value = pure Nothing
186 readNullOrUndefined f value = Just <$> f value
188instance readNullable ∷ ReadForeign a => ReadForeign (Nullable a) where
189 readImpl o =
190 withExcept (map reformat)
191 $ map toNullable
192 <$> traverse readImpl
193 =<< readNull o
194 where
195 reformat error = case error of
196 TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
197 _ -> error
199instance readObject ∷ ReadForeign a => ReadForeign (Object.Object a) where
200 readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
201 where
202 readObject' ∷ Foreign -> F (Object Foreign)
203 readObject' value
204 | tagOf value == "Object" = pure $ unsafeFromForeign value
205 | otherwise = fail $ TypeMismatch "Object" (tagOf value)
207instance readRecord ∷
208 ( RowToList fields fieldList
209 , ReadForeignFields fieldList () fields
210 ) =>
211 ReadForeign (Record fields) where
212 readImpl o = flip Builder.build {} <$> getFields fieldListP o
213 where
214 fieldListP = Proxy ∷ Proxy fieldList
216-- | A class for reading foreign values from properties
217class ReadForeignFields (xs ∷ RowList Type) (from ∷ Row Type) (to ∷ Row Type) | xs -> from to where
218 getFields ∷
219 Proxy xs ->
220 Foreign ->
221 F (Builder (Record from) (Record to))
223instance readFieldsCons ∷
224 ( IsSymbol name
225 , ReadForeign ty
226 , ReadForeignFields tail from from'
227 , Row.Lacks name from'
228 , Row.Cons name ty from' to
229 ) =>
230 ReadForeignFields (Cons name ty tail) from to where
231 getFields _ obj = (compose <$> first) `exceptTApply` rest
232 where
233 first = do
234 value <- withExcept' (readImpl =<< readProp name obj)
235 pure $ Builder.insert nameP value
237 rest = getFields tailP obj
239 nameP = Proxy ∷ Proxy name
241 tailP = Proxy ∷ Proxy tail
243 name = reflectSymbol nameP
245 withExcept' = withExcept <<< map $ ErrorAtProperty name
247exceptTApply ∷ ∀ a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
248exceptTApply fun a =
249 ExceptT $ applyEither
250 <$> runExceptT fun
251 <*> runExceptT a
253applyEither ∷ ∀ e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
254applyEither (Left e) (Right _) = Left e
256applyEither (Left e1) (Left e2) = Left (e1 <> e2)
258applyEither (Right _) (Left e) = Left e
260applyEither (Right fun) (Right a) = Right (fun a)
262instance readFieldsNil ∷
263 ReadForeignFields Nil () () where
264 getFields _ _ = pure identity
266instance readForeignVariant ∷
267 ( RowToList variants rl
268 , ReadForeignVariant rl variants
269 ) =>
270 ReadForeign (Variant variants) where
271 readImpl o = readVariantImpl (Proxy ∷ Proxy rl) o
273class ReadForeignVariant (xs ∷ RowList Type) (row ∷ Row Type) | xs -> row where
274 readVariantImpl ∷
275 Proxy xs ->
276 Foreign ->
277 F (Variant row)
279instance readVariantNil ∷
280 ReadForeignVariant Nil trash where
281 readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."
283instance readVariantCons ∷
284 ( IsSymbol name
285 , ReadForeign ty
286 , Row.Cons name ty trash row
287 , ReadForeignVariant tail row
288 ) =>
289 ReadForeignVariant (Cons name ty tail) row where
290 readVariantImpl _ o =
291 do
292 obj ∷ { type ∷ String, value ∷ Foreign } <- readImpl o
293 if obj.type == name then do
294 value ∷ ty <- readImpl obj.value
295 pure $ inj namep value
296 else
297 (fail <<< ForeignError $ "Did not match variant tag " <> name)
298 <|> readVariantImpl (Proxy ∷ Proxy tail) o
299 where
300 namep = Proxy ∷ Proxy name
302 name = reflectSymbol namep
304-- -- | A class for writing a value into JSON
305-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
306class WriteForeign a where
307 writeImpl ∷ a -> Foreign
309instance writeForeignForeign ∷ WriteForeign Foreign where
310 writeImpl = identity
312instance writeForeignString ∷ WriteForeign String where
313 writeImpl = unsafeToForeign
315instance writeForeignInt ∷ WriteForeign Int where
316 writeImpl = unsafeToForeign
318instance writeForeignChar ∷ WriteForeign Char where
319 writeImpl = unsafeToForeign
321instance writeForeignNumber ∷ WriteForeign Number where
322 writeImpl = unsafeToForeign
324instance writeForeignBoolean ∷ WriteForeign Boolean where
325 writeImpl = unsafeToForeign
327instance writeForeignArray ∷ WriteForeign a => WriteForeign (Array a) where
328 writeImpl xs = unsafeToForeign $ writeImpl <$> xs
330instance writeForeignMaybe ∷ WriteForeign a => WriteForeign (Maybe a) where
331 writeImpl = maybe undefined writeImpl
333instance writeForeignNullable ∷ WriteForeign a => WriteForeign (Nullable a) where
334 writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe
336instance writeForeignObject ∷ WriteForeign a => WriteForeign (Object.Object a) where
337 writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)
339instance recordWriteForeign ∷
340 ( RowToList row rl
341 , WriteForeignFields rl row () to
342 ) =>
343 WriteForeign (Record row) where
344 writeImpl rec = unsafeToForeign $ Builder.build steps {}
345 where
346 rlp = Proxy ∷ Proxy rl
348 steps = writeImplFields rlp rec
350class WriteForeignFields (rl ∷ RowList Type) row (from ∷ Row Type) (to ∷ Row Type) | rl -> row from to where
351 writeImplFields ∷ ∀ g. g rl -> Record row -> Builder (Record from) (Record to)
353instance consWriteForeignFields ∷
354 ( IsSymbol name
355 , WriteForeign ty
356 , WriteForeignFields tail row from from'
357 , Row.Cons name ty whatever row
358 , Row.Lacks name from'
359 , Row.Cons name Foreign from' to
360 ) =>
361 WriteForeignFields (Cons name ty tail) row from to where
362 writeImplFields _ rec = result
363 where
364 namep = Proxy ∷ Proxy name
366 value = writeImpl $ get namep rec
368 tailp = Proxy ∷ Proxy tail
370 rest = writeImplFields tailp rec
372 result = Builder.insert namep value <<< rest
374instance nilWriteForeignFields ∷
375 WriteForeignFields Nil row () () where
376 writeImplFields _ _ = identity
378instance writeForeignVariant ∷
379 ( RowToList row rl
380 , WriteForeignVariant rl row
381 ) =>
382 WriteForeign (Variant row) where
383 writeImpl variant = writeVariantImpl (Proxy ∷ Proxy rl) variant
385class WriteForeignVariant (rl ∷ RowList Type) (row ∷ Row Type) | rl -> row where
386 writeVariantImpl ∷ ∀ g. g rl -> Variant row -> Foreign
388instance nilWriteForeignVariant ∷
389 WriteForeignVariant Nil () where
390 -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
391 writeVariantImpl _ _ = unsafeCrashWith "Variant was not able to be writen row WriteForeign."
393instance consWriteForeignVariant ∷
394 ( IsSymbol name
395 , WriteForeign ty
396 , Row.Cons name ty subRow row
397 , WriteForeignVariant tail subRow
398 ) =>
399 WriteForeignVariant (Cons name ty tail) row where
400 writeVariantImpl _ variant =
401 on
402 namep
403 writeVariant
404 (writeVariantImpl (Proxy ∷ Proxy tail))
405 variant
406 where
407 namep = Proxy ∷ Proxy name
409 writeVariant value =
410 unsafeToForeign
411 { type: reflectSymbol namep
412 , value: writeImpl value
413 }
415instance readForeignNEArray ∷ ReadForeign a => ReadForeign (NonEmptyArray a) where
416 readImpl f = do
417 raw ∷ Array a <- readImpl f
418 except $ note (singleton $ ForeignError "Nonempty array expected, got empty array") $ fromArray raw
420instance writeForeignNEArray ∷ WriteForeign a => WriteForeign (NonEmptyArray a) where
421 writeImpl a = writeImpl <<< toArray $ a