|
1 | 1 | module Data.Argonaut.Decode
|
2 |
| - ( DecodeJson |
3 |
| - , decodeJson |
4 |
| - , gDecodeJson |
5 |
| - , gDecodeJson' |
6 |
| - , decodeMaybe |
| 2 | + ( module Data.Argonaut.Decode.Class |
| 3 | + , module Data.Argonaut.Decode.Combinators |
7 | 4 | ) where
|
8 | 5 |
|
9 |
| -import Prelude |
10 |
| - |
11 |
| -import Control.Alt ((<|>)) |
12 |
| -import Control.Bind ((=<<)) |
13 |
| -import Data.Argonaut.Core (Json(), isNull, foldJsonNull, foldJsonBoolean, foldJsonNumber, foldJsonString, toArray, toNumber, toObject, toString, toBoolean) |
14 |
| -import Data.Array (zipWithA) |
15 |
| -import Data.Either (either, Either(..)) |
16 |
| -import Data.Foldable (find) |
17 |
| -import Data.Generic (Generic, GenericSpine(..), GenericSignature(..), fromSpine, toSignature) |
18 |
| -import Data.Int (fromNumber) |
19 |
| -import Data.List (List(..), toList) |
20 |
| -import Data.Map as Map |
21 |
| -import Data.Maybe (maybe, Maybe(..)) |
22 |
| -import Data.String (charAt, toChar) |
23 |
| -import Data.StrMap as M |
24 |
| -import Data.Traversable (traverse, for) |
25 |
| -import Data.Tuple (Tuple(..)) |
26 |
| -import Type.Proxy (Proxy(..)) |
27 |
| - |
28 |
| -class DecodeJson a where |
29 |
| - decodeJson :: Json -> Either String a |
30 |
| - |
31 |
| --- | Decode `Json` representation of a value which has a `Generic` type. |
32 |
| -gDecodeJson :: forall a. (Generic a) => Json -> Either String a |
33 |
| -gDecodeJson json = maybe (Left "fromSpine failed") Right <<< fromSpine |
34 |
| - =<< gDecodeJson' (toSignature (Proxy :: Proxy a)) json |
35 |
| - |
36 |
| --- | Decode `Json` representation of a `GenericSpine`. |
37 |
| -gDecodeJson' :: GenericSignature -> Json -> Either String GenericSpine |
38 |
| -gDecodeJson' signature json = case signature of |
39 |
| - SigNumber -> SNumber <$> mFail "Expected a number" (toNumber json) |
40 |
| - SigInt -> SInt <$> mFail "Expected an integer number" (fromNumber =<< toNumber json) |
41 |
| - SigString -> SString <$> mFail "Expected a string" (toString json) |
42 |
| - SigChar -> SChar <$> mFail "Expected a char" (toChar =<< toString json) |
43 |
| - SigBoolean -> SBoolean <$> mFail "Expected a boolean" (toBoolean json) |
44 |
| - SigArray thunk -> do |
45 |
| - jArr <- mFail "Expected an array" $ toArray json |
46 |
| - SArray <$> traverse (map const <<< gDecodeJson' (thunk unit)) jArr |
47 |
| - SigRecord props -> do |
48 |
| - jObj <- mFail "Expected an object" $ toObject json |
49 |
| - SRecord <$> for props \({recLabel: lbl, recValue: val}) -> do |
50 |
| - pf <- mFail ("'" <> lbl <> "' property missing") (M.lookup lbl jObj) |
51 |
| - sp <- gDecodeJson' (val unit) pf |
52 |
| - pure { recLabel: lbl, recValue: const sp } |
53 |
| - SigProd typeConstr alts -> do |
54 |
| - let decodingErr msg = "When decoding a " ++ typeConstr ++ ": " ++ msg |
55 |
| - jObj <- mFail (decodingErr "expected an object") (toObject json) |
56 |
| - tagJson <- mFail (decodingErr "'tag' property is missing") (M.lookup "tag" jObj) |
57 |
| - tag <- mFail (decodingErr "'tag' property is not a string") (toString tagJson) |
58 |
| - case find ((tag ==) <<< _.sigConstructor) alts of |
59 |
| - Nothing -> Left (decodingErr ("'" <> tag <> "' isn't a valid constructor")) |
60 |
| - Just { sigValues: sigValues } -> do |
61 |
| - vals <- mFail (decodingErr "'values' array is missing") (toArray =<< M.lookup "values" jObj) |
62 |
| - sps <- zipWithA (\k -> gDecodeJson' (k unit)) sigValues vals |
63 |
| - pure (SProd tag (const <$> sps)) |
64 |
| - where |
65 |
| - mFail :: forall a. String -> Maybe a -> Either String a |
66 |
| - mFail msg = maybe (Left msg) Right |
67 |
| - |
68 |
| -instance decodeJsonMaybe :: (DecodeJson a) => DecodeJson (Maybe a) where |
69 |
| - decodeJson j |
70 |
| - | isNull j = pure Nothing |
71 |
| - | otherwise = (Just <$> decodeJson j) <|> (pure Nothing) |
72 |
| - |
73 |
| -instance decodeJsonTuple :: (DecodeJson a, DecodeJson b) => DecodeJson (Tuple a b) where |
74 |
| - decodeJson j = decodeJson j >>= f |
75 |
| - where |
76 |
| - f (Cons a (Cons b Nil)) = Tuple <$> decodeJson a <*> decodeJson b |
77 |
| - f _ = Left "Couldn't decode Tuple" |
78 |
| - |
79 |
| -instance decodeJsonEither :: (DecodeJson a, DecodeJson b) => DecodeJson (Either a b) where |
80 |
| - decodeJson j = |
81 |
| - case toObject j of |
82 |
| - Just obj -> do |
83 |
| - tag <- just (M.lookup "tag" obj) |
84 |
| - val <- just (M.lookup "value" obj) |
85 |
| - case toString tag of |
86 |
| - Just "Right" -> |
87 |
| - Right <$> decodeJson val |
88 |
| - Just "Left" -> |
89 |
| - Left <$> decodeJson val |
90 |
| - _ -> |
91 |
| - Left "Couldn't decode Either" |
92 |
| - _ -> |
93 |
| - Left "Couldn't decode Either" |
94 |
| - where |
95 |
| - just (Just x) = Right x |
96 |
| - just Nothing = Left "Couldn't decode Either" |
97 |
| - |
98 |
| -instance decodeJsonNull :: DecodeJson Unit where |
99 |
| - decodeJson = foldJsonNull (Left "Not null") (const $ Right unit) |
100 |
| - |
101 |
| -instance decodeJsonBoolean :: DecodeJson Boolean where |
102 |
| - decodeJson = foldJsonBoolean (Left "Not a Boolean") Right |
103 |
| - |
104 |
| -instance decodeJsonNumber :: DecodeJson Number where |
105 |
| - decodeJson = foldJsonNumber (Left "Not a Number") Right |
106 |
| - |
107 |
| -instance decodeJsonInt :: DecodeJson Int where |
108 |
| - decodeJson num = foldJsonNumber (Left "Not a Number") go num |
109 |
| - where go num = maybe (Left "Not an Int") Right $ fromNumber num |
110 |
| - |
111 |
| -instance decodeJsonString :: DecodeJson String where |
112 |
| - decodeJson = foldJsonString (Left "Not a String") Right |
113 |
| - |
114 |
| -instance decodeJsonJson :: DecodeJson Json where |
115 |
| - decodeJson = Right |
116 |
| - |
117 |
| -instance decodeJsonChar :: DecodeJson Char where |
118 |
| - decodeJson j = (charAt 0 <$> decodeJson j) >>= go where |
119 |
| - go Nothing = Left $ "Expected character but found: " ++ show j |
120 |
| - go (Just c) = Right c |
121 |
| - |
122 |
| -instance decodeStrMap :: (DecodeJson a) => DecodeJson (M.StrMap a) where |
123 |
| - decodeJson json = maybe (Left "Couldn't decode StrMap") Right $ do |
124 |
| - obj <- toObject json |
125 |
| - traverse decodeMaybe obj |
126 |
| - |
127 |
| -instance decodeArray :: (DecodeJson a) => DecodeJson (Array a) where |
128 |
| - decodeJson json = maybe (Left "Couldn't decode Array") Right $ do |
129 |
| - obj <- toArray json |
130 |
| - traverse decodeMaybe obj |
131 |
| - |
132 |
| -instance decodeList :: (DecodeJson a) => DecodeJson (List a) where |
133 |
| - decodeJson json = maybe (Left "Couldn't decode List") Right $ do |
134 |
| - lst <- toList <$> toArray json |
135 |
| - traverse decodeMaybe lst |
136 |
| - |
137 |
| -instance decodeMap :: (Ord a, DecodeJson a, DecodeJson b) => DecodeJson (Map.Map a b) where |
138 |
| - decodeJson j = Map.fromList <$> decodeJson j |
139 |
| - |
140 |
| -decodeMaybe :: forall a. (DecodeJson a) => Json -> Maybe a |
141 |
| -decodeMaybe json = either (const Nothing) pure $ decodeJson json |
| 6 | +import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson, gDecodeJson, gDecodeJson') |
| 7 | +import Data.Argonaut.Decode.Combinators (getField, (.?)) |
0 commit comments