@@ -0,0 +1,438 @@
19+, class ReadForeignFields
21+, class ReadForeignVariant
26+, class WriteForeignFields
28+, class WriteForeignVariant
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)
63+import Record.Builder (Builder)
64+import Record.Builder as Builder
65+import Type.Prelude (RLProxy(..))
66+import Type.Proxy (Proxy(..))
68+-- | An alias for the Either result of decoding
69+type E a = Either MultipleErrors a
71+-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
77+readJSON = runExcept <<< (readImpl <=< parseJSON)
79+-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
84+readJSON' = readImpl <=< parseJSON
86+-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
92+readJSON_ = hush <<< readJSON
94+-- | Write a JSON string from a type `a`.
99+writeJSON = unsafeStringify <<< writeImpl
107+-- | Read a Foreign value to a type
112+read = runExcept <<< readImpl
114+-- | Read a value of any type as Foreign to a type
115+readAsForeign :: forall a b
119+readAsForeign = read <<< unsafeToForeign
127+-- | Read a Foreign value to a type, as a Maybe of type
132+read_ = hush <<< read
134+foreign import _parseJSON :: EU.EffectFn1 String Foreign
136+parseJSON :: String -> F Foreign
140+ <<< lmap (pure <<< ForeignError <<< message)
143+ <<< EU.runEffectFn1 _parseJSON
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
148+foreign import _undefined :: Foreign
151+undefined = _undefined
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+instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
179+ readImpl = readNullOrUndefined readImpl
181+ readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
182+ readNullOrUndefined f value = Just <$> f value
184+instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
185+ readImpl o = withExcept (map reformat) $
186+ map toNullable <$> traverse readImpl =<< readNull o
188+ reformat error = case error of
189+ TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
192+instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
193+ readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
195+ readObject' :: Foreign -> F (Object Foreign)
197+ | tagOf value == "Object" = pure $ unsafeFromForeign value
198+ | otherwise = fail $ TypeMismatch "Object" (tagOf value)
200+instance readTuple :: ReadTuple (Tuple a b) => ReadForeign (Tuple a b) where
201+ readImpl = readTupleImpl 0
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
208+instance readTupleNestedHelper :: (ReadForeign a, ReadTuple (Tuple b c)) => ReadTuple (Tuple a (Tuple b c)) where
212+ arr -> case Array.uncons arr of
213+ Just { head, tail } ->
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
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))
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
239+ fieldListP = RLProxy :: RLProxy fieldList
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
246+ -> F (Builder (Record from) (Record to))
248+instance readFieldsCons ::
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
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
266+readAtIdx :: ∀ a. ReadForeign a => Int -> Foreign -> F a
267+readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)
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
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)
280+instance readFieldsNil ::
281+ ReadForeignFields Nil () () where
285+instance readForeignVariant ::
286+ ( RowToList variants rl
287+ , ReadForeignVariant rl variants
288+ ) => ReadForeign (Variant variants) where
289+ readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o
291+class ReadForeignVariant (xs :: RowList) (row :: # Type)
293+ readVariantImpl :: RLProxy xs
297+instance readVariantNil ::
298+ ReadForeignVariant Nil trash where
299+ readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."
301+instance readVariantCons ::
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
311+ value :: ty <- readImpl obj.value
312+ pure $ inj namep value
314+ (fail <<< ForeignError $ "Did not match variant tag " <> name)
315+ <|> readVariantImpl (RLProxy :: RLProxy tail) o
317+ namep = SProxy :: SProxy name
318+ name = reflectSymbol namep
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
325+instance writeForeignForeign :: WriteForeign Foreign where
326+ writeImpl = identity
328+instance writeForeignString :: WriteForeign String where
329+ writeImpl = unsafeToForeign
331+instance writeForeignInt :: WriteForeign Int where
332+ writeImpl = unsafeToForeign
334+instance writeForeignChar :: WriteForeign Char where
335+ writeImpl = unsafeToForeign
337+instance writeForeignNumber :: WriteForeign Number where
338+ writeImpl = unsafeToForeign
340+instance writeForeignBoolean :: WriteForeign Boolean where
341+ writeImpl = unsafeToForeign
343+instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
344+ writeImpl xs = unsafeToForeign $ writeImpl <$> xs
346+instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
347+ writeImpl = maybe undefined writeImpl
349+instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
350+ writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe
352+instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
353+ writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)
355+instance writeForeignTupleNested :: (WriteForeign a, WriteForeign (Tuple b c)) => WriteForeign (Tuple a (Tuple b c)) where
356+ writeImpl (Tuple a bc) =
360+ # Array.cons (writeImpl a)
362+else instance writeForeignTuple :: (WriteForeign a, WriteForeign b) => WriteForeign (Tuple a b) where
363+ writeImpl (Tuple a b) = writeImpl [ writeImpl a, writeImpl b ]
365+instance recordWriteForeign ::
367+ , WriteForeignFields rl row () to
368+ ) => WriteForeign (Record row) where
369+ writeImpl rec = unsafeToForeign $ Builder.build steps {}
371+ rlp = RLProxy :: RLProxy rl
372+ steps = writeImplFields rlp rec
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)
378+instance consWriteForeignFields ::
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
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
397+instance writeForeignVariant ::
399+ , WriteForeignVariant rl row
400+ ) => WriteForeign (Variant row) where
401+ writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant
403+class WriteForeignVariant (rl :: RowList) (row :: # Type)
405+ writeVariantImpl :: forall g. g rl -> Variant row -> Foreign
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."
413+instance consWriteForeignVariant ::
416+ , Row.Cons name ty subRow row
417+ , WriteForeignVariant tail subRow
418+ ) => WriteForeignVariant (Cons name ty tail) row where
419+ writeVariantImpl _ variant =
423+ (writeVariantImpl (RLProxy :: RLProxy tail))
426+ namep = SProxy :: SProxy name
427+ writeVariant value = unsafeToForeign
428+ { type: reflectSymbol namep
429+ , value: writeImpl value
432+instance readForeignNEArray :: ReadForeign a => ReadForeign (NonEmptyArray a) where
434+ raw :: Array a <- readImpl f
435+ except $ note (singleton $ ForeignError "Nonempty array expected, got empty array") $ fromArray raw
437+instance writeForeignNEArray :: WriteForeign a => WriteForeign (NonEmptyArray a) where
438+ writeImpl a = writeImpl <<< toArray $ a