6fbb0c7 · typeable/aeson

1+{-# LANGUAGE CPP

1−{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}

2+ , NoImplicitPrelude

3+ , TemplateHaskell

4+ , NamedFieldPuns

5+ , FlexibleInstances

6+ , UndecidableInstances

7+ , OverlappingInstances

8+ #-}

2

9

3{-|

10{-|

4Module: Data.Aeson.TH

11Module: Data.Aeson.TH

30field name.

37field name.

31

38

32@

39@

33−$('deriveJSON' ('drop' 4) ''D)

40+$('deriveJSON' 'defaultOptions'{'fieldNameModifier' = 'drop' 4} ''D)

34@

41@

35

42

36−This will result in the following (simplified) code to be spliced in your program:

37−

38−@

39−import Control.Applicative

40−import Control.Monad

41−import Data.Aeson

42−import Data.Aeson.TH

43−import qualified Data.HashMap.Strict as H

44−import qualified Data.Text as T

45−import qualified Data.Vector as V

46−

47−instance 'ToJSON' a => 'ToJSON' (D a) where

48− 'toJSON' =

49− \\value ->

50− case value of

51− Nullary ->

52− 'object' [T.pack \"Nullary\" .= 'toJSON' ([] :: [()])]

53− Unary arg1 ->

54− 'object' [T.pack \"Unary\" .= 'toJSON' arg1]

55− Product arg1 arg2 arg3 ->

56− 'object' [ T.pack \"Product\"

57− .= ('Array' $ 'V.create' $ do

58− mv <- 'VM.unsafeNew' 3

59− 'VM.unsafeWrite' mv 0 ('toJSON' arg1)

60− 'VM.unsafeWrite' mv 1 ('toJSON' arg2)

61− 'VM.unsafeWrite' mv 2 ('toJSON' arg3)

62− return mv)

63− ]

64− Record arg1 arg2 arg3 ->

65− 'object' [ T.pack \"Record\"

66− .= 'object' [ T.pack \"One\" '.=' arg1

67− , T.pack \"Two\" '.=' arg2

68− , T.pack \"Three\" '.=' arg3

69− ]

70− ]

71−@

72−

73−@

74−instance 'FromJSON' a => 'FromJSON' (D a) where

75− 'parseJSON' =

76− \\value ->

77− case value of

78− 'Object' obj ->

79− case H.toList obj of

80− [(conKey, conVal)] ->

81− case conKey of

82− _ | conKey == T.pack \"Nullary\" ->

83− case conVal of

84− 'Array' arr ->

85− if V.null arr

86− then pure Nullary

87− else fail \"\<error message\>\"

88− _ -> fail \"\<error message\>\"

89− | conKey == T.pack \"Unary\" ->

90− case conVal of

91− arg -> Unary \<$\> parseJSON arg

92− | conKey == T.pack \"Product\" ->

93− case conVal of

94− 'Array' arr ->

95− if V.length arr == 3

96− then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)

97− \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)

98− \<*\> 'parseJSON' (arr `V.unsafeIndex` 2)

99− else fail \"\<error message\>\"

100− _ -> fail \"\<error message\>\"

101− | conKey == T.pack \"Record\" ->

102− case conVal of

103− 'Object' recObj ->

104− if H.size recObj == 3

105− then Record \<$\> recObj '.:' T.pack \"One\"

106− \<*\> recObj '.:' T.pack \"Two\"

107− \<*\> recObj '.:' T.pack \"Three\"

108− else fail \"\<error message\>\"

109− _ -> fail \"\<error message\>\"

110− | otherwise -> fail \"\<error message\>\"

111− _ -> fail \"\<error message\>\"

112− _ -> fail \"\<error message\>\"

113−@

114−

115−Note that every \"\<error message\>\" is in fact a descriptive message which

116−provides as much information as is reasonable about the failed parse.

117−

118Now we can use the newly created instances.

43Now we can use the newly created instances.

119

44

120@

45@

132

57

133@

58@

134-- FromJSON and ToJSON instances for 4-tuples.

59-- FromJSON and ToJSON instances for 4-tuples.

135−$('deriveJSON' id ''(,,,))

60+$('deriveJSON' 'defaultOptions' ''(,,,))

136@

61@

137

62

138-}

63-}

139

64

140module Data.Aeson.TH

65module Data.Aeson.TH

66+ ( Options(..), SumEncoding(..), defaultOptions

67+

141− ( deriveJSON

68+ , deriveJSON

142

69

143 , deriveToJSON

70 , deriveToJSON

144 , deriveFromJSON

71 , deriveFromJSON

152--------------------------------------------------------------------------------

79--------------------------------------------------------------------------------

153

80

154-- from aeson:

81-- from aeson:

155−import Data.Aeson ( toJSON, Object, object, (.=)

82+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)

156 , ToJSON, toJSON

83 , ToJSON, toJSON

157 , FromJSON, parseJSON

84 , FromJSON, parseJSON

158 )

85 )

160-- from base:

87-- from base:

161import Control.Applicative ( pure, (<$>), (<*>) )

88import Control.Applicative ( pure, (<$>), (<*>) )

162import Control.Monad ( return, mapM, liftM2, fail )

89import Control.Monad ( return, mapM, liftM2, fail )

163−import Data.Bool ( otherwise )

90+import Data.Bool ( Bool(False, True), otherwise, (&&) )

164import Data.Eq ( (==) )

91import Data.Eq ( (==) )

165−import Data.Function ( ($), (.), id )

92+import Data.Function ( ($), (.), id, const )

166import Data.Functor ( fmap )

93import Data.Functor ( fmap )

94+import Data.Int ( Int )

95+import Data.Either ( Either(Left, Right), either )

167import Data.List ( (++), foldl, foldl', intercalate

96import Data.List ( (++), foldl, foldl', intercalate

168− , length, map, zip, genericLength

97+ , length, map, zip, genericLength, all

169 )

98 )

170import Data.Maybe ( Maybe(Nothing, Just) )

99import Data.Maybe ( Maybe(Nothing, Just) )

171import Prelude ( String, (-), Integer, fromIntegral, error )

100import Prelude ( String, (-), Integer, fromIntegral, error )

176import Prelude ( fromInteger )

105import Prelude ( fromInteger )

177#endif

106#endif

178-- from unordered-containers:

107-- from unordered-containers:

179−import qualified Data.HashMap.Strict as H ( lookup, toList, size )

108+import qualified Data.HashMap.Strict as H ( lookup )

180-- from template-haskell:

109-- from template-haskell:

181import Language.Haskell.TH

110import Language.Haskell.TH

111+import Language.Haskell.TH.Syntax ( VarStrictType )

182-- from text:

112-- from text:

183import qualified Data.Text as T ( Text, pack, unpack )

113import qualified Data.Text as T ( Text, pack, unpack )

184-- from vector:

114-- from vector:

185−import qualified Data.Vector as V ( unsafeIndex, null, length, create )

115+import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )

