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