@@ -0,0 +1,421 @@
15+ , class ReadForeignFields
17+ , class ReadForeignVariant
21+ , class WriteForeignFields
23+ , class WriteForeignVariant
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)
52+import Record.Builder (Builder)
53+import Record.Builder as Builder
54+import Type.Prelude (Proxy(..))
56+-- | An alias for the Either result of decoding
58+ Either MultipleErrors a
60+-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
67+readJSON = runExcept <<< (readImpl <=< parseJSON)
69+-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
75+readJSON' = readImpl <=< parseJSON
77+-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
84+readJSON_ = hush <<< readJSON
86+-- | Write a JSON string from a type `a`.
92+writeJSON = unsafeStringify <<< writeImpl
101+-- | Read a Foreign value to a type
107+read = runExcept <<< readImpl
109+-- | Read a value of any type as Foreign to a type
115+readAsForeign = read <<< unsafeToForeign
124+-- | Read a Foreign value to a type, as a Maybe of type
130+read_ = hush <<< read
132+foreign import _parseJSON ∷ EU.EffectFn1 String Foreign
134+parseJSON ∷ String -> F Foreign
138+ <<< lmap (pure <<< ForeignError <<< message)
141+ <<< EU.runEffectFn1 _parseJSON
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
146+foreign import _undefined ∷ Foreign
149+undefined = _undefined
151+foreign import unsafeStringify ∷ ∀ a. a -> String
153+-- | A class for reading foreign values to a type
154+class ReadForeign a where
155+ readImpl ∷ Foreign -> F a
157+instance readForeign ∷ ReadForeign Foreign where
160+instance readChar ∷ ReadForeign Char where
163+instance readNumber ∷ ReadForeign Number where
164+ readImpl = readNumber
166+instance readInt ∷ ReadForeign Int where
169+instance readString ∷ ReadForeign String where
170+ readImpl = readString
172+instance readBoolean ∷ ReadForeign Boolean where
173+ readImpl = readBoolean
175+instance readArray ∷ ReadForeign a => ReadForeign (Array a) where
176+ readImpl = traverseWithIndex readAtIdx <=< readArray
178+ readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)
180+instance readMaybe ∷ ReadForeign a => ReadForeign (Maybe a) where
181+ readImpl = readNullOrUndefined readImpl
183+ readNullOrUndefined _ value
184+ | isNull value || isUndefined value = pure Nothing
186+ readNullOrUndefined f value = Just <$> f value
188+instance readNullable ∷ ReadForeign a => ReadForeign (Nullable a) where
190+ withExcept (map reformat)
192+ <$> traverse readImpl
195+ reformat error = case error of
196+ TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
199+instance readObject ∷ ReadForeign a => ReadForeign (Object.Object a) where
200+ readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
202+ readObject' ∷ Foreign -> F (Object Foreign)
204+ | tagOf value == "Object" = pure $ unsafeFromForeign value
205+ | otherwise = fail $ TypeMismatch "Object" (tagOf value)
207+instance readRecord ∷
208+ ( RowToList fields fieldList
209+ , ReadForeignFields fieldList () fields
211+ ReadForeign (Record fields) where
212+ readImpl o = flip Builder.build {} <$> getFields fieldListP o
214+ fieldListP = Proxy ∷ Proxy fieldList
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
221+ F (Builder (Record from) (Record to))
223+instance readFieldsCons ∷
226+ , ReadForeignFields tail from from'
227+ , Row.Lacks name from'
228+ , Row.Cons name ty from' to
230+ ReadForeignFields (Cons name ty tail) from to where
231+ getFields _ obj = (compose <$> first) `exceptTApply` rest
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
247+exceptTApply ∷ ∀ a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
249+ ExceptT $ applyEither
253+applyEither ∷ ∀ e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
254+applyEither (Left e) (Right _) = Left e
256+applyEither (Left e1) (Left e2) = Left (e1 <> e2)
258+applyEither (Right _) (Left e) = Left e
260+applyEither (Right fun) (Right a) = Right (fun a)
262+instance readFieldsNil ∷
263+ ReadForeignFields Nil () () where
264+ getFields _ _ = pure identity
266+instance readForeignVariant ∷
267+ ( RowToList variants rl
268+ , ReadForeignVariant rl variants
270+ ReadForeign (Variant variants) where
271+ readImpl o = readVariantImpl (Proxy ∷ Proxy rl) o
273+class ReadForeignVariant (xs ∷ RowList Type) (row ∷ Row Type) | xs -> row where
279+instance readVariantNil ∷
280+ ReadForeignVariant Nil trash where
281+ readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."
283+instance readVariantCons ∷
286+ , Row.Cons name ty trash row
287+ , ReadForeignVariant tail row
289+ ReadForeignVariant (Cons name ty tail) row where
290+ readVariantImpl _ o =
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
297+ (fail <<< ForeignError $ "Did not match variant tag " <> name)
298+ <|> readVariantImpl (Proxy ∷ Proxy tail) o
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
306+class WriteForeign a where
307+ writeImpl ∷ a -> Foreign
309+instance writeForeignForeign ∷ WriteForeign Foreign where
310+ writeImpl = identity
312+instance writeForeignString ∷ WriteForeign String where
313+ writeImpl = unsafeToForeign
315+instance writeForeignInt ∷ WriteForeign Int where
316+ writeImpl = unsafeToForeign
318+instance writeForeignChar ∷ WriteForeign Char where
319+ writeImpl = unsafeToForeign
321+instance writeForeignNumber ∷ WriteForeign Number where
322+ writeImpl = unsafeToForeign
324+instance writeForeignBoolean ∷ WriteForeign Boolean where
325+ writeImpl = unsafeToForeign
327+instance writeForeignArray ∷ WriteForeign a => WriteForeign (Array a) where
328+ writeImpl xs = unsafeToForeign $ writeImpl <$> xs
330+instance writeForeignMaybe ∷ WriteForeign a => WriteForeign (Maybe a) where
331+ writeImpl = maybe undefined writeImpl
333+instance writeForeignNullable ∷ WriteForeign a => WriteForeign (Nullable a) where
334+ writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe
336+instance writeForeignObject ∷ WriteForeign a => WriteForeign (Object.Object a) where
337+ writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)
339+instance recordWriteForeign ∷
341+ , WriteForeignFields rl row () to
343+ WriteForeign (Record row) where
344+ writeImpl rec = unsafeToForeign $ Builder.build steps {}
346+ rlp = Proxy ∷ Proxy rl
348+ steps = writeImplFields rlp rec
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)
353+instance consWriteForeignFields ∷
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
361+ WriteForeignFields (Cons name ty tail) row from to where
362+ writeImplFields _ rec = result
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
374+instance nilWriteForeignFields ∷
375+ WriteForeignFields Nil row () () where
376+ writeImplFields _ _ = identity
378+instance writeForeignVariant ∷
380+ , WriteForeignVariant rl row
382+ WriteForeign (Variant row) where
383+ writeImpl variant = writeVariantImpl (Proxy ∷ Proxy rl) variant
385+class WriteForeignVariant (rl ∷ RowList Type) (row ∷ Row Type) | rl -> row where
386+ writeVariantImpl ∷ ∀ g. g rl -> Variant row -> Foreign
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."
393+instance consWriteForeignVariant ∷
396+ , Row.Cons name ty subRow row
397+ , WriteForeignVariant tail subRow
399+ WriteForeignVariant (Cons name ty tail) row where
400+ writeVariantImpl _ variant =
404+ (writeVariantImpl (Proxy ∷ Proxy tail))
407+ namep = Proxy ∷ Proxy name
409+ writeVariant value =
411+ { type: reflectSymbol namep
412+ , value: writeImpl value
415+instance readForeignNEArray ∷ ReadForeign a => ReadForeign (NonEmptyArray a) where
417+ raw ∷ Array a <- readImpl f
418+ except $ note (singleton $ ForeignError "Nonempty array expected, got empty array") $ fromArray raw
420+instance writeForeignNEArray ∷ WriteForeign a => WriteForeign (NonEmptyArray a) where
421+ writeImpl a = writeImpl <<< toArray $ a