1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE NamedFieldPuns #-} 5{-# LANGUAGE NoImplicitPrelude #-} 6{-# LANGUAGE UndecidableInstances #-} 7#if __GLASGOW_HASKELL__ >= 800 8-- a) THQ works on cross-compilers and unregisterised GHCs 9-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this) 10-- c) removes one hindrance to have code inferred as SafeHaskell safe 11{-# LANGUAGE TemplateHaskellQuotes #-} 12#else 13{-# LANGUAGE TemplateHaskell #-} 14#endif 15 16#include "incoherent-compat.h" 17#include "overlapping-compat.h" 18 19{-| 20Module: Data.Aeson.TH 21Copyright: (c) 2011-2016 Bryan O'Sullivan 22 (c) 2011 MailRank, Inc. 23License: BSD3 24Stability: experimental 25Portability: portable 26 27Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that 28you need to enable the @TemplateHaskell@ language extension in order to use this 29module. 30 31An example shows how instances are generated for arbitrary data types. First we 32define a data type: 33 34@ 35data D a = Nullary 36 | Unary Int 37 | Product String Char a 38 | Record { testOne :: Double 39 , testTwo :: Bool 40 , testThree :: D a 41 } deriving Eq 42@ 43 44Next we derive the necessary instances. Note that we make use of the 45feature to change record field names. In this case we drop the first 4 46characters of every field name. We also modify constructor names by 47lower-casing them: 48 49@ 50$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D) 51@ 52 53Now we can use the newly created instances. 54 55@ 56d :: D 'Int' 57d = Record { testOne = 3.14159 58 , testTwo = 'True' 59 , testThree = Product \"test\" \'A\' 123 60 } 61@ 62 63@ 64fromJSON (toJSON d) == Success d 65@ 66 67This also works for data family instances, but instead of passing in the data 68family name (with double quotes), we pass in a data family instance 69constructor (with a single quote): 70 71@ 72data family DF a 73data instance DF Int = DF1 Int 74 | DF2 Int Int 75 deriving Eq 76 77$('deriveJSON' 'defaultOptions' 'DF1) 78-- Alternatively, one could pass 'DF2 instead 79@ 80 81Please note that you can derive instances for tuples using the following syntax: 82 83@ 84-- FromJSON and ToJSON instances for 4-tuples. 85$('deriveJSON' 'defaultOptions' ''(,,,)) 86@ 87 88-} 89module Data.Aeson.TH 90 ( 91 -- * Encoding configuration 92 Options(..) 93 , SumEncoding(..) 94 , defaultOptions 95 , defaultTaggedObject 96 97 -- * FromJSON and ToJSON derivation 98 , deriveJSON 99 , deriveJSON1 100 , deriveJSON2 101 102 , deriveToJSON 103 , deriveToJSON1 104 , deriveToJSON2 105 , deriveFromJSON 106 , deriveFromJSON1 107 , deriveFromJSON2 108 109 , mkToJSON 110 , mkLiftToJSON 111 , mkLiftToJSON2 112 , mkToEncoding 113 , mkLiftToEncoding 114 , mkLiftToEncoding2 115 , mkParseJSON 116 , mkLiftParseJSON 117 , mkLiftParseJSON2 118 ) where 119 120import Prelude.Compat hiding (fail) 121 122-- We don't have MonadFail Q, so we should use `fail` from real `Prelude` 123import Prelude (fail) 124 125import Control.Applicative ((<|>)) 126import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) 127import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject) 128import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key)) 129import Data.Aeson.Types.FromJSON (parseOptionalFieldWith) 130import Data.Aeson.Types.ToJSON (fromPairs, pair) 131import Control.Monad (liftM2, unless, when) 132import Data.Foldable (foldr') 133#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0) 134import Data.List (nub) 135#endif 136import Data.List (foldl', genericLength, intercalate, partition, union) 137import Data.List.NonEmpty ((<|), NonEmpty((:|))) 138import Data.Map (Map) 139import Data.Maybe (catMaybes, fromMaybe, mapMaybe) 140import qualified Data.Monoid as Monoid 141import Data.Set (Set) 142import Language.Haskell.TH hiding (Arity) 143import Language.Haskell.TH.Datatype 144#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) 145import Language.Haskell.TH.Syntax (mkNameG_tc) 146#endif 147import Text.Printf (printf) 148import qualified Data.Aeson.Encoding.Internal as E 149import qualified Data.Foldable as F (all) 150import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList) 151import qualified Data.List.NonEmpty as NE (length, reverse) 152import qualified Data.Map as M (fromList, keys, lookup , singleton, size) 153import qualified Data.Semigroup as Semigroup (Option(..)) 154import qualified Data.Set as Set (empty, insert, member) 155import qualified Data.Text as T (Text, pack, unpack) 156import qualified Data.Vector as V (unsafeIndex, null, length, create, empty) 157import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite) 158 159-------------------------------------------------------------------------------- 160-- Convenience 161-------------------------------------------------------------------------------- 162 163-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given 164-- data type or data family instance constructor. 165-- 166-- This is a convienience function which is equivalent to calling both 167-- 'deriveToJSON' and 'deriveFromJSON'. 168deriveJSON :: Options 169 -- ^ Encoding options. 170 -> Name 171 -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON' 172 -- instances. 173 -> Q [Dec] 174deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON 175 176-- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given 177-- data type or data family instance constructor. 178-- 179-- This is a convienience function which is equivalent to calling both 180-- 'deriveToJSON1' and 'deriveFromJSON1'. 181deriveJSON1 :: Options 182 -- ^ Encoding options. 183 -> Name 184 -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1' 185 -- instances. 186 -> Q [Dec] 187deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1 188 189-- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given 190-- data type or data family instance constructor. 191-- 192-- This is a convienience function which is equivalent to calling both 193-- 'deriveToJSON2' and 'deriveFromJSON2'. 194deriveJSON2 :: Options 195 -- ^ Encoding options. 196 -> Name 197 -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2' 198 -- instances. 199 -> Q [Dec] 200deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2 201 202-------------------------------------------------------------------------------- 203-- ToJSON 204-------------------------------------------------------------------------------- 205 206{- 207TODO: Don't constrain phantom type variables. 208 209data Foo a = Foo Int 210instance (ToJSON a) ⇒ ToJSON Foo where ... 211 212The above (ToJSON a) constraint is not necessary and perhaps undesirable. 213-} 214 215-- | Generates a 'ToJSON' instance declaration for the given data type or 216-- data family instance constructor. 217deriveToJSON :: Options 218 -- ^ Encoding options. 219 -> Name 220 -- ^ Name of the type for which to generate a 'ToJSON' instance 221 -- declaration. 222 -> Q [Dec] 223deriveToJSON = deriveToJSONCommon toJSONClass 224 225-- | Generates a 'ToJSON1' instance declaration for the given data type or 226-- data family instance constructor. 227deriveToJSON1 :: Options 228 -- ^ Encoding options. 229 -> Name 230 -- ^ Name of the type for which to generate a 'ToJSON1' instance 231 -- declaration. 232 -> Q [Dec] 233deriveToJSON1 = deriveToJSONCommon toJSON1Class 234 235-- | Generates a 'ToJSON2' instance declaration for the given data type or 236-- data family instance constructor. 237deriveToJSON2 :: Options 238 -- ^ Encoding options. 239 -> Name 240 -- ^ Name of the type for which to generate a 'ToJSON2' instance 241 -- declaration. 242 -> Q [Dec] 243deriveToJSON2 = deriveToJSONCommon toJSON2Class 244 245deriveToJSONCommon :: JSONClass 246 -- ^ The ToJSON variant being derived. 247 -> Options 248 -- ^ Encoding options. 249 -> Name 250 -- ^ Name of the type for which to generate an instance. 251 -> Q [Dec] 252deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue Value jc) 253 , (ToEncoding, \jc _ -> consToValue Encoding jc) 254 ] 255 256-- | Generates a lambda expression which encodes the given data type or 257-- data family instance constructor as a 'Value'. 258mkToJSON :: Options -- ^ Encoding options. 259 -> Name -- ^ Name of the type to encode. 260 -> Q Exp 261mkToJSON = mkToJSONCommon toJSONClass 262 263-- | Generates a lambda expression which encodes the given data type or 264-- data family instance constructor as a 'Value' by using the given encoding 265-- function on occurrences of the last type parameter. 266mkLiftToJSON :: Options -- ^ Encoding options. 267 -> Name -- ^ Name of the type to encode. 268 -> Q Exp 269mkLiftToJSON = mkToJSONCommon toJSON1Class 270 271-- | Generates a lambda expression which encodes the given data type or 272-- data family instance constructor as a 'Value' by using the given encoding 273-- functions on occurrences of the last two type parameters. 274mkLiftToJSON2 :: Options -- ^ Encoding options. 275 -> Name -- ^ Name of the type to encode. 276 -> Q Exp 277mkLiftToJSON2 = mkToJSONCommon toJSON2Class 278 279mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived. 280 -> Options -- ^ Encoding options. 281 -> Name -- ^ Name of the encoded type. 282 -> Q Exp 283mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc) 284 285-- | Generates a lambda expression which encodes the given data type or 286-- data family instance constructor as a JSON string. 287mkToEncoding :: Options -- ^ Encoding options. 288 -> Name -- ^ Name of the type to encode. 289 -> Q Exp 290mkToEncoding = mkToEncodingCommon toJSONClass 291 292-- | Generates a lambda expression which encodes the given data type or 293-- data family instance constructor as a JSON string by using the given encoding 294-- function on occurrences of the last type parameter. 295mkLiftToEncoding :: Options -- ^ Encoding options. 296 -> Name -- ^ Name of the type to encode. 297 -> Q Exp 298mkLiftToEncoding = mkToEncodingCommon toJSON1Class 299 300-- | Generates a lambda expression which encodes the given data type or 301-- data family instance constructor as a JSON string by using the given encoding 302-- functions on occurrences of the last two type parameters. 303mkLiftToEncoding2 :: Options -- ^ Encoding options. 304 -> Name -- ^ Name of the type to encode. 305 -> Q Exp 306mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class 307 308mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived. 309 -> Options -- ^ Encoding options. 310 -> Name -- ^ Name of the encoded type. 311 -> Q Exp 312mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc) 313 314-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates 315-- code to generate a 'Value' or 'Encoding' of a number of constructors. All 316-- constructors must be from the same type. 317consToValue :: ToJSONFun 318 -- ^ The method ('toJSON' or 'toEncoding') being derived. 319 -> JSONClass 320 -- ^ The ToJSON variant being derived. 321 -> Options 322 -- ^ Encoding options. 323 -> [Type] 324 -- ^ The types from the data type/data family instance declaration 325 -> [ConstructorInfo] 326 -- ^ Constructors for which to generate JSON generating code. 327 -> Q Exp 328 329consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: " 330 ++ "Not a single constructor given!" 331 332consToValue target jc opts instTys cons = do 333 value <- newName "value" 334 tjs <- newNameList "_tj" $ arityInt jc 335 tjls <- newNameList "_tjl" $ arityInt jc 336 let zippedTJs = zip tjs tjls 337 interleavedTJs = interleave tjs tjls 338 lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys 339 tvMap = M.fromList $ zip lastTyVars zippedTJs 340 lamE (map varP $ interleavedTJs ++ [value]) $ 341 caseE (varE value) (matches tvMap) 342 where 343 matches tvMap = case cons of 344 -- A single constructor is directly encoded. The constructor itself may be 345 -- forgotten. 346 [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con] 347 _ | allNullaryToStringTag opts && all isNullary cons -> 348 [ match (conP conName []) (normalB $ conStr target opts conName) [] 349 | con <- cons 350 , let conName = constructorName con 351 ] 352 | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons] 353 354-- | Name of the constructor as a quoted 'Value' or 'Encoding'. 355conStr :: ToJSONFun -> Options -> Name -> Q Exp 356conStr Value opts = appE [|String|] . conTxt opts 357conStr Encoding opts = appE [|E.text|] . conTxt opts 358 359-- | Name of the constructor as a quoted 'Text'. 360conTxt :: Options -> Name -> Q Exp 361conTxt opts = appE [|T.pack|] . stringE . conString opts 362 363-- | Name of the constructor. 364conString :: Options -> Name -> String 365conString opts = constructorTagModifier opts . nameBase 366 367-- | If constructor is nullary. 368isNullary :: ConstructorInfo -> Bool 369isNullary ConstructorInfo { constructorVariant = NormalConstructor 370 , constructorFields = tys } = null tys 371isNullary _ = False 372 373-- | Wrap fields of a non-record constructor. See 'sumToValue'. 374opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ 375opaqueSumToValue target opts multiCons nullary conName value = 376 sumToValue target opts multiCons nullary conName 377 value 378 pairs 379 where 380 pairs contentsFieldName = pairE contentsFieldName value 381 382-- | Wrap fields of a record constructor. See 'sumToValue'. 383recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ 384recordSumToValue target opts multiCons nullary conName pairs = 385 sumToValue target opts multiCons nullary conName 386 (fromPairsE pairs) 387 (const pairs) 388 389-- | Wrap fields of a constructor. 390sumToValue 391 :: ToJSONFun 392 -- ^ The method being derived. 393 -> Options 394 -- ^ Deriving options. 395 -> Bool 396 -- ^ Does this type have multiple constructors. 397 -> Bool 398 -- ^ Is this constructor nullary. 399 -> Name 400 -- ^ Constructor name. 401 -> ExpQ 402 -- ^ Fields of the constructor as a 'Value' or 'Encoding'. 403 -> (String -> ExpQ) 404 -- ^ Representation of an 'Object' fragment used for the 'TaggedObject' 405 -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method 406 -- being derived. 407 -- 408 -- - For non-records, produces a pair @"contentsFieldName":value@, 409 -- given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'. 410 -- - For records, produces the list of pairs corresponding to fields of the 411 -- encoded value (ignores the argument). See 'recordSumToValue'. 412 -> ExpQ 413sumToValue target opts multiCons nullary conName value pairs 414 | multiCons = 415 case sumEncoding opts of 416 TwoElemArray -> 417 array target [conStr target opts conName, value] 418 TaggedObject{tagFieldName, contentsFieldName} -> 419 -- TODO: Maybe throw an error in case 420 -- tagFieldName overwrites a field in pairs. 421 let tag = pairE tagFieldName (conStr target opts conName) 422 content = pairs contentsFieldName 423 in fromPairsE $ 424 if nullary then tag else infixApp tag [|(Monoid.<>)|] content 425 ObjectWithSingleField -> 426 objectE [(conString opts conName, value)] 427 UntaggedValue | nullary -> conStr target opts conName 428 UntaggedValue -> value 429 | otherwise = value 430 431-- | Generates code to generate the JSON encoding of a single constructor. 432argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match 433 434-- Polyadic constructors with special case for unary constructors. 435argsToValue target jc tvMap opts multiCons 436 ConstructorInfo { constructorName = conName 437 , constructorVariant = NormalConstructor 438 , constructorFields = argTys } = do 439 argTys' <- mapM resolveTypeSynonyms argTys 440 let len = length argTys' 441 args <- newNameList "arg" len 442 let js = case [ dispatchToJSON target jc conName tvMap argTy 443 `appE` varE arg 444 | (arg, argTy) <- zip args argTys' 445 ] of 446 -- Single argument is directly converted. 447 [e] -> e 448 -- Zero and multiple arguments are converted to a JSON array. 449 es -> array target es 450 451 match (conP conName $ map varP args) 452 (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js) 453 [] 454 455-- Records. 456argsToValue target jc tvMap opts multiCons 457 info@ConstructorInfo { constructorName = conName 458 , constructorVariant = RecordConstructor fields 459 , constructorFields = argTys } = 460 case (unwrapUnaryRecords opts, not multiCons, argTys) of 461 (True,True,[_]) -> argsToValue target jc tvMap opts multiCons 462 (info{constructorVariant = NormalConstructor}) 463 _ -> do 464 argTys' <- mapM resolveTypeSynonyms argTys 465 args <- newNameList "arg" $ length argTys' 466 let pairs | omitNothingFields opts = infixApp maybeFields 467 [|(Monoid.<>)|] 468 restFields 469 | otherwise = mconcatE (map pureToPair argCons) 470 471 argCons = zip3 (map varE args) argTys' fields 472 473 maybeFields = mconcatE (map maybeToPair maybes) 474 475 restFields = mconcatE (map pureToPair rest) 476 477 (maybes0, rest0) = partition isMaybe argCons 478 (options, rest) = partition isOption rest0 479 maybes = maybes0 ++ map optionToMaybe options 480 481 maybeToPair = toPairLifted True 482 pureToPair = toPairLifted False 483 484 toPairLifted lifted (arg, argTy, field) = 485 let toValue = dispatchToJSON target jc conName tvMap argTy 486 fieldName = fieldLabel opts field 487 e arg' = pairE fieldName (toValue `appE` arg') 488 in if lifted 489 then do 490 x <- newName "x" 491 [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg 492 else e arg 493 494 match (conP conName $ map varP args) 495 (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs) 496 [] 497 498-- Infix constructors. 499argsToValue target jc tvMap opts multiCons 500 ConstructorInfo { constructorName = conName 501 , constructorVariant = InfixConstructor 502 , constructorFields = argTys } = do 503 [alTy, arTy] <- mapM resolveTypeSynonyms argTys 504 al <- newName "argL" 505 ar <- newName "argR" 506 match (infixP (varP al) conName (varP ar)) 507 ( normalB 508 $ opaqueSumToValue target opts multiCons False conName 509 $ array target 510 [ dispatchToJSON target jc conName tvMap aTy 511 `appE` varE a 512 | (a, aTy) <- [(al,alTy), (ar,arTy)] 513 ] 514 ) 515 [] 516 517isMaybe :: (a, Type, b) -> Bool 518isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe 519isMaybe _ = False 520 521isOption :: (a, Type, b) -> Bool 522isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option 523isOption _ = False 524 525optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c) 526optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c) 527 528(<^>) :: ExpQ -> ExpQ -> ExpQ 529(<^>) a b = infixApp a [|(E.><)|] b 530infixr 6 <^> 531 532(<%>) :: ExpQ -> ExpQ -> ExpQ 533(<%>) a b = a <^> [|E.comma|] <^> b 534infixr 4 <%> 535 536-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value'). 537array :: ToJSONFun -> [ExpQ] -> ExpQ 538array Encoding [] = [|E.emptyArray_|] 539array Value [] = [|Array V.empty|] 540array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es 541array Value es = do 542 mv <- newName "mv" 543 let newMV = bindS (varP mv) 544 ([|VM.unsafeNew|] `appE` 545 litE (integerL $ fromIntegral (length es))) 546 stmts = [ noBindS $ 547 [|VM.unsafeWrite|] `appE` 548 varE mv `appE` 549 litE (integerL ix) `appE` 550 e 551 | (ix, e) <- zip [(0::Integer)..] es 552 ] 553 ret = noBindS $ [|return|] `appE` varE mv 554 [|Array|] `appE` 555 (varE 'V.create `appE` 556 doE (newMV:stmts++[ret])) 557 558-- | Wrap an associative list of keys and quoted values in a quoted 'Object'. 559objectE :: [(String, ExpQ)] -> ExpQ 560objectE = fromPairsE . mconcatE . fmap (uncurry pairE) 561 562-- | 'mconcat' a list of fixed length. 563-- 564-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |] 565mconcatE :: [ExpQ] -> ExpQ 566mconcatE [] = [|Monoid.mempty|] 567mconcatE [x] = x 568mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs) 569 570fromPairsE :: ExpQ -> ExpQ 571fromPairsE = ([|fromPairs|] `appE`) 572 573-- | Create (an encoding of) a key-value pair. 574-- 575-- > pairE "k" [|v|] = [|pair "k" v|] 576pairE :: String -> ExpQ -> ExpQ 577pairE k v = [|pair k|] `appE` v 578 579-------------------------------------------------------------------------------- 580-- FromJSON 581-------------------------------------------------------------------------------- 582 583-- | Generates a 'FromJSON' instance declaration for the given data type or 584-- data family instance constructor. 585deriveFromJSON :: Options 586 -- ^ Encoding options. 587 -> Name 588 -- ^ Name of the type for which to generate a 'FromJSON' instance 589 -- declaration. 590 -> Q [Dec] 591deriveFromJSON = deriveFromJSONCommon fromJSONClass 592 593-- | Generates a 'FromJSON1' instance declaration for the given data type or 594-- data family instance constructor. 595deriveFromJSON1 :: Options 596 -- ^ Encoding options. 597 -> Name 598 -- ^ Name of the type for which to generate a 'FromJSON1' instance 599 -- declaration. 600 -> Q [Dec] 601deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class 602 603-- | Generates a 'FromJSON2' instance declaration for the given data type or 604-- data family instance constructor. 605deriveFromJSON2 :: Options 606 -- ^ Encoding options. 607 -> Name 608 -- ^ Name of the type for which to generate a 'FromJSON3' instance 609 -- declaration. 610 -> Q [Dec] 611deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class 612 613deriveFromJSONCommon :: JSONClass 614 -- ^ The FromJSON variant being derived. 615 -> Options 616 -- ^ Encoding options. 617 -> Name 618 -- ^ Name of the type for which to generate an instance. 619 -- declaration. 620 -> Q [Dec] 621deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)] 622 623-- | Generates a lambda expression which parses the JSON encoding of the given 624-- data type or data family instance constructor. 625mkParseJSON :: Options -- ^ Encoding options. 626 -> Name -- ^ Name of the encoded type. 627 -> Q Exp 628mkParseJSON = mkParseJSONCommon fromJSONClass 629 630-- | Generates a lambda expression which parses the JSON encoding of the given 631-- data type or data family instance constructor by using the given parsing 632-- function on occurrences of the last type parameter. 633mkLiftParseJSON :: Options -- ^ Encoding options. 634 -> Name -- ^ Name of the encoded type. 635 -> Q Exp 636mkLiftParseJSON = mkParseJSONCommon fromJSON1Class 637 638-- | Generates a lambda expression which parses the JSON encoding of the given 639-- data type or data family instance constructor by using the given parsing 640-- functions on occurrences of the last two type parameters. 641mkLiftParseJSON2 :: Options -- ^ Encoding options. 642 -> Name -- ^ Name of the encoded type. 643 -> Q Exp 644mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class 645 646mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived. 647 -> Options -- ^ Encoding options. 648 -> Name -- ^ Name of the encoded type. 649 -> Q Exp 650mkParseJSONCommon = mkFunCommon consFromJSON 651 652-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates 653-- code to parse the JSON encoding of a number of constructors. All constructors 654-- must be from the same type. 655consFromJSON :: JSONClass 656 -- ^ The FromJSON variant being derived. 657 -> Name 658 -- ^ Name of the type to which the constructors belong. 659 -> Options 660 -- ^ Encoding options 661 -> [Type] 662 -- ^ The types from the data type/data family instance declaration 663 -> [ConstructorInfo] 664 -- ^ Constructors for which to generate JSON parsing code. 665 -> Q Exp 666 667consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: " 668 ++ "Not a single constructor given!" 669 670consFromJSON jc tName opts instTys cons = do 671 value <- newName "value" 672 pjs <- newNameList "_pj" $ arityInt jc 673 pjls <- newNameList "_pjl" $ arityInt jc 674 let zippedPJs = zip pjs pjls 675 interleavedPJs = interleave pjs pjls 676 lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys 677 tvMap = M.fromList $ zip lastTyVars zippedPJs 678 lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap 679 680 where 681 checkExi tvMap con = checkExistentialContext jc tvMap 682 (constructorContext con) 683 (constructorName con) 684 685 lamExpr value tvMap = case cons of 686 [con] 687 | not (tagSingleConstructors opts) 688 -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value) 689 _ | sumEncoding opts == UntaggedValue 690 -> parseUntaggedValue tvMap cons value 691 | otherwise 692 -> caseE (varE value) $ 693 if allNullaryToStringTag opts && all isNullary cons 694 then allNullaryMatches 695 else mixedMatches tvMap 696 697 allNullaryMatches = 698 [ do txt <- newName "txt" 699 match (conP 'String [varP txt]) 700 (guardedB $ 701 [ liftM2 (,) (normalG $ 702 infixApp (varE txt) 703 [|(==)|] 704 (conTxt opts conName) 705 ) 706 ([|pure|] `appE` conE conName) 707 | con <- cons 708 , let conName = constructorName con 709 ] 710 ++ 711 [ liftM2 (,) 712 (normalG [|otherwise|]) 713 ( [|noMatchFail|] 714 `appE` litE (stringL $ show tName) 715 `appE` ([|T.unpack|] `appE` varE txt) 716 ) 717 ] 718 ) 719 [] 720 , do other <- newName "other" 721 match (varP other) 722 (normalB $ [|noStringFail|] 723 `appE` litE (stringL $ show tName) 724 `appE` ([|valueConName|] `appE` varE other) 725 ) 726 [] 727 ] 728 729 mixedMatches tvMap = 730 case sumEncoding opts of 731 TaggedObject {tagFieldName, contentsFieldName} -> 732 parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName 733 UntaggedValue -> error "UntaggedValue: Should be handled already" 734 ObjectWithSingleField -> 735 parseObject $ parseObjectWithSingleField tvMap 736 TwoElemArray -> 737 [ do arr <- newName "array" 738 match (conP 'Array [varP arr]) 739 (guardedB 740 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr) 741 [|(==)|] 742 (litE $ integerL 2)) 743 (parse2ElemArray tvMap arr) 744 , liftM2 (,) (normalG [|otherwise|]) 745 ([|not2ElemArray|] 746 `appE` litE (stringL $ show tName) 747 `appE` ([|V.length|] `appE` varE arr)) 748 ] 749 ) 750 [] 751 , do other <- newName "other" 752 match (varP other) 753 ( normalB 754 $ [|noArrayFail|] 755 `appE` litE (stringL $ show tName) 756 `appE` ([|valueConName|] `appE` varE other) 757 ) 758 [] 759 ] 760 761 parseObject f = 762 [ do obj <- newName "obj" 763 match (conP 'Object [varP obj]) (normalB $ f obj) [] 764 , do other <- newName "other" 765 match (varP other) 766 ( normalB 767 $ [|noObjectFail|] 768 `appE` litE (stringL $ show tName) 769 `appE` ([|valueConName|] `appE` varE other) 770 ) 771 [] 772 ] 773 774 parseTaggedObject tvMap typFieldName valFieldName obj = do 775 conKey <- newName "conKey" 776 doE [ bindS (varP conKey) 777 (infixApp (varE obj) 778 [|(.:)|] 779 ([|T.pack|] `appE` stringE typFieldName)) 780 , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject 781 ] 782 783 parseUntaggedValue tvMap cons' conVal = 784 foldr1 (\e e' -> infixApp e [|(<|>)|] e') 785 (map (\x -> parseValue tvMap x conVal) cons') 786 787 parseValue _tvMap 788 ConstructorInfo { constructorName = conName 789 , constructorVariant = NormalConstructor 790 , constructorFields = [] } 791 conVal = do 792 str <- newName "str" 793 caseE (varE conVal) 794 [ match (conP 'String [varP str]) 795 (guardedB 796 [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName) 797 ) 798 ([|pure|] `appE` conE conName) 799 ] 800 ) 801 [] 802 , matchFailed tName conName "String" 803 ] 804 parseValue tvMap con conVal = 805 checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal) 806 807 808 parse2ElemArray tvMap arr = do 809 conKey <- newName "conKey" 810 conVal <- newName "conVal" 811 let letIx n ix = 812 valD (varP n) 813 (normalB ([|V.unsafeIndex|] `appE` 814 varE arr `appE` 815 litE (integerL ix))) 816 [] 817 letE [ letIx conKey 0 818 , letIx conVal 1 819 ] 820 (caseE (varE conKey) 821 [ do txt <- newName "txt" 822 match (conP 'String [varP txt]) 823 (normalB $ parseContents tvMap 824 txt 825 (Right conVal) 826 'conNotFoundFail2ElemArray 827 ) 828 [] 829 , do other <- newName "other" 830 match (varP other) 831 ( normalB 832 $ [|firstElemNoStringFail|] 833 `appE` litE (stringL $ show tName) 834 `appE` ([|valueConName|] `appE` varE other) 835 ) 836 [] 837 ] 838 ) 839 840 parseObjectWithSingleField tvMap obj = do 841 conKey <- newName "conKey" 842 conVal <- newName "conVal" 843 caseE ([e|H.toList|] `appE` varE obj) 844 [ match (listP [tupP [varP conKey, varP conVal]]) 845 (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField) 846 [] 847 , do other <- newName "other" 848 match (varP other) 849 (normalB $ [|wrongPairCountFail|] 850 `appE` litE (stringL $ show tName) 851 `appE` ([|show . length|] `appE` varE other) 852 ) 853 [] 854 ] 855 856 parseContents tvMap conKey contents errorFun = 857 caseE (varE conKey) 858 [ match wildP 859 ( guardedB $ 860 [ do g <- normalG $ infixApp (varE conKey) 861 [|(==)|] 862 ([|T.pack|] `appE` 863 conNameExp opts con) 864 e <- checkExi tvMap con $ 865 parseArgs jc tvMap tName opts con contents 866 return (g, e) 867 | con <- cons 868 ] 869 ++ 870 [ liftM2 (,) 871 (normalG [e|otherwise|]) 872 ( varE errorFun 873 `appE` litE (stringL $ show tName) 874 `appE` listE (map ( litE 875 . stringL 876 . constructorTagModifier opts 877 . nameBase 878 . constructorName 879 ) cons 880 ) 881 `appE` ([|T.unpack|] `appE` varE conKey) 882 ) 883 ] 884 ) 885 [] 886 ] 887 888parseNullaryMatches :: Name -> Name -> [Q Match] 889parseNullaryMatches tName conName = 890 [ do arr <- newName "arr" 891 match (conP 'Array [varP arr]) 892 (guardedB 893 [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr) 894 ([|pure|] `appE` conE conName) 895 , liftM2 (,) (normalG [|otherwise|]) 896 (parseTypeMismatch tName conName 897 (litE $ stringL "an empty Array") 898 (infixApp (litE $ stringL "Array of length ") 899 [|(++)|] 900 ([|show . V.length|] `appE` varE arr) 901 ) 902 ) 903 ] 904 ) 905 [] 906 , matchFailed tName conName "Array" 907 ] 908 909parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match] 910parseUnaryMatches jc tvMap argTy conName = 911 [ do arg <- newName "arg" 912 match (varP arg) 913 ( normalB $ infixApp (conE conName) 914 [|(<$>)|] 915 (dispatchParseJSON jc conName tvMap argTy 916 `appE` varE arg) 917 ) 918 [] 919 ] 920 921parseRecord :: JSONClass 922 -> TyVarMap 923 -> [Type] 924 -> Options 925 -> Name 926 -> Name 927 -> [Name] 928 -> Name 929 -> Bool 930 -> ExpQ 931parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject = 932 (if rejectUnknownFields opts 933 then infixApp checkUnknownRecords [|(>>)|] 934 else id) $ 935 foldl' (\a b -> infixApp a [|(<*>)|] b) 936 (infixApp (conE conName) [|(<$>)|] x) 937 xs 938 where 939 tagFieldNameAppender = 940 if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id 941 knownFields = appE [|H.fromList|] $ listE $ 942 map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $ 943 tagFieldNameAppender $ map (fieldLabel opts) fields 944 checkUnknownRecords = 945 caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields) 946 [ match (listP []) (normalB [|return ()|]) [] 947 , newName "unknownFields" >>= 948 \unknownFields -> match (varP unknownFields) 949 (normalB $ appE [|fail|] $ infixApp 950 (litE (stringL "Unknown fields: ")) 951 [|(++)|] 952 (appE [|show|] (varE unknownFields))) 953 [] 954 ] 955 x:xs = [ [|lookupField|] 956 `appE` dispatchParseJSON jc conName tvMap argTy 957 `appE` litE (stringL $ show tName) 958 `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName) 959 `appE` varE obj 960 `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field) 961 ) 962 | (field, argTy) <- zip fields argTys 963 ] 964 965getValField :: Name -> String -> [MatchQ] -> Q Exp 966getValField obj valFieldName matches = do 967 val <- newName "val" 968 doE [ bindS (varP val) $ infixApp (varE obj) 969 [|(.:)|] 970 ([|T.pack|] `appE` 971 litE (stringL valFieldName)) 972 , noBindS $ caseE (varE val) matches 973 ] 974 975matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp 976matchCases (Left (valFieldName, obj)) = getValField obj valFieldName 977matchCases (Right valName) = caseE (varE valName) 978 979-- | Generates code to parse the JSON encoding of a single constructor. 980parseArgs :: JSONClass -- ^ The FromJSON variant being derived. 981 -> TyVarMap -- ^ Maps the last type variables to their decoding 982 -- function arguments. 983 -> Name -- ^ Name of the type to which the constructor belongs. 984 -> Options -- ^ Encoding options. 985 -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code. 986 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or 987 -- Right valName 988 -> Q Exp 989-- Nullary constructors. 990parseArgs _ _ _ _ 991 ConstructorInfo { constructorName = conName 992 , constructorVariant = NormalConstructor 993 , constructorFields = [] } 994 (Left _) = 995 [|pure|] `appE` conE conName 996parseArgs _ _ tName _ 997 ConstructorInfo { constructorName = conName 998 , constructorVariant = NormalConstructor 999 , constructorFields = [] } 1000 (Right valName) = 1001 caseE (varE valName) $ parseNullaryMatches tName conName 1002 1003-- Unary constructors. 1004parseArgs jc tvMap _ _ 1005 ConstructorInfo { constructorName = conName 1006 , constructorVariant = NormalConstructor 1007 , constructorFields = [argTy] } 1008 contents = do 1009 argTy' <- resolveTypeSynonyms argTy 1010 matchCases contents $ parseUnaryMatches jc tvMap argTy' conName 1011 1012-- Polyadic constructors. 1013parseArgs jc tvMap tName _ 1014 ConstructorInfo { constructorName = conName 1015 , constructorVariant = NormalConstructor 1016 , constructorFields = argTys } 1017 contents = do 1018 argTys' <- mapM resolveTypeSynonyms argTys 1019 let len = genericLength argTys' 1020 matchCases contents $ parseProduct jc tvMap argTys' tName conName len 1021 1022-- Records. 1023parseArgs jc tvMap tName opts 1024 ConstructorInfo { constructorName = conName 1025 , constructorVariant = RecordConstructor fields 1026 , constructorFields = argTys } 1027 (Left (_, obj)) = do 1028 argTys' <- mapM resolveTypeSynonyms argTys 1029 parseRecord jc tvMap argTys' opts tName conName fields obj True 1030parseArgs jc tvMap tName opts 1031 info@ConstructorInfo { constructorName = conName 1032 , constructorVariant = RecordConstructor fields 1033 , constructorFields = argTys } 1034 (Right valName) = 1035 case (unwrapUnaryRecords opts,argTys) of 1036 (True,[_])-> parseArgs jc tvMap tName opts 1037 (info{constructorVariant = NormalConstructor}) 1038 (Right valName) 1039 _ -> do 1040 obj <- newName "recObj" 1041 argTys' <- mapM resolveTypeSynonyms argTys 1042 caseE (varE valName) 1043 [ match (conP 'Object [varP obj]) (normalB $ 1044 parseRecord jc tvMap argTys' opts tName conName fields obj False) [] 1045 , matchFailed tName conName "Object" 1046 ] 1047 1048-- Infix constructors. Apart from syntax these are the same as 1049-- polyadic constructors. 1050parseArgs jc tvMap tName _ 1051 ConstructorInfo { constructorName = conName 1052 , constructorVariant = InfixConstructor 1053 , constructorFields = argTys } 1054 contents = do 1055 argTys' <- mapM resolveTypeSynonyms argTys 1056 matchCases contents $ parseProduct jc tvMap argTys' tName conName 2 1057 1058-- | Generates code to parse the JSON encoding of an n-ary 1059-- constructor. 1060parseProduct :: JSONClass -- ^ The FromJSON variant being derived. 1061 -> TyVarMap -- ^ Maps the last type variables to their decoding 1062 -- function arguments. 1063 -> [Type] -- ^ The argument types of the constructor. 1064 -> Name -- ^ Name of the type to which the constructor belongs. 1065 -> Name -- ^ 'Con'structor name. 1066 -> Integer -- ^ 'Con'structor arity. 1067 -> [Q Match] 1068parseProduct jc tvMap argTys tName conName numArgs = 1069 [ do arr <- newName "arr" 1070 -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)" 1071 let x:xs = [ dispatchParseJSON jc conName tvMap argTy 1072 `appE` 1073 infixApp (varE arr) 1074 [|V.unsafeIndex|] 1075 (litE $ integerL ix) 1076 | (argTy, ix) <- zip argTys [0 .. numArgs - 1] 1077 ] 1078 match (conP 'Array [varP arr]) 1079 (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr) 1080 [|(==)|] 1081 (litE $ integerL numArgs) 1082 ) 1083 ( foldl' (\a b -> infixApp a [|(<*>)|] b) 1084 (infixApp (conE conName) [|(<$>)|] x) 1085 xs 1086 ) 1087 ( parseTypeMismatch tName conName 1088 (litE $ stringL $ "Array of length " ++ show numArgs) 1089 ( infixApp (litE $ stringL "Array of length ") 1090 [|(++)|] 1091 ([|show . V.length|] `appE` varE arr) 1092 ) 1093 ) 1094 ) 1095 [] 1096 , matchFailed tName conName "Array" 1097 ] 1098 1099-------------------------------------------------------------------------------- 1100-- Parsing errors 1101-------------------------------------------------------------------------------- 1102 1103matchFailed :: Name -> Name -> String -> MatchQ 1104matchFailed tName conName expected = do 1105 other <- newName "other" 1106 match (varP other) 1107 ( normalB $ parseTypeMismatch tName conName 1108 (litE $ stringL expected) 1109 ([|valueConName|] `appE` varE other) 1110 ) 1111 [] 1112 1113parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ 1114parseTypeMismatch tName conName expected actual = 1115 foldl appE 1116 [|parseTypeMismatch'|] 1117 [ litE $ stringL $ nameBase conName 1118 , litE $ stringL $ show tName 1119 , expected 1120 , actual 1121 ] 1122 1123class LookupField a where 1124 lookupField :: (Value -> Parser a) -> String -> String 1125 -> Object -> T.Text -> Parser a 1126 1127instance OVERLAPPABLE_ LookupField a where 1128 lookupField = lookupFieldWith 1129 1130instance INCOHERENT_ LookupField (Maybe a) where 1131 lookupField pj _ _ = parseOptionalFieldWith pj 1132 1133instance INCOHERENT_ LookupField (Semigroup.Option a) where 1134 lookupField pj tName rec obj key = 1135 fmap Semigroup.Option 1136 (lookupField (fmap Semigroup.getOption . pj) tName rec obj key) 1137 1138lookupFieldWith :: (Value -> Parser a) -> String -> String 1139 -> Object -> T.Text -> Parser a 1140lookupFieldWith pj tName rec obj key = 1141 case H.lookup key obj of 1142 Nothing -> unknownFieldFail tName rec (T.unpack key) 1143 Just v -> pj v <?> Key key 1144 1145unknownFieldFail :: String -> String -> String -> Parser fail 1146unknownFieldFail tName rec key = 1147 fail $ printf "When parsing the record %s of type %s the key %s was not present." 1148 rec tName key 1149 1150noArrayFail :: String -> String -> Parser fail 1151noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o 1152 1153noObjectFail :: String -> String -> Parser fail 1154noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o 1155 1156firstElemNoStringFail :: String -> String -> Parser fail 1157firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o 1158 1159wrongPairCountFail :: String -> String -> Parser fail 1160wrongPairCountFail t n = 1161 fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs." 1162 t n 1163 1164noStringFail :: String -> String -> Parser fail 1165noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o 1166 1167noMatchFail :: String -> String -> Parser fail 1168noMatchFail t o = 1169 fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o 1170 1171not2ElemArray :: String -> Int -> Parser fail 1172not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i 1173 1174conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail 1175conNotFoundFail2ElemArray t cs o = 1176 fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s." 1177 t (intercalate ", " cs) o 1178 1179conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail 1180conNotFoundFailObjectSingleField t cs o = 1181 fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s." 1182 t (intercalate ", " cs) o 1183 1184conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail 1185conNotFoundFailTaggedObject t cs o = 1186 fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s." 1187 t (intercalate ", " cs) o 1188 1189parseTypeMismatch' :: String -> String -> String -> String -> Parser fail 1190parseTypeMismatch' conName tName expected actual = 1191 fail $ printf "When parsing the constructor %s of type %s expected %s but got %s." 1192 conName tName expected actual 1193 1194-------------------------------------------------------------------------------- 1195-- Shared ToJSON and FromJSON code 1196-------------------------------------------------------------------------------- 1197 1198-- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'. 1199deriveJSONBoth :: (Options -> Name -> Q [Dec]) 1200 -- ^ Function which derives a flavor of 'ToJSON'. 1201 -> (Options -> Name -> Q [Dec]) 1202 -- ^ Function which derives a flavor of 'FromJSON'. 1203 -> Options 1204 -- ^ Encoding options. 1205 -> Name 1206 -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON' 1207 -- instances. 1208 -> Q [Dec] 1209deriveJSONBoth dtj dfj opts name = 1210 liftM2 (++) (dtj opts name) (dfj opts name) 1211 1212-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@. 1213deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type] 1214 -> [ConstructorInfo] -> Q Exp)] 1215 -- ^ The class methods and the functions which derive them. 1216 -> JSONClass 1217 -- ^ The class for which to generate an instance. 1218 -> Options 1219 -- ^ Encoding options. 1220 -> Name 1221 -- ^ Name of the type for which to generate a class instance 1222 -- declaration. 1223 -> Q [Dec] 1224deriveJSONClass consFuns jc opts name = do 1225 info <- reifyDatatype name 1226 case info of 1227 DatatypeInfo { datatypeContext = ctxt 1228 , datatypeName = parentName 1229#if MIN_VERSION_th_abstraction(0,3,0) 1230 , datatypeInstTypes = instTys 1231#else 1232 , datatypeVars = instTys 1233#endif 1234 , datatypeVariant = variant 1235 , datatypeCons = cons 1236 } -> do 1237 (instanceCxt, instanceType) 1238 <- buildTypeInstance parentName jc ctxt instTys variant 1239 (:[]) <$> instanceD (return instanceCxt) 1240 (return instanceType) 1241 (methodDecs parentName instTys cons) 1242 where 1243 methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec] 1244 methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) -> 1245 funD (jsonFunValName jf (arity jc)) 1246 [ clause [] 1247 (normalB $ jfMaker jc parentName opts instTys cons) 1248 [] 1249 ] 1250 1251mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp) 1252 -- ^ The function which derives the expression. 1253 -> JSONClass 1254 -- ^ Which class's method is being derived. 1255 -> Options 1256 -- ^ Encoding options. 1257 -> Name 1258 -- ^ Name of the encoded type. 1259 -> Q Exp 1260mkFunCommon consFun jc opts name = do 1261 info <- reifyDatatype name 1262 case info of 1263 DatatypeInfo { datatypeContext = ctxt 1264 , datatypeName = parentName 1265#if MIN_VERSION_th_abstraction(0,3,0) 1266 , datatypeInstTypes = instTys 1267#else 1268 , datatypeVars = instTys 1269#endif 1270 , datatypeVariant = variant 1271 , datatypeCons = cons 1272 } -> do 1273 -- We force buildTypeInstance here since it performs some checks for whether 1274 -- or not the provided datatype's kind matches the derived method's 1275 -- typeclass, and produces errors if it can't. 1276 !_ <- buildTypeInstance parentName jc ctxt instTys variant 1277 consFun jc parentName opts instTys cons 1278 1279dispatchFunByType :: JSONClass 1280 -> JSONFun 1281 -> Name 1282 -> TyVarMap 1283 -> Bool -- True if we are using the function argument that works 1284 -- on lists (e.g., [a] -> Value). False is we are using 1285 -- the function argument that works on single values 1286 -- (e.g., a -> Value). 1287 -> Type 1288 -> Q Exp 1289dispatchFunByType _ jf _ tvMap list (VarT tyName) = 1290 varE $ case M.lookup tyName tvMap of 1291 Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp 1292 Nothing -> jsonFunValOrListName list jf Arity0 1293dispatchFunByType jc jf conName tvMap list (SigT ty _) = 1294 dispatchFunByType jc jf conName tvMap list ty 1295dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) = 1296 dispatchFunByType jc jf conName tvMap list ty 1297dispatchFunByType jc jf conName tvMap list ty = do 1298 let tyCon :: Type 1299 tyArgs :: [Type] 1300 tyCon :| tyArgs = unapplyTy ty 1301 1302 numLastArgs :: Int 1303 numLastArgs = min (arityInt jc) (length tyArgs) 1304 1305 lhsArgs, rhsArgs :: [Type] 1306 (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs 1307 1308 tyVarNames :: [Name] 1309 tyVarNames = M.keys tvMap 1310 1311 itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs 1312 if any (`mentionsName` tyVarNames) lhsArgs || itf 1313 then outOfPlaceTyVarError jc conName 1314 else if any (`mentionsName` tyVarNames) rhsArgs 1315 then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs) 1316 : zipWith (dispatchFunByType jc jf conName tvMap) 1317 (cycle [False,True]) 1318 (interleave rhsArgs rhsArgs) 1319 else varE $ jsonFunValOrListName list jf Arity0 1320 1321dispatchToJSON 1322 :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp 1323dispatchToJSON target jc n tvMap = 1324 dispatchFunByType jc (targetToJSONFun target) n tvMap False 1325 1326dispatchParseJSON 1327 :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp 1328dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False 1329 1330-------------------------------------------------------------------------------- 1331-- Utility functions 1332-------------------------------------------------------------------------------- 1333 1334-- For the given Types, generate an instance context and head. 1335buildTypeInstance :: Name 1336 -- ^ The type constructor or data family name 1337 -> JSONClass 1338 -- ^ The typeclass to derive 1339 -> Cxt 1340 -- ^ The datatype context 1341 -> [Type] 1342 -- ^ The types to instantiate the instance with 1343 -> DatatypeVariant 1344 -- ^ Are we dealing with a data family instance or not 1345 -> Q (Cxt, Type) 1346buildTypeInstance tyConName jc dataCxt varTysOrig variant = do 1347 -- Make sure to expand through type/kind synonyms! Otherwise, the 1348 -- eta-reduction check might get tripped up over type variables in a 1349 -- synonym that are actually dropped. 1350 -- (See GHC Trac #11416 for a scenario where this actually happened.) 1351 varTysExp <- mapM resolveTypeSynonyms varTysOrig 1352 1353 let remainingLength :: Int 1354 remainingLength = length varTysOrig - arityInt jc 1355 1356 droppedTysExp :: [Type] 1357 droppedTysExp = drop remainingLength varTysExp 1358 1359 droppedStarKindStati :: [StarKindStatus] 1360 droppedStarKindStati = map canRealizeKindStar droppedTysExp 1361 1362 -- Check there are enough types to drop and that all of them are either of 1363 -- kind * or kind k (for some kind variable k). If not, throw an error. 1364 when (remainingLength < 0 || elem NotKindStar droppedStarKindStati) $ 1365 derivingKindError jc tyConName 1366 1367 let droppedKindVarNames :: [Name] 1368 droppedKindVarNames = catKindVarNames droppedStarKindStati 1369 1370 -- Substitute kind * for any dropped kind variables 1371 varTysExpSubst :: [Type] 1372 varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp 1373 1374 remainingTysExpSubst, droppedTysExpSubst :: [Type] 1375 (remainingTysExpSubst, droppedTysExpSubst) = 1376 splitAt remainingLength varTysExpSubst 1377 1378 -- All of the type variables mentioned in the dropped types 1379 -- (post-synonym expansion) 1380 droppedTyVarNames :: [Name] 1381 droppedTyVarNames = freeVariables droppedTysExpSubst 1382 1383 -- If any of the dropped types were polykinded, ensure that they are of kind * 1384 -- after substituting * for the dropped kind variables. If not, throw an error. 1385 unless (all hasKindStar droppedTysExpSubst) $ 1386 derivingKindError jc tyConName 1387 1388 let preds :: [Maybe Pred] 1389 kvNames :: [[Name]] 1390 kvNames' :: [Name] 1391 -- Derive instance constraints (and any kind variables which are specialized 1392 -- to * in those constraints) 1393 (preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst 1394 kvNames' = concat kvNames 1395 1396 -- Substitute the kind variables specialized in the constraints with * 1397 remainingTysExpSubst' :: [Type] 1398 remainingTysExpSubst' = 1399 map (substNamesWithKindStar kvNames') remainingTysExpSubst 1400 1401 -- We now substitute all of the specialized-to-* kind variable names with 1402 -- *, but in the original types, not the synonym-expanded types. The reason 1403 -- we do this is a superficial one: we want the derived instance to resemble 1404 -- the datatype written in source code as closely as possible. For example, 1405 -- for the following data family instance: 1406 -- 1407 -- data family Fam a 1408 -- newtype instance Fam String = Fam String 1409 -- 1410 -- We'd want to generate the instance: 1411 -- 1412 -- instance C (Fam String) 1413 -- 1414 -- Not: 1415 -- 1416 -- instance C (Fam [Char]) 1417 remainingTysOrigSubst :: [Type] 1418 remainingTysOrigSubst = 1419 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames')) 1420 $ take remainingLength varTysOrig 1421 1422 isDataFamily :: Bool 1423 isDataFamily = case variant of 1424 Datatype -> False 1425 Newtype -> False 1426 DataInstance -> True 1427 NewtypeInstance -> True 1428 1429 remainingTysOrigSubst' :: [Type] 1430 -- See Note [Kind signatures in derived instances] for an explanation 1431 -- of the isDataFamily check. 1432 remainingTysOrigSubst' = 1433 if isDataFamily 1434 then remainingTysOrigSubst 1435 else map unSigT remainingTysOrigSubst 1436 1437 instanceCxt :: Cxt 1438 instanceCxt = catMaybes preds 1439 1440 instanceType :: Type 1441 instanceType = AppT (ConT $ jsonClassName jc) 1442 $ applyTyCon tyConName remainingTysOrigSubst' 1443 1444 -- If the datatype context mentions any of the dropped type variables, 1445 -- we can't derive an instance, so throw an error. 1446 when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ 1447 datatypeContextError tyConName instanceType 1448 -- Also ensure the dropped types can be safely eta-reduced. Otherwise, 1449 -- throw an error. 1450 unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ 1451 etaReductionError instanceType 1452 return (instanceCxt, instanceType) 1453 1454-- | Attempt to derive a constraint on a Type. If successful, return 1455-- Just the constraint and any kind variable names constrained to *. 1456-- Otherwise, return Nothing and the empty list. 1457-- 1458-- See Note [Type inference in derived instances] for the heuristics used to 1459-- come up with constraints. 1460deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name]) 1461deriveConstraint jc t 1462 | not (isTyVar t) = (Nothing, []) 1463 | hasKindStar t = (Just (applyCon (jcConstraint Arity0) tName), []) 1464 | otherwise = case hasKindVarChain 1 t of 1465 Just ns | jcArity >= Arity1 1466 -> (Just (applyCon (jcConstraint Arity1) tName), ns) 1467 _ -> case hasKindVarChain 2 t of 1468 Just ns | jcArity == Arity2 1469 -> (Just (applyCon (jcConstraint Arity2) tName), ns) 1470 _ -> (Nothing, []) 1471 where 1472 tName :: Name 1473 tName = varTToName t 1474 1475 jcArity :: Arity 1476 jcArity = arity jc 1477 1478 jcConstraint :: Arity -> Name 1479 jcConstraint = jsonClassName . JSONClass (direction jc) 1480 1481{- 1482Note [Kind signatures in derived instances] 1483~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1484 1485It is possible to put explicit kind signatures into the derived instances, e.g., 1486 1487 instance C a => C (Data (f :: * -> *)) where ... 1488 1489But it is preferable to avoid this if possible. If we come up with an incorrect 1490kind signature (which is entirely possible, since Template Haskell doesn't always 1491have the best track record with reifying kind signatures), then GHC will flat-out 1492reject the instance, which is quite unfortunate. 1493 1494Plain old datatypes have the advantage that you can avoid using any kind signatures 1495at all in their instances. This is because a datatype declaration uses all type 1496variables, so the types that we use in a derived instance uniquely determine their 1497kinds. As long as we plug in the right types, the kind inferencer can do the rest 1498of the work. For this reason, we use unSigT to remove all kind signatures before 1499splicing in the instance context and head. 1500 1501Data family instances are trickier, since a data family can have two instances that 1502are distinguished by kind alone, e.g., 1503 1504 data family Fam (a :: k) 1505 data instance Fam (a :: * -> *) 1506 data instance Fam (a :: *) 1507 1508If we dropped the kind signatures for C (Fam a), then GHC will have no way of 1509knowing which instance we are talking about. To avoid this scenario, we always 1510include explicit kind signatures in data family instances. There is a chance that 1511the inferred kind signatures will be incorrect, but if so, we can always fall back 1512on the mk- functions. 1513 1514Note [Type inference in derived instances] 1515~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1516 1517Type inference is can be tricky to get right, and we want to avoid recreating the 1518entirety of GHC's type inferencer in Template Haskell. For this reason, we will 1519probably never come up with derived instance contexts that are as accurate as 1520GHC's. But that doesn't mean we can't do anything! There are a couple of simple 1521things we can do to make instance contexts that work for 80% of use cases: 1522 15231. If one of the last type parameters is polykinded, then its kind will be 1524 specialized to * in the derived instance. We note what kind variable the type 1525 parameter had and substitute it with * in the other types as well. For example, 1526 imagine you had 1527 1528 data Data (a :: k) (b :: k) 1529 1530 Then you'd want to derived instance to be: 1531 1532 instance C (Data (a :: *)) 1533 1534 Not: 1535 1536 instance C (Data (a :: k)) 1537 15382. We naïvely come up with instance constraints using the following criteria: 1539 1540 (i) If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n 1541 constraint. 1542 (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind 1543 variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if 1544 k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the 1545 types. We must consider the case where they are kind variables because 1546 you might have a scenario like this: 1547 1548 newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) 1549 = Compose (f (g a)) 1550 1551 Which would have a derived ToJSON1 instance of: 1552 1553 instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ... 1554 (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are 1555 * or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint 1556 and perform kind substitution as in the other cases. 1557-} 1558 1559checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name 1560 -> Q a -> Q a 1561checkExistentialContext jc tvMap ctxt conName q = 1562 if (any (`predMentionsName` M.keys tvMap) ctxt 1563 || M.size tvMap < arityInt jc) 1564 && not (allowExQuant jc) 1565 then existentialContextError conName 1566 else q 1567 1568{- 1569Note [Matching functions with GADT type variables] 1570~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1571 1572When deriving ToJSON2, there is a tricky corner case to consider: 1573 1574 data Both a b where 1575 BothCon :: x -> x -> Both x x 1576 1577Which encoding functions should be applied to which arguments of BothCon? 1578We have a choice, since both the function of type (a -> Value) and of type 1579(b -> Value) can be applied to either argument. In such a scenario, the 1580second encoding function takes precedence over the first encoding function, so the 1581derived ToJSON2 instance would be something like: 1582 1583 instance ToJSON2 Both where 1584 liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do 1585 mv <- unsafeNew 2 1586 unsafeWrite mv 0 (tj1 x1) 1587 unsafeWrite mv 1 (tj2 x2) 1588 return mv 1589 1590This is not an arbitrary choice, as this definition ensures that 1591liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for 1592Both. 1593-} 1594 1595-- A mapping of type variable Names to their encoding/decoding function Names. 1596-- For example, in a ToJSON2 declaration, a TyVarMap might look like 1597-- 1598-- { a ~> (tj1, tjl1) 1599-- , b ~> (tj2, tjl2) } 1600-- 1601-- where a and b are the last two type variables of the datatype, tj1 and tjl1 are 1602-- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2 1603-- are the function arguments of types (b -> Value) and ([b] -> Value). 1604type TyVarMap = Map Name (Name, Name) 1605 1606-- | Returns True if a Type has kind *. 1607hasKindStar :: Type -> Bool 1608hasKindStar VarT{} = True 1609hasKindStar (SigT _ StarT) = True 1610hasKindStar _ = False 1611 1612-- Returns True is a kind is equal to *, or if it is a kind variable. 1613isStarOrVar :: Kind -> Bool 1614isStarOrVar StarT = True 1615isStarOrVar VarT{} = True 1616isStarOrVar _ = False 1617 1618-- Generate a list of fresh names with a common prefix, and numbered suffixes. 1619newNameList :: String -> Int -> Q [Name] 1620newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]] 1621 1622-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form 1623-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or 1624-- kind variables. 1625hasKindVarChain :: Int -> Type -> Maybe [Name] 1626hasKindVarChain kindArrows t = 1627 let uk = uncurryKind (tyKind t) 1628 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk 1629 then Just (concatMap freeVariables uk) 1630 else Nothing 1631 1632-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. 1633tyKind :: Type -> Kind 1634tyKind (SigT _ k) = k 1635tyKind _ = starK 1636 1637-- | Extract Just the Name from a type variable. If the argument Type is not a 1638-- type variable, return Nothing. 1639varTToNameMaybe :: Type -> Maybe Name 1640varTToNameMaybe (VarT n) = Just n 1641varTToNameMaybe (SigT t _) = varTToNameMaybe t 1642varTToNameMaybe _ = Nothing 1643 1644-- | Extract the Name from a type variable. If the argument Type is not a 1645-- type variable, throw an error. 1646varTToName :: Type -> Name 1647varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe 1648 1649interleave :: [a] -> [a] -> [a] 1650interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s 1651interleave _ _ = [] 1652 1653-- | Fully applies a type constructor to its type variables. 1654applyTyCon :: Name -> [Type] -> Type 1655applyTyCon = foldl' AppT . ConT 1656 1657-- | Is the given type a variable? 1658isTyVar :: Type -> Bool 1659isTyVar (VarT _) = True 1660isTyVar (SigT t _) = isTyVar t 1661isTyVar _ = False 1662 1663-- | Detect if a Name in a list of provided Names occurs as an argument to some 1664-- type family. This makes an effort to exclude /oversaturated/ arguments to 1665-- type families. For instance, if one declared the following type family: 1666-- 1667-- @ 1668-- type family F a :: Type -> Type 1669-- @ 1670-- 1671-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, 1672-- but not @b@. 1673isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool 1674isInTypeFamilyApp names tyFun tyArgs = 1675 case tyFun of 1676 ConT tcName -> go tcName 1677 _ -> return False 1678 where 1679 go :: Name -> Q Bool 1680 go tcName = do 1681 info <- reify tcName 1682 case info of 1683#if MIN_VERSION_template_haskell(2,11,0) 1684 FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ 1685 -> withinFirstArgs bndrs 1686 FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ 1687 -> withinFirstArgs bndrs 1688#else 1689 FamilyI (FamilyD TypeFam _ bndrs _) _ 1690 -> withinFirstArgs bndrs 1691 FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ 1692 -> withinFirstArgs bndrs 1693#endif 1694 _ -> return False 1695 where 1696 withinFirstArgs :: [a] -> Q Bool 1697 withinFirstArgs bndrs = 1698 let firstArgs = take (length bndrs) tyArgs 1699 argFVs = freeVariables firstArgs 1700 in return $ any (`elem` argFVs) names 1701 1702-- | Peel off a kind signature from a Type (if it has one). 1703unSigT :: Type -> Type 1704unSigT (SigT t _) = t 1705unSigT t = t 1706 1707-- | Are all of the items in a list (which have an ordering) distinct? 1708-- 1709-- This uses Set (as opposed to nub) for better asymptotic time complexity. 1710allDistinct :: Ord a => [a] -> Bool 1711allDistinct = allDistinct' Set.empty 1712 where 1713 allDistinct' :: Ord a => Set a -> [a] -> Bool 1714 allDistinct' uniqs (x:xs) 1715 | x `Set.member` uniqs = False 1716 | otherwise = allDistinct' (Set.insert x uniqs) xs 1717 allDistinct' _ _ = True 1718 1719-- | Does the given type mention any of the Names in the list? 1720mentionsName :: Type -> [Name] -> Bool 1721mentionsName = go 1722 where 1723 go :: Type -> [Name] -> Bool 1724 go (AppT t1 t2) names = go t1 names || go t2 names 1725 go (SigT t _k) names = go t names 1726 || go _k names 1727 go (VarT n) names = n `elem` names 1728 go _ _ = False 1729 1730-- | Does an instance predicate mention any of the Names in the list? 1731predMentionsName :: Pred -> [Name] -> Bool 1732#if MIN_VERSION_template_haskell(2,10,0) 1733predMentionsName = mentionsName 1734#else 1735predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys 1736predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names 1737#endif 1738 1739-- | Split an applied type into its individual components. For example, this: 1740-- 1741-- @ 1742-- Either Int Char 1743-- @ 1744-- 1745-- would split to this: 1746-- 1747-- @ 1748-- [Either, Int, Char] 1749-- @ 1750unapplyTy :: Type -> NonEmpty Type 1751unapplyTy = NE.reverse . go 1752 where 1753 go :: Type -> NonEmpty Type 1754 go (AppT t1 t2) = t2 <| go t1 1755 go (SigT t _) = go t 1756 go (ForallT _ _ t) = go t 1757 go t = t :| [] 1758 1759-- | Split a type signature by the arrows on its spine. For example, this: 1760-- 1761-- @ 1762-- forall a b. (a ~ b) => (a -> b) -> Char -> () 1763-- @ 1764-- 1765-- would split to this: 1766-- 1767-- @ 1768-- (a ~ b, [a -> b, Char, ()]) 1769-- @ 1770uncurryTy :: Type -> (Cxt, NonEmpty Type) 1771uncurryTy (AppT (AppT ArrowT t1) t2) = 1772 let (ctxt, tys) = uncurryTy t2 1773 in (ctxt, t1 <| tys) 1774uncurryTy (SigT t _) = uncurryTy t 1775uncurryTy (ForallT _ ctxt t) = 1776 let (ctxt', tys) = uncurryTy t 1777 in (ctxt ++ ctxt', tys) 1778uncurryTy t = ([], t :| []) 1779 1780-- | Like uncurryType, except on a kind level. 1781uncurryKind :: Kind -> NonEmpty Kind 1782uncurryKind = snd . uncurryTy 1783 1784createKindChain :: Int -> Kind 1785createKindChain = go starK 1786 where 1787 go :: Kind -> Int -> Kind 1788 go k 0 = k 1789 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) 1790 1791-- | Makes a string literal expression from a constructor's name. 1792conNameExp :: Options -> ConstructorInfo -> Q Exp 1793conNameExp opts = litE 1794 . stringL 1795 . constructorTagModifier opts 1796 . nameBase 1797 . constructorName 1798 1799-- | Extracts a record field label. 1800fieldLabel :: Options -- ^ Encoding options 1801 -> Name 1802 -> String 1803fieldLabel opts = fieldLabelModifier opts . nameBase 1804 1805-- | The name of the outermost 'Value' constructor. 1806valueConName :: Value -> String 1807valueConName (Object _) = "Object" 1808valueConName (Array _) = "Array" 1809valueConName (String _) = "String" 1810valueConName (Number _) = "Number" 1811valueConName (Bool _) = "Boolean" 1812valueConName Null = "Null" 1813 1814applyCon :: Name -> Name -> Pred 1815applyCon con t = 1816#if MIN_VERSION_template_haskell(2,10,0) 1817 AppT (ConT con) (VarT t) 1818#else 1819 ClassP con [VarT t] 1820#endif 1821 1822-- | Checks to see if the last types in a data family instance can be safely eta- 1823-- reduced (i.e., dropped), given the other types. This checks for three conditions: 1824-- 1825-- (1) All of the dropped types are type variables 1826-- (2) All of the dropped types are distinct 1827-- (3) None of the remaining types mention any of the dropped types 1828canEtaReduce :: [Type] -> [Type] -> Bool 1829canEtaReduce remaining dropped = 1830 all isTyVar dropped 1831 && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type 1832 -- didn't have an Ord instance until template-haskell-2.10.0.0 1833 && not (any (`mentionsName` droppedNames) remaining) 1834 where 1835 droppedNames :: [Name] 1836 droppedNames = map varTToName dropped 1837 1838------------------------------------------------------------------------------- 1839-- Expanding type synonyms 1840------------------------------------------------------------------------------- 1841 1842applySubstitutionKind :: Map Name Kind -> Type -> Type 1843applySubstitutionKind = applySubstitution 1844 1845substNameWithKind :: Name -> Kind -> Type -> Type 1846substNameWithKind n k = applySubstitutionKind (M.singleton n k) 1847 1848substNamesWithKindStar :: [Name] -> Type -> Type 1849substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns 1850 1851------------------------------------------------------------------------------- 1852-- Error messages 1853------------------------------------------------------------------------------- 1854 1855-- | Either the given data type doesn't have enough type variables, or one of 1856-- the type variables to be eta-reduced cannot realize kind *. 1857derivingKindError :: JSONClass -> Name -> Q a 1858derivingKindError jc tyConName = fail 1859 . showString "Cannot derive well-kinded instance of form ‘" 1860 . showString className 1861 . showChar ' ' 1862 . showParen True 1863 ( showString (nameBase tyConName) 1864 . showString " ..." 1865 ) 1866 . showString "‘\n\tClass " 1867 . showString className 1868 . showString " expects an argument of kind " 1869 . showString (pprint . createKindChain $ arityInt jc) 1870 $ "" 1871 where 1872 className :: String 1873 className = nameBase $ jsonClassName jc 1874 1875-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce 1876-- function for the criteria it would have to meet). 1877etaReductionError :: Type -> Q a 1878etaReductionError instanceType = fail $ 1879 "Cannot eta-reduce to an instance of form \n\tinstance (...) => " 1880 ++ pprint instanceType 1881 1882-- | The data type has a DatatypeContext which mentions one of the eta-reduced 1883-- type variables. 1884datatypeContextError :: Name -> Type -> Q a 1885datatypeContextError dataName instanceType = fail 1886 . showString "Can't make a derived instance of ‘" 1887 . showString (pprint instanceType) 1888 . showString "‘:\n\tData type ‘" 1889 . showString (nameBase dataName) 1890 . showString "‘ must not have a class context involving the last type argument(s)" 1891 $ "" 1892 1893-- | The data type mentions one of the n eta-reduced type variables in a place other 1894-- than the last nth positions of a data type in a constructor's field. 1895outOfPlaceTyVarError :: JSONClass -> Name -> a 1896outOfPlaceTyVarError jc conName = error 1897 . showString "Constructor ‘" 1898 . showString (nameBase conName) 1899 . showString "‘ must only use its last " 1900 . shows n 1901 . showString " type variable(s) within the last " 1902 . shows n 1903 . showString " argument(s) of a data type" 1904 $ "" 1905 where 1906 n :: Int 1907 n = arityInt jc 1908 1909-- | The data type has an existential constraint which mentions one of the 1910-- eta-reduced type variables. 1911existentialContextError :: Name -> a 1912existentialContextError conName = error 1913 . showString "Constructor ‘" 1914 . showString (nameBase conName) 1915 . showString "‘ must be truly polymorphic in the last argument(s) of the data type" 1916 $ "" 1917 1918------------------------------------------------------------------------------- 1919-- Class-specific constants 1920------------------------------------------------------------------------------- 1921 1922-- | A representation of the arity of the ToJSON/FromJSON typeclass being derived. 1923data Arity = Arity0 | Arity1 | Arity2 1924 deriving (Enum, Eq, Ord) 1925 1926-- | Whether ToJSON(1)(2) or FromJSON(1)(2) is being derived. 1927data Direction = To | From 1928 1929-- | A representation of which typeclass method is being spliced in. 1930data JSONFun = ToJSON | ToEncoding | ParseJSON 1931 1932-- | A refinement of JSONFun to [ToJSON, ToEncoding]. 1933data ToJSONFun = Value | Encoding 1934 1935targetToJSONFun :: ToJSONFun -> JSONFun 1936targetToJSONFun Value = ToJSON 1937targetToJSONFun Encoding = ToEncoding 1938 1939-- | A representation of which typeclass is being derived. 1940data JSONClass = JSONClass { direction :: Direction, arity :: Arity } 1941 1942toJSONClass, toJSON1Class, toJSON2Class, 1943 fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass 1944toJSONClass = JSONClass To Arity0 1945toJSON1Class = JSONClass To Arity1 1946toJSON2Class = JSONClass To Arity2 1947fromJSONClass = JSONClass From Arity0 1948fromJSON1Class = JSONClass From Arity1 1949fromJSON2Class = JSONClass From Arity2 1950 1951jsonClassName :: JSONClass -> Name 1952jsonClassName (JSONClass To Arity0) = ''ToJSON 1953jsonClassName (JSONClass To Arity1) = ''ToJSON1 1954jsonClassName (JSONClass To Arity2) = ''ToJSON2 1955jsonClassName (JSONClass From Arity0) = ''FromJSON 1956jsonClassName (JSONClass From Arity1) = ''FromJSON1 1957jsonClassName (JSONClass From Arity2) = ''FromJSON2 1958 1959jsonFunValName :: JSONFun -> Arity -> Name 1960jsonFunValName ToJSON Arity0 = 'toJSON 1961jsonFunValName ToJSON Arity1 = 'liftToJSON 1962jsonFunValName ToJSON Arity2 = 'liftToJSON2 1963jsonFunValName ToEncoding Arity0 = 'toEncoding 1964jsonFunValName ToEncoding Arity1 = 'liftToEncoding 1965jsonFunValName ToEncoding Arity2 = 'liftToEncoding2 1966jsonFunValName ParseJSON Arity0 = 'parseJSON 1967jsonFunValName ParseJSON Arity1 = 'liftParseJSON 1968jsonFunValName ParseJSON Arity2 = 'liftParseJSON2 1969 1970jsonFunListName :: JSONFun -> Arity -> Name 1971jsonFunListName ToJSON Arity0 = 'toJSONList 1972jsonFunListName ToJSON Arity1 = 'liftToJSONList 1973jsonFunListName ToJSON Arity2 = 'liftToJSONList2 1974jsonFunListName ToEncoding Arity0 = 'toEncodingList 1975jsonFunListName ToEncoding Arity1 = 'liftToEncodingList 1976jsonFunListName ToEncoding Arity2 = 'liftToEncodingList2 1977jsonFunListName ParseJSON Arity0 = 'parseJSONList 1978jsonFunListName ParseJSON Arity1 = 'liftParseJSONList 1979jsonFunListName ParseJSON Arity2 = 'liftParseJSONList2 1980 1981jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False 1982 -> JSONFun -> Arity -> Name 1983jsonFunValOrListName False = jsonFunValName 1984jsonFunValOrListName True = jsonFunListName 1985 1986arityInt :: JSONClass -> Int 1987arityInt = fromEnum . arity 1988 1989allowExQuant :: JSONClass -> Bool 1990allowExQuant (JSONClass To _) = True 1991allowExQuant _ = False 1992 1993------------------------------------------------------------------------------- 1994-- StarKindStatus 1995------------------------------------------------------------------------------- 1996 1997-- | Whether a type is not of kind *, is of kind *, or is a kind variable. 1998data StarKindStatus = NotKindStar 1999 | KindStar 2000 | IsKindVar Name 2001 deriving Eq 2002 2003-- | Does a Type have kind * or k (for some kind variable k)? 2004canRealizeKindStar :: Type -> StarKindStatus 2005canRealizeKindStar t = case t of 2006 _ | hasKindStar t -> KindStar 2007 SigT _ (VarT k) -> IsKindVar k 2008 _ -> NotKindStar 2009 2010-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. 2011-- Otherwise, returns 'Nothing'. 2012starKindStatusToName :: StarKindStatus -> Maybe Name 2013starKindStatusToName (IsKindVar n) = Just n 2014starKindStatusToName _ = Nothing 2015 2016-- | Concat together all of the StarKindStatuses that are IsKindVar and extract 2017-- the kind variables' Names out. 2018catKindVarNames :: [StarKindStatus] -> [Name] 2019catKindVarNames = mapMaybe starKindStatusToName 2020