f3e922b · typeable/aeson

130#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)

131import Data.List (nub)

132#endif

133−import Data.List (find, foldl', genericLength , intercalate , intersperse, partition, union)

133+import Data.List (foldl', genericLength , intercalate , intersperse, partition, union)

134import Data.List.NonEmpty ((<|), NonEmpty((:|)))

135import Data.Map (Map)

136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

140#else

141import Language.Haskell.TH

142#endif

143−import Language.Haskell.TH.Syntax (VarStrictType)

143+import Language.Haskell.TH.Datatype

144#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))

145import Language.Haskell.TH.Lib (starK)

146#endif

152import qualified Data.Aeson.Encoding.Internal as E

153import qualified Data.Foldable as F (all)

154import qualified Data.HashMap.Strict as H (lookup, toList)

155−import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)

155+import qualified Data.List.NonEmpty as NE (length, reverse)

156−import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)

156+import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

157import qualified Data.Set as Set (empty, insert, member)

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

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

322 -- ^ The ToJSON variant being derived.

323 -> Options

324 -- ^ Encoding options.

325− -> [Con]

325+ -> [Type]

326+ -- ^ The types from the data type/data family instance declaration

327+ -> [ConstructorInfo]

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

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

327 -> Q Exp

329 -> Q Exp

328

330

329−consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "

331+consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "

330− ++ "Not a single constructor given!"

332+ ++ "Not a single constructor given!"

331

333

332−consToValue jc opts cons = do

334+consToValue jc opts vars cons = do

333 value <- newName "value"

335 value <- newName "value"

334 tjs <- newNameList "_tj" $ arityInt jc

336 tjs <- newNameList "_tj" $ arityInt jc

335 tjls <- newNameList "_tjl" $ arityInt jc

337 tjls <- newNameList "_tjl" $ arityInt jc

336 let zippedTJs = zip tjs tjls

338 let zippedTJs = zip tjs tjls

337 interleavedTJs = interleave tjs tjls

339 interleavedTJs = interleave tjs tjls

340+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars

341+ tvMap = M.fromList $ zip lastTyVars zippedTJs

338 lamE (map varP $ interleavedTJs ++ [value]) $

342 lamE (map varP $ interleavedTJs ++ [value]) $

339− caseE (varE value) (matches zippedTJs)

343+ caseE (varE value) (matches tvMap)

340 where

344 where

341− matches tjs = case cons of

345+ matches tvMap = case cons of

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

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

343 -- forgotten.

347 -- forgotten.

344− [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]

348+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con]

345 _ | allNullaryToStringTag opts && all isNullary cons ->

349 _ | allNullaryToStringTag opts && all isNullary cons ->

346 [ match (conP conName []) (normalB $ conStr opts conName) []

350 [ match (conP conName []) (normalB $ conStr opts conName) []

347 | con <- cons

351 | con <- cons

348− , let conName = getConName con

352+ , let conName = constructorName con

349 ]

353 ]

350− | otherwise -> [argsToValue jc tjs opts True con | con <- cons]

354+ | otherwise -> [argsToValue jc tvMap opts True con | con <- cons]

351

355

352conStr :: Options -> Name -> Q Exp

356conStr :: Options -> Name -> Q Exp

353conStr opts = appE [|String|] . conTxt opts

357conStr opts = appE [|String|] . conTxt opts

365 -- ^ The ToJSON variant being derived.

369 -- ^ The ToJSON variant being derived.

366 -> Options

370 -> Options

367 -- ^ Encoding options.

371 -- ^ Encoding options.

368− -> [Con]

372+ -> [Type]

373+ -- ^ The types from the data type/data family instance declaration

374+ -> [ConstructorInfo]

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

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

370 -> Q Exp

376 -> Q Exp

371

377

372−consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "

378+consToEncoding _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "

373− ++ "Not a single constructor given!"

379+ ++ "Not a single constructor given!"

374

380

375−consToEncoding jc opts cons = do

381+consToEncoding jc opts vars cons = do

376 value <- newName "value"

382 value <- newName "value"

377 tes <- newNameList "_te" $ arityInt jc

383 tes <- newNameList "_te" $ arityInt jc

378 tels <- newNameList "_tel" $ arityInt jc

384 tels <- newNameList "_tel" $ arityInt jc

379 let zippedTEs = zip tes tels

385 let zippedTEs = zip tes tels

380 interleavedTEs = interleave tes tels

386 interleavedTEs = interleave tes tels

387+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars

388+ tvMap = M.fromList $ zip lastTyVars zippedTEs

381 lamE (map varP $ interleavedTEs ++ [value]) $

389 lamE (map varP $ interleavedTEs ++ [value]) $

382− caseE (varE value) (matches zippedTEs)

390+ caseE (varE value) (matches tvMap)

383 where

391 where

384− matches tes = case cons of

392+ matches tvMap = case cons of

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

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

386 -- forgotten.

394 -- forgotten.

387− [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]

395+ [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tvMap opts False con]

388 -- Encode just the name of the constructor of a sum type iff all the

396 -- Encode just the name of the constructor of a sum type iff all the

389 -- constructors are nullary.

397 -- constructors are nullary.

390 _ | allNullaryToStringTag opts && all isNullary cons ->

398 _ | allNullaryToStringTag opts && all isNullary cons ->

391 [ match (conP conName [])

399 [ match (conP conName [])

392 (normalB $ encStr opts conName) []

400 (normalB $ encStr opts conName) []

393 | con <- cons

401 | con <- cons

394− , let conName = getConName con

402+ , let conName = constructorName con

395 ]

403 ]

396− | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]

404+ | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons]

397

405

398encStr :: Options -> Name -> Q Exp

406encStr :: Options -> Name -> Q Exp

399encStr opts = appE [|E.text|] . conTxt opts

407encStr opts = appE [|E.text|] . conTxt opts

400

408

401-- | If constructor is nullary.

409-- | If constructor is nullary.

402−isNullary :: Con -> Bool

410+isNullary :: ConstructorInfo -> Bool

403−isNullary (NormalC _ []) = True

411+isNullary (ConstructorInfo { constructorVariant = NormalConstructor

412+ , constructorFields = tys }) = null tys

404isNullary _ = False

413isNullary _ = False

405

414

406sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp

415sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp

423 | otherwise = exp

432 | otherwise = exp

424

433

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

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

426−argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match

435+argsToValue :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match

427

436

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

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

429−argsToValue jc tjs opts multiCons (NormalC conName ts) = do

438+argsToValue jc tvMap opts multiCons

430− (argTys, tvMap) <- reifyConTys jc tjs conName

439+ (ConstructorInfo { constructorName = conName

440+ , constructorVariant = NormalConstructor

441+ , constructorFields = argTys }) = do

442+ argTys' <- mapM resolveTypeSynonyms argTys

431− let len = length ts

443+ let len = length argTys'

432 args <- newNameList "arg" len

444 args <- newNameList "arg" len

433 js <- case [ dispatchToJSON jc conName tvMap argTy

445 js <- case [ dispatchToJSON jc conName tvMap argTy

434 `appE` varE arg

446 `appE` varE arg

435− | (arg, argTy) <- zip args argTys

447+ | (arg, argTy) <- zip args argTys'

436 ] of

448 ] of

437 -- Single argument is directly converted.

449 -- Single argument is directly converted.

438 [e] -> return e

450 [e] -> return e