186import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )

116import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )

187

117

188

118

119+--------------------------------------------------------------------------------

120+-- Configuration

121+--------------------------------------------------------------------------------

122+

123+-- | Options that specify how to encode your datatype to JSON.

124+data Options = Options

125+ { fieldNameModifier :: String -> String

126+ -- ^ Function applied to field names.

127+ -- Handy for removing common record prefixes for example.

128+ , nullaryToString :: Bool

129+ -- ^ If 'True' the constructors of a datatypes, with all nullary

130+ -- constructors, will be encoded to a string with the

131+ -- constructor name. If 'False' the encoding will always follow

132+ -- the `sumEncoding`.

133+ , sumEncoding :: SumEncoding

134+ -- ^ Specifies how to encode constructors of a sum datatype.

135+ }

136+

137+-- | Specifies how to encode constructors of a sum datatype.

138+data SumEncoding =

139+ TwoElemArray -- ^ A constructor will be encoded to a 2-element

140+ -- array where the first element is the name of the

141+ -- constructor and the second element the content of

142+ -- the constructor.

143+ | ObjectWithType { typeFieldName :: String

144+ , valueFieldName :: String

145+ }

146+ -- ^ A constructor will be encoded to an object with a field

147+ -- 'typeFieldName' which specifies the constructor name. If the

148+ -- constructor is not a record the constructor content will be

149+ -- stored under the 'valueFieldName' field.

150+

151+-- | Default encoding options which specify to not modify field names,

152+-- encode the constructors of a datatype with all nullary constructors

153+-- to just strings with the name of the constructor and use a

154+-- 2-element array for other sum datatypes.

155+defaultOptions :: Options

156+defaultOptions = Options

157+ { fieldNameModifier = id

158+ , nullaryToString = True

159+ , sumEncoding = TwoElemArray

160+ }

161+

189--------------------------------------------------------------------------------

162--------------------------------------------------------------------------------

190-- Convenience

163-- Convenience

191--------------------------------------------------------------------------------

164--------------------------------------------------------------------------------

195--

168--

196-- This is a convienience function which is equivalent to calling both

169-- This is a convienience function which is equivalent to calling both

197-- 'deriveToJSON' and 'deriveFromJSON'.

170-- 'deriveToJSON' and 'deriveFromJSON'.

198−deriveJSON :: (String -> String)

171+deriveJSON :: Options

199− -- ^ Function to change field names.

172+ -- ^ Encoding options.

200 -> Name

173 -> Name

201 -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'

174 -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'

202 -- instances.

175 -- instances.

203 -> Q [Dec]

176 -> Q [Dec]

204−deriveJSON withField name =

177+deriveJSON opts name =

205 liftM2 (++)

178 liftM2 (++)

206− (deriveToJSON withField name)

179+ (deriveToJSON opts name)

207− (deriveFromJSON withField name)

180+ (deriveFromJSON opts name)

208

181

209

182

210--------------------------------------------------------------------------------

183--------------------------------------------------------------------------------

221-}

194-}

222

195

223-- | Generates a 'ToJSON' instance declaration for the given data type.

196-- | Generates a 'ToJSON' instance declaration for the given data type.

224−--

225−-- Example:

226−--

227−-- @

228−-- data Foo = Foo 'Char' 'Int'

229−-- $('deriveToJSON' 'id' ''Foo)

230−-- @

231−--

232−-- This will splice in the following code:

233−--

234−-- @

235−-- instance 'ToJSON' Foo where

236−-- 'toJSON' =

237−-- \\value -> case value of

238−-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do

239−-- mv <- 'VM.unsafeNew' 2

240−-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1)

241−-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2)

242−-- return mv

243−-- @

244−deriveToJSON :: (String -> String)

197+deriveToJSON :: Options

245− -- ^ Function to change field names.

198+ -- ^ Encoding options.

246 -> Name

