|
1 | 1 | module Data.Argonaut.Decode.Class
|
2 | 2 | ( class DecodeJson
|
3 | 3 | , decodeJson
|
4 |
| - , gDecodeJson |
5 |
| - , gDecodeJson' |
6 | 4 | ) where
|
7 | 5 |
|
8 | 6 | import Prelude
|
9 | 7 |
|
10 | 8 | import Data.Array as Arr
|
11 | 9 | import Control.Alternative (class Plus)
|
12 |
| -import Data.Argonaut.Core (Json, JArray, JObject, isNull, foldJsonNull, foldJsonBoolean, foldJsonNumber, foldJsonString, toArray, toNumber, toObject, toString, toBoolean) |
13 |
| -import Data.Array (zipWithA) |
| 10 | +import Data.Argonaut.Core (Json, JArray, JObject, isNull, foldJsonNull, foldJsonBoolean, foldJsonNumber, foldJsonString, toArray, toObject, toString) |
14 | 11 | import Data.Bifunctor (lmap)
|
15 | 12 | import Data.Either (Either(..))
|
16 |
| -import Data.Foldable (find) |
17 |
| -import Data.Generic (class Generic, GenericSpine(..), GenericSignature(..), fromSpine, toSignature) |
18 | 13 | import Data.Int (fromNumber)
|
19 | 14 | import Data.List (List(..), (:), fromFoldable)
|
20 | 15 | import Data.Map as M
|
21 | 16 | import Data.List as L
|
22 | 17 | import Data.Maybe (maybe, Maybe(..))
|
23 | 18 | import Data.NonEmpty (NonEmpty, singleton, (:|))
|
24 |
| -import Data.String (charAt, toChar) |
| 19 | +import Data.String (charAt) |
25 | 20 | import Data.StrMap as SM
|
26 |
| -import Data.Traversable (traverse, for) |
| 21 | +import Data.Traversable (traverse) |
27 | 22 | import Data.Tuple (Tuple(..))
|
28 | 23 |
|
29 |
| -import Type.Proxy (Proxy(..)) |
30 |
| - |
31 | 24 | class DecodeJson a where
|
32 | 25 | decodeJson :: Json -> Either String a
|
33 | 26 |
|
34 |
| --- | Decode `Json` representation of a value which has a `Generic` type. |
35 |
| -gDecodeJson :: forall a. Generic a => Json -> Either String a |
36 |
| -gDecodeJson |
37 |
| - = maybe (Left "fromSpine failed") Right |
38 |
| - <<< fromSpine |
39 |
| - <=< gDecodeJson' (toSignature (Proxy :: Proxy a)) |
40 |
| - |
41 |
| --- | Decode `Json` representation of a `GenericSpine`. |
42 |
| -gDecodeJson' :: GenericSignature -> Json -> Either String GenericSpine |
43 |
| -gDecodeJson' signature json = case signature of |
44 |
| - SigNumber -> SNumber <$> mFail "Expected a number" (toNumber json) |
45 |
| - SigInt -> SInt <$> mFail "Expected an integer number" (fromNumber =<< toNumber json) |
46 |
| - SigString -> SString <$> mFail "Expected a string" (toString json) |
47 |
| - SigChar -> SChar <$> mFail "Expected a char" (toChar =<< toString json) |
48 |
| - SigBoolean -> SBoolean <$> mFail "Expected a boolean" (toBoolean json) |
49 |
| - SigUnit -> pure SUnit |
50 |
| - SigArray thunk -> do |
51 |
| - jArr <- mFail "Expected an array" $ toArray json |
52 |
| - SArray <$> traverse (map const <<< gDecodeJson' (thunk unit)) jArr |
53 |
| - SigRecord props -> do |
54 |
| - jObj <- mFail "Expected an object" $ toObject json |
55 |
| - SRecord <$> for props \({recLabel: lbl, recValue: val}) -> do |
56 |
| - pf <- mFail ("'" <> lbl <> "' property missing") (SM.lookup lbl jObj) |
57 |
| - sp <- gDecodeJson' (val unit) pf |
58 |
| - pure { recLabel: lbl, recValue: const sp } |
59 |
| - SigProd typeConstr alts -> do |
60 |
| - let decodingErr msg = "When decoding a " <> typeConstr <> ": " <> msg |
61 |
| - jObj <- mFail (decodingErr "expected an object") (toObject json) |
62 |
| - tagJson <- mFail (decodingErr "'tag' property is missing") (SM.lookup "tag" jObj) |
63 |
| - tag <- mFail (decodingErr "'tag' property is not a string") (toString tagJson) |
64 |
| - case find ((tag == _) <<< _.sigConstructor) alts of |
65 |
| - Nothing -> Left (decodingErr ("'" <> tag <> "' isn't a valid constructor")) |
66 |
| - Just { sigValues: sigValues } -> do |
67 |
| - vals <- mFail (decodingErr "'values' array is missing") (toArray =<< SM.lookup "values" jObj) |
68 |
| - sps <- zipWithA (\k -> gDecodeJson' (k unit)) sigValues vals |
69 |
| - pure (SProd tag (const <$> sps)) |
70 |
| - where |
71 |
| - mFail :: forall a. String -> Maybe a -> Either String a |
72 |
| - mFail msg = maybe (Left msg) Right |
73 |
| - |
74 | 27 | instance decodeJsonMaybe :: DecodeJson a => DecodeJson (Maybe a) where
|
75 |
| - decodeJson j |
76 |
| - | isNull j = pure Nothing |
77 |
| - | otherwise = Just <$> decodeJson j |
| 28 | + decodeJson j = |
| 29 | + case decode j of |
| 30 | + Right x -> Right x |
| 31 | + Left x -> backwardsCompat |
| 32 | + where |
| 33 | + decode = |
| 34 | + decodeJObject >=> lookupJust >=> decodeJson |
| 35 | + lookupJust = |
| 36 | + maybe (Left "Missing property 'just'") Right <<< SM.lookup "just" |
| 37 | + backwardsCompat |
| 38 | + | isNull j = pure Nothing |
| 39 | + | otherwise = Just <$> decodeJson j |
78 | 40 |
|
79 | 41 | instance decodeJsonTuple :: (DecodeJson a, DecodeJson b) => DecodeJson (Tuple a b) where
|
80 | 42 | decodeJson j = decodeJson j >>= f
|
|
0 commit comments