454 (varE 'V.create `appE`

466 (varE 'V.create `appE`

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

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

456 match (conP conName $ map varP args)

468 match (conP conName $ map varP args)

457− (normalB $ sumToValue opts multiCons (null ts) conName js)

469+ (normalB $ sumToValue opts multiCons (null argTys') conName js)

458 []

470 []

459

471

460-- Records.

472-- Records.

473+argsToValue jc tvMap opts multiCons

474+ info@(ConstructorInfo { constructorName = conName

475+ , constructorVariant = RecordConstructor fields

476+ , constructorFields = argTys }) =

461−argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of

477+ case (unwrapUnaryRecords opts, not multiCons, argTys) of

462− (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])

478+ (True,True,[_]) -> argsToValue jc tvMap opts multiCons

479+ (info{constructorVariant = NormalConstructor})

463− _ -> do

480+ _ -> do

464− (argTys, tvMap) <- reifyConTys jc tjs conName

481+ argTys' <- mapM resolveTypeSynonyms argTys

465− args <- newNameList "arg" $ length ts

482+ args <- newNameList "arg" $ length argTys'

466− let exp = [|A.object|] `appE` pairs

483+ let exp = [|A.object|] `appE` pairs

467−

484+

468− pairs | omitNothingFields opts = infixApp maybeFields

485+ pairs | omitNothingFields opts = infixApp maybeFields

469− [|(++)|]

486+ [|(++)|]

470− restFields

487+ restFields

471− | otherwise = listE $ map toPair argCons

488+ | otherwise = listE $ map toPair argCons

472−

489+

473− argCons = zip3 args argTys ts

490+ argCons = zip3 args argTys' fields

474−

491+

475− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

492+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

476−

493+

477− restFields = listE $ map toPair rest

494+ restFields = listE $ map toPair rest

478−

495+

479− (maybes, rest) = partition isMaybe argCons

496+ (maybes, rest) = partition isMaybe argCons

480−

497+

481− maybeToPair (arg, argTy, (field, _, _)) =

498+ maybeToPair (arg, argTy, field) =

482− infixApp ([|keyValuePairWith|]

499+ infixApp ([|keyValuePairWith|]

483− `appE` dispatchToJSON jc conName tvMap argTy

500+ `appE` dispatchToJSON jc conName tvMap argTy

484− `appE` toFieldName field)

501+ `appE` toFieldName field)

485− [|(<$>)|]

502+ [|(<$>)|]

486− (varE arg)

503+ (varE arg)

487−

504+

488− toPair (arg, argTy, (field, _, _)) =

505+ toPair (arg, argTy, field) =

489− [|keyValuePairWith|]

506+ [|keyValuePairWith|]

490− `appE` dispatchToJSON jc conName tvMap argTy

507+ `appE` dispatchToJSON jc conName tvMap argTy

491− `appE` toFieldName field

508+ `appE` toFieldName field

492− `appE` varE arg

509+ `appE` varE arg

493

510

494− toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field

511+ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field

495−

512+

496− match (conP conName $ map varP args)

513+ match (conP conName $ map varP args)

497− ( normalB

514+ ( normalB

498− $ if multiCons

515+ $ if multiCons

499− then case sumEncoding opts of

516+ then case sumEncoding opts of

500− TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]

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

501− TaggedObject{tagFieldName} ->

518+ TaggedObject{tagFieldName} ->

502− [|A.object|] `appE`

519+ [|A.object|] `appE`

503− -- TODO: Maybe throw an error in case

520+ -- TODO: Maybe throw an error in case

504− -- tagFieldName overwrites a field in pairs.

521+ -- tagFieldName overwrites a field in pairs.

505− infixApp (infixApp [|T.pack tagFieldName|]

522+ infixApp (infixApp [|T.pack tagFieldName|]

506− [|(.=)|]

523+ [|(.=)|]

507− (conStr opts conName))

524+ (conStr opts conName))

508− [|(:)|]

525+ [|(:)|]

509− pairs

526+ pairs

510− ObjectWithSingleField ->

527+ ObjectWithSingleField ->

511− [|A.object|] `appE` listE

528+ [|A.object|] `appE` listE

512− [ infixApp (conTxt opts conName) [|(.=)|] exp ]

529+ [ infixApp (conTxt opts conName) [|(.=)|] exp ]

513− UntaggedValue -> exp

530+ UntaggedValue -> exp

514− else exp

531+ else exp

515− ) []

532+ ) []

516

533

517-- Infix constructors.

534-- Infix constructors.

518−argsToValue jc tjs opts multiCons (InfixC _ conName _) = do

535+argsToValue jc tvMap opts multiCons

519− ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName

536+ (ConstructorInfo { constructorName = conName

537+ , constructorVariant = InfixConstructor

538+ , constructorFields = argTys }) = do

539+ [alTy, arTy] <- mapM resolveTypeSynonyms argTys

520 al <- newName "argL"

540 al <- newName "argL"

521 ar <- newName "argR"

541 ar <- newName "argR"

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

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

528 ]

548 ]

529 )

549 )

530 []

550 []

531−-- Existentially quantified constructors.

532−argsToValue jc tjs opts multiCons (ForallC _ _ con) =

533− argsToValue jc tjs opts multiCons con

534−

535−#if MIN_VERSION_template_haskell(2,11,0)

536−-- GADTs.

537−argsToValue jc tjs opts multiCons (GadtC conNames ts _) =

538− argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts

539

551

540−argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =

541− argsToValue jc tjs opts multiCons $ RecC (head conNames) ts

542−#endif

543−

544−isMaybe :: (a, b, (c, d, Type)) -> Bool

552+isMaybe :: (a, Type, b) -> Bool

545−isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe

553+isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe

546−isMaybe _ = False

554+isMaybe _ = False

547

555

548(<^>) :: ExpQ -> ExpQ -> ExpQ

556(<^>) :: ExpQ -> ExpQ -> ExpQ

549(<^>) a b = infixApp a [|(E.><)|] b

557(<^>) a b = infixApp a [|(E.><)|] b

583 | otherwise = exp

591 | otherwise = exp

584

592

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

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

586−argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match

594+argsToEncoding :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match

587

595

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

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

589−argsToEncoding jc tes opts multiCons (NormalC conName ts) = do

597+argsToEncoding jc tvMap opts multiCons

590− (argTys, tvMap) <- reifyConTys jc tes conName

598+ (ConstructorInfo { constructorName = conName

599+ , constructorVariant = NormalConstructor

600+ , constructorFields = argTys }) = do

601+ argTys' <- mapM resolveTypeSynonyms argTys

591− let len = length ts

602+ let len = length argTys'

592 args <- newNameList "arg" len

603 args <- newNameList "arg" len

593− js <- case zip args argTys of

604+ js <- case zip args argTys' of

594 -- Nullary constructors are converted to an empty array.

605 -- Nullary constructors are converted to an empty array.

595 [] -> return [| E.emptyArray_ |]

606 [] -> return [| E.emptyArray_ |]

596

607

604 | (x,xTy) <- es

615 | (x,xTy) <- es

605 ]))

616 ]))

606 match (conP conName $ map varP args)

617 match (conP conName $ map varP args)

607− (normalB $ sumToEncoding opts multiCons (null ts) conName js)

