6407aff · typeable/aeson

13An example shows how instances are generated for arbitrary data types. First we

14define a data type:

15

16−

16+@

17−> data D a = Nullary

17+data D a = Nullary

18−> | Unary Int

18+ | Unary Int

19−> | Product String Char a

19+ | Product String Char a

20−> | Record { testOne :: Double

20+ | Record { testOne :: Double

21−> , testTwo :: Bool

21+ , testTwo :: Bool

22−> , testThree :: D a

22+ , testThree :: D a

23−> } deriving Eq

23+ } deriving Eq

24−

24+@

25

26Next we derive the necessary instances. Note that we make use of the feature to

27−rewrite record fields. In this case we drop the first 4 characters of every

27+change record field names. In this case we drop the first 4 characters of every

28field name.

29

30−

30+@

31−>>> $(deriveJSON (drop 4) ''D)

31+$('deriveJSON' ('drop' 4) ''D)

32−

32+@

33

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

35

36+@

36−> import Control.Applicative

37+import Control.Applicative

37−> import Control.Monad

38+import Control.Monad

38−> import Data.Aeson

39+import Data.Aeson

39−> import Data.Aeson.TH

40+import Data.Aeson.TH

40−> import qualified Data.Map as M

41+import qualified Data.Map as M

41−> import qualified Data.Text as T

42+import qualified Data.Text as T

42−> import qualified Data.Vector as V

43+import qualified Data.Vector as V

43−>

44+

44−> instance ToJSON a => ToJSON (D a) where

45+instance 'ToJSON' a => 'ToJSON' (D a) where

45−> toJSON =

46+ 'toJSON' =

46−> \value ->

47+ \value ->

47−> case value of

48+ case value of

48−> Nullary ->

49+ Nullary ->

49−> object [T.pack "Nullary" .= toJSON ([] :: [()])]