199 -> Name

247 -- ^ Name of the type for which to generate a 'ToJSON' instance

200 -- ^ Name of the type for which to generate a 'ToJSON' instance

248 -- declaration.

201 -- declaration.

249 -> Q [Dec]

202 -> Q [Dec]

250−deriveToJSON withField name =

203+deriveToJSON opts name =

251 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons

204 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons

252 where

205 where

253 fromCons :: [TyVarBndr] -> [Con] -> Q Dec

206 fromCons :: [TyVarBndr] -> [Con] -> Q Dec

256 (classType `appT` instanceType)

209 (classType `appT` instanceType)

257 [ funD 'toJSON

210 [ funD 'toJSON

258 [ clause []

211 [ clause []

259− (normalB $ consToJSON withField cons)

212+ (normalB $ consToJSON opts cons)

260 []

213 []

261 ]

214 ]

262 ]

215 ]

266 instanceType = foldl' appT (conT name) $ map varT typeNames

219 instanceType = foldl' appT (conT name) $ map varT typeNames

267

220

268-- | Generates a lambda expression which encodes the given data type as JSON.

221-- | Generates a lambda expression which encodes the given data type as JSON.

269−--

222+mkToJSON :: Options -- ^ Encoding options.

270−-- Example:

271−--

272−-- @

273−-- data Foo = Foo Int

274−-- @

275−--

276−-- @

277−-- encodeFoo :: Foo -> 'Value'

278−-- encodeFoo = $('mkToJSON' id ''Foo)

279−-- @

280−--

281−-- This will splice in the following code:

282−--

283−-- @

284−-- \\value -> case value of Foo arg1 -> 'toJSON' arg1

285−-- @

286−mkToJSON :: (String -> String) -- ^ Function to change field names.

287 -> Name -- ^ Name of the type to encode.

223 -> Name -- ^ Name of the type to encode.

288 -> Q Exp

224 -> Q Exp

289−mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)

225+mkToJSON opts name = withType name (\_ cons -> consToJSON opts cons)

290

226

291-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code

227-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code

292-- to generate the JSON encoding of a number of constructors. All constructors

228-- to generate the JSON encoding of a number of constructors. All constructors

293-- must be from the same type.

229-- must be from the same type.

294−consToJSON :: (String -> String)

230+consToJSON :: Options

295− -- ^ Function to change field names.

231+ -- ^ Encoding options.

296 -> [Con]

232 -> [Con]

297 -- ^ Constructors for which to generate JSON generating code.

233 -- ^ Constructors for which to generate JSON generating code.

298 -> Q Exp

234 -> Q Exp

235+

299consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "

236consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "

300 ++ "Not a single constructor given!"

237 ++ "Not a single constructor given!"

238+

301-- A single constructor is directly encoded. The constructor itself may be

239-- A single constructor is directly encoded. The constructor itself may be

302-- forgotten.

240-- forgotten.

303−consToJSON withField [con] = do

241+consToJSON opts [con] = do

304 value <- newName "value"

242 value <- newName "value"

305− lam1E (varP value)

243+ lam1E (varP value) $ caseE (varE value) [encodeArgs opts False con]

306− $ caseE (varE value)

244+

307− [encodeArgs id withField con]

308−-- With multiple constructors we need to remember which constructor is

309−-- encoded. This is done by generating a JSON object which maps to constructor's

310−-- name to the JSON encoding of its contents.

311−consToJSON withField cons = do

245+consToJSON opts cons = do

312 value <- newName "value"

246 value <- newName "value"

313− lam1E (varP value)

247+ lam1E (varP value) $ caseE (varE value) matches

314− $ caseE (varE value)

315− [ encodeArgs (wrap $ getConName con) withField con

316− | con <- cons

317− ]

318 where

248 where

319− wrap :: Name -> Q Exp -> Q Exp

249+ -- Constructors of a datatype with all nullary constructors are encoded to

320− wrap name exp =

250+ -- just a string with the constructor name:

321− let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)

251+ matches | nullaryToString opts && all isNullary cons =

252+ [ match (conP conName []) (normalB $ conStr conName) []

253+ | con <- cons

254+ , let conName = getConName con

255+ ]

256+ -- Constructors of a datatype having some constructors with arity > 0 are

257+ -- encoded to a 2-element array where the first element is a string with

258+ -- the constructor name and the second element is the encoded argument or

259+ -- arguments of the constructor.

260+ | otherwise = [ encodeArgs opts True con

261+ | con <- cons

262+ ]

263+

264+conStr :: Name -> Q Exp

265+conStr = appE [|String|] . appE [|T.pack|] . stringE . nameBase

266+

267+-- | If constructor is nullary.

268+isNullary :: Con -> Bool

269+isNullary (NormalC _ []) = True

270+isNullary _ = False

271+

272+encodeSum :: Options -> Bool -> Name -> Q Exp -> Q Exp

273+encodeSum opts multiCons conName exp

274+ | multiCons =

275+ case sumEncoding opts of

276+ TwoElemArray ->

277+ [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr conName, exp])

278+ ObjectWithType{typeFieldName, valueFieldName} ->

322− in [e|object|] `appE` listE [ infixApp fieldName

279+ [|object|] `appE` listE

323− [e|(.=)|]

280+ [ infixApp [|T.pack typeFieldName|] [|(.=)|] (conStr conName)

324− exp

281+ , infixApp [|T.pack valueFieldName|] [|(.=)|] exp

325− ]

282+ ]