618+ (normalB $ sumToEncoding opts multiCons (null argTys') conName js)

608 []

619 []

609

620

610-- Records.

621-- Records.

622+argsToEncoding jc tvMap opts multiCons

623+ info@(ConstructorInfo { constructorName = conName

624+ , constructorVariant = RecordConstructor fields

625+ , constructorFields = argTys }) = do

611−argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of

626+ case (unwrapUnaryRecords opts, not multiCons, argTys) of

612− (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])

627+ (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons

628+ (info{constructorVariant = NormalConstructor})

613− _ -> do

629+ _ -> do

630+ argTys' <- mapM resolveTypeSynonyms argTys

614− args <- newNameList "arg" $ length ts

631+ args <- newNameList "arg" $ length argTys'

615− (argTys, tvMap) <- reifyConTys jc tes conName

616− let exp = object objBody

632+ let exp = object objBody

617−

633+

618− objBody = [|E.econcat|] `appE`

634+ objBody = [|E.econcat|] `appE`

619− ([|intersperse E.comma|] `appE` pairs)

635+ ([|intersperse E.comma|] `appE` pairs)

620− pairs | omitNothingFields opts = infixApp maybeFields

636+ pairs | omitNothingFields opts = infixApp maybeFields

621− [|(++)|]

637+ [|(++)|]

622− restFields

638+ restFields

623− | otherwise = listE (map toPair argCons)

639+ | otherwise = listE (map toPair argCons)

624−

640+

625− argCons = zip3 args argTys ts

641+ argCons = zip3 args argTys' fields

626−

642+

627− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

643+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

628−

644+

629− restFields = listE (map toPair rest)

645+ restFields = listE (map toPair rest)

630−

646+

631− (maybes, rest) = partition isMaybe argCons

647+ (maybes, rest) = partition isMaybe argCons

632−

648+

633− maybeToPair (arg, argTy, (field, _, _)) =

649+ maybeToPair (arg, argTy, field) =

634− infixApp

650+ infixApp

635− (infixApp

651+ (infixApp

636− (infixE

652+ (infixE

637− (Just $ toFieldName field <^> [|E.colon|])

653+ (Just $ toFieldName field <^> [|E.colon|])

638− [|(E.><)|]

654+ [|(E.><)|]

639− Nothing)

655+ Nothing)

640− [|(.)|]

656+ [|(.)|]

641− (dispatchToEncoding jc conName tvMap argTy))

657+ (dispatchToEncoding jc conName tvMap argTy))

642− [|(<$>)|]

658+ [|(<$>)|]

643− (varE arg)

659+ (varE arg)

644−

660+

645− toPair (arg, argTy, (field, _, _)) =

661+ toPair (arg, argTy, field) =

646− toFieldName field

662+ toFieldName field

647− <:> dispatchToEncoding jc conName tvMap argTy

663+ <:> dispatchToEncoding jc conName tvMap argTy

648− `appE` varE arg

664+ `appE` varE arg

649−

665+

650− toFieldName field = [|E.text|] `appE`

666+ toFieldName field = [|E.text|] `appE`

651− ([|T.pack|] `appE` fieldLabelExp opts field)

667+ ([|T.pack|] `appE` fieldLabelExp opts field)

652−

668+

653− match (conP conName $ map varP args)

669+ match (conP conName $ map varP args)

654− ( normalB

670+ ( normalB

655− $ if multiCons

671+ $ if multiCons

656− then case sumEncoding opts of

672+ then case sumEncoding opts of

657− TwoElemArray -> array $

673+ TwoElemArray -> array $

658− encStr opts conName <%> exp

674+ encStr opts conName <%> exp

659− TaggedObject{tagFieldName} -> object $

675+ TaggedObject{tagFieldName} -> object $

660− ([|E.text (T.pack tagFieldName)|] <:>

676+ ([|E.text (T.pack tagFieldName)|] <:>

661− encStr opts conName) <%>

677+ encStr opts conName) <%>

662− objBody

678+ objBody

663− ObjectWithSingleField -> object $

679+ ObjectWithSingleField -> object $

664− encStr opts conName <:> exp

680+ encStr opts conName <:> exp

665− UntaggedValue -> exp

681+ UntaggedValue -> exp

666− else exp

682+ else exp

667− ) []

683+ ) []

668

684

669-- Infix constructors.

685-- Infix constructors.

670−argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do

686+argsToEncoding jc tvMap opts multiCons

687+ (ConstructorInfo { constructorName = conName

688+ , constructorVariant = InfixConstructor

689+ , constructorFields = argTys }) = do

671 al <- newName "argL"

690 al <- newName "argL"

672 ar <- newName "argR"

691 ar <- newName "argR"

673− ([alTy,arTy], tvMap) <- reifyConTys jc tes conName

692+ [alTy,arTy] <- mapM resolveTypeSynonyms argTys

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

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

675 ( normalB

694 ( normalB

676 $ sumToEncoding opts multiCons False conName

695 $ sumToEncoding opts multiCons False conName

680 ])

699 ])

681 )

700 )

682 []

701 []

683−-- Existentially quantified constructors.

684−argsToEncoding jc tes opts multiCons (ForallC _ _ con) =

685− argsToEncoding jc tes opts multiCons con

686−

687−#if MIN_VERSION_template_haskell(2,11,0)

688−-- GADTs.

689−argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =

690− argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts

691−

692−argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =

693− argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts

694−#endif

695

702

696--------------------------------------------------------------------------------

703--------------------------------------------------------------------------------

697-- FromJSON

704-- FromJSON

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

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

776 -> Options

783 -> Options

777 -- ^ Encoding options

784 -- ^ Encoding options

778− -> [Con]

785+ -> [Type]

786+ -- ^ The types from the data type/data family instance declaration

787+ -> [ConstructorInfo]

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

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

780 -> Q Exp

789 -> Q Exp

781

790

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

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

783− ++ "Not a single constructor given!"

792+ ++ "Not a single constructor given!"

784

793

785−consFromJSON jc tName opts cons = do

794+consFromJSON jc tName opts vars cons = do

786 value <- newName "value"

795 value <- newName "value"

787 pjs <- newNameList "_pj" $ arityInt jc

796 pjs <- newNameList "_pj" $ arityInt jc

788 pjls <- newNameList "_pjl" $ arityInt jc

797 pjls <- newNameList "_pjl" $ arityInt jc

789 let zippedPJs = zip pjs pjls

798 let zippedPJs = zip pjs pjls

790 interleavedPJs = interleave pjs pjls

799 interleavedPJs = interleave pjs pjls

800+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars

801+ tvMap = M.fromList $ zip lastTyVars zippedPJs

791− lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs

802+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap

792

803

793 where

804 where

805+ checkExi tvMap con = checkExistentialContext jc tvMap

806+ (constructorContext con)

807+ (constructorName con)

808+

794− lamExpr value pjs = case cons of

809+ lamExpr value tvMap = case cons of

795 [con]

810 [con]

796 | not (tagSingleConstructors opts)

811 | not (tagSingleConstructors opts)

797− -> parseArgs jc pjs tName opts con (Right value)

812+ -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)

798 _ | sumEncoding opts == UntaggedValue

813 _ | sumEncoding opts == UntaggedValue

799− -> parseUntaggedValue pjs cons value

814+ -> parseUntaggedValue tvMap cons value

800 | otherwise

815 | otherwise

801 -> caseE (varE value) $

816 -> caseE (varE value) $

802 if allNullaryToStringTag opts && all isNullary cons

817 if allNullaryToStringTag opts && all isNullary cons

803 then allNullaryMatches

818 then allNullaryMatches

804− else mixedMatches pjs

819+ else mixedMatches tvMap

805

820

806 allNullaryMatches =

821 allNullaryMatches =

807 [ do txt <- newName "txt"

822 [ do txt <- newName "txt"

815 )

830 )

816 ([|pure|] `appE` conE conName)

831 ([|pure|] `appE` conE conName)

817 | con <- cons

832 | con <- cons

818− , let conName = getConName con

833+ , let conName = constructorName con

819 ]

834 ]

820 ++

835 ++

821 [ liftM2 (,)

836 [ liftM2 (,)

836 []

851 []

837 ]

852 ]

838

853

839− mixedMatches pjs =

854+ mixedMatches tvMap =

840 case sumEncoding opts of

855 case sumEncoding opts of

841 TaggedObject {tagFieldName, contentsFieldName} ->

856 TaggedObject {tagFieldName, contentsFieldName} ->

842− parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName

857+ parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName

843 UntaggedValue -> error "UntaggedValue: Should be handled already"

858 UntaggedValue -> error "UntaggedValue: Should be handled already"

844 ObjectWithSingleField ->

859 ObjectWithSingleField ->

845− parseObject $ parseObjectWithSingleField pjs

860+ parseObject $ parseObjectWithSingleField tvMap

846 TwoElemArray ->

861 TwoElemArray ->

