1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6
7module Data.Aeson.Encoding.Internal
8    (
9    -- * Encoding
10      Encoding' (..)
11    , Encoding
12    , encodingToLazyByteString
13    , unsafeToEncoding
14    , retagEncoding
15    , Series (..)
16    , pairs
17    , pair
18    , pairStr
19    , pair'
20    -- * Predicates
21    , nullEncoding
22    -- * Encoding constructors
23    , emptyArray_
24    , emptyObject_
25    , wrapObject
26    , wrapArray
27    , null_
28    , bool
29    , text
30    , lazyText
31    , string
32    , list
33    , dict
34    , tuple
35    , (>*<)
36    , InArray
37    , empty
38    , (><)
39    , econcat
40    -- ** Decimal numbers
41    , int8, int16, int32, int64, int
42    , word8, word16, word32, word64, word
43    , integer, float, double, scientific
44    -- ** Decimal numbers as Text
45    , int8Text, int16Text, int32Text, int64Text, intText
46    , word8Text, word16Text, word32Text, word64Text, wordText
47    , integerText, floatText, doubleText, scientificText
48    -- ** Time
49    , day
50    , localTime
51    , utcTime
52    , timeOfDay
53    , zonedTime
54    -- ** value
55    , value
56    -- ** JSON tokens
57    , comma, colon, openBracket, closeBracket, openCurly, closeCurly
58    ) where
59
60import Prelude.Compat
61
62import Data.Aeson.Types.Internal (Value)
63import Data.ByteString.Builder (Builder, char7, toLazyByteString)
64import Data.Int
65import Data.Scientific (Scientific)
66import Data.Text (Text)
67import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime)
68import Data.Typeable (Typeable)
69import Data.Word
70import qualified Data.Aeson.Encoding.Builder as EB
71import qualified Data.ByteString.Builder as B
72import qualified Data.ByteString.Lazy as BSL
73import qualified Data.Text.Lazy as LT
74
75-- | An encoding of a JSON value.
76--
77-- @tag@ represents which kind of JSON the Encoding is encoding to,
78-- we reuse 'Text' and 'Value' as tags here.
79newtype Encoding' tag = Encoding {
80      fromEncoding :: Builder
81      -- ^ Acquire the underlying bytestring builder.
82    } deriving (Typeable)
83
84-- | Often used synonym for 'Encoding''.
85type Encoding = Encoding' Value
86
87-- | Make Encoding from Builder.
88--
89-- Use with care! You have to make sure that the passed Builder
90-- is a valid JSON Encoding!
91unsafeToEncoding :: Builder -> Encoding' a
92unsafeToEncoding = Encoding
93
94encodingToLazyByteString :: Encoding' a -> BSL.ByteString
95encodingToLazyByteString = toLazyByteString . fromEncoding
96{-# INLINE encodingToLazyByteString #-}
97
98retagEncoding :: Encoding' a -> Encoding' b
99retagEncoding = Encoding . fromEncoding
100
101-------------------------------------------------------------------------------
102-- Encoding instances
103-------------------------------------------------------------------------------
104
105instance Show (Encoding' a) where
106    show (Encoding e) = show (toLazyByteString e)
107
108instance Eq (Encoding' a) where
109    Encoding a == Encoding b = toLazyByteString a == toLazyByteString b
110
111instance Ord (Encoding' a) where
112    compare (Encoding a) (Encoding b) =
113      compare (toLazyByteString a) (toLazyByteString b)
114
115-- | A series of values that, when encoded, should be separated by
116-- commas. Since 0.11.0.0, the '.=' operator is overloaded to create
117-- either @(Text, Value)@ or 'Series'. You can use Series when
118-- encoding directly to a bytestring builder as in the following
119-- example:
120--
121-- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age)
122data Series = Empty
123            | Value (Encoding' Series)
124            deriving (Typeable)
125
126pair :: Text -> Encoding -> Series
127pair name val = pair' (text name) val
128{-# INLINE pair #-}
129
130pairStr :: String -> Encoding -> Series
131pairStr name val = pair' (string name) val
132{-# INLINE pairStr #-}
133
134pair' :: Encoding' Text -> Encoding -> Series
135pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val
136
137instance Semigroup Series where
138    Empty   <> a       = a
139    a       <> Empty   = a
140    Value a <> Value b = Value (a >< comma >< b)
141
142instance Monoid Series where
143    mempty  = Empty
144    mappend = (<>)
145
146nullEncoding :: Encoding' a -> Bool
147nullEncoding = BSL.null . toLazyByteString . fromEncoding
148
149emptyArray_ :: Encoding
150emptyArray_ = Encoding EB.emptyArray_
151
152emptyObject_ :: Encoding
153emptyObject_ = Encoding EB.emptyObject_
154
155wrapArray :: Encoding' a -> Encoding
156wrapArray e = retagEncoding $ openBracket >< e >< closeBracket
157
158wrapObject :: Encoding' a -> Encoding
159wrapObject e = retagEncoding $ openCurly >< e >< closeCurly
160
161null_ :: Encoding
162null_ = Encoding EB.null_
163
164bool :: Bool -> Encoding
165bool True = Encoding "true"
166bool False = Encoding "false"
167
168-- | Encode a series of key/value pairs, separated by commas.
169pairs :: Series -> Encoding
170pairs (Value v) = openCurly >< retagEncoding v >< closeCurly
171pairs Empty     = emptyObject_
172{-# INLINE pairs #-}
173
174list :: (a -> Encoding) -> [a] -> Encoding
175list _  []     = emptyArray_
176list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket
177  where
178    commas = foldr (\v vs -> comma >< to' v >< vs) empty
179{-# INLINE list #-}
180
181-- | Encode as JSON object
182dict
183    :: (k -> Encoding' Text)                     -- ^ key encoding
184    -> (v -> Encoding)                                -- ^ value encoding
185    -> (forall a. (k -> v -> a -> a) -> a -> m -> a)  -- ^ @foldrWithKey@ - indexed fold
186    -> m                                              -- ^ container
187    -> Encoding
188dict encodeKey encodeVal foldrWithKey = pairs . foldrWithKey go mempty
189  where
190    go k v c = Value (encodeKV k v) <> c
191    encodeKV k v = retagEncoding (encodeKey k) >< colon >< retagEncoding (encodeVal v)
192{-# INLINE dict #-}
193
194-- | Type tag for tuples contents, see 'tuple'.
195data InArray
196
197infixr 6 >*<
198-- | See 'tuple'.
199(>*<) :: Encoding' a -> Encoding' b -> Encoding' InArray
200a >*< b = retagEncoding a >< comma >< retagEncoding b
201{-# INLINE (>*<) #-}
202
203empty :: Encoding' a
204empty = Encoding mempty
205
206econcat :: [Encoding' a] -> Encoding' a
207econcat = foldr (><) empty
208
209infixr 6 ><
210(><) :: Encoding' a -> Encoding' a -> Encoding' a
211Encoding a >< Encoding b = Encoding (a <> b)
212{-# INLINE (><) #-}
213
214-- | Encode as a tuple.
215--
216-- @
217-- toEncoding (X a b c) = tuple $
218--     toEncoding a >*<
219--     toEncoding b >*<
220--     toEncoding c
221tuple :: Encoding' InArray -> Encoding
222tuple b = retagEncoding $ openBracket >< b >< closeBracket
223{-# INLINE tuple #-}
224
225text :: Text -> Encoding' a
226text = Encoding . EB.text
227
228lazyText :: LT.Text -> Encoding' a
229lazyText t = Encoding $
230    B.char7 '"' <>
231    LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t
232
233string :: String -> Encoding' a
234string = Encoding . EB.string
235
236-------------------------------------------------------------------------------
237-- chars
238-------------------------------------------------------------------------------
239
240comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding' a
241comma        = Encoding $ char7 ','
242colon        = Encoding $ char7 ':'
243openBracket  = Encoding $ char7 '['
244closeBracket = Encoding $ char7 ']'
245openCurly    = Encoding $ char7 '{'
246closeCurly   = Encoding $ char7 '}'
247
248-------------------------------------------------------------------------------
249-- Decimal numbers
250-------------------------------------------------------------------------------
251
252int8 :: Int8 -> Encoding
253int8 = Encoding . B.int8Dec
254
255int16 :: Int16 -> Encoding
256int16 = Encoding . B.int16Dec
257
258int32 :: Int32 -> Encoding
259int32 = Encoding . B.int32Dec
260
261int64 :: Int64 -> Encoding
262int64 = Encoding . B.int64Dec
263
264int :: Int -> Encoding
265int = Encoding . B.intDec
266
267word8 :: Word8 -> Encoding
268word8 = Encoding . B.word8Dec
269
270word16 :: Word16 -> Encoding
271word16 = Encoding . B.word16Dec
272
273word32 :: Word32 -> Encoding
274word32 = Encoding . B.word32Dec
275
276word64 :: Word64 -> Encoding
277word64 = Encoding . B.word64Dec
278
279word :: Word -> Encoding
280word = Encoding . B.wordDec
281
282integer :: Integer -> Encoding
283integer = Encoding . B.integerDec
284
285float :: Float -> Encoding
286float = realFloatToEncoding $ Encoding . B.floatDec
287
288double :: Double -> Encoding
289double = realFloatToEncoding $ Encoding . B.doubleDec
290
291scientific :: Scientific -> Encoding
292scientific = Encoding . EB.scientific
293
294realFloatToEncoding :: RealFloat a => (a -> Encoding) -> a -> Encoding
295realFloatToEncoding e d
296    | isNaN d || isInfinite d = null_
297    | otherwise               = e d
298{-# INLINE realFloatToEncoding #-}
299
300-------------------------------------------------------------------------------
301-- Decimal numbers as Text
302-------------------------------------------------------------------------------
303
304int8Text :: Int8 -> Encoding' a
305int8Text = Encoding . EB.quote . B.int8Dec
306
307int16Text :: Int16 -> Encoding' a
308int16Text = Encoding . EB.quote . B.int16Dec
309
310int32Text :: Int32 -> Encoding' a
311int32Text = Encoding . EB.quote . B.int32Dec
312
313int64Text :: Int64 -> Encoding' a
314int64Text = Encoding . EB.quote . B.int64Dec
315
316intText :: Int -> Encoding' a
317intText = Encoding . EB.quote . B.intDec
318
319word8Text :: Word8 -> Encoding' a
320word8Text = Encoding . EB.quote . B.word8Dec
321
322word16Text :: Word16 -> Encoding' a
323word16Text = Encoding . EB.quote . B.word16Dec
324
325word32Text :: Word32 -> Encoding' a
326word32Text = Encoding . EB.quote . B.word32Dec
327
328word64Text :: Word64 -> Encoding' a
329word64Text = Encoding . EB.quote . B.word64Dec
330
331wordText :: Word -> Encoding' a
332wordText = Encoding . EB.quote . B.wordDec
333
334integerText :: Integer -> Encoding' a
335integerText = Encoding . EB.quote . B.integerDec
336
337floatText :: Float -> Encoding' a
338floatText = Encoding . EB.quote . B.floatDec
339
340doubleText :: Double -> Encoding' a
341doubleText = Encoding . EB.quote . B.doubleDec
342
343scientificText :: Scientific -> Encoding' a
344scientificText = Encoding . EB.quote . EB.scientific
345
346-------------------------------------------------------------------------------
347-- time
348-------------------------------------------------------------------------------
349
350day :: Day -> Encoding' a
351day = Encoding . EB.quote . EB.day
352
353localTime :: LocalTime -> Encoding' a
354localTime = Encoding . EB.quote . EB.localTime
355
356utcTime :: UTCTime -> Encoding' a
357utcTime = Encoding . EB.quote . EB.utcTime
358
359timeOfDay :: TimeOfDay -> Encoding' a
360timeOfDay = Encoding . EB.quote . EB.timeOfDay
361
362zonedTime :: ZonedTime -> Encoding' a
363zonedTime = Encoding . EB.quote . EB.zonedTime
364
365-------------------------------------------------------------------------------
366-- Value
367-------------------------------------------------------------------------------
368
369value :: Value -> Encoding
370value = Encoding . EB.encodeToBuilder
371