283+ | otherwise = exp

326

284

327-- | Generates code to generate the JSON encoding of a single constructor.

285-- | Generates code to generate the JSON encoding of a single constructor.

328−encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match

286+encodeArgs :: Options -> Bool -> Con -> Q Match

329-- Nullary constructors. Generates code that explicitly matches against the

287-- Nullary constructors. Generates code that explicitly matches against the

330-- constructor even though it doesn't contain data. This is useful to prevent

288-- constructor even though it doesn't contain data. This is useful to prevent

331-- type errors.

289-- type errors.

332−encodeArgs withExp _ (NormalC conName []) =

290+encodeArgs opts multiCons (NormalC conName []) =

333 match (conP conName [])

291 match (conP conName [])

334− (normalB $ withExp [e|toJSON ([] :: [()])|])

292+ (normalB (encodeSum opts multiCons conName [e|toJSON ([] :: [()])|]))

335 []

293 []

294+

336-- Polyadic constructors with special case for unary constructors.

295-- Polyadic constructors with special case for unary constructors.

337−encodeArgs withExp _ (NormalC conName ts) = do

296+encodeArgs opts multiCons (NormalC conName ts) = do

338 let len = length ts

297 let len = length ts

339 args <- mapM newName ["arg" ++ show n | n <- [1..len]]

298 args <- mapM newName ["arg" ++ show n | n <- [1..len]]

340− js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of

299+ js <- case [[|toJSON|] `appE` varE arg | arg <- args] of

341 -- Single argument is directly converted.

300 -- Single argument is directly converted.

342 [e] -> return e

301 [e] -> return e

343 -- Multiple arguments are converted to a JSON array.

302 -- Multiple arguments are converted to a JSON array.

344 es -> do

303 es -> do

345 mv <- newName "mv"

304 mv <- newName "mv"

346 let newMV = bindS (varP mv)

305 let newMV = bindS (varP mv)

347− ([e|VM.unsafeNew|] `appE`

306+ ([|VM.unsafeNew|] `appE`

348 litE (integerL $ fromIntegral len))

307 litE (integerL $ fromIntegral len))

349 stmts = [ noBindS $

308 stmts = [ noBindS $

350− [e|VM.unsafeWrite|] `appE`

309+ [|VM.unsafeWrite|] `appE`

351 (varE mv) `appE`

310 (varE mv) `appE`

352 litE (integerL ix) `appE`

311 litE (integerL ix) `appE`

353 e

312 e

354 | (ix, e) <- zip [(0::Integer)..] es

313 | (ix, e) <- zip [(0::Integer)..] es

355 ]

314 ]

356− ret = noBindS $ [e|return|] `appE` varE mv

315+ ret = noBindS $ [|return|] `appE` varE mv

357− return $ [e|Array|] `appE`

316+ return $ [|Array|] `appE`

358 (varE 'V.create `appE`

317 (varE 'V.create `appE`

359 doE (newMV:stmts++[ret]))

318 doE (newMV:stmts++[ret]))

360 match (conP conName $ map varP args)

319 match (conP conName $ map varP args)

361− (normalB $ withExp js)

320+ (normalB $ encodeSum opts multiCons conName js)

362 []

321 []

322+

363-- Records.

323-- Records.

364−encodeArgs withExp withField (RecC conName ts) = do

324+encodeArgs opts multiCons (RecC conName ts) = do

365 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]

325 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]

366− let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)

326+ let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)

367− [e|(.=)|]

327+ [|(.=)|]

368 (varE arg)

328 (varE arg)

369 | (arg, (field, _, _)) <- zip args ts

329 | (arg, (field, _, _)) <- zip args ts

370 ]

330 ]

331+ exp = [|object|] `appE` listE js

371 match (conP conName $ map varP args)

332 match (conP conName $ map varP args)

333+ ( normalB

334+ $ if multiCons

335+ then case sumEncoding opts of

336+ TwoElemArray -> [|toJSON|] `appE` tupE [conStr conName, exp]

337+ ObjectWithType{typeFieldName} ->

372− (normalB $ withExp $ [e|object|] `appE` listE js)

338+ [|object|] `appE` listE

339+ ( infixApp [|T.pack typeFieldName|] [|(.=)|]

340+ (conStr conName)

341+ : js

342+ )

343+ else exp

373− []

344+ ) []

345+

374-- Infix constructors.

346-- Infix constructors.

375−encodeArgs withExp _ (InfixC _ conName _) = do

347+encodeArgs opts multiCons (InfixC _ conName _) = do

376 al <- newName "argL"

348 al <- newName "argL"

377 ar <- newName "argR"

349 ar <- newName "argR"

378 match (infixP (varP al) conName (varP ar))

350 match (infixP (varP al) conName (varP ar))

379 ( normalB

351 ( normalB

380− $ withExp

352+ $ encodeSum opts multiCons conName

381− $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a

353+ $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a

382− | a <- [al,ar]

354+ | a <- [al,ar]

383− ]

355+ ]

384 )

356 )

385 []

357 []

386-- Existentially quantified constructors.

358-- Existentially quantified constructors.

387−encodeArgs withExp withField (ForallC _ _ con) =

359+encodeArgs opts multiCons (ForallC _ _ con) =

388− encodeArgs withExp withField con

360+ encodeArgs opts multiCons con

389

361

390

362

391--------------------------------------------------------------------------------

