@@ -0,0 +1,160 @@
1+module Data.Aeson.Types
2+ (
3+ Array
4+ , Object
5+ , (.=)
6+ , (.:)
7+ , object
8+ , Value(..)
9+ , JSON(..)
10+ ) where
11+
12+import Control.Applicative
13+import Data.ByteString (ByteString)
14+import Data.Map (Map)
15+import Data.Text (Text, pack, unpack)
16+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
17+import Data.Time.Clock (UTCTime)
18+import Data.Time.Format (formatTime, parseTime)
19+import Data.Vector (Vector)
20+import System.Locale (defaultTimeLocale)
21+import qualified Data.Map as M
22+import qualified Data.Vector as V
23+
24+type Object = Map Text Value
25+type Array = Vector Value
26+
27+data Value = Object Object
28+ | Array Array
29+ | String Text
30+ | Number Double
31+ | Bool !Bool
32+ | Null
33+ deriving (Eq, Show)
34+
35+(.=) :: JSON a => Text -> a -> Object
36+name .= value = M.singleton name (toJSON value)
37+{-# INLINE (.=) #-}
38+
39+(.:) :: (Alternative f, JSON a) => Object -> Text -> f a
40+obj .: key = case M.lookup key obj of
41+ Nothing -> empty
42+ Just v -> fromJSON v
43+{-# INLINE (.:) #-}
44+
45+object :: [Object] -> Value
46+object = Object . M.unions
47+{-# INLINE object #-}
48+
49+class JSON a where
50+ toJSON :: a -> Value
51+ fromJSON :: Alternative f => Value -> f a
52+
53+instance (JSON a) => JSON (Maybe a) where
54+ toJSON (Just a) = toJSON a
55+ toJSON Nothing = Null
56+ {-# INLINE toJSON #-}
57+
58+ fromJSON Null = pure Nothing
59+ fromJSON a = Just <$> fromJSON a
60+ {-# INLINE fromJSON #-}
61+
62+instance JSON Bool where
63+ toJSON = Bool
64+ {-# INLINE toJSON #-}
65+
66+ fromJSON (Bool b) = pure b
67+ fromJSON _ = empty
68+ {-# INLINE fromJSON #-}
69+
70+instance JSON Double where
71+ toJSON = Number
72+ {-# INLINE toJSON #-}
73+
74+ fromJSON (Number n) = pure n
75+ fromJSON _ = empty
76+ {-# INLINE fromJSON #-}
77+
78+instance JSON Int where
79+ toJSON = Number . fromIntegral
80+ {-# INLINE toJSON #-}
81+
82+ fromJSON (Number n) = pure (floor n)
83+ fromJSON _ = empty
84+ {-# INLINE fromJSON #-}
85+
86+instance JSON Text where
87+ toJSON = String
88+ {-# INLINE toJSON #-}
89+
90+ fromJSON (String t) = pure t
91+ fromJSON _ = empty
92+ {-# INLINE fromJSON #-}
93+
94+instance JSON ByteString where
95+ toJSON = String . decodeUtf8
96+
97+ fromJSON (String t) = pure (encodeUtf8 t)
98+ fromJSON _ = empty
99+
100+mapA :: (Applicative f) => (t -> f a) -> [t] -> f [a]
101+mapA f = go
102+ where
103+ go (a:as) = (:) <$> f a <*> go as
104+ go [] = pure []
105+
106+instance (JSON a) => JSON [a] where
107+ toJSON = Array . V.fromList . map toJSON
108+ {-# INLINE toJSON #-}
109+
110+ fromJSON (Array a) = mapA fromJSON (V.toList a)
111+ fromJSON _ = empty
112+ {-# INLINE fromJSON #-}
113+
114+instance (JSON a) => JSON (Vector a) where
115+ toJSON = Array . V.map toJSON
116+ {-# INLINE toJSON #-}
117+
118+ fromJSON (Array a) = V.fromList <$> mapA fromJSON (V.toList a)
119+ fromJSON _ = empty
120+ {-# INLINE fromJSON #-}
121+
122+instance JSON Value where
123+ toJSON a = a
124+ {-# INLINE toJSON #-}
125+
126+ fromJSON a = pure a
127+ {-# INLINE fromJSON #-}
128+
129+-- We happen to use the same JSON formatting for a UTCTime as .NET
130+-- does for a DateTime. How handy!
131+instance JSON UTCTime where
132+ toJSON t = String (pack (formatTime defaultTimeLocale "/Date(%s)/" t))
133+ {-# INLINE toJSON #-}
134+
135+ fromJSON (String t) =
136+ case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
137+ Just d -> pure d
138+ _ -> empty
139+ fromJSON _ = empty
140+ {-# INLINE fromJSON #-}
141+
142+instance (JSON a, JSON b) => JSON (a,b) where
143+ toJSON (a,b) = toJSON [toJSON a, toJSON b]
144+ {-# INLINE toJSON #-}
145+
146+ fromJSON (Array ab) = case V.toList ab of
147+ [a,b] -> (,) <$> fromJSON a <*> fromJSON b
148+ _ -> empty
149+ fromJSON _ = empty
150+ {-# INLINE fromJSON #-}
151+
152+
153+
154+
155+
156+
157+
158+
159+
160+