50+ 'object' ['T.pack' \"Nullary\" .= 'toJSON' ([] :: [()])]

50−> Unary arg1 ->

51+ Unary arg1 ->

51−> object [T.pack "Unary" .= toJSON arg1]

52+ 'object' ['T.pack' \"Unary\" .= 'toJSON' arg1]

52−> Product arg1 arg2 arg3 ->

53+ Product arg1 arg2 arg3 ->

53−> object [ T.pack "Product"

54+ 'object' [ 'T.pack' \"Product\"

54−> .= toJSON [ toJSON arg1

55+ .= 'toJSON' [ 'toJSON' arg1

55−> , toJSON arg2

56+ , 'toJSON' arg2

56−> , toJSON arg3

57+ , 'toJSON' arg3

57−> ]

58+ ]

58−> ]

59+ ]

59−> Record arg1 arg2 arg3 ->

60+ Record arg1 arg2 arg3 ->

60−> object [ T.pack "Record"

61+ 'object' [ 'T.pack' \"Record\"

61−> .= object [ T.pack "One" .= arg1

62+ .= 'object' [ 'T.pack' \"One\" '.=' arg1

62−> , T.pack "Two" .= arg2

63+ , 'T.pack' \"Two\" '.=' arg2

63−> , T.pack "Three" .= arg3

64+ , 'T.pack' \"Three\" '.=' arg3

64−> ]

65+ ]

65−> ]

66+ ]

66−>

67+@

68+

69+@

67−> instance FromJSON a => FromJSON (D a) where

70+instance 'FromJSON' a => 'FromJSON' (D a) where

68−> parseJSON =

71+ 'parseJSON' =

69−> \value ->

72+ \value ->

70−> case value of

73+ case value of

71−> Object obj ->

74+ 'Object' obj ->

72−> case M.toList obj of

75+ case 'M.toList' obj of

73−> [(conKey, conVal)] ->

76+ [(conKey, conVal)] ->

74−> case conKey of

77+ case conKey of

75−> _ | (conKey == T.pack "Nullary") ->

78+ _ | (conKey '==' 'T.pack' \"Nullary\") ->

76−> case conVal of

79+ case conVal of

77−> Array arr | V.null arr -> pure Nullary

80+ 'Array' arr | 'V.null' arr -> 'pure' Nullary

78−> _ -> mzero

81+ _ -> 'mzero'

79−> | (conKey == T.pack "Unary") ->

82+ | (conKey '==' 'T.pack' \"Unary\") ->

80−> case conVal of

83+ case conVal of

81−> arg -> Unary <$> parseJSON arg

84+ arg -> Unary '<$>' 'parseJSON' arg

82−> | (conKey == T.pack "Product") ->

85+ | (conKey '==' 'T.pack' \"Product\") ->

83−> case conVal of

86+ case conVal of

84−> Array arr | V.length arr == 3 ->

87+ 'Array' arr | 'V.length' arr '==' 3 ->

85−> Product <$> parseJSON (arr V.! 0)

88+ 'Product' '<$>' 'parseJSON' (arr 'V.!' 0)

86−> <*> parseJSON (arr V.! 1)

89+ '<*>' 'parseJSON' (arr 'V.!' 1)

87−> <*> parseJSON (arr V.! 2)

90+ '<*>' 'parseJSON' (arr 'V.!' 2)

88−> _ -> mzero

91+ _ -> 'mzero'

89−> | (conKey == T.pack "Record") ->

92+ | (conKey '==' 'T.pack' \"Record\") ->

90−> case conVal of

93+ case conVal of

91−> Object obj ->

94+ 'Object' obj ->

92−> Record <$> (obj .: T.pack "One")

95+ Record '<$>' (obj '.:' 'T.pack' \"One\")

93−> <*> (obj .: T.pack "Two")

96+ '<*>' (obj '.:' 'T.pack' \"Two\")

94−> <*> (obj .: T.pack "Three")

97+ '<*>' (obj '.:' 'T.pack' \"Three\")

95−> _ -> mzero

98+ _ -> 'mzero'

96−> | otherwise -> mzero

99+ | 'otherwise' -> 'mzero'

97−> _ -> mzero

100+ _ -> 'mzero'

98−> _ -> mzero

101+ _ -> 'mzero'

102+@

99

103

100Now we can use the newly created instances.

104Now we can use the newly created instances.

101

105

106+@

102−> d :: D Int

107+d :: D 'Int'

103−> d = Record { testOne = 3.14159

108+d = Record { testOne = 3.14159

104−> , testTwo = True

109+ , testTwo = 'True'

105−> , testThree = Product "test" 'A' 123

110+ , testThree = Product \"test\" \'A\' 123

106−> }

111+ }

112+@

107

113

108>>> fromJSON (toJSON d) == Success d

114>>> fromJSON (toJSON d) == Success d

109> True

115> True

156-- Convenience

162-- Convenience

157--------------------------------------------------------------------------------

163--------------------------------------------------------------------------------

158

164

165+-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given

166+-- data type.

167+--

168+-- This is a convienience function which is equivalent to calling both

169+-- 'deriveToJSON' and 'deriveFromJSON'.

159−deriveJSON :: (String -> String) -> Name -> Q [Dec]

170+deriveJSON :: (String -> String)

171+ -- ^ Function to change field names.

172+ -> Name

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

174+ -- instances.

175+ -> Q [Dec]

160deriveJSON withField name =

176deriveJSON withField name =

161 liftM2 (++)

177 liftM2 (++)

162 (deriveToJSON withField name)

178 (deriveToJSON withField name)

168--------------------------------------------------------------------------------

184--------------------------------------------------------------------------------

169

185

170{-

186{-

171−TODO: Don't constrain type variables that are not used in any constructor.

187+TODO: Don't constrain phantom type variables.

172

188

173data Foo a = Foo Int

189data Foo a = Foo Int

174instance (ToJSON a) ⇒ ToJSON Foo where ...

190instance (ToJSON a) ⇒ ToJSON Foo where ...

175

191

176−The above (ToJSON a) constraint is not necessary.

192+The above (ToJSON a) constraint is not necessary and perhaps undesirable.

177-}

193-}

194+

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

196+--

197+-- Example:

198+--

199+-- @

200+-- data Foo = Foo 'Char' 'Int'

201+-- $('deriveToJSON' 'id' ''Foo)

202+-- @

203+--

204+-- This will splice in the following code:

205+--

206+-- @

207+-- instance 'ToJSON' Foo where

208+-- 'toJSON' =

209+-- \value -> case value of

210+-- Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]

211+-- @

178−deriveToJSON :: (String -> String) -> Name -> Q [Dec]

212+deriveToJSON :: (String -> String)

213+ -- ^ Function to change field names.

214+ -> Name

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

216+ -- declaration.

217+ -> Q [Dec]

179deriveToJSON withField name =

218deriveToJSON withField name =

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

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

181 where

220 where

194 typeNames = map tvbName tvbs

233 typeNames = map tvbName tvbs

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

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

196

235

197−mkToJSON :: (String -> String) -> Name -> Q Exp

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

237+--

238+-- Example:

239+--

240+-- @

241+-- data Foo = Foo 'Int'

242+-- @

243+--

244+-- @

245+-- encodeFoo :: Foo -> 'Value'

246+-- encodeFoo = $('mkToJSON' 'id' ''Foo)

247+-- @

248+--

249+-- This will splice in the following code:

250+--

251+-- @

252+-- \value -> case value of Foo arg1 -> 'toJSON' arg1

253+-- @

254+mkToJSON :: (String -> String) -- ^ Function to change field names.

255+ -> Name -- ^ Name of the type to encode.

256+ -> Q Exp

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

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

199

258

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

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

261+-- must be from the same type.

200−consToJSON :: (String -> String) -> [Con] -> Q Exp

262+consToJSON :: (String -> String)

263+ -- ^ Function to change field names.

264+ -> [Con]

265+ -- ^ Constructors for which to generate JSON generating code.

266+ -> Q Exp

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

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

202 ++ "Not a single constructor given!"

268 ++ "Not a single constructor given!"

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

270+-- forgotten.

203consToJSON withField [con] = do

271consToJSON withField [con] = do

204 value <- newName "value"

272 value <- newName "value"

205 lam1E (varP value)

273 lam1E (varP value)

206 $ caseE (varE value)

274 $ caseE (varE value)

207 [encodeArgs id withField con]

275 [encodeArgs id withField con]

276+-- With multiple constructors we need to remember which constructor is

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

278+-- name to the JSON encoding of its contents.

208consToJSON withField cons = do

279consToJSON withField cons = do

209 value <- newName "value"

280 value <- newName "value"

210 lam1E (varP value)

281 lam1E (varP value)

221 exp

292 exp

222 ]

293 ]

223

294

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

224encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match

296encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match

225−-- Nullary constructors.

297+-- Nullary constructors. Generates code that explicitly matches against the

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

299+-- type errors.

226encodeArgs withExp _ (NormalC conName []) =

300encodeArgs withExp _ (NormalC conName []) =

227 match (conP conName [])

301 match (conP conName [])

228 (normalB $ withExp [e|toJSON ([] :: [()])|])

302 (normalB $ withExp [e|toJSON ([] :: [()])|])

270-- FromJSON

344-- FromJSON

271--------------------------------------------------------------------------------

345--------------------------------------------------------------------------------

272

346

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

348+--

349+-- Example:

350+--

351+-- @

352+-- data Foo = Foo 'Char' 'Int'

353+-- $('deriveFromJSON' 'id' ''Foo)

354+-- @

355+--

356+-- This will splice in the following code:

357+--

358+-- @

359+-- instance 'FromJSON' Foo where

360+-- 'parseJSON' =

361+-- \value -> case value of

362+-- 'Array' arr | ('V.length' arr '==' 2) ->

363+-- Foo '<$>' 'parseJSON' (arr 'V.!' 0)

364+-- '<*>' 'parseJSON' (arr 'V.!' 1)

365+-- _ -> 'mzero'

366+-- @

273−deriveFromJSON :: (String -> String) -> Name -> Q [Dec]

367+deriveFromJSON :: (String -> String)

368+ -- ^ Function to change field names.

369+ -> Name

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

371+ -- declaration.

372+ -> Q [Dec]

274deriveFromJSON withField name =

373deriveFromJSON withField name =

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

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

276 where

375 where

289 typeNames = map tvbName tvbs

388 typeNames = map tvbName tvbs

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

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

291

390

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

392+-- data type.

393+--

394+-- Example:

395+--

396+-- @

397+-- data Foo = Foo 'Int'

398+-- @

399+--

400+-- @

401+-- parseFoo :: 'Value' -> 'Parser' Foo

402+-- parseFoo = $('mkParseJSON' 'id' ''Foo)

403+-- @

404+--

405+-- This will splice in the following code:

406+--

407+-- @

408+-- \\value -> case value of arg -> Foo '<$>' 'parseJSON' arg

409+-- @

292−mkParseJSON :: (String -> String) -> Name -> Q Exp

410+mkParseJSON :: (String -> String) -- ^ Function to change field names.

411+ -> Name -- ^ Name of the encoded type.

412+ -> Q Exp

293mkParseJSON withField name =

413mkParseJSON withField name =

294 withType name (\_ cons -> consFromJSON withField cons)

414 withType name (\_ cons -> consFromJSON withField cons)

295

415

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

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

418+-- must be from the same type.

296−consFromJSON :: (String -> String) -> [Con] -> Q Exp

419+consFromJSON :: (String -> String)

420+ -- ^ Function to change field names.

421+ -> [Con]

422+ -- ^ Constructors for which to generate JSON parsing code.

423+ -> Q Exp

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

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

298 ++ "Not a single constructor given!"

425 ++ "Not a single constructor given!"

299consFromJSON withField [con] = do

426consFromJSON withField [con] = do

338 []

465 []

339 , errorMatch

466 , errorMatch

340 ]

467 ]

341−

468+ where

469+ -- Makes a string literal expression from a constructor's name.

470+ conNameExp :: Con -> Q Exp

471+ conNameExp = litE . stringL . nameBase . getConName

472+

473+-- | Generates code to parse the JSON encoding of a single

474+-- constructor.

342−parseArgs :: (String -> String) -> Con -> [Q Match]

475+parseArgs :: (String -> String) -- ^ Function to change field names.

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

477+ -> [Q Match]

343-- Nullary constructors.

478-- Nullary constructors.

344parseArgs _ (NormalC conName []) =

479parseArgs _ (NormalC conName []) =

345 [ do arr <- newName "arr"

480 [ do arr <- newName "arr"

346 g <- normalG $ [|V.null|] `appE` varE arr

481 g <- normalG $ [|V.null|] `appE` varE arr

347 e <- [e|pure|] `appE` conE conName

482 e <- [e|pure|] `appE` conE conName

483+ -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e']

484+ -- But first need to have "instance Applicative Q".

348 match (conP 'Array [varP arr])

485 match (conP 'Array [varP arr])

349 (guardedB [return (g, e)])

486 (guardedB [return (g, e)])

350 []

487 []

361 []

498 []

362 ]

499 ]

363

500

364−-- Polyadic constuctors.

501+-- Polyadic constructors.

365parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts

502parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts

366-- Records.

503-- Records.

367parseArgs withField (RecC conName ts) =

504parseArgs withField (RecC conName ts) =

383 []

520 []

384 , errorMatch

521 , errorMatch

385 ]

522 ]

386−-- Infix constructors.

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

524+-- polyadic constructors.

387parseArgs _ (InfixC _ conName _) = parseProduct conName 2

525parseArgs _ (InfixC _ conName _) = parseProduct conName 2

388−-- Existentially quantified constructors.

526+-- Existentially quantified constructors. We ignore the quantifiers

527+-- and proceed with the contained constructor.

389parseArgs withField (ForallC _ _ con) = parseArgs withField con

528parseArgs withField (ForallC _ _ con) = parseArgs withField con

390

529

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

531+-- constructor.

391−parseProduct :: Name -> Integer -> [Q Match]

532+parseProduct :: Name -- ^ 'Con'structor name.

533+ -> Integer -- ^ 'Con'structor arity.

534+ -> [Q Match]

392parseProduct conName numArgs =

535parseProduct conName numArgs =

393 [ do arr <- newName "arr"

536 [ do arr <- newName "arr"

394 g <- normalG $ infixApp ([|V.length|] `appE` varE arr)

537 g <- normalG $ infixApp ([|V.length|] `appE` varE arr)

411 , errorMatch

554 , errorMatch

412 ]

555 ]

413

556

557+-- |

558+-- @

414−-- "_ -> mzero"

559+-- _ -> 'mzero'

560+-- @

415errorMatch :: Q Match

561errorMatch :: Q Match

416errorMatch = match wildP (normalB [|mzero|]) []

562errorMatch = match wildP (normalB [|mzero|]) []

417

563

420-- Utility functions

566-- Utility functions

421--------------------------------------------------------------------------------

567--------------------------------------------------------------------------------

422

568

569+-- | Boilerplate for top level splices.

570+--

571+-- The given 'Name' must be from a type constructor. Furthermore, the

572+-- type constructor must be either a data type or a newtype. Any other

573+-- value will result in an exception.

574+withType :: Name

423−withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a

575+ -> ([TyVarBndr] -> [Con] -> Q a)

576+ -- ^ Function that generates the actual code. Will be applied

577+ -- to the type variable binders and constructors extracted

578+ -- from the given 'Name'.

579+ -> Q a

580+ -- ^ Resulting value in the 'Q'uasi monad.

424withType name f = do

581withType name f = do

425 info <- reify name

582 info <- reify name

426 case info of

583 case info of

432 ++ show other

589 ++ show other

433 _ -> error "Data.Aeson.TH.withType: I need the name of a type."

590 _ -> error "Data.Aeson.TH.withType: I need the name of a type."

434

591

592+-- | Extracts the name from a constructor.

435getConName :: Con -> Name

593getConName :: Con -> Name

436getConName (NormalC name _) = name

594getConName (NormalC name _) = name

437getConName (RecC name _) = name

595getConName (RecC name _) = name

438getConName (InfixC _ name _) = name

596getConName (InfixC _ name _) = name

439getConName (ForallC _ _ con) = getConName con

597getConName (ForallC _ _ con) = getConName con

440

598

599+-- | Extracts the name from a type variable binder.

441tvbName :: TyVarBndr -> Name

600tvbName :: TyVarBndr -> Name

442tvbName (PlainTV name ) = name

601tvbName (PlainTV name ) = name

443tvbName (KindedTV name _) = name

602tvbName (KindedTV name _) = name

444

603

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

445−fieldNameExp :: (String -> String) -> Name -> Q Exp

605+fieldNameExp :: (String -> String) -- ^ Function to change the field name.

606+ -> Name

607+ -> Q Exp

446fieldNameExp f = litE . stringL . f . nameBase

608fieldNameExp f = litE . stringL . f . nameBase

447−

448−conNameExp :: Con -> Q Exp

449−conNameExp = litE . stringL . nameBase . getConName