363--------------------------------------------------------------------------------

393--------------------------------------------------------------------------------

365--------------------------------------------------------------------------------

394

366

395-- | Generates a 'FromJSON' instance declaration for the given data type.

367-- | Generates a 'FromJSON' instance declaration for the given data type.

396−--

397−-- Example:

398−--

399−-- @

400−-- data Foo = Foo Char Int

401−-- $('deriveFromJSON' id ''Foo)

402−-- @

403−--

404−-- This will splice in the following code:

405−--

406−-- @

407−-- instance 'FromJSON' Foo where

408−-- 'parseJSON' =

409−-- \\value -> case value of

410−-- 'Array' arr ->

411−-- if (V.length arr == 2)

412−-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)

413−-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)

414−-- else fail \"\<error message\>\"

415−-- other -> fail \"\<error message\>\"

416−-- @

417−deriveFromJSON :: (String -> String)

368+deriveFromJSON :: Options

418− -- ^ Function to change field names.

369+ -- ^ Encoding options.

419 -> Name

370 -> Name

420 -- ^ Name of the type for which to generate a 'FromJSON' instance

371 -- ^ Name of the type for which to generate a 'FromJSON' instance

421 -- declaration.

372 -- declaration.

422 -> Q [Dec]

373 -> Q [Dec]

423−deriveFromJSON withField name =

374+deriveFromJSON opts name =

424 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons

375 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons

425 where

376 where

426 fromCons :: [TyVarBndr] -> [Con] -> Q Dec

377 fromCons :: [TyVarBndr] -> [Con] -> Q Dec

429 (classType `appT` instanceType)

380 (classType `appT` instanceType)

430 [ funD 'parseJSON

381 [ funD 'parseJSON

431 [ clause []

382 [ clause []

432− (normalB $ consFromJSON name withField cons)

383+ (normalB $ consFromJSON name opts cons)

433 []

384 []

434 ]

385 ]

435 ]

386 ]

440

391

441-- | Generates a lambda expression which parses the JSON encoding of the given

392-- | Generates a lambda expression which parses the JSON encoding of the given

442-- data type.

393-- data type.

443−--

394+mkParseJSON :: Options -- ^ Encoding options.

444−-- Example:

445−--

446−-- @

447−-- data Foo = Foo 'Int'

448−-- @

449−--

450−-- @

451−-- parseFoo :: 'Value' -> 'Parser' Foo

452−-- parseFoo = $('mkParseJSON' id ''Foo)

453−-- @

454−--

455−-- This will splice in the following code:

456−--

457−-- @

458−-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg

459−-- @

460−mkParseJSON :: (String -> String) -- ^ Function to change field names.

461 -> Name -- ^ Name of the encoded type.

395 -> Name -- ^ Name of the encoded type.

462 -> Q Exp

396 -> Q Exp

463−mkParseJSON withField name =

397+mkParseJSON opts name =

464− withType name (\_ cons -> consFromJSON name withField cons)

398+ withType name (\_ cons -> consFromJSON name opts cons)

465

399

466-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates

400-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates

467-- code to parse the JSON encoding of a number of constructors. All constructors

401-- code to parse the JSON encoding of a number of constructors. All constructors

468-- must be from the same type.

402-- must be from the same type.

469consFromJSON :: Name

403consFromJSON :: Name

470 -- ^ Name of the type to which the constructors belong.

404 -- ^ Name of the type to which the constructors belong.

471− -> (String -> String)

405+ -> Options

472− -- ^ Function to change field names.

406+ -- ^ Encoding options

473 -> [Con]

407 -> [Con]

474 -- ^ Constructors for which to generate JSON parsing code.

408 -- ^ Constructors for which to generate JSON parsing code.

475 -> Q Exp

409 -> Q Exp

410+

476consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

411consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

477 ++ "Not a single constructor given!"

412 ++ "Not a single constructor given!"

413+

478−consFromJSON tName withField [con] = do

414+consFromJSON tName opts [con] = do

415+ value <- newName "value"

416+ lam1E (varP value) (parseArgs tName opts con (Right value))

417+

418+consFromJSON tName opts cons = do

479 value <- newName "value"

419 value <- newName "value"

480− lam1E (varP value)

420+ lam1E (varP value) $ caseE (varE value) $

481− $ caseE (varE value)

421+ if nullaryToString opts && all isNullary cons

482− (parseArgs tName withField con)

422+ then allNullaryMatches

483−consFromJSON tName withField cons = do

423+ else mixedMatches

484− value <- newName "value"

424+

485− obj <- newName "obj"

425+ where

486− conKey <- newName "conKey"

426+ allNullaryMatches =

487− conVal <- newName "conVal"

488−

489− let -- Convert the Data.Map inside the Object to a list and pattern match

490− -- against it. It must contain a single element otherwise the parse will

491− -- fail.

492− caseLst = caseE ([e|H.toList|] `appE` varE obj)

