@@ -0,0 +1,438 @@
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+
14+, class ReadForeign
15+, readImpl
16+, class ReadTuple
17+, readTupleImpl
18+, tupleSize
19+, class ReadForeignFields
20+, getFields
21+, class ReadForeignVariant
22+, readVariantImpl
23+
24+, class WriteForeign
25+, writeImpl
26+, class WriteForeignFields
27+, writeImplFields
28+, class WriteForeignVariant
29+, writeVariantImpl
30+
31+) where
32+
33+import Prelude
34+
35+import Control.Alt ((<|>))
36+import Control.Apply (lift2)
37+import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, throwError, withExcept)
38+import Data.Array as Array
39+import Data.Array.NonEmpty (NonEmptyArray, fromArray, toArray)
40+import Data.Bifunctor (lmap)
41+import Data.Either (Either(..), hush, note)
42+import Data.Identity (Identity(..))
43+import Data.List.NonEmpty (singleton)
44+import Data.Maybe (Maybe(..), fromMaybe, maybe)
45+import Data.Nullable (Nullable, toMaybe, toNullable)
46+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
47+import Data.Traversable (sequence, traverse)
48+import Data.TraversableWithIndex (traverseWithIndex)
49+import Data.Tuple (Tuple(..))
50+import Data.Variant (Variant, inj, on)
51+import Effect.Exception (message, try)
52+import Effect.Uncurried as EU
53+import Effect.Unsafe (unsafePerformEffect)
54+import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
55+import Foreign.Index (readProp)
56+import Foreign.Object (Object)
57+import Foreign.Object as Object
58+import Global.Unsafe (unsafeStringify)
59+import Partial.Unsafe (unsafeCrashWith)
60+import Prim.Row as Row
61+import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
62+import Record (get)
63+import Record.Builder (Builder)
64+import Record.Builder as Builder
65+import Type.Prelude (RLProxy(..))
66+import Type.Proxy (Proxy(..))
67+
68+-- | An alias for the Either result of decoding
69+type E a = Either MultipleErrors a
70+
71+-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
72+-- | parsing failed.
73+readJSON :: forall a
74+ . ReadForeign a
75+ => String
76+ -> E a
77+readJSON = runExcept <<< (readImpl <=< parseJSON)
78+
79+-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
80+readJSON' :: forall a
81+ . ReadForeign a
82+ => String
83+ -> F a
84+readJSON' = readImpl <=< parseJSON
85+
86+-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
87+-- | failed.
88+readJSON_ :: forall a
89+ . ReadForeign a
90+ => String
91+ -> Maybe a
92+readJSON_ = hush <<< readJSON
93+
94+-- | Write a JSON string from a type `a`.
95+writeJSON :: forall a
96+ . WriteForeign a
97+ => a
98+ -> String
99+writeJSON = unsafeStringify <<< writeImpl
100+
101+write :: forall a
102+ . WriteForeign a
103+ => a
104+ -> Foreign
105+write = writeImpl
106+
107+-- | Read a Foreign value to a type
108+read :: forall a
109+ . ReadForeign a
110+ => Foreign
111+ -> E a
112+read = runExcept <<< readImpl
113+
114+-- | Read a value of any type as Foreign to a type
115+readAsForeign :: forall a b
116+ . ReadForeign a
117+ => b
118+ -> E a
119+readAsForeign = read <<< unsafeToForeign
120+
121+read' :: forall a
122+ . ReadForeign a
123+ => Foreign
124+ -> F a
125+read' = readImpl
126+
127+-- | Read a Foreign value to a type, as a Maybe of type
128+read_ :: forall a
129+ . ReadForeign a
130+ => Foreign
131+ -> Maybe a
132+read_ = hush <<< read
133+
134+foreign import _parseJSON :: EU.EffectFn1 String Foreign
135+
136+parseJSON :: String -> F Foreign
137+parseJSON
138+ = ExceptT
139+ <<< Identity
140+ <<< lmap (pure <<< ForeignError <<< message)
141+ <<< runPure
142+ <<< try
143+ <<< EU.runEffectFn1 _parseJSON
144+ where
145+ -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
146+ runPure = unsafePerformEffect
147+
148+foreign import _undefined :: Foreign
149+
150+undefined :: Foreign
151+undefined = _undefined
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+
178+instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
179+ readImpl = readNullOrUndefined readImpl
180+ where
181+ readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
182+ readNullOrUndefined f value = Just <$> f value
183+
184+instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
185+ readImpl o = withExcept (map reformat) $
186+ map toNullable <$> traverse readImpl =<< readNull o
187+ where
188+ reformat error = case error of
189+ TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
190+ _ -> error
191+
192+instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
193+ readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
194+ where
195+ readObject' :: Foreign -> F (Object Foreign)
196+ readObject' value
197+ | tagOf value == "Object" = pure $ unsafeFromForeign value
198+ | otherwise = fail $ TypeMismatch "Object" (tagOf value)
199+
200+instance readTuple :: ReadTuple (Tuple a b) => ReadForeign (Tuple a b) where
201+ readImpl = readTupleImpl 0
202+
203+-- | A class for reading JSON arrays of lenth `n` as nested tuples of size `n`
204+class ReadTuple a where
205+ readTupleImpl :: Int -> Foreign -> F a
206+ tupleSize :: Proxy a -> Int
207+
208+instance readTupleNestedHelper :: (ReadForeign a, ReadTuple (Tuple b c)) => ReadTuple (Tuple a (Tuple b c)) where
209+ readTupleImpl n =
210+ readImpl
211+ >=> case _ of
212+ arr -> case Array.uncons arr of
213+ Just { head, tail } ->
214+ lift2 Tuple
215+ (readAtIdx n head)
216+ (readTupleImpl (n + 1) $ writeImpl tail)
217+ _ -> throwError $ pure $ TypeMismatch
218+ ("array of length " <> show (1 + n + tupleSize (Proxy :: Proxy (Tuple b c))))
219+ ("array of length " <> show n)
220+ tupleSize _ = 1 + tupleSize (Proxy :: Proxy (Tuple b c))
221+else instance readTupleHelper :: (ReadForeign a, ReadForeign b) => ReadTuple (Tuple a b) where
222+ readTupleImpl n =
223+ readImpl
224+ >=> case _ of
225+ [ a, b ] ->
226+ lift2 Tuple (readAtIdx n a) (readAtIdx (n + 1) b)
227+ arr -> throwError $ pure $ TypeMismatch
228+ ("array of length " <> show (n + 2) )
229+ ("array of length " <> show (n + Array.length arr))
230+
231+ tupleSize = const 2
232+
233+instance readRecord ::
234+ ( RowToList fields fieldList
235+ , ReadForeignFields fieldList () fields
236+ ) => ReadForeign (Record fields) where
237+ readImpl o = flip Builder.build {} <$> getFields fieldListP o
238+ where
239+ fieldListP = RLProxy :: RLProxy fieldList
240+
241+-- | A class for reading foreign values from properties
242+class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
243+ | xs -> from to where
244+ getFields :: RLProxy xs
245+ -> Foreign
246+ -> F (Builder (Record from) (Record to))
247+
248+instance readFieldsCons ::
249+ ( IsSymbol name
250+ , ReadForeign ty
251+ , ReadForeignFields tail from from'
252+ , Row.Lacks name from'
253+ , Row.Cons name ty from' to
254+ ) => ReadForeignFields (Cons name ty tail) from to where
255+ getFields _ obj = (compose <$> first) `exceptTApply` rest
256+ where
257+ first = do
258+ value <- withExcept' (readImpl =<< readProp name obj)
259+ pure $ Builder.insert nameP value
260+ rest = getFields tailP obj
261+ nameP = SProxy :: SProxy name
262+ tailP = RLProxy :: RLProxy tail
263+ name = reflectSymbol nameP
264+ withExcept' = withExcept <<< map $ ErrorAtProperty name
265+
266+readAtIdx :: ∀ a. ReadForeign a => Int -> Foreign -> F a
267+readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)
268+
269+exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
270+exceptTApply fun a = ExceptT $ applyEither
271+ <$> runExceptT fun
272+ <*> runExceptT a
273+
274+applyEither :: forall e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
275+applyEither (Left e) (Right _) = Left e
276+applyEither (Left e1) (Left e2) = Left (e1 <> e2)
277+applyEither (Right _) (Left e) = Left e
278+applyEither (Right fun) (Right a) = Right (fun a)
279+
280+instance readFieldsNil ::
281+ ReadForeignFields Nil () () where
282+ getFields _ _ =
283+ pure identity
284+
285+instance readForeignVariant ::
286+ ( RowToList variants rl
287+ , ReadForeignVariant rl variants
288+ ) => ReadForeign (Variant variants) where
289+ readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o
290+
291+class ReadForeignVariant (xs :: RowList) (row :: # Type)
292+ | xs -> row where
293+ readVariantImpl :: RLProxy xs
294+ -> Foreign
295+ -> F (Variant row)
296+
297+instance readVariantNil ::
298+ ReadForeignVariant Nil trash where
299+ readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."
300+
301+instance readVariantCons ::
302+ ( IsSymbol name
303+ , ReadForeign ty
304+ , Row.Cons name ty trash row
305+ , ReadForeignVariant tail row
306+ ) => ReadForeignVariant (Cons name ty tail) row where
307+ readVariantImpl _ o = do
308+ obj :: { type :: String, value :: Foreign } <- readImpl o
309+ if obj.type == name
310+ then do
311+ value :: ty <- readImpl obj.value
312+ pure $ inj namep value
313+ else
314+ (fail <<< ForeignError $ "Did not match variant tag " <> name)
315+ <|> readVariantImpl (RLProxy :: RLProxy tail) o
316+ where
317+ namep = SProxy :: SProxy name
318+ name = reflectSymbol namep
319+
320+-- -- | A class for writing a value into JSON
321+-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
322+class WriteForeign a where
323+ writeImpl :: a -> Foreign
324+
325+instance writeForeignForeign :: WriteForeign Foreign where
326+ writeImpl = identity
327+
328+instance writeForeignString :: WriteForeign String where
329+ writeImpl = unsafeToForeign
330+
331+instance writeForeignInt :: WriteForeign Int where
332+ writeImpl = unsafeToForeign
333+
334+instance writeForeignChar :: WriteForeign Char where
335+ writeImpl = unsafeToForeign
336+
337+instance writeForeignNumber :: WriteForeign Number where
338+ writeImpl = unsafeToForeign
339+
340+instance writeForeignBoolean :: WriteForeign Boolean where
341+ writeImpl = unsafeToForeign
342+
343+instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
344+ writeImpl xs = unsafeToForeign $ writeImpl <$> xs
345+
346+instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
347+ writeImpl = maybe undefined writeImpl
348+
349+instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
350+ writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe
351+
352+instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
353+ writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)
354+
355+instance writeForeignTupleNested :: (WriteForeign a, WriteForeign (Tuple b c)) => WriteForeign (Tuple a (Tuple b c)) where
356+ writeImpl (Tuple a bc) =
357+ writeImpl bc
358+ # read_
359+ # fromMaybe []
360+ # Array.cons (writeImpl a)
361+ # writeImpl
362+else instance writeForeignTuple :: (WriteForeign a, WriteForeign b) => WriteForeign (Tuple a b) where
363+ writeImpl (Tuple a b) = writeImpl [ writeImpl a, writeImpl b ]
364+
365+instance recordWriteForeign ::
366+ ( RowToList row rl
367+ , WriteForeignFields rl row () to
368+ ) => WriteForeign (Record row) where
369+ writeImpl rec = unsafeToForeign $ Builder.build steps {}
370+ where
371+ rlp = RLProxy :: RLProxy rl
372+ steps = writeImplFields rlp rec
373+
374+class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
375+ | rl -> row from to where
376+ writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)
377+
378+instance consWriteForeignFields ::
379+ ( IsSymbol name
380+ , WriteForeign ty
381+ , WriteForeignFields tail row from from'
382+ , Row.Cons name ty whatever row
383+ , Row.Lacks name from'
384+ , Row.Cons name Foreign from' to
385+ ) => WriteForeignFields (Cons name ty tail) row from to where
386+ writeImplFields _ rec = result
387+ where
388+ namep = SProxy :: SProxy name
389+ value = writeImpl $ get namep rec
390+ tailp = RLProxy :: RLProxy tail
391+ rest = writeImplFields tailp rec
392+ result = Builder.insert namep value <<< rest
393+instance nilWriteForeignFields ::
394+ WriteForeignFields Nil row () () where
395+ writeImplFields _ _ = identity
396+
397+instance writeForeignVariant ::
398+ ( RowToList row rl
399+ , WriteForeignVariant rl row
400+ ) => WriteForeign (Variant row) where
401+ writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant
402+
403+class WriteForeignVariant (rl :: RowList) (row :: # Type)
404+ | rl -> row where
405+ writeVariantImpl :: forall g. g rl -> Variant row -> Foreign
406+
407+instance nilWriteForeignVariant ::
408+ WriteForeignVariant Nil () where
409+ writeVariantImpl _ _ =
410+ -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
411+ unsafeCrashWith "Variant was not able to be writen row WriteForeign."
412+
413+instance consWriteForeignVariant ::
414+ ( IsSymbol name
415+ , WriteForeign ty
416+ , Row.Cons name ty subRow row
417+ , WriteForeignVariant tail subRow
418+ ) => WriteForeignVariant (Cons name ty tail) row where
419+ writeVariantImpl _ variant =
420+ on
421+ namep
422+ writeVariant
423+ (writeVariantImpl (RLProxy :: RLProxy tail))
424+ variant
425+ where
426+ namep = SProxy :: SProxy name
427+ writeVariant value = unsafeToForeign
428+ { type: reflectSymbol namep
429+ , value: writeImpl value
430+ }
431+
432+instance readForeignNEArray :: ReadForeign a => ReadForeign (NonEmptyArray a) where
433+ readImpl f = do
434+ raw :: Array a <- readImpl f
435+ except $ note (singleton $ ForeignError "Nonempty array expected, got empty array") $ fromArray raw
436+
437+instance writeForeignNEArray :: WriteForeign a => WriteForeign (NonEmptyArray a) where
438+ writeImpl a = writeImpl <<< toArray $ a