@@ -0,0 +1,421 @@
1+module 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
26+
27+import Prelude
28+import Control.Alt ((<|>))
29+import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, withExcept)
30+import Data.Array.NonEmpty (NonEmptyArray, fromArray, toArray)
31+import Data.Bifunctor (lmap)
32+import Data.Either (Either(..), hush, note)
33+import Data.Identity (Identity(..))
34+import Data.List.NonEmpty (singleton)
35+import Data.Maybe (Maybe(..), maybe)
36+import Data.Nullable (Nullable, toMaybe, toNullable)
37+import Data.Symbol (class IsSymbol, reflectSymbol)
38+import Data.Traversable (sequence, traverse)
39+import Data.TraversableWithIndex (traverseWithIndex)
40+import Data.Variant (Variant, inj, on)
41+import Effect.Exception (message, try)
42+import Effect.Uncurried as EU
43+import Effect.Unsafe (unsafePerformEffect)
44+import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
45+import Foreign.Index (readProp)
46+import Foreign.Object (Object)
47+import Foreign.Object as Object
48+import Partial.Unsafe (unsafeCrashWith)
49+import Prim.Row as Row
50+import Prim.RowList (class RowToList, Cons, Nil, RowList)
51+import Record (get)
52+import Record.Builder (Builder)
53+import Record.Builder as Builder
54+import Type.Prelude (Proxy(..))
55+
56+-- | An alias for the Either result of decoding
57+type E a =
58+ Either MultipleErrors a
59+
60+-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
61+-- | parsing failed.
62+readJSON ∷
63+ ∀ a.
64+ ReadForeign a =>
65+ String ->
66+ E a
67+readJSON = runExcept <<< (readImpl <=< parseJSON)
68+
69+-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
70+readJSON' ∷
71+ ∀ a.
72+ ReadForeign a =>
73+ String ->
74+ F a
75+readJSON' = readImpl <=< parseJSON
76+
77+-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
78+-- | failed.
79+readJSON_ ∷
80+ ∀ a.
81+ ReadForeign a =>
82+ String ->
83+ Maybe a
84+readJSON_ = hush <<< readJSON
85+
86+-- | Write a JSON string from a type `a`.
87+writeJSON ∷
88+ ∀ a.
89+ WriteForeign a =>
90+ a ->
91+ String
92+writeJSON = unsafeStringify <<< writeImpl
93+
94+write ∷
95+ ∀ a.
96+ WriteForeign a =>
97+ a ->
98+ Foreign
99+write = writeImpl
100+
101+-- | Read a Foreign value to a type
102+read ∷
103+ ∀ a.
104+ ReadForeign a =>
105+ Foreign ->
106+ E a
107+read = runExcept <<< readImpl
108+
109+-- | Read a value of any type as Foreign to a type
110+readAsForeign ∷
111+ ∀ a b.
112+ ReadForeign a =>
113+ b ->
114+ E a
115+readAsForeign = read <<< unsafeToForeign
116+
117+read' ∷
118+ ∀ a.
119+ ReadForeign a =>
120+ Foreign ->
121+ F a
122+read' = readImpl
123+
124+-- | Read a Foreign value to a type, as a Maybe of type
125+read_ ∷
126+ ∀ a.
127+ ReadForeign a =>
128+ Foreign ->
129+ Maybe a
130+read_ = hush <<< read
131+
132+foreign import _parseJSON ∷ EU.EffectFn1 String Foreign
133+
134+parseJSON ∷ String -> F Foreign
135+parseJSON =
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
145+
146+foreign import _undefined ∷ Foreign
147+
148+undefined ∷ Foreign
149+undefined = _undefined
150+
151+foreign import unsafeStringify ∷ ∀ a. a -> String
152+
153+-- | A class for reading foreign values to a type
154+class ReadForeign a where
155+ readImpl ∷ Foreign -> F a
156+
157+instance readForeign ∷ ReadForeign Foreign where
158+ readImpl = pure
159+
160+instance readChar ∷ ReadForeign Char where
161+ readImpl = readChar
162+
163+instance readNumber ∷ ReadForeign Number where
164+ readImpl = readNumber
165+
166+instance readInt ∷ ReadForeign Int where
167+ readImpl = readInt
168+
169+instance readString ∷ ReadForeign String where
170+ readImpl = readString
171+
172+instance readBoolean ∷ ReadForeign Boolean where
173+ readImpl = readBoolean
174+
175+instance readArray ∷ ReadForeign a => ReadForeign (Array a) where
176+ readImpl = traverseWithIndex readAtIdx <=< readArray
177+ where
178+ readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)
179+
180+instance readMaybe ∷ ReadForeign a => ReadForeign (Maybe a) where
181+ readImpl = readNullOrUndefined readImpl
182+ where
183+ readNullOrUndefined _ value
184+ | isNull value || isUndefined value = pure Nothing
185+
186+ readNullOrUndefined f value = Just <$> f value
187+
188+instance 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
198+
199+instance 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)
206+
207+instance 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
215+
216+-- | A class for reading foreign values from properties
217+class 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))
222+
223+instance 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
236+
237+ rest = getFields tailP obj
238+
239+ nameP = Proxy ∷ Proxy name
240+
241+ tailP = Proxy ∷ Proxy tail
242+
243+ name = reflectSymbol nameP
244+
245+ withExcept' = withExcept <<< map $ ErrorAtProperty name
246+
247+exceptTApply ∷ ∀ a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
248+exceptTApply fun a =
249+ ExceptT $ applyEither
250+ <$> runExceptT fun
251+ <*> runExceptT a
252+
253+applyEither ∷ ∀ e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
254+applyEither (Left e) (Right _) = Left e
255+
256+applyEither (Left e1) (Left e2) = Left (e1 <> e2)
257+
258+applyEither (Right _) (Left e) = Left e
259+
260+applyEither (Right fun) (Right a) = Right (fun a)
261+
262+instance readFieldsNil ∷
263+ ReadForeignFields Nil () () where
264+ getFields _ _ = pure identity
265+
266+instance readForeignVariant ∷
267+ ( RowToList variants rl
268+ , ReadForeignVariant rl variants
269+ ) =>
270+ ReadForeign (Variant variants) where
271+ readImpl o = readVariantImpl (Proxy ∷ Proxy rl) o
272+
273+class ReadForeignVariant (xs ∷ RowList Type) (row ∷ Row Type) | xs -> row where
274+ readVariantImpl ∷
275+ Proxy xs ->
276+ Foreign ->
277+ F (Variant row)
278+
279+instance readVariantNil ∷
280+ ReadForeignVariant Nil trash where
281+ readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."
282+
283+instance 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
301+
302+ name = reflectSymbol namep
303+
304+-- -- | A class for writing a value into JSON
305+-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
306+class WriteForeign a where
307+ writeImpl ∷ a -> Foreign
308+
309+instance writeForeignForeign ∷ WriteForeign Foreign where
310+ writeImpl = identity
311+
312+instance writeForeignString ∷ WriteForeign String where
313+ writeImpl = unsafeToForeign
314+
315+instance writeForeignInt ∷ WriteForeign Int where
316+ writeImpl = unsafeToForeign
317+
318+instance writeForeignChar ∷ WriteForeign Char where
319+ writeImpl = unsafeToForeign
320+
321+instance writeForeignNumber ∷ WriteForeign Number where
322+ writeImpl = unsafeToForeign
323+
324+instance writeForeignBoolean ∷ WriteForeign Boolean where
325+ writeImpl = unsafeToForeign
326+
327+instance writeForeignArray ∷ WriteForeign a => WriteForeign (Array a) where
328+ writeImpl xs = unsafeToForeign $ writeImpl <$> xs
329+
330+instance writeForeignMaybe ∷ WriteForeign a => WriteForeign (Maybe a) where
331+ writeImpl = maybe undefined writeImpl
332+
333+instance writeForeignNullable ∷ WriteForeign a => WriteForeign (Nullable a) where
334+ writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe
335+
336+instance writeForeignObject ∷ WriteForeign a => WriteForeign (Object.Object a) where
337+ writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)
338+
339+instance 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
347+
348+ steps = writeImplFields rlp rec
349+
350+class 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)
352+
353+instance 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
365+
366+ value = writeImpl $ get namep rec
367+
368+ tailp = Proxy ∷ Proxy tail
369+
370+ rest = writeImplFields tailp rec
371+
372+ result = Builder.insert namep value <<< rest
373+
374+instance nilWriteForeignFields ∷
375+ WriteForeignFields Nil row () () where
376+ writeImplFields _ _ = identity
377+
378+instance writeForeignVariant ∷
379+ ( RowToList row rl
380+ , WriteForeignVariant rl row
381+ ) =>
382+ WriteForeign (Variant row) where
383+ writeImpl variant = writeVariantImpl (Proxy ∷ Proxy rl) variant
384+
385+class WriteForeignVariant (rl ∷ RowList Type) (row ∷ Row Type) | rl -> row where
386+ writeVariantImpl ∷ ∀ g. g rl -> Variant row -> Foreign
387+
388+instance 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."
392+
393+instance 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
408+
409+ writeVariant value =
410+ unsafeToForeign
411+ { type: reflectSymbol namep
412+ , value: writeImpl value
413+ }
414+
415+instance 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
419+
420+instance writeForeignNEArray ∷ WriteForeign a => WriteForeign (NonEmptyArray a) where
421+ writeImpl a = writeImpl <<< toArray $ a