493− [ match (listP [tupP [varP conKey, varP conVal]])

494− (normalB caseKey)

495− []

496− , do other <- newName "other"

427+ [ do txt <- newName "txt"

497− match (varP other)

428+ match (conP 'String [varP txt])

498− (normalB $ [|wrongPairCountFail|]

499− `appE` (litE $ stringL $ show tName)

500− `appE` ([|show . length|] `appE` varE other)

501− )

502− []

503− ]

504−

505− caseKey = caseE (varE conKey)

506− [match wildP (guardedB guards) []]

429+ (guardedB $

430+ [ liftM2 (,) (normalG $

507− guards = [ do g <- normalG $ infixApp (varE conKey)

431+ infixApp (varE txt)

508− [|(==)|]

432+ [|(==)|]

509− ( [|T.pack|]

433+ ([|T.pack|] `appE`

510− `appE` conNameExp con

434+ stringE (nameBase conName)))

511− )

435+ ([|pure|] `appE` conE conName)

512− e <- caseE (varE conVal)

513− (parseArgs tName withField con)

514− return (g, e)

515− | con <- cons

436+ | con <- cons

437+ , let conName = getConName con

516− ]

438+ ]

517− ++

439+ ++

518− [ liftM2 (,)

440+ [ liftM2 (,)

519− (normalG [e|otherwise|])

441+ (normalG [|otherwise|])

520− ( [|conNotFoundFail|]

442+ ( [|noMatchFail|]

521− `appE` (litE $ stringL $ show tName)

443+ `appE` (litE $ stringL $ show tName)

522− `appE` listE (map (litE . stringL . nameBase . getConName) cons)

523− `appE` ([|T.unpack|] `appE` varE conKey)

444+ `appE` ([|T.unpack|] `appE` varE txt)

524− )

445+ )

525− ]

446+ ]

526−

447+ )

527− lam1E (varP value)

448+ []

528− $ caseE (varE value)

449+ , do other <- newName "other"

450+ match (varP other)

451+ (normalB $ [|noStringFail|]

452+ `appE` (litE $ stringL $ show tName)

453+ `appE` ([|valueConName|] `appE` varE other)

454+ )

455+ []

456+ ]

457+

458+ mixedMatches =

459+ case sumEncoding opts of

460+ ObjectWithType {typeFieldName, valueFieldName} ->

461+ [ do obj <- newName "obj"

529− [ match (conP 'Object [varP obj])

462+ match (conP 'Object [varP obj])

530− (normalB caseLst)

463+ (normalB $ parseObject typeFieldName valueFieldName obj)

531− []

464+ []

532− , do other <- newName "other"

465+ , do other <- newName "other"

533− match (varP other)

466+ match (varP other)

534− ( normalB

467+ ( normalB

535− $ [|noObjectFail|]

468+ $ [|noObjectFail|]

536 `appE` (litE $ stringL $ show tName)

469 `appE` (litE $ stringL $ show tName)

537 `appE` ([|valueConName|] `appE` varE other)

470 `appE` ([|valueConName|] `appE` varE other)

538− )

471+ )

472+ []

473+ ]

474+ TwoElemArray ->

475+ [ do arr <- newName "array"

476+ match (conP 'Array [varP arr])

477+ (guardedB $

478+ [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)

479+ [|(==)|]

480+ (litE $ integerL 2))

481+ (parse2ElemArray arr)

482+ , liftM2 (,) (normalG [|otherwise|])

483+ (([|not2ElemArray|]

484+ `appE` (litE $ stringL $ show tName)

485+ `appE` ([|V.length|] `appE` varE arr)))

539− []

486+ ]

487+ )

488+ []

489+ , do other <- newName "other"

490+ match (varP other)

491+ ( normalB

492+ $ [|noArrayFail|]

493+ `appE` (litE $ stringL $ show tName)

494+ `appE` ([|valueConName|] `appE` varE other)

495+ )

496+ []

497+ ]

498+

499+ parseObject typFieldName valFieldName obj = do

500+ conKey <- newName "conKey"

501+ doE [ bindS (varP conKey)

502+ (infixApp (varE obj)

503+ [|(.:)|]

504+ ([|T.pack|] `appE` stringE typFieldName))

505+ , noBindS $ parseContents conKey (Left (valFieldName, obj))

540− ]

506+ ]

541

507

542−-- | Generates code to parse the JSON encoding of a single constructor.

508+ parse2ElemArray arr = do

543−parseArgs :: Name -- ^ Name of the type to which the constructor belongs.

509+ conKey <- newName "conKey"

544− -> (String -> String) -- ^ Function to change field names.

510+ conVal <- newName "conVal"

545− -> Con -- ^ Constructor for which to generate JSON parsing code.

511+ let letIx n ix =

546− -> [Q Match]

512+ valD (varP n)

547−-- Nullary constructors.

513+ (normalB ([|V.unsafeIndex|] `appE`

514+ varE arr `appE`

515+ litE (integerL ix)))

516+ []

517+ letE [ letIx conKey 0

518+ , letIx conVal 1

519+ ]

520+ (parseContents conKey (Right conVal))

521+

522+ parseContents conKey contents =

523+ caseE (varE conKey)

524+ [ do txt <- newName "txt"

525+ match (conP 'String [varP txt])

526+ (guardedB $

527+ [ liftM2 (,) (normalG $

528+ infixApp (varE txt)

529+ [|(==)|]

530+ ([|T.pack|] `appE`

531+ conNameExp con))

532+ (parseArgs tName opts con contents)

533+ | con <- cons

534+ ]

535+ ++

536+ [ liftM2 (,)

537+ (normalG [|otherwise|])

538+ ( [|conNotFoundFail|]

539+ `appE` (litE $ stringL $ show tName)

540+ `appE` listE (map ( litE

541+ . stringL

542+ . nameBase

543+ . getConName

544+ )

545+ cons

546+ )

547+ `appE` ([|T.unpack|] `appE` varE txt)

548+ )

549+ ]

550+ )

551+ []

552+ , do other <- newName "other"

553+ match (varP other)

554+ ( normalB $

555+ (either (const [|typeNotString|])

556+ (const [|firstElemNotString|])

557+ contents)

558+ `appE` (litE $ stringL $ show tName)

559+ `appE` ([|valueConName|] `appE` varE other)

560+ )

561+ []

562+ ]

563+

564+

565+parseNullaryMatches :: Name -> Name -> [Q Match]

548−parseArgs tName _ (NormalC conName []) =

566+parseNullaryMatches tName conName =

549 [ do arr <- newName "arr"

567 [ do arr <- newName "arr"

550 match (conP 'Array [varP arr])

568 match (conP 'Array [varP arr])

569+ (guardedB $

551− ( normalB $ condE ([|V.null|] `appE` varE arr)

570+ [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)

552− ([e|pure|] `appE` conE conName)

571+ ([|pure|] `appE` conE conName)

572+ , liftM2 (,) (normalG [|otherwise|])

553− ( parseTypeMismatch tName conName

573+ (parseTypeMismatch tName conName

554− (litE $ stringL "an empty Array")

574+ (litE $ stringL "an empty Array")

555− ( infixApp (litE $ stringL $ "Array of length ")

575+ (infixApp (litE $ stringL $ "Array of length ")

556− [|(++)|]

576+ [|(++)|]

557− ([|show . V.length|] `appE` varE arr)

577+ ([|show . V.length|] `appE` varE arr)

558− )

578+ )

559− )

579+ )

580+ ]

560 )

581 )

561 []

582 []

562 , matchFailed tName conName "Array"

583 , matchFailed tName conName "Array"

563 ]

584 ]

564−-- Unary constructors.

585+

565−parseArgs _ _ (NormalC conName [_]) =

586+parseUnaryMatches :: Name -> [Q Match]

587+parseUnaryMatches conName =

566 [ do arg <- newName "arg"

588 [ do arg <- newName "arg"

567 match (varP arg)

589 match (varP arg)

568 ( normalB $ infixApp (conE conName)

590 ( normalB $ infixApp (conE conName)

569− [e|(<$>)|]

591+ [|(<$>)|]

570− ([e|parseJSON|] `appE` varE arg)

592+ ([|parseJSON|] `appE` varE arg)

571 )

593 )

572 []

594 []

573 ]

595 ]

596+

597+parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ

598+parseRecord opts tName conName ts obj =

599+ foldl' (\a b -> infixApp a [|(<*>)|] b)

600+ (infixApp (conE conName) [|(<$>)|] x)

601+ xs

602+ where

603+ x:xs = [ [|lookupField|]

604+ `appE` (litE $ stringL $ show tName)

605+ `appE` (litE $ stringL $ nameBase conName)

606+ `appE` (varE obj)

607+ `appE` ( [|T.pack|] `appE` fieldNameExp opts field

608+ )

609+ | (field, _, _) <- ts

610+ ]

611+

612+getValField :: Name -> String -> [MatchQ] -> Q Exp

613+getValField obj valFieldName matches = do

614+ val <- newName "val"

615+ doE [ bindS (varP val) $ infixApp (varE obj)

616+ [|(.:)|]

617+ ([|T.pack|] `appE`

618+ (litE $ stringL valFieldName))

619+ , noBindS $ caseE (varE val) matches

620+ ]

621+

622+-- | Generates code to parse the JSON encoding of a single constructor.

623+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.

624+ -> Options -- ^ Encoding options.

625+ -> Con -- ^ Constructor for which to generate JSON parsing code.

626+ -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or

627+ -- Right valName

628+ -> Q Exp

629+-- Nullary constructors.

630+parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =

631+ getValField obj valFieldName $ parseNullaryMatches tName conName

632+parseArgs tName _ (NormalC conName []) (Right valName) =

633+ caseE (varE valName) $ parseNullaryMatches tName conName

634+

635+-- Unary constructors.

636+parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =

637+ getValField obj valFieldName $ parseUnaryMatches conName

638+parseArgs _ _ (NormalC conName [_]) (Right valName) =

639+ caseE (varE valName) $ parseUnaryMatches conName

640+

574-- Polyadic constructors.

641-- Polyadic constructors.

642+parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =

643+ getValField obj valFieldName $ parseProduct tName conName $ genericLength ts

644+parseArgs tName _ (NormalC conName ts) (Right valName) =

575−parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts

645+ caseE (varE valName) $ parseProduct tName conName $ genericLength ts

646+

576-- Records.

647-- Records.

577−parseArgs tName withField (RecC conName ts) =

648+parseArgs tName opts (RecC conName ts) (Left (_, obj)) =

649+ parseRecord opts tName conName ts obj

650+parseArgs tName opts (RecC conName ts) (Right valName) = do

578− [ do obj <- newName "recObj"

651+ obj <- newName "recObj"

579− let x:xs = [ [|lookupField|]

652+ caseE (varE valName)

580− `appE` (litE $ stringL $ show tName)

581− `appE` (litE $ stringL $ nameBase conName)

582− `appE` (varE obj)

583− `appE` ( [e|T.pack|]

584− `appE`

585− fieldNameExp withField field

586− )

587− | (field, _, _) <- ts

588− ]

589− match (conP 'Object [varP obj])

653+ [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []

590− ( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj)

591− [|(==)|]

592− (litE $ integerL $ genericLength ts)

593− )

594− ( foldl' (\a b -> infixApp a [|(<*>)|] b)

595− (infixApp (conE conName) [|(<$>)|] x)

596− xs

597− )

598− ( parseTypeMismatch tName conName

599− ( litE $ stringL $ "Object with "

600− ++ show (length ts)

601− ++ " name/value pairs"

602− )

603− ( infixApp ([|show . H.size|] `appE` varE obj)

604− [|(++)|]

605− (litE $ stringL $ " name/value pairs")

606− )

607− )

608− )

609− []

610 , matchFailed tName conName "Object"

654 , matchFailed tName conName "Object"

611 ]

655 ]

656+

612-- Infix constructors. Apart from syntax these are the same as

657-- Infix constructors. Apart from syntax these are the same as

613-- polyadic constructors.

658-- polyadic constructors.

614−parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2

659+parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =

660+ getValField obj valFieldName $ parseProduct tName conName 2

661+parseArgs tName _ (InfixC _ conName _) (Right valName) =

662+ caseE (varE valName) $ parseProduct tName conName 2

663+

615-- Existentially quantified constructors. We ignore the quantifiers

664-- Existentially quantified constructors. We ignore the quantifiers

616-- and proceed with the contained constructor.

665-- and proceed with the contained constructor.

617−parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con

666+parseArgs tName opts (ForallC _ _ con) contents =

667+ parseArgs tName opts con contents

618

668

619-- | Generates code to parse the JSON encoding of an n-ary

669-- | Generates code to parse the JSON encoding of an n-ary

620-- constructor.

670-- constructor.

678 , actual

728 , actual

679 ]

729 ]

680

730

731+class (FromJSON a) => LookupField a where

681−lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a

732+ lookupField :: String -> String -> Object -> T.Text -> Parser a

733+

734+instance (FromJSON a) => LookupField a where

682−lookupField tName rec obj key =

735+ lookupField tName rec obj key =

683− case H.lookup key obj of

736+ case H.lookup key obj of

684− Nothing -> unknownFieldFail tName rec (T.unpack key)

737+ Nothing -> unknownFieldFail tName rec (T.unpack key)

685− Just v -> parseJSON v

738+ Just v -> parseJSON v

739+

740+instance (FromJSON a) => LookupField (Maybe a) where

741+ lookupField _ _ = (.:?)

686

742

687unknownFieldFail :: String -> String -> String -> Parser fail

743unknownFieldFail :: String -> String -> String -> Parser fail

688unknownFieldFail tName rec key =

744unknownFieldFail tName rec key =

689 fail $ printf "When parsing the record %s of type %s the key %s was not present."

745 fail $ printf "When parsing the record %s of type %s the key %s was not present."

690 rec tName key

746 rec tName key

691

747

748+noArrayFail :: String -> String -> Parser fail

749+noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o

750+

692noObjectFail :: String -> String -> Parser fail

751noObjectFail :: String -> String -> Parser fail

693−noObjectFail t o =

752+noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o

753+

754+noStringFail :: String -> String -> Parser fail

755+noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o

756+

757+noMatchFail :: String -> String -> Parser fail

758+noMatchFail t o =

694− fail $ printf "When parsing %s expected Object but got %s." t o

759+ fail $ printf "When parsing %s expected a String with the name of a constructor but got %s." t o

760+

761+not2ElemArray :: String -> Int -> Parser fail

762+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2-elements but got %i elements"

763+ t i

764+typeNotString :: String -> String -> Parser fail

765+typeNotString t o = fail $ printf "When parsing %s expected an Object where the type field is a String with the name of a constructor but got %s." t o

695

766

696−wrongPairCountFail :: String -> String -> Parser fail

767+firstElemNotString :: String -> String -> Parser fail

697−wrongPairCountFail t n =

698− fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."

768+firstElemNotString t o = fail $ printf "When parsing %s expected an Array where the first element is a String with the name of a constructor but got %s." t o

699− t n

700

769

701conNotFoundFail :: String -> [String] -> String -> Parser fail

770conNotFoundFail :: String -> [String] -> String -> Parser fail

702conNotFoundFail t cs o =

771conNotFoundFail t cs o =

703− fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."

772+ fail $ printf "When parsing %s expected a 2-element Array with a name and value element where the name is one of [%s], but got %s."

704 t (intercalate ", " cs) o

773 t (intercalate ", " cs) o

705

774

706parseTypeMismatch' :: String -> String -> String -> String -> Parser fail

775parseTypeMismatch' :: String -> String -> String -> String -> Parser fail

753conNameExp = litE . stringL . nameBase . getConName

822conNameExp = litE . stringL . nameBase . getConName

754

823

755-- | Creates a string literal expression from a record field name.

824-- | Creates a string literal expression from a record field name.

756−fieldNameExp :: (String -> String) -- ^ Function to change the field name.

825+fieldNameExp :: Options -- ^ Encoding options

757 -> Name

826 -> Name

758 -> Q Exp

827 -> Q Exp

759−fieldNameExp f = litE . stringL . f . nameBase

828+fieldNameExp opts = litE . stringL . fieldNameModifier opts . nameBase

760

829

761-- | The name of the outermost 'Value' constructor.

830-- | The name of the outermost 'Value' constructor.

762valueConName :: Value -> String

831valueConName :: Value -> String