847 [ do arr <- newName "array"

862 [ do arr <- newName "array"

848 match (conP 'Array [varP arr])

863 match (conP 'Array [varP arr])

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

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

851 [|(==)|]

866 [|(==)|]

852 (litE $ integerL 2))

867 (litE $ integerL 2))

853− (parse2ElemArray pjs arr)

868+ (parse2ElemArray tvMap arr)

854 , liftM2 (,) (normalG [|otherwise|])

869 , liftM2 (,) (normalG [|otherwise|])

855 ([|not2ElemArray|]

870 ([|not2ElemArray|]

856 `appE` litE (stringL $ show tName)

871 `appE` litE (stringL $ show tName)

881 []

896 []

882 ]

897 ]

883

898

884− parseTaggedObject pjs typFieldName valFieldName obj = do

899+ parseTaggedObject tvMap typFieldName valFieldName obj = do

885 conKey <- newName "conKey"

900 conKey <- newName "conKey"

886 doE [ bindS (varP conKey)

901 doE [ bindS (varP conKey)

887 (infixApp (varE obj)

902 (infixApp (varE obj)

888 [|(.:)|]

903 [|(.:)|]

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

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

890− , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject

905+ , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject

891 ]

906 ]

892

907

893− parseUntaggedValue pjs cons' conVal =

908+ parseUntaggedValue tvMap cons' conVal =

894 foldr1 (\e e' -> infixApp e [|(<|>)|] e')

909 foldr1 (\e e' -> infixApp e [|(<|>)|] e')

895− (map (\x -> parseValue pjs x conVal) cons')

910+ (map (\x -> parseValue tvMap x conVal) cons')

896

911

897− parseValue _pjs (NormalC conName []) conVal = do

912+ parseValue _tvMap

913+ (ConstructorInfo { constructorName = conName

914+ , constructorVariant = NormalConstructor

915+ , constructorFields = [] })

916+ conVal = do

898 str <- newName "str"

917 str <- newName "str"

899 caseE (varE conVal)

918 caseE (varE conVal)

900 [ match (conP 'String [varP str])

919 [ match (conP 'String [varP str])

907 []

926 []

908 , matchFailed tName conName "String"

927 , matchFailed tName conName "String"

909 ]

928 ]

910− parseValue pjs con conVal =

929+ parseValue tvMap con conVal =

911− parseArgs jc pjs tName opts con (Right conVal)

930+ checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)

912

931

913

932

914− parse2ElemArray pjs arr = do

933+ parse2ElemArray tvMap arr = do

915 conKey <- newName "conKey"

934 conKey <- newName "conKey"

916 conVal <- newName "conVal"

935 conVal <- newName "conVal"

917 let letIx n ix =

936 let letIx n ix =

926 (caseE (varE conKey)

945 (caseE (varE conKey)

927 [ do txt <- newName "txt"

946 [ do txt <- newName "txt"

928 match (conP 'String [varP txt])

947 match (conP 'String [varP txt])

929− (normalB $ parseContents pjs

948+ (normalB $ parseContents tvMap

930 txt

949 txt

931 (Right conVal)

950 (Right conVal)

932 'conNotFoundFail2ElemArray

951 'conNotFoundFail2ElemArray

943 ]

962 ]

944 )

963 )

945

964

946− parseObjectWithSingleField pjs obj = do

965+ parseObjectWithSingleField tvMap obj = do

947 conKey <- newName "conKey"

966 conKey <- newName "conKey"

948 conVal <- newName "conVal"

967 conVal <- newName "conVal"

949 caseE ([e|H.toList|] `appE` varE obj)

968 caseE ([e|H.toList|] `appE` varE obj)

950 [ match (listP [tupP [varP conKey, varP conVal]])

969 [ match (listP [tupP [varP conKey, varP conVal]])

951− (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)

970+ (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)

952 []

971 []

953 , do other <- newName "other"

972 , do other <- newName "other"

954 match (varP other)

973 match (varP other)

959 []

978 []

960 ]

979 ]

961

980

962− parseContents pjs conKey contents errorFun =

981+ parseContents tvMap conKey contents errorFun =

963 caseE (varE conKey)

982 caseE (varE conKey)

964 [ match wildP

983 [ match wildP

965 ( guardedB $

984 ( guardedB $

967 [|(==)|]

986 [|(==)|]

968 ([|T.pack|] `appE`

987 ([|T.pack|] `appE`

969 conNameExp opts con)

988 conNameExp opts con)

989+ e <- checkExi tvMap con $

970− e <- parseArgs jc pjs tName opts con contents

990+ parseArgs jc tvMap tName opts con contents

971 return (g, e)

991 return (g, e)

972 | con <- cons

992 | con <- cons

973 ]

993 ]

980 . stringL

1000 . stringL

981 . constructorTagModifier opts

1001 . constructorTagModifier opts

982 . nameBase

1002 . nameBase

983− . getConName

1003+ . constructorName

984 ) cons

1004 ) cons

985 )

1005 )

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

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

1029 -> Options

1049 -> Options

1030 -> Name

1050 -> Name

1031 -> Name

1051 -> Name

1032− -> [VarStrictType]

1052+ -> [Name]

1033 -> Name

1053 -> Name

1034 -> ExpQ

1054 -> ExpQ

1035−parseRecord jc tvMap argTys opts tName conName ts obj =

1055+parseRecord jc tvMap argTys opts tName conName fields obj =

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

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

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

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

1038 xs

1058 xs

1044 `appE` varE obj

1064 `appE` varE obj

1045 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field

1065 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field

1046 )

1066 )

1047− | ((field, _, _), argTy) <- zip ts argTys

1067+ | (field, argTy) <- zip fields argTys

1048 ]

1068 ]

1049

1069

1050getValField :: Name -> String -> [MatchQ] -> Q Exp

1070getValField :: Name -> String -> [MatchQ] -> Q Exp

1063

1083

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

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

1065parseArgs :: JSONClass -- ^ The FromJSON variant being derived.

1085parseArgs :: JSONClass -- ^ The FromJSON variant being derived.

1086+ -> TyVarMap -- ^ Maps the last type variables to their decoding

1066− -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.

1087+ -- function arguments.

1067 -> Name -- ^ Name of the type to which the constructor belongs.

1088 -> Name -- ^ Name of the type to which the constructor belongs.

1068 -> Options -- ^ Encoding options.

1089 -> Options -- ^ Encoding options.

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

1090+ -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.

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

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

1071 -- Right valName

1092 -- Right valName

1072 -> Q Exp

1093 -> Q Exp

1073-- Nullary constructors.

1094-- Nullary constructors.

1074−parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do

1095+parseArgs _ _ _ _

1075− ([], _) <- reifyConTys jc pjs conName

1096+ (ConstructorInfo { constructorName = conName

1097+ , constructorVariant = NormalConstructor

1098+ , constructorFields = [] })

1099+ (Left _) =

1076− [|pure|] `appE` conE conName

1100+ [|pure|] `appE` conE conName

1077−parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do

1101+parseArgs _ _ tName _

1078− ([], _) <- reifyConTys jc pjs conName

1102+ (ConstructorInfo { constructorName = conName

1103+ , constructorVariant = NormalConstructor

1104+ , constructorFields = [] })

1105+ (Right valName) =

1079− caseE (varE valName) $ parseNullaryMatches tName conName

1106+ caseE (varE valName) $ parseNullaryMatches tName conName

1080

1107

1081-- Unary constructors.

1108-- Unary constructors.

1082−parseArgs jc pjs _ _ (NormalC conName [_]) contents = do

1109+parseArgs jc tvMap _ _

1083− ([argTy], tvMap) <- reifyConTys jc pjs conName

1110+ (ConstructorInfo { constructorName = conName

1111+ , constructorVariant = NormalConstructor

1112+ , constructorFields = [argTy] })

1113+ contents = do

1114+ argTy' <- resolveTypeSynonyms argTy

1084− matchCases contents $ parseUnaryMatches jc tvMap argTy conName

1115+ matchCases contents $ parseUnaryMatches jc tvMap argTy' conName

1085

1116

1086-- Polyadic constructors.

1117-- Polyadic constructors.

1087−parseArgs jc pjs tName _ (NormalC conName ts) contents = do

1118+parseArgs jc tvMap tName _

1088− (argTys, tvMap) <- reifyConTys jc pjs conName

1119+ (ConstructorInfo { constructorName = conName

1120+ , constructorVariant = NormalConstructor

1121+ , constructorFields = argTys })

1122+ contents = do

1123+ argTys' <- mapM resolveTypeSynonyms argTys

1089− let len = genericLength ts

1124+ let len = genericLength argTys'

1090− matchCases contents $ parseProduct jc tvMap argTys tName conName len

1125+ matchCases contents $ parseProduct jc tvMap argTys' tName conName len

1091

1126

1092-- Records.

1127-- Records.

1093−parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do

1128+parseArgs jc tvMap tName opts

1094− (argTys, tvMap) <- reifyConTys jc pjs conName

1129+ (ConstructorInfo { constructorName = conName

1130+ , constructorVariant = RecordConstructor fields

1131+ , constructorFields = argTys })

1132+ (Left (_, obj)) = do

1133+ argTys' <- mapM resolveTypeSynonyms argTys

1095− parseRecord jc tvMap argTys opts tName conName ts obj

1134+ parseRecord jc tvMap argTys' opts tName conName fields obj

1135+parseArgs jc tvMap tName opts

1136+ info@(ConstructorInfo { constructorName = conName

1137+ , constructorVariant = RecordConstructor fields

1138+ , constructorFields = argTys })

1139+ (Right valName) =

1096−parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of

1140+ case (unwrapUnaryRecords opts,argTys) of

1097− (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)

1141+ (True,[_])-> parseArgs jc tvMap tName opts

1142+ (info{constructorVariant = NormalConstructor})

1143+ (Right valName)

1098− _ -> do

1144+ _ -> do

1099− obj <- newName "recObj"

1145+ obj <- newName "recObj"

1100− (argTys, tvMap) <- reifyConTys jc pjs conName

1146+ argTys' <- mapM resolveTypeSynonyms argTys

1101− caseE (varE valName)

1147+ caseE (varE valName)

1102− [ match (conP 'Object [varP obj]) (normalB $

1148+ [ match (conP 'Object [varP obj]) (normalB $

1103− parseRecord jc tvMap argTys opts tName conName ts obj) []

1149+ parseRecord jc tvMap argTys' opts tName conName fields obj) []

1104− , matchFailed tName conName "Object"

1150+ , matchFailed tName conName "Object"

1105− ]

1151+ ]

1106

1152

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

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

1108-- polyadic constructors.

1154-- polyadic constructors.

1109−parseArgs jc pjs tName _ (InfixC _ conName _) contents = do

1155+parseArgs jc tvMap tName _

1110− (argTys, tvMap) <- reifyConTys jc pjs conName

1156+ (ConstructorInfo { constructorName = conName

1157+ , constructorVariant = InfixConstructor

1158+ , constructorFields = argTys })

1159+ contents = do

1160+ argTys' <- mapM resolveTypeSynonyms argTys

1111− matchCases contents $ parseProduct jc tvMap argTys tName conName 2

1161+ matchCases contents $ parseProduct jc tvMap argTys' tName conName 2

1112−

1113−-- Existentially quantified constructors. We ignore the quantifiers

1114−-- and proceed with the contained constructor.

1115−parseArgs jc pjs tName opts (ForallC _ _ con) contents =

1116− parseArgs jc pjs tName opts con contents

1117−

1118−#if MIN_VERSION_template_haskell(2,11,0)

1119−-- GADTs. We ignore the refined return type and proceed as if it were a

1120−-- NormalC or RecC.

1121−parseArgs jc pjs tName opts (GadtC conNames ts _) contents =

1122− parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents

1123−

1124−parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =

1125− parseArgs jc pjs tName opts (RecC (head conNames) ts) contents

1126−#endif

1127

1162

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

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

1129-- constructor.

1164-- constructor.

1278 liftM2 (++) (dtj opts name) (dfj opts name)

1313 liftM2 (++) (dtj opts name) (dfj opts name)

1279

1314

1280-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.

1315-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.

1281−deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]

1316+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]

1317+ -> [ConstructorInfo] -> Q Exp)]

1282 -- ^ The class methods and the functions which derive them.

1318 -- ^ The class methods and the functions which derive them.

1283 -> JSONClass

1319 -> JSONClass

1284 -- ^ The class for which to generate an instance.

1320 -- ^ The class for which to generate an instance.

1288 -- ^ Name of the type for which to generate a class instance

1324 -- ^ Name of the type for which to generate a class instance

1289 -- declaration.

1325 -- declaration.

1290 -> Q [Dec]

1326 -> Q [Dec]

1291−deriveJSONClass consFuns jc opts name =

1327+deriveJSONClass consFuns jc opts name = do

1292− withType name $ \name' ctxt tvbs cons mbTys ->

1328+ info <- reifyDatatype name

1293− (:[]) <$> fromCons name' ctxt tvbs cons mbTys

1329+ case info of

1294− where

1330+ DatatypeInfo { datatypeContext = ctxt

1295− fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec

1331+ , datatypeName = parentName

1296− fromCons name' ctxt tvbs cons mbTys = do

1332+ , datatypeVars = vars

1333+ , datatypeVariant = variant

1334+ , datatypeCons = cons

1335+ } -> do

1297 (instanceCxt, instanceType)

1336 (instanceCxt, instanceType)

1298− <- buildTypeInstance name' jc ctxt tvbs mbTys

1337+ <- buildTypeInstance parentName jc ctxt vars variant

1299− instanceD (return instanceCxt)

1338+ (:[]) <$> instanceD (return instanceCxt)

1300− (return instanceType)

1339+ (return instanceType)

1301− (methodDecs name' cons)

1340+ (methodDecs parentName vars cons)

1302−

1341+ where

1303− methodDecs :: Name -> [Con] -> [Q Dec]

1342+ methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]

1304− methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->

1343+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->

1305 funD (jsonFunValName jf (arity jc))

1344 funD (jsonFunValName jf (arity jc))

1306 [ clause []

1345 [ clause []

1307− (normalB $ jfMaker jc name' opts cons)

1346+ (normalB $ jfMaker jc parentName opts vars cons)

1308 []

1347 []

1309 ]

1348 ]

1310

1349

1311−mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)

1350+mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)

1312 -- ^ The function which derives the expression.

1351 -- ^ The function which derives the expression.

1313 -> JSONClass

1352 -> JSONClass

1314 -- ^ Which class's method is being derived.

1353 -- ^ Which class's method is being derived.

1317 -> Name

1356 -> Name

1318 -- ^ Name of the encoded type.

1357 -- ^ Name of the encoded type.

1319 -> Q Exp

1358 -> Q Exp

1320−mkFunCommon consFun jc opts name = withType name fromCons

1359+mkFunCommon consFun jc opts name = do

1321− where

1360+ info <- reifyDatatype name

1322− fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp

1361+ case info of

1323− fromCons name' ctxt tvbs cons mbTys = do

1362+ DatatypeInfo { datatypeContext = ctxt

1363+ , datatypeName = parentName

1364+ , datatypeVars = vars

1365+ , datatypeVariant = variant

1366+ , datatypeCons = cons

1367+ } -> do

1324− -- We force buildTypeInstance here since it performs some checks for whether

1368+ -- We force buildTypeInstance here since it performs some checks for whether

1325− -- or not the provided datatype's kind matches the derived method's

1369+ -- or not the provided datatype's kind matches the derived method's

1326− -- typeclass, and produces errors if it can't.

1370+ -- typeclass, and produces errors if it can't.

1327− !_ <- buildTypeInstance name' jc ctxt tvbs mbTys

1371+ !_ <- buildTypeInstance parentName jc ctxt vars variant

1328− consFun jc name' opts cons

1372+ consFun jc parentName opts vars cons

1329

1373

1330dispatchFunByType :: JSONClass

1374dispatchFunByType :: JSONClass

1331 -> JSONFun

1375 -> JSONFun

1380-- Utility functions

1424-- Utility functions

1381--------------------------------------------------------------------------------

1425--------------------------------------------------------------------------------

1382

1426

1383−-- | Boilerplate for top level splices.

1427+-- For the given Types, generate an instance context and head.

1384−--

1385−-- The given 'Name' must meet one of two criteria:

1386−--

1387−-- 1. It must be the name of a type constructor of a plain data type or newtype.

1388−-- 2. It must be the name of a data family instance or newtype instance constructor.

1389−

1390−-- Any other value will result in an exception.

1391−withType :: Name

1392− -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)

