git.iko.soy/typeable/aeson
on master help sign in
Migrate TH code to use Data.Aeson.Encoding
b67aa29Oleg Grenrus
Data/Aeson/Encode/Functions.hs+1−2
compare with master
unifiedsplit
@@ -3,12 +3,11 @@
3module Data.Aeson.Encode.Functions
3module Data.Aeson.Encode.Functions
4 (
4 (
5 builder
5 builder
6− , char7 -- TODO: used by TH module
7 ) where
6 ) where
8
7
9import Data.Aeson.Encoding
8import Data.Aeson.Encoding
10import Data.Aeson.Types.Class
9import Data.Aeson.Types.Class
11−import Data.ByteString.Builder (Builder, char7)
10+import Data.ByteString.Builder (Builder)
12import Data.Monoid ((<>))
11import Data.Monoid ((<>))
13
12
14builder :: ToJSON a => a -> Builder
13builder :: ToJSON a => a -> Builder
Data/Aeson/Encoding.hs+28−1
@@ -10,12 +10,18 @@ module Data.Aeson.Encoding
10 -- * Encoding constructors
10 -- * Encoding constructors
11 , emptyArray_
11 , emptyArray_
12 , emptyObject_
12 , emptyObject_
13+ , wrapArray
14+ , wrapObject
15+ , text
13 , list
16 , list
14− , dict
17+ , dict
15 , tuple
18 , tuple
16 , (>*<)
19 , (>*<)
20+ -- ** chars
21+ , comma, colon, openBracket, closeBracket, openCurly, closeCurly
17 ) where
22 ) where
18
23
24+import Data.Text (Text)
19import Data.ByteString.Builder (Builder, char7, toLazyByteString)
25import Data.ByteString.Builder (Builder, char7, toLazyByteString)
20import Data.Semigroup (Semigroup((<>)))
26import Data.Semigroup (Semigroup((<>)))
21import Data.ByteString.Builder.Prim (primBounded)
27import Data.ByteString.Builder.Prim (primBounded)
@@ -79,6 +85,12 @@ emptyArray_ = Encoding B.emptyArray_
79emptyObject_ :: Encoding
85emptyObject_ :: Encoding
80emptyObject_ = Encoding B.emptyObject_
86emptyObject_ = Encoding B.emptyObject_
81
87
88+wrapArray :: Encoding -> Encoding
89+wrapArray e = openBracket <> e <> closeBracket
90+
91+wrapObject :: Encoding -> Encoding
92+wrapObject e = openCurly <> e <> closeCurly
93+
82-- | Encode a series of key/value pairs, separated by commas.
94-- | Encode a series of key/value pairs, separated by commas.
83pairs :: Series -> Encoding
95pairs :: Series -> Encoding
84pairs = brackets '{' '}'
96pairs = brackets '{' '}'
@@ -126,3 +138,18 @@ Encoding a >*< Encoding b = Encoding $ a <> char7 ',' <> b
126tuple :: Encoding -> Encoding
138tuple :: Encoding -> Encoding
127tuple b = Encoding (char7 '[' <> fromEncoding b <> char7 ']')
139tuple b = Encoding (char7 '[' <> fromEncoding b <> char7 ']')
128{-# INLINE tuple #-}
140{-# INLINE tuple #-}
141+
142+text :: Text -> Encoding
143+text = Encoding . B.text
144+
145+-------------------------------------------------------------------------------
146+-- chars
147+-------------------------------------------------------------------------------
148+
149+comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding
150+comma = Encoding $ char7 ','
151+colon = Encoding $ char7 ':'
152+openBracket = Encoding $ char7 '['
153+closeBracket = Encoding $ char7 ']'
154+openCurly = Encoding $ char7 '{'
155+closeCurly = Encoding $ char7 '}'
Data/Aeson/TH.hs+14−16
@@ -108,7 +108,6 @@ import Data.Aeson.Types ( Value(..), Parser
108 , defaultTaggedObject
108 , defaultTaggedObject
109 )
109 )
110import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
110import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
111−import Data.Aeson.Encoding ( Encoding(..) )
112import Control.Monad ( liftM2, return, mapM, fail )
111import Control.Monad ( liftM2, return, mapM, fail )
113import Data.Bool ( Bool(False, True), otherwise, (&&), not )
112import Data.Bool ( Bool(False, True), otherwise, (&&), not )
114import Data.Either ( Either(Left, Right) )
113import Data.Either ( Either(Left, Right) )
@@ -141,8 +140,7 @@ import Prelude ( head )
141import Text.Printf ( printf )
140import Text.Printf ( printf )
142import Text.Show ( show )
141import Text.Show ( show )
143import qualified Data.Aeson as A
142import qualified Data.Aeson as A
144−import qualified Data.Aeson.Encode.Builder as E
143+import qualified Data.Aeson.Encoding as E
145−import qualified Data.Aeson.Encode.Functions as E
146import qualified Data.HashMap.Strict as H ( lookup, toList )
144import qualified Data.HashMap.Strict as H ( lookup, toList )
147import qualified Data.Map as M ( fromList, findWithDefault )
145import qualified Data.Map as M ( fromList, findWithDefault )
148import qualified Data.Text as T ( Text, pack, unpack )
146import qualified Data.Text as T ( Text, pack, unpack )
@@ -292,7 +290,7 @@ consToEncoding opts cons = do
292 matches
290 matches
293 | allNullaryToStringTag opts && all isNullary cons =
291 | allNullaryToStringTag opts && all isNullary cons =
294 [ match (conP conName [])
292 [ match (conP conName [])
295− (normalB $ [|Encoding|] `appE` encStr opts conName) []
293+ (normalB $ encStr opts conName) []
296 | con <- cons
294 | con <- cons
297 , let conName = getConName con
295 , let conName = getConName con
298 ]
296 ]
@@ -459,23 +457,23 @@ isMaybe _ = False
459infixr 6 <^>
457infixr 6 <^>
460
458
461(<:>) :: ExpQ -> ExpQ -> ExpQ
459(<:>) :: ExpQ -> ExpQ -> ExpQ
462−(<:>) a b = a <^> [|E.char7 ':'|] <^> b
460+(<:>) a b = a <^> [|E.colon|] <^> b
463infixr 5 <:>
461infixr 5 <:>
464
462
465(<%>) :: ExpQ -> ExpQ -> ExpQ
463(<%>) :: ExpQ -> ExpQ -> ExpQ
466−(<%>) a b = a <^> [|E.char7 ','|] <^> b
464+(<%>) a b = a <^> [|E.comma|] <^> b
467infixr 4 <%>
465infixr 4 <%>
468
466
469array :: ExpQ -> ExpQ
467array :: ExpQ -> ExpQ
470−array exp = [|Encoding|] `appE` ([|E.char7 '['|] <^> exp <^> [|E.char7 ']'|])
468+array exp = [|E.wrapArray|] `appE` exp
471
469
472object :: ExpQ -> ExpQ
470object :: ExpQ -> ExpQ
473−object exp = [|Encoding|] `appE` ([|E.char7 '{'|] <^> exp <^> [|E.char7 '}'|])
471+object exp = [|E.wrapObject|] `appE` exp
474
472
475sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp
473sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp
476sumToEncoding opts multiCons conName exp
474sumToEncoding opts multiCons conName exp
477 | multiCons =
475 | multiCons =
478− let fexp = [|fromEncoding|] `appE` exp in
476+ let fexp = exp in
479 case sumEncoding opts of
477 case sumEncoding opts of
480 TwoElemArray ->
478 TwoElemArray ->
481 array (encStr opts conName <%> fexp)
479 array (encStr opts conName <%> fexp)
@@ -515,7 +513,7 @@ argsToEncoding opts multiCons (NormalC conName ts) = do
515 [e] -> return ([|toEncoding|] `appE` varE e)
513 [e] -> return ([|toEncoding|] `appE` varE e)
516 -- Multiple arguments are converted to a JSON array.
514 -- Multiple arguments are converted to a JSON array.
517 es ->
515 es ->
518− return (array (foldr1 (<%>) [[|E.builder|] `appE` varE x | x <- es]))
516+ return (array (foldr1 (<%>) [[|toEncoding|] `appE` varE x | x <- es]))
519 match (conP conName $ map varP args)
517 match (conP conName $ map varP args)
520 (normalB $ sumToEncoding opts multiCons conName js)
518 (normalB $ sumToEncoding opts multiCons conName js)
521 []
519 []
@@ -529,7 +527,7 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
529 let exp = object objBody
527 let exp = object objBody
530
528
531 objBody = [|mconcat|] `appE`
529 objBody = [|mconcat|] `appE`
532− ([|intersperse (E.char7 ',')|] `appE` pairs)
530+ ([|intersperse E.comma|] `appE` pairs)
533 pairs | omitNothingFields opts = infixApp maybeFields
531 pairs | omitNothingFields opts = infixApp maybeFields
534 [|(<>)|]
532 [|(<>)|]
535 restFields
533 restFields
@@ -547,16 +545,16 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
547 infixApp
545 infixApp
548 (infixApp
546 (infixApp
549 (infixE
547 (infixE
550− (Just $ toFieldName field <^> [|E.char7 ':'|])
548+ (Just $ toFieldName field <^> [|E.colon|])
551 [|(<>)|]
549 [|(<>)|]
552 Nothing)
550 Nothing)
553 [|(.)|]
551 [|(.)|]
554− [|E.builder|])
552+ [|toEncoding|])
555 [|(<$>)|]
553 [|(<$>)|]
556 (varE arg)
554 (varE arg)
557
555
558 toPair (arg, (field, _, _)) =
556 toPair (arg, (field, _, _)) =
559− toFieldName field <:> [|E.builder|] `appE` varE arg
557+ toFieldName field <:> [|toEncoding|] `appE` varE arg
560
558
561 toFieldName field = [|E.text|] `appE`
559 toFieldName field = [|E.text|] `appE`
562 ([|T.pack|] `appE` fieldLabelExp opts field)
560 ([|T.pack|] `appE` fieldLabelExp opts field)
@@ -566,13 +564,13 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
566 $ if multiCons
564 $ if multiCons
567 then case sumEncoding opts of
565 then case sumEncoding opts of
568 TwoElemArray -> array $
566 TwoElemArray -> array $
569− encStr opts conName <%> [|fromEncoding|] `appE` exp
567+ encStr opts conName <%> exp
570 TaggedObject{tagFieldName} -> object $
568 TaggedObject{tagFieldName} -> object $
571 ([|E.text (T.pack tagFieldName)|] <:>
569 ([|E.text (T.pack tagFieldName)|] <:>
572 encStr opts conName) <%>
570 encStr opts conName) <%>
573 objBody
571 objBody
574 ObjectWithSingleField -> object $
572 ObjectWithSingleField -> object $
575− encStr opts conName <:> [|fromEncoding|] `appE` exp
573+ encStr opts conName <:> exp
576 else exp
574 else exp
577 ) []
575 ) []
578
576