@@ -1,5 +1,9 @@
1−{-# LANGUAGE CPP, FlexibleInstances, NamedFieldPuns,
2− NoImplicitPrelude, UndecidableInstances #-}
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE NamedFieldPuns #-}
5+{-# LANGUAGE NoImplicitPrelude #-}
6+{-# LANGUAGE UndecidableInstances #-}
37#if __GLASGOW_HASKELL__ >= 800
48-- a) THQ works on cross-compilers and unregisterised GHCs
59-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)
@@ -87,19 +91,32 @@ module Data.Aeson.TH
8791
8892 -- * FromJSON and ToJSON derivation
8993 , deriveJSON
94+ , deriveJSON1
95+ , deriveJSON2
9096
9197 , deriveToJSON
98+ , deriveToJSON1
99+ , deriveToJSON2
92100 , deriveFromJSON
101+ , deriveFromJSON1
102+ , deriveFromJSON2
93103
94104 , mkToJSON
105+ , mkLiftToJSON
106+ , mkLiftToJSON2
95107 , mkToEncoding
108+ , mkLiftToEncoding
109+ , mkLiftToEncoding2
96110 , mkParseJSON
111+ , mkLiftParseJSON
112+ , mkLiftParseJSON2
97113 ) where
98114
99115import Control.Applicative ( pure, (<$>), (<*>) )
100−import Data.Aeson ( toJSON, Object, (.=), (.:), (.:?)
101− , ToJSON, toEncoding, toJSON
102− , FromJSON, parseJSON
116+import Data.Aeson ( Object, (.=), (.:)
117+ , ToJSON(..), FromJSON(..)
118+ , ToJSON1(..), FromJSON1(..)
119+ , ToJSON2(..), FromJSON2(..)
103120 )
104121import Data.Aeson.Types ( Value(..), Parser
105122 , Options(..)
@@ -107,32 +124,42 @@ import Data.Aeson.Types ( Value(..), Parser
107124 , defaultOptions
108125 , defaultTaggedObject
109126 )
110−import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
111−import Control.Monad ( liftM2, return, mapM, fail )
127+import Data.Aeson.Types.Internal (Pair, (<?>), JSONPathElement(Key))
128+import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
129+import Control.Monad ( fail, liftM2, mapM, return, unless, when )
112130import Data.Bool ( Bool(False, True), otherwise, (&&), not )
113131import Data.Either ( Either(Left, Right) )
114132import Data.Eq ( (==) )
133+import Data.Foldable ( concatMap, foldr' )
115134import Data.Function ( ($), (.), flip )
116135import Data.Functor ( fmap )
117136import Data.Int ( Int )
118137import Data.List ( (++), all, any, find, foldl, foldl'
119138 , genericLength , intercalate , intersperse, length, map
120− , partition, zip
139+ , partition, union, zip, zip3
121140 )
141+import Data.List.NonEmpty ( NonEmpty((:|)), (<|) )
122142import Data.Map ( Map )
123−import Data.Maybe ( Maybe(Nothing, Just), catMaybes )
143+import Data.Maybe ( Maybe(Nothing, Just), catMaybes, fromMaybe, mapMaybe )
124144import Data.Monoid ( (<>), mconcat )
145+import Data.Set ( Set )
125146import Language.Haskell.TH
147+#if MIN_VERSION_template_haskell(2,8,0)
148+ hiding ( Arity )
149+#endif
126150import Language.Haskell.TH.Syntax ( VarStrictType )
127−import Prelude ( String, (-), Integer, error, foldr1, fromIntegral
128− , splitAt, zipWith
151+import Prelude ( Enum(..), Eq(..), Integer, Ord(..), String
152+ , concat, cycle, drop, elem, error, foldr1, fromIntegral
153+ , showChar, showParen, shows, showString, snd, splitAt
154+ , take, unzip, zipWith, (-), (||)
129155 )
156+#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
157+import Language.Haskell.TH.Lib ( starK )
158+#endif
130159#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
131−import Data.Foldable ( foldr' )
132−import qualified Data.Map as M ( singleton )
133160import Data.List ( nub )
134161import Language.Haskell.TH.Syntax ( mkNameG_tc )
135−import Prelude ( concatMap, uncurry )
162+import Prelude ( uncurry )
136163#endif
137164#if MIN_VERSION_template_haskell(2,11,0)
138165import Prelude ( head )
@@ -141,8 +168,13 @@ import Text.Printf ( printf )
141168import Text.Show ( show )
142169import qualified Data.Aeson as A
143170import qualified Data.Aeson.Encoding.Internal as E
171+import qualified Data.Foldable as F ( all )
144172import qualified Data.HashMap.Strict as H ( lookup, toList )
145−import qualified Data.Map as M ( fromList, findWithDefault )
173+import qualified Data.List.NonEmpty as NE ( drop, length, reverse, splitAt )
174+import qualified Data.Map as M ( fromList, findWithDefault, keys, lookup
175+ , singleton, size
176+ )
177+import qualified Data.Set as Set ( empty, insert, member )
146178import qualified Data.Text as T ( Text, pack, unpack )
147179import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )
148180import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
@@ -163,11 +195,33 @@ deriveJSON :: Options
163195 -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
164196 -- instances.
165197 -> Q [Dec]
166−deriveJSON opts name =
167− liftM2 (++)
168− (deriveToJSON opts name)
169− (deriveFromJSON opts name)
198+deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON
170199
200+-- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given
201+-- data type or data family instance constructor.
202+--
203+-- This is a convienience function which is equivalent to calling both
204+-- 'deriveToJSON1' and 'deriveFromJSON1'.
205+deriveJSON1 :: Options
206+ -- ^ Encoding options.
207+ -> Name
208+ -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'
209+ -- instances.
210+ -> Q [Dec]
211+deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1
212+
213+-- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given
214+-- data type or data family instance constructor.
215+--
216+-- This is a convienience function which is equivalent to calling both
217+-- 'deriveToJSON2' and 'deriveFromJSON2'.
218+deriveJSON2 :: Options
219+ -- ^ Encoding options.
220+ -> Name
221+ -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'
222+ -- instances.
223+ -> Q [Dec]
224+deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2
171225
172226--------------------------------------------------------------------------------
173227-- ToJSON
@@ -190,69 +244,130 @@ deriveToJSON :: Options
190244 -- ^ Name of the type for which to generate a 'ToJSON' instance
191245 -- declaration.
192246 -> Q [Dec]
193−deriveToJSON opts name =
194− withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
195− where
196− fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
197− fromCons name' tvbs cons mbTys = do
198− (instanceCxt, instanceType) <- buildTypeInstance name' ''ToJSON tvbs mbTys
199− instanceD (return instanceCxt)
200− (return instanceType)
201− [ funD 'toJSON
202− [ clause []
203− (normalB $ consToValue opts cons)
204− []
205− ]
206− , funD 'toEncoding
207− [ clause []
208− (normalB $ consToEncoding opts cons)
209− []
210− ]
211− ]
247+deriveToJSON = deriveToJSONCommon toJSONClass
248+
249+-- | Generates a 'ToJSON1' instance declaration for the given data type or
250+-- data family instance constructor.
251+deriveToJSON1 :: Options
252+ -- ^ Encoding options.
253+ -> Name
254+ -- ^ Name of the type for which to generate a 'ToJSON1' instance
255+ -- declaration.
256+ -> Q [Dec]
257+deriveToJSON1 = deriveToJSONCommon toJSON1Class
258+
259+-- | Generates a 'ToJSON2' instance declaration for the given data type or
260+-- data family instance constructor.
261+deriveToJSON2 :: Options
262+ -- ^ Encoding options.
263+ -> Name
264+ -- ^ Name of the type for which to generate a 'ToJSON2' instance
265+ -- declaration.
266+ -> Q [Dec]
267+deriveToJSON2 = deriveToJSONCommon toJSON2Class
268+
269+deriveToJSONCommon :: JSONClass
270+ -- ^ The ToJSON variant being derived.
271+ -> Options
272+ -- ^ Encoding options.
273+ -> Name
274+ -- ^ Name of the type for which to generate an instance.
275+ -> Q [Dec]
276+deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue jc)
277+ , (ToEncoding, \jc _ -> consToEncoding jc)
278+ ]
212279
213280-- | Generates a lambda expression which encodes the given data type or
214281-- data family instance constructor as a 'Value'.
215282mkToJSON :: Options -- ^ Encoding options.
216283 -> Name -- ^ Name of the type to encode.
217284 -> Q Exp
218−mkToJSON opts name = withType name (\_ _ cons _ -> consToValue opts cons)
285+mkToJSON = mkToJSONCommon toJSONClass
286+
287+-- | Generates a lambda expression which encodes the given data type or
288+-- data family instance constructor as a 'Value' by using the given encoding
289+-- function on occurrences of the last type parameter.
290+mkLiftToJSON :: Options -- ^ Encoding options.
291+ -> Name -- ^ Name of the type to encode.
292+ -> Q Exp
293+mkLiftToJSON = mkToJSONCommon toJSON1Class
294+
295+-- | Generates a lambda expression which encodes the given data type or
296+-- data family instance constructor as a 'Value' by using the given encoding
297+-- functions on occurrences of the last two type parameters.
298+mkLiftToJSON2 :: Options -- ^ Encoding options.
299+ -> Name -- ^ Name of the type to encode.
300+ -> Q Exp
301+mkLiftToJSON2 = mkToJSONCommon toJSON2Class
302+
303+mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.
304+ -> Options -- ^ Encoding options.
305+ -> Name -- ^ Name of the encoded type.
306+ -> Q Exp
307+mkToJSONCommon = mkFunCommon (\jc _ -> consToValue jc)
219308
220309-- | Generates a lambda expression which encodes the given data type or
221310-- data family instance constructor as a JSON string.
222311mkToEncoding :: Options -- ^ Encoding options.
223312 -> Name -- ^ Name of the type to encode.
224313 -> Q Exp
225−mkToEncoding opts name = withType name (\_ _ cons _ -> consToEncoding opts cons)
314+mkToEncoding = mkToEncodingCommon toJSONClass
315+
316+-- | Generates a lambda expression which encodes the given data type or
317+-- data family instance constructor as a JSON string by using the given encoding
318+-- function on occurrences of the last type parameter.
319+mkLiftToEncoding :: Options -- ^ Encoding options.
320+ -> Name -- ^ Name of the type to encode.
321+ -> Q Exp
322+mkLiftToEncoding = mkToEncodingCommon toJSON1Class
323+
324+-- | Generates a lambda expression which encodes the given data type or
325+-- data family instance constructor as a JSON string by using the given encoding
326+-- functions on occurrences of the last two type parameters.
327+mkLiftToEncoding2 :: Options -- ^ Encoding options.
328+ -> Name -- ^ Name of the type to encode.
329+ -> Q Exp
330+mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class
331+
332+mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.
333+ -> Options -- ^ Encoding options.
334+ -> Name -- ^ Name of the encoded type.
335+ -> Q Exp
336+mkToEncodingCommon = mkFunCommon (\jc _ -> consToEncoding jc)
226337
227338-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
228339-- code to generate a 'Value' of a number of constructors. All constructors
229340-- must be from the same type.
230−consToValue :: Options
231− -- ^ Encoding options.
232− -> [Con]
233− -- ^ Constructors for which to generate JSON generating code.
234− -> Q Exp
235−
236−consToValue _ [] = error $ "Data.Aeson.TH.consToValue: "
237− ++ "Not a single constructor given!"
341+consToValue :: JSONClass
342+ -- ^ The ToJSON variant being derived.
343+ -> Options
344+ -- ^ Encoding options.
345+ -> [Con]
346+ -- ^ Constructors for which to generate JSON generating code.
347+ -> Q Exp
238348
239−-- A single constructor is directly encoded. The constructor itself may be
240−-- forgotten.
241−consToValue opts [con] = do
242− value <- newName "value"
243− lam1E (varP value) $ caseE (varE value) [argsToValue opts False con]
349+consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "
350+ ++ "Not a single constructor given!"
244351
245−consToValue opts cons = do
352+consToValue jc opts cons = do
246353 value <- newName "value"
247− lam1E (varP value) $ caseE (varE value) matches
354+ tjs <- newNameList "_tj" $ arityInt jc
355+ tjls <- newNameList "_tjl" $ arityInt jc
356+ let zippedTJs = zip tjs tjls
357+ interleavedTJs = interleave tjs tjls
358+ lamE (map varP $ interleavedTJs ++ [value]) $
359+ caseE (varE value) (matches zippedTJs)
248360 where
249− matches
250− | allNullaryToStringTag opts && all isNullary cons =
361+ matches tjs = case cons of
362+ -- A single constructor is directly encoded. The constructor itself may be
363+ -- forgotten.
364+ [con] -> [argsToValue jc tjs opts False con]
365+ _ | allNullaryToStringTag opts && all isNullary cons ->
251366 [ match (conP conName []) (normalB $ conStr opts conName) []
252367 | con <- cons
253368 , let conName = getConName con
254369 ]
255− | otherwise = [argsToValue opts True con | con <- cons]
370+ | otherwise -> [argsToValue jc tjs opts True con | con <- cons]
256371
257372conStr :: Options -> Name -> Q Exp
258373conStr opts = appE [|String|] . conTxt opts
@@ -266,35 +381,39 @@ conStringE opts = stringE . constructorTagModifier opts . nameBase
266381-- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates
267382-- code to write out a value for a number of constructors. All constructors
268383-- must be from the same type.
269−consToEncoding :: Options
270− -- ^ Encoding options.
384+consToEncoding :: JSONClass
385+ -- ^ The ToJSON variant being derived.
386+ -> Options
387+ -- ^ Encoding options.
271388 -> [Con]
272389 -- ^ Constructors for which to generate JSON generating code.
273390 -> Q Exp
274391
275−consToEncoding _ [] = error $ "Data.Aeson.TH.consToEncoding: "
276− ++ "Not a single constructor given!"
392+consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
393+ ++ "Not a single constructor given!"
277394
278−-- A single constructor is directly encoded. The constructor itself may be
279−-- forgotten.
280−consToEncoding opts [con] = do
395+consToEncoding jc opts cons = do
281396 value <- newName "value"
282− lam1E (varP value) $ caseE (varE value) [argsToEncoding opts False con]
283−
284−-- Encode just the name of the constructor of a sum type iff all the
285−-- constructors are nullary.
286−consToEncoding opts cons = do
287− value <- newName "value"
288− lam1E (varP value) $ caseE (varE value) matches
397+ tes <- newNameList "_te" $ arityInt jc
398+ tels <- newNameList "_tel" $ arityInt jc
399+ let zippedTEs = zip tes tels
400+ interleavedTEs = interleave tes tels
401+ lamE (map varP $ interleavedTEs ++ [value]) $
402+ caseE (varE value) (matches zippedTEs)
289403 where
290− matches
291− | allNullaryToStringTag opts && all isNullary cons =
404+ matches tes = case cons of
405+ -- A single constructor is directly encoded. The constructor itself may be
406+ -- forgotten.
407+ [con] -> [argsToEncoding jc tes opts False con]
408+ -- Encode just the name of the constructor of a sum type iff all the
409+ -- constructors are nullary.
410+ _ | allNullaryToStringTag opts && all isNullary cons ->
292411 [ match (conP conName [])
293412 (normalB $ encStr opts conName) []
294413 | con <- cons
295414 , let conName = getConName con
296415 ]
297− | otherwise = [argsToEncoding opts True con | con <- cons]
416+ | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]
298417
299418encStr :: Options -> Name -> Q Exp
300419encStr opts = appE [|E.text|] . conTxt opts
@@ -332,20 +451,25 @@ nullarySumToValue opts multiCons conName =
332451 _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]
333452
334453-- | Generates code to generate the JSON encoding of a single constructor.
335−argsToValue :: Options -> Bool -> Con -> Q Match
454+argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
336455-- Nullary constructors. Generates code that explicitly matches against the
337456-- constructor even though it doesn't contain data. This is useful to prevent
338457-- type errors.
339−argsToValue opts multiCons (NormalC conName []) =
458+argsToValue jc tjs opts multiCons (NormalC conName []) = do
459+ ([], _) <- reifyConTys jc tjs conName
340460 match (conP conName [])
341461 (normalB (nullarySumToValue opts multiCons conName))
342462 []
343463
344464-- Polyadic constructors with special case for unary constructors.
345−argsToValue opts multiCons (NormalC conName ts) = do
465+argsToValue jc tjs opts multiCons (NormalC conName ts) = do
466+ (argTys, tvMap) <- reifyConTys jc tjs conName
346467 let len = length ts
347− args <- mapM newName ["arg" ++ show n | n <- [1..len]]
348− js <- case [[|toJSON|] `appE` varE arg | arg <- args] of
468+ args <- newNameList "arg" len
469+ js <- case [ dispatchToJSON jc conName tvMap argTy
470+ `appE` varE arg
471+ | (arg, argTy) <- zip args argTys
472+ ] of
349473 -- Single argument is directly converted.
350474 [e] -> return e
351475 -- Multiple arguments are converted to a JSON array.
@@ -370,10 +494,11 @@ argsToValue opts multiCons (NormalC conName ts) = do
370494 []
371495
372496-- Records.
373−argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
374− (True,True,[(_,st,ty)]) -> argsToValue opts multiCons (NormalC conName [(st,ty)])
497+argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
498+ (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])
375499 _ -> do
376− args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
500+ (argTys, tvMap) <- reifyConTys jc tjs conName
501+ args <- newNameList "arg" $ length ts
377502 let exp = [|A.object|] `appE` pairs
378503
379504 pairs | omitNothingFields opts = infixApp maybeFields
@@ -381,7 +506,7 @@ argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, no
381506 restFields
382507 | otherwise = listE $ map toPair argCons
383508
384− argCons = zip args ts
509+ argCons = zip3 args argTys ts
385510
386511 maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
387512
@@ -389,17 +514,18 @@ argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, no
389514
390515 (maybes, rest) = partition isMaybe argCons
391516
392− maybeToPair (arg, (field, _, _)) =
393− infixApp (infixE (Just $ toFieldName field)
394− [|(.=)|]
395− Nothing)
517+ maybeToPair (arg, argTy, (field, _, _)) =
518+ infixApp ([|keyValuePairWith|]
519+ `appE` dispatchToJSON jc conName tvMap argTy
520+ `appE` toFieldName field)
396521 [|(<$>)|]
397522 (varE arg)
398523
399− toPair (arg, (field, _, _)) =
400− infixApp (toFieldName field)
401− [|(.=)|]
402− (varE arg)
524+ toPair (arg, argTy, (field, _, _)) =
525+ [|keyValuePairWith|]
526+ `appE` dispatchToJSON jc conName tvMap argTy
527+ `appE` toFieldName field
528+ `appE` varE arg
403529
404530 toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
405531
@@ -424,33 +550,35 @@ argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, no
424550 ) []
425551
426552-- Infix constructors.
427−argsToValue opts multiCons (InfixC _ conName _) = do
553+argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
554+ ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName
428555 al <- newName "argL"
429556 ar <- newName "argR"
430557 match (infixP (varP al) conName (varP ar))
431558 ( normalB
432559 $ sumToValue opts multiCons conName
433− $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a
434− | a <- [al,ar]
560+ $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy
561+ `appE` varE a
562+ | (a, aTy) <- [(al,alTy), (ar,arTy)]
435563 ]
436564 )
437565 []
438566-- Existentially quantified constructors.
439−argsToValue opts multiCons (ForallC _ _ con) =
440− argsToValue opts multiCons con
567+argsToValue jc tjs opts multiCons (ForallC _ _ con) =
568+ argsToValue jc tjs opts multiCons con
441569
442570#if MIN_VERSION_template_haskell(2,11,0)
443571-- GADTs.
444−argsToValue opts multiCons (GadtC conNames ts _) =
445− argsToValue opts multiCons $ NormalC (head conNames) ts
572+argsToValue jc tjs opts multiCons (GadtC conNames ts _) =
573+ argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts
446574
447−argsToValue opts multiCons (RecGadtC conNames ts _) =
448− argsToValue opts multiCons $ RecC (head conNames) ts
575+argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =
576+ argsToValue jc tjs opts multiCons $ RecC (head conNames) ts
449577#endif
450578
451−isMaybe :: (a, (b, c, Type)) -> Bool
452−isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe
453−isMaybe _ = False
579+isMaybe :: (a, b, (c, d, Type)) -> Bool
580+isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe
581+isMaybe _ = False
454582
455583(<^>) :: ExpQ -> ExpQ -> ExpQ
456584(<^>) a b = infixApp a [|(<>)|] b
@@ -468,7 +596,7 @@ array :: ExpQ -> ExpQ
468596array exp = [|E.wrapArray|] `appE` exp
469597
470598object :: ExpQ -> ExpQ
471−object exp = [|E.wrapObject|] `appE` exp
599+object exp = [|E.wrapObject|] `appE` exp
472600
473601sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp
474602sumToEncoding opts multiCons conName exp
@@ -495,35 +623,41 @@ nullarySumToEncoding opts multiCons conName =
495623 _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]
496624
497625-- | Generates code to generate the JSON encoding of a single constructor.
498−argsToEncoding :: Options -> Bool -> Con -> Q Match
626+argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
499627-- Nullary constructors. Generates code that explicitly matches against the
500628-- constructor even though it doesn't contain data. This is useful to prevent
501629-- type errors.
502−argsToEncoding opts multiCons (NormalC conName []) =
630+argsToEncoding jc tes opts multiCons (NormalC conName []) = do
631+ ([], _) <- reifyConTys jc tes conName
503632 match (conP conName [])
504633 (normalB (nullarySumToEncoding opts multiCons conName))
505634 []
506635
507636-- Polyadic constructors with special case for unary constructors.
508−argsToEncoding opts multiCons (NormalC conName ts) = do
637+argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
638+ (argTys, tvMap) <- reifyConTys jc tes conName
509639 let len = length ts
510− args <- mapM newName ["arg" ++ show n | n <- [1..len]]
511− js <- case args of
640+ args <- newNameList "arg" len
641+ js <- case zip args argTys of
512642 -- Single argument is directly converted.
513− [e] -> return ([|toEncoding|] `appE` varE e)
643+ [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy
644+ `appE` varE e)
514645 -- Multiple arguments are converted to a JSON array.
515646 es ->
516− return (array (foldr1 (<%>) [[|toEncoding|] `appE` varE x | x <- es]))
647+ return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy
648+ `appE` varE x
649+ | (x,xTy) <- es
650+ ]))
517651 match (conP conName $ map varP args)
518652 (normalB $ sumToEncoding opts multiCons conName js)
519653 []
520654
521655-- Records.
522−argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
523− (True,True,[(_,st,ty)]) -> argsToEncoding opts multiCons (NormalC conName [(st,ty)])
656+argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
657+ (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])
524658 _ -> do
525− args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
526−
659+ args <- newNameList "arg" $ length ts
660+ (argTys, tvMap) <- reifyConTys jc tes conName
527661 let exp = object objBody
528662
529663 objBody = [|mconcat|] `appE`
@@ -533,7 +667,7 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
533667 restFields
534668 | otherwise = listE (map toPair argCons)
535669
536− argCons = zip args ts
670+ argCons = zip3 args argTys ts
537671
538672 maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
539673
@@ -541,7 +675,7 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
541675
542676 (maybes, rest) = partition isMaybe argCons
543677
544− maybeToPair (arg, (field, _, _)) =
678+ maybeToPair (arg, argTy, (field, _, _)) =
545679 infixApp
546680 (infixApp
547681 (infixE
@@ -549,12 +683,14 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
549683 [|(<>)|]
550684 Nothing)
551685 [|(.)|]
552− [|toEncoding|])
686+ (dispatchToEncoding jc conName tvMap argTy))
553687 [|(<$>)|]
554688 (varE arg)
555689
556− toPair (arg, (field, _, _)) =
557− toFieldName field <:> [|toEncoding|] `appE` varE arg
690+ toPair (arg, argTy, (field, _, _)) =
691+ toFieldName field
692+ <:> dispatchToEncoding jc conName tvMap argTy
693+ `appE` varE arg
558694
559695 toFieldName field = [|E.text|] `appE`
560696 ([|T.pack|] `appE` fieldLabelExp opts field)
@@ -575,28 +711,30 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
575711 ) []
576712
577713-- Infix constructors.
578−argsToEncoding opts multiCons (InfixC _ conName _) = do
714+argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
579715 al <- newName "argL"
580716 ar <- newName "argR"
717+ ([alTy,arTy], tvMap) <- reifyConTys jc tes conName
581718 match (infixP (varP al) conName (varP ar))
582719 ( normalB
583720 $ sumToEncoding opts multiCons conName
584− $ [|toEncoding|] `appE` listE [ [|toJSON|] `appE` varE a
585− | a <- [al,ar]
586− ]
721+ $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy
722+ `appE` varE a
723+ | (a,aTy) <- [(al,alTy), (ar,arTy)]
724+ ])
587725 )
588726 []
589727-- Existentially quantified constructors.
590−argsToEncoding opts multiCons (ForallC _ _ con) =
591− argsToEncoding opts multiCons con
728+argsToEncoding jc tes opts multiCons (ForallC _ _ con) =
729+ argsToEncoding jc tes opts multiCons con
592730
593731#if MIN_VERSION_template_haskell(2,11,0)
594732-- GADTs.
595−argsToEncoding opts multiCons (GadtC conNames ts _) =
596− argsToEncoding opts multiCons $ NormalC (head conNames) ts
733+argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =
734+ argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts
597735
598−argsToEncoding opts multiCons (RecGadtC conNames ts _) =
599− argsToEncoding opts multiCons $ RecC (head conNames) ts
736+argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =
737+ argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts
600738#endif
601739
602740--------------------------------------------------------------------------------
@@ -611,33 +749,73 @@ deriveFromJSON :: Options
611749 -- ^ Name of the type for which to generate a 'FromJSON' instance
612750 -- declaration.
613751 -> Q [Dec]
614−deriveFromJSON opts name =
615− withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
616− where
617− fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
618− fromCons name' tvbs cons mbTys = do
619− (instanceCxt, instanceType) <- buildTypeInstance name' ''FromJSON tvbs mbTys
620− instanceD (return instanceCxt)
621− (return instanceType)
622− [ funD 'parseJSON
623− [ clause []
624− (normalB $ consFromJSON name' opts cons)
625− []
626− ]
627− ]
752+deriveFromJSON = deriveFromJSONCommon fromJSONClass
753+
754+-- | Generates a 'FromJSON1' instance declaration for the given data type or
755+-- data family instance constructor.
756+deriveFromJSON1 :: Options
757+ -- ^ Encoding options.
758+ -> Name
759+ -- ^ Name of the type for which to generate a 'FromJSON1' instance
760+ -- declaration.
761+ -> Q [Dec]
762+deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class
763+
764+-- | Generates a 'FromJSON2' instance declaration for the given data type or
765+-- data family instance constructor.
766+deriveFromJSON2 :: Options
767+ -- ^ Encoding options.
768+ -> Name
769+ -- ^ Name of the type for which to generate a 'FromJSON3' instance
770+ -- declaration.
771+ -> Q [Dec]
772+deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class
773+
774+deriveFromJSONCommon :: JSONClass
775+ -- ^ The FromJSON variant being derived.
776+ -> Options
777+ -- ^ Encoding options.
778+ -> Name
779+ -- ^ Name of the type for which to generate an instance.
780+ -- declaration.
781+ -> Q [Dec]
782+deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)]
628783
629784-- | Generates a lambda expression which parses the JSON encoding of the given
630785-- data type or data family instance constructor.
631786mkParseJSON :: Options -- ^ Encoding options.
632787 -> Name -- ^ Name of the encoded type.
633788 -> Q Exp
634−mkParseJSON opts name =
635− withType name (\name' _ cons _ -> consFromJSON name' opts cons)
789+mkParseJSON = mkParseJSONCommon fromJSONClass
790+
791+-- | Generates a lambda expression which parses the JSON encoding of the given
792+-- data type or data family instance constructor by using the given parsing
793+-- function on occurrences of the last type parameter.
794+mkLiftParseJSON :: Options -- ^ Encoding options.
795+ -> Name -- ^ Name of the encoded type.
796+ -> Q Exp
797+mkLiftParseJSON = mkParseJSONCommon fromJSON1Class
798+
799+-- | Generates a lambda expression which parses the JSON encoding of the given
800+-- data type or data family instance constructor by using the given parsing
801+-- functions on occurrences of the last two type parameters.
802+mkLiftParseJSON2 :: Options -- ^ Encoding options.
803+ -> Name -- ^ Name of the encoded type.
804+ -> Q Exp
805+mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class
806+
807+mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.
808+ -> Options -- ^ Encoding options.
809+ -> Name -- ^ Name of the encoded type.
810+ -> Q Exp
811+mkParseJSONCommon = mkFunCommon consFromJSON
636812
637813-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
638814-- code to parse the JSON encoding of a number of constructors. All constructors
639815-- must be from the same type.
640−consFromJSON :: Name
816+consFromJSON :: JSONClass
817+ -- ^ The FromJSON variant being derived.
818+ -> Name
641819 -- ^ Name of the type to which the constructors belong.
642820 -> Options
643821 -- ^ Encoding options
@@ -645,21 +823,25 @@ consFromJSON :: Name
645823 -- ^ Constructors for which to generate JSON parsing code.
646824 -> Q Exp
647825
648−consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
826+consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
649827 ++ "Not a single constructor given!"
650828
651−consFromJSON tName opts [con] = do
829+consFromJSON jc tName opts cons = do
652830 value <- newName "value"
653− lam1E (varP value) (parseArgs tName opts con (Right value))
654−
655−consFromJSON tName opts cons = do
656− value <- newName "value"
657− lam1E (varP value) $ caseE (varE value) $
658− if allNullaryToStringTag opts && all isNullary cons
659− then allNullaryMatches
660− else mixedMatches
831+ pjs <- newNameList "_pj" $ arityInt jc
832+ pjls <- newNameList "_pjl" $ arityInt jc
833+ let zippedPJs = zip pjs pjls
834+ interleavedPJs = interleave pjs pjls
835+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs
661836
662837 where
838+ lamExpr value pjs = case cons of
839+ [con] -> parseArgs jc pjs tName opts con (Right value)
840+ _ -> caseE (varE value) $
841+ if allNullaryToStringTag opts && all isNullary cons
842+ then allNullaryMatches
843+ else mixedMatches pjs
844+
663845 allNullaryMatches =
664846 [ do txt <- newName "txt"
665847 match (conP 'String [varP txt])
@@ -693,12 +875,12 @@ consFromJSON tName opts cons = do
693875 []
694876 ]
695877
696− mixedMatches =
878+ mixedMatches pjs =
697879 case sumEncoding opts of
698880 TaggedObject {tagFieldName, contentsFieldName} ->
699− parseObject $ parseTaggedObject tagFieldName contentsFieldName
881+ parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName
700882 ObjectWithSingleField ->
701− parseObject $ parseObjectWithSingleField
883+ parseObject $ parseObjectWithSingleField pjs
702884 TwoElemArray ->
703885 [ do arr <- newName "array"
704886 match (conP 'Array [varP arr])
@@ -706,7 +888,7 @@ consFromJSON tName opts cons = do
706888 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
707889 [|(==)|]
708890 (litE $ integerL 2))
709− (parse2ElemArray arr)
891+ (parse2ElemArray pjs arr)
710892 , liftM2 (,) (normalG [|otherwise|])
711893 (([|not2ElemArray|]
712894 `appE` (litE $ stringL $ show tName)
@@ -737,16 +919,16 @@ consFromJSON tName opts cons = do
737919 []
738920 ]
739921
740− parseTaggedObject typFieldName valFieldName obj = do
922+ parseTaggedObject pjs typFieldName valFieldName obj = do
741923 conKey <- newName "conKey"
742924 doE [ bindS (varP conKey)
743925 (infixApp (varE obj)
744926 [|(.:)|]
745927 ([|T.pack|] `appE` stringE typFieldName))
746− , noBindS $ parseContents conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
928+ , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
747929 ]
748930
749− parse2ElemArray arr = do
931+ parse2ElemArray pjs arr = do
750932 conKey <- newName "conKey"
751933 conVal <- newName "conVal"
752934 let letIx n ix =
@@ -761,7 +943,8 @@ consFromJSON tName opts cons = do
761943 (caseE (varE conKey)
762944 [ do txt <- newName "txt"
763945 match (conP 'String [varP txt])
764− (normalB $ parseContents txt
946+ (normalB $ parseContents pjs
947+ txt
765948 (Right conVal)
766949 'conNotFoundFail2ElemArray
767950 )
@@ -777,12 +960,12 @@ consFromJSON tName opts cons = do
777960 ]
778961 )
779962
780− parseObjectWithSingleField obj = do
963+ parseObjectWithSingleField pjs obj = do
781964 conKey <- newName "conKey"
782965 conVal <- newName "conVal"
783966 caseE ([e|H.toList|] `appE` varE obj)
784967 [ match (listP [tupP [varP conKey, varP conVal]])
785− (normalB $ parseContents conKey (Right conVal) 'conNotFoundFailObjectSingleField)
968+ (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)
786969 []
787970 , do other <- newName "other"
788971 match (varP other)
@@ -793,7 +976,7 @@ consFromJSON tName opts cons = do
793976 []
794977 ]
795978
796− parseContents conKey contents errorFun =
979+ parseContents pjs conKey contents errorFun =
797980 caseE (varE conKey)
798981 [ match wildP
799982 ( guardedB $
@@ -801,7 +984,7 @@ consFromJSON tName opts cons = do
801984 [|(==)|]
802985 ([|T.pack|] `appE`
803986 conNameExp opts con)
804− e <- parseArgs tName opts con contents
987+ e <- parseArgs jc pjs tName opts con contents
805988 return (g, e)
806989 | con <- cons
807990 ]
@@ -845,30 +1028,40 @@ parseNullaryMatches tName conName =
8451028 , matchFailed tName conName "Array"
8461029 ]
8471030
848−parseUnaryMatches :: Name -> [Q Match]
849−parseUnaryMatches conName =
1031+parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]
1032+parseUnaryMatches jc tvMap argTy conName =
8501033 [ do arg <- newName "arg"
8511034 match (varP arg)
8521035 ( normalB $ infixApp (conE conName)
8531036 [|(<$>)|]
854− ([|parseJSON|] `appE` varE arg)
1037+ (dispatchParseJSON jc conName tvMap argTy
1038+ `appE` varE arg)
8551039 )
8561040 []
8571041 ]
8581042
859−parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ
860−parseRecord opts tName conName ts obj =
1043+parseRecord :: JSONClass
1044+ -> TyVarMap
1045+ -> [Type]
1046+ -> Options
1047+ -> Name
1048+ -> Name
1049+ -> [VarStrictType]
1050+ -> Name
1051+ -> ExpQ
1052+parseRecord jc tvMap argTys opts tName conName ts obj =
8611053 foldl' (\a b -> infixApp a [|(<*>)|] b)
8621054 (infixApp (conE conName) [|(<$>)|] x)
8631055 xs
8641056 where
8651057 x:xs = [ [|lookupField|]
1058+ `appE` dispatchParseJSON jc conName tvMap argTy
8661059 `appE` (litE $ stringL $ show tName)
8671060 `appE` (litE $ stringL $ constructorTagModifier opts $ nameBase conName)
8681061 `appE` (varE obj)
8691062 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
8701063 )
871− | (field, _, _) <- ts
1064+ | ((field, _, _), argTy) <- zip ts argTys
8721065 ]
8731066
8741067getValField :: Name -> String -> [MatchQ] -> Q Exp
@@ -881,80 +1074,93 @@ getValField obj valFieldName matches = do
8811074 , noBindS $ caseE (varE val) matches
8821075 ]
8831076
1077+matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
1078+matchCases (Left (valFieldName, obj)) = getValField obj valFieldName
1079+matchCases (Right valName) = caseE (varE valName)
1080+
8841081-- | Generates code to parse the JSON encoding of a single constructor.
885−parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
1082+parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
1083+ -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.
1084+ -> Name -- ^ Name of the type to which the constructor belongs.
8861085 -> Options -- ^ Encoding options.
8871086 -> Con -- ^ Constructor for which to generate JSON parsing code.
8881087 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
8891088 -- Right valName
8901089 -> Q Exp
8911090-- Nullary constructors.
892−parseArgs _ _ (NormalC conName []) (Left _) =
1091+parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do
1092+ ([], _) <- reifyConTys jc pjs conName
8931093 [|pure|] `appE` conE conName
894−parseArgs tName _ (NormalC conName []) (Right valName) =
1094+parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do
1095+ ([], _) <- reifyConTys jc pjs conName
8951096 caseE (varE valName) $ parseNullaryMatches tName conName
8961097
8971098-- Unary constructors.
898−parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =
899− getValField obj valFieldName $ parseUnaryMatches conName
900−parseArgs _ _ (NormalC conName [_]) (Right valName) =
901− caseE (varE valName) $ parseUnaryMatches conName
1099+parseArgs jc pjs _ _ (NormalC conName [_]) contents = do
1100+ ([argTy], tvMap) <- reifyConTys jc pjs conName
1101+ matchCases contents $ parseUnaryMatches jc tvMap argTy conName
9021102
9031103-- Polyadic constructors.
904−parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =
905− getValField obj valFieldName $ parseProduct tName conName $ genericLength ts
906−parseArgs tName _ (NormalC conName ts) (Right valName) =
907− caseE (varE valName) $ parseProduct tName conName $ genericLength ts
1104+parseArgs jc pjs tName _ (NormalC conName ts) contents = do
1105+ (argTys, tvMap) <- reifyConTys jc pjs conName
1106+ let len = genericLength ts
1107+ matchCases contents $ parseProduct jc tvMap argTys tName conName len
9081108
9091109-- Records.
910−parseArgs tName opts (RecC conName ts) (Left (_, obj)) =
911− parseRecord opts tName conName ts obj
912−parseArgs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of
913− (True,[(_,st,ty)])-> parseArgs tName opts (NormalC conName [(st,ty)]) (Right valName)
1110+parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do
1111+ (argTys, tvMap) <- reifyConTys jc pjs conName
1112+ parseRecord jc tvMap argTys opts tName conName ts obj
1113+parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of
1114+ (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)
9141115 _ -> do
9151116 obj <- newName "recObj"
1117+ (argTys, tvMap) <- reifyConTys jc pjs conName
9161118 caseE (varE valName)
917− [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []
1119+ [ match (conP 'Object [varP obj]) (normalB $
1120+ parseRecord jc tvMap argTys opts tName conName ts obj) []
9181121 , matchFailed tName conName "Object"
9191122 ]
9201123
9211124-- Infix constructors. Apart from syntax these are the same as
9221125-- polyadic constructors.
923−parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =
924− getValField obj valFieldName $ parseProduct tName conName 2
925−parseArgs tName _ (InfixC _ conName _) (Right valName) =
926− caseE (varE valName) $ parseProduct tName conName 2
1126+parseArgs jc pjs tName _ (InfixC _ conName _) contents = do
1127+ (argTys, tvMap) <- reifyConTys jc pjs conName
1128+ matchCases contents $ parseProduct jc tvMap argTys tName conName 2
9271129
9281130-- Existentially quantified constructors. We ignore the quantifiers
9291131-- and proceed with the contained constructor.
930−parseArgs tName opts (ForallC _ _ con) contents =
931− parseArgs tName opts con contents
1132+parseArgs jc pjs tName opts (ForallC _ _ con) contents =
1133+ parseArgs jc pjs tName opts con contents
9321134
9331135#if MIN_VERSION_template_haskell(2,11,0)
9341136-- GADTs. We ignore the refined return type and proceed as if it were a
9351137-- NormalC or RecC.
936−parseArgs tName opts (GadtC conNames ts _) contents =
937− parseArgs tName opts (NormalC (head conNames) ts) contents
1138+parseArgs jc pjs tName opts (GadtC conNames ts _) contents =
1139+ parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents
9381140
939−parseArgs tName opts (RecGadtC conNames ts _) contents =
940− parseArgs tName opts (RecC (head conNames) ts) contents
1141+parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =
1142+ parseArgs jc pjs tName opts (RecC (head conNames) ts) contents
9411143#endif
9421144
9431145-- | Generates code to parse the JSON encoding of an n-ary
9441146-- constructor.
945−parseProduct :: Name -- ^ Name of the type to which the constructor belongs.
1147+parseProduct :: JSONClass -- ^ The FromJSON variant being derived.
1148+ -> TyVarMap -- ^ Maps the last type variables to their decoding
1149+ -- function arguments.
1150+ -> [Type] -- ^ The argument types of the constructor.
1151+ -> Name -- ^ Name of the type to which the constructor belongs.
9461152 -> Name -- ^ 'Con'structor name.
9471153 -> Integer -- ^ 'Con'structor arity.
9481154 -> [Q Match]
949−parseProduct tName conName numArgs =
1155+parseProduct jc tvMap argTys tName conName numArgs =
9501156 [ do arr <- newName "arr"
9511157 -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"
952− let x:xs = [ [|parseJSON|]
1158+ let x:xs = [ dispatchParseJSON jc conName tvMap argTy
9531159 `appE`
9541160 infixApp (varE arr)
9551161 [|V.unsafeIndex|]
9561162 (litE $ integerL ix)
957− | ix <- [0 .. numArgs - 1]
1163+ | (argTy, ix) <- zip argTys [0 .. numArgs - 1]
9581164 ]
9591165 match (conP 'Array [varP arr])
9601166 (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)
@@ -977,7 +1183,6 @@ parseProduct tName conName numArgs =
9771183 , matchFailed tName conName "Array"
9781184 ]
9791185
980−
9811186--------------------------------------------------------------------------------
9821187-- Parsing errors
9831188--------------------------------------------------------------------------------
@@ -1002,17 +1207,25 @@ parseTypeMismatch tName conName expected actual =
10021207 , actual
10031208 ]
10041209
1005−class (FromJSON a) => LookupField a where
1006− lookupField :: String -> String -> Object -> T.Text -> Parser a
1210+class LookupField a where
1211+ lookupField :: (Value -> Parser a) -> String -> String
1212+ -> Object -> T.Text -> Parser a
1213+
1214+instance OVERLAPPABLE_ LookupField a where
1215+ lookupField = lookupFieldWith
10071216
1008−instance OVERLAPPABLE_ (FromJSON a) => LookupField a where
1009− lookupField tName rec obj key =
1010− case H.lookup key obj of
1011− Nothing -> unknownFieldFail tName rec (T.unpack key)
1012− Just v -> parseJSON v <?> Key key
1217+instance LookupField (Maybe a) where
1218+ lookupField pj _ _ = parseOptionalFieldWith pj
10131219
1014−instance (FromJSON a) => LookupField (Maybe a) where
1015− lookupField _ _ = (.:?)
1220+lookupFieldWith :: (Value -> Parser a) -> String -> String
1221+ -> Object -> T.Text -> Parser a
1222+lookupFieldWith pj tName rec obj key =
1223+ case H.lookup key obj of
1224+ Nothing -> unknownFieldFail tName rec (T.unpack key)
1225+ Just v -> pj v <?> Key key
1226+
1227+keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair
1228+keyValuePairWith tj name value = (name, tj value)
10161229
10171230unknownFieldFail :: String -> String -> String -> Parser fail
10181231unknownFieldFail tName rec key =
@@ -1063,6 +1276,120 @@ parseTypeMismatch' conName tName expected actual =
10631276 fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."
10641277 conName tName expected actual
10651278
1279+--------------------------------------------------------------------------------
1280+-- Shared ToJSON and FromJSON code
1281+--------------------------------------------------------------------------------
1282+
1283+-- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'.
1284+deriveJSONBoth :: (Options -> Name -> Q [Dec])
1285+ -- ^ Function which derives a flavor of 'ToJSON'.
1286+ -> (Options -> Name -> Q [Dec])
1287+ -- ^ Function which derives a flavor of 'FromJSON'.
1288+ -> Options
1289+ -- ^ Encoding options.
1290+ -> Name
1291+ -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
1292+ -- instances.
1293+ -> Q [Dec]
1294+deriveJSONBoth dtj dfj opts name =
1295+ liftM2 (++) (dtj opts name) (dfj opts name)
1296+
1297+-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.
1298+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
1299+ -- ^ The class methods and the functions which derive them.
1300+ -> JSONClass
1301+ -- ^ The class for which to generate an instance.
1302+ -> Options
1303+ -- ^ Encoding options.
1304+ -> Name
1305+ -- ^ Name of the type for which to generate a class instance
1306+ -- declaration.
1307+ -> Q [Dec]
1308+deriveJSONClass consFuns jc opts name =
1309+ withType name $ \name' ctxt tvbs cons mbTys ->
1310+ fmap (:[]) $ fromCons name' ctxt tvbs cons mbTys
1311+ where
1312+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
1313+ fromCons name' ctxt tvbs cons mbTys = do
1314+ (instanceCxt, instanceType)
1315+ <- buildTypeInstance name' jc ctxt tvbs mbTys
1316+ instanceD (return instanceCxt)
1317+ (return instanceType)
1318+ (methodDecs name' cons)
1319+
1320+ methodDecs :: Name -> [Con] -> [Q Dec]
1321+ methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->
1322+ funD (jsonFunValName jf (arity jc))
1323+ [ clause []
1324+ (normalB $ jfMaker jc name' opts cons)
1325+ []
1326+ ]
1327+
1328+mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
1329+ -- ^ The function which derives the expression.
1330+ -> JSONClass
1331+ -- ^ Which class's method is being derived.
1332+ -> Options
1333+ -- ^ Encoding options.
1334+ -> Name
1335+ -- ^ Name of the encoded type.
1336+ -> Q Exp
1337+mkFunCommon consFun jc opts name = withType name fromCons
1338+ where
1339+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
1340+ fromCons name' ctxt tvbs cons mbTys = do
1341+ -- We force buildTypeInstance here since it performs some checks for whether
1342+ -- or not the provided datatype's kind matches the derived method's
1343+ -- typeclass, and produces errors if it can't.
1344+ !_ <- buildTypeInstance name' jc ctxt tvbs mbTys
1345+ consFun jc name' opts cons
1346+
1347+dispatchFunByType :: JSONClass
1348+ -> JSONFun
1349+ -> Name
1350+ -> TyVarMap
1351+ -> Bool -- True if we are using the function argument that works
1352+ -- on lists (e.g., [a] -> Value). False is we are using
1353+ -- the function argument that works on single values
1354+ -- (e.g., a -> Value).
1355+ -> Type
1356+ -> Q Exp
1357+dispatchFunByType _ jf _ tvMap list (VarT tyName) =
1358+ varE $ case M.lookup tyName tvMap of
1359+ Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp
1360+ Nothing -> jsonFunValOrListName list jf Arity0
1361+dispatchFunByType jc jf conName tvMap list (SigT ty _) =
1362+ dispatchFunByType jc jf conName tvMap list ty
1363+dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) =
1364+ dispatchFunByType jc jf conName tvMap list ty
1365+dispatchFunByType jc jf conName tvMap list ty = do
1366+ let tyCon :: Type
1367+ tyArgs :: [Type]
1368+ tyCon :| tyArgs = unapplyTy ty
1369+
1370+ numLastArgs :: Int
1371+ numLastArgs = min (arityInt jc) (length tyArgs)
1372+
1373+ lhsArgs, rhsArgs :: [Type]
1374+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
1375+
1376+ tyVarNames :: [Name]
1377+ tyVarNames = M.keys tvMap
1378+
1379+ itf <- isTyFamily tyCon
1380+ if any (`mentionsName` tyVarNames) lhsArgs
1381+ || itf && any (`mentionsName` tyVarNames) tyArgs
1382+ then outOfPlaceTyVarError jc conName
1383+ else appsE $ [ varE . jsonFunValOrListName list jf $ toEnum numLastArgs]
1384+ ++ zipWith (dispatchFunByType jc jf conName tvMap)
1385+ (cycle [False,True])
1386+ (interleave rhsArgs rhsArgs)
1387+
1388+dispatchToJSON, dispatchToEncoding, dispatchParseJSON
1389+ :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1390+dispatchToJSON jc n tvMap = dispatchFunByType jc ToJSON n tvMap False
1391+dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False
1392+dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
10661393
10671394--------------------------------------------------------------------------------
10681395-- Utility functions
@@ -1077,12 +1404,13 @@ parseTypeMismatch' conName tName expected actual =
10771404
10781405-- Any other value will result in an exception.
10791406withType :: Name
1080− -> (Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
1407+ -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
10811408 -- ^ Function that generates the actual code. Will be applied
1082− -- to the datatype/data family 'Name', type variable binders and
1083− -- constructors extracted from the given 'Name'. If the 'Name' is
1084− -- from a data family instance constructor, it will also have its
1085− -- instantiated types; otherwise, it will be 'Nothing'.
1409+ -- to the datatype/data family 'Name', datatype context, type
1410+ -- variable binders and constructors extracted from the given
1411+ -- 'Name'. If the 'Name' is from a data family instance
1412+ -- constructor, it will also have its instantiated types;
1413+ -- otherwise, it will be 'Nothing'.
10861414 -> Q a
10871415 -- ^ Resulting value in the 'Q'uasi monad.
10881416withType name f = do
@@ -1091,13 +1419,13 @@ withType name f = do
10911419 TyConI dec ->
10921420 case dec of
10931421#if MIN_VERSION_template_haskell(2,11,0)
1094− DataD _ _ tvbs _ cons _ -> f name tvbs cons Nothing
1095− NewtypeD _ _ tvbs _ con _ -> f name tvbs [con] Nothing
1422+ DataD ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing
1423+ NewtypeD ctxt _ tvbs _ con _ -> f name ctxt tvbs [con] Nothing
10961424#else
1097− DataD _ _ tvbs cons _ -> f name tvbs cons Nothing
1098− NewtypeD _ _ tvbs con _ -> f name tvbs [con] Nothing
1425+ DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing
1426+ NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing
10991427#endif
1100− other -> error $ ns ++ "Unsupported type: " ++ show other
1428+ other -> fail $ ns ++ "Unsupported type: " ++ show other
11011429#if MIN_VERSION_template_haskell(2,11,0)
11021430 DataConI _ _ parentName -> do
11031431#else
@@ -1121,24 +1449,24 @@ withType name f = do
11211449 _ -> error $ ns ++ "Must be a data or newtype instance."
11221450 in case instDec of
11231451#if MIN_VERSION_template_haskell(2,11,0)
1124− Just (DataInstD _ _ instTys _ cons _) -> f parentName tvbs cons $ Just instTys
1125− Just (NewtypeInstD _ _ instTys _ con _) -> f parentName tvbs [con] $ Just instTys
1452+ Just (DataInstD ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys
1453+ Just (NewtypeInstD ctxt _ instTys _ con _) -> f parentName ctxt tvbs [con] $ Just instTys
11261454#else
1127− Just (DataInstD _ _ instTys cons _) -> f parentName tvbs cons $ Just instTys
1128− Just (NewtypeInstD _ _ instTys con _) -> f parentName tvbs [con] $ Just instTys
1455+ Just (DataInstD ctxt _ instTys cons _) -> f parentName ctxt tvbs cons $ Just instTys
1456+ Just (NewtypeInstD ctxt _ instTys con _) -> f parentName ctxt tvbs [con] $ Just instTys
11291457#endif
1130− _ -> error $ ns ++
1458+ _ -> fail $ ns ++
11311459 "Could not find data or newtype instance constructor."
1132− _ -> error $ ns ++ "Data constructor " ++ show name ++
1460+ _ -> fail $ ns ++ "Data constructor " ++ show name ++
11331461 " is not from a data family instance constructor."
11341462#if MIN_VERSION_template_haskell(2,11,0)
11351463 FamilyI DataFamilyD{} _ ->
11361464#else
11371465 FamilyI (FamilyD DataFam _ _ _) _ ->
11381466#endif
1139− error $ ns ++
1467+ fail $ ns ++
11401468 "Cannot use a data family name. Use a data family instance constructor instead."
1141− _ -> error $ ns ++ "I need the name of a plain data type constructor, "
1469+ _ -> fail $ ns ++ "I need the name of a plain data type constructor, "
11421470 ++ "or a data family instance constructor."
11431471 where
11441472 ns :: String
@@ -1147,8 +1475,10 @@ withType name f = do
11471475-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.
11481476buildTypeInstance :: Name
11491477 -- ^ The type constructor or data family name
1150− -> Name
1151− -- ^ The typeclass name ('ToJSON' or 'FromJSON')
1478+ -> JSONClass
1479+ -- ^ The typeclass to derive
1480+ -> Cxt
1481+ -- ^ The datatype context
11521482 -> [TyVarBndr]
11531483 -- ^ The type variables from the data type/data family declaration
11541484 -> Maybe [Type]
@@ -1157,15 +1487,15 @@ buildTypeInstance :: Name
11571487 -> Q (Cxt, Type)
11581488 -- ^ The resulting 'Cxt' and 'Type' to use in a class instance
11591489-- Plain data type/newtype case
1160−buildTypeInstance tyConName constraint tvbs Nothing =
1490+buildTypeInstance tyConName jc dataCxt tvbs Nothing =
11611491 let varTys :: [Type]
11621492 varTys = map tvbToType tvbs
1163− in buildTypeInstanceFromTys tyConName constraint varTys False
1493+ in buildTypeInstanceFromTys tyConName jc dataCxt varTys False
11641494-- Data family instance case
11651495--
11661496-- The CPP is present to work around a couple of annoying old GHC bugs.
11671497-- See Note [Polykinded data families in Template Haskell]
1168−buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
1498+buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do
11691499#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)
11701500 let instTys :: [Type]
11711501 instTys = zipWith stealKindForType tvbs instTysAndKinds
@@ -1173,16 +1503,6 @@ buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
11731503 let kindVarNames :: [Name]
11741504 kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs
11751505
1176− -- Gets all of the type/kind variable names mentioned somewhere in a Type.
1177− tyVarNamesOfType :: Type -> [Name]
1178− tyVarNamesOfType = go
1179− where
1180− go :: Type -> [Name]
1181− go (AppT t1 t2) = go t1 ++ go t2
1182− go (SigT t k) = go t ++ go k
1183− go (VarT n) = [n]
1184− go _ = []
1185−
11861506 numKindVars :: Int
11871507 numKindVars = length kindVarNames
11881508
@@ -1208,10 +1528,6 @@ buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
12081528 starKindName :: Name
12091529 starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
12101530
1211− -- Generate a list of fresh names with a common prefix, and numbered suffixes.
1212− newNameList :: String -> Int -> Q [Name]
1213− newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]
1214−
12151531 -- If we run this code with GHC 7.8, we might have to generate extra type
12161532 -- variables to compensate for any type variables that Template Haskell
12171533 -- eta-reduced away.
@@ -1225,9 +1541,6 @@ buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
12251541 -- them as VarT to ensure they will be given an explicit kind annotation
12261542 -- (and so the kind inference machinery has the right information).
12271543
1228− substNameWithKind :: Name -> Kind -> Type -> Type
1229− substNameWithKind n k = substType (M.singleton n k)
1230−
12311544 substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
12321545 substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks
12331546
@@ -1246,50 +1559,147 @@ buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
12461559 -- grab the correct kind.
12471560 $ zipWith stealKindForType tvbs (givenTys ++ xTys)
12481561#endif
1249− buildTypeInstanceFromTys dataFamName constraint instTys True
1562+ buildTypeInstanceFromTys dataFamName jc dataCxt instTys True
12501563
12511564-- For the given Types, generate an instance context and head.
12521565buildTypeInstanceFromTys :: Name
12531566 -- ^ The type constructor or data family name
1254− -> Name
1255− -- ^ The typeclass name ('ToJSON' or 'FromJSON')
1567+ -> JSONClass
1568+ -- ^ The typeclass to derive
1569+ -> Cxt
1570+ -- ^ The datatype context
12561571 -> [Type]
12571572 -- ^ The types to instantiate the instance with
12581573 -> Bool
12591574 -- ^ True if it's a data family, False otherwise
12601575 -> Q (Cxt, Type)
1261−buildTypeInstanceFromTys tyConName constraint varTysOrig isDataFamily = do
1262− -- Make sure to expand through type/kind synonyms! Otherwise, we won't
1263− -- be able to infer constraints as accurately.
1576+buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
1577+ -- Make sure to expand through type/kind synonyms! Otherwise, the
1578+ -- eta-reduction check might get tripped up over type variables in a
1579+ -- synonym that are actually dropped.
1580+ -- (See GHC Trac #11416 for a scenario where this actually happened.)
12641581 varTysExp <- mapM expandSyn varTysOrig
12651582
1266− let preds :: [Maybe Pred]
1267− -- Derive instance constraints for type variables of kind *
1268− preds = map (deriveConstraint constraint) varTysExp
1583+ let remainingLength :: Int
1584+ remainingLength = length varTysOrig - arityInt jc
1585+
1586+ droppedTysExp :: [Type]
1587+ droppedTysExp = drop remainingLength varTysExp
1588+
1589+ droppedStarKindStati :: [StarKindStatus]
1590+ droppedStarKindStati = map canRealizeKindStar droppedTysExp
1591+
1592+ -- Check there are enough types to drop and that all of them are either of
1593+ -- kind * or kind k (for some kind variable k). If not, throw an error.
1594+ when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
1595+ derivingKindError jc tyConName
1596+
1597+ let droppedKindVarNames :: [Name]
1598+ droppedKindVarNames = catKindVarNames droppedStarKindStati
1599+
1600+ -- Substitute kind * for any dropped kind variables
1601+ varTysExpSubst :: [Type]
1602+ varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp
1603+
1604+ remainingTysExpSubst, droppedTysExpSubst :: [Type]
1605+ (remainingTysExpSubst, droppedTysExpSubst) =
1606+ splitAt remainingLength varTysExpSubst
12691607
1270− varTys :: [Type]
1608+ -- All of the type variables mentioned in the dropped types
1609+ -- (post-synonym expansion)
1610+ droppedTyVarNames :: [Name]
1611+ droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst
1612+
1613+ -- If any of the dropped types were polykinded, ensure that they are of kind *
1614+ -- after substituting * for the dropped kind variables. If not, throw an error.
1615+ unless (all hasKindStar droppedTysExpSubst) $
1616+ derivingKindError jc tyConName
1617+
1618+ let preds :: [Maybe Pred]
1619+ kvNames :: [[Name]]
1620+ kvNames' :: [Name]
1621+ -- Derive instance constraints (and any kind variables which are specialized
1622+ -- to * in those constraints)
1623+ (preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst
1624+ kvNames' = concat kvNames
1625+
1626+ -- Substitute the kind variables specialized in the constraints with *
1627+ remainingTysExpSubst' :: [Type]
1628+ remainingTysExpSubst' =
1629+ map (substNamesWithKindStar kvNames') remainingTysExpSubst
1630+
1631+ -- We now substitute all of the specialized-to-* kind variable names with
1632+ -- *, but in the original types, not the synonym-expanded types. The reason
1633+ -- we do this is a superficial one: we want the derived instance to resemble
1634+ -- the datatype written in source code as closely as possible. For example,
1635+ -- for the following data family instance:
1636+ --
1637+ -- data family Fam a
1638+ -- newtype instance Fam String = Fam String
1639+ --
1640+ -- We'd want to generate the instance:
1641+ --
1642+ -- instance C (Fam String)
1643+ --
1644+ -- Not:
1645+ --
1646+ -- instance C (Fam [Char])
1647+ remainingTysOrigSubst :: [Type]
1648+ remainingTysOrigSubst =
1649+ map (substNamesWithKindStar (union droppedKindVarNames kvNames'))
1650+ $ take remainingLength varTysOrig
1651+
1652+ remainingTysOrigSubst' :: [Type]
12711653 -- See Note [Kind signatures in derived instances] for an explanation
12721654 -- of the isDataFamily check.
1273− varTys =
1655+ remainingTysOrigSubst' =
12741656 if isDataFamily
1275− then varTysOrig
1276− else map unSigT varTysOrig
1657+ then remainingTysOrigSubst
1658+ else map unSigT remainingTysOrigSubst
12771659
12781660 instanceCxt :: Cxt
12791661 instanceCxt = catMaybes preds
12801662
12811663 instanceType :: Type
1282− instanceType = AppT (ConT constraint)
1283− $ applyTyCon tyConName varTys
1284−
1664+ instanceType = AppT (ConT $ jsonClassName jc)
1665+ $ applyTyCon tyConName remainingTysOrigSubst'
1666+
1667+ -- If the datatype context mentions any of the dropped type variables,
1668+ -- we can't derive an instance, so throw an error.
1669+ when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
1670+ datatypeContextError tyConName instanceType
1671+ -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
1672+ -- throw an error.
1673+ unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
1674+ etaReductionError instanceType
12851675 return (instanceCxt, instanceType)
12861676
1287−-- | Attempt to derive a constraint on a Type. If it's of kind *,
1288−-- we give it Just a ToJSON/FromJSON constraint. Otherwise, return Nothing.
1289−deriveConstraint :: Name -> Type -> Maybe Pred
1290−deriveConstraint constraint t
1291− | isTyVar t && hasKindStar t = Just $ applyCon constraint $ varTToName t
1292− | otherwise = Nothing
1677+-- | Attempt to derive a constraint on a Type. If successful, return
1678+-- Just the constraint and any kind variable names constrained to *.
1679+-- Otherwise, return Nothing and the empty list.
1680+--
1681+-- See Note [Type inference in derived instances] for the heuristics used to
1682+-- come up with constraints.
1683+deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name])
1684+deriveConstraint jc t
1685+ | not (isTyVar t) = (Nothing, [])
1686+ | hasKindStar t = (Just (applyCon (jcConstraint Arity0) tName), [])
1687+ | otherwise = case hasKindVarChain 1 t of
1688+ Just ns | jcArity >= Arity1
1689+ -> (Just (applyCon (jcConstraint Arity1) tName), ns)
1690+ _ -> case hasKindVarChain 2 t of
1691+ Just ns | jcArity == Arity2
1692+ -> (Just (applyCon (jcConstraint Arity2) tName), ns)
1693+ _ -> (Nothing, [])
1694+ where
1695+ tName :: Name
1696+ tName = varTToName t
1697+
1698+ jcArity :: Arity
1699+ jcArity = arity jc
1700+
1701+ jcConstraint :: Arity -> Name
1702+ jcConstraint = jsonClassName . JSONClass (direction jc)
12931703
12941704{-
12951705Note [Polykinded data families in Template Haskell]
@@ -1372,8 +1782,135 @@ knowing which instance we are talking about. To avoid this scenario, we always
13721782include explicit kind signatures in data family instances. There is a chance that
13731783the inferred kind signatures will be incorrect, but if so, we can always fall back
13741784on the mk- functions.
1785+
1786+Note [Type inference in derived instances]
1787+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1788+
1789+Type inference is can be tricky to get right, and we want to avoid recreating the
1790+entirety of GHC's type inferencer in Template Haskell. For this reason, we will
1791+probably never come up with derived instance contexts that are as accurate as
1792+GHC's. But that doesn't mean we can't do anything! There are a couple of simple
1793+things we can do to make instance contexts that work for 80% of use cases:
1794+
1795+1. If one of the last type parameters is polykinded, then its kind will be
1796+ specialized to * in the derived instance. We note what kind variable the type
1797+ parameter had and substitute it with * in the other types as well. For example,
1798+ imagine you had
1799+
1800+ data Data (a :: k) (b :: k)
1801+
1802+ Then you'd want to derived instance to be:
1803+
1804+ instance C (Data (a :: *))
1805+
1806+ Not:
1807+
1808+ instance C (Data (a :: k))
1809+
1810+2. We naïvely come up with instance constraints using the following criteria:
1811+
1812+ (i) If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n
1813+ constraint.
1814+ (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
1815+ variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if
1816+ k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the
1817+ types. We must consider the case where they are kind variables because
1818+ you might have a scenario like this:
1819+
1820+ newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
1821+ = Compose (f (g a))
1822+
1823+ Which would have a derived ToJSON1 instance of:
1824+
1825+ instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ...
1826+ (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
1827+ * or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint
1828+ and perform kind substitution as in the other cases.
13751829-}
13761830
1831+-- Determines the types of a constructor's arguments as well as the last type
1832+-- parameters (mapped to their encoding/decoding functions), expanding through
1833+-- any type synonyms.
1834+--
1835+-- The type parameters are determined on a constructor-by-constructor basis since
1836+-- they may be refined to be particular types in a GADT.
1837+reifyConTys :: JSONClass
1838+ -> [(Name, Name)]
1839+ -> Name
1840+ -> Q ([Type], TyVarMap)
1841+reifyConTys jc tpjs conName = do
1842+ info <- reify conName
1843+ (ctxt, uncTy) <- case info of
1844+ DataConI _ ty _
1845+#if !(MIN_VERSION_template_haskell(2,11,0))
1846+ _
1847+#endif
1848+ -> fmap uncurryTy (expandSyn ty)
1849+ _ -> error "Must be a data constructor"
1850+ let (argTys, [resTy]) = NE.splitAt (NE.length uncTy - 1) uncTy
1851+ unapResTy = unapplyTy resTy
1852+ -- If one of the last type variables is refined to a particular type
1853+ -- (i.e., not truly polymorphic), we mark it with Nothing and filter
1854+ -- it out later, since we only apply encoding/decoding functions to
1855+ -- arguments of a type that it (1) one of the last type variables,
1856+ -- and (2) of a truly polymorphic type.
1857+ jArity = arityInt jc
1858+ mbTvNames = map varTToName_maybe $
1859+ NE.drop (NE.length unapResTy - jArity) unapResTy
1860+ -- We use M.fromList to ensure that if there are any duplicate type
1861+ -- variables (as can happen in a GADT), the rightmost type variable gets
1862+ -- associated with the show function.
1863+ --
1864+ -- See Note [Matching functions with GADT type variables]
1865+ tvMap = M.fromList
1866+ . catMaybes -- Drop refined types
1867+ $ zipWith (\mbTvName tpj ->
1868+ fmap (\tvName -> (tvName, tpj)) mbTvName)
1869+ mbTvNames tpjs
1870+ if (any (`predMentionsName` M.keys tvMap) ctxt
1871+ || M.size tvMap < jArity)
1872+ && not (allowExQuant jc)
1873+ then existentialContextError conName
1874+ else return (argTys, tvMap)
1875+
1876+{-
1877+Note [Matching functions with GADT type variables]
1878+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1879+
1880+When deriving ToJSON2, there is a tricky corner case to consider:
1881+
1882+ data Both a b where
1883+ BothCon :: x -> x -> Both x x
1884+
1885+Which encoding functions should be applied to which arguments of BothCon?
1886+We have a choice, since both the function of type (a -> Value) and of type
1887+(b -> Value) can be applied to either argument. In such a scenario, the
1888+second encoding function takes precedence over the first encoding function, so the
1889+derived ToJSON2 instance would be something like:
1890+
1891+ instance ToJSON2 Both where
1892+ liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do
1893+ mv <- unsafeNew 2
1894+ unsafeWrite mv 0 (tj1 x1)
1895+ unsafeWrite mv 1 (tj2 x2)
1896+ return mv
1897+
1898+This is not an arbitrary choice, as this definition ensures that
1899+liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for
1900+Both.
1901+-}
1902+
1903+-- A mapping of type variable Names to their encoding/decoding function Names.
1904+-- For example, in a ToJSON2 declaration, a TyVarMap might look like
1905+--
1906+-- { a ~> (tj1, tjl1)
1907+-- , b ~> (tj2, tjl2) }
1908+--
1909+-- where a and b are the last two type variables of the datatype, tj1 and tjl1 are
1910+-- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2
1911+-- are the function arguments of types (b -> Value) and ([b] -> Value).
1912+type TyVarMap = Map Name (Name, Name)
1913+
13771914-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.
13781915stealKindForType :: TyVarBndr -> Type -> Type
13791916stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)
@@ -1402,12 +1939,67 @@ hasKindStar (SigT _ StarK) = True
14021939#endif
14031940hasKindStar _ = False
14041941
1942+-- Returns True is a kind is equal to *, or if it is a kind variable.
1943+isStarOrVar :: Kind -> Bool
1944+#if MIN_VERSION_template_haskell(2,8,0)
1945+isStarOrVar StarT = True
1946+isStarOrVar VarT{} = True
1947+#else
1948+isStarOrVar StarK = True
1949+#endif
1950+isStarOrVar _ = False
1951+
1952+-- Generate a list of fresh names with a common prefix, and numbered suffixes.
1953+newNameList :: String -> Int -> Q [Name]
1954+newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
1955+
1956+-- Gets all of the type/kind variable names mentioned somewhere in a Type.
1957+tyVarNamesOfType :: Type -> [Name]
1958+tyVarNamesOfType = go
1959+ where
1960+ go :: Type -> [Name]
1961+ go (AppT t1 t2) = go t1 ++ go t2
1962+ go (SigT t _k) = go t
1963+#if MIN_VERSION_template_haskell(2,8,0)
1964+ ++ go _k
1965+#endif
1966+ go (VarT n) = [n]
1967+ go _ = []
1968+
1969+-- | Gets all of the type/kind variable names mentioned somewhere in a Kind.
1970+tyVarNamesOfKind :: Kind -> [Name]
1971+#if MIN_VERSION_template_haskell(2,8,0)
1972+tyVarNamesOfKind = tyVarNamesOfType
1973+#else
1974+tyVarNamesOfKind _ = [] -- There are no kind variables
1975+#endif
1976+
1977+-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
1978+-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
1979+-- kind variables.
1980+hasKindVarChain :: Int -> Type -> Maybe [Name]
1981+hasKindVarChain kindArrows t =
1982+ let uk = uncurryKind (tyKind t)
1983+ in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk
1984+ then Just (concatMap tyVarNamesOfKind uk)
1985+ else Nothing
1986+
1987+-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
1988+tyKind :: Type -> Kind
1989+tyKind (SigT _ k) = k
1990+tyKind _ = starK
1991+
1992+-- | Extract Just the Name from a type variable. If the argument Type is not a
1993+-- type variable, return Nothing.
1994+varTToName_maybe :: Type -> Maybe Name
1995+varTToName_maybe (VarT n) = Just n
1996+varTToName_maybe (SigT t _) = varTToName_maybe t
1997+varTToName_maybe _ = Nothing
1998+
14051999-- | Extract the Name from a type variable. If the argument Type is not a
14062000-- type variable, throw an error.
14072001varTToName :: Type -> Name
1408−varTToName (VarT n) = n
1409−varTToName (SigT t _) = varTToName t
1410−varTToName _ = error "Not a type variable!"
2002+varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe
14112003
14122004-- | Extracts the name from a constructor.
14132005getConName :: Con -> Name
@@ -1420,6 +2012,10 @@ getConName (GadtC names _ _) = head names
14202012getConName (RecGadtC names _ _) = head names
14212013#endif
14222014
2015+interleave :: [a] -> [a] -> [a]
2016+interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
2017+interleave _ _ = []
2018+
14232019-- | Fully applies a type constructor to its type variables.
14242020applyTyCon :: Name -> [Type] -> Type
14252021applyTyCon = foldl' AppT . ConT
@@ -1430,11 +2026,122 @@ isTyVar (VarT _) = True
14302026isTyVar (SigT t _) = isTyVar t
14312027isTyVar _ = False
14322028
2029+-- | Is the given type a type family constructor (and not a data family constructor)?
2030+isTyFamily :: Type -> Q Bool
2031+isTyFamily (ConT n) = do
2032+ info <- reify n
2033+ return $ case info of
2034+#if MIN_VERSION_template_haskell(2,11,0)
2035+ FamilyI OpenTypeFamilyD{} _ -> True
2036+#else
2037+ FamilyI (FamilyD TypeFam _ _ _) _ -> True
2038+#endif
2039+#if MIN_VERSION_template_haskell(2,9,0)
2040+ FamilyI ClosedTypeFamilyD{} _ -> True
2041+#endif
2042+ _ -> False
2043+isTyFamily _ = return False
2044+
14332045-- | Peel off a kind signature from a Type (if it has one).
14342046unSigT :: Type -> Type
14352047unSigT (SigT t _) = t
14362048unSigT t = t
14372049
2050+-- | Are all of the items in a list (which have an ordering) distinct?
2051+--
2052+-- This uses Set (as opposed to nub) for better asymptotic time complexity.
2053+allDistinct :: Ord a => [a] -> Bool
2054+allDistinct = allDistinct' Set.empty
2055+ where
2056+ allDistinct' :: Ord a => Set a -> [a] -> Bool
2057+ allDistinct' uniqs (x:xs)
2058+ | x `Set.member` uniqs = False
2059+ | otherwise = allDistinct' (Set.insert x uniqs) xs
2060+ allDistinct' _ _ = True
2061+
2062+-- | Does the given type mention any of the Names in the list?
2063+mentionsName :: Type -> [Name] -> Bool
2064+mentionsName = go
2065+ where
2066+ go :: Type -> [Name] -> Bool
2067+ go (AppT t1 t2) names = go t1 names || go t2 names
2068+ go (SigT t _k) names = go t names
2069+#if MIN_VERSION_template_haskell(2,8,0)
2070+ || go _k names
2071+#endif
2072+ go (VarT n) names = n `elem` names
2073+ go _ _ = False
2074+
2075+-- | Does an instance predicate mention any of the Names in the list?
2076+predMentionsName :: Pred -> [Name] -> Bool
2077+#if MIN_VERSION_template_haskell(2,10,0)
2078+predMentionsName = mentionsName
2079+#else
2080+predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
2081+predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
2082+#endif
2083+
2084+-- | Split an applied type into its individual components. For example, this:
2085+--
2086+-- @
2087+-- Either Int Char
2088+-- @
2089+--
2090+-- would split to this:
2091+--
2092+-- @
2093+-- [Either, Int, Char]
2094+-- @
2095+unapplyTy :: Type -> NonEmpty Type
2096+unapplyTy = NE.reverse . go
2097+ where
2098+ go :: Type -> NonEmpty Type
2099+ go (AppT t1 t2) = t2 <| go t1
2100+ go (SigT t _) = go t
2101+ go (ForallT _ _ t) = go t
2102+ go t = t :| []
2103+
2104+-- | Split a type signature by the arrows on its spine. For example, this:
2105+--
2106+-- @
2107+-- forall a b. (a ~ b) => (a -> b) -> Char -> ()
2108+-- @
2109+--
2110+-- would split to this:
2111+--
2112+-- @
2113+-- (a ~ b, [a -> b, Char, ()])
2114+-- @
2115+uncurryTy :: Type -> (Cxt, NonEmpty Type)
2116+uncurryTy (AppT (AppT ArrowT t1) t2) =
2117+ let (ctxt, tys) = uncurryTy t2
2118+ in (ctxt, t1 <| tys)
2119+uncurryTy (SigT t _) = uncurryTy t
2120+uncurryTy (ForallT _ ctxt t) =
2121+ let (ctxt', tys) = uncurryTy t
2122+ in (ctxt ++ ctxt', tys)
2123+uncurryTy t = ([], t :| [])
2124+
2125+-- | Like uncurryType, except on a kind level.
2126+uncurryKind :: Kind -> NonEmpty Kind
2127+#if MIN_VERSION_template_haskell(2,8,0)
2128+uncurryKind = snd . uncurryTy
2129+#else
2130+uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2
2131+uncurryKind k = k :| []
2132+#endif
2133+
2134+createKindChain :: Int -> Kind
2135+createKindChain = go starK
2136+ where
2137+ go :: Kind -> Int -> Kind
2138+ go k !0 = k
2139+#if MIN_VERSION_template_haskell(2,8,0)
2140+ go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)
2141+#else
2142+ go k !n = go (ArrowK StarK k) (n - 1)
2143+#endif
2144+
14382145-- | Makes a string literal expression from a constructor's name.
14392146conNameExp :: Options -> Con -> Q Exp
14402147conNameExp opts = litE
@@ -1466,6 +2173,22 @@ applyCon con t =
14662173 ClassP con [VarT t]
14672174#endif
14682175
2176+-- | Checks to see if the last types in a data family instance can be safely eta-
2177+-- reduced (i.e., dropped), given the other types. This checks for three conditions:
2178+--
2179+-- (1) All of the dropped types are type variables
2180+-- (2) All of the dropped types are distinct
2181+-- (3) None of the remaining types mention any of the dropped types
2182+canEtaReduce :: [Type] -> [Type] -> Bool
2183+canEtaReduce remaining dropped =
2184+ all isTyVar dropped
2185+ && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type
2186+ -- didn't have an Ord instance until template-haskell-2.10.0.0
2187+ && not (any (`mentionsName` droppedNames) remaining)
2188+ where
2189+ droppedNames :: [Name]
2190+ droppedNames = map varTToName dropped
2191+
14692192-------------------------------------------------------------------------------
14702193-- Expanding type synonyms
14712194-------------------------------------------------------------------------------
@@ -1507,6 +2230,7 @@ expandSynApp t ts = do
15072230 return $ foldl' AppT t' ts
15082231
15092232type TypeSubst = Map Name Type
2233+type KindSubst = Map Name Kind
15102234
15112235mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
15122236mkSubst vs ts =
@@ -1526,3 +2250,182 @@ substType subs (SigT t k) = SigT (substType subs t)
15262250 k
15272251#endif
15282252substType _ t = t
2253+
2254+substKind :: KindSubst -> Type -> Type
2255+#if MIN_VERSION_template_haskell(2,8,0)
2256+substKind = substType
2257+#else
2258+substKind _ t = t -- There are no kind variables!
2259+#endif
2260+
2261+substNameWithKind :: Name -> Kind -> Type -> Type
2262+substNameWithKind n k = substKind (M.singleton n k)
2263+
2264+substNamesWithKindStar :: [Name] -> Type -> Type
2265+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns
2266+
2267+-------------------------------------------------------------------------------
2268+-- Error messages
2269+-------------------------------------------------------------------------------
2270+
2271+-- | Either the given data type doesn't have enough type variables, or one of
2272+-- the type variables to be eta-reduced cannot realize kind *.
2273+derivingKindError :: JSONClass -> Name -> Q a
2274+derivingKindError jc tyConName = fail
2275+ . showString "Cannot derive well-kinded instance of form ‘"
2276+ . showString className
2277+ . showChar ' '
2278+ . showParen True
2279+ ( showString (nameBase tyConName)
2280+ . showString " ..."
2281+ )
2282+ . showString "‘\n\tClass "
2283+ . showString className
2284+ . showString " expects an argument of kind "
2285+ . showString (pprint . createKindChain $ arityInt jc)
2286+ $ ""
2287+ where
2288+ className :: String
2289+ className = nameBase $ jsonClassName jc
2290+
2291+-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
2292+-- function for the criteria it would have to meet).
2293+etaReductionError :: Type -> Q a
2294+etaReductionError instanceType = fail $
2295+ "Cannot eta-reduce to an instance of form \n\tinstance (...) => "
2296+ ++ pprint instanceType
2297+
2298+-- | The data type has a DatatypeContext which mentions one of the eta-reduced
2299+-- type variables.
2300+datatypeContextError :: Name -> Type -> Q a
2301+datatypeContextError dataName instanceType = fail
2302+ . showString "Can't make a derived instance of ‘"
2303+ . showString (pprint instanceType)
2304+ . showString "‘:\n\tData type ‘"
2305+ . showString (nameBase dataName)
2306+ . showString "‘ must not have a class context involving the last type argument(s)"
2307+ $ ""
2308+
2309+-- | The data type mentions one of the n eta-reduced type variables in a place other
2310+-- than the last nth positions of a data type in a constructor's field.
2311+outOfPlaceTyVarError :: JSONClass -> Name -> a
2312+outOfPlaceTyVarError jc conName = error
2313+ . showString "Constructor ‘"
2314+ . showString (nameBase conName)
2315+ . showString "‘ must only use its last "
2316+ . shows n
2317+ . showString " type variable(s) within the last "
2318+ . shows n
2319+ . showString " argument(s) of a data type"
2320+ $ ""
2321+ where
2322+ n :: Int
2323+ n = arityInt jc
2324+
2325+-- | The data type has an existential constraint which mentions one of the
2326+-- eta-reduced type variables.
2327+existentialContextError :: Name -> a
2328+existentialContextError conName = error
2329+ . showString "Constructor ‘"
2330+ . showString (nameBase conName)
2331+ . showString "‘ must be truly polymorphic in the last argument(s) of the data type"
2332+ $ ""
2333+
2334+-------------------------------------------------------------------------------
2335+-- Class-specific constants
2336+-------------------------------------------------------------------------------
2337+
2338+-- | A representation of the arity of the ToJSON/FromJSON typeclass being derived.
2339+data Arity = Arity0 | Arity1 | Arity2
2340+ deriving (Enum, Eq, Ord)
2341+
2342+-- | Whether ToJSON(1)(2) or FromJSON(1)(2) is being derived.
2343+data Direction = To | From
2344+
2345+-- | A representation of which typeclass method is being spliced in.
2346+data JSONFun = ToJSON | ToEncoding | ParseJSON
2347+
2348+-- | A representation of which typeclass is being derived.
2349+data JSONClass = JSONClass { direction :: Direction, arity :: Arity }
2350+
2351+toJSONClass, toJSON1Class, toJSON2Class,
2352+ fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass
2353+toJSONClass = JSONClass To Arity0
2354+toJSON1Class = JSONClass To Arity1
2355+toJSON2Class = JSONClass To Arity2
2356+fromJSONClass = JSONClass From Arity0
2357+fromJSON1Class = JSONClass From Arity1
2358+fromJSON2Class = JSONClass From Arity2
2359+
2360+jsonClassName :: JSONClass -> Name
2361+jsonClassName (JSONClass To Arity0) = ''ToJSON
2362+jsonClassName (JSONClass To Arity1) = ''ToJSON1
2363+jsonClassName (JSONClass To Arity2) = ''ToJSON2
2364+jsonClassName (JSONClass From Arity0) = ''FromJSON
2365+jsonClassName (JSONClass From Arity1) = ''FromJSON1
2366+jsonClassName (JSONClass From Arity2) = ''FromJSON2
2367+
2368+jsonFunValName :: JSONFun -> Arity -> Name
2369+jsonFunValName ToJSON Arity0 = 'toJSON
2370+jsonFunValName ToJSON Arity1 = 'liftToJSON
2371+jsonFunValName ToJSON Arity2 = 'liftToJSON2
2372+jsonFunValName ToEncoding Arity0 = 'toEncoding
2373+jsonFunValName ToEncoding Arity1 = 'liftToEncoding
2374+jsonFunValName ToEncoding Arity2 = 'liftToEncoding2
2375+jsonFunValName ParseJSON Arity0 = 'parseJSON
2376+jsonFunValName ParseJSON Arity1 = 'liftParseJSON
2377+jsonFunValName ParseJSON Arity2 = 'liftParseJSON2
2378+
2379+jsonFunListName :: JSONFun -> Arity -> Name
2380+jsonFunListName ToJSON Arity0 = 'toJSONList
2381+jsonFunListName ToJSON Arity1 = 'liftToJSONList
2382+jsonFunListName ToJSON Arity2 = 'liftToJSONList2
2383+jsonFunListName ToEncoding Arity0 = 'toEncodingList
2384+jsonFunListName ToEncoding Arity1 = 'liftToEncodingList
2385+jsonFunListName ToEncoding Arity2 = 'liftToEncodingList2
2386+jsonFunListName ParseJSON Arity0 = 'parseJSONList
2387+jsonFunListName ParseJSON Arity1 = 'liftParseJSONList
2388+jsonFunListName ParseJSON Arity2 = 'liftParseJSONList2
2389+
2390+jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False
2391+ -> JSONFun -> Arity -> Name
2392+jsonFunValOrListName False = jsonFunValName
2393+jsonFunValOrListName True = jsonFunListName
2394+
2395+arityInt :: JSONClass -> Int
2396+arityInt = fromEnum . arity
2397+
2398+allowExQuant :: JSONClass -> Bool
2399+allowExQuant (JSONClass To _) = True
2400+allowExQuant _ = False
2401+
2402+-------------------------------------------------------------------------------
2403+-- StarKindStatus
2404+-------------------------------------------------------------------------------
2405+
2406+-- | Whether a type is not of kind *, is of kind *, or is a kind variable.
2407+data StarKindStatus = NotKindStar
2408+ | KindStar
2409+ | IsKindVar Name
2410+ deriving Eq
2411+
2412+-- | Does a Type have kind * or k (for some kind variable k)?
2413+canRealizeKindStar :: Type -> StarKindStatus
2414+canRealizeKindStar t
2415+ | hasKindStar t = KindStar
2416+ | otherwise = case t of
2417+#if MIN_VERSION_template_haskell(2,8,0)
2418+ SigT _ (VarT k) -> IsKindVar k
2419+#endif
2420+ _ -> NotKindStar
2421+
2422+-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
2423+-- Otherwise, returns 'Nothing'.
2424+starKindStatusToName :: StarKindStatus -> Maybe Name
2425+starKindStatusToName (IsKindVar n) = Just n
2426+starKindStatusToName _ = Nothing
2427+
2428+-- | Concat together all of the StarKindStatuses that are IsKindVar and extract
2429+-- the kind variables' Names out.
2430+catKindVarNames :: [StarKindStatus] -> [Name]
2431+catKindVarNames = mapMaybe starKindStatusToName