1393− -- ^ Function that generates the actual code. Will be applied

1394− -- to the datatype/data family 'Name', datatype context, type

1395− -- variable binders and constructors extracted from the given

1396− -- 'Name'. If the 'Name' is from a data family instance

1397− -- constructor, it will also have its instantiated types;

1398− -- otherwise, it will be 'Nothing'.

1399− -> Q a

1400− -- ^ Resulting value in the 'Q'uasi monad.

1401−withType name f = do

1402− info <- reify name

1403− case info of

1404− TyConI dec ->

1405− case dec of

1406−#if MIN_VERSION_template_haskell(2,11,0)

1407− DataD ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing

1408− NewtypeD ctxt _ tvbs _ con _ -> f name ctxt tvbs [con] Nothing

1409−#else

1410− DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing

1411− NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing

1412−#endif

1413− other -> fail $ ns ++ "Unsupported type: " ++ show other

1414−#if MIN_VERSION_template_haskell(2,11,0)

1415− DataConI _ _ parentName -> do

1416−#else

1417− DataConI _ _ parentName _ -> do

1418−#endif

1419− parentInfo <- reify parentName

1420− case parentInfo of

1421−#if MIN_VERSION_template_haskell(2,11,0)

1422− FamilyI (DataFamilyD _ tvbs _) decs ->

