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