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