1423−#else

1424− FamilyI (FamilyD DataFam _ tvbs _) decs ->

1425−#endif

1426− let instDec = flip find decs $ \dec -> case dec of

1427−#if MIN_VERSION_template_haskell(2,11,0)

1428− DataInstD _ _ _ _ cons _ -> any ((name ==) . getConName) cons

1429− NewtypeInstD _ _ _ _ con _ -> name == getConName con

1430−#else

1431− DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons

1432− NewtypeInstD _ _ _ con _ -> name == getConName con

1433−#endif

1434− _ -> error $ ns ++ "Must be a data or newtype instance."

1435− in case instDec of

1436−#if MIN_VERSION_template_haskell(2,11,0)

1437− Just (DataInstD ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys

1438− Just (NewtypeInstD ctxt _ instTys _ con _) -> f parentName ctxt tvbs [con] $ Just instTys

1439−#else

1440− Just (DataInstD ctxt _ instTys cons _) -> f parentName ctxt tvbs cons $ Just instTys

1441− Just (NewtypeInstD ctxt _ instTys con _) -> f parentName ctxt tvbs [con] $ Just instTys

1442−#endif

1443− _ -> fail $ ns ++

1444− "Could not find data or newtype instance constructor."

1445− _ -> fail $ ns ++ "Data constructor " ++ show name ++

1446− " is not from a data family instance constructor."

1447−#if MIN_VERSION_template_haskell(2,11,0)

1448− FamilyI DataFamilyD{} _ ->

1449−#else

1450− FamilyI (FamilyD DataFam _ _ _) _ ->

1451−#endif

1452− fail $ ns ++

1453− "Cannot use a data family name. Use a data family instance constructor instead."

1454− _ -> fail $ ns ++ "I need the name of a plain data type constructor, "

1455− ++ "or a data family instance constructor."

1456− where

1457− ns :: String

1458− ns = "Data.Aeson.TH.withType: "

1459−

1460−-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.

1461buildTypeInstance :: Name

1428buildTypeInstance :: Name

1462 -- ^ The type constructor or data family name

1429 -- ^ The type constructor or data family name

1463 -> JSONClass

1430 -> JSONClass

1464 -- ^ The typeclass to derive

1431 -- ^ The typeclass to derive

1465 -> Cxt

1432 -> Cxt

1466 -- ^ The datatype context

1433 -- ^ The datatype context

1467− -> [TyVarBndr]

1434+ -> [Type]

1468− -- ^ The type variables from the data type/data family declaration

1435+ -- ^ The types to instantiate the instance with

1469− -> Maybe [Type]

1436+ -> DatatypeVariant

1470− -- ^ 'Just' the types used to instantiate a data family instance,

1437+ -- ^ Are we dealing with a data family instance or not

1471− -- or 'Nothing' if it's a plain data type

1472 -> Q (Cxt, Type)

1438 -> Q (Cxt, Type)

1473− -- ^ The resulting 'Cxt' and 'Type' to use in a class instance

1474−-- Plain data type/newtype case

1475−buildTypeInstance tyConName jc dataCxt tvbs Nothing =

1476− let varTys :: [Type]

1477− varTys = map tvbToType tvbs

1478− in buildTypeInstanceFromTys tyConName jc dataCxt varTys False

1479−-- Data family instance case

1480−--

1481−-- The CPP is present to work around a couple of annoying old GHC bugs.

1482−-- See Note [Polykinded data families in Template Haskell]

1483−buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do

1484−#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)

1485− let instTys :: [Type]

1486− instTys = zipWith stealKindForType tvbs instTysAndKinds

1487−#else

1488− let kindVarNames :: [Name]

1489− kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs

1490−

1491− numKindVars :: Int

1492− numKindVars = length kindVarNames

1493−

1494− givenKinds, givenKinds' :: [Kind]

1495− givenTys :: [Type]

1496− (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds

1497− givenKinds' = map sanitizeStars givenKinds

1498−

1499− -- A GHC 7.6-specific bug requires us to replace all occurrences of

1500− -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.

1501− -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.

1502− sanitizeStars :: Kind -> Kind

1503− sanitizeStars = go

1504− where

1505− go :: Kind -> Kind

1506− go (AppT t1 t2) = AppT (go t1) (go t2)

1507− go (SigT t k) = SigT (go t) (go k)

1508− go (ConT n) | n == starKindName = StarT

1509− go t = t

1510−

1511− -- It's quite awkward to import * from GHC.Prim, so we'll just

1512− -- hack our way around it.

1513− starKindName :: Name

1514− starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"

1515−

1516− -- If we run this code with GHC 7.8, we might have to generate extra type

1517− -- variables to compensate for any type variables that Template Haskell

1518− -- eta-reduced away.

1519− -- See Note [Polykinded data families in Template Haskell]

1520− xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)

1521−

1522− let xTys :: [Type]

1523− xTys = map VarT xTypeNames

1524− -- ^ Because these type variables were eta-reduced away, we can only

1525− -- determine their kind by using stealKindForType. Therefore, we mark

1526− -- them as VarT to ensure they will be given an explicit kind annotation

1527− -- (and so the kind inference machinery has the right information).

1528−

1529− substNamesWithKinds :: [(Name, Kind)] -> Type -> Type

1530− substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks

1531−

1532− -- The types from the data family instance might not have explicit kind

1533− -- annotations, which the kind machinery needs to work correctly. To

1534− -- compensate, we use stealKindForType to explicitly annotate any

1535− -- types without kind annotations.

1536− instTys :: [Type]

1537− instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))

1538− -- Note that due to a GHC 7.8-specific bug

1539− -- (see Note [Polykinded data families in Template Haskell]),

1540− -- there may be more kind variable names than there are kinds

1541− -- to substitute. But this is OK! If a kind is eta-reduced, it

1542− -- means that is was not instantiated to something more specific,

1543− -- so we need not substitute it. Using stealKindForType will

1544− -- grab the correct kind.

1545− $ zipWith stealKindForType tvbs (givenTys ++ xTys)

1546−#endif

1547− buildTypeInstanceFromTys dataFamName jc dataCxt instTys True

