@@ -1,438 +0,0 @@
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