1548−

1549−-- For the given Types, generate an instance context and head.

1550−buildTypeInstanceFromTys :: Name

1551− -- ^ The type constructor or data family name

1552− -> JSONClass

1553− -- ^ The typeclass to derive

1554− -> Cxt

1555− -- ^ The datatype context

1556− -> [Type]

1557− -- ^ The types to instantiate the instance with

1558− -> Bool

1559− -- ^ True if it's a data family, False otherwise

1560− -> Q (Cxt, Type)

1561−buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do

1439+buildTypeInstance tyConName jc dataCxt varTysOrig variant = do

1562 -- Make sure to expand through type/kind synonyms! Otherwise, the

1440 -- Make sure to expand through type/kind synonyms! Otherwise, the

1563 -- eta-reduction check might get tripped up over type variables in a

1441 -- eta-reduction check might get tripped up over type variables in a

1564 -- synonym that are actually dropped.

1442 -- synonym that are actually dropped.

1565 -- (See GHC Trac #11416 for a scenario where this actually happened.)

1443 -- (See GHC Trac #11416 for a scenario where this actually happened.)

1566− varTysExp <- mapM expandSyn varTysOrig

1444+ varTysExp <- mapM resolveTypeSynonyms varTysOrig

1567

1445

1568 let remainingLength :: Int

1446 let remainingLength :: Int

1569 remainingLength = length varTysOrig - arityInt jc

1447 remainingLength = length varTysOrig - arityInt jc

1593 -- All of the type variables mentioned in the dropped types

1471 -- All of the type variables mentioned in the dropped types

1594 -- (post-synonym expansion)

1472 -- (post-synonym expansion)

1595 droppedTyVarNames :: [Name]

1473 droppedTyVarNames :: [Name]

1596− droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst

1474+ droppedTyVarNames = freeVariables droppedTysExpSubst

1597

1475

1598 -- If any of the dropped types were polykinded, ensure that they are of kind *

1476 -- If any of the dropped types were polykinded, ensure that they are of kind *

1599 -- after substituting * for the dropped kind variables. If not, throw an error.

1477 -- after substituting * for the dropped kind variables. If not, throw an error.

1634 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))

1512 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))

1635 $ take remainingLength varTysOrig

1513 $ take remainingLength varTysOrig

1636

1514

1515+ isDataFamily :: Bool

1516+ isDataFamily = case variant of

1517+ Datatype -> False

1518+ Newtype -> False

1519+ DataInstance -> True

1520+ NewtypeInstance -> True

1521+

1637 remainingTysOrigSubst' :: [Type]

1522 remainingTysOrigSubst' :: [Type]

1638 -- See Note [Kind signatures in derived instances] for an explanation

1523 -- See Note [Kind signatures in derived instances] for an explanation

1639 -- of the isDataFamily check.

1524 -- of the isDataFamily check.

1687 jcConstraint = jsonClassName . JSONClass (direction jc)

1572 jcConstraint = jsonClassName . JSONClass (direction jc)

1688

1573

1689{-

1574{-

1690−Note [Polykinded data families in Template Haskell]

1691−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1692−

1693−In order to come up with the correct instance context and head for an instance, e.g.,

1694−

1695− instance C a => C (Data a) where ...

1696−

1697−We need to know the exact types and kinds used to instantiate the instance. For

1698−plain old datatypes, this is simple: every type must be a type variable, and

1699−Template Haskell reliably tells us the type variables and their kinds.

1700−

1701−Doing the same for data families proves to be much harder for three reasons:

1702−

1703−1. On any version of Template Haskell, it may not tell you what an instantiated

1704− type's kind is. For instance, in the following data family instance:

1705−

1706− data family Fam (f :: * -> *) (a :: *)

1707− data instance Fam f a

1708−

1709− Then if we use TH's reify function, it would tell us the TyVarBndrs of the

1710− data family declaration are:

1711−

1712− [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]

1713−

1714− and the instantiated types of the data family instance are:

1715−

1716− [VarT f1,VarT a1]

1717−

1718− We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we

1719− have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the

1720− kind is in case an instantiated type isn't a SigT, so we use the stealKindForType

1721− function to ensure all of the instantiated types are SigTs before passing them

1722− to buildTypeInstanceFromTys.

1723−2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of

1724− the specified kinds of a data family instance efore any of the instantiated

1725− types. Fortunately, this is easy to deal with: you simply count the number of

1726− distinct kind variables in the data family declaration, take that many elements

1727− from the front of the Types list of the data family instance, substitute the

1728− kind variables with their respective instantiated kinds (which you took earlier),

1729− and proceed as normal.

1730−3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template

1731− Haskell might not even list all of the Types of a data family instance, since

1732− they are eta-reduced away! And yes, kinds can be eta-reduced too.

1733−

1734− The simplest workaround is to count how many instantiated types are missing from

1735− the list and generate extra type variables to use in their place. Luckily, we

1736− needn't worry much if its kind was eta-reduced away, since using stealKindForType

1737− will get it back.

1738−

1739Note [Kind signatures in derived instances]

1575Note [Kind signatures in derived instances]

1740~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1576~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1741

1577

1813 and perform kind substitution as in the other cases.

1649 and perform kind substitution as in the other cases.

1814-}

1650-}

1815

1651

1816−-- Determines the types of a constructor's arguments as well as the last type

1652+checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name

1817−-- parameters (mapped to their encoding/decoding functions), expanding through

1653+ -> Q a -> Q a

1818−-- any type synonyms.

1654+checkExistentialContext jc tvMap ctxt conName q =

1819−--

1820−-- The type parameters are determined on a constructor-by-constructor basis since

1821−-- they may be refined to be particular types in a GADT.

1822−reifyConTys :: JSONClass

1823− -> [(Name, Name)]

1824− -> Name

1825− -> Q ([Type], TyVarMap)

1826−reifyConTys jc tpjs conName = do

1827− info <- reify conName

1828− (ctxt, uncTy) <- case info of

1829− DataConI _ ty _

1830−#if !(MIN_VERSION_template_haskell(2,11,0))

1831− _

1832−#endif

1833− -> fmap uncurryTy (expandSyn ty)

1834− _ -> error "Must be a data constructor"

1835− let (argTys, [resTy]) = NE.splitAt (NE.length uncTy - 1) uncTy

1836− unapResTy = unapplyTy resTy

1837− -- If one of the last type variables is refined to a particular type

1838− -- (i.e., not truly polymorphic), we mark it with Nothing and filter

1839− -- it out later, since we only apply encoding/decoding functions to

1840− -- arguments of a type that it (1) one of the last type variables,

1841− -- and (2) of a truly polymorphic type.

1842− jArity = arityInt jc

1843− mbTvNames = map varTToNameMaybe $

1844− NE.drop (NE.length unapResTy - jArity) unapResTy

1845− -- We use M.fromList to ensure that if there are any duplicate type

1846− -- variables (as can happen in a GADT), the rightmost type variable gets

1847− -- associated with the show function.

1848− --

1849− -- See Note [Matching functions with GADT type variables]

1850− tvMap = M.fromList

1851− . catMaybes -- Drop refined types

1852− $ zipWith (\mbTvName tpj ->

1853− fmap (\tvName -> (tvName, tpj)) mbTvName)

1854− mbTvNames tpjs

1855− if (any (`predMentionsName` M.keys tvMap) ctxt

1655+ if (any (`predMentionsName` M.keys tvMap) ctxt

1856− || M.size tvMap < jArity)

1656+ || M.size tvMap < arityInt jc)

1857− && not (allowExQuant jc)

1657+ && not (allowExQuant jc)

1858− then existentialContextError conName

1658+ then existentialContextError conName

1859− else return (argTys, tvMap)

1659+ else q

1860

1660

1861{-

1661{-

1862Note [Matching functions with GADT type variables]

1662Note [Matching functions with GADT type variables]

1896-- are the function arguments of types (b -> Value) and ([b] -> Value).

1696-- are the function arguments of types (b -> Value) and ([b] -> Value).

1897type TyVarMap = Map Name (Name, Name)

1697type TyVarMap = Map Name (Name, Name)

1898

1698

1899−-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.

1900−stealKindForType :: TyVarBndr -> Type -> Type

1901−stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)

1902−stealKindForType _ t = t

1903−

1904−-- | Extracts the kind from a type variable binder.

1905−tvbKind :: TyVarBndr -> Kind

1906−#if MIN_VERSION_template_haskell(2,8,0)

1907−tvbKind (PlainTV _ ) = StarT

1908−#else

1909−tvbKind (PlainTV _ ) = StarK

1910−#endif

1911−tvbKind (KindedTV _ k) = k

1912−

1913−tvbToType :: TyVarBndr -> Type

1914−tvbToType (PlainTV n) = VarT n

1915−tvbToType (KindedTV n k) = SigT (VarT n) k

1916−

1917-- | Returns True if a Type has kind *.

1699-- | Returns True if a Type has kind *.

1918hasKindStar :: Type -> Bool

1700hasKindStar :: Type -> Bool

1919hasKindStar VarT{} = True

1701hasKindStar VarT{} = True

1938newNameList :: String -> Int -> Q [Name]

1720newNameList :: String -> Int -> Q [Name]

1939newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]

1721newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]

1940

1722

1941−-- Gets all of the type/kind variable names mentioned somewhere in a Type.

1942−tyVarNamesOfType :: Type -> [Name]

1943−tyVarNamesOfType = go

1944− where

1945− go :: Type -> [Name]

1946− go (AppT t1 t2) = go t1 ++ go t2

1947− go (SigT t _k) = go t

1948−#if MIN_VERSION_template_haskell(2,8,0)

1949− ++ go _k

1950−#endif

1951− go (VarT n) = [n]

1952− go _ = []

1953−

1954−-- | Gets all of the type/kind variable names mentioned somewhere in a Kind.

1955−tyVarNamesOfKind :: Kind -> [Name]

1956−#if MIN_VERSION_template_haskell(2,8,0)

1957−tyVarNamesOfKind = tyVarNamesOfType

1958−#else

1959−tyVarNamesOfKind _ = [] -- There are no kind variables

1960−#endif

1961−

1962-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form

1723-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form

1963-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or

1724-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or

1964-- kind variables.

1725-- kind variables.

1966hasKindVarChain kindArrows t =

1727hasKindVarChain kindArrows t =

1967 let uk = uncurryKind (tyKind t)

1728 let uk = uncurryKind (tyKind t)

1968 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk

1729 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk

1969− then Just (concatMap tyVarNamesOfKind uk)

1730+ then Just (concatMap freeVariables uk)

1970 else Nothing

1731 else Nothing

1971

1732

1972-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.

1733-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.

1986varTToName :: Type -> Name

1747varTToName :: Type -> Name

1987varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe

1748varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe

1988

1749

1989−-- | Extracts the name from a constructor.

1990−getConName :: Con -> Name

1991−getConName (NormalC name _) = name

1992−getConName (RecC name _) = name

1993−getConName (InfixC _ name _) = name

1994−getConName (ForallC _ _ con) = getConName con

1995−#if MIN_VERSION_template_haskell(2,11,0)

1996−getConName (GadtC names _ _) = head names

1997−getConName (RecGadtC names _ _) = head names

1998−#endif

1999−

2000interleave :: [a] -> [a] -> [a]

1750interleave :: [a] -> [a] -> [a]

2001interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s

1751interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s

2002interleave _ _ = []

1752interleave _ _ = []

2128#endif

1878#endif

2129

1879

2130-- | Makes a string literal expression from a constructor's name.

1880-- | Makes a string literal expression from a constructor's name.

2131−conNameExp :: Options -> Con -> Q Exp

1881+conNameExp :: Options -> ConstructorInfo -> Q Exp

2132conNameExp opts = litE

1882conNameExp opts = litE

2133 . stringL

1883 . stringL

2134 . constructorTagModifier opts

1884 . constructorTagModifier opts

2135 . nameBase

1885 . nameBase

2136− . getConName

1886+ . constructorName

2137

1887

2138-- | Creates a string literal expression from a record field label.

1888-- | Creates a string literal expression from a record field label.

2139fieldLabelExp :: Options -- ^ Encoding options

1889fieldLabelExp :: Options -- ^ Encoding options

2178-- Expanding type synonyms

1928-- Expanding type synonyms

2179-------------------------------------------------------------------------------

1929-------------------------------------------------------------------------------

2180

1930

2181−-- | Expands all type synonyms in a type. Written by Dan Rosén in the

1931+applySubstitutionKind :: Map Name Kind -> Type -> Type

2182−-- @genifunctors@ package (licensed under BSD3).

2183−expandSyn :: Type -> Q Type

2184−expandSyn (ForallT tvs ctx t) = ForallT tvs ctx <$> expandSyn t

2185−expandSyn t@AppT{} = expandSynApp t []

2186−expandSyn t@ConT{} = expandSynApp t []

2187−expandSyn (SigT t k) = do t' <- expandSyn t

2188− k' <- expandSynKind k

2189− return (SigT t' k')

2190−expandSyn t = return t

2191−

2192−expandSynKind :: Kind -> Q Kind

2193−#if MIN_VERSION_template_haskell(2,8,0)

2194−expandSynKind = expandSyn

2195−#else

2196−expandSynKind = return -- There are no kind synonyms to deal with

2197−#endif

2198−

2199−expandSynApp :: Type -> [Type] -> Q Type

2200−expandSynApp (AppT t1 t2) ts = do

2201− t2' <- expandSyn t2

2202− expandSynApp t1 (t2':ts)

2203−expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts

2204−expandSynApp t@(ConT n) ts = do

2205− info <- reify n

2206− case info of

2207− TyConI (TySynD _ tvs rhs) ->

2208− let (ts', ts'') = splitAt (length tvs) ts

2209− subs = mkSubst tvs ts'

2210− rhs' = substType subs rhs

2211− in expandSynApp rhs' ts''

2212− _ -> return $ foldl' AppT t ts

2213−expandSynApp t ts = do

2214− t' <- expandSyn t

2215− return $ foldl' AppT t' ts

2216−

2217−type TypeSubst = Map Name Type

2218−type KindSubst = Map Name Kind

2219−

2220−mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst

2221−mkSubst vs ts =

2222− let vs' = map un vs

2223− un (PlainTV v) = v

2224− un (KindedTV v _) = v

2225− in M.fromList $ zip vs' ts

2226−

2227−substType :: TypeSubst -> Type -> Type

2228−substType subs (ForallT v c t) = ForallT v c $ substType subs t

2229−substType subs t@(VarT n) = M.findWithDefault t n subs

2230−substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)

2231−substType subs (SigT t k) = SigT (substType subs t)

2232−#if MIN_VERSION_template_haskell(2,8,0)

2233− (substType subs k)

2234−#else

2235− k

2236−#endif

2237−substType _ t = t

2238−

2239−substKind :: KindSubst -> Type -> Type

2240#if MIN_VERSION_template_haskell(2,8,0)

1932#if MIN_VERSION_template_haskell(2,8,0)

2241−substKind = substType

1933+applySubstitutionKind = applySubstitution

2242#else

1934#else

2243−substKind _ t = t -- There are no kind variables!

1935+applySubstitutionKind _ t = t

2244#endif

1936#endif

2245

1937

2246substNameWithKind :: Name -> Kind -> Type -> Type

1938substNameWithKind :: Name -> Kind -> Type -> Type

2247−substNameWithKind n k = substKind (M.singleton n k)

1939+substNameWithKind n k = applySubstitutionKind (M.singleton n k)

2248

1940

2249substNamesWithKindStar :: [Name] -> Type -> Type

1941substNamesWithKindStar :: [Name] -> Type -> Type

2250substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns

1942substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns